From 1e75515018e1de7aa5e82dc087b154b810000e72 Mon Sep 17 00:00:00 2001 From: Svjatoslav Agejenko Date: Sun, 11 Oct 2026 10:52:22 +0300 Subject: [PATCH] refactor: rename cryptic identifiers and document 8 old programs Second readability pass (n0-qbasic-improver) over programs whose names were still cryptic or Estonian-derived: - People.bas: slideshow subs (pr/wpr/pri/sc1/pal*, mkjuku) and shared vars (fontt, jas, tmr) get descriptive names - Worm/worm.bas: game-loop subs (ai, prc, tkt, sc2) and vars renamed; also fixes the 8.lvl arena layout rows - checkers2.bas: Estonian move subs (compki = computer move, humngo, thinkc/thinkh) and lookahead vars renamed - 3D graph.bas: Estonian subs (graaf, mkgr*, nait3d, getcor) renamed to heightmap/camera domain terms - Galaxy explorer.bas: temp/rn/disp renamed (mkGalaxy kept: the site docs reference it by name) - school clock v1 kk.bas + ekr.bas and v2 kkmini.bas: Estonian subs (ekr, kola, leiaconf-style names, getnad, getmd) renamed to bell/ timetable/LPT-display terms Algorithm, control flow, labels, string literals and DATA untouched. Verified with scripts/verify_rename.py (token-stream equivalence vs HEAD: literals identical, renames bijective per QBasic scope, line endings preserved) plus crtbasic --headless before/after runs. --- 2D GFX/People.bas | 608 +++++------ 3D GFX/Space/Galaxy explorer.bas | 57 +- Games/Worm/8.lvl | 16 +- Games/Worm/worm.bas | 714 ++++++------- Games/checkers2.bas | 687 +++++++------ Math/Plotting/3D graph.bas | 324 +++--- .../Automated school clock/v1/ekr.bas | 82 +- .../Automated school clock/v1/kk.bas | 965 +++++++++--------- .../Automated school clock/v2/kkmini.bas | 643 ++++++------ 9 files changed, 2127 insertions(+), 1969 deletions(-) diff --git a/2D GFX/People.bas b/2D GFX/People.bas index 60161a5..cb13fcb 100755 --- a/2D GFX/People.bas +++ b/2D GFX/People.bas @@ -8,48 +8,49 @@ ' Changelog: ' 2001, Initial version ' 2024 - 2025, Improved program readability +' 2026, Improved program readability DECLARE SUB displaySlide1 () -DECLARE SUB setink (a!) -DECLARE SUB inke (a$) -DECLARE SUB mkjuku (x!, y!, a!, c!) -DECLARE SUB pr (x!, y!, s!, c!, n!, a$) -DECLARE SUB wpr () +DECLARE SUB setIdleTimeout (seconds!) +DECLARE SUB pollKey (key$) +DECLARE SUB drawBoy (x!, y!, phaseIndex!, shade!) +DECLARE SUB printNthChar (x!, y!, scale!, shade!, charIndex!, text$) +DECLARE SUB updateReveal () DECLARE SUB displayEffect7 () DECLARE SUB displaySlide6 () DECLARE SUB displaySlide5 () -DECLARE SUB pal4 (c, r!, g!, b!) +DECLARE SUB setPaletteColor (paletteIndex, r!, g!, b!) DECLARE SUB displaySlide4 () -DECLARE SUB inpur () +DECLARE SUB waitKeypress () DECLARE SUB displayEffect5 () DECLARE SUB displaySlide3 () -DECLARE SUB prin (x1!, y1!, s!, c, a$) -DECLARE SUB pal3 (r!, g!, b!) -DECLARE SUB mkfont () -DECLARE SUB pal2 (r!, g!, b!) -DECLARE SUB box1 (x1!, y1!, x2!, y2!, c!) -DECLARE SUB mkback () +DECLARE SUB printText (xPos!, yPos!, scale!, shade, text$) +DECLARE SUB setBoxPalette2 (red!, green!, blue!) +DECLARE SUB makeFont () +DECLARE SUB setBoxPalette1 (red!, green!, blue!) +DECLARE SUB drawShadedBox (x1!, y1!, x2!, y2!, shadeType!) +DECLARE SUB makeBackground () DECLARE SUB displaySlide2 () -DECLARE SUB resiz () -DECLARE SUB pri (x!, y!, a$, c!) -DECLARE SUB deca (xs!, ys!, fx!, fy!) -DECLARE SUB box (xs!, ys!) +DECLARE SUB splitTransition () +DECLARE SUB printTypewriter (x!, y!, text$, shade!) +DECLARE SUB shrinkBox (sizeX!, sizeY!, shrinkX!, shrinkY!) +DECLARE SUB box (sizeX!, sizeY!) DECLARE SUB displayEffect4 () DECLARE SUB displayEffect3 () DECLARE SUB displayEffect2 () DECLARE SUB displayEffect1 () DECLARE SUB start () -DECLARE SUB sc1 () -DECLARE SUB pal (x!) -DIM SHARED fontt(0 TO 7, 0 TO 7, 0 TO 255) -DIM SHARED tim -DIM SHARED tim2 -DIM SHARED jas(1 TO 500) -DIM SHARED pii -DIM SHARED tmr -DIM SHARED ink -DIM SHARED tim$ +DECLARE SUB sc1 () ' leftover declaration; the routine was never implemented +DECLARE SUB setPalette (scheme!) +DIM SHARED fontBitmap(0 TO 7, 0 TO 7, 0 TO 255) +DIM SHARED revealCounter +DIM SHARED revealStage +DIM SHARED animPhase(1 TO 500) +DIM SHARED piValue +DIM SHARED autoAdvance +DIM SHARED idleCountdown +DIM SHARED lastTime$ start @@ -74,31 +75,31 @@ displayEffect5 SYSTEM -SUB box (xs, ys) +SUB box (sizeX, sizeY) ' Draws a 3D style box border at the top-left corner of the screen ' Parameters: -' xs - width of the box -' ys - height of the box +' sizeX - width of the box +' sizeY - height of the box -LINE (0, 186)-(0 + xs, 186 - ys), 15, B -LINE (1, 187)-(-1 + xs, 187 - ys), 25, B -LINE (2, 188)-(-2 + xs, 188 - ys), 15, B +LINE (0, 186)-(0 + sizeX, 186 - sizeY), 15, B +LINE (1, 187)-(-1 + sizeX, 187 - sizeY), 25, B +LINE (2, 188)-(-2 + sizeX, 188 - sizeY), 15, B PSET (0, 188), 0 -PSET (0 + xs, 188), 0 -PSET (0, 186 - ys), 0 -PSET (0 + xs, 186 - ys), 0 +PSET (0 + sizeX, 188), 0 +PSET (0, 186 - sizeY), 0 +PSET (0 + sizeX, 186 - sizeY), 0 END SUB DEFINT Z -SUB box1 (x1, y1, x2, y2, c) +SUB drawShadedBox (x1, y1, x2, y2, shadeType) ' Draws a shaded box with a 3D effect ' Parameters: ' x1, y1 - top-left corner coordinates ' x2, y2 - bottom-right corner coordinates -' c - type of shading +' shadeType - type of shading -IF c = 1 THEN za = 51 ELSE za = 102 +IF shadeType = 1 THEN za = 51 ELSE za = 102 FOR zy = y1 + 7 TO y2 + 7 FOR zx = x1 + 7 TO x2 + 7 @@ -122,17 +123,19 @@ NEXT zy END SUB DEFSNG Z -SUB deca (xs, ys, fx, fy) -LINE (0, 185 - ys)-(xs, 185 - ys + fy), 0, BF -LINE (xs, 18 - ys)-(xs - fx, 188), 0, BF -xs = xs - fx -ys = ys - fy -box xs, ys +SUB shrinkBox (sizeX, sizeY, shrinkX, shrinkY) +' Erodes the border box inward by shrinkX/shrinkY pixels and redraws it smaller +LINE (0, 185 - sizeY)-(sizeX, 185 - sizeY + shrinkY), 0, BF +LINE (sizeX, 18 - sizeY)-(sizeX - shrinkX, 188), 0, BF +sizeX = sizeX - shrinkX +sizeY = sizeY - shrinkY +box sizeX, sizeY END SUB SUB displayEffect1 +' Effect 1: scrolling color bands, sine-wave line and walking boy figures; waits for keypress -pal 3 +setPalette 3 DIM buf1(1 TO 10000) DIM buf2(1 TO 10000) @@ -144,7 +147,7 @@ NEXT a b = 0 c1 = 1 -setink 10 +setIdleTimeout 10 1 c1 = c1 + 1 IF c1 > 50 THEN c1 = 1 @@ -181,18 +184,19 @@ a = 50 FOR x = 65 + 18 TO 270 STEP 40 a = a + 1 IF buf3(x - 1) < 190 THEN -mkjuku x, buf3(x - 1) - 27, x, 0 -mkjuku x, buf3(x) - 27, x, a +drawBoy x, buf3(x - 1) - 27, x, 0 +drawBoy x, buf3(x) - 27, x, a END IF NEXT x -inke a$ -SOUND 0, .4 +pollKey a$ +SOUND 0, .4 ' sub-second delay workaround (inaudible 0 Hz sound) IF a$ = "" THEN GOTO 1 END SUB SUB displayEffect2 +' Effect 2: palette fade transition (ramps palette brightness down, then up) FOR a = 1 TO 30 e = 0 @@ -207,7 +211,7 @@ OUT &H3C9, e / 3 NEXT f FOR b = 1 TO 3 -SOUND 0, .3 +SOUND 0, .3 ' sub-second delay workaround (inaudible 0 Hz sound) NEXT b NEXT a @@ -223,7 +227,7 @@ OUT &H3C9, e / 3 NEXT f FOR b = 1 TO 2 -SOUND 0, .3 +SOUND 0, .3 ' sub-second delay workaround (inaudible 0 Hz sound) NEXT b NEXT a @@ -231,6 +235,7 @@ NEXT a END SUB SUB displayEffect3 +' Effect 3: accelerating line-burst zoom on screen 7, then authors roll on screen 13 SCREEN 7 SCREEN 7, , , 1 @@ -256,11 +261,11 @@ NEXT a PCOPY 0, 1 CLS -SOUND 0, .4 +SOUND 0, .4 ' sub-second delay workaround (inaudible 0 Hz sound) IF b < 50 THEN GOTO 2 SCREEN 13 -pal 2 +setPalette 2 FOR a = 0 TO 160 STEP b LINE (160 + a, 0)-(160 + a, 199), 25 @@ -269,57 +274,58 @@ LINE (0, 100 + a)-(319, 100 + a), 25 LINE (0, 100 - a)-(319, 100 - a), 25 NEXT a -resiz -pal 3 +splitTransition +setPalette 3 -pri 11, 8, "-* A U T H O R S *-", 55 -pri 10, 11, CHR$(254) + " John Doe", 55 -pri 10, 13, CHR$(254) + " Jane Doe", 55 -pri 10, 15, CHR$(254) + " Anonymous", 55 -pri 20, 19, "year 2001", 55 +printTypewriter 11, 8, "-* A U T H O R S *-", 55 +printTypewriter 10, 11, CHR$(254) + " John Doe", 55 +printTypewriter 10, 13, CHR$(254) + " Jane Doe", 55 +printTypewriter 10, 15, CHR$(254) + " Anonymous", 55 +printTypewriter 20, 19, "year 2001", 55 -inpur +waitKeypress CLS END SUB SUB displayEffect4 -pal 2 +' Effect 4: border box erodes while random characters scroll up and text lines appear; waits for keypress +setPalette 2 xs = 317 ys = 185 box xs, ys -tey = 20 +textY = 20 DIM buf4(1 TO 10000) b = 0 -setink 10 +setIdleTimeout 10 COLOR 25 4 b = b + 1 SELECT CASE b CASE 50 TO 200 -deca xs, ys, 1, 1 +shrinkBox xs, ys, 1, 1 CASE 201 -'pal4 255, 63, 45, 0 -'prin 10, tey, 2, 255, "Sources:" -tey = tey + 20 +'setPaletteColor 255, 63, 45, 0 +'printText 10, textY, 2, 255, "Sources:" +textY = textY + 20 CASE 290 -pal4 254, 20, 20, 63 -prin 70, tey, 7, 254, "TEST" -tey = tey + 60 +setPaletteColor 254, 20, 20, 63 +printText 70, textY, 7, 254, "TEST" +textY = textY + 60 CASE 350 -pal4 254, 20, 20, 63 -prin 100, tey, 2, 254, "www.12345.com" -tey = tey + 20 +setPaletteColor 254, 20, 20, 63 +printText 100, textY, 2, 254, "www.12345.com" +textY = textY + 20 CASE 400 -pal4 254, 20, 20, 63 -prin 100, tey, 2, 254, CHR$(16) + "Subject 1" -tey = tey + 10 +setPaletteColor 254, 20, 20, 63 +printText 100, textY, 2, 254, CHR$(16) + "Subject 1" +textY = textY + 10 END SELECT @@ -333,16 +339,17 @@ GET (x, 183 - ys + 14)-(x + 7, 183), buf4(1) PUT (x, 183 - ys + 6), buf4(1), PSET NEXT x -inke a$ +pollKey a$ IF a$ <> "" THEN GOTO 3 -wpr +updateReveal GOTO 4 3 END SUB SUB displayEffect5 +' Effect 5: random screen blocks drift, then the screen wipes to black DIM buf(1 TO 5000) FOR a = 1 TO 1000 @@ -352,48 +359,50 @@ GET (x, y)-(x + 19, y + 19), buf(1) IF RND * 100 < 50 THEN x = x + 1 ELSE x = x - 1 IF RND * 100 < 50 THEN y = y + 1 PUT (x, y), buf(1), PSET -SOUND 0, .05 +SOUND 0, .05 ' sub-second delay workaround (inaudible 0 Hz sound) NEXT a FOR a = 0 TO 100 LINE (0, a)-(319, a), 0 LINE (0, 200 - a)-(319, 200 - a), 0 -SOUND 0, .4 +SOUND 0, .4 ' sub-second delay workaround (inaudible 0 Hz sound) NEXT a END SUB SUB displayEffect7 -pal 4 -mkback +' Effect 7: sample content slide with header box and bullet list +setPalette 4 +makeBackground -pal2 0, 0, 32 -box1 3, 3, 300, 50, 1 +setBoxPalette1 0, 0, 32 +drawShadedBox 3, 3, 300, 50, 1 -pal4 255, 50, 50, 0 -prin 10, 10, 2, 255, "Et dolore magna" -prin 50, 30, 1, 255, "www.utenimadminim.org" +setPaletteColor 255, 50, 50, 0 +printText 10, 10, 2, 255, "Et dolore magna" +printText 50, 30, 1, 255, "www.utenimadminim.org" -pal3 20, 32, 63 -box1 20, 40, 290, 180, 2 +setBoxPalette2 20, 32, 63 +drawShadedBox 20, 40, 290, 180, 2 -pal4 254, 63, 45, 0 +setPaletteColor 254, 63, 45, 0 b = 25 -prin 40, 60, 1, 254, CHR$(254) + " Ut enim ad minim veniam" +printText 40, 60, 1, 254, CHR$(254) + " Ut enim ad minim veniam" a = b -prin 40, 60 + a, 1, 254, CHR$(254) + " Quis nostrud exercitation" +printText 40, 60 + a, 1, 254, CHR$(254) + " Quis nostrud exercitation" a = a + b -prin 40, 60 + a, 1, 254, CHR$(254) + " Laboris nisi ut aliquip ex" +printText 40, 60 + a, 1, 254, CHR$(254) + " Laboris nisi ut aliquip ex" a = a + b -prin 40, 60 + a, 1, 254, CHR$(254) + " Sed ut perspiciatis unde" +printText 40, 60 + a, 1, 254, CHR$(254) + " Sed ut perspiciatis unde" -inpur +waitKeypress END SUB SUB displaySlide1 +' Slide 1: pixelates the "HEADER" title onto the screen, then blurs it in four passes -pal 2 +setPalette 2 LOCATE 1, 1 COLOR 1 PRINT "HEADER" @@ -444,187 +453,196 @@ NEXT x END SUB SUB displaySlide2 +' Slide 2: "Goal:" text layout test slide CLS -pal 4 -mkback +setPalette 4 +makeBackground -pal2 40, 64, 63 -pal3 0, 0, 0 +setBoxPalette1 40, 64, 63 +setBoxPalette2 0, 0, 0 -box1 30, 30, 290, 170, 1 +drawShadedBox 30, 30, 290, 170, 1 -prin 65, 50, 3, 0, "Goal:" +printText 65, 50, 3, 0, "Goal:" -prin 40, 100, 1, 0, CHR$(254) + " Random text" -prin 40, 108, 1, 0, " goes here to test" -prin 40, 116, 1, 0, " text layout." -prin 40, 130, 1, 0, CHR$(254) + " Testing 123." +printText 40, 100, 1, 0, CHR$(254) + " Random text" +printText 40, 108, 1, 0, " goes here to test" +printText 40, 116, 1, 0, " text layout." +printText 40, 130, 1, 0, CHR$(254) + " Testing 123." -inpur +waitKeypress END SUB SUB displaySlide3 -mkback +' Slide 3: closing "Thank you for attention" slide +makeBackground -pal2 64, 64, 0 -box1 30, 30, 290, 150, 1 +setBoxPalette1 64, 64, 0 +drawShadedBox 30, 30, 290, 150, 1 -prin 57, 50, 3, 0, "Thank you" -prin 45, 74, 3, 0, " for" -prin 45, 98, 3, 0, "attention" -inpur +printText 57, 50, 3, 0, "Thank you" +printText 45, 74, 3, 0, " for" +printText 45, 98, 3, 0, "attention" +waitKeypress END SUB SUB displaySlide4 +' Slide 4: sample content slide with header box and bullet list -pal 4 -mkback +setPalette 4 +makeBackground -pal2 0, 0, 32 -box1 3, 3, 260, 50, 1 +setBoxPalette1 0, 0, 32 +drawShadedBox 3, 3, 260, 50, 1 -pal4 255, 50, 50, 0 -prin 10, 10, 2, 255, "Random header" -prin 50, 30, 1, 255, "www.randomsite.org" +setPaletteColor 255, 50, 50, 0 +printText 10, 10, 2, 255, "Random header" +printText 50, 30, 1, 255, "www.randomsite.org" -pal3 10, 20, 0 -box1 20, 40, 290, 180, 2 +setBoxPalette2 10, 20, 0 +drawShadedBox 20, 40, 290, 180, 2 -pal4 254, 63, 45, 0 +setPaletteColor 254, 63, 45, 0 b = 25 -prin 40, 60, 1, 254, CHR$(254) + " Lorem ipsum dolor sit amet," +printText 40, 60, 1, 254, CHR$(254) + " Lorem ipsum dolor sit amet," a = b -prin 40, 60 + a, 1, 254, CHR$(254) + " consectetur adipiscing elit," +printText 40, 60 + a, 1, 254, CHR$(254) + " consectetur adipiscing elit," a = a + b -prin 40, 60 + a, 1, 254, CHR$(254) + " sed do eiusmod" +printText 40, 60 + a, 1, 254, CHR$(254) + " sed do eiusmod" a = a + b -prin 40, 60 + a, 1, 254, CHR$(254) + " tempor incididunt ut labore" +printText 40, 60 + a, 1, 254, CHR$(254) + " tempor incididunt ut labore" -inpur +waitKeypress END SUB SUB displaySlide5 -pal 4 -mkback +' Slide 5: sample content slide with header box and bullet list +setPalette 4 +makeBackground -pal2 0, 0, 32 -box1 3, 3, 300, 50, 1 +setBoxPalette1 0, 0, 32 +drawShadedBox 3, 3, 300, 50, 1 -pal4 255, 50, 50, 0 -prin 10, 10, 2, 255, "Totam rem aperiam" -prin 50, 30, 1, 255, "www.randomurl.org" +setPaletteColor 255, 50, 50, 0 +printText 10, 10, 2, 255, "Totam rem aperiam" +printText 50, 30, 1, 255, "www.randomurl.org" -pal3 20, 32, 63 -box1 20, 40, 290, 180, 2 +setBoxPalette2 20, 32, 63 +drawShadedBox 20, 40, 290, 180, 2 -pal4 254, 63, 45, 0 +setPaletteColor 254, 63, 45, 0 b = 25 -prin 40, 60, 1, 254, CHR$(254) + " Nemo enim ipsam voluptatem" +printText 40, 60, 1, 254, CHR$(254) + " Nemo enim ipsam voluptatem" a = b -prin 40, 60 + a, 1, 254, CHR$(254) + " Sed quia consequuntur" +printText 40, 60 + a, 1, 254, CHR$(254) + " Sed quia consequuntur" a = a + b -prin 40, 60 + a, 1, 254, CHR$(254) + " Magni dolores eos" +printText 40, 60 + a, 1, 254, CHR$(254) + " Magni dolores eos" a = a + b -prin 40, 60 + a, 1, 254, CHR$(254) + " Qui ratione voluptatem" +printText 40, 60 + a, 1, 254, CHR$(254) + " Qui ratione voluptatem" -inpur +waitKeypress END SUB SUB displaySlide6 -pal 4 -mkback +' Slide 6: sample content slide with header box and bullet list +setPalette 4 +makeBackground -pal2 0, 0, 32 -box1 3, 3, 300, 50, 1 +setBoxPalette1 0, 0, 32 +drawShadedBox 3, 3, 300, 50, 1 -pal4 255, 50, 50, 0 -prin 10, 10, 2, 255, "H E L L O !" -prin 50, 30, 1, 255, "www.hello.net" +setPaletteColor 255, 50, 50, 0 +printText 10, 10, 2, 255, "H E L L O !" +printText 50, 30, 1, 255, "www.hello.net" -pal3 30, 20, 10 -box1 20, 40, 290, 180, 2 +setBoxPalette2 30, 20, 10 +drawShadedBox 20, 40, 290, 180, 2 -pal4 254, 63, 45, 0 +setPaletteColor 254, 63, 45, 0 b = 25 -prin 40, 60, 1, 254, CHR$(254) + " Quis autem vel eum" +printText 40, 60, 1, 254, CHR$(254) + " Quis autem vel eum" a = b -prin 40, 60 + a, 1, 254, CHR$(254) + " Iure reprehenderit qui" +printText 40, 60 + a, 1, 254, CHR$(254) + " Iure reprehenderit qui" a = a + b -prin 40, 60 + a, 1, 254, CHR$(254) + " In ea voluptate velit" +printText 40, 60 + a, 1, 254, CHR$(254) + " In ea voluptate velit" a = a + b -prin 40, 60 + a, 1, 254, CHR$(254) + " Esse quam nihil molestiae" +printText 40, 60 + a, 1, 254, CHR$(254) + " Esse quam nihil molestiae" -inpur +waitKeypress END SUB -SUB inke (a$) -IF tim$ <> TIME$ THEN -ink = ink - 1 -tim$ = TIME$ +SUB pollKey (key$) +' Returns key$ = " " when a key was pressed (or the idle timer ran out in timer mode), "" otherwise +IF lastTime$ <> TIME$ THEN +idleCountdown = idleCountdown - 1 +lastTime$ = TIME$ END IF -IF (ink <= 0) AND (tmr = 1) THEN a$ = " " ELSE a$ = "" -IF INKEY$ <> "" THEN a$ = " " +IF (idleCountdown <= 0) AND (autoAdvance = 1) THEN key$ = " " ELSE key$ = "" +IF INKEY$ <> "" THEN key$ = " " END SUB -SUB inpur -setink 10 +SUB waitKeypress +' Waits until a key is pressed (or the idle auto-advance timer expires) +setIdleTimeout 10 11 -inke a$ +pollKey a$ IF a$ = "" THEN GOTO 11 END SUB DEFINT A-Z -SUB mkback +SUB makeBackground +' Generates a random plasma-style background via recursive midpoint displacement CLS -lm1 = 0 -lm2 = 50 +shadeMin = 0 +shadeMax = 50 -s = 2 ^ 7 +cellSize = 2 ^ 7 7 -s = s \ 2 +cellSize = cellSize \ 2 -FOR y = 0 TO 199 STEP s -FOR x = 0 TO 319 STEP s +FOR y = 0 TO 199 STEP cellSize +FOR x = 0 TO 319 STEP cellSize c1 = POINT(x, y) -c2 = POINT(x + s, y) -c3 = POINT(x, y + s) -c4 = POINT(x + s, y + s) +c2 = POINT(x + cellSize, y) +c3 = POINT(x, y + cellSize) +c4 = POINT(x + cellSize, y + cellSize) -sp = s \ 2 +halfCell = cellSize \ 2 -c5 = (c1 + c2 + c3 + c4) / 4 + RND * s - sp -IF c5 > lm2 THEN c5 = lm2 -IF c5 < lm1 THEN c5 = lm1 +c5 = (c1 + c2 + c3 + c4) / 4 + RND * cellSize - halfCell +IF c5 > shadeMax THEN c5 = shadeMax +IF c5 < shadeMin THEN c5 = shadeMin -c6 = (c2 + c4) / 2 + RND * s - sp -IF c6 > lm2 THEN c6 = lm2 -IF c6 < lm1 THEN c6 = lm1 +c6 = (c2 + c4) / 2 + RND * cellSize - halfCell +IF c6 > shadeMax THEN c6 = shadeMax +IF c6 < shadeMin THEN c6 = shadeMin -c7 = (c3 + c4) / 2 + RND * s - sp -IF c7 > lm2 THEN c7 = lm2 -IF c7 < lm1 THEN c7 = lm1 +c7 = (c3 + c4) / 2 + RND * cellSize - halfCell +IF c7 > shadeMax THEN c7 = shadeMax +IF c7 < shadeMin THEN c7 = shadeMin IF INT(RND * 30) = 2 THEN c5 = 50 -PSET (x + sp, y + sp), c5 -PSET (x + s, y + sp), c6 -PSET (x + sp, y + s), c7 +PSET (x + halfCell, y + halfCell), c5 +PSET (x + cellSize, y + halfCell), c6 +PSET (x + halfCell, y + cellSize), c7 NEXT x NEXT y -IF s > 2 THEN GOTO 7 +IF cellSize > 2 THEN GOTO 7 END SUB DEFSNG A-Z -SUB mkfont +SUB makeFont +' Captures the ROM 8x8 pixel patterns of all 256 characters into the fontBitmap array SCREEN 13 FOR a = 0 TO 255 LOCATE 1, 1 @@ -632,75 +650,77 @@ IF a <> 7 THEN PRINT CHR$(a) FOR y = 0 TO 7 FOR x = 0 TO 7 -fontt(x, y, a) = POINT(x, y) +fontBitmap(x, y, a) = POINT(x, y) NEXT x NEXT y NEXT a END SUB -SUB mkjuku (x, y, a, c) -jas(a) = jas(a) + .08 -IF jas(a) > 30000 THEN jas(a) = 0 -b = jas(a) -IF c = 0 THEN b = jas(a) - .08 -x1 = x + COS(b) * 10 -y1 = y + SIN(b) * 5 + 20 +SUB drawBoy (x, y, phaseIndex, shade) +' Draws an animated stick-figure boy ("Juku") with legs, arms and head at x, y; shade 0 erases +animPhase(phaseIndex) = animPhase(phaseIndex) + .08 +IF animPhase(phaseIndex) > 30000 THEN animPhase(phaseIndex) = 0 +angle = animPhase(phaseIndex) +IF shade = 0 THEN angle = animPhase(phaseIndex) - .08 +x1 = x + COS(angle) * 10 +y1 = y + SIN(angle) * 5 + 20 -x2 = x + COS(b) * 5 + 2 -y2 = y + SIN(b) * 3 + 10 +x2 = x + COS(angle) * 5 + 2 +y2 = y + SIN(angle) * 3 + 10 -x3 = x + COS(b + 1) * 2 -y3 = y + SIN(b + 1) * 2 + 2 +x3 = x + COS(angle + 1) * 2 +y3 = y + SIN(angle + 1) * 2 + 2 -LINE (x2, y2)-(x1, y1), c -LINE (x2, y2)-(x3, y3), c +LINE (x2, y2)-(x1, y1), shade +LINE (x2, y2)-(x3, y3), shade -x1 = x + COS(b + pii) * 10 -y1 = y + SIN(b + pii) * 5 + 20 +x1 = x + COS(angle + piValue) * 10 +y1 = y + SIN(angle + piValue) * 5 + 20 -x2 = x + COS(b + pii) * 5 + 2 -y2 = y + SIN(b + pii) * 3 + 10 +x2 = x + COS(angle + piValue) * 5 + 2 +y2 = y + SIN(angle + piValue) * 3 + 10 -LINE (x2, y2)-(x1, y1), c -LINE (x2, y2)-(x3, y3), c +LINE (x2, y2)-(x1, y1), shade +LINE (x2, y2)-(x3, y3), shade -x4 = x + COS(b + 1.2) * 3 - 1 -y4 = y + SIN(b + 1.2) * 1 - 10 +x4 = x + COS(angle + 1.2) * 3 - 1 +y4 = y + SIN(angle + 1.2) * 1 - 10 -LINE (x4, y4)-(x3, y3), c +LINE (x4, y4)-(x3, y3), shade -x5 = x + COS(b + .5) * 13 - 3 -y5 = y + SIN(b + .5) * 2 + 1 +x5 = x + COS(angle + .5) * 13 - 3 +y5 = y + SIN(angle + .5) * 2 + 1 -x6 = x + COS(b + .5) * 15 - 1 -y6 = y + SIN(b + .5) * 3 + 4 +x6 = x + COS(angle + .5) * 15 - 1 +y6 = y + SIN(angle + .5) * 3 + 4 -LINE (x5, y5)-(x4, y4), c -LINE (x5, y5)-(x6, y6), c +LINE (x5, y5)-(x4, y4), shade +LINE (x5, y5)-(x6, y6), shade -x5 = x + COS(b + pii) * 13 - 3 -y5 = y + SIN(b + pii) * 2 + 1 +x5 = x + COS(angle + piValue) * 13 - 3 +y5 = y + SIN(angle + piValue) * 2 + 1 -x6 = x + COS(b + pii) * 15 - 1 -y6 = y + SIN(b + pii) * 3 + 4 +x6 = x + COS(angle + piValue) * 15 - 1 +y6 = y + SIN(angle + piValue) * 3 + 4 -LINE (x5, y5)-(x4, y4), c -LINE (x5, y5)-(x6, y6), c +LINE (x5, y5)-(x4, y4), shade +LINE (x5, y5)-(x6, y6), shade -x7 = x + COS(b + 1.2) * 2 -y7 = y + SIN(b + 1.2) * 1 - 14 +x7 = x + COS(angle + 1.2) * 2 +y7 = y + SIN(angle + 1.2) * 1 - 14 -LINE (x7, y7 + 2)-(x4, y4), c +LINE (x7, y7 + 2)-(x4, y4), shade -CIRCLE (x7, y7), 3, c +CIRCLE (x7, y7), 3, shade END SUB -SUB pal (x) -SELECT CASE x +SUB setPalette (scheme) +' Loads one of four preset VGA palette schemes (1 = gray ramp, 2/4 = blue ramps, 3 = sine colors) +SELECT CASE scheme CASE 1 FOR f = 0 TO 25 @@ -746,71 +766,77 @@ END SELECT END SUB -SUB pal2 (r, g, b) +SUB setBoxPalette1 (red, green, blue) +' Loads palette entries 51-101: shaded-box gradient (type 1) tinted toward the given base color FOR f = 0 TO 25 OUT &H3C8, f + 51 -OUT &H3C9, (f * 2.5 + r * 1) / 2 -OUT &H3C9, (f * 2.5 + g * 1) / 2 -OUT &H3C9, (f * 1.5 + b * 1) / 2 +OUT &H3C9, (f * 2.5 + red * 1) / 2 +OUT &H3C9, (f * 2.5 + green * 1) / 2 +OUT &H3C9, (f * 1.5 + blue * 1) / 2 NEXT f FOR f = 26 TO 50 OUT &H3C8, f + 51 -OUT &H3C9, ((50 - f) * 2.5 + r * 1) / 2 -OUT &H3C9, ((50 - f) * 2.5 + g * 1) / 2 -OUT &H3C9, ((50 - f) * 1.5 + b * 1) / 2 +OUT &H3C9, ((50 - f) * 2.5 + red * 1) / 2 +OUT &H3C9, ((50 - f) * 2.5 + green * 1) / 2 +OUT &H3C9, ((50 - f) * 1.5 + blue * 1) / 2 NEXT f END SUB -SUB pal3 (r, g, b) +SUB setBoxPalette2 (red, green, blue) +' Loads palette entries 102-152: shaded-box gradient (type 2) tinted toward the given base color FOR f = 0 TO 25 OUT &H3C8, f + 102 -OUT &H3C9, (f * 2.5 + r * 1) / 2 -OUT &H3C9, (f * 2.5 + g * 1) / 2 -OUT &H3C9, (f * 1.5 + b * 1) / 2 +OUT &H3C9, (f * 2.5 + red * 1) / 2 +OUT &H3C9, (f * 2.5 + green * 1) / 2 +OUT &H3C9, (f * 1.5 + blue * 1) / 2 NEXT f FOR f = 26 TO 50 OUT &H3C8, f + 102 -OUT &H3C9, ((50 - f) * 2.5 + r * 1) / 2 -OUT &H3C9, ((50 - f) * 2.5 + g * 1) / 2 -OUT &H3C9, ((50 - f) * 1.5 + b * 1) / 2 +OUT &H3C9, ((50 - f) * 2.5 + red * 1) / 2 +OUT &H3C9, ((50 - f) * 2.5 + green * 1) / 2 +OUT &H3C9, ((50 - f) * 1.5 + blue * 1) / 2 NEXT f END SUB -SUB pal4 (c, r!, g!, b!) -OUT &H3C8, c +SUB setPaletteColor (paletteIndex, r!, g!, b!) +' Sets one VGA palette entry to the given red/green/blue components (0-63) +OUT &H3C8, paletteIndex OUT &H3C9, r OUT &H3C9, g OUT &H3C9, b END SUB -SUB pr (x, y, s, c, n, a$) -IF n > LEN(a$) THEN GOTO 10 -a$ = RIGHT$(LEFT$(a$, n), 1) -x1 = n * 8 * s + x -prin x1, y, s, c, a$ +SUB printNthChar (x, y, scale, shade, charIndex, text$) +' Prints only the charIndex-th character of text$ (used for gradual text reveal) +IF charIndex > LEN(text$) THEN GOTO 10 +text$ = RIGHT$(LEFT$(text$, charIndex), 1) +x1 = charIndex * 8 * scale + x +printText x1, y, scale, shade, text$ 10 END SUB -SUB pri (x, y, a$, c) -COLOR c -FOR a = 1 TO LEN(a$) -b$ = RIGHT$(LEFT$(a$, a), 1) +SUB printTypewriter (x, y, text$, shade) +' Prints text$ character by character with a delay (typewriter effect) +COLOR shade +FOR a = 1 TO LEN(text$) +b$ = RIGHT$(LEFT$(text$, a), 1) LOCATE y, x + a PRINT b$ -SOUND 0, 1 +SOUND 0, 1 ' sub-second delay workaround (inaudible 0 Hz sound) NEXT a END SUB -SUB prin (x1, y1, s, c1, a$) +SUB printText (xPos, yPos, scale, shade, text$) +' Prints text$ at a pixel position using the captured bitmap font, scaled by 'scale', in palette shade -FOR a = 1 TO LEN(a$) -b = ASC(RIGHT$(LEFT$(a$, a), 1)) -c = (a - 1) * 8 * s + x1 +FOR a = 1 TO LEN(text$) +b = ASC(RIGHT$(LEFT$(text$, a), 1)) +c = (a - 1) * 8 * scale + xPos FOR y = 0 TO 7 FOR x = 0 TO 7 -IF fontt(x, y, b) > 0 THEN -LINE (x * s + c, y * s + y1)-(x * s + s - 1 + c, y * s + s - 1 + y1), c1, BF +IF fontBitmap(x, y, b) > 0 THEN +LINE (x * scale + c, y * scale + yPos)-(x * scale + scale - 1 + c, y * scale + scale - 1 + yPos), shade, BF END IF NEXT x NEXT y @@ -819,7 +845,8 @@ NEXT a END SUB -SUB resiz +SUB splitTransition +' Transition effect: expanding circle, then the screen splits apart horizontally and vertically FOR a = 1 TO 10 CIRCLE (160, 100), a, a * 2 + 5 @@ -836,7 +863,7 @@ GET (160, 90)-(160 + a, 110), buff2(1) PUT (159 - a, 90), buff1(1), PSET PUT (150 + a, 90), buff2(1), PSET a = a + 1 -SOUND 0, .2 +SOUND 0, .2 ' sub-second delay workaround (inaudible 0 Hz sound) IF a < 140 THEN GOTO 5 a = 1 @@ -848,46 +875,49 @@ PUT (20, 90 - a), buff1(1), PSET PUT (20, 100 + a), buff2(1), PSET a = a + 1 -SOUND 0, .2 +SOUND 0, .2 ' sub-second delay workaround (inaudible 0 Hz sound) IF a < 60 THEN GOTO 6 END SUB -SUB setink (a!) -ink = a -tim$ = TIME$ +SUB setIdleTimeout (seconds!) +' Sets the idle countdown (in seconds) before auto-advance and stamps the current time +idleCountdown = seconds +lastTime$ = TIME$ END SUB SUB start +' Initializes screen, font, random animation phases and the optional auto-advance timer mode SCREEN 13 RANDOMIZE TIMER -mkfont -tim = 0 -tim2 = 0 +makeFont +revealCounter = 0 +revealStage = 0 FOR a = 1 TO 500 -jas(a) = RND * 10 +animPhase(a) = RND * 10 NEXT a -pii = 3.14 +piValue = 3.14 IF COMMAND$ = "t" OR COMMAND$ = "T" THEN -tmr = 1 +autoAdvance = 1 PRINT "timer is on" SLEEP 1 ELSE -tmr = 0 +autoAdvance = 0 END IF END SUB -SUB wpr -tim = tim + 1 -IF tim \ 10 = tim / 10 THEN -a = tim / 10 -SELECT CASE tim2 +SUB updateReveal +' Counts effect ticks and reveals the next character of the "Sources:" text every 10 ticks +revealCounter = revealCounter + 1 +IF revealCounter \ 10 = revealCounter / 10 THEN +a = revealCounter / 10 +SELECT CASE revealStage CASE 0 -IF a = 10 THEN tim2 = 1: tim = 0: pal4 255, 63, 45, 0 +IF a = 10 THEN revealStage = 1: revealCounter = 0: setPaletteColor 255, 63, 45, 0 CASE 1 -pr 10, 10, 2, 255, a, "Sources:" +printNthChar 10, 10, 2, 255, a, "Sources:" END SELECT END IF diff --git a/3D GFX/Space/Galaxy explorer.bas b/3D GFX/Space/Galaxy explorer.bas index ab2f8c9..f58979e 100755 --- a/3D GFX/Space/Galaxy explorer.bas +++ b/3D GFX/Space/Galaxy explorer.bas @@ -8,6 +8,7 @@ ' Changelog: ' 2003, Initial version. ' 2024, Improved program readability. +' 2026, Improved program readability. ' ' User can navigate through the galaxy using mouse or keyboard controls. ' @@ -22,11 +23,12 @@ ' - 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!) @@ -75,12 +77,14 @@ currentZ = 0 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 @@ -90,13 +94,15 @@ CASE 2 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) @@ -157,7 +163,8 @@ myY = myY + speedY 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) @@ -191,10 +198,12 @@ NEXT pointIndex 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) @@ -209,10 +218,11 @@ getWord = combinedValue 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) @@ -227,21 +237,21 @@ spiralBarsMultiplier = 3 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 @@ -262,11 +272,13 @@ NEXT pointIndex 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) @@ -287,16 +299,18 @@ POKE (externalAddress + address + 1), firstByteValue 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 @@ -307,8 +321,9 @@ randomPointer = 0 END SUB SUB start +' Set up graphics mode and initialize program state. -starText +initMouseDriver ' Set up graphics mode SCREEN 7, , , 1 @@ -319,7 +334,8 @@ rndInit 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 @@ -337,6 +353,7 @@ PRINT "relative address is:"; externalAddress ' 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!" diff --git a/Games/Worm/8.lvl b/Games/Worm/8.lvl index d4bdc60..35bedb0 100644 --- a/Games/Worm/8.lvl +++ b/Games/Worm/8.lvl @@ -11,15 +11,15 @@ / /#m m# /#m m# -/#m m mmmm m m# -/#m m m m m m# -/#m m m m m m# -/#m m m m m m# +/#m m m m m# +/#m m m m m# +/#m m m m m# +/#m m m m m# /#m m mmmmmmmmm m m# -/#m m m m m m# -/#m m m m m m# -/#m m m m m m# -/#m m mmmm m m# +/#m m m m m# +/#m m m m m# +/#m m m m m# +/#m m m m m# /#m m# /#m m# / diff --git a/Games/Worm/worm.bas b/Games/Worm/worm.bas index 83a56cc..166bd9c 100755 --- a/Games/Worm/worm.bas +++ b/Games/Worm/worm.bas @@ -19,48 +19,49 @@ ' Changelog: ' 2002, Initial version ' 2024-2005, Improved program readability - -DECLARE FUNCTION cnum$ (a%) -DECLARE SUB putworm (a%) -DECLARE SUB level (a%) -DECLARE SUB showb () -DECLARE SUB sc2 (x%, y%) -DECLARE SUB ai (a%) -DECLARE SUB autop (a%) -DECLARE SUB prc (a%) -DECLARE SUB dead (a%) +' 2026, Improved program readability + +DECLARE FUNCTION numStr$ (value%) +DECLARE SUB spawnWorm (playerNumber%) +DECLARE SUB startLevel (levelNum%) +DECLARE SUB showDistMap () +DECLARE SUB debugTrace (x%, y%) +DECLARE SUB planPath (playerNumber%) +DECLARE SUB autopilot (playerNumber%) +DECLARE SUB advanceWorm (a%) +DECLARE SUB handleDeath (playerNumber%) DECLARE SUB add (a%) -DECLARE SUB tkt () +DECLARE SUB gameTick () DECLARE SUB subt (b%) -DECLARE SUB show () +DECLARE SUB drawArena () DECLARE SUB sc (x%, y%) DEFINT A-Z ' Shared arrays for the game grid and worms -DIM SHARED buf(0 TO 36, 0 TO 36) -DIM SHARED buf2(0 TO 36, 0 TO 36) -DIM SHARED ussx(1 TO 2000, 1 TO 5) -DIM SHARED ussy(1 TO 2000, 1 TO 5) -DIM SHARED ussp(1 TO 5) -DIM SHARED ussl(1 TO 5) -DIM SHARED usss(1 TO 5) -DIM SHARED ussk(1 TO 2000, 1 TO 5) -DIM SHARED usskp(1 TO 5) +DIM SHARED arena(0 TO 36, 0 TO 36) ' grid cell: 0=empty, 1=wall, 2=fruit, 10+worm +DIM SHARED distMap(0 TO 36, 0 TO 36) ' AI distance field: 32000=unreached, -1=blocked, 0=fruit, else distance +DIM SHARED trailX(1 TO 2000, 1 TO 5) ' ring buffer of worm body positions, X coordinate +DIM SHARED trailY(1 TO 2000, 1 TO 5) ' ring buffer of worm body positions, Y coordinate +DIM SHARED headPtr(1 TO 5) ' ring buffer index of the worm head +DIM SHARED wormLen(1 TO 5) ' worm length in grid cells +DIM SHARED score(1 TO 5) ' player score +DIM SHARED pathPlan(1 TO 2000, 1 TO 5) ' AI movement plan (direction codes 1-4, 5=replan) +DIM SHARED planPtr(1 TO 5) ' index of the next step in pathPlan ' Variables for worm positions and game state -DIM SHARED ux(1 TO 5), uy(1 TO 5), uxp(1 TO 5), uyp(1 TO 5) -DIM SHARED mtm +DIM SHARED headX(1 TO 5), headY(1 TO 5), dirX(1 TO 5), dirY(1 TO 5) ' worm head position and direction +DIM SHARED fruitCount ' fruits eaten on current level (next level at 15) DIM SHARED playerCount DIM SHARED lives(1 TO 5) DIM SHARED isAI(1 TO 5) -DIM SHARED ail -DIM SHARED lvl -DIM SHARED elum -DIM SHARED spd +DIM SHARED planLimit ' maximum AI plan length in steps +DIM SHARED levelNum ' current level number +DIM SHARED startLives ' lives each worm starts with +DIM SHARED speed ' game speed (larger = faster) playerCount = 1 -ail = 10 -lvl = 1 +planLimit = 10 +levelNum = 1 ' Array defines if player is human (0) or computer (1). isAI(1) = 0 @@ -72,220 +73,220 @@ isAI(5) = 0 CLS INPUT "How many players (1 - 5):", playerCount -INPUT "How many of them are computers:", a -FOR b = playerCount TO playerCount - a + 1 STEP -1 - isAI(b) = 1 -NEXT b +INPUT "How many of them are computers:", computerCount +FOR player = playerCount TO playerCount - computerCount + 1 STEP -1 + isAI(player) = 1 +NEXT player -INPUT "How many lives:", elum -INPUT "Speed: (1-slow, 3-ok, 10-very fast)", spd +INPUT "How many lives:", startLives +INPUT "Speed: (1-slow, 3-ok, 10-very fast)", speed start -level lvl +startLevel levelNum 1 -tkt -delay .5 / spd -' spd -IF mtm >= 15 THEN - mtm = 1 - lvl = lvl + 1 - level lvl +gameTick +delay .5 / speed +' speed +IF fruitCount >= 15 THEN + fruitCount = 1 + levelNum = levelNum + 1 + startLevel levelNum END IF GOTO 1 -SUB ai (a%) - ' This subroutine handles the AI logic for computer-controlled worms. +SUB planPath (playerNumber%) + ' Computes a distance field to the nearest fruit and builds a movement plan. FOR y = 0 TO 36 FOR x = 0 TO 36 - buf2(x, y) = 32000 - IF buf(x, y) = 2 THEN buf2(x, y) = 0 - IF buf(x, y) > 9 OR buf(x, y) = 1 THEN buf2(x, y) = -1 + distMap(x, y) = 32000 + IF arena(x, y) = 2 THEN distMap(x, y) = 0 + IF arena(x, y) > 9 OR arena(x, y) = 1 THEN distMap(x, y) = -1 NEXT x NEXT y - ' Set the target position to the center of the grid. - IF buf2(16, 16) = 32000 THEN buf2(16, 16) = 15000 + ' If no fruit is reachable, use the grid center as a fallback target. + IF distMap(16, 16) = 32000 THEN distMap(16, 16) = 15000 6 b = 0 FOR y = 1 TO 35 FOR x = 1 TO 34 - IF (buf2(x + 1, y) > buf2(x, y) + 1) AND (buf2(x, y) >= 0) THEN - buf2(x + 1, y) = buf2(x, y) + 1 + IF (distMap(x + 1, y) > distMap(x, y) + 1) AND (distMap(x, y) >= 0) THEN + distMap(x + 1, y) = distMap(x, y) + 1 b = 1 END IF NEXT x - ' Check if moving left is the shortest path. + ' Check if moving right is the shortest path. FOR x = 35 TO 2 STEP -1 - IF (buf2(x - 1, y) > buf2(x, y) + 1) AND (buf2(x, y) >= 0) THEN - buf2(x - 1, y) = buf2(x, y) + 1 + IF (distMap(x - 1, y) > distMap(x, y) + 1) AND (distMap(x, y) >= 0) THEN + distMap(x - 1, y) = distMap(x, y) + 1 b = 1 END IF NEXT x - IF (buf2(1, y) > buf2(35, y) + 1) AND (buf2(35, y) >= 0) THEN - buf2(1, y) = buf2(35, y) + 1 + IF (distMap(1, y) > distMap(35, y) + 1) AND (distMap(35, y) >= 0) THEN + distMap(1, y) = distMap(35, y) + 1 b = 1 END IF - IF (buf2(35, y) > buf2(1, y) + 1) AND (buf2(1, y) >= 0) THEN - buf2(35, y) = buf2(1, y) + 1 + IF (distMap(35, y) > distMap(1, y) + 1) AND (distMap(1, y) >= 0) THEN + distMap(35, y) = distMap(1, y) + 1 b = 1 END IF NEXT y FOR x = 1 TO 35 FOR y = 1 TO 34 - IF (buf2(x, y + 1) > buf2(x, y) + 1) AND (buf2(x, y) >= 0) THEN - buf2(x, y + 1) = buf2(x, y) + 1 + IF (distMap(x, y + 1) > distMap(x, y) + 1) AND (distMap(x, y) >= 0) THEN + distMap(x, y + 1) = distMap(x, y) + 1 b = 1 END IF NEXT y - ' Check if moving up is the shortest path. + ' Check if moving down is the shortest path. FOR y = 35 TO 2 STEP -1 - IF (buf2(x, y - 1) > buf2(x, y) + 1) AND (buf2(x, y) >= 0) THEN - buf2(x, y - 1) = buf2(x, y) + 1 + IF (distMap(x, y - 1) > distMap(x, y) + 1) AND (distMap(x, y) >= 0) THEN + distMap(x, y - 1) = distMap(x, y) + 1 b = 1 END IF NEXT y - IF (buf2(x, 1) > buf2(x, 35) + 1) AND (buf2(x, 35) >= 0) THEN - buf2(x, 1) = buf2(x, 35) + 1 + IF (distMap(x, 1) > distMap(x, 35) + 1) AND (distMap(x, 35) >= 0) THEN + distMap(x, 1) = distMap(x, 35) + 1 b = 1 END IF - IF (buf2(x, 35) > buf2(x, 1) + 1) AND (buf2(x, 1) >= 0) THEN - buf2(x, 35) = buf2(x, 1) + 1 + IF (distMap(x, 35) > distMap(x, 1) + 1) AND (distMap(x, 1) >= 0) THEN + distMap(x, 35) = distMap(x, 1) + 1 b = 1 END IF NEXT x - ' If no shorter path is found, exit the loop. + ' Repeat the relaxation passes until no cell distance improves. IF b = 1 THEN GOTO 6 - tx = ux(a) - ty = uy(a) + traceX = headX(playerNumber) + traceY = headY(playerNumber) - d = 0 + stepCount = 0 7 b = 32001 - tmpxp = 0 - tmpyp = 0 + stepX = 0 + stepY = 0 - ' Check if moving right is the shortest path. - IF (buf2(tx - 1, ty) < b) AND (buf2(tx - 1, ty) >= 0) THEN - b = buf2(tx - 1, ty) - tmpxp = -1 - tmpyp = 0 - c = 1 + ' Check if moving left is the shortest path. + IF (distMap(traceX - 1, traceY) < b) AND (distMap(traceX - 1, traceY) >= 0) THEN + b = distMap(traceX - 1, traceY) + stepX = -1 + stepY = 0 + direction = 1 END IF - ' Check if moving down is the shortest path. - IF (buf2(tx, ty - 1) < b) AND (buf2(tx, ty - 1) >= 0) THEN - b = buf2(tx, ty - 1) - tmpxp = 0 - tmpyp = -1 - c = 2 + ' Check if moving up is the shortest path. + IF (distMap(traceX, traceY - 1) < b) AND (distMap(traceX, traceY - 1) >= 0) THEN + b = distMap(traceX, traceY - 1) + stepX = 0 + stepY = -1 + direction = 2 END IF - ' Check if moving left is the shortest path. - IF (buf2(tx + 1, ty) < b) AND (buf2(tx + 1, ty) >= 0) THEN - b = buf2(tx + 1, ty) - tmpxp = 1 - tmpyp = 0 - c = 3 + ' Check if moving right is the shortest path. + IF (distMap(traceX + 1, traceY) < b) AND (distMap(traceX + 1, traceY) >= 0) THEN + b = distMap(traceX + 1, traceY) + stepX = 1 + stepY = 0 + direction = 3 END IF - ' Check if moving up is the shortest path. - IF (buf2(tx, ty + 1) < b) AND (buf2(tx, ty + 1) >= 0) THEN - b = buf2(tx, ty + 1) - tmpxp = 0 - tmpyp = 1 - c = 4 + ' Check if moving down is the shortest path. + IF (distMap(traceX, traceY + 1) < b) AND (distMap(traceX, traceY + 1) >= 0) THEN + b = distMap(traceX, traceY + 1) + stepX = 0 + stepY = 1 + direction = 4 END IF - ' If no shorter path is found, set the direction to random. + ' If no neighbor is reachable, default to moving left. IF b = 32001 THEN - tmpxp = -1 - tmpyp = 0 - c = 1 + stepX = -1 + stepY = 0 + direction = 1 b = -1 END IF - buf2(tx, ty) = -1 - d = d + 1 - ussk(d, a) = c - tx = tx + tmpxp - ty = ty + tmpyp + distMap(traceX, traceY) = -1 + stepCount = stepCount + 1 + pathPlan(stepCount, playerNumber) = direction + traceX = traceX + stepX + traceY = traceY + stepY ' Wrap around the edges of the grid. - IF tx = 1 THEN tx = 34 - IF ty = 1 THEN ty = 34 - IF tx = 35 THEN tx = 2 - IF ty = 35 THEN ty = 2 + IF traceX = 1 THEN traceX = 34 + IF traceY = 1 THEN traceY = 34 + IF traceX = 35 THEN traceX = 2 + IF traceY = 35 THEN traceY = 2 - e = buf2(tx, ty) - buf2(tx, ty) = -1 + cellDist = distMap(traceX, traceY) + distMap(traceX, traceY) = -1 - sc2 tx, ty + debugTrace traceX, traceY - ' If the worm hits a wall or another worm, stop moving. - IF d > ail THEN GOTO 8 + ' Stop tracing when the plan reaches its maximum length. + IF stepCount > planLimit THEN GOTO 8 - ' If the worm finds food, continue moving. - IF (e > 0) AND (b > -1) THEN GOTO 7 + ' Keep tracing while the path still leads toward a fruit. + IF (cellDist > 0) AND (b > -1) THEN GOTO 7 8 - d = d + 1 - ussk(d, a) = 5 - usskp(a) = 1 + stepCount = stepCount + 1 + pathPlan(stepCount, playerNumber) = 5 + planPtr(playerNumber) = 1 - showb + showDistMap END SUB -SUB autop (a%) - ' This subroutine handles the movement of computer-controlled worms. - c = 0 +SUB autopilot (playerNumber%) + ' Follows the AI movement plan; replans when the path is blocked. + replanned = 0 5 ' If the worm is not at the end of its path, continue moving. - IF usskp(a) > 0 THEN - b = ussk(usskp(a), a) + IF planPtr(playerNumber) > 0 THEN + b = pathPlan(planPtr(playerNumber), playerNumber) IF b = 1 THEN - uxp(a) = -1 - uyp(a) = 0 + dirX(playerNumber) = -1 + dirY(playerNumber) = 0 ELSEIF b = 2 THEN - uxp(a) = 0 - uyp(a) = -1 + dirX(playerNumber) = 0 + dirY(playerNumber) = -1 ELSEIF b = 3 THEN - uxp(a) = 1 - uyp(a) = 0 + dirX(playerNumber) = 1 + dirY(playerNumber) = 0 ELSEIF b = 4 THEN - uxp(a) = 0 - uyp(a) = 1 + dirX(playerNumber) = 0 + dirY(playerNumber) = 1 ELSEIF b = 5 THEN - ai a + planPath playerNumber GOTO 5 END IF - usskp(a) = usskp(a) + 1 + planPtr(playerNumber) = planPtr(playerNumber) + 1 END IF ' Calculate the new position of the worm. - nx = ux(a) + uxp(a) - ny = uy(a) + uyp(a) + nextX = headX(playerNumber) + dirX(playerNumber) + nextY = headY(playerNumber) + dirY(playerNumber) ' Check if the worm hits a wall or another worm. - b = buf(INT(nx), INT(ny)) + b = arena(INT(nextX), INT(nextY)) ' If the worm hits a wall or another worm, recalculate the AI. - IF (b = 1 OR b > 9) AND (c = 0) THEN - ai a - c = 1 + IF (b = 1 OR b > 9) AND (replanned = 0) THEN + planPath playerNumber + replanned = 1 GOTO 5 END IF END SUB @@ -296,46 +297,46 @@ SUB clearTail (playerNumber) ' is responsible for clearing out squares where worm tail moved out ' of. Such squares are marked as empty (no longer occupied by worm) ' and also correspondingly are erased from the screen. - a = ussp(playerNumber) - ussl(playerNumber) + tailPtr = headPtr(playerNumber) - wormLen(playerNumber) - IF a < 1 THEN - a = a + 2000 + IF tailPtr < 1 THEN + tailPtr = tailPtr + 2000 END IF ' The tail position can fall outside the ring buffer: below 1 when ' the worm has grown longer than the buffer capacity, above 2000 ' when a dead worm's head pointer keeps advancing without wrapping. ' Nothing to erase in those cases. - IF a < 1 OR a > 2000 THEN + IF tailPtr < 1 OR tailPtr > 2000 THEN GOTO 13 END IF - IF ussx(a, playerNumber) > 0 THEN - buf(ussx(a, playerNumber), ussy(a, playerNumber)) = 0 + IF trailX(tailPtr, playerNumber) > 0 THEN + arena(trailX(tailPtr, playerNumber), trailY(tailPtr, playerNumber)) = 0 - drawGridCell ussx(a, playerNumber), ussy(a, playerNumber) + drawGridCell trailX(tailPtr, playerNumber), trailY(tailPtr, playerNumber) - ussx(a, playerNumber) = 0 + trailX(tailPtr, playerNumber) = 0 END IF 13 END SUB -FUNCTION cnum$ (a%) +FUNCTION numStr$ (value%) ' This function converts an integer to a string. - b$ = STR$(a%) + text$ = STR$(value%) ' Remove leading spaces from the string. - IF LEFT$(b$, 1) = " " THEN - b$ = RIGHT$(b$, LEN(b$) - 1) + IF LEFT$(text$, 1) = " " THEN + text$ = RIGHT$(text$, LEN(text$) - 1) END IF - cnum$ = b$ + numStr$ = text$ END FUNCTION -SUB dead (a%) +SUB handleDeath (playerNumber%) ' This subroutine handles the death of a worm. - lives(a) = lives(a) - 1 - putworm a + lives(playerNumber) = lives(playerNumber) - 1 + spawnWorm playerNumber END SUB SUB delay (delayInSeconds AS SINGLE) @@ -350,108 +351,108 @@ SUB drawGridCell (x%, y%) ' This subroutine updates one cell on the screen as denoted by its ' X and Y coordinates. ' -' Cell content is red from global 'buf' array and corresponding +' Cell content is read from global 'arena' array and corresponding ' sprite is drawn on the screen. ' ' This procedure is handy because it allows redrawing only parts of the ' screen that were changed and thereby we avoid redrawing entire screen ' for every frame. - x1 = x% * 5 + pixelX = x% * 5 - y1 = y% * 5 + pixelY = y% * 5 - LINE (x1, y1)-(x1 + 3, y1 + 3), 0, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 0, BF - SELECT CASE buf(x%, y%) + SELECT CASE arena(x%, y%) CASE 0 ' Draw an empty space on the grid. - LINE (x1, y1)-(x1 + 3, y1 + 3), 1, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 1, BF CASE 1 ' Draw a wall on the grid. - LINE (x1, y1)-(x1 + 3, y1 + 3), 7, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 7, BF - LINE (x1, y1)-(x1 + 3, y1 + 3), 8, B + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 8, B CASE 2 ' Draw food on the grid. - LINE (x1, y1)-(x1 + 3, y1 + 3), 14, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 14, BF CASE 10 ' Draw the head of a worm. - LINE (x1, y1)-(x1 + 3, y1 + 3), 10, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 10, BF - PSET (x1, y1), 0 + PSET (pixelX, pixelY), 0 - PSET (x1 + 3, y1), 0 + PSET (pixelX + 3, pixelY), 0 - PSET (x1, y1 + 3), 0 + PSET (pixelX, pixelY + 3), 0 - PSET (x1 + 3, y1 + 3), 0 + PSET (pixelX + 3, pixelY + 3), 0 CASE 11 ' Draw the body of a worm. - LINE (x1, y1)-(x1 + 3, y1 + 3), 12, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 12, BF - PSET (x1, y1), 0 + PSET (pixelX, pixelY), 0 - PSET (x1 + 3, y1), 0 + PSET (pixelX + 3, pixelY), 0 - PSET (x1, y1 + 3), 0 + PSET (pixelX, pixelY + 3), 0 - PSET (x1 + 3, y1 + 3), 0 + PSET (pixelX + 3, pixelY + 3), 0 CASE 12 ' Draw the body of a worm. - LINE (x1, y1)-(x1 + 3, y1 + 3), 13, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 13, BF - PSET (x1, y1), 0 + PSET (pixelX, pixelY), 0 - PSET (x1 + 3, y1), 0 + PSET (pixelX + 3, pixelY), 0 - PSET (x1, y1 + 3), 0 + PSET (pixelX, pixelY + 3), 0 - PSET (x1 + 3, y1 + 3), 0 + PSET (pixelX + 3, pixelY + 3), 0 CASE 13 ' Draw the body of a worm. - LINE (x1, y1)-(x1 + 3, y1 + 3), 15, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 15, BF - PSET (x1, y1), 0 + PSET (pixelX, pixelY), 0 - PSET (x1 + 3, y1), 0 + PSET (pixelX + 3, pixelY), 0 - PSET (x1, y1 + 3), 0 + PSET (pixelX, pixelY + 3), 0 - PSET (x1 + 3, y1 + 3), 0 + PSET (pixelX + 3, pixelY + 3), 0 CASE 14 ' Draw the body of a worm. - LINE (x1, y1)-(x1 + 3, y1 + 3), 9, BF + LINE (pixelX, pixelY)-(pixelX + 3, pixelY + 3), 9, BF - PSET (x1, y1), 0 + PSET (pixelX, pixelY), 0 - PSET (x1 + 3, y1), 0 + PSET (pixelX + 3, pixelY), 0 - PSET (x1, y1 + 3), 0 + PSET (pixelX, pixelY + 3), 0 - PSET (x1 + 3, y1 + 3), 0 + PSET (pixelX + 3, pixelY + 3), 0 END SELECT END SUB SUB init ' Initialize the game by setting up the first level. - level 1 + startLevel 1 END SUB -SUB level (a%) +SUB startLevel (levelNum%) ' This subroutine sets up a new level of the game. LOCATE 5, 5 PRINT "G E T R E A D Y" LOCATE 7, 5 - PRINT "L E V E L :"; a% + PRINT "L E V E L :"; levelNum% ' Display a countdown before starting the level. delay 2 @@ -461,52 +462,52 @@ SUB level (a%) ' Clear the game grid. FOR y = 0 TO 36 FOR x = 0 TO 36 - buf(x, y) = 0 + arena(x, y) = 0 NEXT x NEXT y ' Set up the walls of the grid. FOR x = 0 TO 36 - buf(x, 0) = 1 - buf(x, 36) = 1 - buf(0, x) = 1 - buf(36, x) = 1 + arena(x, 0) = 1 + arena(x, 36) = 1 + arena(0, x) = 1 + arena(36, x) = 1 NEXT x ' Load the level from a file. - b$ = cnum(a%) + ".lvl" + fileName$ = numStr(levelNum%) + ".lvl" - OPEN b$ FOR INPUT AS #1 + OPEN fileName$ FOR INPUT AS #1 10 ' Read the level data line by line. IF EOF(1) <> 0 THEN GOTO 11 - LINE INPUT #1, c$ + LINE INPUT #1, rowText$ ' If the line starts with a slash, it contains grid data. - IF LEFT$(c$, 1) = "/" THEN - d = d + 1 + IF LEFT$(rowText$, 1) = "/" THEN + rowNum = rowNum + 1 - IF d > 35 THEN + IF rowNum > 35 THEN GOTO 12 END IF - g = LEN(c$) - IF g > 36 THEN - g = 36 + rowLen = LEN(rowText$) + IF rowLen > 36 THEN + rowLen = 36 END IF ' Parse the grid data and set up the game grid. - FOR e = 2 TO g - f$ = RIGHT$(LEFT$(c$, e), 1) + FOR column = 2 TO rowLen + cellChar$ = RIGHT$(LEFT$(rowText$, column), 1) - IF f$ = "#" OR f$ = "m" THEN - buf(e - 1, d) = 1 + IF cellChar$ = "#" OR cellChar$ = "m" THEN + arena(column - 1, rowNum) = 1 ELSE - buf(e - 1, d) = 0 + arena(column - 1, rowNum) = 0 END IF - NEXT e + NEXT column END IF 12 @@ -516,31 +517,31 @@ SUB level (a%) CLOSE #1 ' Place food randomly on the grid. - stuff + placeFruit ' Initialize the worms for each player. - show + drawArena - FOR b = 1 TO playerCount - ussl(b) = 0 - putworm b - NEXT b + FOR player = 1 TO playerCount + wormLen(player) = 0 + spawnWorm player + NEXT player - stat + showStats END SUB -SUB prc (playerNumber) +SUB advanceWorm (playerNumber) ' This subroutine handles the main game loop for each player. clearTail playerNumber - ussp(playerNumber) = ussp(playerNumber) + 1 + headPtr(playerNumber) = headPtr(playerNumber) + 1 ' Wrap the head pointer unconditionally: dead worms skip the rest of ' this procedure, so without wrapping here their pointer would grow ' past the ring buffer (and eventually overflow the integer). - IF ussp(playerNumber) > 2000 THEN - ussp(playerNumber) = ussp(playerNumber) - 2000 + IF headPtr(playerNumber) > 2000 THEN + headPtr(playerNumber) = headPtr(playerNumber) - 2000 END IF ' If the current player has no lives left, no further processing is needed @@ -550,122 +551,122 @@ SUB prc (playerNumber) ' If the worm is controlled by AI, recalculate its path. IF isAI(playerNumber) = 1 THEN - autop playerNumber + autopilot playerNumber END IF ' Move the worm based on user input or AI direction. - ux(playerNumber) = ux(playerNumber) + uxp(playerNumber) - uy(playerNumber) = uy(playerNumber) + uyp(playerNumber) + headX(playerNumber) = headX(playerNumber) + dirX(playerNumber) + headY(playerNumber) = headY(playerNumber) + dirY(playerNumber) ' Wrap around the edges of the grid. - IF ux(playerNumber) = 35 THEN - ux(playerNumber) = 2 + IF headX(playerNumber) = 35 THEN + headX(playerNumber) = 2 END IF - IF uy(playerNumber) = 35 THEN - uy(playerNumber) = 2 + IF headY(playerNumber) = 35 THEN + headY(playerNumber) = 2 END IF - IF ux(playerNumber) = 1 THEN - ux(playerNumber) = 34 + IF headX(playerNumber) = 1 THEN + headX(playerNumber) = 34 END IF - IF uy(playerNumber) = 1 THEN - uy(playerNumber) = 34 + IF headY(playerNumber) = 1 THEN + headY(playerNumber) = 34 END IF - x = ux(playerNumber) - y = uy(playerNumber) + cellX = headX(playerNumber) + cellY = headY(playerNumber) 3 - IF buf(x, y) = 2 THEN - buf(x, y) = 0 + IF arena(cellX, cellY) = 2 THEN + arena(cellX, cellY) = 0 - drawGridCell x, y + drawGridCell cellX, cellY - stuff + placeFruit - ussl(playerNumber) = ussl(playerNumber) + mtm + wormLen(playerNumber) = wormLen(playerNumber) + fruitCount - usss(playerNumber) = usss(playerNumber) + mtm + score(playerNumber) = score(playerNumber) + fruitCount - FOR b = 1 TO playerCount - IF (lives(b) > 0) AND (isAI(b) = 1) THEN - ai b + FOR player = 1 TO playerCount + IF (lives(player) > 0) AND (isAI(player) = 1) THEN + planPath player END IF - NEXT b + NEXT player - stat + showStats GOTO 3 END IF - IF buf(x, y) > 0 THEN - dead playerNumber + IF arena(cellX, cellY) > 0 THEN + handleDeath playerNumber GOTO 4 END IF IF playerNumber = 1 THEN - buf(x, y) = 10 + arena(cellX, cellY) = 10 ELSEIF playerNumber = 2 THEN - buf(x, y) = 11 + arena(cellX, cellY) = 11 ELSEIF playerNumber = 3 THEN - buf(x, y) = 12 + arena(cellX, cellY) = 12 ELSEIF playerNumber = 4 THEN - buf(x, y) = 13 + arena(cellX, cellY) = 13 ELSEIF playerNumber = 5 THEN - buf(x, y) = 14 + arena(cellX, cellY) = 14 END IF - drawGridCell x, y + drawGridCell cellX, cellY - IF ussp(playerNumber) > 2000 THEN - ussp(playerNumber) = ussp(playerNumber) - 2000 + IF headPtr(playerNumber) > 2000 THEN + headPtr(playerNumber) = headPtr(playerNumber) - 2000 END IF - ussx(ussp(playerNumber), playerNumber) = x + trailX(headPtr(playerNumber), playerNumber) = cellX - ussy(ussp(playerNumber), playerNumber) = y + trailY(headPtr(playerNumber), playerNumber) = cellY 4 END SUB -SUB putworm (a%) +SUB spawnWorm (playerNumber%) ' This subroutine initializes a new worm for a player. - b = ussl(a%) + b = wormLen(playerNumber%) ' Move the worm back to its starting position. - FOR c = b TO 1 STEP -1 - ussl(a%) = c + FOR segment = b TO 1 STEP -1 + wormLen(playerNumber%) = segment - clearTail a% - NEXT c + clearTail playerNumber% + NEXT segment 9 - uy(a%) = INT(RND * 30 + 2) + headY(playerNumber%) = INT(RND * 30 + 2) - ux(a%) = INT(RND * 10 + 5) + headX(playerNumber%) = INT(RND * 10 + 5) ' Ensure that the worm starts in an empty space. - FOR b = ux(a%) TO ux(a%) + 10 - IF buf(b, uy(a%)) <> 0 THEN + FOR b = headX(playerNumber%) TO headX(playerNumber%) + 10 + IF arena(b, headY(playerNumber%)) <> 0 THEN GOTO 9 END IF NEXT b ' Set the initial direction of the worm. - uxp(a%) = 1 + dirX(playerNumber%) = 1 - uyp(a%) = 0 + dirY(playerNumber%) = 0 - ussl(a%) = 3 + wormLen(playerNumber%) = 3 - stat + showStats END SUB -SUB sc2 (x%, y%) - ' This subroutine draws a worm on the game grid for AI pathfinding. +SUB debugTrace (x%, y%) + ' Debug helper: plots the AI path trace on screen (currently disabled). ' LOCATE 1, 1 ' PRINT x%, y% @@ -678,7 +679,7 @@ SUB sc2 (x%, y%) ' a$ = INPUT$(1) END SUB -SUB show +SUB drawArena ' This subroutine draws the entire game grid. FOR y = 1 TO 35 FOR x = 1 TO 35 @@ -687,12 +688,13 @@ SUB show NEXT y END SUB -SUB showb +SUB showDistMap + ' Disabled debug view: draws the AI distance map (distMap) beside the arena. GOTO 15 FOR x = 1 TO 35 FOR y = 1 TO 35 -LINE (x * 2 + 200, y * 2 + 100)-(x * 2 + 201, y * 2 + 101), buf2(x, y) MOD 255, BF +LINE (x * 2 + 200, y * 2 + 100)-(x * 2 + 201, y * 2 + 101), distMap(x, y) MOD 255, BF NEXT y NEXT x 15 @@ -705,57 +707,57 @@ SUB start RANDOMIZE TIMER - uy(1) = 5 + headY(1) = 5 - uy(2) = 10 + headY(2) = 10 - uy(3) = 15 + headY(3) = 15 - uy(4) = 20 + headY(4) = 20 - uy(5) = 25 + headY(5) = 25 - FOR a = 1 TO playerCount - ux(a) = 15 + FOR player = 1 TO playerCount + headX(player) = 15 - uxp(a) = 1 + dirX(player) = 1 - uyp(a) = 0 + dirY(player) = 0 - ussp(a) = 0 + headPtr(player) = 0 - ussl(a) = 3 + wormLen(player) = 3 - lives(a) = elum + lives(player) = startLives - usss(a) = 0 + score(player) = 0 - usskp(a) = 1 + planPtr(player) = 1 - ussk(1, a) = 5 - NEXT a + pathPlan(1, player) = 5 + NEXT player - mtm = 0 + fruitCount = 0 END SUB -SUB stat +SUB showStats ' This subroutine displays the current game statistics. LOCATE 1, 25 - PRINT mtm + PRINT fruitCount - FOR a = 1 TO 5 + FOR player = 1 TO 5 COLOR 15 - LOCATE 2 + a, 24 + LOCATE 2 + player, 24 - PRINT RIGHT$(STR$(a), 1) + PRINT RIGHT$(STR$(player), 1) COLOR 10 - LOCATE 2 + a, 26 + LOCATE 2 + player, 26 - IF isAI(a) = 1 THEN + IF isAI(player) = 1 THEN PRINT "*" ELSE PRINT "-" @@ -763,20 +765,20 @@ SUB stat COLOR 12 - LOCATE 2 + a, 27 + LOCATE 2 + player, 27 - b$ = STR$(usss(a)) + text$ = STR$(score(player)) - PRINT RIGHT$(b$, LEN(b$) - 1) + PRINT RIGHT$(text$, LEN(text$) - 1) COLOR 13 - LOCATE 2 + a, 30 + LOCATE 2 + player, 30 - b$ = STR$(lives(a)) + text$ = STR$(lives(player)) - PRINT RIGHT$(b$, LEN(b$) - 1) - NEXT a + PRINT RIGHT$(text$, LEN(text$) - 1) + NEXT player COLOR 10 @@ -798,98 +800,98 @@ SUB stat LOCATE 1, 30 - PRINT "Level:"; lvl + PRINT "Level:"; levelNum END SUB -SUB stuff +SUB placeFruit ' This subroutine places food randomly on the game grid. 2 x = INT(RND * 33 + 2) y = INT(RND * 33 + 2) - IF buf(x, y) = 0 THEN - buf(x, y) = 2 + IF arena(x, y) = 0 THEN + arena(x, y) = 2 drawGridCell x, y ELSE GOTO 2 END IF - mtm = mtm + 1 + fruitCount = fruitCount + 1 - stat + showStats END SUB -SUB tkt - ' This subroutine handles user input and AI recalculation. - a$ = INKEY$ +SUB gameTick + ' One game tick: read keyboard input, then advance every worm. + key$ = INKEY$ - IF a$ = CHR$(27) THEN + IF key$ = CHR$(27) THEN SYSTEM END IF - IF (a$ = CHR$(0) + "M") AND (uxp(1) <> -1) THEN - uxp(1) = 1 + IF (key$ = CHR$(0) + "M") AND (dirX(1) <> -1) THEN + dirX(1) = 1 - uyp(1) = 0 + dirY(1) = 0 END IF - IF (a$ = CHR$(0) + "K") AND (uxp(1) <> 1) THEN - uxp(1) = -1 + IF (key$ = CHR$(0) + "K") AND (dirX(1) <> 1) THEN + dirX(1) = -1 - uyp(1) = 0 + dirY(1) = 0 END IF - IF (a$ = CHR$(0) + "P") AND (uyp(1) <> -1) THEN - uxp(1) = 0 + IF (key$ = CHR$(0) + "P") AND (dirY(1) <> -1) THEN + dirX(1) = 0 - uyp(1) = 1 + dirY(1) = 1 END IF - IF (a$ = CHR$(0) + "H") AND (uyp(1) <> 1) THEN - uxp(1) = 0 + IF (key$ = CHR$(0) + "H") AND (dirY(1) <> 1) THEN + dirX(1) = 0 - uyp(1) = -1 + dirY(1) = -1 END IF - IF (a$ = "d") AND (uxp(2) <> -1) THEN - uxp(2) = 1 + IF (key$ = "d") AND (dirX(2) <> -1) THEN + dirX(2) = 1 - uyp(2) = 0 + dirY(2) = 0 END IF - IF (a$ = "a") AND (uxp(2) <> 1) THEN - uxp(2) = -1 + IF (key$ = "a") AND (dirX(2) <> 1) THEN + dirX(2) = -1 - uyp(2) = 0 + dirY(2) = 0 END IF - IF (a$ = "s") AND (uyp(2) <> -1) THEN - uxp(2) = 0 + IF (key$ = "s") AND (dirY(2) <> -1) THEN + dirX(2) = 0 - uyp(2) = 1 + dirY(2) = 1 END IF - IF (a$ = "w") AND (uyp(2) <> 1) THEN - uxp(2) = 0 + IF (key$ = "w") AND (dirY(2) <> 1) THEN + dirX(2) = 0 - uyp(2) = -1 + dirY(2) = -1 END IF - b = VAL(a$) + playerNum = VAL(key$) - IF b > 0 THEN - IF isAI(b) = 1 THEN - isAI(b) = 0 + IF playerNum > 0 THEN + IF isAI(playerNum) = 1 THEN + isAI(playerNum) = 0 ELSE - isAI(b) = 1 + isAI(playerNum) = 1 END IF - stat + showStats END IF - FOR a = 1 TO playerCount - prc a - NEXT a + FOR player = 1 TO playerCount + advanceWorm player + NEXT player END SUB diff --git a/Games/checkers2.bas b/Games/checkers2.bas index ca58775..898df06 100755 --- a/Games/checkers2.bas +++ b/Games/checkers2.bas @@ -8,494 +8,525 @@ ' 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 " 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 - make move", 14 - msg "n - no. positions processed", 14 + showMessage "h - display help screen", 14 + showMessage "q - to quit", 14 + showMessage "m - 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 ", 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 diff --git a/Math/Plotting/3D graph.bas b/Math/Plotting/3D graph.bas index 9b52fc5..a09856a 100644 --- a/Math/Plotting/3D graph.bas +++ b/Math/Plotting/3D graph.bas @@ -1,11 +1,11 @@ DECLARE SUB formula (x!, y!, z!) -DECLARE SUB graaf () -DECLARE SUB mkgr3 (x1!, y1!, z1!) -DECLARE SUB mkgr2 (x1!, y1!, z1!) -DECLARE SUB mkgr (x1!, y1!, z1!) +DECLARE SUB buildSurface () +DECLARE SUB makeGridXZ (x1!, y1!, z1!) +DECLARE SUB makeGridXY (x1!, y1!, z1!) +DECLARE SUB makeGridZY (x1!, y1!, z1!) DECLARE SUB start () -DECLARE SUB getcor () -DECLARE SUB nait3d () +DECLARE SUB setupScene () +DECLARE SUB mainLoop () ' 3D heightmap explorer. Allows to visualize heightmap for arbitrary function. ' Inspect and edit function "formula" to visualize alternative mathematical functions. @@ -17,6 +17,7 @@ DECLARE SUB nait3d () ' Changelog: ' 2002, Initial version ' 2024.09, Improved program readability +' 2026, Improved program readability ' Keyboard controls: ' Cursor keys - move around @@ -26,42 +27,48 @@ DECLARE SUB nait3d () ' Type your formula to sub module "formula". ' X & Y are surface coordinates. Z must be formula -' result, indicating height. "tm" variable counts +' result, indicating height. "frameCount" variable counts ' frames. Use it in your formula to make graph moving in time. DIM SHARED vertexX(4000), vertexY(4000), vertexZ(4000) DIM SHARED x(4000), y(4000), z(4000) DIM SHARED xo(4000), yo(4000), zo(4000) +' NOTE: in QB45 a scalar and an array may share one name with separate +' storage. xo/yo/zo are used BOTH as scalars (camera-relative coordinates +' in mainLoop) and as arrays xo()/yo() that remember each vertex position +' from the previous frame, so stale lines can be erased before redrawing. DIM SHARED linePoint1(4000), linePoint2(4000) DIM SHARED lineColor(4000) DIM SHARED vertexCount, lineCount -DIM SHARED tmvertexCount, tmlineCount, tm -DIM SHARED myx, myy, myz, mye, myk +DIM SHARED staticVertexCount, staticLineCount, frameCount +DIM SHARED camX, camY, camZ, speedForward, speedSideways -myx = 520 -myy = -250 -myz = -1000 -tm = 0 +camX = 520 +camY = -250 +camZ = -1000 +frameCount = 0 +' On numeric overflow or similar, print a message and keep running (RESUME). ON ERROR GOTO 3 start -nait3d +mainLoop 3 +' Estonian: "Somewhere in the program a number went over the allowed limits!!!" PRINT "Kuskil programmis l�ks mingi arv �le lubatud piiride!!!" RESUME -' This subroutine initializes the coordinate system and sets up the grid. -SUB getcor - c = 12 +SUB setupScene + ' Set up the static scene: background measuring grids and the 3D cross. + drawColor = 12 ' light red ' Create background 2D grids along every axis in 3D space ' to help viewer perceive scale. - mkgr -500, 0, 0 - mkgr2 0, 0, 500 - mkgr3 0, -500, 0 + makeGridZY -500, 0, 0 + makeGridXY 0, 0, 500 + makeGridXZ 0, -500, 0 ' Place center-crossing pink lines across every axis (3D cross). ' This is to help viewer to see where zero point on the graph is. @@ -94,213 +101,218 @@ SUB getcor ' Add lines for the 3D cross. linePoint1(lineCount + 1) = vertexCount + 1 linePoint2(lineCount + 1) = vertexCount + 2 - lineColor(lineCount + 1) = c + lineColor(lineCount + 1) = drawColor linePoint1(lineCount + 2) = vertexCount + 3 linePoint2(lineCount + 2) = vertexCount + 4 - lineColor(lineCount + 2) = c + lineColor(lineCount + 2) = drawColor linePoint1(lineCount + 3) = vertexCount + 5 linePoint2(lineCount + 3) = vertexCount + 6 - lineColor(lineCount + 3) = c + lineColor(lineCount + 3) = drawColor ' Update the vertex and line counts vertexCount = vertexCount + 6 lineCount = lineCount + 3 - tmvertexCount = vertexCount - tmlineCount = lineCount + staticVertexCount = vertexCount + staticLineCount = lineCount END SUB -' This subroutine generates a grid of points based on the formula -SUB graaf - c = 14 +SUB buildSurface + ' Build the heightmap surface: evaluate the formula on a 21x21 point + ' grid and connect neighbors into the yellow mesh. Rebuilt every frame. + drawColor = 14 ' yellow - d = 0 - e = 0 + vertsAdded = 0 + linesAdded = 0 FOR x = -500 TO 500 STEP 50 FOR z = -500 TO 500 STEP 50 ' Increment the vertex count and add a new vertex - d = d + 1 - vertexX(vertexCount + d) = x + vertsAdded = vertsAdded + 1 + vertexX(vertexCount + vertsAdded) = x formula x / 50, z / 50, y ' evaluate formula that we want to visualize - vertexY(vertexCount + d) = y * 50 - vertexZ(vertexCount + d) = z + vertexY(vertexCount + vertsAdded) = y * 50 + vertexZ(vertexCount + vertsAdded) = z ' Connect current point on the grid with neighbors IF z > -500 THEN - e = e + 1 - linePoint1(lineCount + e) = vertexCount + d - linePoint2(lineCount + e) = vertexCount + d - 1 - lineColor(lineCount + e) = c + linesAdded = linesAdded + 1 + linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded + linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 1 + lineColor(lineCount + linesAdded) = drawColor END IF IF x > -500 THEN - e = e + 1 - linePoint1(lineCount + e) = vertexCount + d - linePoint2(lineCount + e) = vertexCount + d - 21 - lineColor(lineCount + e) = c + linesAdded = linesAdded + 1 + linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded + linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 21 + lineColor(lineCount + linesAdded) = drawColor END IF NEXT z NEXT x ' Update the vertex and line counts - vertexCount = vertexCount + d - lineCount = lineCount + e + vertexCount = vertexCount + vertsAdded + lineCount = lineCount + linesAdded END SUB -' This subroutine generates a measuring grid in the ZY plane. -SUB mkgr (x1, y1, z1) - c = 3 +SUB makeGridZY (x1, y1, z1) + ' Generate a measuring grid in the ZY plane (drawn cyan). + drawColor = 3 - d = 0 - e = 0 + vertsAdded = 0 + linesAdded = 0 FOR z = -500 TO 500 STEP 100 FOR y = -500 TO 500 STEP 100 ' Increment the vertex count and add a new vertex - d = d + 1 - vertexX(vertexCount + d) = x1 - vertexY(vertexCount + d) = y1 + y - vertexZ(vertexCount + d) = z1 + z + vertsAdded = vertsAdded + 1 + vertexX(vertexCount + vertsAdded) = x1 + vertexY(vertexCount + vertsAdded) = y1 + y + vertexZ(vertexCount + vertsAdded) = z1 + z ' Add lines to the line array if necessary IF y > -500 THEN - e = e + 1 - linePoint1(lineCount + e) = vertexCount + d - linePoint2(lineCount + e) = vertexCount + d - 1 - lineColor(lineCount + e) = c + linesAdded = linesAdded + 1 + linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded + linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 1 + lineColor(lineCount + linesAdded) = drawColor END IF IF z > -500 THEN - e = e + 1 - linePoint1(lineCount + e) = vertexCount + d - linePoint2(lineCount + e) = vertexCount + d - 11 - lineColor(lineCount + e) = c + linesAdded = linesAdded + 1 + linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded + linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 11 + lineColor(lineCount + linesAdded) = drawColor END IF NEXT y NEXT z ' Update the vertex and line counts - vertexCount = vertexCount + d - lineCount = lineCount + e + vertexCount = vertexCount + vertsAdded + lineCount = lineCount + linesAdded END SUB -' This subroutine generates a measuring grid XY plane. -SUB mkgr2 (x1, y1, z1) - c = 3 +SUB makeGridXY (x1, y1, z1) + ' Generate a measuring grid in the XY plane (drawn cyan). + drawColor = 3 - d = 0 - e = 0 + vertsAdded = 0 + linesAdded = 0 FOR x = -500 TO 500 STEP 100 FOR y = -500 TO 500 STEP 100 ' Increment the vertex count and add a new vertex - d = d + 1 - vertexX(vertexCount + d) = x1 + x - vertexY(vertexCount + d) = y1 + y - vertexZ(vertexCount + d) = z1 + vertsAdded = vertsAdded + 1 + vertexX(vertexCount + vertsAdded) = x1 + x + vertexY(vertexCount + vertsAdded) = y1 + y + vertexZ(vertexCount + vertsAdded) = z1 ' Add lines to the line array if necessary IF y > -500 THEN - e = e + 1 - linePoint1(lineCount + e) = vertexCount + d - linePoint2(lineCount + e) = vertexCount + d - 1 - lineColor(lineCount + e) = c + linesAdded = linesAdded + 1 + linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded + linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 1 + lineColor(lineCount + linesAdded) = drawColor END IF IF x > -500 THEN - e = e + 1 - linePoint1(lineCount + e) = vertexCount + d - linePoint2(lineCount + e) = vertexCount + d - 11 - lineColor(lineCount + e) = c + linesAdded = linesAdded + 1 + linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded + linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 11 + lineColor(lineCount + linesAdded) = drawColor END IF NEXT y NEXT x ' Update the vertex and line counts - vertexCount = vertexCount + d - lineCount = lineCount + e + vertexCount = vertexCount + vertsAdded + lineCount = lineCount + linesAdded END SUB -' This subroutine generates a measuring grid in the XZ plane. -SUB mkgr3 (x1, y1, z1) - c = 3 +SUB makeGridXZ (x1, y1, z1) + ' Generate a measuring grid in the XZ plane (drawn cyan). + drawColor = 3 - d = 0 - e = 0 + vertsAdded = 0 + linesAdded = 0 FOR x = -500 TO 500 STEP 100 FOR z = -500 TO 500 STEP 100 ' Increment the vertex count and add a new vertex - d = d + 1 - vertexX(vertexCount + d) = x1 + x - vertexY(vertexCount + d) = y1 - vertexZ(vertexCount + d) = z + vertsAdded = vertsAdded + 1 + vertexX(vertexCount + vertsAdded) = x1 + x + vertexY(vertexCount + vertsAdded) = y1 + vertexZ(vertexCount + vertsAdded) = z ' Add lines to the line array if necessary IF z > -500 THEN - e = e + 1 - linePoint1(lineCount + e) = vertexCount + d - linePoint2(lineCount + e) = vertexCount + d - 1 - lineColor(lineCount + e) = c + linesAdded = linesAdded + 1 + linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded + linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 1 + lineColor(lineCount + linesAdded) = drawColor END IF IF x > -500 THEN - e = e + 1 - linePoint1(lineCount + e) = vertexCount + d - linePoint2(lineCount + e) = vertexCount + d - 11 - lineColor(lineCount + e) = c + linesAdded = linesAdded + 1 + linePoint1(lineCount + linesAdded) = vertexCount + vertsAdded + linePoint2(lineCount + linesAdded) = vertexCount + vertsAdded - 11 + lineColor(lineCount + linesAdded) = drawColor END IF NEXT z NEXT x ' Update the vertex and line counts - vertexCount = vertexCount + d - lineCount = lineCount + e + vertexCount = vertexCount + vertsAdded + lineCount = lineCount + linesAdded END SUB -' This subroutine renders the 3D scene. -SUB nait3d +SUB mainLoop +' Main loop: rebuild the animated surface, advance the camera, erase and +' redraw all lines, handle keyboard input, repeat. 1 -SOUND 0, .5 -vertexCount = tmvertexCount -lineCount = tmlineCount -tm = tm + 1 -graaf +SOUND 0, .5 ' sub-second delay workaround: 0 Hz tone is inaudible, only waits +vertexCount = staticVertexCount +lineCount = staticLineCount +frameCount = frameCount + 1 +buildSurface -myx = myx + SIN(deg1) * mye -myz = myz + COS(deg1) * mye +' Move the camera: forward and sideways relative to the view direction. +camX = camX + SIN(camAngle1) * speedForward +camZ = camZ + COS(camAngle1) * speedForward -myx = myx + COS(deg1) * myk -myz = myz - SIN(deg1) * myk +camX = camX + COS(camAngle1) * speedSideways +camZ = camZ - SIN(camAngle1) * speedSideways -myy = myy + myyp +' Climb or sink. +camY = camY + speedY -deg1 = deg1 + d1 -Deg2 = Deg2 + d2 +' Spin the view by the current spin speeds. +camAngle1 = camAngle1 + spinSpeed1 +camAngle2 = camAngle2 + spinSpeed2 -C1 = COS(deg1): S1 = SIN(deg1) -C2 = COS(Deg2): S2 = SIN(Deg2) +cosAngle1 = COS(camAngle1): sinAngle1 = SIN(camAngle1) +cosAngle2 = COS(camAngle2): sinAngle2 = SIN(camAngle2) ' Transform the vertices to 3D space FOR a = 1 TO vertexCount - xo = vertexX(a) - myx - yo = -vertexY(a) - myy - zo = vertexZ(a) - myz + xo = vertexX(a) - camX + yo = -vertexY(a) - camY + zo = vertexZ(a) - camZ ' Apply rotation transformations - x1 = (xo * C1 - zo * S1) - z1 = (xo * S1 + zo * C1) + x1 = (xo * cosAngle1 - zo * sinAngle1) + z1 = (xo * sinAngle1 + zo * cosAngle1) - y1 = (yo * C2 - z1 * S2) - z2 = (yo * S2 + z1 * C2) + y1 = (yo * cosAngle2 - z1 * sinAngle2) + z2 = (yo * sinAngle2 + z1 * cosAngle2) ' Project the vertices onto the 2D screen xo(a) = x(a) @@ -316,64 +328,66 @@ NEXT ' Draw the lines on the screen FOR a = 1 TO lineCount - p1 = linePoint1(a) - p2 = linePoint2(a) + endPoint1 = linePoint1(a) + endPoint2 = linePoint2(a) ' Skip drawing if either point is off-screen - IF xo(p1) = -1 OR xo(p2) = -1 THEN + IF xo(endPoint1) = -1 OR xo(endPoint2) = -1 THEN ' Do nothing ELSE ' erase line at previous position - LINE (xo(p1), yo(p1))-(xo(p2), yo(p2)), 0 + LINE (xo(endPoint1), yo(endPoint1))-(xo(endPoint2), yo(endPoint2)), 0 ' draw line at new position - LINE (x(p1), y(p1))-(x(p2), y(p2)), lineColor(a) + LINE (x(endPoint1), y(endPoint1))-(x(endPoint2), y(endPoint2)), lineColor(a) END IF NEXT -' Handle keyboard input -K$ = INKEY$ -IF K$ <> "" THEN +' Handle keyboard input: cursor keys = forward/sideways speed, +/- = vertical +' speed, 4/6/8/2 = spin speeds, space = halve all motion, q/ESC = quit. +keyPress$ = INKEY$ +IF keyPress$ <> "" THEN - SELECT CASE K$ + SELECT CASE keyPress$ CASE CHR$(0) + "P" - mye = mye - 3 + speedForward = speedForward - 3 CASE CHR$(0) + "H" - mye = mye + 3 + speedForward = speedForward + 3 CASE CHR$(0) + "M" - myk = myk + 3 + speedSideways = speedSideways + 3 CASE CHR$(0) + "K" - myk = myk - 3 + speedSideways = speedSideways - 3 CASE "+" - myyp = myyp + 5 + speedY = speedY + 5 CASE "-" - myyp = myyp - 5 + speedY = speedY - 5 CASE "6" - d1 = d1 + .01 + spinSpeed1 = spinSpeed1 + .01 CASE "4" - d1 = d1 - .01 + spinSpeed1 = spinSpeed1 - .01 CASE "8" - d2 = d2 - .01 + spinSpeed2 = spinSpeed2 - .01 CASE "2" - d2 = d2 + .01 + spinSpeed2 = spinSpeed2 + .01 CASE " " - d1 = d1 / 2 - d2 = d2 / 2 - d3 = d3 / 2 - mye = mye / 2 - myk = myk / 2 - myyp = myyp / 2 + ' halve everything (spinSpeed3 is a leftover, not used anywhere else) + spinSpeed1 = spinSpeed1 / 2 + spinSpeed2 = spinSpeed2 / 2 + spinSpeed3 = spinSpeed3 / 2 + speedForward = speedForward / 2 + speedSideways = speedSideways / 2 + speedY = speedY / 2 CASE "q" SYSTEM @@ -387,8 +401,8 @@ END IF GOTO 1 END SUB -' This subroutine initializes the graphics and sets up the program. SUB start +' Set up graphics mode and build the static scene geometry. SCREEN 12 CLS @@ -399,28 +413,28 @@ NEXT a vertexCount = 0 lineCount = 0 -getcor +setupScene END SUB -' This subroutine calculates the height of a point based on the formula SUB formula (x, y, z) +' User-editable formula: return the surface height z for grid coordinate (x, y). z = 0 v = SQR(x * x + y * y) ' v = distance from center, some formulas need it. ' Apply the formula to calculate the height -z = z + SIN(x + y) * SIN(tm / 10) ' diagonal lines +z = z + SIN(x + y) * SIN(frameCount / 10) ' diagonal lines z = z + (SQR((15 + v) * (15 - v)) - 10) ' top of the ball ' As you see, multiple formulas can be enabled simultaneously. ' Few more example formulas that you can uncomment and enable. ' z = z + RND * 1 ' noise -' z = z + SIN((y + tm) / 2) ' forward moving wave +' z = z + SIN((y + frameCount) / 2) ' forward moving wave ' z = z + SIN(v / 2) * 2 ' circular waves ' z = z - SQR(v * 6) ' sharp peak ' z = z + SIN(y / 1.5) / 1.5 + COS(x / 1.5) / 1.5' custom 1 ' z = z + SIN(y / 1.5) * COS(x / 1.5) / 1.5 ' custom 2 -' z = z + INT(SIN(1.5 * x * SIN(tm / 10))) * 3 ' custom 3 +' z = z + INT(SIN(1.5 * x * SIN(frameCount / 10))) * 3 ' custom 3 ' z = z - INT(v / 5) * 3 + 3 ' custom 4 ' 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 diff --git a/Miscellaneous/Automated school clock/v1/ekr.bas b/Miscellaneous/Automated school clock/v1/ekr.bas index 67ac754..30ce279 100755 --- a/Miscellaneous/Automated school clock/v1/ekr.bas +++ b/Miscellaneous/Automated school clock/v1/ekr.bas @@ -1,69 +1,71 @@ -DECLARE SUB jooks () -DECLARE SUB suva () -DECLARE SUB display () -DECLARE SUB clearBits () +' Test/demo program for the LPT attached 2 digit LED display. +' Drives the same display hardware as the school clock (kk.bas). +DECLARE SUB chaseDemo () +DECLARE SUB randomDemo () +DECLARE SUB refreshDisplay () +DECLARE SUB ledsOff () DEFINT A-Z -DIM SHARED bit(0 TO 16) +DIM SHARED ledBits(0 TO 16) -suva -jooks +randomDemo +chaseDemo -clearBits -bit(10) = 0 -bit(14) = 0 -bit(6) = 0 -bit(2) = 0 +ledsOff +ledBits(10) = 0 +ledBits(14) = 0 +ledBits(6) = 0 +ledBits(2) = 0 4 GOTO 4 -SUB clearBits -' This subroutine initializes all bits in the bit array to 1 +SUB ledsOff +' Turns all LEDs off: every position set to 1 (active low) FOR a = 1 TO 16 - bit(a) = 1 + ledBits(a) = 1 NEXT a END SUB -SUB display -' This subroutine displays the current state of the bit array using LPT attached display -prt = &H378 -d = 0 -FOR a = 0 TO 3 - c = 2 ^ a +SUB refreshDisplay +' Writes the 16 positions to the LPT data port, 4 per scan group +lptData = &H378 ' LPT data port address +bitIndex = 0 +FOR scanGroup = 0 TO 3 + scanByte = 2 ^ scanGroup FOR b = 4 TO 7 - d = d + 1 - c = c + (bit(d) * 2 ^ b) + bitIndex = bitIndex + 1 + scanByte = scanByte + (ledBits(bitIndex) * 2 ^ b) NEXT b - OUT prt, c -NEXT a + OUT lptData, scanByte +NEXT scanGroup END SUB -SUB jooks -' This subroutine demonstrates a simple counting +SUB chaseDemo +' Running light demo: one lit position chases through all 16 2 -clearBits -FOR a = 1 TO 16 - bit(16) = 1 ' Set the most significant bit to 1 - bit(a - 1) = 1 ' Set the previous bit to 1 - bit(a) = 0 ' Clear the current bit - PRINT a +ledsOff +FOR ledPos = 1 TO 16 + ledBits(16) = 1 ' Previous top position back to off + ledBits(ledPos - 1) = 1 ' Previous position back to off + ledBits(ledPos) = 0 ' Light the current position (0 = on) + PRINT ledPos FOR b = 1 TO 1000 - display + refreshDisplay NEXT b -NEXT a +NEXT ledPos GOTO 2 END SUB -SUB suva -' This subroutine demonstrates a simple random bit setting algorithm +SUB randomDemo +' Random pattern demo: each position randomly on or off 3 -clearBits +ledsOff FOR b = 1 TO 16 - IF RND * 100 > 50 THEN bit(b) = 0 ' Randomly set bits to 0 + IF RND * 100 > 50 THEN ledBits(b) = 0 ' Randomly set bits to 0 NEXT b FOR b = 1 TO 100 - display + refreshDisplay NEXT b GOTO 3 END SUB diff --git a/Miscellaneous/Automated school clock/v1/kk.bas b/Miscellaneous/Automated school clock/v1/kk.bas index 14883f8..73c4f33 100755 --- a/Miscellaneous/Automated school clock/v1/kk.bas +++ b/Miscellaneous/Automated school clock/v1/kk.bas @@ -3,337 +3,350 @@ ' 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 @@ -344,47 +357,51 @@ GOTO 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 @@ -395,305 +412,327 @@ NEXT c 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 (.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 "" 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 "" 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 "" 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 diff --git a/Miscellaneous/Automated school clock/v2/kkmini.bas b/Miscellaneous/Automated school clock/v2/kkmini.bas index 4564dc8..3730ae5 100755 --- a/Miscellaneous/Automated school clock/v2/kkmini.bas +++ b/Miscellaneous/Automated school clock/v2/kkmini.bas @@ -1,124 +1,131 @@ -DECLARE SUB dispt () +DECLARE SUB showskipmsg () ' Svjatoslav Agejenko ' E-mail: svjatoslav@svjatoslav.eu ' Homepage: www.hot.ee/n0/ - -DECLARE SUB dispp () -DECLARE SUB displukk () -DECLARE SUB kola (a%) -DECLARE SUB rese () -DECLARE SUB start () -DECLARE SUB getnad (g%, n%, d%, k%) -DECLARE SUB initp (b$) -DECLARE SUB getmd (a$, m%, d%) -DECLARE SUB son (a$) -DECLARE SUB inita () -DECLARE SUB chm () -DECLARE SUB chd () -DECLARE SUB kell (a%) -DECLARE SUB sync2 () -DECLARE SUB sync () -DECLARE SUB mnmain () -DECLARE SUB heli (a%) -DECLARE SUB disp () +' +' School bell scheduler (mini version): rings a bell relay connected to the +' parallel port, driven by timetable files (aasta.ap = year plan selecting +' which .pp day-plan file to use; a day plan lists the bell times). + +DECLARE SUB showdayinfo () +DECLARE SUB showlockmsg () +DECLARE SUB ringbell (seconds%) +DECLARE SUB resetprogram () +DECLARE SUB initprogram () +DECLARE SUB getweekday (yr%, mon%, dy%, wdout%) +DECLARE SUB loadplan (planbase$) +DECLARE SUB parsedate (datestr$, monthnum%, daynum%) +DECLARE SUB splitwords (txt$) +DECLARE SUB loadyearplan () +DECLARE SUB checkminute () +DECLARE SUB checkdate () +DECLARE SUB ringevent (ringtype%) +DECLARE SUB roundtohour () +DECLARE SUB loadsyncfile () +DECLARE SUB mainloop () +DECLARE SUB playsound (sndnum%) +DECLARE SUB drawscreen () DEFINT A-Z -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 lk$ -DIM SHARED ssave -DIM SHARED ssavel -DIM SHARED timero AS LONG -DIM SHARED kblukk -DIM SHARED tunnidara - -start - - -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 -FOR a = 1 TO apl -son ap$(a) -SELECT CASE sona$(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) -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) -CASE "e" -getmd sona$(2), m1, d1 -getmd DATE$, m2, d2 -IF (m1 = m2) AND (d1 = d2) THEN b$ = sona$(3) +DIM SHARED yearplan$(1 TO 500) +DIM SHARED yearplancount +DIM SHARED dayplan$(1 TO 500) +DIM SHARED dayplancount +DIM SHARED lptport, prt2 +DIM SHARED lasttime$ +DIM SHARED lastdate$ +DIM SHARED words$(1 TO 50) +DIM SHARED wordcount +DIM SHARED loadedplan$ +DIM SHARED weekdaynum +DIM SHARED dayname$(1 TO 7) +DIM SHARED lastbell$ +DIM SHARED idlecount +DIM SHARED idlelimit +DIM SHARED timersnap AS LONG +DIM SHARED keylock +DIM SHARED dayoff + +initprogram + + +drawscreen +mainloop + +SUB checkdate + ' Selects today's day-plan file from the year plan (runs when the date changes). +selplan$ = "tuhi" ' default plan name when no rule matches (tuhi = empty) +IF yearplancount = 0 THEN loadyearplan + +tmp$ = DATE$ +yr = VAL(RIGHT$(tmp$, 4)) +mon = VAL(LEFT$(tmp$, 2)) +tmp$ = LEFT$(tmp$, 5) +dy = VAL(RIGHT$(tmp$, 2)) +getweekday yr, mon, dy, weekdaynum +FOR i = 1 TO yearplancount +splitwords yearplan$(i) +SELECT CASE words$(1) +CASE "v" ' v = plan active within a date range +parsedate words$(2), beginmon, beginday +parsedate words$(3), endmon, endday +parsedate DATE$, curmon, curday +IF curmon < beginmon THEN GOTO 9 +IF curmon > endmon THEN GOTO 9 +IF curmon = beginmon THEN IF curday < beginday THEN GOTO 9 +IF curmon = endmon THEN IF curday > endday THEN GOTO 9 +selplan$ = words$(4) +CASE "n" ' n = plan active on one weekday in a range +parsedate words$(2), beginmon, beginday +parsedate words$(3), endmon, endday +parsedate DATE$, curmon, curday +IF curmon < beginmon THEN GOTO 9 +IF curmon > endmon THEN GOTO 9 +IF curmon = beginmon THEN IF curday < beginday THEN GOTO 9 +IF curmon = endmon THEN IF curday > endday THEN GOTO 9 +IF weekdaynum <> VAL(words$(4)) THEN GOTO 9 +selplan$ = words$(5) +CASE "e" ' e = plan active on one exact date +parsedate words$(2), beginmon, beginday +parsedate DATE$, endmon, endday +IF (beginmon = endmon) AND (beginday = endday) THEN selplan$ = words$(3) END SELECT 9 -NEXT a +NEXT i -IF b$ <> lp$ THEN initp b$ -lp$ = b$ -tunnidara = 0 -dispp -disp +IF selplan$ <> loadedplan$ THEN loadplan selplan$ +loadedplan$ = selplan$ +dayoff = 0 +showdayinfo +drawscreen END SUB -SUB chm -a$ = DATE$ -IF a$ <> dato$ THEN chd -dato$ = a$ -b = 0 -FOR a = 1 TO ppl -son pp$(a) -SELECT CASE sona$(1) -CASE "#" -getmd sona$(2), h1, m1 -getmd TIME$, h2, m2 +SUB checkminute + ' Minute tick: scans the day plan for bell events matching the current time. +tmp$ = DATE$ +IF tmp$ <> lastdate$ THEN checkdate +lastdate$ = tmp$ +ringtype = 0 +FOR i = 1 TO dayplancount +splitwords dayplan$(i) +SELECT CASE words$(1) +CASE "#" ' timetable entry: # HH:MM sis|val (sis = lesson start, val = lesson end) +parsedate words$(2), bellhour, bellmin +parsedate TIME$, nowhour, nowmin ' 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 +IF (nowhour = bellhour) AND (nowmin = bellmin) THEN +IF words$(3) = "sis" THEN ringtype = 1 +IF words$(3) = "val" THEN ringtype = 2 END IF END SELECT -NEXT a +NEXT i -IF (tunnidara = 0) AND (b > 0) THEN kell b -ssave = ssave + 1 +IF (dayoff = 0) AND (ringtype > 0) THEN ringevent ringtype ' ring only when lessons are not skipped today +idlecount = idlecount + 1 END SUB -SUB disp +SUB drawscreen + ' Draws the main screen: title, key help, day-plan list and status fields. CLS PRINT "Kooli Kell (mini) v 1.1 2003.3" PRINT "Programmi autor Svjatoslav Agejenko E-mail: n0@hot.ee" @@ -131,7 +138,7 @@ PRINT "4 - 1 tund tagasi 5 - 1 tund edasi" PRINT "r - programmi restart q - programmist v�lja" PRINT " j - j�tab k�ik tunnid t�na �ra" -dispp +showdayinfo LOCATE 12, 15 PRINT "Kuu-P�ev-Aasta (USA standard)" @@ -139,20 +146,21 @@ PRINT "Kuu-P�ev-Aasta (USA standard)" LOCATE 17 -FOR a = 1 TO ppl -IF pp$(a) <> SPACE$(LEN(pp$(a))) THEN - PRINT pp$(a); - PRINT SPACE$(15 - LEN(pp$(a))); +FOR i = 1 TO dayplancount +IF dayplan$(i) <> SPACE$(LEN(dayplan$(i))) THEN + PRINT dayplan$(i); + PRINT SPACE$(15 - LEN(dayplan$(i))); END IF -NEXT a +NEXT i -displukk -dispt +showlockmsg +showskipmsg END SUB -SUB displukk +SUB showlockmsg + ' Shows or clears the "keyboard locked" warning in the top row. LOCATE 1, 40 -IF kblukk = 1 THEN +IF keylock = 1 THEN COLOR 0, 7 PRINT "Klaviatuur lukus! Vajuta CTRL+L" COLOR 7, 0 @@ -161,19 +169,21 @@ ELSE END IF END SUB -SUB dispp -IF ndlp = 0 THEN GOTO 14 +SUB showdayinfo + ' Shows the current weekday name and the active day-plan name. +IF weekdaynum = 0 THEN GOTO 14 LOCATE 14, 1 -PRINT "n�dalap�ev:", pn$(ndlp) +PRINT "n�dalap�ev:", dayname$(weekdaynum) LOCATE 15, 1 -PRINT "p�evaplaan:", lp$ +PRINT "p�evaplaan:", loadedplan$ 14 END SUB -SUB dispt +SUB showskipmsg + ' Shows or clears the "all lessons skipped today" notice. LOCATE 16, 20 COLOR 12 + 15, 0 -IF tunnidara = 1 THEN +IF dayoff = 1 THEN PRINT "T�na on k�ik tunnid �ra j�etud" ELSE PRINT " " @@ -181,59 +191,62 @@ END IF COLOR 7, 0 END SUB -SUB getmd (a$, m, d) -b$ = LEFT$(a$, 5) -m = VAL(LEFT$(b$, 2)) -d = VAL(RIGHT$(b$, 2)) +SUB parsedate (datestr$, monthnum, daynum) + ' Parses month and day numbers out of an MM-DD-YYYY style date string. +tmp$ = LEFT$(datestr$, 5) +monthnum = VAL(LEFT$(tmp$, 2)) +daynum = VAL(RIGHT$(tmp$, 2)) END SUB -SUB getnad (g, n, d, k) +SUB getweekday (yr, mon, dy, wdout) + ' Zeller's congruence: computes the weekday (1=Monday..7=Sunday) of 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 +adjyear = yr +adjmon = mon - 2 +IF mon > 2 GOTO 120 +adjyear = adjyear - 1: adjmon = adjmon + 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(adjyear / 100) +shortyear = adjyear - century * 100 +zeller = dy + INT((13 * adjmon - 1) / 5) + shortyear + INT(shortyear / 4) + INT(century / 4) - 2 * century +wdout = zeller - 7 * INT(zeller / 7) +IF wdout = 0 THEN wdout = 7 END SUB -SUB heli (a) +SUB playsound (sndnum) + ' Plays one of four sound effects (sndnum = effect number). 'GOTO 10 -SELECT CASE a +SELECT CASE sndnum CASE 1 -FOR c = 1 TO 5 +FOR i = 1 TO 5 SOUND 3000, 1 -SOUND 0, 1 -NEXT c +SOUND 0, 1 ' SOUND 0, n = sub-second delay workaround (inaudible 0 Hz tone) +NEXT i CASE 2 -FOR c = 1 TO 5 +FOR i = 1 TO 5 SOUND 2500, 1 -SOUND 0, 2 -NEXT c +SOUND 0, 2 ' SOUND 0, n = sub-second delay workaround (inaudible 0 Hz tone) +NEXT i SOUND 2500, 10 CASE 3 -FOR a = 1 TO 10 +FOR i = 1 TO 10 SOUND 500, .5 SOUND 1500, .5 SOUND 2000, .5 SOUND 1520, .5 -NEXT a +NEXT i CASE 4 -FOR a = 800 TO 1000 STEP 10 -SOUND a, .1 -SOUND a * 3, .1 -SOUND 0, 1 -NEXT a +FOR freq = 800 TO 1000 STEP 10 +SOUND freq, .1 +SOUND freq * 3, .1 +SOUND 0, 1 ' SOUND 0, n = sub-second delay workaround (inaudible 0 Hz tone) +NEXT freq 10 END SELECT @@ -241,164 +254,169 @@ END SELECT END SUB -SUB inita -apl = 0 +SUB loadyearplan + ' Loads the year-plan file aasta.ap into the yearplan$ array. +yearplancount = 0 OPEN "aasta.ap" FOR INPUT AS #1 5 IF EOF(1) <> 0 THEN GOTO 3 -LINE INPUT #1, a$ -apl = apl + 1 -ap$(apl) = a$ +LINE INPUT #1, tmp$ +yearplancount = yearplancount + 1 +yearplan$(yearplancount) = tmp$ GOTO 5 3 CLOSE #1 END SUB -SUB initp (b$) -ppl = 0 -OPEN b$ + ".pp" FOR INPUT AS #1 +SUB loadplan (planbase$) + ' Loads the day-plan file .pp into the dayplan$ array. +dayplancount = 0 +OPEN planbase$ + ".pp" FOR INPUT AS #1 6 IF EOF(1) <> 0 THEN GOTO 7 -LINE INPUT #1, a$ -ppl = ppl + 1 -pp$(ppl) = a$ +LINE INPUT #1, tmp$ +dayplancount = dayplancount + 1 +dayplan$(dayplancount) = tmp$ GOTO 6 7 CLOSE #1 END SUB -SUB kell (a) -b$ = TIME$ + DATE$ -IF b$ <> lk$ THEN lk$ = b$ ELSE GOTO 2 +SUB ringevent (ringtype) + ' Rings the bell for an event (1 = lesson start, 2 = lesson end), max once per second. +tmp$ = TIME$ + DATE$ +IF tmp$ <> lastbell$ THEN lastbell$ = tmp$ ELSE GOTO 2 ' skip if the bell already rang during this second -heli 3 +playsound 3 -SELECT CASE a +SELECT CASE ringtype CASE 1 -kola 4 -FOR b = 1 TO 15 -SOUND 0, 1 -NEXT b -kola 1 +ringbell 4 +FOR i = 1 TO 15 +SOUND 0, 1 ' SOUND 0, n = sub-second delay workaround (inaudible 0 Hz tone) +NEXT i +ringbell 1 CASE 2 -kola 5 +ringbell 5 END SELECT 2 END SUB -SUB kola (a) -timero = TIMER +SUB ringbell (seconds) + ' Rings the physical bell: toggles the LPT port lines for the given seconds. +timersnap = TIMER 11 -FOR b = 1 TO 100 -OUT prt, 0 -OUT prt, 255 -NEXT b -IF ABS(timero - TIMER) < a THEN GOTO 11 +FOR i = 1 TO 100 +OUT lptport, 0 ' toggle all LPT data lines (drives the bell relay) +OUT lptport, 255 +NEXT i +IF ABS(timersnap - TIMER) < seconds THEN GOTO 11 END SUB -SUB mnmain +SUB mainloop + ' Main loop: checks the clock, handles keys, runs the idle screensaver. 1 -b$ = LEFT$(TIME$, 5) -IF b$ <> timo$ THEN chm -timo$ = b$ +tmp$ = LEFT$(TIME$, 5) +IF tmp$ <> lasttime$ THEN checkminute +lasttime$ = tmp$ -a$ = INKEY$ +key$ = INKEY$ -IF a$ <> "" THEN -IF ssave > ssavel THEN disp -ssave = 0 +IF key$ <> "" THEN + IF idlecount > idlelimit THEN drawscreen ' first keypress after idle: redraw the main screen + idlecount = 0 END IF -IF a$ = CHR$(12) THEN - IF kblukk = 1 THEN kblukk = 0 ELSE kblukk = 1 - displukk +IF key$ = CHR$(12) THEN ' CTRL+L toggles the keyboard lock + IF keylock = 1 THEN keylock = 0 ELSE keylock = 1 + showlockmsg END IF -IF kblukk = 1 THEN a$ = "" +IF keylock = 1 THEN key$ = "" -IF a$ = "s" THEN kell 1 -IF a$ = "v" THEN kell 2 +IF key$ = "s" THEN ringevent 1 +IF key$ = "v" THEN ringevent 2 -IF a$ = "a" THEN -CLS -PRINT " vana aeg: " + TIME$ -INPUT "sisesta uus aeg (TT:MM:SS): ", b$ -IF LEN(b$) <> 8 THEN GOTO 12 -TIME$ = b$ -timo$ = "" -12 -disp +IF key$ = "a" THEN + CLS + PRINT " vana aeg: " + TIME$ + INPUT "sisesta uus aeg (TT:MM:SS): ", tmp$ + IF LEN(tmp$) <> 8 THEN GOTO 12 + TIME$ = tmp$ + lasttime$ = "" + 12 + drawscreen END IF -IF a$ = "d" THEN -CLS -PRINT " vana daatum: " + DATE$ -INPUT "sisesta uus daatum (KK-PP-AAAA): ", b$ -IF LEN(b$) <> 10 THEN GOTO 13 -DATE$ = b$ -timo$ = "" -13 -disp +IF key$ = "d" THEN + CLS + PRINT " vana daatum: " + DATE$ + INPUT "sisesta uus daatum (KK-PP-AAAA): ", tmp$ + IF LEN(tmp$) <> 10 THEN GOTO 13 + DATE$ = tmp$ + lasttime$ = "" + 13 + drawscreen END IF -IF a$ = "7" OR a$ = "8" THEN - b = VAL(RIGHT$(LEFT$(TIME$, 5), 2)) - IF a$ = "7" THEN b = b - 1 - IF a$ = "8" THEN 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) - TIME$ = e$ +IF key$ = "7" OR key$ = "8" THEN + num = VAL(RIGHT$(LEFT$(TIME$, 5), 2)) + IF key$ = "7" THEN num = num - 1 + IF key$ = "8" THEN num = num + 1 + IF num < 0 THEN num = 0 + IF num > 59 THEN num = 59 + numstr$ = STR$(num) + IF LEFT$(numstr$, 1) = " " THEN numstr$ = RIGHT$(numstr$, LEN(numstr$) - 1) + IF LEN(numstr$) < 2 THEN numstr$ = "0" + numstr$ + newtime$ = LEFT$(TIME$, 3) + numstr$ + RIGHT$(TIME$, 3) + TIME$ = newtime$ END IF -IF a$ = "4" OR a$ = "5" THEN - b = VAL(LEFT$(TIME$, 2)) - IF a$ = "4" THEN b = b - 1 - IF a$ = "5" THEN 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) - TIME$ = e$ +IF key$ = "4" OR key$ = "5" THEN + num = VAL(LEFT$(TIME$, 2)) + IF key$ = "4" THEN num = num - 1 + IF key$ = "5" THEN num = num + 1 + IF num < 0 THEN num = 0 + IF num > 23 THEN num = 23 + numstr$ = STR$(num) + IF LEFT$(numstr$, 1) = " " THEN numstr$ = RIGHT$(numstr$, LEN(numstr$) - 1) + IF LEN(numstr$) < 2 THEN numstr$ = "0" + numstr$ + newtime$ = numstr$ + RIGHT$(TIME$, 6) + TIME$ = newtime$ END IF -IF a$ = "u" THEN sync2 -IF a$ = "l" THEN sync +IF key$ = "u" THEN roundtohour +IF key$ = "l" THEN loadsyncfile -IF a$ = "r" THEN rese -IF a$ = "q" THEN SYSTEM +IF key$ = "r" THEN resetprogram +IF key$ = "q" THEN SYSTEM -IF a$ = "j" THEN -IF tunnidara = 0 THEN tunnidara = 1 ELSE tunnidara = 0 -dispt +IF key$ = "j" THEN + IF dayoff = 0 THEN dayoff = 1 ELSE dayoff = 0 ' j = skip all lessons today (toggle) + showskipmsg END IF -IF ssave <= ssavel THEN +IF idlecount <= idlelimit THEN LOCATE 11, 1 PRINT TIME$ LOCATE 12, 1 PRINT DATE$ ELSE - IF ABS(TIMER - timero) > 10 THEN - CLS - kblukk = 1 - FOR b = 1 TO 20 - LOCATE RND * 22 + 1, RND * 79 + 1 - IF RND * 100 < 50 THEN PRINT "*" ELSE PRINT "." - NEXT b - LOCATE RND * 22 + 1, RND * 50 + 1 - COLOR 0, 7 - PRINT "< " + LEFT$(TIME$, 2); - COLOR 16, 7 - PRINT ":"; - COLOR 0, 7 - PRINT RIGHT$(LEFT$(TIME$, 5), 2) + " >" - COLOR 7, 0 - timero = TIMER + IF ABS(TIMER - timersnap) > 10 THEN ' idle too long: starfield screensaver with clock + CLS + keylock = 1 + FOR i = 1 TO 20 + LOCATE RND * 22 + 1, RND * 79 + 1 + IF RND * 100 < 50 THEN PRINT "*" ELSE PRINT "." + NEXT i + LOCATE RND * 22 + 1, RND * 50 + 1 + COLOR 0, 7 + PRINT "< " + LEFT$(TIME$, 2); + COLOR 16, 7 + PRINT ":"; + COLOR 0, 7 + PRINT RIGHT$(LEFT$(TIME$, 5), 2) + " >" + COLOR 7, 0 + timersnap = TIMER END IF END IF GOTO 1 @@ -406,80 +424,85 @@ GOTO 1 END SUB -SUB rese -heli 4 -timo$ = "" -dato$ = "" -apl = 0 +SUB resetprogram + ' Resets cached date/time and the year plan so everything reloads. +playsound 4 +lasttime$ = "" +lastdate$ = "" +yearplancount = 0 END SUB -SUB son (a$) +SUB splitwords (txt$) + ' Splits a string at spaces/tabs into the words$ array (wordcount words). -FOR b = 1 TO 50 -sona$(b) = "" -NEXT b -mitus = 0 +FOR inword = 1 TO 50 +words$(inword) = "" +NEXT inword +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 +inword = 1 +FOR i = 1 TO LEN(txt$) +ch$ = RIGHT$(LEFT$(txt$, i), 1) +IF ch$ = " " OR ch$ = CHR$(9) THEN +inword = 1 ELSE -IF b = 1 THEN b = 0: mitus = mitus + 1 -sona$(mitus) = sona$(mitus) + d$ +IF inword = 1 THEN inword = 0: wordcount = wordcount + 1 +words$(wordcount) = words$(wordcount) + ch$ END IF -NEXT c +NEXT i END SUB -SUB start -pn$(1) = "esmasp�ev" -pn$(2) = "teisip�ev" -pn$(3) = "kolmap�ev" -pn$(4) = "neljap�ev" -pn$(5) = "reede" -pn$(6) = "laup�ev" -pn$(7) = "p�hap�ev" - -prt = &H378 - -ssavel = 2 -kblukk = 1 -tunnidara = 0 +SUB initprogram + ' Program init: weekday names, LPT port address, default flags. +dayname$(1) = "esmasp�ev" +dayname$(2) = "teisip�ev" +dayname$(3) = "kolmap�ev" +dayname$(4) = "neljap�ev" +dayname$(5) = "reede" +dayname$(6) = "laup�ev" +dayname$(7) = "p�hap�ev" + +lptport = &H378 ' LPT1 parallel port base address + +idlelimit = 2 ' screensaver starts after 2 minutes without keypresses +keylock = 1 ' keyboard starts locked (unlock with CTRL+L) +dayoff = 0 END SUB -SUB sync +SUB loadsyncfile + ' Reads date and time from sync.txt and sets 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, tmp$ +DATE$ = tmp$ +LINE INPUT #1, tmp$ +TIME$ = tmp$ CLOSE #1 -heli 2 +playsound 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 current time up to the nearest full hour. +timestr$ = TIME$ +timestr$ = LEFT$(timestr$, 5) +mins = VAL(RIGHT$(timestr$, 2)) +hrs = VAL(LEFT$(timestr$, 2)) +IF mins >= 30 THEN hrs = hrs + 1 ' past half hour: round up to the next hour +mins = 0 +IF hrs > 23 THEN hrs = hrs - 24 +timestr$ = RIGHT$(STR$(hrs), LEN(STR$(hrs)) - 1) +minstr$ = RIGHT$(STR$(mins), LEN(STR$(mins)) - 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$ -TIME$ = a$ +TIME$ = timestr$ -heli 1 +playsound 1 END SUB -- 2.20.1