' Changelog:\r
' 2001, Initial version\r
' 2024 - 2025, Improved program readability\r
+' 2026, Improved program readability\r
\r
\r
DECLARE SUB displaySlide1 ()\r
-DECLARE SUB setink (a!)\r
-DECLARE SUB inke (a$)\r
-DECLARE SUB mkjuku (x!, y!, a!, c!)\r
-DECLARE SUB pr (x!, y!, s!, c!, n!, a$)\r
-DECLARE SUB wpr ()\r
+DECLARE SUB setIdleTimeout (seconds!)\r
+DECLARE SUB pollKey (key$)\r
+DECLARE SUB drawBoy (x!, y!, phaseIndex!, shade!)\r
+DECLARE SUB printNthChar (x!, y!, scale!, shade!, charIndex!, text$)\r
+DECLARE SUB updateReveal ()\r
DECLARE SUB displayEffect7 ()\r
DECLARE SUB displaySlide6 ()\r
DECLARE SUB displaySlide5 ()\r
-DECLARE SUB pal4 (c, r!, g!, b!)\r
+DECLARE SUB setPaletteColor (paletteIndex, r!, g!, b!)\r
DECLARE SUB displaySlide4 ()\r
-DECLARE SUB inpur ()\r
+DECLARE SUB waitKeypress ()\r
DECLARE SUB displayEffect5 ()\r
DECLARE SUB displaySlide3 ()\r
-DECLARE SUB prin (x1!, y1!, s!, c, a$)\r
-DECLARE SUB pal3 (r!, g!, b!)\r
-DECLARE SUB mkfont ()\r
-DECLARE SUB pal2 (r!, g!, b!)\r
-DECLARE SUB box1 (x1!, y1!, x2!, y2!, c!)\r
-DECLARE SUB mkback ()\r
+DECLARE SUB printText (xPos!, yPos!, scale!, shade, text$)\r
+DECLARE SUB setBoxPalette2 (red!, green!, blue!)\r
+DECLARE SUB makeFont ()\r
+DECLARE SUB setBoxPalette1 (red!, green!, blue!)\r
+DECLARE SUB drawShadedBox (x1!, y1!, x2!, y2!, shadeType!)\r
+DECLARE SUB makeBackground ()\r
DECLARE SUB displaySlide2 ()\r
-DECLARE SUB resiz ()\r
-DECLARE SUB pri (x!, y!, a$, c!)\r
-DECLARE SUB deca (xs!, ys!, fx!, fy!)\r
-DECLARE SUB box (xs!, ys!)\r
+DECLARE SUB splitTransition ()\r
+DECLARE SUB printTypewriter (x!, y!, text$, shade!)\r
+DECLARE SUB shrinkBox (sizeX!, sizeY!, shrinkX!, shrinkY!)\r
+DECLARE SUB box (sizeX!, sizeY!)\r
DECLARE SUB displayEffect4 ()\r
DECLARE SUB displayEffect3 ()\r
DECLARE SUB displayEffect2 ()\r
DECLARE SUB displayEffect1 ()\r
DECLARE SUB start ()\r
-DECLARE SUB sc1 ()\r
-DECLARE SUB pal (x!)\r
-DIM SHARED fontt(0 TO 7, 0 TO 7, 0 TO 255)\r
-DIM SHARED tim\r
-DIM SHARED tim2\r
-DIM SHARED jas(1 TO 500)\r
-DIM SHARED pii\r
-DIM SHARED tmr\r
-DIM SHARED ink\r
-DIM SHARED tim$\r
+DECLARE SUB sc1 () ' leftover declaration; the routine was never implemented\r
+DECLARE SUB setPalette (scheme!)\r
+DIM SHARED fontBitmap(0 TO 7, 0 TO 7, 0 TO 255)\r
+DIM SHARED revealCounter\r
+DIM SHARED revealStage\r
+DIM SHARED animPhase(1 TO 500)\r
+DIM SHARED piValue\r
+DIM SHARED autoAdvance\r
+DIM SHARED idleCountdown\r
+DIM SHARED lastTime$\r
\r
start\r
\r
\r
SYSTEM\r
\r
-SUB box (xs, ys)\r
+SUB box (sizeX, sizeY)\r
' Draws a 3D style box border at the top-left corner of the screen\r
' Parameters:\r
-' xs - width of the box\r
-' ys - height of the box\r
+' sizeX - width of the box\r
+' sizeY - height of the box\r
\r
-LINE (0, 186)-(0 + xs, 186 - ys), 15, B\r
-LINE (1, 187)-(-1 + xs, 187 - ys), 25, B\r
-LINE (2, 188)-(-2 + xs, 188 - ys), 15, B\r
+LINE (0, 186)-(0 + sizeX, 186 - sizeY), 15, B\r
+LINE (1, 187)-(-1 + sizeX, 187 - sizeY), 25, B\r
+LINE (2, 188)-(-2 + sizeX, 188 - sizeY), 15, B\r
PSET (0, 188), 0\r
-PSET (0 + xs, 188), 0\r
-PSET (0, 186 - ys), 0\r
-PSET (0 + xs, 186 - ys), 0\r
+PSET (0 + sizeX, 188), 0\r
+PSET (0, 186 - sizeY), 0\r
+PSET (0 + sizeX, 186 - sizeY), 0\r
END SUB\r
\r
DEFINT Z\r
-SUB box1 (x1, y1, x2, y2, c)\r
+SUB drawShadedBox (x1, y1, x2, y2, shadeType)\r
\r
' Draws a shaded box with a 3D effect\r
' Parameters:\r
' x1, y1 - top-left corner coordinates\r
' x2, y2 - bottom-right corner coordinates\r
-' c - type of shading\r
+' shadeType - type of shading\r
\r
-IF c = 1 THEN za = 51 ELSE za = 102\r
+IF shadeType = 1 THEN za = 51 ELSE za = 102\r
\r
FOR zy = y1 + 7 TO y2 + 7\r
FOR zx = x1 + 7 TO x2 + 7\r
END SUB\r
\r
DEFSNG Z\r
-SUB deca (xs, ys, fx, fy)\r
-LINE (0, 185 - ys)-(xs, 185 - ys + fy), 0, BF\r
-LINE (xs, 18 - ys)-(xs - fx, 188), 0, BF\r
-xs = xs - fx\r
-ys = ys - fy\r
-box xs, ys\r
+SUB shrinkBox (sizeX, sizeY, shrinkX, shrinkY)\r
+' Erodes the border box inward by shrinkX/shrinkY pixels and redraws it smaller\r
+LINE (0, 185 - sizeY)-(sizeX, 185 - sizeY + shrinkY), 0, BF\r
+LINE (sizeX, 18 - sizeY)-(sizeX - shrinkX, 188), 0, BF\r
+sizeX = sizeX - shrinkX\r
+sizeY = sizeY - shrinkY\r
+box sizeX, sizeY\r
END SUB\r
\r
SUB displayEffect1\r
+' Effect 1: scrolling color bands, sine-wave line and walking boy figures; waits for keypress\r
\r
-pal 3\r
+setPalette 3\r
\r
DIM buf1(1 TO 10000)\r
DIM buf2(1 TO 10000)\r
\r
b = 0\r
c1 = 1\r
-setink 10\r
+setIdleTimeout 10\r
1\r
c1 = c1 + 1\r
IF c1 > 50 THEN c1 = 1\r
FOR x = 65 + 18 TO 270 STEP 40\r
a = a + 1\r
IF buf3(x - 1) < 190 THEN\r
-mkjuku x, buf3(x - 1) - 27, x, 0\r
-mkjuku x, buf3(x) - 27, x, a\r
+drawBoy x, buf3(x - 1) - 27, x, 0\r
+drawBoy x, buf3(x) - 27, x, a\r
END IF\r
NEXT x\r
\r
-inke a$\r
-SOUND 0, .4\r
+pollKey a$\r
+SOUND 0, .4 ' sub-second delay workaround (inaudible 0 Hz sound)\r
IF a$ = "" THEN GOTO 1\r
\r
END SUB\r
\r
SUB displayEffect2\r
+' Effect 2: palette fade transition (ramps palette brightness down, then up)\r
\r
FOR a = 1 TO 30\r
e = 0\r
NEXT f\r
\r
FOR b = 1 TO 3\r
-SOUND 0, .3\r
+SOUND 0, .3 ' sub-second delay workaround (inaudible 0 Hz sound)\r
NEXT b\r
NEXT a\r
\r
NEXT f\r
\r
FOR b = 1 TO 2\r
-SOUND 0, .3\r
+SOUND 0, .3 ' sub-second delay workaround (inaudible 0 Hz sound)\r
NEXT b\r
\r
NEXT a\r
END SUB\r
\r
SUB displayEffect3\r
+' Effect 3: accelerating line-burst zoom on screen 7, then authors roll on screen 13\r
SCREEN 7\r
SCREEN 7, , , 1\r
\r
\r
PCOPY 0, 1\r
CLS\r
-SOUND 0, .4\r
+SOUND 0, .4 ' sub-second delay workaround (inaudible 0 Hz sound)\r
IF b < 50 THEN GOTO 2\r
\r
SCREEN 13\r
-pal 2\r
+setPalette 2\r
\r
FOR a = 0 TO 160 STEP b\r
LINE (160 + a, 0)-(160 + a, 199), 25\r
LINE (0, 100 - a)-(319, 100 - a), 25\r
NEXT a\r
\r
-resiz\r
-pal 3\r
+splitTransition\r
+setPalette 3\r
\r
-pri 11, 8, "-* A U T H O R S *-", 55\r
-pri 10, 11, CHR$(254) + " John Doe", 55\r
-pri 10, 13, CHR$(254) + " Jane Doe", 55\r
-pri 10, 15, CHR$(254) + " Anonymous", 55\r
-pri 20, 19, "year 2001", 55\r
+printTypewriter 11, 8, "-* A U T H O R S *-", 55\r
+printTypewriter 10, 11, CHR$(254) + " John Doe", 55\r
+printTypewriter 10, 13, CHR$(254) + " Jane Doe", 55\r
+printTypewriter 10, 15, CHR$(254) + " Anonymous", 55\r
+printTypewriter 20, 19, "year 2001", 55\r
\r
-inpur\r
+waitKeypress\r
CLS\r
END SUB\r
\r
SUB displayEffect4\r
-pal 2\r
+' Effect 4: border box erodes while random characters scroll up and text lines appear; waits for keypress\r
+setPalette 2\r
xs = 317\r
ys = 185\r
box xs, ys\r
-tey = 20\r
+textY = 20\r
\r
DIM buf4(1 TO 10000)\r
\r
b = 0\r
-setink 10\r
+setIdleTimeout 10\r
COLOR 25\r
4\r
b = b + 1\r
\r
SELECT CASE b\r
CASE 50 TO 200\r
-deca xs, ys, 1, 1\r
+shrinkBox xs, ys, 1, 1\r
\r
CASE 201\r
-'pal4 255, 63, 45, 0\r
-'prin 10, tey, 2, 255, "Sources:"\r
-tey = tey + 20\r
+'setPaletteColor 255, 63, 45, 0\r
+'printText 10, textY, 2, 255, "Sources:"\r
+textY = textY + 20\r
\r
CASE 290\r
-pal4 254, 20, 20, 63\r
-prin 70, tey, 7, 254, "TEST"\r
-tey = tey + 60\r
+setPaletteColor 254, 20, 20, 63\r
+printText 70, textY, 7, 254, "TEST"\r
+textY = textY + 60\r
\r
CASE 350\r
-pal4 254, 20, 20, 63\r
-prin 100, tey, 2, 254, "www.12345.com"\r
-tey = tey + 20\r
+setPaletteColor 254, 20, 20, 63\r
+printText 100, textY, 2, 254, "www.12345.com"\r
+textY = textY + 20\r
\r
CASE 400\r
-pal4 254, 20, 20, 63\r
-prin 100, tey, 2, 254, CHR$(16) + "Subject 1"\r
-tey = tey + 10\r
+setPaletteColor 254, 20, 20, 63\r
+printText 100, textY, 2, 254, CHR$(16) + "Subject 1"\r
+textY = textY + 10\r
\r
END SELECT\r
\r
PUT (x, 183 - ys + 6), buf4(1), PSET\r
NEXT x\r
\r
-inke a$\r
+pollKey a$\r
\r
IF a$ <> "" THEN GOTO 3\r
-wpr\r
+updateReveal\r
GOTO 4\r
\r
3\r
END SUB\r
\r
SUB displayEffect5\r
+' Effect 5: random screen blocks drift, then the screen wipes to black\r
DIM buf(1 TO 5000)\r
\r
FOR a = 1 TO 1000\r
IF RND * 100 < 50 THEN x = x + 1 ELSE x = x - 1\r
IF RND * 100 < 50 THEN y = y + 1\r
PUT (x, y), buf(1), PSET\r
-SOUND 0, .05\r
+SOUND 0, .05 ' sub-second delay workaround (inaudible 0 Hz sound)\r
NEXT a\r
\r
FOR a = 0 TO 100\r
LINE (0, a)-(319, a), 0\r
LINE (0, 200 - a)-(319, 200 - a), 0\r
-SOUND 0, .4\r
+SOUND 0, .4 ' sub-second delay workaround (inaudible 0 Hz sound)\r
NEXT a\r
\r
END SUB\r
\r
SUB displayEffect7\r
-pal 4\r
-mkback\r
+' Effect 7: sample content slide with header box and bullet list\r
+setPalette 4\r
+makeBackground\r
\r
-pal2 0, 0, 32\r
-box1 3, 3, 300, 50, 1\r
+setBoxPalette1 0, 0, 32\r
+drawShadedBox 3, 3, 300, 50, 1\r
\r
-pal4 255, 50, 50, 0\r
-prin 10, 10, 2, 255, "Et dolore magna"\r
-prin 50, 30, 1, 255, "www.utenimadminim.org"\r
+setPaletteColor 255, 50, 50, 0\r
+printText 10, 10, 2, 255, "Et dolore magna"\r
+printText 50, 30, 1, 255, "www.utenimadminim.org"\r
\r
-pal3 20, 32, 63\r
-box1 20, 40, 290, 180, 2\r
+setBoxPalette2 20, 32, 63\r
+drawShadedBox 20, 40, 290, 180, 2\r
\r
-pal4 254, 63, 45, 0\r
+setPaletteColor 254, 63, 45, 0\r
b = 25\r
-prin 40, 60, 1, 254, CHR$(254) + " Ut enim ad minim veniam"\r
+printText 40, 60, 1, 254, CHR$(254) + " Ut enim ad minim veniam"\r
a = b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " Quis nostrud exercitation"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " Quis nostrud exercitation"\r
a = a + b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " Laboris nisi ut aliquip ex"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " Laboris nisi ut aliquip ex"\r
a = a + b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " Sed ut perspiciatis unde"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " Sed ut perspiciatis unde"\r
\r
-inpur\r
+waitKeypress\r
\r
END SUB\r
\r
SUB displaySlide1\r
+' Slide 1: pixelates the "HEADER" title onto the screen, then blurs it in four passes\r
\r
-pal 2\r
+setPalette 2\r
LOCATE 1, 1\r
COLOR 1\r
PRINT "HEADER"\r
END SUB\r
\r
SUB displaySlide2\r
+' Slide 2: "Goal:" text layout test slide\r
\r
CLS\r
-pal 4\r
-mkback\r
+setPalette 4\r
+makeBackground\r
\r
-pal2 40, 64, 63\r
-pal3 0, 0, 0\r
+setBoxPalette1 40, 64, 63\r
+setBoxPalette2 0, 0, 0\r
\r
-box1 30, 30, 290, 170, 1\r
+drawShadedBox 30, 30, 290, 170, 1\r
\r
-prin 65, 50, 3, 0, "Goal:"\r
+printText 65, 50, 3, 0, "Goal:"\r
\r
-prin 40, 100, 1, 0, CHR$(254) + " Random text"\r
-prin 40, 108, 1, 0, " goes here to test"\r
-prin 40, 116, 1, 0, " text layout."\r
-prin 40, 130, 1, 0, CHR$(254) + " Testing 123."\r
+printText 40, 100, 1, 0, CHR$(254) + " Random text"\r
+printText 40, 108, 1, 0, " goes here to test"\r
+printText 40, 116, 1, 0, " text layout."\r
+printText 40, 130, 1, 0, CHR$(254) + " Testing 123."\r
\r
-inpur\r
+waitKeypress\r
\r
END SUB\r
\r
SUB displaySlide3\r
-mkback\r
+' Slide 3: closing "Thank you for attention" slide\r
+makeBackground\r
\r
-pal2 64, 64, 0\r
-box1 30, 30, 290, 150, 1\r
+setBoxPalette1 64, 64, 0\r
+drawShadedBox 30, 30, 290, 150, 1\r
\r
-prin 57, 50, 3, 0, "Thank you"\r
-prin 45, 74, 3, 0, " for"\r
-prin 45, 98, 3, 0, "attention"\r
-inpur\r
+printText 57, 50, 3, 0, "Thank you"\r
+printText 45, 74, 3, 0, " for"\r
+printText 45, 98, 3, 0, "attention"\r
+waitKeypress\r
\r
END SUB\r
\r
SUB displaySlide4\r
+' Slide 4: sample content slide with header box and bullet list\r
\r
-pal 4\r
-mkback\r
+setPalette 4\r
+makeBackground\r
\r
-pal2 0, 0, 32\r
-box1 3, 3, 260, 50, 1\r
+setBoxPalette1 0, 0, 32\r
+drawShadedBox 3, 3, 260, 50, 1\r
\r
-pal4 255, 50, 50, 0\r
-prin 10, 10, 2, 255, "Random header"\r
-prin 50, 30, 1, 255, "www.randomsite.org"\r
+setPaletteColor 255, 50, 50, 0\r
+printText 10, 10, 2, 255, "Random header"\r
+printText 50, 30, 1, 255, "www.randomsite.org"\r
\r
-pal3 10, 20, 0\r
-box1 20, 40, 290, 180, 2\r
+setBoxPalette2 10, 20, 0\r
+drawShadedBox 20, 40, 290, 180, 2\r
\r
-pal4 254, 63, 45, 0\r
+setPaletteColor 254, 63, 45, 0\r
\r
b = 25\r
-prin 40, 60, 1, 254, CHR$(254) + " Lorem ipsum dolor sit amet,"\r
+printText 40, 60, 1, 254, CHR$(254) + " Lorem ipsum dolor sit amet,"\r
a = b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " consectetur adipiscing elit,"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " consectetur adipiscing elit,"\r
a = a + b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " sed do eiusmod"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " sed do eiusmod"\r
a = a + b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " tempor incididunt ut labore"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " tempor incididunt ut labore"\r
\r
-inpur\r
+waitKeypress\r
\r
END SUB\r
\r
SUB displaySlide5\r
-pal 4\r
-mkback\r
+' Slide 5: sample content slide with header box and bullet list\r
+setPalette 4\r
+makeBackground\r
\r
-pal2 0, 0, 32\r
-box1 3, 3, 300, 50, 1\r
+setBoxPalette1 0, 0, 32\r
+drawShadedBox 3, 3, 300, 50, 1\r
\r
-pal4 255, 50, 50, 0\r
-prin 10, 10, 2, 255, "Totam rem aperiam"\r
-prin 50, 30, 1, 255, "www.randomurl.org"\r
+setPaletteColor 255, 50, 50, 0\r
+printText 10, 10, 2, 255, "Totam rem aperiam"\r
+printText 50, 30, 1, 255, "www.randomurl.org"\r
\r
-pal3 20, 32, 63\r
-box1 20, 40, 290, 180, 2\r
+setBoxPalette2 20, 32, 63\r
+drawShadedBox 20, 40, 290, 180, 2\r
\r
-pal4 254, 63, 45, 0\r
+setPaletteColor 254, 63, 45, 0\r
b = 25\r
-prin 40, 60, 1, 254, CHR$(254) + " Nemo enim ipsam voluptatem"\r
+printText 40, 60, 1, 254, CHR$(254) + " Nemo enim ipsam voluptatem"\r
a = b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " Sed quia consequuntur"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " Sed quia consequuntur"\r
a = a + b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " Magni dolores eos"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " Magni dolores eos"\r
a = a + b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " Qui ratione voluptatem"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " Qui ratione voluptatem"\r
\r
-inpur\r
+waitKeypress\r
\r
END SUB\r
\r
SUB displaySlide6\r
-pal 4\r
-mkback\r
+' Slide 6: sample content slide with header box and bullet list\r
+setPalette 4\r
+makeBackground\r
\r
-pal2 0, 0, 32\r
-box1 3, 3, 300, 50, 1\r
+setBoxPalette1 0, 0, 32\r
+drawShadedBox 3, 3, 300, 50, 1\r
\r
-pal4 255, 50, 50, 0\r
-prin 10, 10, 2, 255, "H E L L O !"\r
-prin 50, 30, 1, 255, "www.hello.net"\r
+setPaletteColor 255, 50, 50, 0\r
+printText 10, 10, 2, 255, "H E L L O !"\r
+printText 50, 30, 1, 255, "www.hello.net"\r
\r
-pal3 30, 20, 10\r
-box1 20, 40, 290, 180, 2\r
+setBoxPalette2 30, 20, 10\r
+drawShadedBox 20, 40, 290, 180, 2\r
\r
-pal4 254, 63, 45, 0\r
+setPaletteColor 254, 63, 45, 0\r
b = 25\r
-prin 40, 60, 1, 254, CHR$(254) + " Quis autem vel eum"\r
+printText 40, 60, 1, 254, CHR$(254) + " Quis autem vel eum"\r
a = b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " Iure reprehenderit qui"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " Iure reprehenderit qui"\r
a = a + b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " In ea voluptate velit"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " In ea voluptate velit"\r
a = a + b\r
-prin 40, 60 + a, 1, 254, CHR$(254) + " Esse quam nihil molestiae"\r
+printText 40, 60 + a, 1, 254, CHR$(254) + " Esse quam nihil molestiae"\r
\r
-inpur\r
+waitKeypress\r
\r
END SUB\r
\r
-SUB inke (a$)\r
-IF tim$ <> TIME$ THEN\r
-ink = ink - 1\r
-tim$ = TIME$\r
+SUB pollKey (key$)\r
+' Returns key$ = " " when a key was pressed (or the idle timer ran out in timer mode), "" otherwise\r
+IF lastTime$ <> TIME$ THEN\r
+idleCountdown = idleCountdown - 1\r
+lastTime$ = TIME$\r
END IF\r
-IF (ink <= 0) AND (tmr = 1) THEN a$ = " " ELSE a$ = ""\r
-IF INKEY$ <> "" THEN a$ = " "\r
+IF (idleCountdown <= 0) AND (autoAdvance = 1) THEN key$ = " " ELSE key$ = ""\r
+IF INKEY$ <> "" THEN key$ = " "\r
END SUB\r
\r
-SUB inpur\r
-setink 10\r
+SUB waitKeypress\r
+' Waits until a key is pressed (or the idle auto-advance timer expires)\r
+setIdleTimeout 10\r
11\r
-inke a$\r
+pollKey a$\r
IF a$ = "" THEN GOTO 11\r
END SUB\r
\r
DEFINT A-Z\r
-SUB mkback\r
+SUB makeBackground\r
+' Generates a random plasma-style background via recursive midpoint displacement\r
CLS\r
-lm1 = 0\r
-lm2 = 50\r
+shadeMin = 0\r
+shadeMax = 50\r
\r
-s = 2 ^ 7\r
+cellSize = 2 ^ 7\r
\r
7\r
-s = s \ 2\r
+cellSize = cellSize \ 2\r
\r
-FOR y = 0 TO 199 STEP s\r
-FOR x = 0 TO 319 STEP s\r
+FOR y = 0 TO 199 STEP cellSize\r
+FOR x = 0 TO 319 STEP cellSize\r
\r
c1 = POINT(x, y)\r
-c2 = POINT(x + s, y)\r
-c3 = POINT(x, y + s)\r
-c4 = POINT(x + s, y + s)\r
+c2 = POINT(x + cellSize, y)\r
+c3 = POINT(x, y + cellSize)\r
+c4 = POINT(x + cellSize, y + cellSize)\r
\r
-sp = s \ 2\r
+halfCell = cellSize \ 2\r
\r
-c5 = (c1 + c2 + c3 + c4) / 4 + RND * s - sp\r
-IF c5 > lm2 THEN c5 = lm2\r
-IF c5 < lm1 THEN c5 = lm1\r
+c5 = (c1 + c2 + c3 + c4) / 4 + RND * cellSize - halfCell\r
+IF c5 > shadeMax THEN c5 = shadeMax\r
+IF c5 < shadeMin THEN c5 = shadeMin\r
\r
-c6 = (c2 + c4) / 2 + RND * s - sp\r
-IF c6 > lm2 THEN c6 = lm2\r
-IF c6 < lm1 THEN c6 = lm1\r
+c6 = (c2 + c4) / 2 + RND * cellSize - halfCell\r
+IF c6 > shadeMax THEN c6 = shadeMax\r
+IF c6 < shadeMin THEN c6 = shadeMin\r
\r
-c7 = (c3 + c4) / 2 + RND * s - sp\r
-IF c7 > lm2 THEN c7 = lm2\r
-IF c7 < lm1 THEN c7 = lm1\r
+c7 = (c3 + c4) / 2 + RND * cellSize - halfCell\r
+IF c7 > shadeMax THEN c7 = shadeMax\r
+IF c7 < shadeMin THEN c7 = shadeMin\r
\r
IF INT(RND * 30) = 2 THEN c5 = 50\r
-PSET (x + sp, y + sp), c5\r
-PSET (x + s, y + sp), c6\r
-PSET (x + sp, y + s), c7\r
+PSET (x + halfCell, y + halfCell), c5\r
+PSET (x + cellSize, y + halfCell), c6\r
+PSET (x + halfCell, y + cellSize), c7\r
\r
NEXT x\r
NEXT y\r
-IF s > 2 THEN GOTO 7\r
+IF cellSize > 2 THEN GOTO 7\r
END SUB\r
\r
DEFSNG A-Z\r
-SUB mkfont\r
+SUB makeFont\r
+' Captures the ROM 8x8 pixel patterns of all 256 characters into the fontBitmap array\r
SCREEN 13\r
FOR a = 0 TO 255\r
LOCATE 1, 1\r
\r
FOR y = 0 TO 7\r
FOR x = 0 TO 7\r
-fontt(x, y, a) = POINT(x, y)\r
+fontBitmap(x, y, a) = POINT(x, y)\r
NEXT x\r
NEXT y\r
NEXT a\r
\r
END SUB\r
\r
-SUB mkjuku (x, y, a, c)\r
-jas(a) = jas(a) + .08\r
-IF jas(a) > 30000 THEN jas(a) = 0\r
-b = jas(a)\r
-IF c = 0 THEN b = jas(a) - .08\r
-x1 = x + COS(b) * 10\r
-y1 = y + SIN(b) * 5 + 20\r
+SUB drawBoy (x, y, phaseIndex, shade)\r
+' Draws an animated stick-figure boy ("Juku") with legs, arms and head at x, y; shade 0 erases\r
+animPhase(phaseIndex) = animPhase(phaseIndex) + .08\r
+IF animPhase(phaseIndex) > 30000 THEN animPhase(phaseIndex) = 0\r
+angle = animPhase(phaseIndex)\r
+IF shade = 0 THEN angle = animPhase(phaseIndex) - .08\r
+x1 = x + COS(angle) * 10\r
+y1 = y + SIN(angle) * 5 + 20\r
\r
-x2 = x + COS(b) * 5 + 2\r
-y2 = y + SIN(b) * 3 + 10\r
+x2 = x + COS(angle) * 5 + 2\r
+y2 = y + SIN(angle) * 3 + 10\r
\r
-x3 = x + COS(b + 1) * 2\r
-y3 = y + SIN(b + 1) * 2 + 2\r
+x3 = x + COS(angle + 1) * 2\r
+y3 = y + SIN(angle + 1) * 2 + 2\r
\r
-LINE (x2, y2)-(x1, y1), c\r
-LINE (x2, y2)-(x3, y3), c\r
+LINE (x2, y2)-(x1, y1), shade\r
+LINE (x2, y2)-(x3, y3), shade\r
\r
-x1 = x + COS(b + pii) * 10\r
-y1 = y + SIN(b + pii) * 5 + 20\r
+x1 = x + COS(angle + piValue) * 10\r
+y1 = y + SIN(angle + piValue) * 5 + 20\r
\r
-x2 = x + COS(b + pii) * 5 + 2\r
-y2 = y + SIN(b + pii) * 3 + 10\r
+x2 = x + COS(angle + piValue) * 5 + 2\r
+y2 = y + SIN(angle + piValue) * 3 + 10\r
\r
-LINE (x2, y2)-(x1, y1), c\r
-LINE (x2, y2)-(x3, y3), c\r
+LINE (x2, y2)-(x1, y1), shade\r
+LINE (x2, y2)-(x3, y3), shade\r
\r
-x4 = x + COS(b + 1.2) * 3 - 1\r
-y4 = y + SIN(b + 1.2) * 1 - 10\r
+x4 = x + COS(angle + 1.2) * 3 - 1\r
+y4 = y + SIN(angle + 1.2) * 1 - 10\r
\r
-LINE (x4, y4)-(x3, y3), c\r
+LINE (x4, y4)-(x3, y3), shade\r
\r
-x5 = x + COS(b + .5) * 13 - 3\r
-y5 = y + SIN(b + .5) * 2 + 1\r
+x5 = x + COS(angle + .5) * 13 - 3\r
+y5 = y + SIN(angle + .5) * 2 + 1\r
\r
-x6 = x + COS(b + .5) * 15 - 1\r
-y6 = y + SIN(b + .5) * 3 + 4\r
+x6 = x + COS(angle + .5) * 15 - 1\r
+y6 = y + SIN(angle + .5) * 3 + 4\r
\r
-LINE (x5, y5)-(x4, y4), c\r
-LINE (x5, y5)-(x6, y6), c\r
+LINE (x5, y5)-(x4, y4), shade\r
+LINE (x5, y5)-(x6, y6), shade\r
\r
-x5 = x + COS(b + pii) * 13 - 3\r
-y5 = y + SIN(b + pii) * 2 + 1\r
+x5 = x + COS(angle + piValue) * 13 - 3\r
+y5 = y + SIN(angle + piValue) * 2 + 1\r
\r
-x6 = x + COS(b + pii) * 15 - 1\r
-y6 = y + SIN(b + pii) * 3 + 4\r
+x6 = x + COS(angle + piValue) * 15 - 1\r
+y6 = y + SIN(angle + piValue) * 3 + 4\r
\r
-LINE (x5, y5)-(x4, y4), c\r
-LINE (x5, y5)-(x6, y6), c\r
+LINE (x5, y5)-(x4, y4), shade\r
+LINE (x5, y5)-(x6, y6), shade\r
\r
-x7 = x + COS(b + 1.2) * 2\r
-y7 = y + SIN(b + 1.2) * 1 - 14\r
+x7 = x + COS(angle + 1.2) * 2\r
+y7 = y + SIN(angle + 1.2) * 1 - 14\r
\r
-LINE (x7, y7 + 2)-(x4, y4), c\r
+LINE (x7, y7 + 2)-(x4, y4), shade\r
\r
-CIRCLE (x7, y7), 3, c\r
+CIRCLE (x7, y7), 3, shade\r
\r
\r
\r
END SUB\r
\r
-SUB pal (x)\r
-SELECT CASE x\r
+SUB setPalette (scheme)\r
+' Loads one of four preset VGA palette schemes (1 = gray ramp, 2/4 = blue ramps, 3 = sine colors)\r
+SELECT CASE scheme\r
CASE 1\r
\r
FOR f = 0 TO 25\r
\r
END SUB\r
\r
-SUB pal2 (r, g, b)\r
+SUB setBoxPalette1 (red, green, blue)\r
+' Loads palette entries 51-101: shaded-box gradient (type 1) tinted toward the given base color\r
FOR f = 0 TO 25\r
OUT &H3C8, f + 51\r
-OUT &H3C9, (f * 2.5 + r * 1) / 2\r
-OUT &H3C9, (f * 2.5 + g * 1) / 2\r
-OUT &H3C9, (f * 1.5 + b * 1) / 2\r
+OUT &H3C9, (f * 2.5 + red * 1) / 2\r
+OUT &H3C9, (f * 2.5 + green * 1) / 2\r
+OUT &H3C9, (f * 1.5 + blue * 1) / 2\r
NEXT f\r
FOR f = 26 TO 50\r
OUT &H3C8, f + 51\r
-OUT &H3C9, ((50 - f) * 2.5 + r * 1) / 2\r
-OUT &H3C9, ((50 - f) * 2.5 + g * 1) / 2\r
-OUT &H3C9, ((50 - f) * 1.5 + b * 1) / 2\r
+OUT &H3C9, ((50 - f) * 2.5 + red * 1) / 2\r
+OUT &H3C9, ((50 - f) * 2.5 + green * 1) / 2\r
+OUT &H3C9, ((50 - f) * 1.5 + blue * 1) / 2\r
NEXT f\r
END SUB\r
\r
-SUB pal3 (r, g, b)\r
+SUB setBoxPalette2 (red, green, blue)\r
+' Loads palette entries 102-152: shaded-box gradient (type 2) tinted toward the given base color\r
FOR f = 0 TO 25\r
OUT &H3C8, f + 102\r
-OUT &H3C9, (f * 2.5 + r * 1) / 2\r
-OUT &H3C9, (f * 2.5 + g * 1) / 2\r
-OUT &H3C9, (f * 1.5 + b * 1) / 2\r
+OUT &H3C9, (f * 2.5 + red * 1) / 2\r
+OUT &H3C9, (f * 2.5 + green * 1) / 2\r
+OUT &H3C9, (f * 1.5 + blue * 1) / 2\r
NEXT f\r
FOR f = 26 TO 50\r
OUT &H3C8, f + 102\r
-OUT &H3C9, ((50 - f) * 2.5 + r * 1) / 2\r
-OUT &H3C9, ((50 - f) * 2.5 + g * 1) / 2\r
-OUT &H3C9, ((50 - f) * 1.5 + b * 1) / 2\r
+OUT &H3C9, ((50 - f) * 2.5 + red * 1) / 2\r
+OUT &H3C9, ((50 - f) * 2.5 + green * 1) / 2\r
+OUT &H3C9, ((50 - f) * 1.5 + blue * 1) / 2\r
NEXT f\r
END SUB\r
\r
-SUB pal4 (c, r!, g!, b!)\r
-OUT &H3C8, c\r
+SUB setPaletteColor (paletteIndex, r!, g!, b!)\r
+' Sets one VGA palette entry to the given red/green/blue components (0-63)\r
+OUT &H3C8, paletteIndex\r
OUT &H3C9, r\r
OUT &H3C9, g\r
OUT &H3C9, b\r
END SUB\r
\r
-SUB pr (x, y, s, c, n, a$)\r
-IF n > LEN(a$) THEN GOTO 10\r
-a$ = RIGHT$(LEFT$(a$, n), 1)\r
-x1 = n * 8 * s + x\r
-prin x1, y, s, c, a$\r
+SUB printNthChar (x, y, scale, shade, charIndex, text$)\r
+' Prints only the charIndex-th character of text$ (used for gradual text reveal)\r
+IF charIndex > LEN(text$) THEN GOTO 10\r
+text$ = RIGHT$(LEFT$(text$, charIndex), 1)\r
+x1 = charIndex * 8 * scale + x\r
+printText x1, y, scale, shade, text$\r
10\r
END SUB\r
\r
-SUB pri (x, y, a$, c)\r
-COLOR c\r
-FOR a = 1 TO LEN(a$)\r
-b$ = RIGHT$(LEFT$(a$, a), 1)\r
+SUB printTypewriter (x, y, text$, shade)\r
+' Prints text$ character by character with a delay (typewriter effect)\r
+COLOR shade\r
+FOR a = 1 TO LEN(text$)\r
+b$ = RIGHT$(LEFT$(text$, a), 1)\r
LOCATE y, x + a\r
PRINT b$\r
-SOUND 0, 1\r
+SOUND 0, 1 ' sub-second delay workaround (inaudible 0 Hz sound)\r
NEXT a\r
\r
END SUB\r
\r
-SUB prin (x1, y1, s, c1, a$)\r
+SUB printText (xPos, yPos, scale, shade, text$)\r
+' Prints text$ at a pixel position using the captured bitmap font, scaled by 'scale', in palette shade\r
\r
-FOR a = 1 TO LEN(a$)\r
-b = ASC(RIGHT$(LEFT$(a$, a), 1))\r
-c = (a - 1) * 8 * s + x1\r
+FOR a = 1 TO LEN(text$)\r
+b = ASC(RIGHT$(LEFT$(text$, a), 1))\r
+c = (a - 1) * 8 * scale + xPos\r
FOR y = 0 TO 7\r
FOR x = 0 TO 7\r
-IF fontt(x, y, b) > 0 THEN\r
-LINE (x * s + c, y * s + y1)-(x * s + s - 1 + c, y * s + s - 1 + y1), c1, BF\r
+IF fontBitmap(x, y, b) > 0 THEN\r
+LINE (x * scale + c, y * scale + yPos)-(x * scale + scale - 1 + c, y * scale + scale - 1 + yPos), shade, BF\r
END IF\r
NEXT x\r
NEXT y\r
\r
END SUB\r
\r
-SUB resiz\r
+SUB splitTransition\r
+' Transition effect: expanding circle, then the screen splits apart horizontally and vertically\r
\r
FOR a = 1 TO 10\r
CIRCLE (160, 100), a, a * 2 + 5\r
PUT (159 - a, 90), buff1(1), PSET\r
PUT (150 + a, 90), buff2(1), PSET\r
a = a + 1\r
-SOUND 0, .2\r
+SOUND 0, .2 ' sub-second delay workaround (inaudible 0 Hz sound)\r
IF a < 140 THEN GOTO 5\r
\r
a = 1\r
PUT (20, 100 + a), buff2(1), PSET\r
\r
a = a + 1\r
-SOUND 0, .2\r
+SOUND 0, .2 ' sub-second delay workaround (inaudible 0 Hz sound)\r
IF a < 60 THEN GOTO 6\r
END SUB\r
\r
-SUB setink (a!)\r
-ink = a\r
-tim$ = TIME$\r
+SUB setIdleTimeout (seconds!)\r
+' Sets the idle countdown (in seconds) before auto-advance and stamps the current time\r
+idleCountdown = seconds\r
+lastTime$ = TIME$\r
END SUB\r
\r
SUB start\r
+' Initializes screen, font, random animation phases and the optional auto-advance timer mode\r
SCREEN 13\r
RANDOMIZE TIMER\r
\r
-mkfont\r
-tim = 0\r
-tim2 = 0\r
+makeFont\r
+revealCounter = 0\r
+revealStage = 0\r
\r
FOR a = 1 TO 500\r
-jas(a) = RND * 10\r
+animPhase(a) = RND * 10\r
NEXT a\r
\r
-pii = 3.14\r
+piValue = 3.14\r
IF COMMAND$ = "t" OR COMMAND$ = "T" THEN\r
-tmr = 1\r
+autoAdvance = 1\r
PRINT "timer is on"\r
SLEEP 1\r
ELSE\r
-tmr = 0\r
+autoAdvance = 0\r
END IF\r
END SUB\r
\r
-SUB wpr\r
-tim = tim + 1\r
-IF tim \ 10 = tim / 10 THEN\r
-a = tim / 10\r
-SELECT CASE tim2\r
+SUB updateReveal\r
+' Counts effect ticks and reveals the next character of the "Sources:" text every 10 ticks\r
+revealCounter = revealCounter + 1\r
+IF revealCounter \ 10 = revealCounter / 10 THEN\r
+a = revealCounter / 10\r
+SELECT CASE revealStage\r
CASE 0\r
-IF a = 10 THEN tim2 = 1: tim = 0: pal4 255, 63, 45, 0\r
+IF a = 10 THEN revealStage = 1: revealCounter = 0: setPaletteColor 255, 63, 45, 0\r
CASE 1\r
-pr 10, 10, 2, 255, a, "Sources:"\r
+printNthChar 10, 10, 2, 255, a, "Sources:"\r
\r
END SELECT\r
END IF\r
' Changelog:
' 2003, Initial version.
' 2024, Improved program readability.
+' 2026, Improved program readability.
'
' User can navigate through the galaxy using mouse or keyboard controls.
'
' - Use keyboard keys 'a', 'd', 'w', 's' to move in X and Z axis.
' - Press 'q' to quit the program.
+' temp: leftover declaration of a long-gone helper; the SUB no longer exists.
DECLARE SUB temp ()
DECLARE SUB mkGalaxy (x!, y!, z!)
DECLARE SUB rndInit ()
-DECLARE FUNCTION rn! ()
-DECLARE SUB disp ()
+DECLARE FUNCTION nextRandom! ()
+DECLARE SUB drawGalaxy ()
DECLARE SUB control ()
DECLARE SUB putByte (addr!, dat!)
DECLARE SUB putWord (addr!, dat!)
numPoints = 0
mkGalaxy 0, 0, 0
+' Main loop: steer the camera, redraw the galaxy, flip the page.
1
-' Generate a random angle for initial camera position
-variableAngle = INT(RND * 3)
+' Harmless leftover: each frame one of currentX/Y/Z gets a random offset,
+' but these variables are never read anywhere.
+startAxis = INT(RND * 3)
-SELECT CASE variableAngle
+SELECT CASE startAxis
CASE 0
currentX = RND * 500 - 250
CASE 1
END SELECT
control
-disp
+drawGalaxy
+' Show the freshly drawn frame (page 0 -> visible page 1), then clear page 0.
PCOPY 0, 1
CLS
GOTO 1
SUB control
+' Read the TSR mouse driver and WASD keys; accelerate/decelerate the camera.
' Read mouse input from the driver, resetting its counters every frame
xPosition = getWord(2)
END SUB
-SUB disp
+SUB drawGalaxy
+' Rotate every star by the camera angles, perspective-project and plot it.
' Calculate sine and cosine values for rotation angles
sinAngle1 = SIN(angle1)
END SUB
FUNCTION getByte (address)
+' Read one byte from the TSR driver memory.
getByte = PEEK(externalAddress + address)
END FUNCTION
FUNCTION getWord (address)
+' Read one 16-bit little-endian word from the TSR driver memory.
firstByte = PEEK(externalAddress + address)
secondByte = PEEK(externalAddress + address + 1)
END FUNCTION
SUB mkGalaxy (localX, localY, localZ)
+' Generate the spiral galaxy point cloud centered at (localX, localY, localZ).
' Generate random angles for stars within galaxy
-randomAngle1 = rn * 10
-randomAngle2 = rn * 10
+randomAngle1 = nextRandom * 10
+randomAngle2 = nextRandom * 10
galaxySin1 = SIN(randomAngle1)
galaxyCos1 = COS(randomAngle1)
FOR pointIndex = 1 TO 10000
' Generate a random star distance from the center
- randomVariable = rn * 10
+ randomVariable = nextRandom * 10
distanceFromCenter = randomVariable * randomVariable / 30
' Calculate spiral offset and half of it
- spiralOffset = rn * (11.5 - randomVariable) / 3
+ spiralOffset = nextRandom * (11.5 - randomVariable) / 3
halfSpiralOffset = spiralOffset / 2
' Generate angle exponent and spiral bar angle
- angleExponent = rn * (distanceFromCenter / 2) / spiralBarsMultiplier * 2
- spiralBarAngle = 2 * piValue / spiralBarsMultiplier * INT(rn * spiralBarsMultiplier)
+ angleExponent = nextRandom * (distanceFromCenter / 2) / spiralBarsMultiplier * 2
+ spiralBarAngle = 2 * piValue / spiralBarsMultiplier * INT(nextRandom * spiralBarsMultiplier)
' Calculate x, z, and y coordinates
- xCoordinate = (SIN(randomVariable - spiralBarAngle + angleExponent) * distanceFromCenter + rn * spiralOffset - halfSpiralOffset) * size
- zCoordinate = (COS(randomVariable - spiralBarAngle + angleExponent) * distanceFromCenter + rn * spiralOffset - halfSpiralOffset) * size
- yCoordinate = (rn * spiralOffset - halfSpiralOffset) * size
+ xCoordinate = (SIN(randomVariable - spiralBarAngle + angleExponent) * distanceFromCenter + nextRandom * spiralOffset - halfSpiralOffset) * size
+ zCoordinate = (COS(randomVariable - spiralBarAngle + angleExponent) * distanceFromCenter + nextRandom * spiralOffset - halfSpiralOffset) * size
+ yCoordinate = (nextRandom * spiralOffset - halfSpiralOffset) * size
' Rotate the coordinates
rotatedX = xCoordinate * galaxyCos1 + zCoordinate * galaxySin1
END SUB
SUB putByte (address, dataByte)
+' Write one byte into the TSR driver memory.
POKE (externalAddress + address), dataByte
END SUB
SUB putWord (address, dataWord)
+' Write one 16-bit word into the TSR driver memory (little-endian).
' Convert the word to a hexadecimal string
hexValue$ = HEX$(dataWord)
END SUB
-FUNCTION rn
+FUNCTION nextRandom
+' Return the next value from the pre-generated random table.
' Increment the random pointer and get a new random value
randomPointer = randomPointer + 1
IF randomPointer > 10000 THEN randomPointer = 0
-rn = randomValue(randomPointer)
+nextRandom = randomValue(randomPointer)
END FUNCTION
SUB rndInit
+' Fill the random table with 10001 RND values.
' Initialize the array of random values
FOR index = 0 TO 10000
END SUB
SUB start
+' Set up graphics mode and initialize program state.
-starText
+initMouseDriver
' Set up graphics mode
SCREEN 7, , , 1
END SUB
-SUB starText
+SUB initMouseDriver
+' Locate the TSR mouse driver via the interrupt table and verify it.
' Read the segment and address from the interrupt table
DEF SEG = 0 ' read first from interrupt table
' Read the word at the specified address
DEF SEG = externalSegment
+' 1983 is the identification magic number of the qbext TSR driver.
IF getWord(0) <> 1983 THEN
PRINT "FATAL ERROR: you must load"
PRINT "QBasic extension TSR first!"
/ \r
/#m m#\r
/#m m#\r
-/#m m mmmm m m#\r
-/#m m m m m m#\r
-/#m m m m m m#\r
-/#m m m m m m#\r
+/#m m m m m#\r
+/#m m m m m#\r
+/#m m m m m#\r
+/#m m m m m#\r
/#m m mmmmmmmmm m m#\r
-/#m m m m m m#\r
-/#m m m m m m#\r
-/#m m m m m m#\r
-/#m m mmmm m m#\r
+/#m m m m m#\r
+/#m m m m m#\r
+/#m m m m m#\r
+/#m m m m m#\r
/#m m#\r
/#m m#\r
/ \r
' Changelog:\r
' 2002, Initial version\r
' 2024-2005, Improved program readability\r
-\r
-DECLARE FUNCTION cnum$ (a%)\r
-DECLARE SUB putworm (a%)\r
-DECLARE SUB level (a%)\r
-DECLARE SUB showb ()\r
-DECLARE SUB sc2 (x%, y%)\r
-DECLARE SUB ai (a%)\r
-DECLARE SUB autop (a%)\r
-DECLARE SUB prc (a%)\r
-DECLARE SUB dead (a%)\r
+' 2026, Improved program readability\r
+\r
+DECLARE FUNCTION numStr$ (value%)\r
+DECLARE SUB spawnWorm (playerNumber%)\r
+DECLARE SUB startLevel (levelNum%)\r
+DECLARE SUB showDistMap ()\r
+DECLARE SUB debugTrace (x%, y%)\r
+DECLARE SUB planPath (playerNumber%)\r
+DECLARE SUB autopilot (playerNumber%)\r
+DECLARE SUB advanceWorm (a%)\r
+DECLARE SUB handleDeath (playerNumber%)\r
DECLARE SUB add (a%)\r
-DECLARE SUB tkt ()\r
+DECLARE SUB gameTick ()\r
DECLARE SUB subt (b%)\r
-DECLARE SUB show ()\r
+DECLARE SUB drawArena ()\r
DECLARE SUB sc (x%, y%)\r
DEFINT A-Z\r
\r
' Shared arrays for the game grid and worms\r
-DIM SHARED buf(0 TO 36, 0 TO 36)\r
-DIM SHARED buf2(0 TO 36, 0 TO 36)\r
-DIM SHARED ussx(1 TO 2000, 1 TO 5)\r
-DIM SHARED ussy(1 TO 2000, 1 TO 5)\r
-DIM SHARED ussp(1 TO 5)\r
-DIM SHARED ussl(1 TO 5)\r
-DIM SHARED usss(1 TO 5)\r
-DIM SHARED ussk(1 TO 2000, 1 TO 5)\r
-DIM SHARED usskp(1 TO 5)\r
+DIM SHARED arena(0 TO 36, 0 TO 36) ' grid cell: 0=empty, 1=wall, 2=fruit, 10+worm\r
+DIM SHARED distMap(0 TO 36, 0 TO 36) ' AI distance field: 32000=unreached, -1=blocked, 0=fruit, else distance\r
+DIM SHARED trailX(1 TO 2000, 1 TO 5) ' ring buffer of worm body positions, X coordinate\r
+DIM SHARED trailY(1 TO 2000, 1 TO 5) ' ring buffer of worm body positions, Y coordinate\r
+DIM SHARED headPtr(1 TO 5) ' ring buffer index of the worm head\r
+DIM SHARED wormLen(1 TO 5) ' worm length in grid cells\r
+DIM SHARED score(1 TO 5) ' player score\r
+DIM SHARED pathPlan(1 TO 2000, 1 TO 5) ' AI movement plan (direction codes 1-4, 5=replan)\r
+DIM SHARED planPtr(1 TO 5) ' index of the next step in pathPlan\r
\r
' Variables for worm positions and game state\r
-DIM SHARED ux(1 TO 5), uy(1 TO 5), uxp(1 TO 5), uyp(1 TO 5)\r
-DIM SHARED mtm\r
+DIM SHARED headX(1 TO 5), headY(1 TO 5), dirX(1 TO 5), dirY(1 TO 5) ' worm head position and direction\r
+DIM SHARED fruitCount ' fruits eaten on current level (next level at 15)\r
DIM SHARED playerCount\r
DIM SHARED lives(1 TO 5)\r
DIM SHARED isAI(1 TO 5)\r
-DIM SHARED ail\r
-DIM SHARED lvl\r
-DIM SHARED elum\r
-DIM SHARED spd\r
+DIM SHARED planLimit ' maximum AI plan length in steps\r
+DIM SHARED levelNum ' current level number\r
+DIM SHARED startLives ' lives each worm starts with\r
+DIM SHARED speed ' game speed (larger = faster)\r
\r
playerCount = 1\r
-ail = 10\r
-lvl = 1\r
+planLimit = 10\r
+levelNum = 1\r
\r
' Array defines if player is human (0) or computer (1).\r
isAI(1) = 0\r
CLS\r
\r
INPUT "How many players (1 - 5):", playerCount\r
-INPUT "How many of them are computers:", a\r
-FOR b = playerCount TO playerCount - a + 1 STEP -1\r
- isAI(b) = 1\r
-NEXT b\r
+INPUT "How many of them are computers:", computerCount\r
+FOR player = playerCount TO playerCount - computerCount + 1 STEP -1\r
+ isAI(player) = 1\r
+NEXT player\r
\r
-INPUT "How many lives:", elum\r
-INPUT "Speed: (1-slow, 3-ok, 10-very fast)", spd\r
+INPUT "How many lives:", startLives\r
+INPUT "Speed: (1-slow, 3-ok, 10-very fast)", speed\r
\r
start\r
\r
-level lvl\r
+startLevel levelNum\r
1\r
-tkt\r
-delay .5 / spd\r
-' spd\r
-IF mtm >= 15 THEN\r
- mtm = 1\r
- lvl = lvl + 1\r
- level lvl\r
+gameTick\r
+delay .5 / speed\r
+' speed\r
+IF fruitCount >= 15 THEN\r
+ fruitCount = 1\r
+ levelNum = levelNum + 1\r
+ startLevel levelNum\r
END IF\r
GOTO 1\r
\r
-SUB ai (a%)\r
- ' This subroutine handles the AI logic for computer-controlled worms.\r
+SUB planPath (playerNumber%)\r
+ ' Computes a distance field to the nearest fruit and builds a movement plan.\r
FOR y = 0 TO 36\r
FOR x = 0 TO 36\r
- buf2(x, y) = 32000\r
- IF buf(x, y) = 2 THEN buf2(x, y) = 0\r
- IF buf(x, y) > 9 OR buf(x, y) = 1 THEN buf2(x, y) = -1\r
+ distMap(x, y) = 32000\r
+ IF arena(x, y) = 2 THEN distMap(x, y) = 0\r
+ IF arena(x, y) > 9 OR arena(x, y) = 1 THEN distMap(x, y) = -1\r
NEXT x\r
NEXT y\r
\r
- ' Set the target position to the center of the grid.\r
- IF buf2(16, 16) = 32000 THEN buf2(16, 16) = 15000\r
+ ' If no fruit is reachable, use the grid center as a fallback target.\r
+ IF distMap(16, 16) = 32000 THEN distMap(16, 16) = 15000\r
\r
6\r
b = 0\r
FOR y = 1 TO 35\r
FOR x = 1 TO 34\r
- IF (buf2(x + 1, y) > buf2(x, y) + 1) AND (buf2(x, y) >= 0) THEN\r
- buf2(x + 1, y) = buf2(x, y) + 1\r
+ IF (distMap(x + 1, y) > distMap(x, y) + 1) AND (distMap(x, y) >= 0) THEN\r
+ distMap(x + 1, y) = distMap(x, y) + 1\r
b = 1\r
END IF\r
NEXT x\r
\r
- ' Check if moving left is the shortest path.\r
+ ' Check if moving right is the shortest path.\r
FOR x = 35 TO 2 STEP -1\r
- IF (buf2(x - 1, y) > buf2(x, y) + 1) AND (buf2(x, y) >= 0) THEN\r
- buf2(x - 1, y) = buf2(x, y) + 1\r
+ IF (distMap(x - 1, y) > distMap(x, y) + 1) AND (distMap(x, y) >= 0) THEN\r
+ distMap(x - 1, y) = distMap(x, y) + 1\r
b = 1\r
END IF\r
NEXT x\r
\r
- IF (buf2(1, y) > buf2(35, y) + 1) AND (buf2(35, y) >= 0) THEN\r
- buf2(1, y) = buf2(35, y) + 1\r
+ IF (distMap(1, y) > distMap(35, y) + 1) AND (distMap(35, y) >= 0) THEN\r
+ distMap(1, y) = distMap(35, y) + 1\r
b = 1\r
END IF\r
\r
- IF (buf2(35, y) > buf2(1, y) + 1) AND (buf2(1, y) >= 0) THEN\r
- buf2(35, y) = buf2(1, y) + 1\r
+ IF (distMap(35, y) > distMap(1, y) + 1) AND (distMap(1, y) >= 0) THEN\r
+ distMap(35, y) = distMap(1, y) + 1\r
b = 1\r
END IF\r
NEXT y\r
\r
FOR x = 1 TO 35\r
FOR y = 1 TO 34\r
- IF (buf2(x, y + 1) > buf2(x, y) + 1) AND (buf2(x, y) >= 0) THEN\r
- buf2(x, y + 1) = buf2(x, y) + 1\r
+ IF (distMap(x, y + 1) > distMap(x, y) + 1) AND (distMap(x, y) >= 0) THEN\r
+ distMap(x, y + 1) = distMap(x, y) + 1\r
b = 1\r
END IF\r
NEXT y\r
\r
- ' Check if moving up is the shortest path.\r
+ ' Check if moving down is the shortest path.\r
FOR y = 35 TO 2 STEP -1\r
- IF (buf2(x, y - 1) > buf2(x, y) + 1) AND (buf2(x, y) >= 0) THEN\r
- buf2(x, y - 1) = buf2(x, y) + 1\r
+ IF (distMap(x, y - 1) > distMap(x, y) + 1) AND (distMap(x, y) >= 0) THEN\r
+ distMap(x, y - 1) = distMap(x, y) + 1\r
b = 1\r
END IF\r
NEXT y\r
\r
- IF (buf2(x, 1) > buf2(x, 35) + 1) AND (buf2(x, 35) >= 0) THEN\r
- buf2(x, 1) = buf2(x, 35) + 1\r
+ IF (distMap(x, 1) > distMap(x, 35) + 1) AND (distMap(x, 35) >= 0) THEN\r
+ distMap(x, 1) = distMap(x, 35) + 1\r
b = 1\r
END IF\r
\r
- IF (buf2(x, 35) > buf2(x, 1) + 1) AND (buf2(x, 1) >= 0) THEN\r
- buf2(x, 35) = buf2(x, 1) + 1\r
+ IF (distMap(x, 35) > distMap(x, 1) + 1) AND (distMap(x, 1) >= 0) THEN\r
+ distMap(x, 35) = distMap(x, 1) + 1\r
b = 1\r
END IF\r
NEXT x\r
\r
- ' If no shorter path is found, exit the loop.\r
+ ' Repeat the relaxation passes until no cell distance improves.\r
IF b = 1 THEN GOTO 6\r
\r
- tx = ux(a)\r
- ty = uy(a)\r
+ traceX = headX(playerNumber)\r
+ traceY = headY(playerNumber)\r
\r
- d = 0\r
+ stepCount = 0\r
7\r
b = 32001\r
- tmpxp = 0\r
- tmpyp = 0\r
+ stepX = 0\r
+ stepY = 0\r
\r
- ' Check if moving right is the shortest path.\r
- IF (buf2(tx - 1, ty) < b) AND (buf2(tx - 1, ty) >= 0) THEN\r
- b = buf2(tx - 1, ty)\r
- tmpxp = -1\r
- tmpyp = 0\r
- c = 1\r
+ ' Check if moving left is the shortest path.\r
+ IF (distMap(traceX - 1, traceY) < b) AND (distMap(traceX - 1, traceY) >= 0) THEN\r
+ b = distMap(traceX - 1, traceY)\r
+ stepX = -1\r
+ stepY = 0\r
+ direction = 1\r
END IF\r
\r
- ' Check if moving down is the shortest path.\r
- IF (buf2(tx, ty - 1) < b) AND (buf2(tx, ty - 1) >= 0) THEN\r
- b = buf2(tx, ty - 1)\r
- tmpxp = 0\r
- tmpyp = -1\r
- c = 2\r
+ ' Check if moving up is the shortest path.\r
+ IF (distMap(traceX, traceY - 1) < b) AND (distMap(traceX, traceY - 1) >= 0) THEN\r
+ b = distMap(traceX, traceY - 1)\r
+ stepX = 0\r
+ stepY = -1\r
+ direction = 2\r
END IF\r
\r
- ' Check if moving left is the shortest path.\r
- IF (buf2(tx + 1, ty) < b) AND (buf2(tx + 1, ty) >= 0) THEN\r
- b = buf2(tx + 1, ty)\r
- tmpxp = 1\r
- tmpyp = 0\r
- c = 3\r
+ ' Check if moving right is the shortest path.\r
+ IF (distMap(traceX + 1, traceY) < b) AND (distMap(traceX + 1, traceY) >= 0) THEN\r
+ b = distMap(traceX + 1, traceY)\r
+ stepX = 1\r
+ stepY = 0\r
+ direction = 3\r
END IF\r
\r
- ' Check if moving up is the shortest path.\r
- IF (buf2(tx, ty + 1) < b) AND (buf2(tx, ty + 1) >= 0) THEN\r
- b = buf2(tx, ty + 1)\r
- tmpxp = 0\r
- tmpyp = 1\r
- c = 4\r
+ ' Check if moving down is the shortest path.\r
+ IF (distMap(traceX, traceY + 1) < b) AND (distMap(traceX, traceY + 1) >= 0) THEN\r
+ b = distMap(traceX, traceY + 1)\r
+ stepX = 0\r
+ stepY = 1\r
+ direction = 4\r
END IF\r
\r
- ' If no shorter path is found, set the direction to random.\r
+ ' If no neighbor is reachable, default to moving left.\r
IF b = 32001 THEN\r
- tmpxp = -1\r
- tmpyp = 0\r
- c = 1\r
+ stepX = -1\r
+ stepY = 0\r
+ direction = 1\r
b = -1\r
END IF\r
\r
- buf2(tx, ty) = -1\r
- d = d + 1\r
- ussk(d, a) = c\r
- tx = tx + tmpxp\r
- ty = ty + tmpyp\r
+ distMap(traceX, traceY) = -1\r
+ stepCount = stepCount + 1\r
+ pathPlan(stepCount, playerNumber) = direction\r
+ traceX = traceX + stepX\r
+ traceY = traceY + stepY\r
\r
' Wrap around the edges of the grid.\r
- IF tx = 1 THEN tx = 34\r
- IF ty = 1 THEN ty = 34\r
- IF tx = 35 THEN tx = 2\r
- IF ty = 35 THEN ty = 2\r
+ IF traceX = 1 THEN traceX = 34\r
+ IF traceY = 1 THEN traceY = 34\r
+ IF traceX = 35 THEN traceX = 2\r
+ IF traceY = 35 THEN traceY = 2\r
\r
- e = buf2(tx, ty)\r
- buf2(tx, ty) = -1\r
+ cellDist = distMap(traceX, traceY)\r
+ distMap(traceX, traceY) = -1\r
\r
- sc2 tx, ty\r
+ debugTrace traceX, traceY\r
\r
- ' If the worm hits a wall or another worm, stop moving.\r
- IF d > ail THEN GOTO 8\r
+ ' Stop tracing when the plan reaches its maximum length.\r
+ IF stepCount > planLimit THEN GOTO 8\r
\r
- ' If the worm finds food, continue moving.\r
- IF (e > 0) AND (b > -1) THEN GOTO 7\r
+ ' Keep tracing while the path still leads toward a fruit.\r
+ IF (cellDist > 0) AND (b > -1) THEN GOTO 7\r
\r
8\r
- d = d + 1\r
- ussk(d, a) = 5\r
- usskp(a) = 1\r
+ stepCount = stepCount + 1\r
+ pathPlan(stepCount, playerNumber) = 5\r
+ planPtr(playerNumber) = 1\r
\r
- showb\r
+ showDistMap\r
END SUB\r
\r
-SUB autop (a%)\r
- ' This subroutine handles the movement of computer-controlled worms.\r
- c = 0\r
+SUB autopilot (playerNumber%)\r
+ ' Follows the AI movement plan; replans when the path is blocked.\r
+ replanned = 0\r
\r
5\r
' If the worm is not at the end of its path, continue moving.\r
- IF usskp(a) > 0 THEN\r
- b = ussk(usskp(a), a)\r
+ IF planPtr(playerNumber) > 0 THEN\r
+ b = pathPlan(planPtr(playerNumber), playerNumber)\r
\r
IF b = 1 THEN\r
- uxp(a) = -1\r
- uyp(a) = 0\r
+ dirX(playerNumber) = -1\r
+ dirY(playerNumber) = 0\r
ELSEIF b = 2 THEN\r
- uxp(a) = 0\r
- uyp(a) = -1\r
+ dirX(playerNumber) = 0\r
+ dirY(playerNumber) = -1\r
ELSEIF b = 3 THEN\r
- uxp(a) = 1\r
- uyp(a) = 0\r
+ dirX(playerNumber) = 1\r
+ dirY(playerNumber) = 0\r
ELSEIF b = 4 THEN\r
- uxp(a) = 0\r
- uyp(a) = 1\r
+ dirX(playerNumber) = 0\r
+ dirY(playerNumber) = 1\r
ELSEIF b = 5 THEN\r
- ai a\r
+ planPath playerNumber\r
GOTO 5\r
END IF\r
\r
- usskp(a) = usskp(a) + 1\r
+ planPtr(playerNumber) = planPtr(playerNumber) + 1\r
END IF\r
\r
' Calculate the new position of the worm.\r
- nx = ux(a) + uxp(a)\r
- ny = uy(a) + uyp(a)\r
+ nextX = headX(playerNumber) + dirX(playerNumber)\r
+ nextY = headY(playerNumber) + dirY(playerNumber)\r
\r
' Check if the worm hits a wall or another worm.\r
- b = buf(INT(nx), INT(ny))\r
+ b = arena(INT(nextX), INT(nextY))\r
\r
' If the worm hits a wall or another worm, recalculate the AI.\r
- IF (b = 1 OR b > 9) AND (c = 0) THEN\r
- ai a\r
- c = 1\r
+ IF (b = 1 OR b > 9) AND (replanned = 0) THEN\r
+ planPath playerNumber\r
+ replanned = 1\r
GOTO 5\r
END IF\r
END SUB\r
' is responsible for clearing out squares where worm tail moved out\r
' of. Such squares are marked as empty (no longer occupied by worm)\r
' and also correspondingly are erased from the screen.\r
- a = ussp(playerNumber) - ussl(playerNumber)\r
+ tailPtr = headPtr(playerNumber) - wormLen(playerNumber)\r
\r
- IF a < 1 THEN\r
- a = a + 2000\r
+ IF tailPtr < 1 THEN\r
+ tailPtr = tailPtr + 2000\r
END IF\r
\r
' The tail position can fall outside the ring buffer: below 1 when\r
' the worm has grown longer than the buffer capacity, above 2000\r
' when a dead worm's head pointer keeps advancing without wrapping.\r
' Nothing to erase in those cases.\r
- IF a < 1 OR a > 2000 THEN\r
+ IF tailPtr < 1 OR tailPtr > 2000 THEN\r
GOTO 13\r
END IF\r
\r
- IF ussx(a, playerNumber) > 0 THEN\r
- buf(ussx(a, playerNumber), ussy(a, playerNumber)) = 0\r
+ IF trailX(tailPtr, playerNumber) > 0 THEN\r
+ arena(trailX(tailPtr, playerNumber), trailY(tailPtr, playerNumber)) = 0\r
\r
- drawGridCell ussx(a, playerNumber), ussy(a, playerNumber)\r
+ drawGridCell trailX(tailPtr, playerNumber), trailY(tailPtr, playerNumber)\r
\r
- ussx(a, playerNumber) = 0\r
+ trailX(tailPtr, playerNumber) = 0\r
END IF\r
13\r
END SUB\r
\r
-FUNCTION cnum$ (a%)\r
+FUNCTION numStr$ (value%)\r
' This function converts an integer to a string.\r
- b$ = STR$(a%)\r
+ text$ = STR$(value%)\r
\r
' Remove leading spaces from the string.\r
- IF LEFT$(b$, 1) = " " THEN\r
- b$ = RIGHT$(b$, LEN(b$) - 1)\r
+ IF LEFT$(text$, 1) = " " THEN\r
+ text$ = RIGHT$(text$, LEN(text$) - 1)\r
END IF\r
\r
- cnum$ = b$\r
+ numStr$ = text$\r
END FUNCTION\r
\r
-SUB dead (a%)\r
+SUB handleDeath (playerNumber%)\r
' This subroutine handles the death of a worm.\r
- lives(a) = lives(a) - 1\r
- putworm a\r
+ lives(playerNumber) = lives(playerNumber) - 1\r
+ spawnWorm playerNumber\r
END SUB\r
\r
SUB delay (delayInSeconds AS SINGLE)\r
' This subroutine updates one cell on the screen as denoted by its\r
' X and Y coordinates.\r
'\r
-' Cell content is red from global 'buf' array and corresponding\r
+' Cell content is read from global 'arena' array and corresponding\r
' sprite is drawn on the screen.\r
'\r
' This procedure is handy because it allows redrawing only parts of the\r
' screen that were changed and thereby we avoid redrawing entire screen\r
' for every frame.\r
\r
- x1 = x% * 5\r
+ pixelX = x% * 5\r
\r
- y1 = y% * 5\r
+ pixelY = y% * 5\r
\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 0, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 0, BF\r
\r
- SELECT CASE buf(x%, y%)\r
+ SELECT CASE arena(x%, y%)\r
CASE 0\r
' Draw an empty space on the grid.\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 1, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 1, BF\r
\r
CASE 1\r
' Draw a wall on the grid.\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 7, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 7, BF\r
\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 8, B\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 8, B\r
\r
CASE 2\r
' Draw food on the grid.\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 14, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 14, BF\r
\r
CASE 10\r
' Draw the head of a worm.\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 10, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 10, BF\r
\r
- PSET (x1, y1), 0\r
+ PSET (pixelX, pixelY), 0\r
\r
- PSET (x1 + 3, y1), 0\r
+ PSET (pixelX + 3, pixelY), 0\r
\r
- PSET (x1, y1 + 3), 0\r
+ PSET (pixelX, pixelY + 3), 0\r
\r
- PSET (x1 + 3, y1 + 3), 0\r
+ PSET (pixelX + 3, pixelY + 3), 0\r
\r
CASE 11\r
' Draw the body of a worm.\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 12, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 12, BF\r
\r
- PSET (x1, y1), 0\r
+ PSET (pixelX, pixelY), 0\r
\r
- PSET (x1 + 3, y1), 0\r
+ PSET (pixelX + 3, pixelY), 0\r
\r
- PSET (x1, y1 + 3), 0\r
+ PSET (pixelX, pixelY + 3), 0\r
\r
- PSET (x1 + 3, y1 + 3), 0\r
+ PSET (pixelX + 3, pixelY + 3), 0\r
\r
CASE 12\r
' Draw the body of a worm.\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 13, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 13, BF\r
\r
- PSET (x1, y1), 0\r
+ PSET (pixelX, pixelY), 0\r
\r
- PSET (x1 + 3, y1), 0\r
+ PSET (pixelX + 3, pixelY), 0\r
\r
- PSET (x1, y1 + 3), 0\r
+ PSET (pixelX, pixelY + 3), 0\r
\r
- PSET (x1 + 3, y1 + 3), 0\r
+ PSET (pixelX + 3, pixelY + 3), 0\r
\r
CASE 13\r
' Draw the body of a worm.\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 15, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 15, BF\r
\r
- PSET (x1, y1), 0\r
+ PSET (pixelX, pixelY), 0\r
\r
- PSET (x1 + 3, y1), 0\r
+ PSET (pixelX + 3, pixelY), 0\r
\r
- PSET (x1, y1 + 3), 0\r
+ PSET (pixelX, pixelY + 3), 0\r
\r
- PSET (x1 + 3, y1 + 3), 0\r
+ PSET (pixelX + 3, pixelY + 3), 0\r
\r
CASE 14\r
' Draw the body of a worm.\r
- LINE (x1, y1)-(x1 + 3, y1 + 3), 9, BF\r
+ LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 9, BF\r
\r
- PSET (x1, y1), 0\r
+ PSET (pixelX, pixelY), 0\r
\r
- PSET (x1 + 3, y1), 0\r
+ PSET (pixelX + 3, pixelY), 0\r
\r
- PSET (x1, y1 + 3), 0\r
+ PSET (pixelX, pixelY + 3), 0\r
\r
- PSET (x1 + 3, y1 + 3), 0\r
+ PSET (pixelX + 3, pixelY + 3), 0\r
END SELECT\r
END SUB\r
\r
SUB init\r
' Initialize the game by setting up the first level.\r
- level 1\r
+ startLevel 1\r
END SUB\r
\r
-SUB level (a%)\r
+SUB startLevel (levelNum%)\r
' This subroutine sets up a new level of the game.\r
LOCATE 5, 5\r
PRINT "G E T R E A D Y"\r
\r
LOCATE 7, 5\r
- PRINT "L E V E L :"; a%\r
+ PRINT "L E V E L :"; levelNum%\r
\r
' Display a countdown before starting the level.\r
delay 2\r
' Clear the game grid.\r
FOR y = 0 TO 36\r
FOR x = 0 TO 36\r
- buf(x, y) = 0\r
+ arena(x, y) = 0\r
NEXT x\r
NEXT y\r
\r
' Set up the walls of the grid.\r
FOR x = 0 TO 36\r
- buf(x, 0) = 1\r
- buf(x, 36) = 1\r
- buf(0, x) = 1\r
- buf(36, x) = 1\r
+ arena(x, 0) = 1\r
+ arena(x, 36) = 1\r
+ arena(0, x) = 1\r
+ arena(36, x) = 1\r
NEXT x\r
\r
' Load the level from a file.\r
- b$ = cnum(a%) + ".lvl"\r
+ fileName$ = numStr(levelNum%) + ".lvl"\r
\r
- OPEN b$ FOR INPUT AS #1\r
+ OPEN fileName$ FOR INPUT AS #1\r
\r
10\r
' Read the level data line by line.\r
IF EOF(1) <> 0 THEN GOTO 11\r
\r
- LINE INPUT #1, c$\r
+ LINE INPUT #1, rowText$\r
\r
' If the line starts with a slash, it contains grid data.\r
- IF LEFT$(c$, 1) = "/" THEN\r
- d = d + 1\r
+ IF LEFT$(rowText$, 1) = "/" THEN\r
+ rowNum = rowNum + 1\r
\r
- IF d > 35 THEN\r
+ IF rowNum > 35 THEN\r
GOTO 12\r
END IF\r
\r
- g = LEN(c$)\r
- IF g > 36 THEN\r
- g = 36\r
+ rowLen = LEN(rowText$)\r
+ IF rowLen > 36 THEN\r
+ rowLen = 36\r
END IF\r
\r
' Parse the grid data and set up the game grid.\r
- FOR e = 2 TO g\r
- f$ = RIGHT$(LEFT$(c$, e), 1)\r
+ FOR column = 2 TO rowLen\r
+ cellChar$ = RIGHT$(LEFT$(rowText$, column), 1)\r
\r
- IF f$ = "#" OR f$ = "m" THEN\r
- buf(e - 1, d) = 1\r
+ IF cellChar$ = "#" OR cellChar$ = "m" THEN\r
+ arena(column - 1, rowNum) = 1\r
ELSE\r
- buf(e - 1, d) = 0\r
+ arena(column - 1, rowNum) = 0\r
END IF\r
- NEXT e\r
+ NEXT column\r
END IF\r
\r
12\r
CLOSE #1\r
\r
' Place food randomly on the grid.\r
- stuff\r
+ placeFruit\r
\r
' Initialize the worms for each player.\r
- show\r
+ drawArena\r
\r
- FOR b = 1 TO playerCount\r
- ussl(b) = 0\r
- putworm b\r
- NEXT b\r
+ FOR player = 1 TO playerCount\r
+ wormLen(player) = 0\r
+ spawnWorm player\r
+ NEXT player\r
\r
- stat\r
+ showStats\r
END SUB\r
\r
-SUB prc (playerNumber)\r
+SUB advanceWorm (playerNumber)\r
' This subroutine handles the main game loop for each player.\r
\r
clearTail playerNumber\r
\r
- ussp(playerNumber) = ussp(playerNumber) + 1\r
+ headPtr(playerNumber) = headPtr(playerNumber) + 1\r
\r
' Wrap the head pointer unconditionally: dead worms skip the rest of\r
' this procedure, so without wrapping here their pointer would grow\r
' past the ring buffer (and eventually overflow the integer).\r
- IF ussp(playerNumber) > 2000 THEN\r
- ussp(playerNumber) = ussp(playerNumber) - 2000\r
+ IF headPtr(playerNumber) > 2000 THEN\r
+ headPtr(playerNumber) = headPtr(playerNumber) - 2000\r
END IF\r
\r
' If the current player has no lives left, no further processing is needed\r
\r
' If the worm is controlled by AI, recalculate its path.\r
IF isAI(playerNumber) = 1 THEN\r
- autop playerNumber\r
+ autopilot playerNumber\r
END IF\r
\r
' Move the worm based on user input or AI direction.\r
- ux(playerNumber) = ux(playerNumber) + uxp(playerNumber)\r
- uy(playerNumber) = uy(playerNumber) + uyp(playerNumber)\r
+ headX(playerNumber) = headX(playerNumber) + dirX(playerNumber)\r
+ headY(playerNumber) = headY(playerNumber) + dirY(playerNumber)\r
\r
' Wrap around the edges of the grid.\r
- IF ux(playerNumber) = 35 THEN\r
- ux(playerNumber) = 2\r
+ IF headX(playerNumber) = 35 THEN\r
+ headX(playerNumber) = 2\r
END IF\r
\r
- IF uy(playerNumber) = 35 THEN\r
- uy(playerNumber) = 2\r
+ IF headY(playerNumber) = 35 THEN\r
+ headY(playerNumber) = 2\r
END IF\r
\r
- IF ux(playerNumber) = 1 THEN\r
- ux(playerNumber) = 34\r
+ IF headX(playerNumber) = 1 THEN\r
+ headX(playerNumber) = 34\r
END IF\r
\r
- IF uy(playerNumber) = 1 THEN\r
- uy(playerNumber) = 34\r
+ IF headY(playerNumber) = 1 THEN\r
+ headY(playerNumber) = 34\r
END IF\r
\r
- x = ux(playerNumber)\r
- y = uy(playerNumber)\r
+ cellX = headX(playerNumber)\r
+ cellY = headY(playerNumber)\r
\r
3\r
- IF buf(x, y) = 2 THEN\r
- buf(x, y) = 0\r
+ IF arena(cellX, cellY) = 2 THEN\r
+ arena(cellX, cellY) = 0\r
\r
- drawGridCell x, y\r
+ drawGridCell cellX, cellY\r
\r
- stuff\r
+ placeFruit\r
\r
- ussl(playerNumber) = ussl(playerNumber) + mtm\r
+ wormLen(playerNumber) = wormLen(playerNumber) + fruitCount\r
\r
- usss(playerNumber) = usss(playerNumber) + mtm\r
+ score(playerNumber) = score(playerNumber) + fruitCount\r
\r
- FOR b = 1 TO playerCount\r
- IF (lives(b) > 0) AND (isAI(b) = 1) THEN\r
- ai b\r
+ FOR player = 1 TO playerCount\r
+ IF (lives(player) > 0) AND (isAI(player) = 1) THEN\r
+ planPath player\r
END IF\r
- NEXT b\r
+ NEXT player\r
\r
- stat\r
+ showStats\r
\r
GOTO 3\r
END IF\r
\r
- IF buf(x, y) > 0 THEN\r
- dead playerNumber\r
+ IF arena(cellX, cellY) > 0 THEN\r
+ handleDeath playerNumber\r
\r
GOTO 4\r
END IF\r
\r
IF playerNumber = 1 THEN\r
- buf(x, y) = 10\r
+ arena(cellX, cellY) = 10\r
ELSEIF playerNumber = 2 THEN\r
- buf(x, y) = 11\r
+ arena(cellX, cellY) = 11\r
ELSEIF playerNumber = 3 THEN\r
- buf(x, y) = 12\r
+ arena(cellX, cellY) = 12\r
ELSEIF playerNumber = 4 THEN\r
- buf(x, y) = 13\r
+ arena(cellX, cellY) = 13\r
ELSEIF playerNumber = 5 THEN\r
- buf(x, y) = 14\r
+ arena(cellX, cellY) = 14\r
END IF\r
\r
- drawGridCell x, y\r
+ drawGridCell cellX, cellY\r
\r
- IF ussp(playerNumber) > 2000 THEN\r
- ussp(playerNumber) = ussp(playerNumber) - 2000\r
+ IF headPtr(playerNumber) > 2000 THEN\r
+ headPtr(playerNumber) = headPtr(playerNumber) - 2000\r
END IF\r
\r
- ussx(ussp(playerNumber), playerNumber) = x\r
+ trailX(headPtr(playerNumber), playerNumber) = cellX\r
\r
- ussy(ussp(playerNumber), playerNumber) = y\r
+ trailY(headPtr(playerNumber), playerNumber) = cellY\r
\r
4\r
END SUB\r
\r
-SUB putworm (a%)\r
+SUB spawnWorm (playerNumber%)\r
' This subroutine initializes a new worm for a player.\r
- b = ussl(a%)\r
+ b = wormLen(playerNumber%)\r
\r
' Move the worm back to its starting position.\r
- FOR c = b TO 1 STEP -1\r
- ussl(a%) = c\r
+ FOR segment = b TO 1 STEP -1\r
+ wormLen(playerNumber%) = segment\r
\r
- clearTail a%\r
- NEXT c\r
+ clearTail playerNumber%\r
+ NEXT segment\r
\r
9\r
- uy(a%) = INT(RND * 30 + 2)\r
+ headY(playerNumber%) = INT(RND * 30 + 2)\r
\r
- ux(a%) = INT(RND * 10 + 5)\r
+ headX(playerNumber%) = INT(RND * 10 + 5)\r
\r
' Ensure that the worm starts in an empty space.\r
- FOR b = ux(a%) TO ux(a%) + 10\r
- IF buf(b, uy(a%)) <> 0 THEN\r
+ FOR b = headX(playerNumber%) TO headX(playerNumber%) + 10\r
+ IF arena(b, headY(playerNumber%)) <> 0 THEN\r
GOTO 9\r
END IF\r
NEXT b\r
\r
' Set the initial direction of the worm.\r
- uxp(a%) = 1\r
+ dirX(playerNumber%) = 1\r
\r
- uyp(a%) = 0\r
+ dirY(playerNumber%) = 0\r
\r
- ussl(a%) = 3\r
+ wormLen(playerNumber%) = 3\r
\r
- stat\r
+ showStats\r
END SUB\r
\r
-SUB sc2 (x%, y%)\r
- ' This subroutine draws a worm on the game grid for AI pathfinding.\r
+SUB debugTrace (x%, y%)\r
+ ' Debug helper: plots the AI path trace on screen (currently disabled).\r
' LOCATE 1, 1\r
' PRINT x%, y%\r
\r
' a$ = INPUT$(1)\r
END SUB\r
\r
-SUB show\r
+SUB drawArena\r
' This subroutine draws the entire game grid.\r
FOR y = 1 TO 35\r
FOR x = 1 TO 35\r
NEXT y\r
END SUB\r
\r
-SUB showb\r
+SUB showDistMap\r
+ ' Disabled debug view: draws the AI distance map (distMap) beside the arena.\r
GOTO 15\r
FOR x = 1 TO 35\r
FOR y = 1 TO 35\r
\r
-LINE (x * 2 + 200, y * 2 + 100)-(x * 2 + 201, y * 2 + 101), buf2(x, y) MOD 255, BF\r
+LINE (x * 2 + 200, y * 2 + 100)-(x * 2 + 201, y * 2 + 101), distMap(x, y) MOD 255, BF\r
NEXT y\r
NEXT x\r
15\r
\r
RANDOMIZE TIMER\r
\r
- uy(1) = 5\r
+ headY(1) = 5\r
\r
- uy(2) = 10\r
+ headY(2) = 10\r
\r
- uy(3) = 15\r
+ headY(3) = 15\r
\r
- uy(4) = 20\r
+ headY(4) = 20\r
\r
- uy(5) = 25\r
+ headY(5) = 25\r
\r
- FOR a = 1 TO playerCount\r
- ux(a) = 15\r
+ FOR player = 1 TO playerCount\r
+ headX(player) = 15\r
\r
- uxp(a) = 1\r
+ dirX(player) = 1\r
\r
- uyp(a) = 0\r
+ dirY(player) = 0\r
\r
- ussp(a) = 0\r
+ headPtr(player) = 0\r
\r
- ussl(a) = 3\r
+ wormLen(player) = 3\r
\r
- lives(a) = elum\r
+ lives(player) = startLives\r
\r
- usss(a) = 0\r
+ score(player) = 0\r
\r
- usskp(a) = 1\r
+ planPtr(player) = 1\r
\r
- ussk(1, a) = 5\r
- NEXT a\r
+ pathPlan(1, player) = 5\r
+ NEXT player\r
\r
- mtm = 0\r
+ fruitCount = 0\r
END SUB\r
\r
-SUB stat\r
+SUB showStats\r
' This subroutine displays the current game statistics.\r
LOCATE 1, 25\r
\r
- PRINT mtm\r
+ PRINT fruitCount\r
\r
- FOR a = 1 TO 5\r
+ FOR player = 1 TO 5\r
COLOR 15\r
\r
- LOCATE 2 + a, 24\r
+ LOCATE 2 + player, 24\r
\r
- PRINT RIGHT$(STR$(a), 1)\r
+ PRINT RIGHT$(STR$(player), 1)\r
\r
COLOR 10\r
\r
- LOCATE 2 + a, 26\r
+ LOCATE 2 + player, 26\r
\r
- IF isAI(a) = 1 THEN\r
+ IF isAI(player) = 1 THEN\r
PRINT "*"\r
ELSE\r
PRINT "-"\r
\r
COLOR 12\r
\r
- LOCATE 2 + a, 27\r
+ LOCATE 2 + player, 27\r
\r
- b$ = STR$(usss(a))\r
+ text$ = STR$(score(player))\r
\r
- PRINT RIGHT$(b$, LEN(b$) - 1)\r
+ PRINT RIGHT$(text$, LEN(text$) - 1)\r
\r
COLOR 13\r
\r
- LOCATE 2 + a, 30\r
+ LOCATE 2 + player, 30\r
\r
- b$ = STR$(lives(a))\r
+ text$ = STR$(lives(player))\r
\r
- PRINT RIGHT$(b$, LEN(b$) - 1)\r
- NEXT a\r
+ PRINT RIGHT$(text$, LEN(text$) - 1)\r
+ NEXT player\r
\r
COLOR 10\r
\r
\r
LOCATE 1, 30\r
\r
- PRINT "Level:"; lvl\r
+ PRINT "Level:"; levelNum\r
END SUB\r
\r
-SUB stuff\r
+SUB placeFruit\r
' This subroutine places food randomly on the game grid.\r
2\r
x = INT(RND * 33 + 2)\r
\r
y = INT(RND * 33 + 2)\r
\r
- IF buf(x, y) = 0 THEN\r
- buf(x, y) = 2\r
+ IF arena(x, y) = 0 THEN\r
+ arena(x, y) = 2\r
\r
drawGridCell x, y\r
ELSE\r
GOTO 2\r
END IF\r
\r
- mtm = mtm + 1\r
+ fruitCount = fruitCount + 1\r
\r
- stat\r
+ showStats\r
END SUB\r
\r
-SUB tkt\r
- ' This subroutine handles user input and AI recalculation.\r
- a$ = INKEY$\r
+SUB gameTick\r
+ ' One game tick: read keyboard input, then advance every worm.\r
+ key$ = INKEY$\r
\r
- IF a$ = CHR$(27) THEN\r
+ IF key$ = CHR$(27) THEN\r
SYSTEM\r
END IF\r
\r
- IF (a$ = CHR$(0) + "M") AND (uxp(1) <> -1) THEN\r
- uxp(1) = 1\r
+ IF (key$ = CHR$(0) + "M") AND (dirX(1) <> -1) THEN\r
+ dirX(1) = 1\r
\r
- uyp(1) = 0\r
+ dirY(1) = 0\r
END IF\r
\r
- IF (a$ = CHR$(0) + "K") AND (uxp(1) <> 1) THEN\r
- uxp(1) = -1\r
+ IF (key$ = CHR$(0) + "K") AND (dirX(1) <> 1) THEN\r
+ dirX(1) = -1\r
\r
- uyp(1) = 0\r
+ dirY(1) = 0\r
END IF\r
\r
- IF (a$ = CHR$(0) + "P") AND (uyp(1) <> -1) THEN\r
- uxp(1) = 0\r
+ IF (key$ = CHR$(0) + "P") AND (dirY(1) <> -1) THEN\r
+ dirX(1) = 0\r
\r
- uyp(1) = 1\r
+ dirY(1) = 1\r
END IF\r
\r
- IF (a$ = CHR$(0) + "H") AND (uyp(1) <> 1) THEN\r
- uxp(1) = 0\r
+ IF (key$ = CHR$(0) + "H") AND (dirY(1) <> 1) THEN\r
+ dirX(1) = 0\r
\r
- uyp(1) = -1\r
+ dirY(1) = -1\r
END IF\r
\r
- IF (a$ = "d") AND (uxp(2) <> -1) THEN\r
- uxp(2) = 1\r
+ IF (key$ = "d") AND (dirX(2) <> -1) THEN\r
+ dirX(2) = 1\r
\r
- uyp(2) = 0\r
+ dirY(2) = 0\r
END IF\r
\r
- IF (a$ = "a") AND (uxp(2) <> 1) THEN\r
- uxp(2) = -1\r
+ IF (key$ = "a") AND (dirX(2) <> 1) THEN\r
+ dirX(2) = -1\r
\r
- uyp(2) = 0\r
+ dirY(2) = 0\r
END IF\r
\r
- IF (a$ = "s") AND (uyp(2) <> -1) THEN\r
- uxp(2) = 0\r
+ IF (key$ = "s") AND (dirY(2) <> -1) THEN\r
+ dirX(2) = 0\r
\r
- uyp(2) = 1\r
+ dirY(2) = 1\r
END IF\r
\r
- IF (a$ = "w") AND (uyp(2) <> 1) THEN\r
- uxp(2) = 0\r
+ IF (key$ = "w") AND (dirY(2) <> 1) THEN\r
+ dirX(2) = 0\r
\r
- uyp(2) = -1\r
+ dirY(2) = -1\r
END IF\r
\r
- b = VAL(a$)\r
+ playerNum = VAL(key$)\r
\r
- IF b > 0 THEN\r
- IF isAI(b) = 1 THEN\r
- isAI(b) = 0\r
+ IF playerNum > 0 THEN\r
+ IF isAI(playerNum) = 1 THEN\r
+ isAI(playerNum) = 0\r
ELSE\r
- isAI(b) = 1\r
+ isAI(playerNum) = 1\r
END IF\r
\r
- stat\r
+ showStats\r
END IF\r
\r
- FOR a = 1 TO playerCount\r
- prc a\r
- NEXT a\r
+ FOR player = 1 TO playerCount\r
+ advanceWorm player\r
+ NEXT player\r
END SUB\r
' Changelog:
' 2001, Initial version
' 2024, Improved program readability
+' 2026, Improved program readability
-DECLARE SUB compki (m%, h%, x1%, y1%)
-DECLARE SUB compgo2 (h%)
-DECLARE SUB compgo (h%)
-DECLARE SUB humngo (h%)
+DECLARE SUB evalCapture (jumps%, score%, landX%, landY%)
+DECLARE SUB searchCompMoves2 (score%) ' declared but never used
+DECLARE SUB searchCompMoves (score%)
+DECLARE SUB searchOppMoves (score%)
DefInt A-Z
-DECLARE SUB thinkc ()
-DECLARE SUB thinkh ()
-DECLARE SUB cmd (a$)
-DECLARE SUB freet ()
-DECLARE SUB prn (x%, y%, c%, a$)
-DECLARE SUB msg (a$, c)
-DECLARE SUB getfnt ()
-DECLARE SUB playg ()
-DECLARE SUB geth ()
-DECLARE SUB start ()
-DECLARE SUB mklau ()
-DECLARE SUB showr (x, y)
-DECLARE SUB show ()
+DECLARE SUB computerMove ()
+DECLARE SUB humanMove ()
+DECLARE SUB doCommand (cmdText$)
+DECLARE SUB pollKeys ()
+DECLARE SUB drawText (pixelX%, pixelY%, fgColor%, text$)
+DECLARE SUB showMessage (text$, fgColor)
+DECLARE SUB grabFont ()
+DECLARE SUB gameLoop ()
+DECLARE SUB getHumanMove () ' declared but never used
+DECLARE SUB initGame ()
+DECLARE SUB initBoard ()
+DECLARE SUB drawSquare (x, y)
+DECLARE SUB drawBoard ()
Dim Shared font(0 To 7, 0 To 7, 0 To 255)
-Dim Shared siz, fi, ri, rs
-Dim Shared stri$
-Dim Shared humx1, humy1, humx2, humy2
-Dim Shared sug, smax
-Dim Shared npos As Long
-Dim Shared cx1, cy1, cx2, cy2
-
-siz = 6 ' Board size
-fi = 0
-ri = 2
-smax = 3 ' thinking depth
-
-Dim Shared lau(-1 To siz + 2, -1 To siz + 2)
-
-start
-mklau
-show
-playg
-
-Sub cmd (a$)
- mitus = 0
- Dim sona$(1 To 10)
- For b = 1 To 10
- sona$(b) = ""
- Next b
-
- d = 1
- e = 1
- For b = 1 To Len(a$)
- c$ = Right$(Left$(a$, b), 1)
- If c$ = " " Then
- If e = 0 Then d = d + 1: e = 1
+Dim Shared boardSize, parity, pieceRows, squareSize
+Dim Shared cmdLine$
+Dim Shared humFromX, humFromY, humToX, humToY
+Dim Shared depth, maxDepth
+Dim Shared positions As Long
+Dim Shared compFromX, compFromY, compToX, compToY
+
+boardSize = 6 ' Board size
+parity = 0
+pieceRows = 2
+maxDepth = 3 ' thinking depth
+
+' Board encoding: -1 = off-board border, 0 = empty, 1 = computer piece, 2 = human piece
+Dim Shared board(-1 To boardSize + 2, -1 To boardSize + 2)
+
+initGame
+initBoard
+drawBoard
+gameLoop
+
+Sub doCommand (cmdText$)
+ ' Parse and run a command typed in the game's command line (m/h/q/n).
+ wordCount = 0
+ Dim word$(1 To 10)
+ For charIdx = 1 To 10
+ word$(charIdx) = ""
+ Next charIdx
+
+ wordNum = 1
+ afterSpace = 1
+ For charIdx = 1 To Len(cmdText$)
+ char$ = Right$(Left$(cmdText$, charIdx), 1)
+ If char$ = " " Then
+ If afterSpace = 0 Then wordNum = wordNum + 1: afterSpace = 1
GoTo 4
End If
- e = 0
- sona$(d) = sona$(d) + c$
+ afterSpace = 0
+ word$(wordNum) = word$(wordNum) + char$
4
- Next b
- If e = 1 Then d = d - 1
- mitus = d
+ Next charIdx
+ If afterSpace = 1 Then wordNum = wordNum - 1
+ wordCount = wordNum
- Select Case sona$(1)
+ ' word$(1) = command letter; word$(2) and word$(3) = arguments.
+ Select Case word$(1)
Case "m"
- If humx1 > 0 Then msg "Move replaced.", 14
+ If humFromX > 0 Then showMessage "Move replaced.", 14
- humx1 = Asc(Left$(sona$(2), 1)) - 64
- If humx1 > 32 Then humx1 = humx1 - 32
- humy1 = Val(Right$(sona$(2), Len(sona$(2)) - 1))
- humx2 = Asc(Left$(sona$(3), 1)) - 64
- If humx2 > 32 Then humx2 = humx2 - 32
- humy2 = Val(Right$(sona$(3), Len(sona$(2)) - 1))
+ ' Parse "m <from> <to>" e.g. "m b3 d4": column letter -> 1-6, row digit.
+ humFromX = Asc(Left$(word$(2), 1)) - 64
+ If humFromX > 32 Then humFromX = humFromX - 32 ' tolerate lowercase
+ humFromY = Val(Right$(word$(2), Len(word$(2)) - 1))
+ humToX = Asc(Left$(word$(3), 1)) - 64
+ If humToX > 32 Then humToX = humToX - 32 ' tolerate lowercase
+ humToY = Val(Right$(word$(3), Len(word$(2)) - 1))
Case "h"
- msg "h - display help screen", 14
- msg "q - to quit", 14
- msg "m <from> <to> - make move", 14
- msg "n - no. positions processed", 14
+ showMessage "h - display help screen", 14
+ showMessage "q - to quit", 14
+ showMessage "m <from> <to> - make move", 14
+ showMessage "n - no. positions processed", 14
Case "q"
System
Case "n"
- b$ = "positions processed:" + Str$(npos)
- msg b$, 14
+ outMsg$ = "positions processed:" + Str$(positions)
+ showMessage outMsg$, 14
End Select
End Sub
-Sub compgo (h)
- If sug > smax Then h = 0: GoTo 6
- sug = sug + 1
- npos = npos + 1
- freet
- If sug = 1 Then h1 = -2000 Else h1 = -1000
-
- 'cx1 = x: cy1 = y: cx2 = x - 1: cy2 = y + 1
- b = 0
- c = 0
- m = 0
- For y = 1 To siz ' check for eating
- For x = 1 To siz
- If lau(x, y) = 1 Then
+Sub searchCompMoves (score)
+ ' Recursively search computer moves and opponent replies up to maxDepth.
+ ' Returns the best achievable score via the score parameter.
+ If depth > maxDepth Then score = 0: GoTo 6 ' cut-off depth reached, stop searching
+ depth = depth + 1
+ positions = positions + 1
+ pollKeys
+ If depth = 1 Then bestScore = -2000 Else bestScore = -1000
+
+ 'compFromX = x: compFromY = y: compToX = x - 1: compToY = y + 1
+ foundCapture = 0
+ jumped = 0
+ maxJumps = 0
+ For y = 1 To boardSize ' look for captures
+ For x = 1 To boardSize
+ If board(x, y) = 1 Then
8
- If (lau(x - 1, y + 1) = 2) And (lau(x - 2, y + 2) = 0) Then
- Swap lau(x, y), lau(x - 2, y + 2)
- lau(x - 1, y + 1) = 0
- compki m1, h2, x - 2, y + 2
- lau(x - 1, y + 1) = 2
- Swap lau(x, y), lau(x - 2, y + 2)
- m1 = m1 + 1
- If m1 > m Then m = m1: h1 = -1000
- If m1 = m Then
- If h2 + 1 > h1 Then
- h1 = h2 + 1
- If npos = 1 Then cx1 = x: cy1 = y: cx2 = x - 2: cy2 = y + 2
+ ' Capture: opponent piece diagonally adjacent and the landing square behind
+ ' it empty -> jump over it, remove it, recurse, then restore the board.
+ If (board(x - 1, y + 1) = 2) And (board(x - 2, y + 2) = 0) Then
+ Swap board(x, y), board(x - 2, y + 2)
+ board(x - 1, y + 1) = 0
+ evalCapture jumpCount, replyScore, x - 2, y + 2
+ board(x - 1, y + 1) = 2
+ Swap board(x, y), board(x - 2, y + 2)
+ jumpCount = jumpCount + 1
+ If jumpCount > maxJumps Then maxJumps = jumpCount: bestScore = -1000
+ If jumpCount = maxJumps Then
+ If replyScore + 1 > bestScore Then
+ bestScore = replyScore + 1
+ If positions = 1 Then compFromX = x: compFromY = y: compToX = x - 2: compToY = y + 2
End If
End If
- b = 1
+ foundCapture = 1
End If
- If (lau(x + 1, y + 1) = 2) And (lau(x + 2, y + 2) = 0) Then
- Swap lau(x, y), lau(x + 2, y + 2)
- lau(x + 1, y + 1) = 0
- compki m1, h2, x + 2, y + 2
- lau(x + 1, y + 1) = 2
- Swap lau(x, y), lau(x + 2, y + 2)
- m1 = m1 + 1
- If m1 > m Then m = m1: h1 = -1000
- If m1 = m Then
- If h2 + 1 > h1 Then
- h1 = h2 + 1
- If npos = 1 Then cx1 = x: cy1 = y: cx2 = x + 2: cy2 = y + 2
+ If (board(x + 1, y + 1) = 2) And (board(x + 2, y + 2) = 0) Then
+ Swap board(x, y), board(x + 2, y + 2)
+ board(x + 1, y + 1) = 0
+ evalCapture jumpCount, replyScore, x + 2, y + 2
+ board(x + 1, y + 1) = 2
+ Swap board(x, y), board(x + 2, y + 2)
+ jumpCount = jumpCount + 1
+ If jumpCount > maxJumps Then maxJumps = jumpCount: bestScore = -1000
+ If jumpCount = maxJumps Then
+ If replyScore + 1 > bestScore Then
+ bestScore = replyScore + 1
+ If positions = 1 Then compFromX = x: compFromY = y: compToX = x + 2: compToY = y + 2
End If
End If
- b = 1
+ foundCapture = 1
End If
- If (lau(x - 1, y - 1) = 2) And (lau(x - 2, y - 2) = 0) Then
- Swap lau(x, y), lau(x - 2, y - 2)
- lau(x - 1, y - 1) = 0
- compki m1, h2, x - 2, y - 2
- lau(x - 1, y - 1) = 2
- Swap lau(x, y), lau(x - 2, y - 2)
- m1 = m1 + 1
- If m1 > m Then m = m1: h1 = -1000
- If m1 = m Then
- If h2 + 1 > h1 Then
- h1 = h2 + 1
- If npos = 1 Then cx1 = x: cy1 = y: cx2 = x - 2: cy2 = y - 2
+ If (board(x - 1, y - 1) = 2) And (board(x - 2, y - 2) = 0) Then
+ Swap board(x, y), board(x - 2, y - 2)
+ board(x - 1, y - 1) = 0
+ evalCapture jumpCount, replyScore, x - 2, y - 2
+ board(x - 1, y - 1) = 2
+ Swap board(x, y), board(x - 2, y - 2)
+ jumpCount = jumpCount + 1
+ If jumpCount > maxJumps Then maxJumps = jumpCount: bestScore = -1000
+ If jumpCount = maxJumps Then
+ If replyScore + 1 > bestScore Then
+ bestScore = replyScore + 1
+ If positions = 1 Then compFromX = x: compFromY = y: compToX = x - 2: compToY = y - 2
End If
End If
- b = 1
+ foundCapture = 1
End If
- If (lau(x + 1, y - 1) = 2) And (lau(x + 2, y - 2) = 0) Then
- Swap lau(x, y), lau(x + 2, y - 2)
- lau(x + 1, y - 1) = 0
- compki m1, h2, x + 2, y - 2
- lau(x + 1, y - 1) = 2
- Swap lau(x, y), lau(x + 2, y - 2)
- m1 = m1 + 1
- If m1 > m Then m = m1: h1 = -1000
- If m1 = m Then
- If h2 + 1 > h1 Then
- h1 = h2 + 1
- If npos = 1 Then cx1 = x: cy1 = y: cx2 = x + 2: cy2 = y - 2
+ If (board(x + 1, y - 1) = 2) And (board(x + 2, y - 2) = 0) Then
+ Swap board(x, y), board(x + 2, y - 2)
+ board(x + 1, y - 1) = 0
+ evalCapture jumpCount, replyScore, x + 2, y - 2
+ board(x + 1, y - 1) = 2
+ Swap board(x, y), board(x + 2, y - 2)
+ jumpCount = jumpCount + 1
+ If jumpCount > maxJumps Then maxJumps = jumpCount: bestScore = -1000
+ If jumpCount = maxJumps Then
+ If replyScore + 1 > bestScore Then
+ bestScore = replyScore + 1
+ If positions = 1 Then compFromX = x: compFromY = y: compToX = x + 2: compToY = y - 2
End If
End If
- b = 1
+ foundCapture = 1
End If
- If c = 1 Then GoTo 9
+ If jumped = 1 Then GoTo 9
End If
Next x
Next y
9
- If (b = 1) And (npos = 1) Then
- cx3 = (cx1 + cx2) / 2
- cy3 = (cy1 + cy2) / 2
- lau(cx3, cy3) = 0
- showr cx3, cy3
-
- Swap lau(cx1, cy1), lau(cx2, cy2)
- showr cx1, cy1
- showr cx2, cy2
- msg "NJAM!", 10
- x = cx2
- y = cy2
- c = 1
- b = 0
- GoTo 8
+ ' Top level only: play the chosen capture on screen and scan for further jumps.
+ If (foundCapture = 1) And (positions = 1) Then
+ midX = (compFromX + compToX) / 2
+ midY = (compFromY + compToY) / 2
+ board(midX, midY) = 0
+ drawSquare midX, midY
+
+ Swap board(compFromX, compFromY), board(compToX, compToY)
+ drawSquare compFromX, compFromY
+ drawSquare compToX, compToY
+ showMessage "NJAM!", 10
+ x = compToX
+ y = compToY
+ jumped = 1
+ foundCapture = 0
+ GoTo 8 ' re-enter the scan loop to continue a multi-jump
End If
- If c = 1 Then
- cx1 = 1: cy1 = 1: cx2 = 1: cy2 = 1
+ If jumped = 1 Then
+ compFromX = 1: compFromY = 1: compToX = 1: compToY = 1
GoTo 10
End If
- If sug = 1 Then
- msg "Cannot eat.", 4
- msg Str$(h1), 4
+ If depth = 1 Then
+ showMessage "Cannot eat.", 4
+ showMessage Str$(bestScore), 4
End If
- For y = 1 To siz ' unuseful move
- For x = 1 To siz
- If lau(x, y) = 1 Then
- If lau(x - 1, y + 1) = 0 Then
- Swap lau(x, y), lau(x - 1, y + 1)
- humngo h2
- Swap lau(x, y), lau(x - 1, y + 1)
- If h2 > h1 Then
- h1 = h2
- If sug = 1 Then cx1 = x: cy1 = y: cx2 = x - 1: cy2 = y + 1
+ For y = 1 To boardSize ' quiet move (no capture available)
+ For x = 1 To boardSize
+ If board(x, y) = 1 Then
+ If board(x - 1, y + 1) = 0 Then
+ Swap board(x, y), board(x - 1, y + 1)
+ searchOppMoves replyScore
+ Swap board(x, y), board(x - 1, y + 1)
+ If replyScore > bestScore Then
+ bestScore = replyScore
+ If depth = 1 Then compFromX = x: compFromY = y: compToX = x - 1: compToY = y + 1
End If
End If
- If lau(x + 1, y + 1) = 0 Then
- Swap lau(x, y), lau(x + 1, y + 1)
- humngo h2
- Swap lau(x, y), lau(x + 1, y + 1)
- If h2 > h1 Then
- h1 = h2
- If sug = 1 Then cx1 = x: cy1 = y: cx2 = x + 1: cy2 = y + 1
+ If board(x + 1, y + 1) = 0 Then
+ Swap board(x, y), board(x + 1, y + 1)
+ searchOppMoves replyScore
+ Swap board(x, y), board(x + 1, y + 1)
+ If replyScore > bestScore Then
+ bestScore = replyScore
+ If depth = 1 Then compFromX = x: compFromY = y: compToX = x + 1: compToY = y + 1
End If
End If
End If
Next x
Next y
- h = h1
+ score = bestScore
10
- sug = sug - 1
+ depth = depth - 1
6
End Sub
-Sub compki (m, h, x1, y1)
- h1 = 0
+Sub evalCapture (jumps, score, landX, landY)
+ ' Evaluation stub for the position after a capture; currently always returns 0.
+ bestScore = 0
- For y = 1 To siz
- For x = 1 To siz
+ For y = 1 To boardSize
+ For x = 1 To boardSize
Next x
Next y
- h = h1
+ score = bestScore
End Sub
-Sub freet
- a$ = InKey$
- If a$ = "" Then
+Sub pollKeys
+ ' Poll the keyboard, echo typed characters and run the command on Enter.
+ key$ = InKey$
+ If key$ = "" Then
Else
- If a$ = Chr$(8) Then
- If Len(stri$) > 0 Then
- stri$ = Left$(stri$, Len(stri$) - 1): GoTo 3
+ If key$ = Chr$(8) Then ' Backspace
+ If Len(cmdLine$) > 0 Then
+ cmdLine$ = Left$(cmdLine$, Len(cmdLine$) - 1): GoTo 3
End If
End If
- If a$ = Chr$(13) Then
- If Len(stri$) > 0 Then
- msg stri$, 7
- cmd stri$
- stri$ = ""
+ If key$ = Chr$(13) Then ' Enter: run the typed command
+ If Len(cmdLine$) > 0 Then
+ showMessage cmdLine$, 7
+ doCommand cmdLine$
+ cmdLine$ = ""
End If
GoTo 3
End If
- stri$ = stri$ + a$
+ cmdLine$ = cmdLine$ + key$
3
Line (400, 468)-(639, 479), 1, BF
- prn 405, 469, 14, stri$
+ drawText 405, 469, 14, cmdLine$
End If
End Sub
-Sub getfnt
+Sub grabFont
+ ' Capture the ROM 8x8 character bitmaps into the font() array for later drawing.
Screen 13
- For a = 0 To 255
- If (a > 5) And (a < 17) Then GoTo 2
+ For code = 0 To 255
+ If (code > 5) And (code < 17) Then GoTo 2 ' skip control characters that would mess up the screen
Locate 1, 1
- Print Chr$(a)
+ Print Chr$(code)
2
For y = 0 To 7
For x = 0 To 7
- font(x, y, a) = Point(x, y)
+ font(x, y, code) = Point(x, y)
Next x
Next y
- Next a
+ Next code
End Sub
-Sub humngo (h)
- npos = npos + 1
- h1 = 1000
-
- For y = siz To 1 Step -1
- For x = siz To 1 Step -1
- If lau(x, y) = 2 Then
- If lau(x - 1, y - 1) = 0 Then
- Swap lau(x, y), lau(x - 1, y - 1)
- compgo h2
- Swap lau(x, y), lau(x - 1, y - 1)
- If h2 < h1 Then h1 = h2
+Sub searchOppMoves (score)
+ ' Recursively search the opponent's (human) replies; returns score via parameter.
+ positions = positions + 1
+ bestScore = 1000
+
+ For y = boardSize To 1 Step -1
+ For x = boardSize To 1 Step -1
+ If board(x, y) = 2 Then
+ If board(x - 1, y - 1) = 0 Then
+ Swap board(x, y), board(x - 1, y - 1)
+ searchCompMoves replyScore
+ Swap board(x, y), board(x - 1, y - 1)
+ If replyScore < bestScore Then bestScore = replyScore
End If
- If lau(x + 1, y - 1) = 0 Then
- Swap lau(x, y), lau(x + 1, y - 1)
- compgo h2
- Swap lau(x, y), lau(x + 1, y - 1)
- If h2 < h1 Then h1 = h2
+ If board(x + 1, y - 1) = 0 Then
+ Swap board(x, y), board(x + 1, y - 1)
+ searchCompMoves replyScore
+ Swap board(x, y), board(x + 1, y - 1)
+ If replyScore < bestScore Then bestScore = replyScore
End If
- If (lau(x - 1, y - 1) = 1) And (lau(x - 2, y - 2) = 0) Then
- Swap lau(x, y), lau(x - 2, y - 2)
- lau(x - 1, y - 1) = 0
- humngo h2
- lau(x - 1, y - 1) = 1
- Swap lau(x, y), lau(x - 2, y - 2)
- If h2 - 1 < h1 Then h1 = h2 - 1
+ If (board(x - 1, y - 1) = 1) And (board(x - 2, y - 2) = 0) Then
+ Swap board(x, y), board(x - 2, y - 2)
+ board(x - 1, y - 1) = 0
+ searchOppMoves replyScore
+ board(x - 1, y - 1) = 1
+ Swap board(x, y), board(x - 2, y - 2)
+ If replyScore - 1 < bestScore Then bestScore = replyScore - 1
End If
- If (lau(x + 1, y - 1) = 1) And (lau(x + 2, y - 2) = 0) Then
- Swap lau(x, y), lau(x + 2, y - 2)
- lau(x + 1, y - 1) = 0
- humngo h2
- lau(x + 1, y - 1) = 1
- Swap lau(x, y), lau(x + 2, y - 2)
- If h2 - 1 < h1 Then h1 = h2 - 1
+ If (board(x + 1, y - 1) = 1) And (board(x + 2, y - 2) = 0) Then
+ Swap board(x, y), board(x + 2, y - 2)
+ board(x + 1, y - 1) = 0
+ searchOppMoves replyScore
+ board(x + 1, y - 1) = 1
+ Swap board(x, y), board(x + 2, y - 2)
+ If replyScore - 1 < bestScore Then bestScore = replyScore - 1
End If
End If
Next x
Next y
- h = h1
+ score = bestScore
End Sub
-Sub mklau
- For y = -1 To siz + 2
- For x = -1 To siz + 2
- lau(x, y) = -1
+Sub initBoard
+ ' Fill the board array with the starting position.
+ ' Mark the border ring as off-board (-1).
+ For y = -1 To boardSize + 2
+ For x = -1 To boardSize + 2
+ board(x, y) = -1
Next x
Next y
- For y = 1 To siz
- For x = 1 To siz
- lau(x, y) = 0
+ For y = 1 To boardSize
+ For x = 1 To boardSize
+ board(x, y) = 0
Next x
Next y
- For y = 1 To ri
- For x = 1 To siz
- If (x + y + fi) / 2 = Int((x + y + fi) / 2) Then
- lau(x, y) = 1
+ ' Computer pieces (1) on the top rows.
+ For y = 1 To pieceRows
+ For x = 1 To boardSize
+ If (x + y + parity) / 2 = Int((x + y + parity) / 2) Then
+ board(x, y) = 1
End If
Next x
Next y
- For y = siz - ri + 1 To siz
- For x = 1 To siz
- If (x + y + fi) / 2 = Int((x + y + fi) / 2) Then
- lau(x, y) = 2
+ ' Human pieces (2) on the bottom rows.
+ For y = boardSize - pieceRows + 1 To boardSize
+ For x = 1 To boardSize
+ If (x + y + parity) / 2 = Int((x + y + parity) / 2) Then
+ board(x, y) = 2
End If
Next x
Next y
End Sub
-Sub msg (a$, c)
+Sub showMessage (text$, fgColor)
+ ' Scroll the message area up by one line and print a new message.
Dim buf(1 To 10000)
+ ' Shift the message area one text line (8 pixels) up.
For x = 400 To 630 Step 40
Get (x, 8)-(x + 39, 467), buf(1)
Put (x, 0), buf(1), PSet
Next x
Line (400, 460)-(639, 467), 0, BF
- prn 405, 460, c, a$
+ drawText 405, 460, fgColor, text$
End Sub
-Sub playg
+Sub gameLoop
+ ' Main game loop: alternate computer and human turns forever.
'GOTO 7
1
- thinkc
- show
+ computerMove
+ drawBoard
7
- thinkh
- show
+ humanMove
+ drawBoard
GoTo 1
End Sub
-Sub prn (x, y, c, a$)
- x1 = x
- y1 = y
- For a = 1 To Len(a$)
- b = Asc(Right$(Left$(a$, a), 1))
- For y2 = 0 To 7
- For x2 = 0 To 7
- If font(x2, y2, b) > 0 Then PSet (x2 + x1, y2 + y1), c
- Next x2
- Next y2
- x1 = x1 + 8
- Next a
+Sub drawText (pixelX, pixelY, fgColor, text$)
+ ' Draw a string at pixel position using the captured 8x8 font.
+ drawX = pixelX
+ drawY = pixelY
+ For charIdx = 1 To Len(text$)
+ code = Asc(Right$(Left$(text$, charIdx), 1))
+ For fontY = 0 To 7
+ For fontX = 0 To 7
+ If font(fontX, fontY, code) > 0 Then PSet (fontX + drawX, fontY + drawY), fgColor
+ Next fontX
+ Next fontY
+ drawX = drawX + 8
+ Next charIdx
End Sub
-Sub show
- For y = 1 To siz
- For x = 1 To siz
- showr x, y
+Sub drawBoard
+ ' Redraw all squares plus the coordinate labels around the board.
+ For y = 1 To boardSize
+ For x = 1 To boardSize
+ drawSquare x, y
Next x
Next y
- sp = rs / 2
- For x = 1 To siz
- prn ((x - 1) * rs + 12 + sp), 2, 10, Chr$(64 + x)
- prn ((x - 1) * rs + 12 + sp), siz * rs + 11, 10, Chr$(64 + x)
+ ' Draw the column letters (top and bottom) and row numbers (left and right).
+ halfSize = squareSize / 2
+ For x = 1 To boardSize
+ drawText ((x - 1) * squareSize + 12 + halfSize), 2, 10, Chr$(64 + x)
+ drawText ((x - 1) * squareSize + 12 + halfSize), boardSize * squareSize + 11, 10, Chr$(64 + x)
Next x
- For y = 1 To siz
- a$ = Str$(y)
- a$ = Right$(a$, Len(a$) - 1)
- prn 15 - (Len(a$) * 8), (y - 1) * rs + sp + 7, 10, a$
- prn (siz * rs + 16), (y - 1) * rs + sp + 7, 10, a$
+ For y = 1 To boardSize
+ label$ = Str$(y)
+ label$ = Right$(label$, Len(label$) - 1)
+ drawText 15 - (Len(label$) * 8), (y - 1) * squareSize + halfSize + 7, 10, label$
+ drawText (boardSize * squareSize + 16), (y - 1) * squareSize + halfSize + 7, 10, label$
Next y
End Sub
-Sub showr (x, y)
- If (x + y + fi) / 2 = Int((x + y + fi) / 2) Then c = 8 Else c = 7
- x1 = (x - 1) * rs + 15
- y1 = (y - 1) * rs + 10
- Line (x1, y1)-(x1 + rs - 1, y1 + rs - 1), c, BF
-
- If lau(x, y) > 0 Then
- sp = rs / 2
- If lau(x, y) = 1 Then c1 = 15 Else c1 = 14
- Circle (x1 + sp, y1 + sp), sp - 1, c1
- Paint (x1 + sp, y1 + sp), c1
+Sub drawSquare (x, y)
+ ' Redraw one board square and the piece standing on it, if any.
+ If (x + y + parity) / 2 = Int((x + y + parity) / 2) Then sqColor = 8 Else sqColor = 7
+ pixelX = (x - 1) * squareSize + 15
+ pixelY = (y - 1) * squareSize + 10
+ Line (pixelX, pixelY)-(pixelX + squareSize - 1, pixelY + squareSize - 1), sqColor, BF
+
+ If board(x, y) > 0 Then
+ halfSize = squareSize / 2
+ If board(x, y) = 1 Then pieceColor = 15 Else pieceColor = 14
+ Circle (pixelX + halfSize, pixelY + halfSize), halfSize - 1, pieceColor
+ Paint (pixelX + halfSize, pixelY + halfSize), pieceColor
End If
End Sub
-Sub start
- getfnt
+Sub initGame
+ ' One-time setup: grab font, set screen mode, draw layout, compute square size.
+ grabFont
Screen 12
Line (399, 0)-(399, 479), 13
- msg "Type 'h' for help.", 14
+ showMessage "Type 'h' for help.", 14
- rs = Int(370 / siz)
+ squareSize = Int(370 / boardSize)
End Sub
-Sub thinkc
- msg "Computer turn.", 14
- sug = 0
- npos = 0
- cx1 = -1
-
- compgo h
- cmd "n"
- If cx1 = -1 Then msg "You won!", 10: msg "--------", 10: System
-
- If h <= -2 Then msg "Oh no...", 10
- If h = -1 Then msg "Oops!", 10
- If h = 1 Then msg "Yess! I will eat soon!", 10
- If h >= 2 Then msg "HA HA HA YOU ARE IN TROUBLE!", 10
-
- If Abs(cx1 - cx2) = 2 Then
- cx3 = (cx1 + cx2) / 2
- cy3 = (cy1 + cy2) / 2
- lau(cx3, cy3) = 0
- showr cx3, cy3
+Sub computerMove
+ ' The computer's turn: search the best move, comment on it and play it.
+ showMessage "Computer turn.", 14
+ depth = 0
+ positions = 0
+ compFromX = -1
+
+ searchCompMoves score
+ doCommand "n" ' print "positions processed: N"
+ If compFromX = -1 Then showMessage "You won!", 10: showMessage "--------", 10: System
+
+ If score <= -2 Then showMessage "Oh no...", 10
+ If score = -1 Then showMessage "Oops!", 10
+ If score = 1 Then showMessage "Yess! I will eat soon!", 10
+ If score >= 2 Then showMessage "HA HA HA YOU ARE IN TROUBLE!", 10
+
+ ' If the move was a jump, remove the captured piece from the middle square.
+ If Abs(compFromX - compToX) = 2 Then
+ midX = (compFromX + compToX) / 2
+ midY = (compFromY + compToY) / 2
+ board(midX, midY) = 0
+ drawSquare midX, midY
End If
- Swap lau(cx1, cy1), lau(cx2, cy2)
- showr cx1, cy1
- showr cx2, cy2
+ Swap board(compFromX, compFromY), board(compToX, compToY)
+ drawSquare compFromX, compFromY
+ drawSquare compToX, compToY
End Sub
-Sub thinkh
- msg "Your turn.", 14
+Sub humanMove
+ ' The human's turn: wait for a typed move and play it.
+ showMessage "Your turn.", 14
5
- freet
- If humx1 = 0 Then GoTo 5
- Swap lau(humx2, humy2), lau(humx1, humy1)
- showr humx1, humy1
- showr humx2, humy2
- If Abs(humx1 - humx2) = 2 Then
- cx3 = (humx1 + humx2) / 2
- cy3 = (humy1 + humy2) / 2
- lau(cx3, cy3) = 0
- showr cx3, cy3
+ ' Wait until the player types a move ("m <from> <to>", see doCommand).
+ pollKeys
+ If humFromX = 0 Then GoTo 5
+ Swap board(humToX, humToY), board(humFromX, humFromY)
+ drawSquare humFromX, humFromY
+ drawSquare humToX, humToY
+ ' If the move was a jump, remove the captured piece from the middle square.
+ If Abs(humFromX - humToX) = 2 Then
+ midX = (humFromX + humToX) / 2
+ midY = (humFromY + humToY) / 2
+ board(midX, midY) = 0
+ drawSquare midX, midY
End If
- humx1 = 0
+ humFromX = 0
End Sub
DECLARE SUB formula (x!, y!, z!)\r
-DECLARE SUB graaf ()\r
-DECLARE SUB mkgr3 (x1!, y1!, z1!)\r
-DECLARE SUB mkgr2 (x1!, y1!, z1!)\r
-DECLARE SUB mkgr (x1!, y1!, z1!)\r
+DECLARE SUB buildSurface ()\r
+DECLARE SUB makeGridXZ (x1!, y1!, z1!)\r
+DECLARE SUB makeGridXY (x1!, y1!, z1!)\r
+DECLARE SUB makeGridZY (x1!, y1!, z1!)\r
DECLARE SUB start ()\r
-DECLARE SUB getcor ()\r
-DECLARE SUB nait3d ()\r
+DECLARE SUB setupScene ()\r
+DECLARE SUB mainLoop ()\r
' 3D heightmap explorer. Allows to visualize heightmap for arbitrary function.\r
' Inspect and edit function "formula" to visualize alternative mathematical functions.\r
\r
' Changelog:\r
' 2002, Initial version\r
' 2024.09, Improved program readability\r
+' 2026, Improved program readability\r
\r
' Keyboard controls:\r
' Cursor keys - move around\r
\r
' Type your formula to sub module "formula".\r
' X & Y are surface coordinates. Z must be formula\r
-' result, indicating height. "tm" variable counts\r
+' result, indicating height. "frameCount" variable counts\r
' frames. Use it in your formula to make graph moving in time.\r
\r
DIM SHARED vertexX(4000), vertexY(4000), vertexZ(4000)\r
DIM SHARED x(4000), y(4000), z(4000)\r
\r
DIM SHARED xo(4000), yo(4000), zo(4000)\r
+' NOTE: in QB45 a scalar and an array may share one name with separate\r
+' storage. xo/yo/zo are used BOTH as scalars (camera-relative coordinates\r
+' in mainLoop) and as arrays xo()/yo() that remember each vertex position\r
+' from the previous frame, so stale lines can be erased before redrawing.\r
DIM SHARED linePoint1(4000), linePoint2(4000)\r
DIM SHARED lineColor(4000)\r
DIM SHARED vertexCount, lineCount\r
-DIM SHARED tmvertexCount, tmlineCount, tm\r
-DIM SHARED myx, myy, myz, mye, myk\r
+DIM SHARED staticVertexCount, staticLineCount, frameCount\r
+DIM SHARED camX, camY, camZ, speedForward, speedSideways\r
\r
-myx = 520\r
-myy = -250\r
-myz = -1000\r
-tm = 0\r
+camX = 520\r
+camY = -250\r
+camZ = -1000\r
+frameCount = 0\r
\r
+' On numeric overflow or similar, print a message and keep running (RESUME).\r
ON ERROR GOTO 3\r
start\r
\r
-nait3d\r
+mainLoop\r
\r
3\r
+' Estonian: "Somewhere in the program a number went over the allowed limits!!!"\r
PRINT "Kuskil programmis l�ks mingi arv �le lubatud piiride!!!"\r
RESUME\r
\r
-' This subroutine initializes the coordinate system and sets up the grid.\r
-SUB getcor\r
- c = 12\r
+SUB setupScene\r
+ ' Set up the static scene: background measuring grids and the 3D cross.\r
+ drawColor = 12 ' light red\r
\r
' Create background 2D grids along every axis in 3D space\r
' to help viewer perceive scale.\r
- mkgr -500, 0, 0\r
- mkgr2 0, 0, 500\r
- mkgr3 0, -500, 0\r
+ makeGridZY -500, 0, 0\r
+ makeGridXY 0, 0, 500\r
+ makeGridXZ 0, -500, 0\r
\r
' Place center-crossing pink lines across every axis (3D cross).\r
' This is to help viewer to see where zero point on the graph is.\r
' Add lines for the 3D cross.\r
linePoint1(lineCount + 1) = vertexCount + 1\r
linePoint2(lineCount + 1) = vertexCount + 2\r
- lineColor(lineCount + 1) = c\r
+ lineColor(lineCount + 1) = drawColor\r
\r
linePoint1(lineCount + 2) = vertexCount + 3\r
linePoint2(lineCount + 2) = vertexCount + 4\r
- lineColor(lineCount + 2) = c\r
+ lineColor(lineCount + 2) = drawColor\r
\r
linePoint1(lineCount + 3) = vertexCount + 5\r
linePoint2(lineCount + 3) = vertexCount + 6\r
- lineColor(lineCount + 3) = c\r
+ lineColor(lineCount + 3) = drawColor\r
\r
' Update the vertex and line counts\r
vertexCount = vertexCount + 6\r
lineCount = lineCount + 3\r
- tmvertexCount = vertexCount\r
- tmlineCount = lineCount\r
+ staticVertexCount = vertexCount\r
+ staticLineCount = lineCount\r
END SUB\r
\r
-' This subroutine generates a grid of points based on the formula\r
-SUB graaf\r
- c = 14\r
+SUB buildSurface\r
+ ' Build the heightmap surface: evaluate the formula on a 21x21 point\r
+ ' grid and connect neighbors into the yellow mesh. Rebuilt every frame.\r
+ drawColor = 14 ' yellow\r
\r
- d = 0\r
- e = 0\r
+ vertsAdded = 0\r
+ linesAdded = 0\r
FOR x = -500 TO 500 STEP 50\r
FOR z = -500 TO 500 STEP 50\r
\r
' Increment the vertex count and add a new vertex\r
- d = d + 1\r
- vertexX(vertexCount + d) = x\r
+ vertsAdded = vertsAdded + 1\r
+ vertexX(vertexCount + vertsAdded) = x\r
formula x / 50, z / 50, y ' evaluate formula that we want to visualize\r
- vertexY(vertexCount + d) = y * 50\r
- vertexZ(vertexCount + d) = z\r
+ vertexY(vertexCount + vertsAdded) = y * 50\r
+ vertexZ(vertexCount + vertsAdded) = z\r
\r
' Connect current point on the grid with neighbors\r
IF z > -500 THEN\r
- e = e + 1\r
- linePoint1(lineCount + e) = vertexCount + d\r
- linePoint2(lineCount + e) = vertexCount + d - 1\r
- lineColor(lineCount + e) = c\r
+ linesAdded = linesAdded + 1\r
+ linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded\r
+ linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 1\r
+ lineColor(lineCount + linesAdded) = drawColor\r
END IF\r
\r
IF x > -500 THEN\r
- e = e + 1\r
- linePoint1(lineCount + e) = vertexCount + d\r
- linePoint2(lineCount + e) = vertexCount + d - 21\r
- lineColor(lineCount + e) = c\r
+ linesAdded = linesAdded + 1\r
+ linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded\r
+ linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 21\r
+ lineColor(lineCount + linesAdded) = drawColor\r
END IF\r
\r
NEXT z\r
NEXT x\r
\r
' Update the vertex and line counts\r
- vertexCount = vertexCount + d\r
- lineCount = lineCount + e\r
+ vertexCount = vertexCount + vertsAdded\r
+ lineCount = lineCount + linesAdded\r
END SUB\r
\r
-' This subroutine generates a measuring grid in the ZY plane.\r
-SUB mkgr (x1, y1, z1)\r
- c = 3\r
+SUB makeGridZY (x1, y1, z1)\r
+ ' Generate a measuring grid in the ZY plane (drawn cyan).\r
+ drawColor = 3\r
\r
- d = 0\r
- e = 0\r
+ vertsAdded = 0\r
+ linesAdded = 0\r
FOR z = -500 TO 500 STEP 100\r
FOR y = -500 TO 500 STEP 100\r
\r
' Increment the vertex count and add a new vertex\r
- d = d + 1\r
- vertexX(vertexCount + d) = x1\r
- vertexY(vertexCount + d) = y1 + y\r
- vertexZ(vertexCount + d) = z1 + z\r
+ vertsAdded = vertsAdded + 1\r
+ vertexX(vertexCount + vertsAdded) = x1\r
+ vertexY(vertexCount + vertsAdded) = y1 + y\r
+ vertexZ(vertexCount + vertsAdded) = z1 + z\r
\r
' Add lines to the line array if necessary\r
IF y > -500 THEN\r
- e = e + 1\r
- linePoint1(lineCount + e) = vertexCount + d\r
- linePoint2(lineCount + e) = vertexCount + d - 1\r
- lineColor(lineCount + e) = c\r
+ linesAdded = linesAdded + 1\r
+ linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded\r
+ linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 1\r
+ lineColor(lineCount + linesAdded) = drawColor\r
END IF\r
\r
IF z > -500 THEN\r
- e = e + 1\r
- linePoint1(lineCount + e) = vertexCount + d\r
- linePoint2(lineCount + e) = vertexCount + d - 11\r
- lineColor(lineCount + e) = c\r
+ linesAdded = linesAdded + 1\r
+ linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded\r
+ linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 11\r
+ lineColor(lineCount + linesAdded) = drawColor\r
END IF\r
\r
NEXT y\r
NEXT z\r
\r
' Update the vertex and line counts\r
- vertexCount = vertexCount + d\r
- lineCount = lineCount + e\r
+ vertexCount = vertexCount + vertsAdded\r
+ lineCount = lineCount + linesAdded\r
END SUB\r
\r
-' This subroutine generates a measuring grid XY plane.\r
-SUB mkgr2 (x1, y1, z1)\r
- c = 3\r
+SUB makeGridXY (x1, y1, z1)\r
+ ' Generate a measuring grid in the XY plane (drawn cyan).\r
+ drawColor = 3\r
\r
- d = 0\r
- e = 0\r
+ vertsAdded = 0\r
+ linesAdded = 0\r
FOR x = -500 TO 500 STEP 100\r
FOR y = -500 TO 500 STEP 100\r
\r
' Increment the vertex count and add a new vertex\r
- d = d + 1\r
- vertexX(vertexCount + d) = x1 + x\r
- vertexY(vertexCount + d) = y1 + y\r
- vertexZ(vertexCount + d) = z1\r
+ vertsAdded = vertsAdded + 1\r
+ vertexX(vertexCount + vertsAdded) = x1 + x\r
+ vertexY(vertexCount + vertsAdded) = y1 + y\r
+ vertexZ(vertexCount + vertsAdded) = z1\r
\r
' Add lines to the line array if necessary\r
IF y > -500 THEN\r
- e = e + 1\r
- linePoint1(lineCount + e) = vertexCount + d\r
- linePoint2(lineCount + e) = vertexCount + d - 1\r
- lineColor(lineCount + e) = c\r
+ linesAdded = linesAdded + 1\r
+ linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded\r
+ linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 1\r
+ lineColor(lineCount + linesAdded) = drawColor\r
END IF\r
\r
IF x > -500 THEN\r
- e = e + 1\r
- linePoint1(lineCount + e) = vertexCount + d\r
- linePoint2(lineCount + e) = vertexCount + d - 11\r
- lineColor(lineCount + e) = c\r
+ linesAdded = linesAdded + 1\r
+ linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded\r
+ linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 11\r
+ lineColor(lineCount + linesAdded) = drawColor\r
END IF\r
\r
NEXT y\r
NEXT x\r
\r
' Update the vertex and line counts\r
- vertexCount = vertexCount + d\r
- lineCount = lineCount + e\r
+ vertexCount = vertexCount + vertsAdded\r
+ lineCount = lineCount + linesAdded\r
END SUB\r
\r
-' This subroutine generates a measuring grid in the XZ plane.\r
-SUB mkgr3 (x1, y1, z1)\r
- c = 3\r
+SUB makeGridXZ (x1, y1, z1)\r
+ ' Generate a measuring grid in the XZ plane (drawn cyan).\r
+ drawColor = 3\r
\r
- d = 0\r
- e = 0\r
+ vertsAdded = 0\r
+ linesAdded = 0\r
FOR x = -500 TO 500 STEP 100\r
FOR z = -500 TO 500 STEP 100\r
\r
' Increment the vertex count and add a new vertex\r
- d = d + 1\r
- vertexX(vertexCount + d) = x1 + x\r
- vertexY(vertexCount + d) = y1\r
- vertexZ(vertexCount + d) = z\r
+ vertsAdded = vertsAdded + 1\r
+ vertexX(vertexCount + vertsAdded) = x1 + x\r
+ vertexY(vertexCount + vertsAdded) = y1\r
+ vertexZ(vertexCount + vertsAdded) = z\r
\r
' Add lines to the line array if necessary\r
IF z > -500 THEN\r
- e = e + 1\r
- linePoint1(lineCount + e) = vertexCount + d\r
- linePoint2(lineCount + e) = vertexCount + d - 1\r
- lineColor(lineCount + e) = c\r
+ linesAdded = linesAdded + 1\r
+ linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded\r
+ linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 1\r
+ lineColor(lineCount + linesAdded) = drawColor\r
END IF\r
\r
IF x > -500 THEN\r
- e = e + 1\r
- linePoint1(lineCount + e) = vertexCount + d\r
- linePoint2(lineCount + e) = vertexCount + d - 11\r
- lineColor(lineCount + e) = c\r
+ linesAdded = linesAdded + 1\r
+ linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded\r
+ linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 11\r
+ lineColor(lineCount + linesAdded) = drawColor\r
END IF\r
\r
NEXT z\r
NEXT x\r
\r
' Update the vertex and line counts\r
- vertexCount = vertexCount + d\r
- lineCount = lineCount + e\r
+ vertexCount = vertexCount + vertsAdded\r
+ lineCount = lineCount + linesAdded\r
END SUB\r
\r
-' This subroutine renders the 3D scene.\r
-SUB nait3d\r
+SUB mainLoop\r
+' Main loop: rebuild the animated surface, advance the camera, erase and\r
+' redraw all lines, handle keyboard input, repeat.\r
\r
1\r
-SOUND 0, .5\r
-vertexCount = tmvertexCount\r
-lineCount = tmlineCount\r
-tm = tm + 1\r
-graaf\r
+SOUND 0, .5 ' sub-second delay workaround: 0 Hz tone is inaudible, only waits\r
+vertexCount = staticVertexCount\r
+lineCount = staticLineCount\r
+frameCount = frameCount + 1\r
+buildSurface\r
\r
-myx = myx + SIN(deg1) * mye\r
-myz = myz + COS(deg1) * mye\r
+' Move the camera: forward and sideways relative to the view direction.\r
+camX = camX + SIN(camAngle1) * speedForward\r
+camZ = camZ + COS(camAngle1) * speedForward\r
\r
-myx = myx + COS(deg1) * myk\r
-myz = myz - SIN(deg1) * myk\r
+camX = camX + COS(camAngle1) * speedSideways\r
+camZ = camZ - SIN(camAngle1) * speedSideways\r
\r
-myy = myy + myyp\r
+' Climb or sink.\r
+camY = camY + speedY\r
\r
-deg1 = deg1 + d1\r
-Deg2 = Deg2 + d2\r
+' Spin the view by the current spin speeds.\r
+camAngle1 = camAngle1 + spinSpeed1\r
+camAngle2 = camAngle2 + spinSpeed2\r
\r
-C1 = COS(deg1): S1 = SIN(deg1)\r
-C2 = COS(Deg2): S2 = SIN(Deg2)\r
+cosAngle1 = COS(camAngle1): sinAngle1 = SIN(camAngle1)\r
+cosAngle2 = COS(camAngle2): sinAngle2 = SIN(camAngle2)\r
\r
' Transform the vertices to 3D space\r
FOR a = 1 TO vertexCount\r
\r
- xo = vertexX(a) - myx\r
- yo = -vertexY(a) - myy\r
- zo = vertexZ(a) - myz\r
+ xo = vertexX(a) - camX\r
+ yo = -vertexY(a) - camY\r
+ zo = vertexZ(a) - camZ\r
\r
' Apply rotation transformations\r
- x1 = (xo * C1 - zo * S1)\r
- z1 = (xo * S1 + zo * C1)\r
+ x1 = (xo * cosAngle1 - zo * sinAngle1)\r
+ z1 = (xo * sinAngle1 + zo * cosAngle1)\r
\r
- y1 = (yo * C2 - z1 * S2)\r
- z2 = (yo * S2 + z1 * C2)\r
+ y1 = (yo * cosAngle2 - z1 * sinAngle2)\r
+ z2 = (yo * sinAngle2 + z1 * cosAngle2)\r
\r
' Project the vertices onto the 2D screen\r
xo(a) = x(a)\r
\r
' Draw the lines on the screen\r
FOR a = 1 TO lineCount\r
- p1 = linePoint1(a)\r
- p2 = linePoint2(a)\r
+ endPoint1 = linePoint1(a)\r
+ endPoint2 = linePoint2(a)\r
\r
' Skip drawing if either point is off-screen\r
- IF xo(p1) = -1 OR xo(p2) = -1 THEN\r
+ IF xo(endPoint1) = -1 OR xo(endPoint2) = -1 THEN\r
' Do nothing\r
ELSE\r
' erase line at previous position\r
- LINE (xo(p1), yo(p1))-(xo(p2), yo(p2)), 0\r
+ LINE (xo(endPoint1), yo(endPoint1))-(xo(endPoint2), yo(endPoint2)), 0\r
' draw line at new position\r
- LINE (x(p1), y(p1))-(x(p2), y(p2)), lineColor(a)\r
+ LINE (x(endPoint1), y(endPoint1))-(x(endPoint2), y(endPoint2)), lineColor(a)\r
END IF\r
\r
NEXT\r
\r
-' Handle keyboard input\r
-K$ = INKEY$\r
-IF K$ <> "" THEN\r
+' Handle keyboard input: cursor keys = forward/sideways speed, +/- = vertical\r
+' speed, 4/6/8/2 = spin speeds, space = halve all motion, q/ESC = quit.\r
+keyPress$ = INKEY$\r
+IF keyPress$ <> "" THEN\r
\r
- SELECT CASE K$\r
+ SELECT CASE keyPress$\r
\r
CASE CHR$(0) + "P"\r
- mye = mye - 3\r
+ speedForward = speedForward - 3\r
\r
CASE CHR$(0) + "H"\r
- mye = mye + 3\r
+ speedForward = speedForward + 3\r
\r
CASE CHR$(0) + "M"\r
- myk = myk + 3\r
+ speedSideways = speedSideways + 3\r
\r
CASE CHR$(0) + "K"\r
- myk = myk - 3\r
+ speedSideways = speedSideways - 3\r
\r
CASE "+"\r
- myyp = myyp + 5\r
+ speedY = speedY + 5\r
\r
CASE "-"\r
- myyp = myyp - 5\r
+ speedY = speedY - 5\r
\r
CASE "6"\r
- d1 = d1 + .01\r
+ spinSpeed1 = spinSpeed1 + .01\r
\r
CASE "4"\r
- d1 = d1 - .01\r
+ spinSpeed1 = spinSpeed1 - .01\r
\r
CASE "8"\r
- d2 = d2 - .01\r
+ spinSpeed2 = spinSpeed2 - .01\r
\r
CASE "2"\r
- d2 = d2 + .01\r
+ spinSpeed2 = spinSpeed2 + .01\r
\r
CASE " "\r
- d1 = d1 / 2\r
- d2 = d2 / 2\r
- d3 = d3 / 2\r
- mye = mye / 2\r
- myk = myk / 2\r
- myyp = myyp / 2\r
+ ' halve everything (spinSpeed3 is a leftover, not used anywhere else)\r
+ spinSpeed1 = spinSpeed1 / 2\r
+ spinSpeed2 = spinSpeed2 / 2\r
+ spinSpeed3 = spinSpeed3 / 2\r
+ speedForward = speedForward / 2\r
+ speedSideways = speedSideways / 2\r
+ speedY = speedY / 2\r
\r
CASE "q"\r
SYSTEM\r
GOTO 1\r
END SUB\r
\r
-' This subroutine initializes the graphics and sets up the program.\r
SUB start\r
+' Set up graphics mode and build the static scene geometry.\r
SCREEN 12\r
CLS\r
\r
vertexCount = 0\r
lineCount = 0\r
\r
-getcor\r
+setupScene\r
\r
END SUB\r
\r
-' This subroutine calculates the height of a point based on the formula\r
SUB formula (x, y, z)\r
+' User-editable formula: return the surface height z for grid coordinate (x, y).\r
z = 0\r
v = SQR(x * x + y * y) ' v = distance from center, some formulas need it.\r
\r
' Apply the formula to calculate the height\r
-z = z + SIN(x + y) * SIN(tm / 10) ' diagonal lines\r
+z = z + SIN(x + y) * SIN(frameCount / 10) ' diagonal lines\r
z = z + (SQR((15 + v) * (15 - v)) - 10) ' top of the ball\r
\r
' As you see, multiple formulas can be enabled simultaneously.\r
' Few more example formulas that you can uncomment and enable.\r
' z = z + RND * 1 ' noise\r
-' z = z + SIN((y + tm) / 2) ' forward moving wave\r
+' z = z + SIN((y + frameCount) / 2) ' forward moving wave\r
' z = z + SIN(v / 2) * 2 ' circular waves\r
' z = z - SQR(v * 6) ' sharp peak\r
' z = z + SIN(y / 1.5) / 1.5 + COS(x / 1.5) / 1.5' custom 1\r
' z = z + SIN(y / 1.5) * COS(x / 1.5) / 1.5 ' custom 2\r
-' z = z + INT(SIN(1.5 * x * SIN(tm / 10))) * 3 ' custom 3\r
+' z = z + INT(SIN(1.5 * x * SIN(frameCount / 10))) * 3 ' custom 3\r
' z = z - INT(v / 5) * 3 + 3 ' custom 4\r
' z = z + 3 * ((-INT((x - .3) / 20) * INT((23 + x - ABS(y * 1.2)) / 15)) + -INT(-y / 20) * -INT(-x / 20) * INT(-((x - 2) * (x - 2) + (y * 1.2 - 4) * (y * 1.2 - 4)) / 2000 + 1.01) + -INT(y / 20) * -INT(-x / 20) * INT(-((x - 2) * (x - 2) + (y * 1.2 + 4) * (y * 1.2 + 4)) / 2000 + 1.01)) ' heart\r
\r
-DECLARE SUB jooks ()\r
-DECLARE SUB suva ()\r
-DECLARE SUB display ()\r
-DECLARE SUB clearBits ()\r
+' Test/demo program for the LPT attached 2 digit LED display.\r
+' Drives the same display hardware as the school clock (kk.bas).\r
+DECLARE SUB chaseDemo ()\r
+DECLARE SUB randomDemo ()\r
+DECLARE SUB refreshDisplay ()\r
+DECLARE SUB ledsOff ()\r
DEFINT A-Z\r
-DIM SHARED bit(0 TO 16)\r
+DIM SHARED ledBits(0 TO 16)\r
\r
-suva\r
-jooks\r
+randomDemo\r
+chaseDemo\r
\r
-clearBits\r
-bit(10) = 0\r
-bit(14) = 0\r
-bit(6) = 0\r
-bit(2) = 0\r
+ledsOff\r
+ledBits(10) = 0\r
+ledBits(14) = 0\r
+ledBits(6) = 0\r
+ledBits(2) = 0\r
4\r
GOTO 4\r
\r
-SUB clearBits\r
-' This subroutine initializes all bits in the bit array to 1\r
+SUB ledsOff\r
+' Turns all LEDs off: every position set to 1 (active low)\r
FOR a = 1 TO 16\r
- bit(a) = 1\r
+ ledBits(a) = 1\r
NEXT a\r
\r
END SUB\r
\r
-SUB display\r
-' This subroutine displays the current state of the bit array using LPT attached display\r
-prt = &H378\r
-d = 0\r
-FOR a = 0 TO 3\r
- c = 2 ^ a\r
+SUB refreshDisplay\r
+' Writes the 16 positions to the LPT data port, 4 per scan group\r
+lptData = &H378 ' LPT data port address\r
+bitIndex = 0\r
+FOR scanGroup = 0 TO 3\r
+ scanByte = 2 ^ scanGroup\r
FOR b = 4 TO 7\r
- d = d + 1\r
- c = c + (bit(d) * 2 ^ b)\r
+ bitIndex = bitIndex + 1\r
+ scanByte = scanByte + (ledBits(bitIndex) * 2 ^ b)\r
NEXT b\r
\r
- OUT prt, c\r
-NEXT a\r
+ OUT lptData, scanByte\r
+NEXT scanGroup\r
END SUB\r
\r
-SUB jooks\r
-' This subroutine demonstrates a simple counting\r
+SUB chaseDemo\r
+' Running light demo: one lit position chases through all 16\r
2\r
-clearBits\r
-FOR a = 1 TO 16\r
- bit(16) = 1 ' Set the most significant bit to 1\r
- bit(a - 1) = 1 ' Set the previous bit to 1\r
- bit(a) = 0 ' Clear the current bit\r
- PRINT a\r
+ledsOff\r
+FOR ledPos = 1 TO 16\r
+ ledBits(16) = 1 ' Previous top position back to off\r
+ ledBits(ledPos - 1) = 1 ' Previous position back to off\r
+ ledBits(ledPos) = 0 ' Light the current position (0 = on)\r
+ PRINT ledPos\r
FOR b = 1 TO 1000\r
- display\r
+ refreshDisplay\r
NEXT b\r
-NEXT a\r
+NEXT ledPos\r
GOTO 2\r
END SUB\r
\r
-SUB suva\r
-' This subroutine demonstrates a simple random bit setting algorithm\r
+SUB randomDemo\r
+' Random pattern demo: each position randomly on or off\r
3\r
-clearBits\r
+ledsOff\r
FOR b = 1 TO 16\r
- IF RND * 100 > 50 THEN bit(b) = 0 ' Randomly set bits to 0\r
+ IF RND * 100 > 50 THEN ledBits(b) = 0 ' Randomly set bits to 0\r
NEXT b\r
FOR b = 1 TO 100\r
- display\r
+ refreshDisplay\r
NEXT b\r
GOTO 3\r
END SUB\r
' Also it drives numerical 2 digit led display through parallel LPT printer port.
' Program is driven by special 3 button keyboard that is also attached to LPT port.
-DECLARE SUB num (a%)
-DECLARE SUB mntime ()
-DECLARE SUB showit ()
-DECLARE SUB ekrf (a%)
-DECLARE SUB ekr ()
-DECLARE SUB rese ()
-DECLARE SUB start ()
+DECLARE SUB showNumber (value%)
+DECLARE SUB menuTime ()
+DECLARE SUB showTime ()
+DECLARE SUB setDigit (digit%)
+DECLARE SUB refreshDisplay ()
+DECLARE SUB reloadSchedule ()
+DECLARE SUB initialize ()
DECLARE SUB boot ()
-DECLARE SUB getnad (g%, n%, d%, k%)
-DECLARE SUB initp (b$)
-DECLARE SUB getmd (a$, m, d)
-DECLARE SUB son (a$)
+DECLARE SUB findWeekDay (year%, month%, day%, dayOfWeek%)
+DECLARE SUB fetchDayPlan (planName$)
+DECLARE SUB parseMonthDay (dateStr$, month, day)
+DECLARE SUB splitWords (text$)
DEFINT A-Z
-DECLARE SUB inita ()
-DECLARE SUB chm ()
-DECLARE SUB chd ()
-DECLARE SUB kell (a%)
-DECLARE SUB sync2 ()
-DECLARE SUB sync ()
-DECLARE SUB mnmain ()
+DECLARE SUB fetchYearPlan ()
+DECLARE SUB checkBellTimes ()
+DECLARE SUB pickDayPlan ()
+DECLARE SUB ringBell (ringType%)
+DECLARE SUB roundToHour ()
+DECLARE SUB syncClock ()
+DECLARE SUB mainMenu ()
DECLARE SUB main ()
-DECLARE SUB getkey (kla%)
-DECLARE SUB klnait (k%)
-DECLARE SUB heli (a%)
-DECLARE SUB keys ()
-DECLARE SUB disp ()
-DIM SHARED bit(0 TO 7)
-DIM SHARED kl
-DIM SHARED hist(1 TO 3)
-DIM SHARED ap$(1 TO 500)
-DIM SHARED apl
-DIM SHARED pp$(1 TO 500)
-DIM SHARED ppl
-DIM SHARED prt, prt2
-DIM SHARED timo$
-DIM SHARED dato$
-DIM SHARED sona$(1 TO 50)
-DIM SHARED mitus
-DIM SHARED lp$
-DIM SHARED ndlp
-DIM SHARED pn$(1 TO 7)
-DIM SHARED bitt(1 TO 16)
-DIM SHARED modee, vilgu
-DIM SHARED tul(1 TO 2)
-
-start
-heli 4
-
-disp
-mnmain
-
-SUB chd
-b$ = "tuhi"
-IF apl = 0 THEN inita
-
-a$ = DATE$
-n1 = VAL(RIGHT$(a$, 4))
-n2 = VAL(LEFT$(a$, 2))
-a$ = LEFT$(a$, 5)
-n3 = VAL(RIGHT$(a$, 2))
-getnad n1, n2, n3, ndlp
+DECLARE SUB pollButtons (keyCode%)
+DECLARE SUB highlightButton (keyCode%)
+DECLARE SUB melody (tune%)
+DECLARE SUB scanButtons ()
+DECLARE SUB showTitle ()
+DIM SHARED btnBits(0 TO 7)
+DIM SHARED button
+DIM SHARED pressTicks(1 TO 3)
+DIM SHARED yearPlan$(1 TO 500)
+DIM SHARED yearPlanCount
+DIM SHARED dayPlan$(1 TO 500)
+DIM SHARED dayPlanCount
+DIM SHARED lptCtrl, lptData
+DIM SHARED lastTime$
+DIM SHARED lastDate$
+DIM SHARED words$(1 TO 50)
+DIM SHARED wordCount
+DIM SHARED dayPlanName$
+DIM SHARED weekDay
+DIM SHARED weekDayName$(1 TO 7)
+DIM SHARED ledBits(1 TO 16)
+DIM SHARED editMode, blinking
+DIM SHARED dotLed(1 TO 2)
+
+initialize
+melody 4 ' Startup jingle
+
+showTitle
+mainMenu ' Main menu loop (never returns)
+
+SUB pickDayPlan
+' Selects the day plan for today from the year plan and loads it
+planName$ = "tuhi" ' Default: empty plan
+IF yearPlanCount = 0 THEN fetchYearPlan
+
+dateStr$ = DATE$
+thisYear = VAL(RIGHT$(dateStr$, 4))
+thisMonth = VAL(LEFT$(dateStr$, 2))
+dateStr$ = LEFT$(dateStr$, 5)
+thisDay = VAL(RIGHT$(dateStr$, 2))
+findWeekDay thisYear, thisMonth, thisDay, weekDay
LOCATE 10, 1
-PRINT "Week plan:", pn$(ndlp)
-FOR a = 1 TO apl
-son ap$(a)
-SELECT CASE sona$(1)
+PRINT "Week plan:", weekDayName$(weekDay)
+FOR a = 1 TO yearPlanCount
+' Year plan entry: v = date range, n = weekday in range, e = single date
+splitWords yearPlan$(a)
+SELECT CASE words$(1)
CASE "v"
-getmd sona$(2), m1, d1
-getmd sona$(3), m2, d2
-getmd DATE$, m3, d3
-IF m3 < m1 THEN GOTO 9
-IF m3 > m2 THEN GOTO 9
-IF m3 = m1 THEN IF d3 < d1 THEN GOTO 9
-IF m3 = m2 THEN IF d3 > d2 THEN GOTO 9
-b$ = sona$(4)
+parseMonthDay words$(2), startMonth, startDay
+parseMonthDay words$(3), endMonth, endDay
+parseMonthDay DATE$, nowMonth, nowDay
+IF nowMonth < startMonth THEN GOTO 9
+IF nowMonth > endMonth THEN GOTO 9
+IF nowMonth = startMonth THEN IF nowDay < startDay THEN GOTO 9
+IF nowMonth = endMonth THEN IF nowDay > endDay THEN GOTO 9
+planName$ = words$(4)
CASE "n"
-getmd sona$(2), m1, d1
-getmd sona$(3), m2, d2
-getmd DATE$, m3, d3
-IF m3 < m1 THEN GOTO 9
-IF m3 > m2 THEN GOTO 9
-IF m3 = m1 THEN IF d3 < d1 THEN GOTO 9
-IF m3 = m2 THEN IF d3 > d2 THEN GOTO 9
-IF ndlp <> VAL(sona$(4)) THEN GOTO 9
-b$ = sona$(5)
+parseMonthDay words$(2), startMonth, startDay
+parseMonthDay words$(3), endMonth, endDay
+parseMonthDay DATE$, nowMonth, nowDay
+IF nowMonth < startMonth THEN GOTO 9
+IF nowMonth > endMonth THEN GOTO 9
+IF nowMonth = startMonth THEN IF nowDay < startDay THEN GOTO 9
+IF nowMonth = endMonth THEN IF nowDay > endDay THEN GOTO 9
+IF weekDay <> VAL(words$(4)) THEN GOTO 9
+planName$ = words$(5)
CASE "e"
-getmd sona$(2), m1, d1
-getmd DATE$, m2, d2
-IF (m1 = m2) AND (d1 = d2) THEN b$ = sona$(3)
+parseMonthDay words$(2), startMonth, startDay
+parseMonthDay DATE$, endMonth, endDay
+IF (startMonth = endMonth) AND (startDay = endDay) THEN planName$ = words$(3)
END SELECT
-9
+9 ' Entry did not match, try the next one
NEXT a
-IF b$ <> lp$ THEN initp b$
-lp$ = b$
+IF planName$ <> dayPlanName$ THEN fetchDayPlan planName$
+dayPlanName$ = planName$
LOCATE 9, 1
-PRINT "Day plan:", lp$
+PRINT "Day plan:", dayPlanName$
END SUB
-SUB chm
-showit
-a$ = DATE$
-IF a$ <> dato$ THEN chd
-dato$ = a$
-b = 0
-FOR a = 1 TO ppl
-son pp$(a)
-SELECT CASE sona$(1)
+SUB checkBellTimes
+' Runs on every minute change: reloads plans when needed, rings the bell on schedule
+showTime
+dateStr$ = DATE$
+IF dateStr$ <> lastDate$ THEN pickDayPlan
+lastDate$ = dateStr$
+ringType = 0
+' Look for a bell entry (# HH:MM sis|val) matching the current time
+FOR a = 1 TO dayPlanCount
+splitWords dayPlan$(a)
+SELECT CASE words$(1)
CASE "#"
-getmd sona$(2), h1, m1
-getmd TIME$, h2, m2
-' PRINT h1, m1, h2, m2
-IF (h2 = h1) AND (m2 = m1) THEN
-IF sona$(3) = "sis" THEN b = 1
-IF sona$(3) = "val" THEN b = 2
+parseMonthDay words$(2), planHour, planMin
+parseMonthDay TIME$, nowHour, nowMin
+' PRINT planHour, planMin, nowHour, nowMin
+IF (nowHour = planHour) AND (nowMin = planMin) THEN
+IF words$(3) = "sis" THEN ringType = 1
+IF words$(3) = "val" THEN ringType = 2
END IF
END SELECT
NEXT a
-IF b > 0 THEN kell b
+IF ringType > 0 THEN ringBell ringType
END SUB
-SUB disp
+SUB showTitle
+' Clears the screen and shows the program title
CLS
PRINT "Kooli Kell v 1.2 2002.10.10"
PRINT "Programmi autor Svjatoslav Agejenko"
END SUB
-SUB ekr
-FOR e = 1 TO 10
-c = 1
-c = c + 16 * bitt(1)
-c = c + 32 * bitt(2)
-c = c + 64 * bitt(3)
-c = c + 128 * bitt(4)
-OUT prt2, c
-
-c = 2
-c = c + 16 * bitt(5)
-c = c + 32 * bitt(6)
-c = c + 64 * bitt(7)
-c = c + 128 * bitt(8)
-OUT prt2, c
-
-c = 4
-c = c + 16 * bitt(9)
-c = c + 32 * bitt(10)
-c = c + 64 * bitt(11)
-c = c + 128 * bitt(12)
-OUT prt2, c
-
-c = 8
-c = c + 16 * bitt(13)
-c = c + 32 * bitt(14)
-c = c + 64 * bitt(15)
-c = c + 128 * bitt(16)
-OUT prt2, c
+SUB refreshDisplay
+' Writes the LED segment bits to the LPT data port
+' Low nibble = digit group select, high nibble = 4 segment bits (1 = off)
+FOR e = 1 TO 10 ' Refresh repeatedly so the display looks steady
+scanByte = 1
+scanByte = scanByte + 16 * ledBits(1)
+scanByte = scanByte + 32 * ledBits(2)
+scanByte = scanByte + 64 * ledBits(3)
+scanByte = scanByte + 128 * ledBits(4)
+OUT lptData, scanByte
+
+scanByte = 2
+scanByte = scanByte + 16 * ledBits(5)
+scanByte = scanByte + 32 * ledBits(6)
+scanByte = scanByte + 64 * ledBits(7)
+scanByte = scanByte + 128 * ledBits(8)
+OUT lptData, scanByte
+
+scanByte = 4
+scanByte = scanByte + 16 * ledBits(9)
+scanByte = scanByte + 32 * ledBits(10)
+scanByte = scanByte + 64 * ledBits(11)
+scanByte = scanByte + 128 * ledBits(12)
+OUT lptData, scanByte
+
+scanByte = 8
+scanByte = scanByte + 16 * ledBits(13)
+scanByte = scanByte + 32 * ledBits(14)
+scanByte = scanByte + 64 * ledBits(15)
+scanByte = scanByte + 128 * ledBits(16)
+OUT lptData, scanByte
NEXT e
END SUB
-SUB ekrf (a)
-SELECT CASE (a)
+SUB setDigit (digit)
+' Lights the LED segments forming one digit (0-9 = first digit, 10-19 = second)
+' 0 = segment on, 1 = segment off; bits 1-8 = first digit, 9-16 = second
+SELECT CASE (digit)
CASE 0
-bitt(1) = 0
-bitt(2) = 0
-bitt(3) = 0
-bitt(7) = 0
-bitt(5) = 0
-bitt(6) = 0
-bitt(8) = 1
+ledBits(1) = 0
+ledBits(2) = 0
+ledBits(3) = 0
+ledBits(7) = 0
+ledBits(5) = 0
+ledBits(6) = 0
+ledBits(8) = 1
CASE 1
-bitt(2) = 0
-bitt(7) = 0
+ledBits(2) = 0
+ledBits(7) = 0
CASE 2
-bitt(1) = 0
-bitt(3) = 0
-bitt(5) = 0
-bitt(7) = 0
-bitt(8) = 0
+ledBits(1) = 0
+ledBits(3) = 0
+ledBits(5) = 0
+ledBits(7) = 0
+ledBits(8) = 0
CASE 3
-bitt(1) = 0
-bitt(2) = 0
-bitt(5) = 0
-bitt(8) = 0
-bitt(7) = 0
+ledBits(1) = 0
+ledBits(2) = 0
+ledBits(5) = 0
+ledBits(8) = 0
+ledBits(7) = 0
CASE 4
-bitt(2) = 0
-bitt(6) = 0
-bitt(7) = 0
-bitt(8) = 0
+ledBits(2) = 0
+ledBits(6) = 0
+ledBits(7) = 0
+ledBits(8) = 0
CASE 5
-bitt(1) = 0
-bitt(2) = 0
-bitt(5) = 0
-bitt(6) = 0
-bitt(8) = 0
+ledBits(1) = 0
+ledBits(2) = 0
+ledBits(5) = 0
+ledBits(6) = 0
+ledBits(8) = 0
CASE 6
-bitt(1) = 0
-bitt(2) = 0
-bitt(3) = 0
-bitt(5) = 0
-bitt(6) = 0
-bitt(8) = 0
+ledBits(1) = 0
+ledBits(2) = 0
+ledBits(3) = 0
+ledBits(5) = 0
+ledBits(6) = 0
+ledBits(8) = 0
CASE 7
-bitt(2) = 0
-bitt(7) = 0
-bitt(5) = 0
+ledBits(2) = 0
+ledBits(7) = 0
+ledBits(5) = 0
CASE 8
-bitt(1) = 0
-bitt(2) = 0
-bitt(3) = 0
-bitt(7) = 0
-bitt(5) = 0
-bitt(6) = 0
-bitt(8) = 0
+ledBits(1) = 0
+ledBits(2) = 0
+ledBits(3) = 0
+ledBits(7) = 0
+ledBits(5) = 0
+ledBits(6) = 0
+ledBits(8) = 0
CASE 9
-bitt(1) = 0
-bitt(2) = 0
-bitt(7) = 0
-bitt(5) = 0
-bitt(6) = 0
-bitt(8) = 0
+ledBits(1) = 0
+ledBits(2) = 0
+ledBits(7) = 0
+ledBits(5) = 0
+ledBits(6) = 0
+ledBits(8) = 0
CASE 10
-bitt(15) = 0
-bitt(16) = 0
-bitt(12) = 0
-bitt(10) = 0
-bitt(9) = 0
-bitt(4) = 0
+ledBits(15) = 0
+ledBits(16) = 0
+ledBits(12) = 0
+ledBits(10) = 0
+ledBits(9) = 0
+ledBits(4) = 0
CASE 11
-bitt(15) = 0
-bitt(4) = 0
+ledBits(15) = 0
+ledBits(4) = 0
CASE 12
-bitt(15) = 0
-bitt(16) = 0
-bitt(9) = 0
-bitt(10) = 0
-bitt(11) = 0
+ledBits(15) = 0
+ledBits(16) = 0
+ledBits(9) = 0
+ledBits(10) = 0
+ledBits(11) = 0
CASE 13
-bitt(15) = 0
-bitt(4) = 0
-bitt(16) = 0
-bitt(11) = 0
-bitt(9) = 0
+ledBits(15) = 0
+ledBits(4) = 0
+ledBits(16) = 0
+ledBits(11) = 0
+ledBits(9) = 0
CASE 14
-bitt(15) = 0
-bitt(4) = 0
-bitt(12) = 0
-bitt(11) = 0
+ledBits(15) = 0
+ledBits(4) = 0
+ledBits(12) = 0
+ledBits(11) = 0
CASE 15
-bitt(9) = 0
-bitt(4) = 0
-bitt(11) = 0
-bitt(12) = 0
-bitt(16) = 0
+ledBits(9) = 0
+ledBits(4) = 0
+ledBits(11) = 0
+ledBits(12) = 0
+ledBits(16) = 0
CASE 16
-bitt(9) = 0
-bitt(4) = 0
-bitt(11) = 0
-bitt(12) = 0
-bitt(16) = 0
-bitt(10) = 0
+ledBits(9) = 0
+ledBits(4) = 0
+ledBits(11) = 0
+ledBits(12) = 0
+ledBits(16) = 0
+ledBits(10) = 0
CASE 17
-bitt(4) = 0
-bitt(15) = 0
-bitt(16) = 0
+ledBits(4) = 0
+ledBits(15) = 0
+ledBits(16) = 0
CASE 18
-bitt(4) = 0
-bitt(15) = 0
-bitt(16) = 0
-bitt(12) = 0
-bitt(11) = 0
-bitt(10) = 0
-bitt(9) = 0
+ledBits(4) = 0
+ledBits(15) = 0
+ledBits(16) = 0
+ledBits(12) = 0
+ledBits(11) = 0
+ledBits(10) = 0
+ledBits(9) = 0
CASE 19
-bitt(4) = 0
-bitt(15) = 0
-bitt(16) = 0
-bitt(12) = 0
-bitt(11) = 0
-bitt(9) = 0
+ledBits(4) = 0
+ledBits(15) = 0
+ledBits(16) = 0
+ledBits(12) = 0
+ledBits(11) = 0
+ledBits(9) = 0
END SELECT
END SUB
-SUB getkey (kla)
+SUB pollButtons (keyCode)
+' Main input loop: polls the buttons, detects clicks and double-clicks
-' Read the state of the buttons on the keyboard
+' Blink the dot LEDs while the time editing menu is active
1
-IF vilgu = 1 THEN
-tmr = tmr + 1
-IF tmr > 5 THEN bitt(13) = tul(1): bitt(14) = tul(2) ELSE bitt(13) = 1: bitt(14) = 1
-IF tmr > 10 THEN
-tmr = 0
+IF blinking = 1 THEN
+blinkCount = blinkCount + 1
+IF blinkCount > 5 THEN ledBits(13) = dotLed(1): ledBits(14) = dotLed(2) ELSE ledBits(13) = 1: ledBits(14) = 1
+IF blinkCount > 10 THEN
+blinkCount = 0
END IF
ELSE
-bitt(13) = tul(1)
-bitt(14) = tul(2)
+ledBits(13) = dotLed(1)
+ledBits(14) = dotLed(2)
END IF
' Get the current time
-b$ = LEFT$(TIME$, 5)
-IF b$ <> timo$ THEN chm
-timo$ = b$
-hist(1) = hist(1) + 1
-IF hist(1) > 20000 THEN hist(1) = 15000
-hist(2) = hist(2) + 1
-IF hist(2) > 20000 THEN hist(2) = 15000
-hist(3) = hist(3) + 1
-IF hist(3) > 20000 THEN hist(3) = 15000
+nowTime$ = LEFT$(TIME$, 5)
+IF nowTime$ <> lastTime$ THEN checkBellTimes
+lastTime$ = nowTime$
+' Count poll ticks since each button press (click/double-click timing)
+pressTicks(1) = pressTicks(1) + 1
+IF pressTicks(1) > 20000 THEN pressTicks(1) = 15000
+pressTicks(2) = pressTicks(2) + 1
+IF pressTicks(2) > 20000 THEN pressTicks(2) = 15000
+pressTicks(3) = pressTicks(3) + 1
+IF pressTicks(3) > 20000 THEN pressTicks(3) = 15000
' Read the state of the buttons on the keyboard
-keys
-IF kl > 0 THEN
- IF hist(kl) > 1 AND hist(kl) < 9 THEN
- klnait kl + 3
- kla = kl + 3
+scanButtons
+' Released and pressed again within 2-8 ticks = double-click
+IF button > 0 THEN
+ IF pressTicks(button) > 1 AND pressTicks(button) < 9 THEN
+ highlightButton button + 3
+ keyCode = button + 3
GOTO 4
ELSE
- hist(kl) = 0
+ pressTicks(button) = 0
END IF
END IF
-IF hist(1) = 10 THEN klnait 1: kla = 1: GOTO 4
-IF hist(2) = 10 THEN klnait 2: kla = 2: GOTO 4
-IF hist(3) = 10 THEN klnait 3: kla = 3: GOTO 4
+' Held down for 10 ticks = single click
+IF pressTicks(1) = 10 THEN highlightButton 1: keyCode = 1: GOTO 4
+IF pressTicks(2) = 10 THEN highlightButton 2: keyCode = 2: GOTO 4
+IF pressTicks(3) = 10 THEN highlightButton 3: keyCode = 3: GOTO 4
-IF hist(1) > 11 AND hist(2) > 11 AND hist(3) > 11 THEN klnait 0
+IF pressTicks(1) > 11 AND pressTicks(2) > 11 AND pressTicks(3) > 11 THEN highlightButton 0 ' All released: clear highlight
' Display current time and date
LOCATE 7, 1
4
' Reset the button press count
-hist(1) = 10000
-hist(2) = 10000
-hist(3) = 10000
+pressTicks(1) = 10000
+pressTicks(2) = 10000
+pressTicks(3) = 10000
' Play a sound to indicate button press
FOR b = 1 TO 100
-SOUND 0, .1
+SOUND 0, .1 ' SOUND 0 = sub-second delay workaround (inaudible)
NEXT b
-IF kla > 3 THEN SOUND 4000, .1 ELSE SOUND 3000, .1
+IF keyCode > 3 THEN SOUND 4000, .1 ELSE SOUND 3000, .1 ' Higher pitch for double-click
END SUB
-SUB getmd (a$, m, d)
-b$ = LEFT$(a$, 5)
-m = VAL(LEFT$(b$, 2))
-d = VAL(RIGHT$(b$, 2))
+SUB parseMonthDay (dateStr$, month, day)
+' Extracts month and day numbers from an MM-DD string
+monthDay$ = LEFT$(dateStr$, 5)
+month = VAL(LEFT$(monthDay$, 2))
+day = VAL(RIGHT$(monthDay$, 2))
END SUB
-SUB getnad (g, n, d, k)
+SUB findWeekDay (year, month, day, dayOfWeek)
+' Returns the day of week (1 = Monday .. 7 = Sunday) for a date
LOCATE 11, 1
-PRINT g, n, d
-p = g
-m = n - 2
-IF n > 2 GOTO 120
-p = p - 1: m = m + 12
+PRINT year, month, day
+' Zeller's congruence; Jan/Feb count as months 13/14 of the previous year
+zYear = year
+zMonth = month - 2
+IF month > 2 GOTO 120
+zYear = zYear - 1: zMonth = zMonth + 12
120
-c = INT(p / 100)
-y = p - c * 100
-w = d + INT((13 * m - 1) / 5) + y + INT(y / 4) + INT(c / 4) - 2 * c
-k = w - 7 * INT(w / 7)
-IF k = 0 THEN k = 7
+century = INT(zYear / 100)
+shortYear = zYear - century * 100
+zeller = day + INT((13 * zMonth - 1) / 5) + shortYear + INT(shortYear / 4) + INT(century / 4) - 2 * century
+dayOfWeek = zeller - 7 * INT(zeller / 7)
+IF dayOfWeek = 0 THEN dayOfWeek = 7 ' Sunday
END SUB
-SUB heli (a)
+SUB melody (tune)
+' Plays one of the sound effects through the PC speaker
'GOTO 10
-SELECT CASE a
+SELECT CASE tune
CASE 1
FOR c = 1 TO 5
SOUND 3000, 1
-SOUND 0, 1
+SOUND 0, 1 ' SOUND 0 = sub-second delay workaround (inaudible)
NEXT c
CASE 2
SOUND 2500, 10
CASE 3
-FOR a = 1 TO 10
+FOR tune = 1 TO 10
SOUND 500, .5
SOUND 1500, .5
SOUND 2000, .5
SOUND 1520, .5
-NEXT a
+NEXT tune
CASE 4
-FOR a = 800 TO 1000 STEP 10
-SOUND a, .1
-SOUND a * 3, .1
+FOR tune = 800 TO 1000 STEP 10
+SOUND tune, .1
+SOUND tune * 3, .1
SOUND 0, 1
-NEXT a
+NEXT tune
10
END SELECT
END SUB
-SUB inita
-apl = 0
-OPEN "aasta.ap" FOR INPUT AS #1
+SUB fetchYearPlan
+' Loads the year plan (aasta.ap) into memory
+yearPlanCount = 0
+OPEN "aasta.ap" FOR INPUT AS #1 ' Year plan
5
IF EOF(1) <> 0 THEN GOTO 3
-LINE INPUT #1, a$
-apl = apl + 1
-ap$(apl) = a$
+LINE INPUT #1, textLine$
+yearPlanCount = yearPlanCount + 1
+yearPlan$(yearPlanCount) = textLine$
GOTO 5
3
CLOSE #1
END SUB
-SUB initp (b$)
-ppl = 0
-OPEN b$ + ".pp" FOR INPUT AS #1
+SUB fetchDayPlan (planName$)
+' Loads a day plan (<name>.pp) into memory
+dayPlanCount = 0
+OPEN planName$ + ".pp" FOR INPUT AS #1 ' Day plan
6
IF EOF(1) <> 0 THEN GOTO 7
-LINE INPUT #1, a$
-ppl = ppl + 1
-pp$(ppl) = a$
+LINE INPUT #1, textLine$
+dayPlanCount = dayPlanCount + 1
+dayPlan$(dayPlanCount) = textLine$
GOTO 6
7
CLOSE #1
END SUB
-SUB kell (a)
-heli 3
+SUB ringBell (ringType)
+' Rings the school bell through the LPT relay (1 = lesson start, 2 = lesson end)
+melody 3
-SELECT CASE a
+SELECT CASE ringType
CASE 1
-OUT prt, 255
+OUT lptCtrl, 255 ' Relay on: bell rings
+' SOUND 0 below = sub-second delay workaround (inaudible)
FOR b = 1 TO 80
SOUND 0, 1
NEXT b
-OUT prt, 0
+OUT lptCtrl, 0 ' Relay off
FOR b = 1 TO 15
SOUND 0, 1
NEXT b
-OUT prt, 255
+OUT lptCtrl, 255
FOR b = 1 TO 15
SOUND 0, 1
NEXT b
-OUT prt, 0
+OUT lptCtrl, 0
CASE 2
-OUT prt, 255
+OUT lptCtrl, 255
FOR b = 1 TO 80
SOUND 0, 1
NEXT b
-OUT prt, 0
+OUT lptCtrl, 0
END SELECT
END SUB
-SUB keys
-kl = 0
-OUT prt, 0
+SUB scanButtons
+' Reads the 3 button keyboard attached to the LPT port
+button = 0
+OUT lptCtrl, 0
8
-a = INP(prt)
-b = INP(prt)
-IF a <> b THEN GOTO 8
+' Read the port twice and keep the stable value (debounce)
+portByte = INP(lptCtrl)
+b = INP(lptCtrl)
+IF portByte <> b THEN GOTO 8
+' Split the port byte into individual bits
b = 128
-FOR c = 0 TO 7
-d = INT(a / b)
-bit(c) = d
-a = a - (b * d)
+FOR bitNum = 0 TO 7
+bitValue = INT(portByte / b)
+btnBits(bitNum) = bitValue
+portByte = portByte - (b * bitValue)
b = b / 2
-NEXT c
-
-IF bit(4) = 1 AND bit(6) = 1 THEN bit(4) = 0: bit(6) = 0: kl = 3
-IF bit(6) = 1 THEN kl = 2
-IF bit(4) = 1 THEN kl = 1
-
-a$ = INKEY$
-IF a$ = CHR$(0) + "K" THEN kl = 1
-IF a$ = CHR$(0) + "M" THEN kl = 2
-IF a$ = CHR$(0) + "P" THEN kl = 3
-ekr
+NEXT bitNum
+
+' The three buttons are wired to port bits 4 and 6
+IF btnBits(4) = 1 AND btnBits(6) = 1 THEN btnBits(4) = 0: btnBits(6) = 0: button = 3
+IF btnBits(6) = 1 THEN button = 2
+IF btnBits(4) = 1 THEN button = 1
+
+' Cursor keys emulate the buttons without the hardware
+keyHit$ = INKEY$
+IF keyHit$ = CHR$(0) + "K" THEN button = 1
+IF keyHit$ = CHR$(0) + "M" THEN button = 2
+IF keyHit$ = CHR$(0) + "P" THEN button = 3
+refreshDisplay
END SUB
-SUB klnait (k)
+SUB highlightButton (keyCode)
+' Highlights the pressed button on screen (4-6 = double-click, shown yellow)
' Highlight the pressed button on the display
-IF k = 3 THEN c = 3 ELSE c = 1
-IF k = 6 THEN c = 14
+IF keyCode = 3 THEN bgColor = 3 ELSE bgColor = 1
+IF keyCode = 6 THEN bgColor = 14
LOCATE 5, 6
-COLOR 7, c
+COLOR 7, bgColor
PRINT "<kesk>"
COLOR 7, 0
' Highlight the pressed button on the display
-IF k = 1 THEN c = 3 ELSE c = 1
-IF k = 4 THEN c = 14
+IF keyCode = 1 THEN bgColor = 3 ELSE bgColor = 1
+IF keyCode = 4 THEN bgColor = 14
LOCATE 4, 1
-COLOR 7, c
+COLOR 7, bgColor
PRINT "<vasak>"
COLOR 7, 0
-IF k = 2 THEN c = 3 ELSE c = 1
-IF k = 5 THEN c = 14
+IF keyCode = 2 THEN bgColor = 3 ELSE bgColor = 1
+IF keyCode = 5 THEN bgColor = 14
LOCATE 4, 10
-COLOR 7, c
+COLOR 7, bgColor
PRINT "<parem>"
COLOR 7, 0
END SUB
-SUB mnmain
+SUB mainMenu
+' Main menu: maps button codes to actions, loops forever
+' Codes: 1/2/3 = click on button 1/2/3, 4/5/6 = double-click
2
-getkey a
-IF a = 6 THEN sync
-IF a = 3 THEN sync2
+pollButtons keyCode
+IF keyCode = 6 THEN syncClock
+IF keyCode = 3 THEN roundToHour
-IF a = 1 THEN kell 1
-IF a = 4 THEN kell 2
+IF keyCode = 1 THEN ringBell 1
+IF keyCode = 4 THEN ringBell 2
-IF a = 2 THEN mntime
-IF a = 5 THEN rese
+IF keyCode = 2 THEN menuTime
+IF keyCode = 5 THEN reloadSchedule
GOTO 2
END SUB
-SUB mntime
-vilgu = 1
+SUB menuTime
+' Time editing menu: buttons adjust the system time
+' editMode 1 = adjust hours, 2 = adjust minutes
+blinking = 1
11
-showit
-getkey a
-
-IF modee = 1 THEN
- b = VAL(LEFT$(TIME$, 2))
- c = 0
- IF a = 1 THEN c = 1: b = b - 1
- IF a = 2 THEN c = 1: b = b + 1
- IF b < 0 THEN b = 0
- IF b > 23 THEN b = 23
- d$ = STR$(b)
- IF LEFT$(d$, 1) = " " THEN d$ = RIGHT$(d$, LEN(d$) - 1)
- IF LEN(d$) < 2 THEN d$ = "0" + d$
- e$ = d$ + RIGHT$(TIME$, 6)
- IF c = 1 THEN TIME$ = e$
+showTime
+pollButtons keyCode
+
+IF editMode = 1 THEN
+ editValue = VAL(LEFT$(TIME$, 2))
+ changed = 0
+ IF keyCode = 1 THEN changed = 1: editValue = editValue - 1
+ IF keyCode = 2 THEN changed = 1: editValue = editValue + 1
+ IF editValue < 0 THEN editValue = 0
+ IF editValue > 23 THEN editValue = 23
+ twoDigit$ = STR$(editValue)
+ IF LEFT$(twoDigit$, 1) = " " THEN twoDigit$ = RIGHT$(twoDigit$, LEN(twoDigit$) - 1)
+ IF LEN(twoDigit$) < 2 THEN twoDigit$ = "0" + twoDigit$
+ newTime$ = twoDigit$ + RIGHT$(TIME$, 6)
+ IF changed = 1 THEN TIME$ = newTime$
ELSE
- b = VAL(RIGHT$(LEFT$(TIME$, 5), 2))
- c = 0
- IF a = 1 THEN c = 1: b = b - 1
- IF a = 2 THEN c = 1: b = b + 1
- IF b < 0 THEN b = 0
- IF b > 59 THEN b = 59
- d$ = STR$(b)
- IF LEFT$(d$, 1) = " " THEN d$ = RIGHT$(d$, LEN(d$) - 1)
- IF LEN(d$) < 2 THEN d$ = "0" + d$
- e$ = LEFT$(TIME$, 3) + d$ + RIGHT$(TIME$, 3)
- IF c = 1 THEN TIME$ = e$
+ editValue = VAL(RIGHT$(LEFT$(TIME$, 5), 2))
+ changed = 0
+ IF keyCode = 1 THEN changed = 1: editValue = editValue - 1
+ IF keyCode = 2 THEN changed = 1: editValue = editValue + 1
+ IF editValue < 0 THEN editValue = 0
+ IF editValue > 59 THEN editValue = 59
+ twoDigit$ = STR$(editValue)
+ IF LEFT$(twoDigit$, 1) = " " THEN twoDigit$ = RIGHT$(twoDigit$, LEN(twoDigit$) - 1)
+ IF LEN(twoDigit$) < 2 THEN twoDigit$ = "0" + twoDigit$
+ newTime$ = LEFT$(TIME$, 3) + twoDigit$ + RIGHT$(TIME$, 3)
+ IF changed = 1 THEN TIME$ = newTime$
END IF
-IF a = 3 THEN
-IF modee = 1 THEN modee = 2 ELSE modee = 1
+IF keyCode = 3 THEN
+IF editMode = 1 THEN editMode = 2 ELSE editMode = 1
END IF
-IF a = 6 THEN GOTO 12
+IF keyCode = 6 THEN GOTO 12
GOTO 11
12
-vilgu = 0
-modee = 2
+blinking = 0
+editMode = 2 ' 1 = show hours, 2 = show minutes
END SUB
-SUB num (a)
+SUB showNumber (value)
+' Shows a two digit number on the LED display
-FOR b = 1 TO 12
-bitt(b) = 1
-NEXT b
-bitt(15) = 1
-bitt(16) = 1
+FOR tens = 1 TO 12
+ledBits(tens) = 1
+NEXT tens
+ledBits(15) = 1
+ledBits(16) = 1
-b = INT(a / 10)
-c = a - (10 * b)
-ekrf b
-ekrf c + 10
+tens = INT(value / 10)
+ones = value - (10 * tens)
+setDigit tens
+setDigit ones + 10
END SUB
-SUB rese
-heli 4
-timo$ = ""
-dato$ = ""
-apl = 0
+SUB reloadSchedule
+' Reloads the schedules after the plan files were edited
+melody 4
+lastTime$ = ""
+lastDate$ = ""
+yearPlanCount = 0
END SUB
-SUB showit
-a$ = LEFT$(TIME$, 5)
-IF modee = 1 THEN
-b = VAL(LEFT$(a$, 2))
-tul(1) = 1
-tul(2) = 0
+SUB showTime
+' Shows the current hours or minutes on the LED display
+' The dot LED marks whether hours or minutes are shown
+hm$ = LEFT$(TIME$, 5)
+IF editMode = 1 THEN
+shownValue = VAL(LEFT$(hm$, 2))
+dotLed(1) = 1
+dotLed(2) = 0
ELSE
-b = VAL(RIGHT$(a$, 2))
-tul(1) = 0
-tul(2) = 1
+shownValue = VAL(RIGHT$(hm$, 2))
+dotLed(1) = 0
+dotLed(2) = 1
END IF
LOCATE 15, 1
-PRINT b
-num b
+PRINT shownValue
+showNumber shownValue
END SUB
-SUB son (a$)
+SUB splitWords (text$)
+' Splits a plan file line into separate words
-FOR b = 1 TO 50
-sona$(b) = ""
-NEXT b
-mitus = 0
+FOR newWord = 1 TO 50
+words$(newWord) = ""
+NEXT newWord
+wordCount = 0
-b = 1
-FOR c = 1 TO LEN(a$)
-d$ = RIGHT$(LEFT$(a$, c), 1)
-IF d$ = " " OR d$ = CHR$(9) THEN
-b = 1
+newWord = 1
+FOR charPos = 1 TO LEN(text$)
+curChar$ = RIGHT$(LEFT$(text$, charPos), 1)
+IF curChar$ = " " OR curChar$ = CHR$(9) THEN ' Space or tab separates words
+newWord = 1
ELSE
-IF b = 1 THEN b = 0: mitus = mitus + 1
-sona$(mitus) = sona$(mitus) + d$
+IF newWord = 1 THEN newWord = 0: wordCount = wordCount + 1
+words$(wordCount) = words$(wordCount) + curChar$
END IF
-NEXT c
+NEXT charPos
END SUB
-SUB start
-pn$(1) = "Monday"
-pn$(2) = "Tuesday"
-pn$(3) = "Wednesday"
-pn$(4) = "Thursday"
-pn$(5) = "Friday"
-pn$(6) = "Saturday"
-pn$(7) = "Sunday"
-
-prt = &H37A
-prt2 = &H378
-hist(1) = 10000
-hist(2) = 10000
-hist(3) = 10000
+SUB initialize
+' Sets up port addresses and initial variable values
+weekDayName$(1) = "Monday"
+weekDayName$(2) = "Tuesday"
+weekDayName$(3) = "Wednesday"
+weekDayName$(4) = "Thursday"
+weekDayName$(5) = "Friday"
+weekDayName$(6) = "Saturday"
+weekDayName$(7) = "Sunday"
+
+lptCtrl = &H37A ' LPT control port: bell relay out, buttons in
+lptData = &H378 ' LPT data port: LED display out
+pressTicks(1) = 10000
+pressTicks(2) = 10000
+pressTicks(3) = 10000
FOR a = 1 TO 16
-bitt(a) = 1
+ledBits(a) = 1 ' All LEDs off (active low)
NEXT a
-modee = 2
-vilgu = 0
-tul(1) = 1
-tul(2) = 1
+editMode = 2
+blinking = 0
+dotLed(1) = 1
+dotLed(2) = 1
END SUB
-SUB sync
+SUB syncClock
+' Loads date and time from sync.txt into the system clock
OPEN "sync.txt" FOR INPUT AS #1
-LINE INPUT #1, a$
-DATE$ = a$
-LINE INPUT #1, a$
-TIME$ = a$
+LINE INPUT #1, textLine$
+DATE$ = textLine$
+LINE INPUT #1, textLine$
+TIME$ = textLine$
CLOSE #1
-heli 2
+melody 2
END SUB
-SUB sync2
-a$ = TIME$
-a$ = LEFT$(a$, 5)
-b = VAL(RIGHT$(a$, 2))
-c = VAL(LEFT$(a$, 2))
-IF b >= 30 THEN c = c + 1
-b = 0
-IF c > 23 THEN c = c - 24
-a$ = RIGHT$(STR$(c), LEN(STR$(c)) - 1)
-b$ = RIGHT$(STR$(b), LEN(STR$(b)) - 1)
-IF LEN(a$) < 2 THEN a$ = "0" + a$
-IF LEN(b$) < 2 THEN b$ = "0" + b$
-a$ = a$ + ":" + b$
+SUB roundToHour
+' Rounds the system time to the nearest full hour
+timeStr$ = TIME$
+timeStr$ = LEFT$(timeStr$, 5)
+minutes = VAL(RIGHT$(timeStr$, 2))
+hours = VAL(LEFT$(timeStr$, 2))
+IF minutes >= 30 THEN hours = hours + 1 ' Round up from 30 minutes
+minutes = 0
+IF hours > 23 THEN hours = hours - 24
+timeStr$ = RIGHT$(STR$(hours), LEN(STR$(hours)) - 1)
+minStr$ = RIGHT$(STR$(minutes), LEN(STR$(minutes)) - 1)
+IF LEN(timeStr$) < 2 THEN timeStr$ = "0" + timeStr$
+IF LEN(minStr$) < 2 THEN minStr$ = "0" + minStr$
+timeStr$ = timeStr$ + ":" + minStr$
'LOCATE 10, 1
-'PRINT a$
+'PRINT timeStr$
-TIME$ = a$
+TIME$ = timeStr$
-heli 1
+melody 1
END SUB
-DECLARE SUB dispt ()\r
+DECLARE SUB showskipmsg ()\r
' Svjatoslav Agejenko\r
' E-mail: svjatoslav@svjatoslav.eu\r
' Homepage: www.hot.ee/n0/\r
-\r
-DECLARE SUB dispp ()\r
-DECLARE SUB displukk ()\r
-DECLARE SUB kola (a%)\r
-DECLARE SUB rese ()\r
-DECLARE SUB start ()\r
-DECLARE SUB getnad (g%, n%, d%, k%)\r
-DECLARE SUB initp (b$)\r
-DECLARE SUB getmd (a$, m%, d%)\r
-DECLARE SUB son (a$)\r
-DECLARE SUB inita ()\r
-DECLARE SUB chm ()\r
-DECLARE SUB chd ()\r
-DECLARE SUB kell (a%)\r
-DECLARE SUB sync2 ()\r
-DECLARE SUB sync ()\r
-DECLARE SUB mnmain ()\r
-DECLARE SUB heli (a%)\r
-DECLARE SUB disp ()\r
+'\r
+' School bell scheduler (mini version): rings a bell relay connected to the\r
+' parallel port, driven by timetable files (aasta.ap = year plan selecting\r
+' which <name>.pp day-plan file to use; a day plan lists the bell times).\r
+\r
+DECLARE SUB showdayinfo ()\r
+DECLARE SUB showlockmsg ()\r
+DECLARE SUB ringbell (seconds%)\r
+DECLARE SUB resetprogram ()\r
+DECLARE SUB initprogram ()\r
+DECLARE SUB getweekday (yr%, mon%, dy%, wdout%)\r
+DECLARE SUB loadplan (planbase$)\r
+DECLARE SUB parsedate (datestr$, monthnum%, daynum%)\r
+DECLARE SUB splitwords (txt$)\r
+DECLARE SUB loadyearplan ()\r
+DECLARE SUB checkminute ()\r
+DECLARE SUB checkdate ()\r
+DECLARE SUB ringevent (ringtype%)\r
+DECLARE SUB roundtohour ()\r
+DECLARE SUB loadsyncfile ()\r
+DECLARE SUB mainloop ()\r
+DECLARE SUB playsound (sndnum%)\r
+DECLARE SUB drawscreen ()\r
DEFINT A-Z\r
\r
-DIM SHARED ap$(1 TO 500)\r
-DIM SHARED apl\r
-DIM SHARED pp$(1 TO 500)\r
-DIM SHARED ppl\r
-DIM SHARED prt, prt2\r
-DIM SHARED timo$\r
-DIM SHARED dato$\r
-DIM SHARED sona$(1 TO 50)\r
-DIM SHARED mitus\r
-DIM SHARED lp$\r
-DIM SHARED ndlp\r
-DIM SHARED pn$(1 TO 7)\r
-DIM SHARED lk$\r
-DIM SHARED ssave\r
-DIM SHARED ssavel\r
-DIM SHARED timero AS LONG\r
-DIM SHARED kblukk\r
-DIM SHARED tunnidara\r
-\r
-start\r
-\r
-\r
-disp\r
-mnmain\r
-\r
-SUB chd\r
-b$ = "tuhi"\r
-IF apl = 0 THEN inita\r
-\r
-a$ = DATE$\r
-n1 = VAL(RIGHT$(a$, 4))\r
-n2 = VAL(LEFT$(a$, 2))\r
-a$ = LEFT$(a$, 5)\r
-n3 = VAL(RIGHT$(a$, 2))\r
-getnad n1, n2, n3, ndlp\r
-FOR a = 1 TO apl\r
-son ap$(a)\r
-SELECT CASE sona$(1)\r
-CASE "v"\r
-getmd sona$(2), m1, d1\r
-getmd sona$(3), m2, d2\r
-getmd DATE$, m3, d3\r
-IF m3 < m1 THEN GOTO 9\r
-IF m3 > m2 THEN GOTO 9\r
-IF m3 = m1 THEN IF d3 < d1 THEN GOTO 9\r
-IF m3 = m2 THEN IF d3 > d2 THEN GOTO 9\r
-b$ = sona$(4)\r
-CASE "n"\r
-getmd sona$(2), m1, d1\r
-getmd sona$(3), m2, d2\r
-getmd DATE$, m3, d3\r
-IF m3 < m1 THEN GOTO 9\r
-IF m3 > m2 THEN GOTO 9\r
-IF m3 = m1 THEN IF d3 < d1 THEN GOTO 9\r
-IF m3 = m2 THEN IF d3 > d2 THEN GOTO 9\r
-IF ndlp <> VAL(sona$(4)) THEN GOTO 9\r
-b$ = sona$(5)\r
-CASE "e"\r
-getmd sona$(2), m1, d1\r
-getmd DATE$, m2, d2\r
-IF (m1 = m2) AND (d1 = d2) THEN b$ = sona$(3)\r
+DIM SHARED yearplan$(1 TO 500)\r
+DIM SHARED yearplancount\r
+DIM SHARED dayplan$(1 TO 500)\r
+DIM SHARED dayplancount\r
+DIM SHARED lptport, prt2\r
+DIM SHARED lasttime$\r
+DIM SHARED lastdate$\r
+DIM SHARED words$(1 TO 50)\r
+DIM SHARED wordcount\r
+DIM SHARED loadedplan$\r
+DIM SHARED weekdaynum\r
+DIM SHARED dayname$(1 TO 7)\r
+DIM SHARED lastbell$\r
+DIM SHARED idlecount\r
+DIM SHARED idlelimit\r
+DIM SHARED timersnap AS LONG\r
+DIM SHARED keylock\r
+DIM SHARED dayoff\r
+\r
+initprogram\r
+\r
+\r
+drawscreen\r
+mainloop\r
+\r
+SUB checkdate\r
+ ' Selects today's day-plan file from the year plan (runs when the date changes).\r
+selplan$ = "tuhi" ' default plan name when no rule matches (tuhi = empty)\r
+IF yearplancount = 0 THEN loadyearplan\r
+\r
+tmp$ = DATE$\r
+yr = VAL(RIGHT$(tmp$, 4))\r
+mon = VAL(LEFT$(tmp$, 2))\r
+tmp$ = LEFT$(tmp$, 5)\r
+dy = VAL(RIGHT$(tmp$, 2))\r
+getweekday yr, mon, dy, weekdaynum\r
+FOR i = 1 TO yearplancount\r
+splitwords yearplan$(i)\r
+SELECT CASE words$(1)\r
+CASE "v" ' v <from> <to> <plan> = plan active within a date range\r
+parsedate words$(2), beginmon, beginday\r
+parsedate words$(3), endmon, endday\r
+parsedate DATE$, curmon, curday\r
+IF curmon < beginmon THEN GOTO 9\r
+IF curmon > endmon THEN GOTO 9\r
+IF curmon = beginmon THEN IF curday < beginday THEN GOTO 9\r
+IF curmon = endmon THEN IF curday > endday THEN GOTO 9\r
+selplan$ = words$(4)\r
+CASE "n" ' n <from> <to> <weekday> <plan> = plan active on one weekday in a range\r
+parsedate words$(2), beginmon, beginday\r
+parsedate words$(3), endmon, endday\r
+parsedate DATE$, curmon, curday\r
+IF curmon < beginmon THEN GOTO 9\r
+IF curmon > endmon THEN GOTO 9\r
+IF curmon = beginmon THEN IF curday < beginday THEN GOTO 9\r
+IF curmon = endmon THEN IF curday > endday THEN GOTO 9\r
+IF weekdaynum <> VAL(words$(4)) THEN GOTO 9\r
+selplan$ = words$(5)\r
+CASE "e" ' e <date> <plan> = plan active on one exact date\r
+parsedate words$(2), beginmon, beginday\r
+parsedate DATE$, endmon, endday\r
+IF (beginmon = endmon) AND (beginday = endday) THEN selplan$ = words$(3)\r
END SELECT\r
9\r
-NEXT a\r
+NEXT i\r
\r
-IF b$ <> lp$ THEN initp b$\r
-lp$ = b$\r
-tunnidara = 0\r
-dispp\r
-disp\r
+IF selplan$ <> loadedplan$ THEN loadplan selplan$\r
+loadedplan$ = selplan$\r
+dayoff = 0\r
+showdayinfo\r
+drawscreen\r
END SUB\r
\r
-SUB chm\r
-a$ = DATE$\r
-IF a$ <> dato$ THEN chd\r
-dato$ = a$\r
-b = 0\r
-FOR a = 1 TO ppl\r
-son pp$(a)\r
-SELECT CASE sona$(1)\r
-CASE "#"\r
-getmd sona$(2), h1, m1\r
-getmd TIME$, h2, m2\r
+SUB checkminute\r
+ ' Minute tick: scans the day plan for bell events matching the current time.\r
+tmp$ = DATE$\r
+IF tmp$ <> lastdate$ THEN checkdate\r
+lastdate$ = tmp$\r
+ringtype = 0\r
+FOR i = 1 TO dayplancount\r
+splitwords dayplan$(i)\r
+SELECT CASE words$(1)\r
+CASE "#" ' timetable entry: # HH:MM sis|val (sis = lesson start, val = lesson end)\r
+parsedate words$(2), bellhour, bellmin\r
+parsedate TIME$, nowhour, nowmin\r
' PRINT h1, m1, h2, m2\r
-IF (h2 = h1) AND (m2 = m1) THEN\r
-IF sona$(3) = "sis" THEN b = 1\r
-IF sona$(3) = "val" THEN b = 2\r
+IF (nowhour = bellhour) AND (nowmin = bellmin) THEN\r
+IF words$(3) = "sis" THEN ringtype = 1\r
+IF words$(3) = "val" THEN ringtype = 2\r
END IF\r
END SELECT\r
-NEXT a\r
+NEXT i\r
\r
-IF (tunnidara = 0) AND (b > 0) THEN kell b\r
-ssave = ssave + 1\r
+IF (dayoff = 0) AND (ringtype > 0) THEN ringevent ringtype ' ring only when lessons are not skipped today\r
+idlecount = idlecount + 1\r
END SUB\r
\r
-SUB disp\r
+SUB drawscreen\r
+ ' Draws the main screen: title, key help, day-plan list and status fields.\r
CLS\r
PRINT "Kooli Kell (mini) v 1.1 2003.3"\r
PRINT "Programmi autor Svjatoslav Agejenko E-mail: n0@hot.ee"\r
PRINT "r - programmi restart q - programmist v�lja"\r
PRINT " j - j�tab k�ik tunnid t�na �ra"\r
\r
-dispp\r
+showdayinfo\r
\r
LOCATE 12, 15\r
PRINT "Kuu-P�ev-Aasta (USA standard)"\r
\r
LOCATE 17\r
\r
-FOR a = 1 TO ppl\r
-IF pp$(a) <> SPACE$(LEN(pp$(a))) THEN\r
- PRINT pp$(a);\r
- PRINT SPACE$(15 - LEN(pp$(a)));\r
+FOR i = 1 TO dayplancount\r
+IF dayplan$(i) <> SPACE$(LEN(dayplan$(i))) THEN\r
+ PRINT dayplan$(i);\r
+ PRINT SPACE$(15 - LEN(dayplan$(i)));\r
END IF\r
-NEXT a\r
+NEXT i\r
\r
-displukk\r
-dispt\r
+showlockmsg\r
+showskipmsg\r
END SUB\r
\r
-SUB displukk\r
+SUB showlockmsg\r
+ ' Shows or clears the "keyboard locked" warning in the top row.\r
LOCATE 1, 40\r
-IF kblukk = 1 THEN\r
+IF keylock = 1 THEN\r
COLOR 0, 7\r
PRINT "Klaviatuur lukus! Vajuta CTRL+L"\r
COLOR 7, 0\r
END IF\r
END SUB\r
\r
-SUB dispp\r
-IF ndlp = 0 THEN GOTO 14\r
+SUB showdayinfo\r
+ ' Shows the current weekday name and the active day-plan name.\r
+IF weekdaynum = 0 THEN GOTO 14\r
LOCATE 14, 1\r
-PRINT "n�dalap�ev:", pn$(ndlp)\r
+PRINT "n�dalap�ev:", dayname$(weekdaynum)\r
LOCATE 15, 1\r
-PRINT "p�evaplaan:", lp$\r
+PRINT "p�evaplaan:", loadedplan$\r
14\r
END SUB\r
\r
-SUB dispt\r
+SUB showskipmsg\r
+ ' Shows or clears the "all lessons skipped today" notice.\r
LOCATE 16, 20\r
COLOR 12 + 15, 0\r
-IF tunnidara = 1 THEN\r
+IF dayoff = 1 THEN\r
PRINT "T�na on k�ik tunnid �ra j�etud"\r
ELSE\r
PRINT " "\r
COLOR 7, 0\r
END SUB\r
\r
-SUB getmd (a$, m, d)\r
-b$ = LEFT$(a$, 5)\r
-m = VAL(LEFT$(b$, 2))\r
-d = VAL(RIGHT$(b$, 2))\r
+SUB parsedate (datestr$, monthnum, daynum)\r
+ ' Parses month and day numbers out of an MM-DD-YYYY style date string.\r
+tmp$ = LEFT$(datestr$, 5)\r
+monthnum = VAL(LEFT$(tmp$, 2))\r
+daynum = VAL(RIGHT$(tmp$, 2))\r
\r
END SUB\r
\r
-SUB getnad (g, n, d, k)\r
+SUB getweekday (yr, mon, dy, wdout)\r
+ ' Zeller's congruence: computes the weekday (1=Monday..7=Sunday) of a date.\r
'LOCATE 11, 1\r
'PRINT g, n, d\r
-p = g\r
-m = n - 2\r
-IF n > 2 GOTO 120\r
-p = p - 1: m = m + 12\r
+adjyear = yr\r
+adjmon = mon - 2\r
+IF mon > 2 GOTO 120\r
+adjyear = adjyear - 1: adjmon = adjmon + 12\r
120\r
-c = INT(p / 100)\r
-y = p - c * 100\r
-w = d + INT((13 * m - 1) / 5) + y + INT(y / 4) + INT(c / 4) - 2 * c\r
-k = w - 7 * INT(w / 7)\r
-IF k = 0 THEN k = 7\r
+century = INT(adjyear / 100)\r
+shortyear = adjyear - century * 100\r
+zeller = dy + INT((13 * adjmon - 1) / 5) + shortyear + INT(shortyear / 4) + INT(century / 4) - 2 * century\r
+wdout = zeller - 7 * INT(zeller / 7)\r
+IF wdout = 0 THEN wdout = 7\r
END SUB\r
\r
-SUB heli (a)\r
+SUB playsound (sndnum)\r
+ ' Plays one of four sound effects (sndnum = effect number).\r
'GOTO 10\r
-SELECT CASE a\r
+SELECT CASE sndnum\r
CASE 1\r
-FOR c = 1 TO 5\r
+FOR i = 1 TO 5\r
SOUND 3000, 1\r
-SOUND 0, 1\r
-NEXT c\r
+SOUND 0, 1 ' SOUND 0, n = sub-second delay workaround (inaudible 0 Hz tone)\r
+NEXT i\r
\r
CASE 2\r
-FOR c = 1 TO 5\r
+FOR i = 1 TO 5\r
SOUND 2500, 1\r
-SOUND 0, 2\r
-NEXT c\r
+SOUND 0, 2 ' SOUND 0, n = sub-second delay workaround (inaudible 0 Hz tone)\r
+NEXT i\r
SOUND 2500, 10\r
\r
CASE 3\r
-FOR a = 1 TO 10\r
+FOR i = 1 TO 10\r
SOUND 500, .5\r
SOUND 1500, .5\r
SOUND 2000, .5\r
SOUND 1520, .5\r
-NEXT a\r
+NEXT i\r
\r
\r
CASE 4\r
-FOR a = 800 TO 1000 STEP 10\r
-SOUND a, .1\r
-SOUND a * 3, .1\r
-SOUND 0, 1\r
-NEXT a\r
+FOR freq = 800 TO 1000 STEP 10\r
+SOUND freq, .1\r
+SOUND freq * 3, .1\r
+SOUND 0, 1 ' SOUND 0, n = sub-second delay workaround (inaudible 0 Hz tone)\r
+NEXT freq\r
10\r
\r
END SELECT\r
\r
END SUB\r
\r
-SUB inita\r
-apl = 0\r
+SUB loadyearplan\r
+ ' Loads the year-plan file aasta.ap into the yearplan$ array.\r
+yearplancount = 0\r
OPEN "aasta.ap" FOR INPUT AS #1\r
5\r
IF EOF(1) <> 0 THEN GOTO 3\r
-LINE INPUT #1, a$\r
-apl = apl + 1\r
-ap$(apl) = a$\r
+LINE INPUT #1, tmp$\r
+yearplancount = yearplancount + 1\r
+yearplan$(yearplancount) = tmp$\r
GOTO 5\r
3\r
CLOSE #1\r
END SUB\r
\r
-SUB initp (b$)\r
-ppl = 0\r
-OPEN b$ + ".pp" FOR INPUT AS #1\r
+SUB loadplan (planbase$)\r
+ ' Loads the day-plan file <planbase$>.pp into the dayplan$ array.\r
+dayplancount = 0\r
+OPEN planbase$ + ".pp" FOR INPUT AS #1\r
6\r
IF EOF(1) <> 0 THEN GOTO 7\r
-LINE INPUT #1, a$\r
-ppl = ppl + 1\r
-pp$(ppl) = a$\r
+LINE INPUT #1, tmp$\r
+dayplancount = dayplancount + 1\r
+dayplan$(dayplancount) = tmp$\r
GOTO 6\r
7\r
CLOSE #1\r
END SUB\r
\r
-SUB kell (a)\r
-b$ = TIME$ + DATE$\r
-IF b$ <> lk$ THEN lk$ = b$ ELSE GOTO 2\r
+SUB ringevent (ringtype)\r
+ ' Rings the bell for an event (1 = lesson start, 2 = lesson end), max once per second.\r
+tmp$ = TIME$ + DATE$\r
+IF tmp$ <> lastbell$ THEN lastbell$ = tmp$ ELSE GOTO 2 ' skip if the bell already rang during this second\r
\r
-heli 3\r
+playsound 3\r
\r
-SELECT CASE a\r
+SELECT CASE ringtype\r
CASE 1\r
-kola 4\r
-FOR b = 1 TO 15\r
-SOUND 0, 1\r
-NEXT b\r
-kola 1\r
+ringbell 4\r
+FOR i = 1 TO 15\r
+SOUND 0, 1 ' SOUND 0, n = sub-second delay workaround (inaudible 0 Hz tone)\r
+NEXT i\r
+ringbell 1\r
CASE 2\r
-kola 5\r
+ringbell 5\r
END SELECT\r
2\r
END SUB\r
\r
-SUB kola (a)\r
-timero = TIMER\r
+SUB ringbell (seconds)\r
+ ' Rings the physical bell: toggles the LPT port lines for the given seconds.\r
+timersnap = TIMER\r
11\r
-FOR b = 1 TO 100\r
-OUT prt, 0\r
-OUT prt, 255\r
-NEXT b\r
-IF ABS(timero - TIMER) < a THEN GOTO 11\r
+FOR i = 1 TO 100\r
+OUT lptport, 0 ' toggle all LPT data lines (drives the bell relay)\r
+OUT lptport, 255\r
+NEXT i\r
+IF ABS(timersnap - TIMER) < seconds THEN GOTO 11\r
END SUB\r
\r
-SUB mnmain\r
+SUB mainloop\r
+ ' Main loop: checks the clock, handles keys, runs the idle screensaver.\r
1\r
-b$ = LEFT$(TIME$, 5)\r
-IF b$ <> timo$ THEN chm\r
-timo$ = b$\r
+tmp$ = LEFT$(TIME$, 5)\r
+IF tmp$ <> lasttime$ THEN checkminute\r
+lasttime$ = tmp$\r
\r
-a$ = INKEY$\r
+key$ = INKEY$\r
\r
-IF a$ <> "" THEN\r
-IF ssave > ssavel THEN disp\r
-ssave = 0\r
+IF key$ <> "" THEN\r
+ IF idlecount > idlelimit THEN drawscreen ' first keypress after idle: redraw the main screen\r
+ idlecount = 0\r
END IF\r
\r
-IF a$ = CHR$(12) THEN\r
- IF kblukk = 1 THEN kblukk = 0 ELSE kblukk = 1\r
- displukk\r
+IF key$ = CHR$(12) THEN ' CTRL+L toggles the keyboard lock\r
+ IF keylock = 1 THEN keylock = 0 ELSE keylock = 1\r
+ showlockmsg\r
END IF\r
-IF kblukk = 1 THEN a$ = ""\r
+IF keylock = 1 THEN key$ = ""\r
\r
-IF a$ = "s" THEN kell 1\r
-IF a$ = "v" THEN kell 2\r
+IF key$ = "s" THEN ringevent 1\r
+IF key$ = "v" THEN ringevent 2\r
\r
-IF a$ = "a" THEN\r
-CLS\r
-PRINT " vana aeg: " + TIME$\r
-INPUT "sisesta uus aeg (TT:MM:SS): ", b$\r
-IF LEN(b$) <> 8 THEN GOTO 12\r
-TIME$ = b$\r
-timo$ = ""\r
-12\r
-disp\r
+IF key$ = "a" THEN\r
+ CLS\r
+ PRINT " vana aeg: " + TIME$\r
+ INPUT "sisesta uus aeg (TT:MM:SS): ", tmp$\r
+ IF LEN(tmp$) <> 8 THEN GOTO 12\r
+ TIME$ = tmp$\r
+ lasttime$ = ""\r
+ 12\r
+ drawscreen\r
END IF\r
\r
-IF a$ = "d" THEN\r
-CLS\r
-PRINT " vana daatum: " + DATE$\r
-INPUT "sisesta uus daatum (KK-PP-AAAA): ", b$\r
-IF LEN(b$) <> 10 THEN GOTO 13\r
-DATE$ = b$\r
-timo$ = ""\r
-13\r
-disp\r
+IF key$ = "d" THEN\r
+ CLS\r
+ PRINT " vana daatum: " + DATE$\r
+ INPUT "sisesta uus daatum (KK-PP-AAAA): ", tmp$\r
+ IF LEN(tmp$) <> 10 THEN GOTO 13\r
+ DATE$ = tmp$\r
+ lasttime$ = ""\r
+ 13\r
+ drawscreen\r
END IF\r
\r
-IF a$ = "7" OR a$ = "8" THEN\r
- b = VAL(RIGHT$(LEFT$(TIME$, 5), 2))\r
- IF a$ = "7" THEN b = b - 1\r
- IF a$ = "8" THEN b = b + 1\r
- IF b < 0 THEN b = 0\r
- IF b > 59 THEN b = 59\r
- d$ = STR$(b)\r
- IF LEFT$(d$, 1) = " " THEN d$ = RIGHT$(d$, LEN(d$) - 1)\r
- IF LEN(d$) < 2 THEN d$ = "0" + d$\r
- e$ = LEFT$(TIME$, 3) + d$ + RIGHT$(TIME$, 3)\r
- TIME$ = e$\r
+IF key$ = "7" OR key$ = "8" THEN\r
+ num = VAL(RIGHT$(LEFT$(TIME$, 5), 2))\r
+ IF key$ = "7" THEN num = num - 1\r
+ IF key$ = "8" THEN num = num + 1\r
+ IF num < 0 THEN num = 0\r
+ IF num > 59 THEN num = 59\r
+ numstr$ = STR$(num)\r
+ IF LEFT$(numstr$, 1) = " " THEN numstr$ = RIGHT$(numstr$, LEN(numstr$) - 1)\r
+ IF LEN(numstr$) < 2 THEN numstr$ = "0" + numstr$\r
+ newtime$ = LEFT$(TIME$, 3) + numstr$ + RIGHT$(TIME$, 3)\r
+ TIME$ = newtime$\r
END IF\r
\r
-IF a$ = "4" OR a$ = "5" THEN\r
- b = VAL(LEFT$(TIME$, 2))\r
- IF a$ = "4" THEN b = b - 1\r
- IF a$ = "5" THEN b = b + 1\r
- IF b < 0 THEN b = 0\r
- IF b > 23 THEN b = 23\r
- d$ = STR$(b)\r
- IF LEFT$(d$, 1) = " " THEN d$ = RIGHT$(d$, LEN(d$) - 1)\r
- IF LEN(d$) < 2 THEN d$ = "0" + d$\r
- e$ = d$ + RIGHT$(TIME$, 6)\r
- TIME$ = e$\r
+IF key$ = "4" OR key$ = "5" THEN\r
+ num = VAL(LEFT$(TIME$, 2))\r
+ IF key$ = "4" THEN num = num - 1\r
+ IF key$ = "5" THEN num = num + 1\r
+ IF num < 0 THEN num = 0\r
+ IF num > 23 THEN num = 23\r
+ numstr$ = STR$(num)\r
+ IF LEFT$(numstr$, 1) = " " THEN numstr$ = RIGHT$(numstr$, LEN(numstr$) - 1)\r
+ IF LEN(numstr$) < 2 THEN numstr$ = "0" + numstr$\r
+ newtime$ = numstr$ + RIGHT$(TIME$, 6)\r
+ TIME$ = newtime$\r
END IF\r
\r
-IF a$ = "u" THEN sync2\r
-IF a$ = "l" THEN sync\r
+IF key$ = "u" THEN roundtohour\r
+IF key$ = "l" THEN loadsyncfile\r
\r
-IF a$ = "r" THEN rese\r
-IF a$ = "q" THEN SYSTEM\r
+IF key$ = "r" THEN resetprogram\r
+IF key$ = "q" THEN SYSTEM\r
\r
-IF a$ = "j" THEN\r
-IF tunnidara = 0 THEN tunnidara = 1 ELSE tunnidara = 0\r
-dispt\r
+IF key$ = "j" THEN\r
+ IF dayoff = 0 THEN dayoff = 1 ELSE dayoff = 0 ' j = skip all lessons today (toggle)\r
+ showskipmsg\r
END IF\r
\r
-IF ssave <= ssavel THEN\r
+IF idlecount <= idlelimit THEN\r
LOCATE 11, 1\r
PRINT TIME$\r
LOCATE 12, 1\r
PRINT DATE$\r
ELSE\r
- IF ABS(TIMER - timero) > 10 THEN\r
- CLS\r
- kblukk = 1\r
- FOR b = 1 TO 20\r
- LOCATE RND * 22 + 1, RND * 79 + 1\r
- IF RND * 100 < 50 THEN PRINT "*" ELSE PRINT "."\r
- NEXT b\r
- LOCATE RND * 22 + 1, RND * 50 + 1\r
- COLOR 0, 7\r
- PRINT "< " + LEFT$(TIME$, 2);\r
- COLOR 16, 7\r
- PRINT ":";\r
- COLOR 0, 7\r
- PRINT RIGHT$(LEFT$(TIME$, 5), 2) + " >"\r
- COLOR 7, 0\r
- timero = TIMER\r
+ IF ABS(TIMER - timersnap) > 10 THEN ' idle too long: starfield screensaver with clock\r
+ CLS\r
+ keylock = 1\r
+ FOR i = 1 TO 20\r
+ LOCATE RND * 22 + 1, RND * 79 + 1\r
+ IF RND * 100 < 50 THEN PRINT "*" ELSE PRINT "."\r
+ NEXT i\r
+ LOCATE RND * 22 + 1, RND * 50 + 1\r
+ COLOR 0, 7\r
+ PRINT "< " + LEFT$(TIME$, 2);\r
+ COLOR 16, 7\r
+ PRINT ":";\r
+ COLOR 0, 7\r
+ PRINT RIGHT$(LEFT$(TIME$, 5), 2) + " >"\r
+ COLOR 7, 0\r
+ timersnap = TIMER\r
END IF\r
END IF\r
GOTO 1\r
\r
END SUB\r
\r
-SUB rese\r
-heli 4\r
-timo$ = ""\r
-dato$ = ""\r
-apl = 0\r
+SUB resetprogram\r
+ ' Resets cached date/time and the year plan so everything reloads.\r
+playsound 4\r
+lasttime$ = ""\r
+lastdate$ = ""\r
+yearplancount = 0\r
END SUB\r
\r
-SUB son (a$)\r
+SUB splitwords (txt$)\r
+ ' Splits a string at spaces/tabs into the words$ array (wordcount words).\r
\r
-FOR b = 1 TO 50\r
-sona$(b) = ""\r
-NEXT b\r
-mitus = 0\r
+FOR inword = 1 TO 50\r
+words$(inword) = ""\r
+NEXT inword\r
+wordcount = 0\r
\r
-b = 1\r
-FOR c = 1 TO LEN(a$)\r
-d$ = RIGHT$(LEFT$(a$, c), 1)\r
-IF d$ = " " OR d$ = CHR$(9) THEN\r
-b = 1\r
+inword = 1\r
+FOR i = 1 TO LEN(txt$)\r
+ch$ = RIGHT$(LEFT$(txt$, i), 1)\r
+IF ch$ = " " OR ch$ = CHR$(9) THEN\r
+inword = 1\r
ELSE\r
-IF b = 1 THEN b = 0: mitus = mitus + 1\r
-sona$(mitus) = sona$(mitus) + d$\r
+IF inword = 1 THEN inword = 0: wordcount = wordcount + 1\r
+words$(wordcount) = words$(wordcount) + ch$\r
END IF\r
-NEXT c\r
+NEXT i\r
\r
\r
END SUB\r
\r
-SUB start\r
-pn$(1) = "esmasp�ev"\r
-pn$(2) = "teisip�ev"\r
-pn$(3) = "kolmap�ev"\r
-pn$(4) = "neljap�ev"\r
-pn$(5) = "reede"\r
-pn$(6) = "laup�ev"\r
-pn$(7) = "p�hap�ev"\r
-\r
-prt = &H378\r
-\r
-ssavel = 2\r
-kblukk = 1\r
-tunnidara = 0\r
+SUB initprogram\r
+ ' Program init: weekday names, LPT port address, default flags.\r
+dayname$(1) = "esmasp�ev"\r
+dayname$(2) = "teisip�ev"\r
+dayname$(3) = "kolmap�ev"\r
+dayname$(4) = "neljap�ev"\r
+dayname$(5) = "reede"\r
+dayname$(6) = "laup�ev"\r
+dayname$(7) = "p�hap�ev"\r
+\r
+lptport = &H378 ' LPT1 parallel port base address\r
+\r
+idlelimit = 2 ' screensaver starts after 2 minutes without keypresses\r
+keylock = 1 ' keyboard starts locked (unlock with CTRL+L)\r
+dayoff = 0\r
END SUB\r
\r
-SUB sync\r
+SUB loadsyncfile\r
+ ' Reads date and time from sync.txt and sets the system clock.\r
OPEN "sync.txt" FOR INPUT AS #1\r
-LINE INPUT #1, a$\r
-DATE$ = a$\r
-LINE INPUT #1, a$\r
-TIME$ = a$\r
+LINE INPUT #1, tmp$\r
+DATE$ = tmp$\r
+LINE INPUT #1, tmp$\r
+TIME$ = tmp$\r
CLOSE #1\r
\r
-heli 2\r
+playsound 2\r
END SUB\r
\r
-SUB sync2\r
-a$ = TIME$\r
-a$ = LEFT$(a$, 5)\r
-b = VAL(RIGHT$(a$, 2))\r
-c = VAL(LEFT$(a$, 2))\r
-IF b >= 30 THEN c = c + 1\r
-b = 0\r
-IF c > 23 THEN c = c - 24\r
-a$ = RIGHT$(STR$(c), LEN(STR$(c)) - 1)\r
-b$ = RIGHT$(STR$(b), LEN(STR$(b)) - 1)\r
-IF LEN(a$) < 2 THEN a$ = "0" + a$\r
-IF LEN(b$) < 2 THEN b$ = "0" + b$\r
-a$ = a$ + ":" + b$\r
+SUB roundtohour\r
+ ' Rounds the current time up to the nearest full hour.\r
+timestr$ = TIME$\r
+timestr$ = LEFT$(timestr$, 5)\r
+mins = VAL(RIGHT$(timestr$, 2))\r
+hrs = VAL(LEFT$(timestr$, 2))\r
+IF mins >= 30 THEN hrs = hrs + 1 ' past half hour: round up to the next hour\r
+mins = 0\r
+IF hrs > 23 THEN hrs = hrs - 24\r
+timestr$ = RIGHT$(STR$(hrs), LEN(STR$(hrs)) - 1)\r
+minstr$ = RIGHT$(STR$(mins), LEN(STR$(mins)) - 1)\r
+IF LEN(timestr$) < 2 THEN timestr$ = "0" + timestr$\r
+IF LEN(minstr$) < 2 THEN minstr$ = "0" + minstr$\r
+timestr$ = timestr$ + ":" + minstr$\r
\r
'LOCATE 10, 1\r
'PRINT a$\r
\r
-TIME$ = a$\r
+TIME$ = timestr$\r
\r
-heli 1\r
+playsound 1\r
END SUB\r
\r
projects / qbasicapps.git / commitdiff