diff --git a/samples.md b/samples.md index 52dbbd8e..4252c5f3 100644 --- a/samples.md +++ b/samples.md @@ -2,62 +2,83 @@ ## SAMPLES -- **[Julia Rings](samples/3d-cube/index.md)** • [Relsoft](samples/relsoft.md) [3d](samples/3d.md), [cube](samples/cube.md) +- **[3D Cube](samples/3d-cube/index.md)** • [Relsoft](samples/relsoft.md) [3d](samples/3d.md), [cube](samples/cube.md) - **[Abacus](samples/abacus/index.md)** • [Bob Seguin](samples/bob-seguin.md) [abacus](samples/abacus.md), [arithmetic](samples/arithmetic.md) - **[Amongst](samples/amongst/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [multiplayer](samples/multiplayer.md) - **[Animax](samples/animax/index.md)** • [Bob Seguin](samples/bob-seguin.md) [art](samples/art.md), [drawing](samples/drawing.md) -- **[ArcDemo](samples/arc-demo/index.md)** • [Tsiplacov Sergey](samples/tsiplacov-sergey.md) [game](samples/game.md), [platformer](samples/platformer.md) +- **[Arc Demo](samples/arc-demo/index.md)** • [Tsiplacov Sergey](samples/tsiplacov-sergey.md) [game](samples/game.md), [platformer](samples/platformer.md) - **[Assault](samples/assault/index.md)** • [Glenn Powell](samples/glenn-powell.md) [game](samples/game.md) - **[Bezier](samples/bezier/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) -- **[Binary Clock](samples/binary-clock/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Binary Clock](samples/binary-clock/index.md)** • [RhoSigma](samples/rhosigma.md) [screenblanker](samples/screenblanker.md) - **[Blockout](samples/blockout/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [breakout](samples/breakout.md) -- **[Can't Contain Me](samples/cant-contain-me/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md) +- **[Cant Contain Me](samples/cant-contain-me/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md) - **[Castle](samples/castle/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [2 player](samples/2-player.md) -- **[Chaotic Scattering - Gaspard-Rice system](samples/chaotic-scattering/index.md)** • [vince](samples/vince.md) [ray tracing](samples/ray-tracing.md), [reflections](samples/reflections.md) +- **[Chaotic Scattering](samples/chaotic-scattering/index.md)** • [vince](samples/vince.md) [ray tracing](samples/ray-tracing.md), [reflections](samples/reflections.md) - **[Circle Intersecting Circle](samples/circle-intersecting-circle/index.md)** • [bplus](samples/bplus.md) • [STxAxTIC](samples/stxaxtic.md) [geometry](samples/geometry.md), [intersections](samples/intersections.md) - **[Circle Intersecting Line](samples/circle-intersecting-line/index.md)** • [bplus](samples/bplus.md) [geometry](samples/geometry.md), [intersections](samples/intersections.md) - **[Colliding Ball Simulation](samples/colliding-ball-simulation/index.md)** • [Timothy Baxendale](samples/timothy-baxendale.md) [physics](samples/physics.md), [collisions](samples/collisions.md) - **[Connect Circles](samples/connect-circles/index.md)** • [bplus](samples/bplus.md) [screensaver](samples/screensaver.md), [mosaic](samples/mosaic.md) - **[Convert BMP to Dominoes](samples/convert-bmp-to-dominoes/index.md)** • [Richard Frost](samples/richard-frost.md) [image processing](samples/image-processing.md) - **[Darokin](samples/darokin/index.md)** • [darokin](samples/darokin.md) [screensaver](samples/screensaver.md), [starfield](samples/starfield.md) -- **[Dragon Warrior 64](samples/dragon-warrior/index.md)** • [Cobalt](samples/cobalt.md) [game](samples/game.md), [rpg](samples/rpg.md) +- **[Dragon Warrior](samples/dragon-warrior/index.md)** • [Cobalt](samples/cobalt.md) [game](samples/game.md), [rpg](samples/rpg.md) - **[Dropping Balls](samples/dropping-balls/index.md)** • [bplus](samples/bplus.md) [gravity](samples/gravity.md), [collisions](samples/collisions.md) - **[Ellipse Intersecting Line](samples/ellipse-intersecting-line/index.md)** • [STxAxTIC](samples/stxaxtic.md) [geometry](samples/geometry.md), [intersections](samples/intersections.md) - **[Fibonacci Variations](samples/fibonacci-variations/index.md)** • [STxAxTIC](samples/stxaxtic.md) [fibonacci](samples/fibonacci.md) - **[Filled Circles and Ellipses](samples/filled-circles-and-ellipses/index.md)** • [QB64 Team 2018](samples/qb64-team-2018.md) [filled circle](samples/filled-circle.md), [ellipse](samples/ellipse.md) - **[Fire](samples/fire/index.md)** • [*missing*](samples/author-missing.md) [fire](samples/fire.md), [graphics](samples/graphics.md) - **[Floormaper](samples/floormaper/index.md)** • [Antoni Gual](samples/antoni-gual.md) [graphics](samples/graphics.md), [floorscape](samples/floorscape.md) -- **[4 Player Pong](samples/four-player-pong/index.md)** • [Matthew](samples/matthew.md) [game](samples/game.md), [pong](samples/pong.md) -- **[Bezier](samples/fractal/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Four Player Pong](samples/four-player-pong/index.md)** • [Matthew](samples/matthew.md) [game](samples/game.md), [pong](samples/pong.md) +- **[Fractal](samples/fractal/index.md)** • [RhoSigma](samples/rhosigma.md) [screenblanker](samples/screenblanker.md) - **[Fractal Art](samples/fractal-art/index.md)** • [Zom-B](samples/zom-b.md) [fractal](samples/fractal.md), [art](samples/art.md) - **[Fractal Fern](samples/fractal-fern/index.md)** • [*missing*](samples/author-missing.md) [fractal](samples/fractal.md), [fern](samples/fern.md) -- **[Globe](samples/globe/index.md)** • [Glen Jeh](samples/glen-jeh.md) • [8/12/1994](samples/8/12/1994.md) • [William Yu (05-28-96)](samples/william-yu-(05-28-96).md) [3d](samples/3d.md), [sphere](samples/sphere.md) -- **[GUJERO2](samples/gujero2/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [tunnel](samples/tunnel.md) +- **[Globe](samples/globe/index.md)** • [Jeh](samples/jeh.md) • [Yu](samples/yu.md) [3d](samples/3d.md), [sphere](samples/sphere.md) +- **[Gujero2](samples/gujero2/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [tunnel](samples/tunnel.md) - **[Helicopter Rescue](samples/helicopter-rescue/index.md)** • [TrialAndTerror](samples/trialandterror.md) [game](samples/game.md), [3d](samples/3d.md), [flight](samples/flight.md) - **[Inverse Julia Fractal Explorer](samples/inverse-julia-fractal-explorer/index.md)** • [Zom-B](samples/zom-b.md) [fractal](samples/fractal.md), [julia set](samples/julia-set.md) - **[Julia Rings](samples/julia-rings/index.md)** • [Relsoft](samples/relsoft.md) [fractal](samples/fractal.md), [julia set](samples/julia-set.md) -- **[Bezier](samples/kaleidoscope/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) -- **[Bezier](samples/kaleidoscope-mill/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) -- **[Bezier](samples/lightning-one/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) -- **[Bezier](samples/lightning-two/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) -- **[Lissajous Curve Table](samples/lissajous-curve-table/index.md)** • [FellippeHeitor](samples/fellippeheitor.md) [graphics](samples/graphics.md), [trigonometry](samples/trigonometry.md) +- **[Kaleidoscope](samples/kaleidoscope/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Kaleidoscope Mill](samples/kaleidoscope-mill/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Lightning One](samples/lightning-one/index.md)** • [RhoSigma](samples/rhosigma.md) [screenblanker](samples/screenblanker.md) +- **[Lightning Two](samples/lightning-two/index.md)** • [RhoSigma](samples/rhosigma.md) [screenblanker](samples/screenblanker.md) +- **[LightsOn](samples/lightson/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [lights](samples/lights.md) +- **[Lissajous Curve Table](samples/lissajous-curve-table/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [graphics](samples/graphics.md), [trigonometry](samples/trigonometry.md) - **[Lissajous Screensaver](samples/lissajous-screensaver/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) -- **[Rotating Lorenz Attractor](samples/lorenz-attractor/index.md)** • [Vince](samples/vince.md) [lorenz](samples/lorenz.md), [rotations](samples/rotations.md) -- **[Mandala 9 Line](samples/manadla/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) +- **[Lorenz Attractor](samples/lorenz-attractor/index.md)** • [Vince](samples/vince.md) [lorenz](samples/lorenz.md), [rotations](samples/rotations.md) +- **[Manadla](samples/manadla/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) - **[Mandelbrot Animator](samples/mandelbrot-animator/index.md)** • [*missing*](samples/author-missing.md) [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md) -- **[Mandelbrot](samples/mandelbrot-set-2003/index.md)** • [Antoni Gual](samples/antoni-gual.md) [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md), [9 lines](samples/9-lines.md) -- **[Mandelbrot Set](samples/mandelbrot-set-2008/index.md)** • [qbguy](samples/qbguy.md) [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md) -- **[Tor Myklebust](samples/mandelbrot-zoomer/index.md)** • [*missing*](samples/author-missing.md) [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md) +- **[Mandelbrot Set 2003](samples/mandelbrot-set-2003/index.md)** • [Antoni Gual](samples/antoni-gual.md) [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md), [9 lines](samples/9-lines.md) +- **[Mandelbrot Set 2008](samples/mandelbrot-set-2008/index.md)** • [qbguy](samples/qbguy.md) [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md) +- **[Mandelbrot Zoomer](samples/mandelbrot-zoomer/index.md)** • [*missing*](samples/author-missing.md) [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md) - **[Maptriangle in 3D](samples/maptriangle-in-3d/index.md)** • [Petr](samples/petr.md) [3d](samples/3d.md), [maptriangle](samples/maptriangle.md) - **[Matrix Effect](samples/matrix-effect/index.md)** • [TylerDarko](samples/tylerdarko.md) [ascii](samples/ascii.md), [matrix](samples/matrix.md) +- **[Mazes of Misery](samples/mazes-of-misery/index.md)** • [Steve M.](samples/steve-m..md) [game](samples/game.md), [maze](samples/maze.md) - **[Mini Clock](samples/mini-clock/index.md)** • [Folker Fritz](samples/folker-fritz.md) [clock](samples/clock.md), [desktop](samples/desktop.md) -- **[Bezier](samples/multi-mill/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) -- **[Bezier](samples/mystify/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Money](samples/money/index.md)** • [Microsoft](samples/microsoft.md) [data management](samples/data-management.md) +- **[Moon Lander](samples/moon-lander/index.md)** • [Richard Frost](samples/richard-frost.md) [game](samples/game.md), [lander](samples/lander.md) +- **[Multi-Mill](samples/multi-mill/index.md)** • [RhoSigma](samples/rhosigma.md) [screenblanker](samples/screenblanker.md) +- **[Mystify](samples/mystify/index.md)** • [RhoSigma](samples/rhosigma.md) [screenblanker](samples/screenblanker.md) +- **[Nibbles](samples/nibbles/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [snake](samples/snake.md) - **[Particle Fountain](samples/particle-fountain/index.md)** • [bplus](samples/bplus.md) [particles](samples/particles.md) -- **[Mandala 9 Line](samples/pattern/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) +- **[Pattern](samples/pattern/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) - **[Pendulum Game](samples/pendulum-game/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [pendulum](samples/pendulum.md) -- **[Pipes Puzzle (Maze Connect)](samples/pipes-puzzle/index.md)** • [Dav](samples/dav.md) [game](samples/game.md), [puzzle](samples/puzzle.md) -- **[Non-Palette Rotated Plasma](samples/plasma-non-pal/index.md)** • [Relsoft](samples/relsoft.md) [screensaver](samples/screensaver.md), [plasma](samples/plasma.md) +- **[Phone](samples/phone/index.md)** • [Microsoft](samples/microsoft.md) [data management](samples/data-management.md) +- **[Pipes Puzzle](samples/pipes-puzzle/index.md)** • [Dav](samples/dav.md) [game](samples/game.md), [puzzle](samples/puzzle.md) +- **[PixelPlus](samples/pixelplus/index.md)** • [Chris Chadwick](samples/chris-chadwick.md) [graphics](samples/graphics.md), [bitmap](samples/bitmap.md) +- **[Plasma Non-Pal](samples/plasma-non-pal/index.md)** • [Relsoft](samples/relsoft.md) [screensaver](samples/screensaver.md), [plasma](samples/plasma.md) +- **[Platform](samples/platform/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [platform](samples/platform.md) +- **[QBAscii](samples/qbascii/index.md)** • [Jeremy Munn](samples/jeremy-munn.md) [drawing](samples/drawing.md), [ascii](samples/ascii.md) +- **[QBlocks](samples/qblocks/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [tetris](samples/tetris.md) +- **[QBricks](samples/qbricks/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [breakout](samples/breakout.md) +- **[QCards](samples/qcards/index.md)** • [Microsoft](samples/microsoft.md) [data management](samples/data-management.md) +- **[QDigger](samples/qdigger/index.md)** • [RETROQB45](samples/retroqb45.md) [game](samples/game.md), [digger](samples/digger.md) +- **[QMaze](samples/qmaze/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [maze](samples/maze.md) +- **[QShips](samples/qships/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [artillery](samples/artillery.md) +- **[QSpace](samples/qspace/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [defense](samples/defense.md) +- **[QSynth](samples/qsynth/index.md)** • [Microsoft](samples/microsoft.md) [sound](samples/sound.md), [music](samples/music.md) +- **[QTrek](samples/qtrek/index.md)** • [Philipp Strathausen](samples/philipp-strathausen.md) [game](samples/game.md), [space shooter](samples/space-shooter.md) +- **[Rattler](samples/rattler/index.md)** • [Bob Seguin](samples/bob-seguin.md) [game](samples/game.md), [snake](samples/snake.md) +- **[RayCaster](samples/raycaster/index.md)** • [Antoni Gual](samples/antoni-gual.md) [3d](samples/3d.md), [raycaster](samples/raycaster.md) +- **[Reversi](samples/reversi/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md) - **[Ripples](samples/ripples/index.md)** • [Antoni Gual](samples/antoni-gual.md) [image processing](samples/image-processing.md), [ripple](samples/ripple.md) - **[Rotozoomer](samples/rotozoomer/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) - **[Set Fire to Rain](samples/set-fire-to-rain/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [zen](samples/zen.md) @@ -66,11 +87,11 @@ - **[SineCube](samples/sinecube/index.md)** • [Mennonite](samples/mennonite.md) [graphics](samples/graphics.md) - **[Snake Basic](samples/snake-basic/index.md)** • [pcluddite](samples/pcluddite.md) [game](samples/game.md), [snake](samples/snake.md) - **[Sokoban](samples/sokoban/index.md)** • [David Joffe](samples/david-joffe.md) [game](samples/game.md), [puzzle](samples/puzzle.md) -- **[Sort demo](samples/sort-demo/index.md)** • [Microsoft](samples/microsoft.md) [sort](samples/sort.md) +- **[Sort Demo](samples/sort-demo/index.md)** • [Microsoft](samples/microsoft.md) [sort](samples/sort.md) - **[Space64](samples/space64/index.md)** • [Cyperium](samples/cyperium.md) [game](samples/game.md), [space shooter](samples/space-shooter.md) - **[Spaceship](samples/spaceship/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [space shooter](samples/space-shooter.md) -- **[Bezier](samples/splines/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) -- **[Starfield 9 Line](samples/starfield/index.md)** • [Antoni Gual](samples/antoni-gual.md) [starfield](samples/starfield.md), [9 lines](samples/9-lines.md) +- **[Splines](samples/splines/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Starfield](samples/starfield/index.md)** • [Antoni Gual](samples/antoni-gual.md) [starfield](samples/starfield.md), [9 lines](samples/9-lines.md) - **[Starfield Torus](samples/starfield-torus/index.md)** • [JKC](samples/jkc.md) [starfield](samples/starfield.md) - **[Texel Raytracer](samples/texel-raytracer/index.md)** • [Antoni Gual](samples/antoni-gual.md) [3d](samples/3d.md), [ray tracing](samples/ray-tracing.md) - **[Tic Tac Toe](samples/tic-tac-toe/index.md)** • [Paul Meyer](samples/paul-meyer.md) [game](samples/game.md), [tic tac toe](samples/tic-tac-toe.md) @@ -81,4 +102,4 @@ - **[Twirl](samples/twirl/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) - **[Vortex](samples/vortex/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) - **[Water](samples/water/index.md)** • [*missing*](samples/author-missing.md) [wave motion](samples/wave-motion.md) -- **[Bezier](samples/worms/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Worms](samples/worms/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) diff --git a/samples/3d-cube/index.md b/samples/3d-cube/index.md index a52f600a..bdaa3682 100644 --- a/samples/3d-cube/index.md +++ b/samples/3d-cube/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: JULIA RINGS +## SAMPLE: 3D CUBE ![screenshot.png](img/screenshot.png) diff --git a/samples/3d.md b/samples/3d.md index 86faa05a..12f37309 100644 --- a/samples/3d.md +++ b/samples/3d.md @@ -2,7 +2,7 @@ ## SAMPLES: 3D -**[Julia Rings](3d-cube/index.md)** +**[3D Cube](3d-cube/index.md)** [🐝 Relsoft](relsoft.md) 🔗 [3d](3d.md), [cube](cube.md) @@ -10,9 +10,9 @@ **[Globe](globe/index.md)** -[🐝 Glen Jeh](glen-jeh.md) [🐝 8/12/1994](8/12/1994.md) [🐝 William Yu (05-28-96)](william-yu-(05-28-96).md) 🔗 [3d](3d.md), [sphere](sphere.md) +[🐝 Jeh](jeh.md) [🐝 Yu](yu.md) 🔗 [3d](3d.md), [sphere](sphere.md) -'{A little rotating sphere, by Glen Jeh, 8/12/1994, use freely} '{Try messing with the constants.... +Glen Jeh, 8/12/1994, William Yu (05-28-96) '{A little rotating sphere, by Glen Jeh, 8/12/1994, u... **[Helicopter Rescue](helicopter-rescue/index.md)** @@ -26,6 +26,12 @@ A demo to show rotation in 3D using MAPTRIANGLE 3D, without direct OpenGL statements. Librarian'... +**[RayCaster](raycaster/index.md)** + +[🐝 Antoni Gual](antoni-gual.md) 🔗 [3d](3d.md), [raycaster](raycaster.md) + +'Antoni Gual raycaster 'Modified from Entropy's an 36-lines entry for the Biskbart's '40-lines QB... + **[Texel Raytracer](texel-raytracer/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [3d](3d.md), [ray tracing](ray-tracing.md) diff --git a/samples/8-12-1994.md b/samples/8-12-1994.md deleted file mode 100644 index 1548f89e..00000000 --- a/samples/8-12-1994.md +++ /dev/null @@ -1,9 +0,0 @@ -[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) - -## SAMPLES BY 8/12/1994 - -**[Globe](globe/index.md)** - -[🐝 Glen Jeh](glen-jeh.md) [🐝 8/12/1994](8/12/1994.md) [🐝 William Yu (05-28-96)](william-yu-(05-28-96).md) 🔗 [3d](3d.md), [sphere](sphere.md) - -'{A little rotating sphere, by Glen Jeh, 8/12/1994, use freely} '{Try messing with the constants.... diff --git a/samples/9-lines.md b/samples/9-lines.md index f3a0ea6a..a02a8c53 100644 --- a/samples/9-lines.md +++ b/samples/9-lines.md @@ -8,19 +8,19 @@ 'Lissajous by Antoni Gual 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-----------------... -**[Mandala 9 Line](manadla/index.md)** +**[Manadla](manadla/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [9 lines](9-lines.md) 'Mandala by Antoni gual 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-------------------... -**[Mandelbrot](mandelbrot-set-2003/index.md)** +**[Mandelbrot Set 2003](mandelbrot-set-2003/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md), [9 lines](9-lines.md) 'MANDELBROT by Antoni Gual 2003 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-----------... -**[Mandala 9 Line](pattern/index.md)** +**[Pattern](pattern/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [9 lines](9-lines.md) @@ -32,7 +32,7 @@ ' OPTIMIZED :) rotozoomer in 9 lines by Antoni Gual 'for Rel's 9 LINER contest at QBASICNEWS.COM... -**[Starfield 9 Line](starfield/index.md)** +**[Starfield](starfield/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [starfield](starfield.md), [9 lines](9-lines.md) diff --git a/samples/antoni-gual.md b/samples/antoni-gual.md index d9ae4573..b020fcff 100644 --- a/samples/antoni-gual.md +++ b/samples/antoni-gual.md @@ -8,7 +8,7 @@ Floormaper by Antoni Gual for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 -**[GUJERO2](gujero2/index.md)** +**[Gujero2](gujero2/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [tunnel](tunnel.md) @@ -20,24 +20,30 @@ Floormaper by Antoni Gual for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 'Lissajous by Antoni Gual 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-----------------... -**[Mandala 9 Line](manadla/index.md)** +**[Manadla](manadla/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [9 lines](9-lines.md) 'Mandala by Antoni gual 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-------------------... -**[Mandelbrot](mandelbrot-set-2003/index.md)** +**[Mandelbrot Set 2003](mandelbrot-set-2003/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md), [9 lines](9-lines.md) 'MANDELBROT by Antoni Gual 2003 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-----------... -**[Mandala 9 Line](pattern/index.md)** +**[Pattern](pattern/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [9 lines](9-lines.md) 'patterns 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '---------------------------------... +**[RayCaster](raycaster/index.md)** + +[🐝 Antoni Gual](antoni-gual.md) 🔗 [3d](3d.md), [raycaster](raycaster.md) + +'Antoni Gual raycaster 'Modified from Entropy's an 36-lines entry for the Biskbart's '40-lines QB... + **[Ripples](ripples/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [image processing](image-processing.md), [ripple](ripple.md) @@ -50,7 +56,7 @@ Floormaper by Antoni Gual for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 ' OPTIMIZED :) rotozoomer in 9 lines by Antoni Gual 'for Rel's 9 LINER contest at QBASICNEWS.COM... -**[Starfield 9 Line](starfield/index.md)** +**[Starfield](starfield/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [starfield](starfield.md), [9 lines](9-lines.md) diff --git a/samples/arc-demo/index.md b/samples/arc-demo/index.md index aba13054..30626c59 100644 --- a/samples/arc-demo/index.md +++ b/samples/arc-demo/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: ARCDEMO +## SAMPLE: ARC DEMO ![screenshot.png](img/screenshot.png) diff --git a/samples/ray-tracer.md b/samples/artillery.md similarity index 50% rename from samples/ray-tracer.md rename to samples/artillery.md index e3b74919..d10564f7 100644 --- a/samples/ray-tracer.md +++ b/samples/artillery.md @@ -1,9 +1,9 @@ [Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) -## SAMPLES: RAY TRACER +## SAMPLES: ARTILLERY -**[Ray Tracer Demo](ray-tracer-demo/index.md)** +**[QShips](qships/index.md)** -[🐝 Antoni Gual](antoni-gual.md) 🔗 [ray tracer](ray-tracer.md) +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [artillery](artillery.md) -'Pure QB Realtime Raytracer Demo 'Translated to/optimized for QB by Antoni Gual agual@eic.ictnet.... +Turn-based artillery game by Microsoft. diff --git a/samples/ascii.md b/samples/ascii.md index e65e0bd1..42d57167 100644 --- a/samples/ascii.md +++ b/samples/ascii.md @@ -7,3 +7,9 @@ [🐝 TylerDarko](tylerdarko.md) 🔗 [ascii](ascii.md), [matrix](matrix.md) If you look close, it spells F-e-l-l-i-p-p-e. + +**[QBAscii](qbascii/index.md)** + +[🐝 Jeremy Munn](jeremy-munn.md) 🔗 [drawing](drawing.md), [ascii](ascii.md) + +'***************************************************************************** ' Name: QB... diff --git a/samples/author-cloud.md b/samples/author-cloud.md index 0f12b936..0ea69b64 100644 --- a/samples/author-cloud.md +++ b/samples/author-cloud.md @@ -2,4 +2,4 @@ ## AUTHORS -[Antoni Gual:23](antoni-gual.md) • [Rho Sigma:21](rho-sigma.md) • [*missing*:15](author-missing.md) • [Fellippe Heitor:13](fellippe-heitor.md) • [bplus:9](bplus.md) • [Microsoft:5](microsoft.md) • [Relsoft:5](relsoft.md) • [STxAxTIC:5](stxaxtic.md) • [Bob Seguin:3](bob-seguin.md) • [vince:3](vince.md) • [Zom-B:3](zom-b.md) • [8/12/1994:1](8-12-1994.md) • [Cobalt:1](cobalt.md) • [Cyperium:1](cyperium.md) • [darokin:1](darokin.md) • [Dav:1](dav.md) • [David Joffe:1](david-joffe.md) • [FellippeHeitor:1](fellippeheitor.md) • [Folker Fritz:1](folker-fritz.md) • [Glen Jeh:1](glen-jeh.md) • [Glenn Powell:1](glenn-powell.md) • [JKC:1](jkc.md) • [Matthew:1](matthew.md) • [Mennonite:1](mennonite.md) • [Paul Meyer:1](paul-meyer.md) • [pcluddite:1](pcluddite.md) • [Petr:1](petr.md) • [QB64 Team 2018:1](qb64-team-2018.md) • [qbguy:1](qbguy.md) • [Richard Frost:1](richard-frost.md) • [Timothy Baxendale:1](timothy-baxendale.md) • [TrialAndTerror:1](trialandterror.md) • [triggered:1](triggered.md) • [Tsiplacov Sergey:1](tsiplacov-sergey.md) • [TylerDarko:1](tylerdarko.md) • [William Yu (05-28-96):1](william-yu-(05-28-96).md) \ No newline at end of file +[Microsoft:27](microsoft.md) • [Antoni Gual:25](antoni-gual.md) • [Fellippe Heitor:19](fellippe-heitor.md) • [*missing*:15](author-missing.md) • [RhoSigma:11](rhosigma.md) • [bplus:9](bplus.md) • [Rho Sigma:9](rho-sigma.md) • [Bob Seguin:5](bob-seguin.md) • [Relsoft:5](relsoft.md) • [STxAxTIC:5](stxaxtic.md) • [Richard Frost:3](richard-frost.md) • [vince:3](vince.md) • [Zom-B:3](zom-b.md) • [Chris Chadwick:1](chris-chadwick.md) • [Cobalt:1](cobalt.md) • [Cyperium:1](cyperium.md) • [darokin:1](darokin.md) • [Dav:1](dav.md) • [David Joffe:1](david-joffe.md) • [Folker Fritz:1](folker-fritz.md) • [Glenn Powell:1](glenn-powell.md) • [Jeh:1](jeh.md) • [Jeremy Munn:1](jeremy-munn.md) • [JKC:1](jkc.md) • [Matthew:1](matthew.md) • [Mennonite:1](mennonite.md) • [Paul Meyer:1](paul-meyer.md) • [pcluddite:1](pcluddite.md) • [Petr:1](petr.md) • [Philipp Strathausen:1](philipp-strathausen.md) • [QB64 Team 2018:1](qb64-team-2018.md) • [qbguy:1](qbguy.md) • [RETROQB45:1](retroqb45.md) • [Steve M.:1](steve-m..md) • [Timothy Baxendale:1](timothy-baxendale.md) • [TrialAndTerror:1](trialandterror.md) • [triggered:1](triggered.md) • [Tsiplacov Sergey:1](tsiplacov-sergey.md) • [TylerDarko:1](tylerdarko.md) • [Yu:1](yu.md) \ No newline at end of file diff --git a/samples/author-missing.md b/samples/author-missing.md index 53989854..35b3ac8a 100644 --- a/samples/author-missing.md +++ b/samples/author-missing.md @@ -20,7 +20,7 @@ The legendary fractal fern. Mandelbrot animator. -**[Tor Myklebust](mandelbrot-zoomer/index.md)** +**[Mandelbrot Zoomer](mandelbrot-zoomer/index.md)** [🐝 *missing*](author-missing.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) diff --git a/samples/binary-clock/index.md b/samples/binary-clock/index.md index 83161143..e2e59076 100644 --- a/samples/binary-clock/index.md +++ b/samples/binary-clock/index.md @@ -6,7 +6,7 @@ ### Author -[🐝 Rho Sigma](../rho-sigma.md) +[🐝 RhoSigma](../rhosigma.md) ### Description diff --git a/samples/bitmap.md b/samples/bitmap.md new file mode 100644 index 00000000..1d5f72fd --- /dev/null +++ b/samples/bitmap.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: BITMAP + +**[PixelPlus](pixelplus/index.md)** + +[🐝 Chris Chadwick](chris-chadwick.md) 🔗 [graphics](graphics.md), [bitmap](bitmap.md) + +'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' PIXELplus 256 Us... diff --git a/samples/bob-seguin.md b/samples/bob-seguin.md index 31267ba7..2fcce06a 100644 --- a/samples/bob-seguin.md +++ b/samples/bob-seguin.md @@ -13,3 +13,9 @@ Abacus app by Bob Seguin. NOTE: This game requires graphics files created by an [🐝 Bob Seguin](bob-seguin.md) 🔗 [art](art.md), [drawing](drawing.md) A Graphics/Animation utility by Bob Seguin. NOTE: This game requires graphics files created by a... + +**[Rattler](rattler/index.md)** + +[🐝 Bob Seguin](bob-seguin.md) 🔗 [game](game.md), [snake](snake.md) + +Snake clone by Bob Seguin. diff --git a/samples/breakout.md b/samples/breakout.md index 56640c6c..c9d27dc5 100644 --- a/samples/breakout.md +++ b/samples/breakout.md @@ -7,3 +7,9 @@ [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [breakout](breakout.md) A Breakout clone with DXBall aspirations. + +**[QBricks](qbricks/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [breakout](breakout.md) + +Breakout clone by Microsoft. diff --git a/samples/cant-contain-me/index.md b/samples/cant-contain-me/index.md index 92c55572..310a87d6 100644 --- a/samples/cant-contain-me/index.md +++ b/samples/cant-contain-me/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: CAN'T CONTAIN ME +## SAMPLE: CANT CONTAIN ME ![screenshot.jpg](img/screenshot.jpg) diff --git a/samples/chaotic-scattering/index.md b/samples/chaotic-scattering/index.md index b149f161..89d01b4e 100644 --- a/samples/chaotic-scattering/index.md +++ b/samples/chaotic-scattering/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: CHAOTIC SCATTERING - GASPARD-RICE SYSTEM +## SAMPLE: CHAOTIC SCATTERING ![chaoticscattering.png](img/chaoticscattering.png) @@ -20,3 +20,6 @@ Demo of the Gaspard-Rice system. Left-click to change location. * [scatter2.bas](src/scatter2.bas) 🔗 [ray tracing](../ray-tracing.md), [reflections](../reflections.md) + + +Reference: [1](ttps://en.wikipedia.org/wiki/Chaotic_scattering) diff --git a/samples/chris-chadwick.md b/samples/chris-chadwick.md new file mode 100644 index 00000000..7093ea20 --- /dev/null +++ b/samples/chris-chadwick.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES BY CHRIS CHADWICK + +**[PixelPlus](pixelplus/index.md)** + +[🐝 Chris Chadwick](chris-chadwick.md) 🔗 [graphics](graphics.md), [bitmap](bitmap.md) + +'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' PIXELplus 256 Us... diff --git a/samples/cobalt.md b/samples/cobalt.md index 4d9bda24..4dd6a421 100644 --- a/samples/cobalt.md +++ b/samples/cobalt.md @@ -2,7 +2,7 @@ ## SAMPLES BY COBALT -**[Dragon Warrior 64](dragon-warrior/index.md)** +**[Dragon Warrior](dragon-warrior/index.md)** [🐝 Cobalt](cobalt.md) 🔗 [game](game.md), [rpg](rpg.md) diff --git a/samples/cube.md b/samples/cube.md index b3ffc5e8..24c07a82 100644 --- a/samples/cube.md +++ b/samples/cube.md @@ -2,7 +2,7 @@ ## SAMPLES: CUBE -**[Julia Rings](3d-cube/index.md)** +**[3D Cube](3d-cube/index.md)** [🐝 Relsoft](relsoft.md) 🔗 [3d](3d.md), [cube](cube.md) diff --git a/samples/data-management.md b/samples/data-management.md new file mode 100644 index 00000000..8d8a26fd --- /dev/null +++ b/samples/data-management.md @@ -0,0 +1,21 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: DATA MANAGEMENT + +**[Money](money/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) + +Money manager by Microsoft. + +**[Phone](phone/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) + +Simple phone directory by Microsoft. + +**[QCards](qcards/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) + +A simple database using a cardfile user interface by Microsoft. diff --git a/samples/dav.md b/samples/dav.md index 05f208a9..ac44a5d1 100644 --- a/samples/dav.md +++ b/samples/dav.md @@ -2,7 +2,7 @@ ## SAMPLES BY DAV -**[Pipes Puzzle (Maze Connect)](pipes-puzzle/index.md)** +**[Pipes Puzzle](pipes-puzzle/index.md)** [🐝 Dav](dav.md) 🔗 [game](game.md), [puzzle](puzzle.md) diff --git a/samples/defense.md b/samples/defense.md new file mode 100644 index 00000000..88da0634 --- /dev/null +++ b/samples/defense.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: DEFENSE + +**[QSpace](qspace/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [defense](defense.md) + +Space station defense game by Microsoft. diff --git a/samples/digger.md b/samples/digger.md new file mode 100644 index 00000000..de713ace --- /dev/null +++ b/samples/digger.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: DIGGER + +**[QDigger](qdigger/index.md)** + +[🐝 RETROQB45](retroqb45.md) 🔗 [game](game.md), [digger](digger.md) + +A DIGGER game clone by RETROQB45. diff --git a/samples/dragon-warrior/index.md b/samples/dragon-warrior/index.md index 21ae29dd..b7f546ef 100644 --- a/samples/dragon-warrior/index.md +++ b/samples/dragon-warrior/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: DRAGON WARRIOR 64 +## SAMPLE: DRAGON WARRIOR ![dragon-warrior-64-gameplay1-screenshot.png](img/dragon-warrior-64-gameplay1-screenshot.png) diff --git a/samples/drawing.md b/samples/drawing.md index 74823f09..ca8d25e7 100644 --- a/samples/drawing.md +++ b/samples/drawing.md @@ -7,3 +7,9 @@ [🐝 Bob Seguin](bob-seguin.md) 🔗 [art](art.md), [drawing](drawing.md) A Graphics/Animation utility by Bob Seguin. NOTE: This game requires graphics files created by a... + +**[QBAscii](qbascii/index.md)** + +[🐝 Jeremy Munn](jeremy-munn.md) 🔗 [drawing](drawing.md), [ascii](ascii.md) + +'***************************************************************************** ' Name: QB... diff --git a/samples/fellippe-heitor.md b/samples/fellippe-heitor.md index dff35de7..c417016d 100644 --- a/samples/fellippe-heitor.md +++ b/samples/fellippe-heitor.md @@ -14,18 +14,36 @@ A pretentious clone attempt of Among Us (originally by Inner Sloth) To test: 1) A Breakout clone with DXBall aspirations. -**[Can't Contain Me](cant-contain-me/index.md)** +**[Cant Contain Me](cant-contain-me/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md) Can't Contain Me is a game developed in QB64. The pieces are trying to escape your screen and th... +**[LightsOn](lightson/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [lights](lights.md) + +'Lights On 'A game by Fellippe Heitor. ' 'Original concept by Avi Olti, Gyora Benedek, Zvi Herman... + +**[Lissajous Curve Table](lissajous-curve-table/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [graphics](graphics.md), [trigonometry](trigonometry.md) + +Graphical Lissajou's Figures. For added eye-candy-ness, I've changed the plot line to paint usin... + **[Pendulum Game](pendulum-game/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [pendulum](pendulum.md) My attempt at creating something drawing inspiration from Fire Rides by Voodoo. Made with QB64. +**[Platform](platform/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [platform](platform.md) + +# Platform What does a 2D platform game take? Made with QB64. + **[Set Fire to Rain](set-fire-to-rain/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [zen](zen.md) diff --git a/samples/fellippeheitor.md b/samples/fellippeheitor.md deleted file mode 100644 index 2023c71f..00000000 --- a/samples/fellippeheitor.md +++ /dev/null @@ -1,9 +0,0 @@ -[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) - -## SAMPLES BY FELLIPPEHEITOR - -**[Lissajous Curve Table](lissajous-curve-table/index.md)** - -[🐝 FellippeHeitor](fellippeheitor.md) 🔗 [graphics](graphics.md), [trigonometry](trigonometry.md) - -Graphical Lissajou's Figures. For added eye-candy-ness, I've changed the plot line to paint usin... diff --git a/samples/four-player-pong/index.md b/samples/four-player-pong/index.md index d21fa445..f53c36f0 100644 --- a/samples/four-player-pong/index.md +++ b/samples/four-player-pong/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: 4 PLAYER PONG +## SAMPLE: FOUR PLAYER PONG ![screenshot.png](img/screenshot.png) diff --git a/samples/fractal.md b/samples/fractal.md index 3d6a1665..89214582 100644 --- a/samples/fractal.md +++ b/samples/fractal.md @@ -32,19 +32,19 @@ Automated Julia set explorer. Mandelbrot animator. -**[Mandelbrot](mandelbrot-set-2003/index.md)** +**[Mandelbrot Set 2003](mandelbrot-set-2003/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md), [9 lines](9-lines.md) 'MANDELBROT by Antoni Gual 2003 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-----------... -**[Mandelbrot Set](mandelbrot-set-2008/index.md)** +**[Mandelbrot Set 2008](mandelbrot-set-2008/index.md)** [🐝 qbguy](qbguy.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) public domain, uses qb64's 2d prototype -**[Tor Myklebust](mandelbrot-zoomer/index.md)** +**[Mandelbrot Zoomer](mandelbrot-zoomer/index.md)** [🐝 *missing*](author-missing.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) diff --git a/samples/fractal/index.md b/samples/fractal/index.md index 14064262..b902f9cd 100644 --- a/samples/fractal/index.md +++ b/samples/fractal/index.md @@ -1,12 +1,12 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: FRACTAL ![screenshot.png](img/screenshot.png) ### Author -[🐝 Rho Sigma](../rho-sigma.md) +[🐝 RhoSigma](../rhosigma.md) ### Description diff --git a/samples/game.md b/samples/game.md index 45671844..a3e2d597 100644 --- a/samples/game.md +++ b/samples/game.md @@ -8,7 +8,7 @@ A pretentious clone attempt of Among Us (originally by Inner Sloth) To test: 1) Compile/run amon... -**[ArcDemo](arc-demo/index.md)** +**[Arc Demo](arc-demo/index.md)** [🐝 Tsiplacov Sergey](tsiplacov-sergey.md) 🔗 [game](game.md), [platformer](platformer.md) @@ -26,7 +26,7 @@ This is a game of weapons and destruction that relies upon the properties of phy A Breakout clone with DXBall aspirations. -**[Can't Contain Me](cant-contain-me/index.md)** +**[Cant Contain Me](cant-contain-me/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md) @@ -38,13 +38,13 @@ Can't Contain Me is a game developed in QB64. The pieces are trying to escape y A turn-based artillery game by Microsoft. -**[Dragon Warrior 64](dragon-warrior/index.md)** +**[Dragon Warrior](dragon-warrior/index.md)** [🐝 Cobalt](cobalt.md) 🔗 [game](game.md), [rpg](rpg.md) QB64 version of Nintendo Dragon Quest (Dragon Warrior). The time has come to go on your quest to... -**[4 Player Pong](four-player-pong/index.md)** +**[Four Player Pong](four-player-pong/index.md)** [🐝 Matthew](matthew.md) 🔗 [game](game.md), [pong](pong.md) @@ -56,18 +56,102 @@ Four-player pong game. ================================================================================= H E L ... +**[LightsOn](lightson/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [lights](lights.md) + +'Lights On 'A game by Fellippe Heitor. ' 'Original concept by Avi Olti, Gyora Benedek, Zvi Herman... + +**[Mazes of Misery](mazes-of-misery/index.md)** + +[🐝 Steve M.](steve-m..md) 🔗 [game](game.md), [maze](maze.md) + +'Maze of Misery 'By Steve M. (c),May 5,01 '**************** 'Please visit my web page at: www.a... + +**[Moon Lander](moon-lander/index.md)** + +[🐝 Richard Frost](richard-frost.md) 🔗 [game](game.md), [lander](lander.md) + +Lunar Lander based on a 1974 program running on a DEC PDP/11 with GT40 vector display terminal at... + +**[Nibbles](nibbles/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [snake](snake.md) + +Snake clone by Microsoft. + **[Pendulum Game](pendulum-game/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [pendulum](pendulum.md) My attempt at creating something drawing inspiration from Fire Rides by Voodoo. Made with QB64. -**[Pipes Puzzle (Maze Connect)](pipes-puzzle/index.md)** +**[Pipes Puzzle](pipes-puzzle/index.md)** [🐝 Dav](dav.md) 🔗 [game](game.md), [puzzle](puzzle.md) '================ 'PIPES.BAS v1.0 '================ 'Connect the pipes puzzle game 'Coded by ... +**[Platform](platform/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [platform](platform.md) + +# Platform What does a 2D platform game take? Made with QB64. + +**[QBlocks](qblocks/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [tetris](tetris.md) + +Tetris clone by Microsoft. + +**[QBricks](qbricks/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [breakout](breakout.md) + +Breakout clone by Microsoft. + +**[QDigger](qdigger/index.md)** + +[🐝 RETROQB45](retroqb45.md) 🔗 [game](game.md), [digger](digger.md) + +A DIGGER game clone by RETROQB45. + +**[QMaze](qmaze/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [maze](maze.md) + +Maze puzzle game by Microsoft. + +**[QShips](qships/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [artillery](artillery.md) + +Turn-based artillery game by Microsoft. + +**[QSpace](qspace/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [defense](defense.md) + +Space station defense game by Microsoft. + +**[QTrek](qtrek/index.md)** + +[🐝 Philipp Strathausen](philipp-strathausen.md) 🔗 [game](game.md), [space shooter](space-shooter.md) + +Star Trek-like game by Philipp Strathausen. + +**[Rattler](rattler/index.md)** + +[🐝 Bob Seguin](bob-seguin.md) 🔗 [game](game.md), [snake](snake.md) + +Snake clone by Bob Seguin. + +**[Reversi](reversi/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md) + +Reversi game by Microsoft. + **[Set Fire to Rain](set-fire-to-rain/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [zen](zen.md) diff --git a/samples/glen-jeh.md b/samples/glen-jeh.md deleted file mode 100644 index 226889f8..00000000 --- a/samples/glen-jeh.md +++ /dev/null @@ -1,9 +0,0 @@ -[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) - -## SAMPLES BY GLEN JEH - -**[Globe](globe/index.md)** - -[🐝 Glen Jeh](glen-jeh.md) [🐝 8/12/1994](8/12/1994.md) [🐝 William Yu (05-28-96)](william-yu-(05-28-96).md) 🔗 [3d](3d.md), [sphere](sphere.md) - -'{A little rotating sphere, by Glen Jeh, 8/12/1994, use freely} '{Try messing with the constants.... diff --git a/samples/globe/index.md b/samples/globe/index.md index 3f7e17da..38a974b2 100644 --- a/samples/globe/index.md +++ b/samples/globe/index.md @@ -6,11 +6,13 @@ ### Authors -[🐝 Glen Jeh](../glen-jeh.md) [🐝 8/12/1994](../8/12/1994.md) [🐝 William Yu (05-28-96)](../william-yu-(05-28-96).md) +[🐝 Jeh](../jeh.md) [🐝 Yu](../yu.md) ### Description ```text +Glen Jeh, 8/12/1994, William Yu (05-28-96) + '{A little rotating sphere, by Glen Jeh, 8/12/1994, use freely} '{Try messing with the constants...code is squished a little} ' Converted to BASIC by William Yu (05-28-96) diff --git a/samples/graphics.md b/samples/graphics.md index aa31de77..856ecf93 100644 --- a/samples/graphics.md +++ b/samples/graphics.md @@ -16,10 +16,16 @@ Floormaper by Antoni Gual for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 **[Lissajous Curve Table](lissajous-curve-table/index.md)** -[🐝 FellippeHeitor](fellippeheitor.md) 🔗 [graphics](graphics.md), [trigonometry](trigonometry.md) +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [graphics](graphics.md), [trigonometry](trigonometry.md) Graphical Lissajou's Figures. For added eye-candy-ness, I've changed the plot line to paint usin... +**[PixelPlus](pixelplus/index.md)** + +[🐝 Chris Chadwick](chris-chadwick.md) 🔗 [graphics](graphics.md), [bitmap](bitmap.md) + +'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' PIXELplus 256 Us... + **[SineCube](sinecube/index.md)** [🐝 Mennonite](mennonite.md) 🔗 [graphics](graphics.md) diff --git a/samples/jeh.md b/samples/jeh.md new file mode 100644 index 00000000..b43875e3 --- /dev/null +++ b/samples/jeh.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES BY JEH + +**[Globe](globe/index.md)** + +[🐝 Jeh](jeh.md) [🐝 Yu](yu.md) 🔗 [3d](3d.md), [sphere](sphere.md) + +Glen Jeh, 8/12/1994, William Yu (05-28-96) '{A little rotating sphere, by Glen Jeh, 8/12/1994, u... diff --git a/samples/jeremy-munn.md b/samples/jeremy-munn.md new file mode 100644 index 00000000..86cf2d99 --- /dev/null +++ b/samples/jeremy-munn.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES BY JEREMY MUNN + +**[QBAscii](qbascii/index.md)** + +[🐝 Jeremy Munn](jeremy-munn.md) 🔗 [drawing](drawing.md), [ascii](ascii.md) + +'***************************************************************************** ' Name: QB... diff --git a/samples/kaleidoscope-mill/index.md b/samples/kaleidoscope-mill/index.md index af56fd18..21dd6998 100644 --- a/samples/kaleidoscope-mill/index.md +++ b/samples/kaleidoscope-mill/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: KALEIDOSCOPE MILL ![screenshot.png](img/screenshot.png) diff --git a/samples/kaleidoscope/index.md b/samples/kaleidoscope/index.md index 4d6f3081..e5452091 100644 --- a/samples/kaleidoscope/index.md +++ b/samples/kaleidoscope/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: KALEIDOSCOPE ![screenshot.png](img/screenshot.png) diff --git a/samples/lander.md b/samples/lander.md new file mode 100644 index 00000000..2c4a140b --- /dev/null +++ b/samples/lander.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: LANDER + +**[Moon Lander](moon-lander/index.md)** + +[🐝 Richard Frost](richard-frost.md) 🔗 [game](game.md), [lander](lander.md) + +Lunar Lander based on a 1974 program running on a DEC PDP/11 with GT40 vector display terminal at... diff --git a/samples/lightning-one/index.md b/samples/lightning-one/index.md index 0a4915bf..66dafdd0 100644 --- a/samples/lightning-one/index.md +++ b/samples/lightning-one/index.md @@ -1,12 +1,12 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: LIGHTNING ONE ![screenshot.png](img/screenshot.png) ### Author -[🐝 Rho Sigma](../rho-sigma.md) +[🐝 RhoSigma](../rhosigma.md) ### Description diff --git a/samples/lightning-two/index.md b/samples/lightning-two/index.md index 50136081..3ec3fde3 100644 --- a/samples/lightning-two/index.md +++ b/samples/lightning-two/index.md @@ -1,12 +1,12 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: LIGHTNING TWO ![screenshot.png](img/screenshot.png) ### Author -[🐝 Rho Sigma](../rho-sigma.md) +[🐝 RhoSigma](../rhosigma.md) ### Description diff --git a/samples/lights.md b/samples/lights.md new file mode 100644 index 00000000..d0ad25af --- /dev/null +++ b/samples/lights.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: LIGHTS + +**[LightsOn](lightson/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [lights](lights.md) + +'Lights On 'A game by Fellippe Heitor. ' 'Original concept by Avi Olti, Gyora Benedek, Zvi Herman... diff --git a/samples/lightson/img/screenshot.png b/samples/lightson/img/screenshot.png new file mode 100644 index 00000000..09a81bfe Binary files /dev/null and b/samples/lightson/img/screenshot.png differ diff --git a/samples/lightson/img/screenshot2.png b/samples/lightson/img/screenshot2.png new file mode 100644 index 00000000..be306501 Binary files /dev/null and b/samples/lightson/img/screenshot2.png differ diff --git a/samples/lightson/img/screenshot3.png b/samples/lightson/img/screenshot3.png new file mode 100644 index 00000000..c8c7687b Binary files /dev/null and b/samples/lightson/img/screenshot3.png differ diff --git a/samples/lightson/index.md b/samples/lightson/index.md new file mode 100644 index 00000000..d25ac836 --- /dev/null +++ b/samples/lightson/index.md @@ -0,0 +1,34 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: LIGHTSON + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Fellippe Heitor](../fellippe-heitor.md) + +### Description + +```text +'Lights On +'A game by Fellippe Heitor. +' +'Original concept by Avi Olti, Gyora Benedek, Zvi Herman, Revital Bloomberg, Avi Weiner and Michael Ganor +'https://en.wikipedia.org/wiki/Lights_Out_(game) +``` + +### File(s) + +* [lightson.bas](src/lightson.bas) +* [lightson.zip](src/lightson.zip) + +### Additional Image(s) + +![screenshot2.png](img/screenshot2.png) +![screenshot3.png](img/screenshot3.png) + +🔗 [game](../game.md), [lights](../lights.md) + + +Reference: [github.com](https://github.com/FellippeHeitor/LightsOn) diff --git a/samples/lightson/src/lightson.bas b/samples/lightson/src/lightson.bas new file mode 100644 index 00000000..2d320232 --- /dev/null +++ b/samples/lightson/src/lightson.bas @@ -0,0 +1,919 @@ +'Lights On +'A game by Fellippe Heitor - @FellippeHeitor - fellippe@qb64.org +' +'Original concept by Avi Olti, Gyora Benedek, Zvi Herman, Revital Bloomberg, Avi Weiner and Michael Ganor +'https://en.wikipedia.org/wiki/Lights_Out_(game) +' +'Assets sources acknowledged inside SUB GameSetup + +Option _Explicit + +$ExeIcon:'./assets/lightson.ico' +_Icon + +Const true = -1, false = Not true + +Type obj + i As Integer + j As Integer + x As Integer + y As Integer + w As Integer + h As Integer + IsOn As _Byte + lastSwitch As Single + lastHint As Single +End Type + +Randomize Timer + +Dim Shared Arena As Long, OverlayScreen As Long, Bg As Long +Dim Shared LightOn(1 To 9) As Long, LightOff(1 To 9) As Long +Dim Shared RestartIcon As Long, MouseCursor As Long +Dim Shared Ding As Long, Piano As Long, Switch As Long, Bonus As Long +Dim Shared Arial As Long, FontHeight As Integer +Dim Shared maxGridW As Integer, maxGridH As Integer +Dim Shared lights(1 To 20, 1 To 20) As obj +Dim Shared start!, moves As Integer, m$ +Dim Shared i As Integer, j As Integer, Level As Integer +Dim Shared k As Long, Alpha As Integer +Dim Shared maxW As Integer, maxH As Integer +Dim Shared MinMoves As Integer, Score As _Unsigned Long +Dim Shared TryAgain As _Byte, TutorialMode As _Byte +Dim Shared lightID As Integer +ReDim Shared Button(1 To 1) As obj, Caption(1 To UBound(Button)) As String + +'from p5js.bas - sound system +Type new_SoundHandle + handle As Long + sync As _Byte +End Type +ReDim Shared loadedSounds(0) As new_SoundHandle + +GameSetup +Intro + +Do + SetLevel + Do + UpdateScore + UpdateArena + + _Display + + k = _KeyHit + + If k = 27 Then System + + _Limit 30 + Loop Until Victory + + 'Give time for the last set of bulbs to light up + Dim LastBulbs As Single + LastBulbs = Timer + Do + UpdateArena + _Display + Loop Until Timer - LastBulbs > .3 + + EndScreen +Loop + +Sub Intro + 'Show intro + If isLoaded(LightOn(1)) And isLoaded(LightOff(1)) Then + _Dest OverlayScreen + Cls , 0 + Color _RGB32(255, 255, 255), 0 + _PrintString (_Width / 2 - _PrintWidth("Lights On!") / 2, _Height - FontHeight * 2), "Lights On!" + _Dest 0 + + _PutImage (_Width / 2 - _Width(LightOff(1)) / 2, 0), LightOff(1) + _Delay .5 + Alpha = 0 + p5play Piano + _Font 8 + Do + If Alpha < 255 Then Alpha = Alpha + 5 Else Exit Do + _SetAlpha Alpha, , OverlayScreen + _ClearColor _RGB32(0, 0, 0), OverlayScreen + _SetAlpha Alpha, , LightOn(1) + + _PutImage (_Width / 2 - _Width(LightOn(1)) / 2, 0), LightOn(1) + _PutImage , OverlayScreen + Color _RGBA32(255, 255, 255, Alpha), 0 + _PrintString (_Width / 2 - _PrintWidth("Fellippe Heitor, 2017") / 2, _Height - FontHeight * 1.5), "Fellippe Heitor, 2017" + + _Display + _Limit 20 + Loop + + _Font 16 + + If _FileExists("lightson.dat") = false And isLoaded(MouseCursor) Then + 'offer tutorial on the first run + Dim ii As Integer + + _Dest OverlayScreen + Cls , 0 + m$ = "Show instructions?" + Color _RGB32(0, 0, 0), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2 + 1, _Height / 2 - FontHeight * 2 + 1), m$ + Color _RGB32(255, 255, 255), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2, _Height / 2 - FontHeight * 2), m$ + _Dest 0 + + Do + _PutImage (_Width / 2 - _Width(LightOn(1)) / 2, 0), LightOn(1) + _PutImage , OverlayScreen + + For ii = 4 To 5 + If Hovering(Button(ii)) Then + Line (Button(ii).x + 5, Button(ii).y + 5)-Step(Button(ii).w, Button(ii).h), _RGB32(0, 0, 0), BF + Line (Button(ii).x, Button(ii).y)-Step(Button(ii).w, Button(ii).h), _RGB32(255, 255, 255), BF + Else + Line (Button(ii).x, Button(ii).y)-Step(Button(ii).w, Button(ii).h), _RGBA32(255, 255, 255, 170), BF + End If + Color _RGB32(0, 0, 0), 0 + _PrintString (Button(ii).x + Button(ii).w / 2 - _PrintWidth(Caption(ii)) / 2, Button(ii).y + Button(ii).h / 2 - FontHeight / 2), Caption(ii) + Next + + If _MouseButton(1) Then + While _MouseButton(1): ii = _MouseInput: Wend + If Hovering(Button(5)) Then + Exit Do + ElseIf Hovering(Button(4)) Then + TutorialMode = true + ShowTutorial + Open "lightson.dat" For Output As #1 + Close #1 + TutorialMode = false + Exit Do + End If + End If + + _Display + _Limit 30 + Loop + End If + End If +End Sub + +Sub ClickPause + Do + k = _KeyHit + + While _MouseInput: Wend + If _MouseButton(1) Then + While _MouseButton(1): i = _MouseInput: Wend + Exit Do + End If + + _Display + _Limit 30 + Loop Until k = 27 Or k = 13 +End Sub + +Sub CenteredText (Text$) + Dim tWidth As Integer, tHeight As Integer + + tWidth = _PrintWidth(Text$) + 20 + tHeight = FontHeight * 3 + + Line (_Width / 2 - tWidth / 2, _Height / 2 - tHeight / 2)-Step(tWidth - 1, tHeight - 1), _RGBA32(255, 255, 255, 200), BF + Color _RGB32(255, 255, 255), 0 + _PrintString (_Width / 2 - _PrintWidth(Text$) / 2 + 1, _Height / 2 - FontHeight / 2 + 1), Text$ + Color _RGB32(0, 0, 0), 0 + _PrintString (_Width / 2 - _PrintWidth(Text$) / 2, _Height / 2 - FontHeight / 2), Text$ +End Sub + +Sub StatusText (Text$) + Color _RGB32(0, 0, 0), _RGB32(255, 255, 255) + Cls + + _PrintString (_Width / 2 - _PrintWidth(Text$) / 2, _Height - FontHeight * 1.5), Text$ +End Sub + +Sub GameSetup + 'Acknowledgements: + '-------------------------------------------------------------------------------------------------------------------- + 'Light bulb images from https://blog.1000bulbs.com/home/flip-the-switch-how-an-incandescent-light-bulb-works + 'End level bg from http://blog-sap.com/analytics/2013/06/14/sap-lumira-new-software-update-general-availability-of-cloud-version-and-emeauk-flash-sale-at-bi2013/ + 'Ding sound: https://www.freesound.org/people/Flo_Rayen/sounds/191835/ + 'Bonus sound: http://freesound.org/people/LittleRobotSoundFactory/sounds/274183/ + 'Piano sound: https://www.freesound.org/people/FoolBoyMedia/sounds/352655/ + 'Switch sound: https://www.freesound.org/people/Mindloop/sounds/253659/ + 'App icon: http://www.iconarchive.com/show/small-n-flat-icons-by-paomedia/light-bulb-icon.html + 'Restart icon: http://www.iconarchive.com/show/windows-8-icons-by-icons8/Computer-Hardware-Restart-icon.html + 'Mouse cursor icon: http://www.iconarchive.com/show/windows-8-icons-by-icons8/Very-Basic-Cursor-icon.html + '-------------------------------------------------------------------------------------------------------------------- + + 'Load assets: + Arena = _NewImage(600, 600, 32) + + 'Arial = _LOADFONT("arial.ttf", 24) + LightOn(1) = loadImage("assets/lighton.png") + LightOn(2) = loadImage("assets/lighton300.png") + LightOn(3) = loadImage("assets/lighton120.png") + LightOn(4) = loadImage("assets/lighton86.png") + LightOn(5) = loadImage("assets/lighton67.png") + LightOn(6) = loadImage("assets/lighton60.png") + LightOn(7) = loadImage("assets/lighton55.png") + LightOn(8) = loadImage("assets/lighton35.png") + LightOn(9) = loadImage("assets/lighton30.png") + + LightOff(1) = loadImage("assets/lightoff.png") + LightOff(2) = loadImage("assets/lightoff300.png") + LightOff(3) = loadImage("assets/lightoff120.png") + LightOff(4) = loadImage("assets/lightoff86.png") + LightOff(5) = loadImage("assets/lightoff67.png") + LightOff(6) = loadImage("assets/lightoff60.png") + LightOff(7) = loadImage("assets/lightoff55.png") + LightOff(8) = loadImage("assets/lightoff35.png") + LightOff(9) = loadImage("assets/lightoff30.png") + + Bg = loadImage("assets/bg.jpg") + RestartIcon = loadImage("assets/restart.png") + MouseCursor = loadImage("assets/mouse.png") + + Ding = loadSound("assets/ding.wav") + Piano = loadSound("assets/piano.ogg") + Switch = loadSound("assets/switch.wav") + Bonus = loadSound("assets/bonus.wav") + + If isLoaded(Bg) Then _SetAlpha 30, , Bg + If Arial > 0 Then FontHeight = _FontHeight(Arial) Else FontHeight = 16 + + If Arial > 0 Then + _Font Arial + _Dest OverlayScreen + _Font Arial + _Dest 0 + End If + + 'Screen setup: + Screen _NewImage(600, 600 + FontHeight * 2, 32) + Do Until _ScreenExists: _Limit 30: Loop + _Title "Lights On" + Chr$(0) + + OverlayScreen = _NewImage(_Width / 2, _Height / 2, 32) + + 'Set buttons: + ReDim Button(1 To 5) As obj, Caption(1 To UBound(Button)) As String + + Dim b As Integer + b = b + 1: Caption(b) = "Try again" + Button(b).y = _Height / 2 + FontHeight * 11.5 + Button(b).w = _PrintWidth(Caption(b)) + 40 + Button(b).x = _Width / 2 - 10 - Button(b).w + Button(b).h = 40 + + b = b + 1: Caption(b) = "Next level" + Button(b).y = _Height / 2 + FontHeight * 11.5 + Button(b).w = _PrintWidth(Caption(b)) + 40 + Button(b).x = _Width / 2 + 10 + Button(b).h = 40 + + b = b + 1: Caption(b) = "Restart level" + If isLoaded(RestartIcon) Then + Button(b).w = _Width(RestartIcon) + 20 + Button(b).h = FontHeight * 2 + Button(b).x = _Width - Button(b).w - 10 + Button(b).y = _Height - FontHeight - Button(b).h / 2 + Else + Button(b).h = FontHeight * 2 + Button(b).w = _PrintWidth(Caption(b)) + 20 + Button(b).x = _Width - 10 - Button(b).w + Button(b).y = _Height - Button(b).h + End If + + b = b + 1: Caption(b) = "Yes" + Button(b).y = _Height / 2 - FontHeight / 2 + Button(b).w = _PrintWidth(Caption(b)) + 40 + Button(b).x = _Width / 2 - 10 - Button(b).w + Button(b).h = 40 + + b = b + 1: Caption(b) = "No" + Button(b).y = _Height / 2 - FontHeight / 2 + Button(b).w = _PrintWidth(Caption(b)) + 40 + Button(b).x = _Width / 2 + 10 + Button(b).h = 40 +End Sub + +Function loadImage& (file$) + Dim tempHandle& + + If _FileExists(file$) = 0 Then Exit Function + + tempHandle& = _LoadImage(file$, 32) + If tempHandle& = -1 Then 'load failed + tempHandle& = 0 + End If + + loadImage& = tempHandle& +End Function + +Function isLoaded%% (imgHandle&) + isLoaded%% = imgHandle& < -1 +End Function + +Sub SetLevel + If Not TryAgain Then Level = Level + 1 + + Dim LevelSettings As Integer + If Level <= 15 Then LevelSettings = Level Else LevelSettings = _Ceil(Rnd * 13) + 2 + + Select Case LevelSettings + Case 1 + maxGridW = 1 + maxGridH = 2 + MinMoves = 2 + lightID = 2 + Case 2 + maxGridW = 2 + maxGridH = 2 + MinMoves = 1 + lightID = 2 + Case 3, 4 + maxGridW = 4 + maxGridH = 5 + MinMoves = 11 + lightID = 3 + Case 5 + maxGridW = 5 + maxGridH = 7 + MinMoves = 65 + lightID = 4 + Case 6 + maxGridW = 10 + maxGridH = 10 + MinMoves = 65 + lightID = 6 + Case 7, 8 + maxGridW = 7 + maxGridH = 9 + MinMoves = 90 + lightID = 5 + Case 9, 10 + maxGridW = 7 + maxGridH = 11 + MinMoves = 130 + lightID = 7 + Case 11, 12 + maxGridW = 9 + maxGridH = 11 + MinMoves = 90 + lightID = 7 + Case 13, 14 + maxGridW = 11 + maxGridH = 17 + MinMoves = 180 + lightID = 8 + Case Else + maxGridW = 20 + maxGridH = 20 + MinMoves = 230 + lightID = 9 + End Select + + maxW = _Width(Arena) / maxGridW + maxH = _Height(Arena) / maxGridH + + For i = 1 To maxGridW + For j = 1 To maxGridH + lights(i, j).x = i * maxW - maxW + lights(i, j).y = j * maxH - maxH + lights(i, j).w = maxW - 1 + lights(i, j).h = maxH - 1 + lights(i, j).i = i + lights(i, j).j = j + lights(i, j).IsOn = false + Next + Next + + Dim rndState As Integer + For rndState = 1 To maxGridW / 3 + i = _Ceil(Rnd * maxGridW) + j = _Ceil(Rnd * maxGridH) + SetState lights(i, j) + Next + + start! = Timer + moves = 0 +End Sub + +Sub EndScreen + UpdateArena + _Dest 0 + _PutImage (0, 0), Arena + + Dim EndAnimationStep As Integer, FinalBonus As _Byte + Dim SlideOpen As Integer, SlideVelocity As Single + Dim Snd1 As _Byte, Snd2 As _Byte, Snd3 As _Byte + Dim FinalLamp1!, FinalLamp2!, FinalLamp3! + Dim SkipEndAnimation As _Byte + Dim BgXOffset As Single, BgYOffset As Single + Dim BgXSpeed As Single, BgYSpeed As Single + + Snd1 = false: Snd2 = false: Snd3 = false + FinalBonus = false + + If isLoaded(LightOn(3)) Then _SetAlpha 255, , LightOn(3) + + Alpha = 0 + TryAgain = false + EndAnimationStep = 1 + SkipEndAnimation = false + + BgXSpeed = .5 + BgYSpeed = .3 + If isLoaded(Bg) Then + BgXOffset = _Width(Bg) - _Width * 1.5 + BgYOffset = _Height(Bg) - _Height * 1.5 + End If + + p5play Piano + Do + While _MouseInput: Wend + + If EndAnimationStep < 70 Then + _Dest OverlayScreen + Cls , 0 + m$ = "Level" + Str$(Level) + " - All Lights On!" + Color _RGB32(0, 0, 0), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2 + 1, _Height / 2 - 80 - FontHeight + 1), m$ + Color _RGB32(255, 255, 255), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2, _Height / 2 - 80 - FontHeight), m$ + + m$ = "Moves used:" + Str$(moves) + Color _RGB32(0, 0, 0), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2 + 1, _Height / 2 + FontHeight * 2.5 + 1), m$ + Color _RGB32(255, 255, 255), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2, _Height / 2 + FontHeight * 2.5), m$ + + m$ = "Score:" + Str$(Score) + Color _RGB32(0, 0, 0), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2 + 1, _Height / 2 + FontHeight * 3.5 + 1), m$ + Color _RGB32(255, 255, 255), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2, _Height / 2 + FontHeight * 3.5), m$ + End If + + _Dest 0 + + BgXOffset = BgXOffset + BgXSpeed + BgYOffset = BgYOffset + BgYSpeed + If isLoaded(Bg) Then + If BgXOffset < 0 Or BgXOffset + _Width - 1 > _Width(Bg) Then BgXSpeed = BgXSpeed * -1 + If BgYOffset < 0 Or BgYOffset + _Height - 1 > _Height(Bg) Then BgYSpeed = BgYSpeed * -1 + _PutImage (0, 0)-Step(_Width - 1, _Height - 1), Bg, , (BgXOffset, BgYOffset)-Step(_Width - 1, _Height - 1) + End If + Select Case EndAnimationStep + Case 1 + If Alpha < 255 Then Alpha = Alpha + 10 Else EndAnimationStep = 2: SlideOpen = 0: SlideVelocity = 30: Alpha = 0 + If Not isLoaded(Bg) Then + Line (0, 0)-(_Width, _Height), _RGBA32(255, 255, 0, Alpha), BF + Line (0, 0)-(_Width, _Height), _RGBA32(255, 255, 255, Alpha), BF + End If + _PutImage , OverlayScreen + Case 2 + If Not isLoaded(Bg) Then Line (0, 0)-(_Width, _Height), _RGBA32(255, 255, 255, 30), BF + SlideVelocity = SlideVelocity - .2 + If SlideVelocity < 1 Then SlideVelocity = 1 + If SlideOpen < 600 Then + SlideOpen = SlideOpen + SlideVelocity + Else + SlideOpen = 600 + EndAnimationStep = 3 + i = _Width / 2 - (SlideOpen / 3.5) + j = _Height / 2 - SlideOpen / 5 + FontHeight * 1.5 + End If + + _PutImage , OverlayScreen + Dim b As Integer + b = map(SlideOpen, 0, 600, 255, 0) + Line (0, _Height / 2 - 125 + FontHeight * 1.5)-Step(SlideOpen, 130), _RGB32(255, 255, 255), BF + Line (0, _Height / 2 - 120 + FontHeight * 1.5)-Step(SlideOpen, 120), _RGB32(b * 1.5, b * 1.5 - 50, 0), BF + Case Is >= 3 + EndAnimationStep = EndAnimationStep + 1 + If Not isLoaded(Bg) Then Line (0, 0)-(_Width, _Height), _RGBA32(255, 255, 255, 40), BF + _PutImage , OverlayScreen + Line (0, _Height / 2 - 125 + FontHeight * 1.5)-Step(SlideOpen, 130), _RGB32(255, 255, 255), BF + Line (0, _Height / 2 - 120 + FontHeight * 1.5)-Step(SlideOpen, 120), _RGB32(b, b - 20, 0), BF + + If isLoaded(LightOff(3)) Then + _PutImage (i, j), LightOff(3) + _PutImage (i + SlideOpen / 5, j), LightOff(3) + _PutImage (i + (SlideOpen / 5) * 2, j), LightOff(3) + End If + + If EndAnimationStep >= 3 Then + If MinMoves <= MinMoves * 3 Then + If Snd1 = false Then p5play Ding: Snd1 = true + If EndAnimationStep = 4 Then FinalLamp1! = Timer: Score = Score + 20 + + If EndAnimationStep <= 20 Then + Score = Score + 10 + If Not SkipEndAnimation Then p5play Switch + End If + + If isLoaded(LightOn(3)) Then + _SetAlpha constrain(map(Timer - FinalLamp1!, 0, .3, 0, 255), 0, 255), , LightOn(3) + _PutImage (i, j), LightOn(3) + Else + Line (i, j)-Step(SlideOpen / 5, SlideOpen / 5), _RGB32(111, 227, 39), BF + Line (i, j)-Step(SlideOpen / 5, SlideOpen / 5), _RGB32(0, 0, 0), B + End If + End If + End If + + If EndAnimationStep > 20 Then + If moves <= MinMoves * 2 Then + If Snd2 = false Then p5play Ding: Snd2 = true + If EndAnimationStep = 21 Then FinalLamp2! = Timer: Score = Score + 20 + + If EndAnimationStep <= 40 Then + Score = Score + 10 + If Not SkipEndAnimation Then p5play Switch + End If + + If isLoaded(LightOn(3)) Then + _SetAlpha constrain(map(Timer - FinalLamp2!, 0, .3, 0, 255), 0, 255), , LightOn(3) + _PutImage (i + SlideOpen / 5, j), LightOn(3) + Else + Line (i + SlideOpen / 5, j)-Step(SlideOpen / 5, SlideOpen / 5), _RGB32(111, 227, 39), BF + Line (i + SlideOpen / 5, j)-Step(SlideOpen / 5, SlideOpen / 5), _RGB32(0, 0, 0), B + End If + End If + End If + + If EndAnimationStep > 40 Then + If moves <= MinMoves Then + If Snd3 = false Then p5play Ding: Snd3 = true + If EndAnimationStep = 41 Then FinalLamp3! = Timer: Score = Score + 20 + + If EndAnimationStep <= 60 Then + Score = Score + 10 + If Not SkipEndAnimation Then p5play Switch + End If + + If isLoaded(LightOn(3)) Then + _SetAlpha constrain(map(Timer - FinalLamp3!, 0, .3, 0, 255), 0, 255), , LightOn(3) + _PutImage (i + (SlideOpen / 5) * 2, j), LightOn(3) + Else + Line (i + (SlideOpen / 5) * 2, j)-Step(SlideOpen / 5, SlideOpen / 5), _RGB32(111, 227, 39), BF + Line (i + (SlideOpen / 5) * 2, j)-Step(SlideOpen / 5, SlideOpen / 5), _RGB32(0, 0, 0), B + End If + End If + End If + + If EndAnimationStep > 60 Then + If FinalBonus = false Then + FinalBonus = true + If moves < MinMoves Then + Score = Score + 50 + p5play Bonus + End If + Else + If moves < MinMoves Then + m$ = "Strategy master! +50 bonus points!" + Color _RGB32(0, 0, 0), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2 + 1, _Height / 2 + FontHeight * 9.5 + 1), m$ + Color _RGB32(255, 255, 255), 0 + _PrintString (_Width / 2 - _PrintWidth(m$) / 2, _Height / 2 + FontHeight * 9.5), m$ + End If + End If + End If + End Select + + 'Buttons + If EndAnimationStep > 60 Then + Dim ii As Integer + For ii = 1 To 2 + If Hovering(Button(ii)) Then + Line (Button(ii).x + 5, Button(ii).y + 5)-Step(Button(ii).w, Button(ii).h), _RGB32(0, 0, 0), BF + Line (Button(ii).x, Button(ii).y)-Step(Button(ii).w, Button(ii).h), _RGB32(255, 255, 255), BF + Else + Line (Button(ii).x, Button(ii).y)-Step(Button(ii).w, Button(ii).h), _RGBA32(255, 255, 255, 20), BF + End If + 'COLOR _RGB32(255, 255, 255), 0 + '_PRINTSTRING (Button(ii).x + Button(ii).w / 2 - _PRINTWIDTH(Caption(ii)) / 2 + 1, Button(ii).y + Button(ii).h / 2 - FontHeight / 2 + 1), Caption(ii) + Color _RGB32(0, 0, 0), 0 + _PrintString (Button(ii).x + Button(ii).w / 2 - _PrintWidth(Caption(ii)) / 2, Button(ii).y + Button(ii).h / 2 - FontHeight / 2), Caption(ii) + Next + End If + + _Display + + k = _KeyHit + + If k = 13 And EndAnimationStep > 60 Then Exit Do + If k = 27 Then System + + If _MouseButton(1) And EndAnimationStep > 60 Then + While _MouseButton(1): ii = _MouseInput: Wend + If Hovering(Button(1)) Then + TryAgain = true + Exit Do + ElseIf Hovering(Button(2)) Then + Exit Do + End If + ElseIf _MouseButton(1) Then + SkipEndAnimation = true + End If + + If Not SkipEndAnimation Then _Limit 30 + Loop +End Sub + +Sub UpdateArena + Dim imgWidth As Integer, imgHeight As Integer + Dim FoundHover As _Byte + + imgHeight = lights(1, 1).h + imgWidth = imgHeight + + _Dest Arena + Cls + For i = 1 To maxGridW + For j = 1 To maxGridH + If isLoaded(LightOff(lightID)) Then + _PutImage (lights(i, j).x + lights(i, j).w / 2 - imgWidth / 2, lights(i, j).y), LightOff(lightID) + End If + If lights(i, j).IsOn Then + If isLoaded(LightOn(lightID)) Then + If Timer - lights(i, j).lastSwitch < .3 Then + _SetAlpha constrain(map(Timer - lights(i, j).lastSwitch, 0, .3, 0, 255), 0, 255), , LightOn(lightID) + Else + _SetAlpha 255, , LightOn(lightID) + End If + _PutImage (lights(i, j).x + lights(i, j).w / 2 - imgWidth / 2, lights(i, j).y), LightOn(lightID) + Else + Line (lights(i, j).x, lights(i, j).y)-Step(lights(i, j).w, lights(i, j).h), _RGB32(111, 227, 39), BF + End If + End If + If Hovering(lights(i, j)) And FoundHover = false And TutorialMode = false Then + FoundHover = true + Line (lights(i, j).x, lights(i, j).y)-Step(lights(i, j).w, lights(i, j).h), _RGBA32(255, 255, 255, 100), BF + CheckState lights(i, j) + End If + Line (lights(i, j).x, lights(i, j).y)-Step(lights(i, j).w, lights(i, j).h), , B + Next + Next + _Dest 0 + _PutImage (0, 0), Arena +End Sub + +Sub UpdateScore + Dim seconds% + Color _RGB32(0, 0, 0), _RGB32(255, 255, 255) + Cls + + If Timer > start! Then + seconds% = Timer - start! + Else + seconds% = 86400 - start: start! = Timer + End If + + m$ = "Level:" + Str$(Level) + " (" + LTrim$(Str$(maxGridW)) + "x" + LTrim$(Str$(maxGridH)) + ") Moves:" + Str$(moves) + " Time elapsed:" + Str$(seconds%) + "s" + _PrintString (10, _Height - FontHeight * 1.5), m$ + + If Hovering(Button(3)) Then + Line (Button(3).x, Button(3).y)-Step(Button(3).w - 1, Button(3).h - 1), _RGB32(127, 127, 127), BF + If _MouseButton(1) Then + While _MouseButton(1): i = _MouseInput: Wend + If Hovering(Button(3)) Then + TryAgain = true: SetLevel + End If + End If + End If + + If isLoaded(RestartIcon) Then + _PutImage (Button(3).x + Button(3).w / 2 - _Width(RestartIcon) / 2, Button(3).y + Button(3).h / 2 - _Height(RestartIcon) / 2), RestartIcon + Else + Color _RGB32(0, 0, 0), 0 + _PrintString (Button(3).x + Button(3).w / 2 - _PrintWidth(Caption(3)) / 2, Button(3).y + Button(3).h / 2 - FontHeight / 2), Caption(3) + End If +End Sub + +Function Victory%% + Dim i As Integer, j As Integer + For i = 1 To maxGridW + For j = 1 To maxGridH + If lights(i, j).IsOn = false Then Exit Function + Next + Next + + Victory%% = true +End Function + +Sub CheckState (object As obj) + Dim i As Integer + + If _MouseButton(1) Then + While _MouseButton(1): i = _MouseInput: Wend + If Hovering(object) Then + p5play Switch + moves = moves + 1 + SetState object + End If + End If +End Sub + +Sub SetState (object As obj) + Dim ioff As Integer, joff As Integer + ioff = -1 + joff = 0 + If object.i + ioff > 0 And object.i + ioff < maxGridW + 1 And object.j + joff > 0 And object.j + joff < maxGridH + 1 Then + lights(object.i + ioff, object.j + joff).IsOn = Not lights(object.i + ioff, object.j + joff).IsOn + lights(object.i + ioff, object.j + joff).lastSwitch = Timer + End If + + ioff = 1 + joff = 0 + If object.i + ioff > 0 And object.i + ioff < maxGridW + 1 And object.j + joff > 0 And object.j + joff < maxGridH + 1 Then + lights(object.i + ioff, object.j + joff).IsOn = Not lights(object.i + ioff, object.j + joff).IsOn + lights(object.i + ioff, object.j + joff).lastSwitch = Timer + End If + + ioff = 0 + joff = -1 + If object.i + ioff > 0 And object.i + ioff < maxGridW + 1 And object.j + joff > 0 And object.j + joff < maxGridH + 1 Then + lights(object.i + ioff, object.j + joff).IsOn = Not lights(object.i + ioff, object.j + joff).IsOn + lights(object.i + ioff, object.j + joff).lastSwitch = Timer + End If + + ioff = 0 + joff = 1 + If object.i + ioff > 0 And object.i + ioff < maxGridW + 1 And object.j + joff > 0 And object.j + joff < maxGridH + 1 Then + lights(object.i + ioff, object.j + joff).IsOn = Not lights(object.i + ioff, object.j + joff).IsOn + lights(object.i + ioff, object.j + joff).lastSwitch = Timer + End If +End Sub + +Function Hovering%% (object As obj) + While _MouseInput: Wend + Hovering%% = _MouseX > object.x And _MouseX < object.x + object.w And _MouseY > object.y And _MouseY < object.y + object.h +End Function + +Sub MoveMouse (sx As Integer, sy As Integer, dx As Integer, dy As Integer) + Dim stepX As Single, stepY As Single + Dim i As _Byte + + Const maxSteps = 30 + + stepX = (dx - sx) / maxSteps + stepY = (dy - sy) / maxSteps + + For i = 1 To maxSteps + sx = sx + stepX + sy = sy + stepY + UpdateArena + _PutImage (sx, sy), MouseCursor + _Display + _Limit 30 + Next +End Sub + +Sub ShowTutorial + Dim i As Integer, j As Integer + Dim mx As Integer, my As Integer + Dim StepNumber As Integer, TotalSteps As Integer + + Level = 2 + SetLevel + TotalSteps = 5 + + StatusText "Tutorial Mode - Click to proceed" + UpdateArena + StepNumber = StepNumber + 1 + CenteredText "(" + LTrim$(Str$(StepNumber)) + "/" + LTrim$(Str$(TotalSteps)) + ") Your goal is to turn all light bulbs on." + + mx = 400 + my = 400 + _PutImage (mx, my), MouseCursor + + _Display + ClickPause + If k = 27 Then Level = 0: Exit Sub + + For i = 1 To maxGridW + For j = 1 To maxGridH + lights(i, j).IsOn = false + Next + Next + + UpdateArena + StepNumber = StepNumber + 1 + CenteredText "(" + LTrim$(Str$(StepNumber)) + "/" + LTrim$(Str$(TotalSteps)) + ") However, you can't simply switch a light bulb on or off directly." + + mx = 400 + my = 400 + _PutImage (mx, my), MouseCursor + + _Display + + ClickPause + If k = 27 Then Level = 0: Exit Sub + + UpdateArena + StepNumber = StepNumber + 1 + CenteredText "(" + LTrim$(Str$(StepNumber)) + "/" + LTrim$(Str$(TotalSteps)) + ") You click a light bulb to turn the surrounding ones on/off." + _PutImage (mx, my), MouseCursor + _Display + + ClickPause + If k = 27 Then Level = 0: Exit Sub + + MoveMouse mx, my, lights(2, 2).x + lights(2, 2).w / 2, lights(2, 2).y + lights(2, 2).h / 2 + SetState lights(2, 2) + p5play Switch + Do + UpdateArena + _PutImage (mx, my), MouseCursor + _Display + Loop Until Timer - lights(2, 1).lastSwitch > .3 + + UpdateArena + _PutImage (mx, my), MouseCursor + StepNumber = StepNumber + 1 + CenteredText "(" + LTrim$(Str$(StepNumber)) + "/" + LTrim$(Str$(TotalSteps)) + ") Continue until all light bulbs are on." + _Display + + ClickPause + If k = 27 Then Level = 0: Exit Sub + + MoveMouse mx, my, lights(3, 2).x + lights(3, 2).w / 2, lights(3, 2).y + lights(3, 2).h / 2 + SetState lights(3, 2) + p5play Switch + Do + UpdateArena + _PutImage (mx, my), MouseCursor + _Display + Loop Until Timer - lights(3, 1).lastSwitch > .3 + + UpdateArena + StepNumber = StepNumber + 1 + _PutImage (mx, my), MouseCursor + CenteredText "(" + LTrim$(Str$(StepNumber)) + "/" + LTrim$(Str$(TotalSteps)) + ") Simple right? Click to start." + _Display + + ClickPause + + Level = 0 + Exit Sub +End Sub + +'functions below are borrowed from p5js.bas: +Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!) + map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange! +End Function + +Function min! (a!, b!) + If a! < b! Then min! = a! Else min! = b! +End Function + +Function max! (a!, b!) + If a! > b! Then max! = a! Else max! = b! +End Function + +Function constrain! (n!, low!, high!) + constrain! = max(min(n!, high!), low!) +End Function + +Function loadSound& (file$) + If _FileExists(file$) = 0 Then Exit Function + Dim tempHandle&, setting$ + Static totalLoadedSounds As Long + + setting$ = "vol" + + Select Case UCase$(Right$(file$, 4)) + Case ".WAV", ".OGG", ".AIF", ".RIF", ".VOC" + setting$ = "vol,sync,len,pause" + Case ".MP3" + setting$ = "vol,pause,setpos" + End Select + + tempHandle& = _SndOpen(file$, setting$) + If tempHandle& > 0 Then + totalLoadedSounds = totalLoadedSounds + 1 + ReDim _Preserve loadedSounds(totalLoadedSounds) As new_SoundHandle + loadedSounds(totalLoadedSounds).handle = tempHandle& + loadedSounds(totalLoadedSounds).sync = InStr(setting$, "sync") > 0 + loadSound& = tempHandle& + End If +End Function + +Sub p5play (soundHandle&) + Dim i As Long + For i = 1 To UBound(loadedSounds) + If loadedSounds(i).handle = soundHandle& Then + If loadedSounds(i).sync Then + _SndPlayCopy soundHandle& + Else + If Not _SndPlaying(soundHandle&) Then _SndPlay soundHandle& + End If + End If + Next +End Sub + diff --git a/samples/lightson/src/lightson.zip b/samples/lightson/src/lightson.zip new file mode 100644 index 00000000..828f0022 Binary files /dev/null and b/samples/lightson/src/lightson.zip differ diff --git a/samples/lissajous-curve-table/index.md b/samples/lissajous-curve-table/index.md index f2aa13b0..75f2c6f8 100644 --- a/samples/lissajous-curve-table/index.md +++ b/samples/lissajous-curve-table/index.md @@ -6,7 +6,7 @@ ### Author -[🐝 FellippeHeitor](../fellippeheitor.md) +[🐝 Fellippe Heitor](../fellippe-heitor.md) ### Description diff --git a/samples/lorenz-attractor/index.md b/samples/lorenz-attractor/index.md index 7a8d6f93..a67c75cd 100644 --- a/samples/lorenz-attractor/index.md +++ b/samples/lorenz-attractor/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: ROTATING LORENZ ATTRACTOR +## SAMPLE: LORENZ ATTRACTOR ![screenshot.png](img/screenshot.png) diff --git a/samples/lorenz.md b/samples/lorenz.md index 82d5c7e4..b62a86eb 100644 --- a/samples/lorenz.md +++ b/samples/lorenz.md @@ -2,7 +2,7 @@ ## SAMPLES: LORENZ -**[Rotating Lorenz Attractor](lorenz-attractor/index.md)** +**[Lorenz Attractor](lorenz-attractor/index.md)** [🐝 Vince](vince.md) 🔗 [lorenz](lorenz.md), [rotations](rotations.md) diff --git a/samples/manadla/index.md b/samples/manadla/index.md index 98f11558..6da29a26 100644 --- a/samples/manadla/index.md +++ b/samples/manadla/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: MANDALA 9 LINE +## SAMPLE: MANADLA ![screenshot.png](img/screenshot.png) diff --git a/samples/mandelbrot-set-2003/index.md b/samples/mandelbrot-set-2003/index.md index 2f0e5f39..b1396b01 100644 --- a/samples/mandelbrot-set-2003/index.md +++ b/samples/mandelbrot-set-2003/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: MANDELBROT +## SAMPLE: MANDELBROT SET 2003 ![screenshot.png](img/screenshot.png) diff --git a/samples/mandelbrot-set-2008/index.md b/samples/mandelbrot-set-2008/index.md index a3279aa4..68c36203 100644 --- a/samples/mandelbrot-set-2008/index.md +++ b/samples/mandelbrot-set-2008/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: MANDELBROT SET +## SAMPLE: MANDELBROT SET 2008 ![qbguymandel.png](img/qbguymandel.png) diff --git a/samples/mandelbrot-zoomer/index.md b/samples/mandelbrot-zoomer/index.md index addf5ff5..844499df 100644 --- a/samples/mandelbrot-zoomer/index.md +++ b/samples/mandelbrot-zoomer/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: TOR MYKLEBUST +## SAMPLE: MANDELBROT ZOOMER ![screenshot.png](img/screenshot.png) diff --git a/samples/mandelbrot.md b/samples/mandelbrot.md index ddcdfcf5..eac25622 100644 --- a/samples/mandelbrot.md +++ b/samples/mandelbrot.md @@ -8,19 +8,19 @@ Mandelbrot animator. -**[Mandelbrot](mandelbrot-set-2003/index.md)** +**[Mandelbrot Set 2003](mandelbrot-set-2003/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md), [9 lines](9-lines.md) 'MANDELBROT by Antoni Gual 2003 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-----------... -**[Mandelbrot Set](mandelbrot-set-2008/index.md)** +**[Mandelbrot Set 2008](mandelbrot-set-2008/index.md)** [🐝 qbguy](qbguy.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) public domain, uses qb64's 2d prototype -**[Tor Myklebust](mandelbrot-zoomer/index.md)** +**[Mandelbrot Zoomer](mandelbrot-zoomer/index.md)** [🐝 *missing*](author-missing.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) diff --git a/samples/matthew.md b/samples/matthew.md index 2a97682d..be737114 100644 --- a/samples/matthew.md +++ b/samples/matthew.md @@ -2,7 +2,7 @@ ## SAMPLES BY MATTHEW -**[4 Player Pong](four-player-pong/index.md)** +**[Four Player Pong](four-player-pong/index.md)** [🐝 Matthew](matthew.md) 🔗 [game](game.md), [pong](pong.md) diff --git a/samples/maze.md b/samples/maze.md new file mode 100644 index 00000000..a2ec31d9 --- /dev/null +++ b/samples/maze.md @@ -0,0 +1,15 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: MAZE + +**[Mazes of Misery](mazes-of-misery/index.md)** + +[🐝 Steve M.](steve-m..md) 🔗 [game](game.md), [maze](maze.md) + +'Maze of Misery 'By Steve M. (c),May 5,01 '**************** 'Please visit my web page at: www.a... + +**[QMaze](qmaze/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [maze](maze.md) + +Maze puzzle game by Microsoft. diff --git a/samples/mazes-of-misery/img/screenshot.png b/samples/mazes-of-misery/img/screenshot.png new file mode 100644 index 00000000..4996e8b8 Binary files /dev/null and b/samples/mazes-of-misery/img/screenshot.png differ diff --git a/samples/mazes-of-misery/index.md b/samples/mazes-of-misery/index.md new file mode 100644 index 00000000..28b5a8de --- /dev/null +++ b/samples/mazes-of-misery/index.md @@ -0,0 +1,36 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: MAZES OF MISERY + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Steve M.](../steve-m..md) + +### Description + +```text +'Maze of Misery +'By Steve M. (c),May 5,01 +'**************** + +'Please visit my web page at: www.angelfire.com/bc2/cuebasic/qpage.html +' +'Disclaimer: This program may not be distributed, modified or copied without +'written permission from the author at yochatwitme@yahoo.com. +'Not liable for system or hardware damage. Tho' I can assure you that you +'won't experience any problems. Email me at yochatwitme@yahoo.com about +'any concerns or difficulties you may be having. +'Finally, you have my permission to post the program on your web page. +'Hope you enjoy the game. +' +'Thanks. SM :) +'Gbgames Chatname: QB4ever +``` + +### File(s) + +* [mzupd2.bas](src/mzupd2.bas) + +🔗 [game](../game.md), [maze](../maze.md) diff --git a/samples/mazes-of-misery/src/mzupd2.bas b/samples/mazes-of-misery/src/mzupd2.bas new file mode 100644 index 00000000..98f53067 --- /dev/null +++ b/samples/mazes-of-misery/src/mzupd2.bas @@ -0,0 +1,1922 @@ +'Maze of Misery +'By Steve M. (c),May 5,01 +'**************** + +'Please visit my web page at: www.angelfire.com/bc2/cuebasic/qpage.html +' +'Disclaimer: This program may not be distributed, modified or copied without +'written permission from the author at yochatwitme@yahoo.com. +'Not liable for system or hardware damage. Tho' I can assure you that you +'won't experience any problems. Email me at yochatwitme@yahoo.com about +'any concerns or difficulties you may be having. +'Finally, you have my permission to post the program on your web page. +'Hope you enjoy the game. +' +'Thanks. SM :) +'Gbgames Chatname: QB4ever + +$NoPrefix +$Resize:Smooth + +Const FALSE = 0, TRUE = Not FALSE + +'CLEAR 2000, 2000 +Dim T$(150), Wall%(1 To 300), Wall2%(1 To 300), Wall3%(1 To 300) +Dim Shared Player%(1 To 300), Maze$(768), Object$(20), Door%(1 To 300) +Dim EDoor%(1 To 300), Keylock%(1 To 300), Clrobject%(1 To 300) +'Dim Gold%(1 To 300) +Dim Treasure%(1 To 300), Diamond%(1 To 300) +'Dim Enemy%(1 To 300) +Dim Diamond2%(1 To 300), Gem%(1 To 300) +'Dim Enemydotpos(16) +Dim Spider%(1 To 300), Spider2%(1 To 300) +Dim Spike%(1 To 300), Spikemask%(1 To 300), Wallmask%(1 To 300) +Dim Web%(1 To 300), Wcs(64, 1), Keyfl(64), Clrkey(64) +Dim Spiderfr2%(1 To 300), Spiderpfr2%(1 To 300), Playerdeath%(1 To 300) +'Dim Shared Reptxt%(1 To 3000) + +Start: +X = 154: Y = 40: MatrixY = 14: MatrixX = 6: Lives = 5: Health = 9000 +En = 1: Dx = -30: Lx = -1: Dy = 1: SpacerX = 0: SpacerY = 0: EVL = 11 +CIX1 = 275: CIY1 = 145: CIY2 = 90: Rm = 2: Web = 20: Glow = 1: Adv = 0 +M2 = -1: V2x = 1: G = 1 +Health$ = "Good": M1$ = "Mazes of Misery": Time$ = "00:00:00" +T$ = Chr$(0) + Chr$(63) + Chr$(48) + Chr$(48) + Chr$(60) + Chr$(48) + Chr$(48) + Chr$(48) + Chr$(0) +Restore Wallcols: For A = 1 To 64: Read Wcs(A, 0): Next +Restore Wallbord: For A = 1 To 64: Read Wcs(A, 1): Next + +BegindotMaze: + +'Setup array picture images + +Screen 12 +FullScreen SquarePixels , Smooth + +Randomize Timer +GoSub Copydotwall: GoSub Cleardotplayer +GoSub Copydotwall2: GoSub Cleardotplayer +GoSub Copydotwall3: GoSub Cleardotplayer +GoSub CopydotPlayer: GoSub Cleardotplayer +GoSub CopydotCleardotObject 'This array clears the current image +GoSub CopydotDoor: GoSub Cleardotplayer +GoSub CopydotKeylock: GoSub Cleardotplayer +GoSub CopydotTreasure: GoSub Cleardotplayer +GoSub CopydotRing: GoSub Cleardotplayer +GoSub CopydotRing2: GoSub Cleardotplayer +GoSub CopydotGem: GoSub Cleardotplayer +GoSub CopydotSpider: GoSub Cleardotplayer +GoSub CopydotSpider2: GoSub Cleardotplayer +GoSub CopydotWeb: GoSub Cleardotplayer +GoSub CopydotSpike: GoSub Cleardotplayer +SpacerX = 0: SpacerY = 0: GoSub Titledotscr +Begin: +frm = 1: Screen 12: Cls: GoSub Builddotmazes +SpacerX = 0: SpacerY = 0: GoSub RoomdotCheck: GoSub Gamedotstatus +r = StartdotA: SpacerX = 0: SpacerY = 0 + +Kyboard: +Do: Loop While Timer = oldtimer! +oldtimer! = Timer +For i = 1 To 100 + GoSub Scandotmaze +Next +T$ = Mid$(Maze$(MatrixY), MatrixX, 1) +If T$ = "L" And (CT >= 1 And CT <= 20) Then GoSub Shocked +i$ = InKey$: If i$ = "" Then GoTo Kyboard + +Oldx = X: Oldy = Y: Matrixydotold = MatrixY: Matrixxdotold = MatrixX +If Kytapfl < 1 Then + If i$ = Chr$(0) + "M" Then GoSub Cleardotman: X = X + 30: MatrixX = MatrixX + 1: If X > 574 Then X = 4: Rm = Rm + 8: MatrixY = MatrixY + 96: MatrixX = 1: GoSub RoomdotCheck + If i$ = Chr$(0) + "K" Then GoSub Cleardotman: X = X - 30: MatrixX = MatrixX - 1: If X < 4 Then X = 574: Rm = Rm - 8: MatrixY = MatrixY - 96: MatrixX = 20: GoSub RoomdotCheck + If i$ = Chr$(0) + "H" Then GoSub Cleardotman: Y = Y - 36: MatrixY = MatrixY - 1: If Y < 4 Then Rm = Rm - 1: GoSub RoomdotCheck + If i$ = Chr$(0) + "P" Then GoSub Cleardotman: Y = Y + 36: MatrixY = MatrixY + 1: If Y > 400 Then Rm = Rm + 1: GoSub RoomdotCheck +Else + If i$ = "6" Then GoSub Cleardotman: X = X + 30: MatrixX = MatrixX + 1: If X > 574 Then X = 4: Rm = Rm + 8: MatrixY = MatrixY + 96: MatrixX = 1: GoSub RoomdotCheck + If i$ = "4" Then GoSub Cleardotman: X = X - 30: MatrixX = MatrixX - 1: If X < 4 Then X = 574: Rm = Rm - 8: MatrixY = MatrixY - 96: MatrixX = 20: GoSub RoomdotCheck + If i$ = "8" Then GoSub Cleardotman: Y = Y - 36: MatrixY = MatrixY - 1: If Y < 4 Then Rm = Rm - 1: GoSub RoomdotCheck + If i$ = "2" Then GoSub Cleardotman: Y = Y + 36: MatrixY = MatrixY + 1: If Y > 400 Then Rm = Rm + 1: GoSub RoomdotCheck +End If +If i$ = Chr$(27) Then i$ = "": GoSub Menulist +T$ = Mid$(Maze$(MatrixY), MatrixX, 1) +If T$ = "#" Or T$ = "@" Or T$ = "%" Or T$ = "W" Then GoSub Recalldotolddotposition +If T$ = "B" And M > 11 Then GoSub Spiderdotbite +If T$ = "L" And (CT >= 1 And CT <= 20) Then GoSub Shocked +If T$ = "k" Then GoSub Keyfound +If T$ = "E" Then GoTo Escaped +If T$ = "D" Then Sx = X: Sy = Y: Svsx = Sx: Svsy = Sy: SMy = MatrixY: SMx = MatrixX: GoSub Recalldotolddotposition: GoSub Doordotroutine +If T$ = "t" Then GoSub Treasuredotroutine +If T$ = "g" Then GoSub Gemdotroutine +If T$ = "r" Then GoSub Ringdotroutine +If Flg Then GmdotTmr = Timer: DelTim = CPU * 15 + Sqr(2 / 2 + GmdotTmr + .6) + 800: For LL = 1 To DelTim: Next +If frm > 100 Then frm = 1 +GoSub Displaydotman +GoTo Kyboard + +Scandotmaze: +B = B + 1 +T$ = Mid$(Maze$(r), B, 1): SPK$ = Mid$(Maze$(r), B, 1) +GoSub SkipdotX: Cnt = Cnt + 1 +If T$ = "B" Or T$ = "S" Then Spx = SpacerX: Spy = SpacerY: GoSub Spiderdotroutine +If T$ = "L" Then Lex = SpacerX: Ley = SpacerY: GoSub Electricdotroutine +If T$ = "r" Then RingdotX = SpacerX: RingdotY = SpacerY + 6: GoSub Ringdotglow +If SPK$ = "s" Then SpikeX = SpacerX: SpikeY = SpacerY + 6: GoSub SpikedotMoving +If B < 20 Then Return +B = 1: SpacerX = 0: SpacerY = SpacerY + 36 +If r < FinishdotA Then r = r + 1: Return +r = StartdotA: SpacerX = 0: SpacerY = 0 +Return + +SkipdotX: +SpacerX = SpacerX + 30 +Return + +Spiderdotroutine: +frm = frm + 1 +If (T$ = "S") Then Poisondotspider = 1 +T$ = Mid$(Maze$(MatrixY), MatrixX, 1) +If Demo Then T$ = Mid$(A$(Dmx), Dmy, 1) +If (T$ = "B" Or T$ = "S") And M > 11 Then GoSub Spiderdotbite +If T$ = "s" And M2 < 8 Then GoSub Spikedotstabb +M = M + Vx: If M > 31 Then Vx = -1 +GoSub Showdotspider +If M < 1 Then Vx = 1 +Line (Spx + 12, (Spy - Web))-(Spx + 12, (Spy - 10) + M), 8, BF +For H = 1 To 800 - Adv + DelTim: Next +Return + +SpikedotMoving: +SPK$ = Mid$(Maze$(r), B, 1) +M2 = M2 + V2x: If M2 > 25 Then V2x = -1 +If M2 < 1 Then V2x = 1 +If Wm < 1 Then Get (SpikeX, SpikeY + 36)-(SpikeX + 26, SpikeY + 71), Spikemask%(): Wm = 1 +Put (SpikeX, (SpikeY) + 11 + M2), Spike%(), PSet +If Wm2 < 1 Then Get (SpikeX, SpikeY + 5 + M2)-(SpikeX + 18, SpikeY + 36 + M2), Wallmask%(): Wm2 = 1 +If T$ = "s" Then GoSub Displaydotman +Put (SpikeX, SpikeY + 5 + M2), Wallmask%(), And 'spike mask +Put (SpikeX, SpikeY + 36), Spikemask%(), PSet 'wall mask +Return + +Showdotspider: +If Poisondotspider Then + If Int(frm / 2) = frm / 2 Then + Put (Spx - 1, (Spy - 30) + 10 + M), Spiderpfr2%(), PSet: Poisondotspider = 0: Return + Else + Put (Spx - 1, (Spy - 30) + 10 + M), Spider2%(), PSet: Poisondotspider = 0: Return + End If + +Else + If Int(frm / 4) = frm / 4 Then + Put (Spx - 1, (Spy - 30) + 10 + M), Spiderfr2%(), PSet: Return + Else + Put (Spx - 1, (Spy - 30) + 10 + M), Spider%(), PSet + End If +End If +Return + +Showdotspike: +Put (SpikeX, SpikeY + M2), Spike%(), PSet +Return + +Electricdotroutine: +CT = CT + 1: If CT >= 1 And CT <= 20 Then GoTo EStart +If CT > 50 Then CT = 1 +Return + +EStart: +Randomize Timer +If G < 1 Then Gv = 1 +G = G + Gv: If G > 5 Then Gv = -1 +E1 = Rnd(6 * Rnd(0)): E2 = Rnd(6 * Rnd(0)): E3 = Fix(Rnd(6 * Rnd(0))) +E4 = Fix(6 * Rnd(0)): E5 = Fix(6 * Rnd(0)): E6 = Fix(Rnd(6 * Rnd(0))) +E7 = Fix(6 * Rnd(0)): E8 = Fix(6 * Rnd(0)): E9 = Fix(Rnd(6 * Rnd(0))) +Line (Lex + E1, Ley + 4)-(Lex + E2 * (G + 3), Ley + 9), 14 +Line -(Lex + E3 + Sgn(G + 3), Ley + 15), 14 +Line -(Lex + E4 * (G + 3), Ley + 20), 14 +Line -(Lex + E5 + Sgn(G + 3), Ley + 26), 14 +Line -(Lex + E6 * (G + 3), Ley + 32), 14 +Line -(Lex + E7 + Sgn(G + 3), Ley + 38), 14 +For H = 1 To 150 - Adv / 4: Next +Sx = SpacerX + 2: Sy = SpacerY + 4: GoSub Cleardotarea +Return + +Spiderdotbite: +GoSub Displaydotman: M$ = "Yow! I've been bitten!": PS = 40 - Len(M$) / 2 +Locate 30, PS: Print M$;: GoSub Hold: GoSub Clearline +Put (X, Y), Playerdeath%(), PSet: Sleep 1: Put (X, Y), Clrobject%(), PSet +Health = Health - Abs(75 * (T$ = "S") - 55) +If Health < 1 Then Locate 30, PS + 4: Print "You died!";: Sleep 2: GoSub Clearline: GoTo Fin +GoSub Gamedotstatus +Return + +Spikedotstabb: +GoSub Displaydotman: M$ = "Yarrgghh! I've been sheared!": PS = 40 - Len(M$) / 2 +Locate 30, PS: Print M$;: GoSub Hold: GoSub Clearline +Put (X, Y), Playerdeath%(), PSet: Sleep 1: Put (X, Y), Clrobject%(), PSet +Health = Health - Abs(75 * (T$ = "S") - 55) +If Health < 1 Then Locate 30, PS + 4: Print "You died!";: Sleep 2: GoSub Clearline: GoTo Fin +GoSub Gamedotstatus +Return + +Shocked: +GoSub Displaydotman: M$ = "Arrggghh! I've been shocked!": PS = 40 - Len(M$) / 2 +Locate 30, PS: Print M$;: GoSub Hold: GoSub Clearline +Put (X, Y), Playerdeath%(), PSet: Sleep 1: Put (X, Y), Clrobject%(), PSet +Health = Health - 25 +If Health < 1 Then Locate 30, 30: Print "You died!";: Sleep 2: GoSub Clearline: GoTo Fin +GoSub Gamedotstatus +Return + +Treasuredotroutine: +GoSub Replacedotchar: GoSub Openeddotchest +Return + +Ringdotroutine: +Locate 30, 20: Print "You have found a diamond ring!";: GoSub Displaydotman +Sleep 2: GoSub Replacedotchar: GoSub Clearline: GoSub Cleardotarea +Fortune = 200: GoSub Tallydotpnts: GoSub Gamedotstatus +Return + +Gemdotroutine: +Locate 30, 20: Print "You have found a valuable gem!!";: GoSub Displaydotman +Sleep 2: GoSub Replacedotchar: GoSub Clearline: GoSub Cleardotarea +Fortune = 400: GoSub Tallydotpnts: GoSub Gamedotstatus +Return + +Ringdotglow: +If Glow Then Put (RingdotX, RingdotY), Diamond2%(), PSet: Glow = 0 +If Right$(Time$, 2) < "01" Then Return +Glow = 1 +If Glow Then Put (RingdotX, RingdotY), Diamond%(), PSet: Glow = 0 +If Right$(Time$, 2) < "02" Then Return +Time$ = "00:00:00": Glow = 1 +Return + +Replacedotchar: +If T$ = "D" Then Sx = Svsx: Sy = Svsy: GoSub Cleardotarea +Showy = SMy: Showx = SMx +Sx = X: Sy = Y: SMy = MatrixY: SMx = MatrixX +If (T$ <> "r" And T$ <> "g") Then GoSub Recalldotolddotposition: GoSub Displaydotman +If T$ = "D" Then SMy = Showy: SMx = Showx +Mid$(Maze$(SMy), SMx, 1) = Chr$(32) +Return + +Displaydotman: +Put (X, Y), Player%(), PSet: Return + +Recalldotolddotposition: +X = Oldx: Y = Oldy: For A = 1 To 64 + Barrier = 1 * (T$ = "D" And Unl And Rm = A And Keyfl(Rm)) + If Barrier Then A = 1: Return +Next + +Oldpl: +MatrixX = Matrixxdotold: MatrixY = Matrixydotold +Return + +Keyfound: +For A = 1 To 64 + Keyfl(Rm) = Abs(1 * (Rm = A)): Unl = 1 + If Keyfl(Rm) And Unl Then A = 1: GoTo Keymes +Next + +Keymes: +Color 15: Locate 30, 9: Print "You have found the key. "; +Print "Use it to unlock the door in this room.";: +GoSub Replacedotchar: GoSub Cleardotarea +Sleep 3: GoSub Clearline: Keys = Keys + 1: GoSub Gamedotstatus: Return + +Doordotroutine: +For A = 1 To 64 + Kyfd = 1 * (Rm = A And Keyfl(Rm)): If Kyfd Then A = 1: GoTo Available +Next: Return + +Available: +For A = 1 To 64 + Clrkey = 1 * (Rm = A And Keyfl(Rm)): If Clrkey > 0 Then Keyfl(Rm) = 0: A = 1: GoTo DOpen +Next + +DOpen: +GoSub Displaydotman +Locate 30, 20: Print "Good Job! You have opened the door.";: Sleep 3: +GoSub Clearline: GoSub Replacedotchar: Unl = 0 +Keys = Keys - 1: GoSub Gamedotstatus +Return + +Openeddotchest: +Color 14: Tr = 1: Locate 29, 1: Print Space$(79); +Locate 30, 20: Print "You have found a treasure chest!"; +Sleep 2: GoSub Clearline +Randomize Timer: Length = Fix(16 * Rnd(1)) + 1: Restore Makedotobj +N = Fix(50 * Rnd(1)) + 2 +For T = 1 To Length: Read Object$(T): Next +L = Len(Object$(Length)): O$ = Mid$(Object$(Length), 3, L) +If Left$(O$, 2) = "No" Or Left$(O$, 3) = "Wat" Then + Message$ = "" +Else + Message$ = "a " +End If + +Locate 30, 20: Print "It contains "; Message$; ""; O$; Space$(2); addon$; +Sleep 2: GoSub ObjectdotProperties: Message$ = "": addon$ = "" +O$ = "": Message$ = O$ +If LO$ = "~" Then GoSub Clearline: Locate 30, 20: Print "There are " + Str$(N) + " of them.";: Sleep 2 +GoSub Gamedotstatus: Tr = 0: addon$ = "": GoSub Clearline: GoSub Cleardotarea +Return + +Clearline: +Locate 30, 1: Print Space$(79);: Return + +Hold: +H$ = InKey$: If H$ = "" Then GoTo Hold +Return + +Escaped: +Color 15 +Line (110, 190)-(510, 255), 10, BF: Line (115, 200)-(500, 245), 14, BF +Line (115, 200)-(500, 245), 1, B +Locate 14, 25: Print "Congratulations Adventurer!" +Locate 15, 19: Print "You have escaped from this maze for now.": Sleep 4: System + +'CopydotPlayer: +Line (CIX1 + 15, CIY1 + 23)-(CIX1 + 37, CIY1 + 45), 0, BF +Circle (CIX1 + 28, CIY1 + 35), 10, 15: Paint (CIX1 + 28, CIY1 + 35), 15 +Circle (CIX1 + 28, CIY1 + 35), 10, 6: Circle (CIX1 + 28, CIY1 + 35), 9, 6 +For E = 1 To 5: Circle (CIX1 + 28, CIY1 + 35), E, 0: Next +Circle (CIX1 + 28, CIY1 + 35), 1, 0 +Get (CIX1 + 15, CIY1 + 23)-(CIX1 + 37, CIY1 + 45), Player%() +Return + +CopydotPlayer: +X1 = 20: Y1 = 40: c = 1 +Circle (X1, Y1), 9, 6: Paint (X1, Y1), 6: Circle (X1, Y1), 10, 4 'Body +Circle (X1 - 5, Y1 - 5), 3, 15: Paint (X1 - 5, Y1 - 5), 15 'left eye +Circle (X1 - 5, Y1 - 5), 3, c, -6.28, -3.14: Paint (X1 - 5, Y1 - 6), c +Circle (X1 - 5, Y1 - 5), 1, 0: Paint (X1 - 5, Y1 - 5), 0 'outline +Circle (X1 + 5, Y1 - 5), 3, 15: Paint (X1 + 5, Y1 - 5), 15 'right eye +Circle (X1 + 5, Y1 - 5), 3, c, -6.28, -3.14: Paint (X1 + 5, Y1 - 6), c +Circle (X1 + 5, Y1 - 5), 1, 0: Paint (X1 + 5, Y1 - 5), 0 +Circle (X1, Y1), 2, 4: Paint (X1, Y1), 4: Circle (X1, Y1), 3, 1 'nose +Line (X1 - 2, Y1 + 5)-(X1 + 2, Y1 + 5), 5 'mouth(top) +Line (X1 - 1, Y1 + 6)-(X1 + 1, Y1 + 6), 5 'mouth(bottom) +Get (X1 - 10, Y1 - 10)-(X1 + 10, Y1 + 10), Player%() +GoSub CopydotPlayerdeath +Return + +CopydotPlayerdeath: +X1 = 20: Y1 = 40: c = 4 +Circle (X1, Y1), 9, 6: Paint (X1, Y1), 6: Circle (X1, Y1), 10, 4 'Body +Circle (X1 - 5, Y1 - 5), 5, 15: Paint (X1 - 5, Y1 - 5), 15 'left eye +Circle (X1 - 5, Y1 - 5), 1, 0: Paint (X1 - 5, Y1 - 5), 0 'outline +Circle (X1 + 5, Y1 - 5), 5, 15: Paint (X1 + 5, Y1 - 5), 15 'right eye +Circle (X1 + 5, Y1 - 5), 1, 0: Paint (X1 + 5, Y1 - 5), 0 +Circle (X1, Y1), 2, 4: Paint (X1, Y1), 4: Circle (X1, Y1), 3, 1 'nose +Line (X1 - 2, Y1 + 5)-(X1 + 2, Y1 + 5), 5 'mouth(top) +Line (X1 - 1, Y1 + 6)-(X1 + 1, Y1 + 6), 5 'mouth(bottom) +Circle (X1, Y1 + 6), 2, c, , , .32: Paint (X1, Y1 + 6), c +Circle (X1, Y1 + 6), 3, 1, , , .32 +Get (X1 - 10, Y1 - 10)-(X1 + 10, Y1 + 10), Playerdeath%() +Return + +Copydotwall: +Line (CIX1 + 11, CIY1 + 21)-(CIX1 + 34, CIY1 + 50), Wcs(Rm, 0), BF +Line (CIX1 + 12, CIY1 + 20)-(CIX1 + 35, CIY1 + 51), Wcs(Rm, 1), B +Line (CIX1 + 36, CIY1 + 20)-(CIX1 + 36, CIY1 + 50), 10 +For A = CIX1 + 12 To CIX1 + 34 Step 2: Line (A, CIY1 + 21)-(A, CIY1 + 50), 6 +Next: Line (CIX1 + 11, CIY1 + 50)-(CIX1 + 34, CIY1 + 50), 1 +Line (CIX1 + 11, CIY1 + 21)-(CIX1 + 11, CIY1 + 50), 8 +'FOR A = CIY1 + 11 TO CIY1 + 50 STEP 2: LINE (CIX1 + 11, A)-(CIX1 + 35, A), 5: NEXT +Get (CIX1 + 11, CIY1 + 19)-(CIX1 + 36, CIY1 + 51), Wall%() +Return + +Copydotwall2: +Line (CIX1 + 11, CIY1 + 20)-(CIX1 + 34, CIY1 + 50), Wcs(Rm, 0), BF +Line (CIX1 + 12, CIY1 + 19)-(CIX1 + 35, CIY1 + 51), Wcs(Rm, 1), B +Line (CIX1 + 36, CIY1 + 19)-(CIX1 + 36, CIY1 + 50), 10 +For A = 0 To 41 Step 2 +Line (CIX1 + 11, CIY1 + 20 + A)-(CIX1 + 33, CIY1 + A), 1: Next +Get (CIX1 + 11, CIY1 + 19)-(CIX1 + 42, CIY1 + 51), Wall2%() +Return + +Copydotwall3: +WX = 26: WY = 32 +Line (100, 75)-(100 + WX, 75 + WY), , B +T$ = T$ + Chr$(200) + Chr$(130) + Chr$(146) + Chr$(48) + Chr$(8) + Chr$(2) + Chr$(144) + Chr$(152) + Chr$(2) +Paint (102, 76), T$ +Line (100, 75)-(100 + WX, 75 + WY), 4, B +Get (100, 75)-(100 + WX, 75 + WY), Wall3%() +Return + +CopydotCleardotObject: +Line (CIX1 + 16, CIY1 + 50)-(CIX1 + 60, CIY1 + 80), 0, BF +Get (265, CIY1 + 20)-(290, CIY1 + 54), Clrobject%() +Return + +CopydotDoor: +Line (CIX1 + 11, CIY1 + 20)-(CIX1 + 36, CIY1 + 52), 6, BF +Line (CIX1 + 13, CIY1 + 22)-(CIX1 + 33, CIY1 + 31), 12, BF +Line (CIX1 + 13, CIY1 + 40)-(CIX1 + 33, CIY1 + 48), 12, BF +Line (CIX1 + 13, CIY1 + 22)-(CIX1 + 33, CIY1 + 31), 0, B +Line (CIX1 + 13, CIY1 + 40)-(CIX1 + 33, CIY1 + 48), 0, B +Line (CIX1 + 10, CIY1 + 19)-(CIX1 + 37, CIY1 + 53), 1, B +Line (CIX1 + 37, CIY1 + 20)-(CIX1 + 37, CIY1 + 52), 12 +Circle (CIX1 + 34, CIY1 + 36), 2, 14: Paint (CIX1 + 34, CIY1 + 36), 14 +Circle (CIX1 + 34, CIY1 + 36), 2, 0 +Get (CIX1 + 11, CIY1 + 20)-(CIX1 + 40, CIY1 + 53), Door%() +GoSub CopydotEDoor +Return + +CopydotEDoor: +Line (CIX1 + 11, CIY1 + 20)-(CIX1 + 36, CIY1 + 52), 13, BF +Line (CIX1 + 13, CIY1 + 22)-(CIX1 + 33, CIY1 + 31), 2, BF +Line (CIX1 + 13, CIY1 + 40)-(CIX1 + 33, CIY1 + 48), 2, BF +Line (CIX1 + 13, CIY1 + 22)-(CIX1 + 33, CIY1 + 31), 0, B +Line (CIX1 + 13, CIY1 + 40)-(CIX1 + 33, CIY1 + 48), 0, B +Line (CIX1 + 10, CIY1 + 19)-(CIX1 + 37, CIY1 + 53), 1, B +Line (CIX1 + 37, CIY1 + 20)-(CIX1 + 37, CIY1 + 52), 12 +Circle (CIX1 + 34, CIY1 + 36), 2, 14: Paint (CIX1 + 34, CIY1 + 36), 14 +Circle (CIX1 + 34, CIY1 + 36), 2, 0 +Get (CIX1 + 11, CIY1 + 20)-(CIX1 + 40, CIY1 + 53), EDoor%() +Return + +CopydotKeylock: +Circle (CIX1 + 24, CIY1 + 35), 4, 7 +Circle (CIX1 + 27, CIY1 + 40), 4, 7 +Color 4: Line (CIX1 + 26, CIY1 + 39)-(CIX1 + 44, CIY1 + 21) +Line (CIX1 + 26, CIY1 + 40)-(CIX1 + 44, CIY1 + 22) +Color 6: Line (CIX1 + 34, CIY1 + 20)-(CIX1 + 39, CIY1 + 28) +Line (CIX1 + 35, CIY1 + 20)-(CIX1 + 40, CIY1 + 28) +Line (CIX1 + 35, CIY1 + 32)-(CIX1 + 31, CIY1 + 27) +Get (CIX1 + 15, CIY1 + 16)-(CIX1 + 39, CIY1 + 47), Keylock%() +Return + +CopydotTreasure: +Line (CIX1 + 16, CIY1 + 65)-(CIX1 + 35, CIY1 + 80), 14, B +Line -(CIX1 + 40, CIY1 + 75), 14: Line -(CIX1 + 40, CIY1 + 60), 14 +Line -(CIX1 + 35, CIY1 + 65), 14 +Line (CIX1 + 16, CIY1 + 65)-(CIX1 + 21, CIY1 + 60), 14 +Line -(CIX1 + 40, CIY1 + 60), 14 +Line (CIX1 + 17, CIY1 + 66)-(CIX1 + 34, CIY1 + 79), 6, BF +Paint (CIX1 + 38, CIY1 + 68), 14 +Line (CIX1 + 22, CIY1 + 60)-(CIX1 + 40, CIY1), 6, BF +Line (CIX1 + 40, CIY1 + 60)-(CIX1 + 40, CIY1), 12 +Line (CIX1 + 22, CIY1 + 50)-(CIX1 + 40, CIY1 + 50), 12 +Get (CIX1 + 16, CIY1 + 50)-(CIX1 + 40, CIY1 + 80), Treasure%() +Return + +CopydotRing: +Circle (CIX1 + 28, CIY1 + 35), 5, 15: Circle (CIX1 + 28, CIY1 + 35), 6, 8 +Circle (CIX1 + 28, CIY1 + 26), 3, 1: Paint (CIX1 + 28, CIY1 + 26), 13, 1 +Line (CIX1 + 26, CIY1 + 24)-(CIX1 + 30, CIY1 + 24), 11 +Circle (CIX1 + 28, CIY1 + 26), 2, 1: Circle (CIX1 + 28, CIY1 + 35), 4, 9 +Get (CIX1 + 15, CIY1 + 20)-(CIX1 + 38, CIY1 + 45), Diamond%() +Return + +CopydotRing2: +Circle (CIX1 + 28, CIY1 + 35), 5, 15: Circle (CIX1 + 28, CIY1 + 35), 6, 8 +Circle (CIX1 + 28, CIY1 + 26), 3, 12: Paint (CIX1 + 28, CIY1 + 26), 13, 12 +Line (CIX1 + 26, CIY1 + 24)-(CIX1 + 30, CIY1 + 24), 14 +Circle (CIX1 + 28, CIY1 + 26), 2, 1: Circle (CIX1 + 28, CIY1 + 35), 4, 9 +Get (CIX1 + 15, CIY1 + 20)-(CIX1 + 38, CIY1 + 47), Diamond2%() +Return + +CopydotGem: +Circle (CIX1 + 28, CIY1 + 35), 5, 10: 'CIRCLE (CIX1 + 28, CIY1 + 35), 10, 8 +Circle (CIX1 + 28, CIY1 + 26), 2: Paint (CIX1 + 28, CIY1 + 26), T$ +Line (CIX1 + 26, CIY1 + 24)-(CIX1 + 30, CIY1 + 24), 1 +Circle (CIX1 + 28, CIY1 + 35), 4, 9 +Get (CIX1 + 15, CIY1 + 20)-(CIX1 + 38, CIY1 + 45), Gem%() +Return + +CopydotSpider: +Circle (CIX1 + 28, CIY1 + 27), 3, 8: Paint (CIX1 + 28, CIY1 + 27), 8 +Circle (CIX1 + 28, CIY1 + 20), 6, 8: Paint (CIX1 + 28, CIY1 + 20), 8 +Circle (CIX1 + 28, CIY1 + 25), 6, 0 +Line (CIX1 + 24, CIY1 + 25)-(CIX1 + 19, CIY1 + 30), 7: Line -(CIX1 + 22, CIY1 + 33), 7 +Line (CIX1 + 32, CIY1 + 25)-(CIX1 + 37, CIY1 + 30), 7: Line -(CIX1 + 34, CIY1 + 33), 7 +Line (CIX1 + 23, CIY1 + 22)-(CIX1 + 20, CIY1 + 25), 7 +Line (CIX1 + 23, CIY1 + 16)-(CIX1 + 18, CIY1 + 21), 7 +Line -(CIX1 + 18, CIY1 + 23), 7 +Line (CIX1 + 33, CIY1 + 22)-(CIX1 + 36, CIY1 + 25), 7 +Line (CIX1 + 33, CIY1 + 16)-(CIX1 + 38, CIY1 + 21), 7 +Line -(CIX1 + 38, CIY1 + 23), 7 +Line (CIX1 + 27, CIY1 + 29)-(CIX1 + 27, CIY1 + 31), 4 +Line (CIX1 + 30, CIY1 + 29)-(CIX1 + 30, CIY1 + 31), 4 +Get (CIX1 + 15, CIY1 + 10)-(CIX1 + 42, CIY1 + 40), Spider%() +GoSub CopydotSpiderfr2 +Return + +CopydotSpiderfr2: +Cls +Circle (CIX1 + 28, CIY1 + 27), 5, 8: Paint (CIX1 + 28, CIY1 + 27), 8 +Circle (CIX1 + 28, CIY1 + 20), 6, 8: Paint (CIX1 + 28, CIY1 + 20), 8 +Circle (CIX1 + 28, CIY1 + 25), 6, 0 +Line (CIX1 + 24, CIY1 + 25)-(CIX1 + 19, CIY1 + 20), 7: Line -(CIX1 + 17, CIY1 + 24), 7 +Line (CIX1 + 32, CIY1 + 25)-(CIX1 + 37, CIY1 + 20), 7: Line -(CIX1 + 40, CIY1 + 25), 7 +Line (CIX1 + 24, CIY1 + 25)-(CIX1 + 22, CIY1 + 30), 7: Line -(CIX1 + 24, CIY1 + 33), 7 +Line (CIX1 + 32, CIY1 + 25)-(CIX1 + 34, CIY1 + 30), 7: Line -(CIX1 + 32, CIY1 + 33), 7 +Line (CIX1 + 27, CIY1 + 29)-(CIX1 + 27, CIY1 + 31), 4 +Line (CIX1 + 30, CIY1 + 29)-(CIX1 + 30, CIY1 + 31), 4 +Get (CIX1 + 14, CIY1 + 10)-(CIX1 + 44, CIY1 + 40), Spiderfr2%() +Return + +CopydotSpider2: +Circle (CIX1 + 28, CIY1 + 27), 3, 10: Paint (CIX1 + 28, CIY1 + 27), 10 +Circle (CIX1 + 28, CIY1 + 20), 6, 10: Paint (CIX1 + 28, CIY1 + 20), 10 +Circle (CIX1 + 28, CIY1 + 25), 6, 0 +Line (CIX1 + 24, CIY1 + 25)-(CIX1 + 19, CIY1 + 30), 7: Line -(CIX1 + 22, CIY1 + 33), 7 +Line (CIX1 + 32, CIY1 + 25)-(CIX1 + 37, CIY1 + 30), 7: Line -(CIX1 + 34, CIY1 + 33), 7 +Line (CIX1 + 23, CIY1 + 22)-(CIX1 + 20, CIY1 + 25), 7 +Line (CIX1 + 33, CIY1 + 22)-(CIX1 + 36, CIY1 + 25), 7 +Line (CIX1 + 23, CIY1 + 22)-(CIX1 + 20, CIY1 + 25), 7 +Line (CIX1 + 23, CIY1 + 16)-(CIX1 + 18, CIY1 + 21), 7 +Line -(CIX1 + 18, CIY1 + 23), 7 +Line (CIX1 + 33, CIY1 + 22)-(CIX1 + 36, CIY1 + 25), 7 +Line (CIX1 + 33, CIY1 + 16)-(CIX1 + 38, CIY1 + 21), 7 +Line -(CIX1 + 38, CIY1 + 23), 7 +Line (CIX1 + 27, CIY1 + 29)-(CIX1 + 27, CIY1 + 31), 4 +Line (CIX1 + 30, CIY1 + 29)-(CIX1 + 30, CIY1 + 31), 4 +Get (CIX1 + 15, CIY1 + 10)-(CIX1 + 43, CIY1 + 40), Spider2%() +GoSub CopydotSpiderpfr2 +Return + +CopydotSpiderpfr2: +Cls +Circle (CIX1 + 28, CIY1 + 27), 3, 10: Paint (CIX1 + 28, CIY1 + 27), 10 +Circle (CIX1 + 28, CIY1 + 20), 6, 10: Paint (CIX1 + 28, CIY1 + 20), 10 +Circle (CIX1 + 28, CIY1 + 25), 6, 0 +Line (CIX1 + 24, CIY1 + 25)-(CIX1 + 19, CIY1 + 20), 7: Line -(CIX1 + 17, CIY1 + 24), 7 +Line (CIX1 + 32, CIY1 + 25)-(CIX1 + 37, CIY1 + 20), 7: Line -(CIX1 + 40, CIY1 + 25), 7 +Line (CIX1 + 23, CIY1 + 22)-(CIX1 + 20, CIY1 + 25), 7 +Line (CIX1 + 33, CIY1 + 22)-(CIX1 + 36, CIY1 + 25), 7 +Line (CIX1 + 23, CIY1 + 22)-(CIX1 + 20, CIY1 + 25), 7 +Line (CIX1 + 23, CIY1 + 16)-(CIX1 + 18, CIY1 + 21), 7 +Line (CIX1 + 24, CIY1 + 25)-(CIX1 + 23, CIY1 + 30), 7 +Line (CIX1 + 32, CIY1 + 25)-(CIX1 + 34, CIY1 + 30), 7 +Line (CIX1 + 33, CIY1 + 16)-(CIX1 + 38, CIY1 + 21), 7 +Line (CIX1 + 27, CIY1 + 29)-(CIX1 + 27, CIY1 + 31), 4 +Line (CIX1 + 30, CIY1 + 29)-(CIX1 + 30, CIY1 + 31), 4 +Get (CIX1 + 15, CIY1 + 10)-(CIX1 + 42, CIY1 + 40), Spiderpfr2%() +Return + +CopydotWeb: +T$ = Chr$(200) + Chr$(130) + Chr$(146) + Chr$(48) + Chr$(8) + Chr$(2) + Chr$(144) + Chr$(152) + Chr$(2) +Line (CIX1 + 8, CIY1 + 15)-(CIX1 + 35, CIY1 + 25), 1, B +Paint (CIX1 + 8, CIY1 + 15), T$ +Line (CIX1 + 31, CIY1 + 15)-(CIX1 + 35, CIY1 + 30), 8 +Get (CIX1 + 8, CIY1 + 15)-(CIX1 + 36, CIY1 + 25), Web%() +Return + +CopydotSpike: +X1 = 10: Y1 = 15: Cls +Line (X1, Y1)-(X1 + 5, Y1 - 10), 7: Line -(X1 + 10, Y1), 7 +Line -(X1, Y1), 7: Paint (X1 + 5, Y1 - 5), 7 +Line (X1 - 1, Y1)-(X1 + 4, Y1 - 10), 14 +Line (X1 - 1, Y1 + 1)-(X1 + 10, Y1 + 12), 7, BF +Line (X1 - 1, Y1 + 1)-(X1 - 1, Y1 + 12), 14, BF +Circle (X1 + 12, Y1 + 6), 5, 0: Paint (X1 + 10, Y1 + 6), 0 +Line (X1 + 5, Y1 - 11)-(X1 + 5, Y1 - 10), 14, BF +Get (X1 - 5, Y1 - 12)-(X1 + 12, Y1 + 12), Spike%() +Return + +ObjectdotProperties: +LO$ = Mid$(Object$(Length), 1, 1): HL = InStr(Object$(Length), "@") +If LO$ = "!" Then Health = Health + 25: Ob = Ob + 1 +If LO$ = "$" Then Fortune = Fortune + 20 +If LO$ = "%" Then Health = Health + 200 + (200 * (HL = 64)) +GoSub Gamedotstatus: Objects = Objects + Ob: Ob = 0 +Tallydotpnts: +Score = Score + Fortune: Fortune = 0 +Return + +Cleardotobject: +Put (Sx, Sy), Clrobject%(), PSet: Return + +Cleardotplayer: +Line (265, 145)-(345, 215), 0, BF +Return + +Cleardotman: +Put (X, Y), Clrobject%(), PSet: Return + +Cleardotarea: +Line (Sx - 4, Sy)-(Sx + 23, Sy + 35), 0, BF +Return + +Placedotwall: +If T$ = "@" Then Put (1 + SpacerX, 6 + SpacerY), Wall3%(), PSet: GoTo Skipdotover +If T$ = "%" Then Put (1 + SpacerX, 6 + SpacerY), Wall2%(), PSet: GoTo Skipdotover +Color 2: Put (1 + SpacerX, 6 + SpacerY), Wall%(), PSet +Skipdotover: +SpacerX = SpacerX + 30: +Return + +Placedotdoor: +Put (SpacerX, 36 + SpacerY - 36 + 6), Door%() +SpacerX = SpacerX + 30 +Return + +PlacedotEdoor: +Put (SpacerX, 36 + SpacerY - 36 + 6), EDoor%() +SpacerX = SpacerX + 30 +Return + +Placedotkey: +Put (SpacerX, 36 + SpacerY - 36 + 6), Keylock%(), PSet +SpacerX = SpacerX + 30 +Return + +Placedotchest: +Put (SpacerX, 36 + SpacerY - 36 + 6), Treasure%(), PSet +SpacerX = SpacerX + 30 +Return + +Placedotring: +Put (SpacerX, 36 + SpacerY - 36 + 6), Diamond%(), PSet +SpacerX = SpacerX + 30 +Return + +Placedotgem: +Put (SpacerX, 36 + SpacerY - 36 + 6), Gem%(), PSet +SpacerX = SpacerX + 30 +Return + +Placedotweb: +Put (SpacerX, 36 + SpacerY - 36 + 6), Web%(), PSet +SpacerX = SpacerX + 30 +Return + +PlacedotSpike: +Put (SpacerX + 5, SpacerY + 36), Spike%(), PSet +SpacerX = SpacerX + 30 +Return + +Fin: +Screen 7: Cls: Locate 10, 15: Print "GAME": Locate 10, 20: Print "OVER" +If slc <> 4 Then Locate 13, 12: Print "SPACE - RESTART" +Locate 16, 15: Print "ESC - END" +WtdotKey: +T$ = InKey$: If T$ = "" Then GoTo WtdotKey +If T$ = Chr$(27) Then Cls: Screen 0: Print "THANKS FOR PLAYING!": System 0 +If slc <> 4 Then If InKey$ = " " Then GoTo Start +If InKey$ = "" Then GoTo WtdotKey +GoTo WtdotKey + +Checkdotkey: +i$ = InKey$ +Select Case InKey$ + Case Chr$(27) + Cls: System + Case Chr$(32) + GoTo Start + + If InKey$ = "" Then GoTo Checkdotkey +End Select +GoTo Checkdotkey + +RoomdotCheck: +Cls: L = 0: LL = 0: SpacerX = 0: SpacerY = 0: Adv = 0: Wm = 0: Wm2 = 0 +Eny = 0: Stringdotpnt = 0: Count = 0: EndotTally = 0 +StartdotA = (12 * Rm) - 11: FinishdotA = 12 * Rm +If Y > 400 Then Y = 4 +If Y < 4 Then Y = 400 + +Confirmdotrm: +GoSub Copydotwall: GoSub Cleardotplayer +For A = StartdotA To FinishdotA: For B = 1 To 20 'Height x Width + T$ = Mid$(Maze$(A), B, 1) + If T$ = " " Or T$ = "." Or T$ = "L" Then GoSub SkipdotX + If T$ = "#" Then GoSub Placedotwall + If T$ = "B" Or T$ = "S" Or T$ = "w" Then GoSub SkipdotX + If T$ = "D" Then GoSub Placedotdoor + If T$ = "E" Then GoSub PlacedotEdoor + If T$ = "W" Then GoSub Placedotweb + If T$ = "g" Then GoSub Placedotgem + If T$ = "k" Then GoSub Placedotkey + If T$ = "r" Then GoSub Placedotring + If T$ = "s" Then GoSub PlacedotSpike + If T$ = "t" Then GoSub Placedotchest +Next B: SpacerX = 0: SpacerY = SpacerY + 36: Next A: GoSub Displaydotman +T = 0: L = 0: SpacerX = 0: SpacerY = 0 +If Rm = 0 Or Rm = 33 Or Rm = 64 Then Adv = 500 +If Rm = 1 Or Rm = 5 Or Rm = 9 Or Rm = 17 Or Rm = 18 Or Rm = 19 Then Adv = 300 +If Rm = 7 Or Rm = 8 Or Rm = 12 Or Rm = 16 Or Rm = 25 Or Rm = 28 Then Adv = 400 +If Rm = 29 Or Rm = 31 Or Rm = 35 Or Rm = 39 Or Rm = 40 Or Rm = 41 Then Adv = 500 +If Rm = 6 Or Rm = 10 Or Rm = 15 Or Rm = 20 Or Rm = 30 Then Adv = 450 +If Rm = 42 Or Rm = 43 Or Rm = 44 Then Adv = 450 +If Rm = 45 Or Rm = 46 Or Rm = 47 Or Rm = 54 Or Rm = 53 Or Rm = 55 Then Adv = 500 +If Rm = 60 Or Rm = 61 Or Rm = 62 Then Adv = 500 +r = StartdotA: B = 1: GoSub Gamedotstatus: Return + +Gamedotstatus: +Color 2: Locate 29, 5: Print "LIVES:";: Color 15: Print Lives; +Color 2: Print Space$(4); "SCORE:";: Color 15: Print Score; +Color 2: Print Space$(5); "WEAPONS:";: Color 15: Print Objects; +Color 2: Print Space$(4); "HEALTH: ";: Color 15: Print Health; +Color 2: Print Space$(4); "KEYS:";: Color 15: Print Keys; +Return + +Titledotscr: +Screen 12: Cls +W = (600 / 4) + 50: H = (400 / 4) + 40: CL = 1: Dmx = 1: Dmy = 1 +CIX1 = 106: CIY1 = 279: Spx = 60: Spy = 243 +SpacerX = Spx: SpacerY = Spy +Demo = TRUE: Plx% = CIX1 - 12: Ply% = CIY1 + (36 * 2) + +Scandotmes: +Color 8: Locate 1, 1: +If (T < 1 Or T > 0) Then Print M1$ +For A = 0 To 133: For B = 0 To 15 + + Rand: + Randomize Timer + c = Fix(15 * Rnd(1)): If c = 8 Then GoTo Rand + cx = W - 190 + A * 5: cy = H + 20 + (B * 5) - 80 + Pt = Point(A, B) + If Pt = 8 And T < 1 Then GoSub CircdotFont: GoTo SkipdotPt + If Pt = 8 And T > 0 Then GoSub Message + + SkipdotPt: +Next B, A: ht = CsrLin - 1: Locate ht, 1: Print Space$(16) +T = T + 1: M1$ = "ANY KEY TO START" +If T < 2 Then GoTo Scandotmes +GoSub Drawdotwall: Put (Plx%, Ply%), Player%(), PSet: A = 0: B = A: M = 5: +Aax = 30: BBx = 36: Playdotdemo = TRUE +Locate 10, 25: Print "Version 2.1: Trapped Forever" + +Checkdotpress: +GoSub Spiderdotroutine: GoSub Ringdotglow: If Playdotdemo Then GoSub Demodotroutine +If InKey$ = "" Then GoTo Checkdotpress +CIX1 = 275: CIY1 = 145: CL = 0: Web = 5: Demo = FALSE +RingdotX = 0: RingdotY = 0: Return + +Demodotroutine: +If A = (30 * 3) Then GoSub Listdotmes +If A = (30 * 5) Then GoSub Listdotmes2 +If A = (30 * 9) And Not (Unlockeddotdoor) And Tr < 1 Then GoSub Listdotmes3 +If A = (30 * 12) And Unlockeddotdoor < 1 And Tr < 1 Then GoSub Listdotmes4: Unlockeddotdoor = TRUE +Put (Plx% + A, Ply% - B), Player%(), PSet +For H = 1 To 1000: Next +Put (Plx% + A, Ply% - B), Player%() +If (A < 30 * 12) Then A = A + Aax +If (A <= (30 * 9)) And Tr Then GoSub Plotdotdemdotplr: GoSub Listdotmes5: Playdotdemo = FALSE: Return +If (A > (30 * 10) And Tr) Then A = A + Aax + +If Unlockeddotdoor And Not (Tr) Then B = B + BBx: If B >= (36 * 2) Then GoSub Plotdotdemdotplr: Aax = -30: Tr = 1: Unlockeddotdoor = FALSE: Sleep 1 +Null: +Return + +Plotdotdemdotplr: +Put (Plx% + A, Ply% - B), Player%(), PSet: Return + +Listdotmes: +GoSub Plotdotdemdotplr: GoSub Dmes1: Return + +Listdotmes2: +GoSub Plotdotdemdotplr: GoSub Dmes2: Return + +Listdotmes3: +GoSub Plotdotdemdotplr: GoSub Dmes3: Return + +Listdotmes4: +GoSub Plotdotdemdotplr: GoSub Dmes4: Return + +Listdotmes5: +GoSub Plotdotdemdotplr: GoSub Dmes5: Return + +Dmes1: +A$ = "Avoid getting bit by the hanging spiders.": L = (80 - Len(A$)) * .5 +A$(2) = "and don't touch the flashing electric pulses." +Color 15: Locate 12, L: Print A$ +L2 = (80 - Len(A$(2))) * .5: Color 15: Locate 14, L2: Print A$(2): Sleep 6 +Locate 12, L: Print Space$(Len(A$)): +Locate 14, L2: Print Space$(Len(A$(2))) +Return + +Dmes2: +Line (Plx% + A - 4, Ply%)-(Plx% + A + 23, Ply% + 35), 0, BF +Put (Plx% + A, Ply%), Player%() +A$ = "Only the key you see in the same room as the door." +A$(2) = "will unlock that door." +L = (80 - Len(A$)) * .5: Color 15: Locate 12, L: Print A$ +L2 = (80 - Len(A$(2))) * .5: Color 15: Locate 14, L2: Print A$(2): Sleep 6 +Locate 12, L: Print Space$(Len(A$)) +Locate 14, L2: Print Space$(Len(A$(2))) +Return + +Dmes3: +A$ = "Collect rings, gems and treasures on your journey." +L = (80 - Len(A$)) * .5: Color 15: Locate 12, L: Print A$: Sleep 6 +Locate 12, L: Print Space$(Len(A$)): Return + +Dmes4: +A$ = "Now open the door with the key you found." +L = (80 - Len(A$)) * .5: Color 15: Locate 12, L: Print A$: Sleep 6 +Locate 12, L: Print Space$(Len(A$)): +Line (Plx% + A - 4, (Ply%) - 36)-(Plx% + A + 23, (Ply% + 35) - 36), 0, BF +Return + +Dmes5: +A$ = "Search for items and health potions in the treasure chests." +L = (80 - Len(A$)) * .5: Color 15: Locate 12, L: Print A$: Sleep 6 +Locate 12, L: Print Space$(Len(A$)): +Return + +CircdotFont: +Circle (cx, cy), 3, c: Paint (cx, cy), c: Circle (cx, cy), 1, 14 +PSet (cx, cy), 0 +Return + +Message: +msx = W - 80 + A * 3: msy = H + 280 + B * 2 +Circle (msx, msy), 2, CL +Inc = Inc + 1: If Fix(Inc / 45) = Inc / 45 Then CL = CL + 1 +If CL = 8 Then CL = CL + 1 +Return + +Drawdotwall: +GoSub Demodotmaze: For A = 1 To 5: For L = 1 To 15 + S$ = Mid$(A$(A), L, 1) + If S$ = "#" Then Put (SpacerX, SpacerY), Wall%(), PSet + If S$ = "t" Then Put (SpacerX, SpacerY), Treasure%(), PSet + If S$ = "D" Then Put (SpacerX, SpacerY), Door%(), PSet + If S$ = "k" Then Put (SpacerX, SpacerY), Keylock%(), PSet + If S$ = "r" Then RingdotX = SpacerX: RingdotY = SpacerY: Put (SpacerX, SpacerY), Diamond%(), PSet + If S$ = "g" Then Put (SpacerX, SpacerY), Gem%(), PSet + If S$ = "W" Then Put (SpacerX, SpacerY), Web%(), PSet + If (S$ = "B" Or S$ = "S") Then Spx = SpacerX: Spy = SpacerY - 6: GoSub Spiderdotroutine + SpacerX = SpacerX + 30 +Next L: SpacerX = 60: SpacerY = SpacerY + 36: Next A +SpacerX = 60: SpacerY = 0 +Return + +Menulist: +Cls: Ky$(1) = "ARROW KEYS IN USE": Ky$(2) = "NUMPAD IN USE" + Space$(4) +Pntr = 190: SvspX = Spx: SvspY = Spy: slc = 1 +Indent = 30: Dnx = 182: Bot = 410 +'LINE (120, 100)-(490, 320), 7, BF +For O = 120 To 490 Step 2.1: Line (O, 100)-(O, Bot), 8: Next +Line (120 + Indent, 100 + Indent)-(490 - Indent, Bot - Indent), 7, BF +Line (120 + Indent + 10, 100 + Indent + 10)-(490 - Indent - 10, Bot - Indent - 10), 0, BF +Line (120 + Indent, 100 + Indent)-(490 - Indent, 320 - Indent), 14, B +Line (120 + Indent + 1, 100 + Indent + 1)-(490 - Indent - 1, Bot - Indent - 1), 4, B +Circle (190, 182), 6, 4: Paint (190, 182), 4: Circle (190, 182), 7, 14 + +Options: +Color 14 +Locate 10, 26: Print "Use SPACE-BAR to select": Color 9 +Locate 12, 28: Print "HELP (Game tips)" +Locate 14, 28: Print "GAME SPEED" +Locate 16, 28: Print Ky$(Kytapfl + 1) +Locate 18, 28: Print "ABORT THE GAME" +'LINE (120 + Indent + 10, 262 + Indent)-(490 - Indent - 10, Bot - Indent - 10), 15, BF +For O = 120 + Indent + 10 To 490 - Indent - 10 Step 2 +Line (O, 262 + Indent)-(O, Bot - Indent - 10), 15: Next +Color 5: Locate 22, 26: Print "Press ESC to return to game" + +OptiondotSel: +T$ = InKey$: If T$ = "" Then GoTo OptiondotSel +If T$ = Chr$(0) + "P" Then GoSub ErasedotPntr: Dnx = Dnx + 30: If Dnx > 272 Then Dnx = 272 +If T$ = Chr$(0) + "H" Then GoSub ErasedotPntr: Dnx = Dnx - 30: If Dnx < 182 Then Dnx = 182 +If T$ = Chr$(27) Then GoSub RoomdotCheck: Spx = SvspX: Spy = SvspY: Return +If T$ = Chr$(32) Then + If slc = 1 Then + GoSub Helpdotscr: GoTo Menulist + Else + If slc = 2 Then + T$ = "": GoSub Alterdotdelay: GoTo Menulist + Else + If slc = 3 Then + Kytapfl = Kytapfl + 1: If Kytapfl > 1 Then Kytapfl = 0 + Actiondotkey = (Kytapfl) + GoTo Options + Else + If slc = 4 Then + Cls: GoTo Fin + End If + End If + End If + End If +End If +GoSub MovedotPntr +GoTo OptiondotSel + +MovedotPntr: +slc = Int(Dnx / 30) - 5 +Circle (190, Dnx), 6, 4: Paint (190, Dnx), 4: Circle (190, Dnx), 7, 14 +Return + +ErasedotPntr: +If Dnx >= 182 Or Dnx <= 242 Then Circle (190, Dnx), 7, 0: Paint (190, Dnx), 0 +Return + +Helpdotscr: +Cls: Far = 600: Line (0, 0)-(Far, 478), 15, BF +Line (40, 0)-(40, 478), 12, B: c = 0 +For E = 0 To 478 Step 15.2: Line (0, E)-(Far, E), 3: Next +Circle (15, 10), 7, c: Paint (16, 11), c +Circle (15, 140), 7, c: Paint (16, 141), c: Circle (15, 270), 7, c +Paint (16, 271), c: Circle (15, 400), 7, c: Paint (16, 401), c +Color 6: Locate 5, 17: Print "You must navigate through a 64-room maze," +Locate 7, 17: Print "all while avoiding dangling spiders, electric shocks" +Locate 9, 17: Print "and large knives that move up from the floor." +Locate 12, 17: Print "A word of advice: Time yourself when passing beyond" +Locate 14, 17: Print "spiders, electric shocks and moving knives." +Locate 17, 17: Print "Also make a hand-made map of the maze as you start" +Locate 19, 17: Print "advancing further and further into the labyrinth." +Locate 21, 17: Print "Finally, take advantage of the treasure chests and" +Locate 23, 17: Print "the helpful items inside." +Color 2: Locate 26, 23: Print "PRESS SPACE-BAR TO RETURN TO MENU" +Holddothelp: +T$ = InKey$: If T$ = "" Then GoTo Holddothelp +If T$ = Chr$(32) Then Return +GoTo Holddothelp + + +Demodotmaze: +A$(1) = "###############" +A$(2) = "# r t #" +A$(3) = "####W########D#" +A$(4) = "# S k g #" +A$(5) = "###############" +Return + +Alterdotdelay: +Screen 12: Cls +Line (0, 0)-(600, 300), 8, BF: Line (0, 301)-(600, 315), 4, BF +For L = 2 To 598 Step 2.8: Line (L, 302)-(L, 314), 1: Next +For L = 1 To 598 Step 2.36: Line (L, 1)-(L, 298), 7: Next +CPU = 106: T = 1: c = 1 +Color 15: Locate 10, 22: Print "GAME DELAY PERFORMANCE METER" +Color 2: Locate 22, 2: Print "USE THE LEFT & RIGHT ARROW KEYS TO SET A DELAY CHANNEL "; +Print "FOR THIS GAME." +Locate 23, 2: Print "YOU WILL THEN SEE A NUMERICAL COUNTER INCREMENTING "; +Print "OR DECREMENTING." +Locate 24, 2: Print "WHEN YOU HAVE THE DELAY YOU NEED, PRESS THE "; +Color 14: Print "SPACE BAR ";: Color 2: Print "TO EXIT." +Locate 25, 2: Print "USE CHANNEL ";: Color 14: Print "0 "; +Color 2: Print "FOR FASTEST SPEED." +Line (94, 100 + 80 - 6)-(456, 150 + 80 + 6), 0, B +Line (95, 100 + 80 - 5)-(455, 150 + 80 + 5), 9, BF +Line (100, 100 + 80)-(450, 150 + 80), 14, BF +Line (107, 190)-(107, 220), 6, BF +'Counter +Line (240, 245)-(300, 290), 0, BF: Line (239, 244)-(301, 291), 15, B +Line (241, 246)-(299, 289), 6, B: Line (243, 246)-(298, 288), 6, B +GoSub Cntr + +Pskey: +i$ = InKey$: If i$ = "" Then GoTo Pskey +If i$ = Chr$(0) + "M" Then Flg = 1: T = 1: SL = 6: GoSub DrwMtr: GoSub Cntr: CPU = CPU + T: If CPU > 443 Then CPU = 443 +If i$ = Chr$(0) + "K" Then T = -1: SL = 14: GoSub DrwMtr: CPU = CPU + T: GoSub DrwMtr: GoSub Cntr: If CPU < 105 Then CPU = 105 +If i$ = Chr$(27) Then GoTo BegdotGame +If i$ = Chr$(32) Then Return +GoTo Pskey + +Cntr: +c = c + T +If c < 1 Then c = 1: Flg = 0 +If c > 340 Then c = 340 +Color 7: Locate 17, 32: Print c - 1; +Return + +BegdotGame: +If c - 1 < 2 Then Flg = 0: CPU = 0 +Return + +DrwMtr: +Line (CPU, 190)-(CPU, 220), SL, BF +Return + +Builddotmazes: +'M:1 Maze 1 +Maze$(1) = "######W#W#W#########" +Maze$(2) = "#t### S B S #####" +Maze$(3) = "#t# # # ###### LL#" +Maze$(4) = "#t# # # ###### ###W#" +Maze$(5) = "#t# # # # S." +Maze$(6) = "#r# # # # # ###W####" +Maze$(7) = "#g#t# # # # SLk ." +Maze$(8) = "#t# # # # ##########" +Maze$(9) = "# # # # # # # ." +Maze$(10) = "# W # # # ########W#" +Maze$(11) = "# B D # # B." +Maze$(12) = "#######.############" + +'M:9 Maze 2 +Maze$(13) = "#######.############" +Maze$(14) = "#t # # ####W#W###W#" +Maze$(15) = "#r # # # # B B ttS." +Maze$(16) = "#r # # # ##W#######" +Maze$(17) = "# # # # #kB ." +Maze$(18) = "# # # # ##########" +Maze$(19) = "# # # # ." +Maze$(20) = "# # # #######W####" +Maze$(21) = "# # # D #rB ." +Maze$(22) = "# # # #### #######" +Maze$(23) = "# # # # ." +Maze$(24) = "#.##.##.######.#####" + +'M:17 +Maze$(25) = "#.##.##.######.#W###" +Maze$(26) = "# # # #gtrr Brk#" +Maze$(27) = "# # # ############" +Maze$(28) = "# # # ." +Maze$(29) = "# # ##############" +Maze$(30) = "# # #" +Maze$(31) = "# #####D######### #" +Maze$(32) = "# ####W W# ## #" +Maze$(33) = "# ##ttBgBt# ## #" +Maze$(34) = "# ################ #" +Maze$(35) = "# # ." +Maze$(36) = "#.#.################" + +'M:25 +Maze$(37) = "#.#.################" +Maze$(38) = "# ." +Maze$(39) = "# ##################" +Maze$(40) = "# ." +Maze$(41) = "# ################W#" +Maze$(42) = "# B." +Maze$(43) = "##W###W#############" +Maze$(44) = "#tBtttB tt # ." +Maze$(45) = "#rB r B # ####" +Maze$(46) = "#######D##.W### ##W#" +Maze$(47) = "# rr # # B # #kB." +Maze$(48) = "##..###.##.## #.####" + +'M:33 +Maze$(49) = "##..###.##.## #.####" +Maze$(50) = "# # # # k# ." +Maze$(51) = "#W# ### ###W###W####" +Maze$(52) = "#B B B ." +Maze$(53) = "# ##### ##### # ####" +Maze$(54) = "# # # # # # # #" +Maze$(55) = "# # # # r # # #" +Maze$(56) = "# # # # # # # #" +Maze$(57) = "# # # W#### # # #" +Maze$(58) = "# # # B # # #" +Maze$(59) = "#D# # ##### # # #" +Maze$(60) = "#.#####.#####.#.####" + +'M:41 +Maze$(61) = "#.#####.#####.#.####" +Maze$(62) = "# # # # # W## #" +Maze$(63) = "# # t # # # Bk# #" +Maze$(64) = "# # # # ##### #" +Maze$(65) = "# # # # ######## #" +Maze$(66) = "# # r # # # # #" +Maze$(67) = "# # # # # rrr # #" +Maze$(68) = "# # # # # # #" +Maze$(69) = "# # # # ttt # #" +Maze$(70) = "# ############## #W#" +Maze$(71) = "# D B." +Maze$(72) = "####.###############" + +'M:49 +Maze$(73) = "####.#######W###W###" +Maze$(74) = "# # # # B B #" +Maze$(75) = "# # # # ### # #" +Maze$(76) = "# # # # # # # #" +Maze$(77) = "# # # # # # # #" +Maze$(78) = "# # ### # # # #r #" +Maze$(79) = "# # # # # # # #" +Maze$(80) = "# # # # # # # t#" +Maze$(81) = "# # k # # # # # #" +Maze$(82) = "# ##### # # # #W##" +Maze$(83) = "# #r# #D # B ." +Maze$(84) = "#####.#####.######.#" + +'M:57 +Maze$(85) = "#####.#####.######.#" +Maze$(86) = "# t# # # # # ." +Maze$(87) = "# # # # # ###" +Maze$(88) = "# ### ##### ##W#####" +Maze$(89) = "# #kB L ." +Maze$(90) = "# #######W##########" +Maze$(91) = "# B ." +Maze$(92) = "# ##################" +Maze$(93) = "# ## rr ggg ttt tt#." +Maze$(94) = "# #W ggg tt rr###" +Maze$(95) = "# DS g ggg ttt ttg #" +Maze$(96) = "####################" + +'M:2 +Maze$(97) = "####################" +Maze$(98) = "##WW##############W#" +Maze$(99) = "#kBS SD" +Maze$(100) = "###W #" +Maze$(101) = ". B ." +Maze$(102) = "#####W######W#######" +Maze$(103) = ". B B ttt# ." +Maze$(104) = "################## #" +Maze$(105) = ". #r # #" +Maze$(106) = "################.# #" +Maze$(107) = ". #" +Maze$(108) = "####################" + +'M:10 +Maze$(109) = "####################" +Maze$(110) = "###W#######W######W#" +Maze$(111) = ". B S S." +Maze$(112) = "########### ########" +Maze$(113) = ". # # ." +Maze$(114) = "######### # # #" +Maze$(115) = ". # #r# ###W#" +Maze$(116) = "####### # ### # B." +Maze$(117) = ". # # # #" +Maze$(118) = "##### # ######## #" +Maze$(119) = ". # # #" +Maze$(120) = "##.##.######.#######" + +'M:18 +Maze$(121) = "##.##.######.#####W#" +Maze$(122) = "#ggg# # ## # B." +Maze$(123) = "##W## # ## #####t#" +Maze$(124) = "D B # ##k# r ###" +Maze$(125) = "#### ## ### r r #" +Maze$(126) = "# ## ## ## ." +Maze$(127) = "# ## ## #########" +Maze$(128) = "# ## ## ." +Maze$(129) = "# # # # ##W## ##" +Maze$(130) = "####### # # #rB W#" +Maze$(131) = ". # # # #rB B." +Maze$(132) = "#######.###.#.######" + +'M:26 +Maze$(133) = "#######.###.#.####W#" +Maze$(134) = ". rr# ## # ttt#B." +Maze$(135) = "####### ## # rr # #" +Maze$(136) = ". rr# ## ###### #" +Maze$(137) = "###### ## # rrr t#" +Maze$(138) = ". # D## #### ###" +Maze$(139) = "# # # # #" +Maze$(140) = ". # #### ####W ###" +Maze$(141) = "#### ## # B #k#" +Maze$(142) = "#W#### ## # #####L#" +Maze$(143) = ".B ## # # #" +Maze$(144) = "#######.##.#.#####.#" + +'M:34 +Maze$(145) = "#######.##.#.#####.#" +Maze$(146) = ". # # #t# #" +Maze$(147) = "#######.#### # #t# #" +Maze$(148) = ". L # # #r# #" +Maze$(149) = "### ##WW#D# # # # #" +Maze$(150) = "# # # BB # B# # # #" +Maze$(151) = "# # # # # k# # # #" +Maze$(152) = "# # # ####### # # #" +Maze$(153) = "# # #t # # # ." +Maze$(154) = "# # #g # W##### # #" +Maze$(155) = "# # #g # B # #" +Maze$(156) = "###.####.#########.#" + +'M:42 +Maze$(157) = "###.####.#########.#" +Maze$(158) = "# # # # # # # #" +Maze$(159) = "# # # # # # # # # #" +Maze$(160) = "# # # #t # # # # # #" +Maze$(161) = "# # # # # # # # # #" +Maze$(162) = "# # # # r# # # # # #" +Maze$(163) = "# # # # # # # # # #" +Maze$(164) = "# # # # W## # # # #" +Maze$(165) = "# #k# # B # # #" +Maze$(166) = "#W###############W #" +Maze$(167) = ".B D B #" +Maze$(168) = "### ############.###" + +'M:50 +Maze$(169) = "###.############.###" +Maze$(170) = "# # # ## # #" +Maze$(171) = "# #L# ## # #" +Maze$(172) = "# # # ## ## #" +Maze$(173) = "# #k# #W ### #" +Maze$(174) = "# ### ## B ## ##W#" +Maze$(175) = "# ## ## # t#tB." +Maze$(176) = "# ## ## #L ## #" +Maze$(177) = "# ## ## #tt## #" +Maze$(178) = "## ## W#### L## #" +Maze$(179) = ".L # Brr tt##D#" +Maze$(180) = "##################.# " + +'M:58 +Maze$(181) = "#W################.#" +Maze$(182) = ".B # # #" +Maze$(183) = "# k############### #" +Maze$(184) = "#W# #" +Maze$(185) = ".B ############## #" +Maze$(186) = "### # #" +Maze$(187) = ". # # ##############" +Maze$(188) = "# # ##############W#" +Maze$(189) = ". # B." +Maze$(190) = "# ################W#" +Maze$(191) = "# BD" +Maze$(192) = "####################" + +'M:3 +Maze$(193) = "####################" +Maze$(194) = "####################" +Maze$(195) = ". #" +Maze$(196) = "######W###W#W## # ." +Maze$(197) = ". L S S Sk# # #" +Maze$(198) = "############### # #" +Maze$(199) = ". # # #" +Maze$(200) = "########### # # # #" +Maze$(201) = "#r r r # # # #" +Maze$(202) = "# g t # # # #" +Maze$(203) = "# # # #D#" +Maze$(204) = "########.####.#.##.#" + +'M:11 +Maze$(205) = "########.####.#.##.#" +Maze$(206) = "####### Lt # # # #" +Maze$(207) = ". # Lt L# # # #" +Maze$(208) = "#W### ####W## # # #" +Maze$(209) = ".SW B## # # #" +Maze$(210) = "#kBs######g## #r # #" +Maze$(211) = "######ggt# ## # # #" +Maze$(212) = ". #trt# ## # # #" +Maze$(213) = "#### #rrt# W# # r#D#" +Maze$(214) = "#tW# # W B# #### #" +Maze$(215) = "# B # BsS # #" +Maze$(216) = "####.##########.##.#" + +'M:19 +Maze$(217) = "####.##########.##.#" +Maze$(218) = ". # # # ." +Maze$(219) = "## # # ####WW#W# ###" +Maze$(220) = "## # # # D BBsB ." +Maze$(221) = "## # # # ##W########" +Maze$(222) = "## # # # #kBttL ttt#" +Maze$(223) = "## # # # # LLL LttL#" +Maze$(224) = ". # # # L ttLt#" +Maze$(225) = "### # # # L LLtL#" +Maze$(226) = "#r# # # # L L L#" +Maze$(227) = ". # # # #L L L ." +Maze$(228) = "#.####.#.###########" + +'M:27 +Maze$(229) = "#.####.#.##W#W######" +Maze$(230) = ". ### # #LStBt#rrr#" +Maze$(231) = "# # ## # LLLL# #" +Maze$(232) = "# # #### # r LWrr #" +Maze$(233) = "# # # #L r S #" +Maze$(234) = "# # # ###W L L#rrr#" +Maze$(235) = "# # # #ttB r # #" +Maze$(236) = "# # # # ######## ###" +Maze$(237) = "# # # # r g ## # ." +Maze$(238) = "# # # # r r t## # #" +Maze$(239) = "# # # # g t ## # #" +Maze$(240) = "#.#.#.##########.#.#" + +'M:35 +Maze$(241) = "#.#.#.##########.#.#" +Maze$(242) = "# #L# # # #" +Maze$(243) = "# #t# ####W##### # #" +Maze$(244) = "# #g# B #" +Maze$(245) = "# ##################" +Maze$(246) = "# ##############W###" +Maze$(247) = "# B #" +Maze$(248) = "##W############### #" +Maze$(249) = ". B rrLrrr k# #" +Maze$(250) = "###W############## #" +Maze$(251) = "# B D." +Maze$(252) = "##.#################" + +'M:43 +Maze$(253) = "##.#################" +Maze$(254) = "## ######W#W########" +Maze$(255) = "## # SsS ." +Maze$(256) = "## # ###W#########W#" +Maze$(257) = "## # #kgSs L S." +Maze$(258) = "## # ###############" +Maze$(259) = "## # ." +Maze$(260) = "## #################" +Maze$(261) = "## # sL L#" +Maze$(262) = "## # #W#####W##### #" +Maze$(263) = "## # DS Ss E## #" +Maze$(264) = "##.###############.#" + +'M:51 +Maze$(265) = "##.###########W###.#" +Maze$(266) = "## # S Ds#" +Maze$(267) = "## # ###############" +Maze$(268) = "## # ." +Maze$(269) = "## ##W#####W###### #" +Maze$(270) = "#W B B # #" +Maze$(271) = ".B # #####W##L # #" +Maze$(272) = "#### # B # L# #" +Maze$(273) = "# # #### #k# ##" +Maze$(274) = "# ttt # # # ### #W#" +Maze$(275) = "# # # #B." +Maze$(276) = "#######.# ########.#" + +'M:59 +Maze$(277) = "#######.# W#######.#" +Maze$(278) = "#kttt # # S r t g# #" +Maze$(279) = "# tt L# ########D# #" +Maze$(280) = "# ttt # #tttttttt# #" +Maze$(281) = "#L L # ########## #" +Maze$(282) = "# # #" +Maze$(283) = "###.##############W#" +Maze$(284) = "# W # B." +Maze$(285) = ". # B # #" +Maze$(286) = "####################" +Maze$(287) = ". ." +Maze$(288) = "####################" + +'M:4 +Maze$(289) = "####################" +Maze$(290) = "####################" +Maze$(291) = "#######W###W####WW##" +Maze$(292) = ". St# S BBk." +Maze$(293) = "# #W###### #########" +Maze$(294) = "# .B tttt LtLLtttt#" +Maze$(295) = "# #L ttt L ttttLtt." +Maze$(296) = "# # L L L LL LL L#" +Maze$(297) = "# #L L LL LL ." +Maze$(298) = "# #####W##########W#" +Maze$(299) = "# sS D B." +Maze$(300) = "#########.##########" + +'M:12 +Maze$(301) = "#########.##########" +Maze$(302) = "# # # ." +Maze$(303) = "# ####### # ########" +Maze$(304) = "# # ###W####" +Maze$(305) = "#L##### # # #ttS ." +Maze$(306) = "# # # # #####W##" +Maze$(307) = "# # ##### # # tt S ." +Maze$(308) = "#L# ###W# # # tt ###" +Maze$(309) = "# L sB# # # #" +Maze$(310) = "# ##### # # # rrrr #" +Maze$(311) = "#S k# #D# rrrr #" +Maze$(312) = "#.#######.#.########" + +'M:20 +Maze$(313) = "#.#######.#.#W######" +Maze$(314) = ". # # # Btttts." +Maze$(315) = "### # # # # #WW#####" +Maze$(316) = ". # # # # #D BBLLtt#" +Maze$(317) = "# # # # # # # Bt##W#" +Maze$(318) = "# # # # # # #LWW#kS." +Maze$(319) = "# # # # # # #LBS####" +Maze$(320) = "# # # # # # #ttttt #" +Maze$(321) = "# # # # # # # tttt #" +Maze$(322) = "# # # # # # # tttt #" +Maze$(323) = ". # # # # # # tttt #" +Maze$(324) = "#.#.#.###.#.######.#" + +'M:28 +Maze$(325) = "#.#.#.###.#.######.#" +Maze$(326) = "#L# # # # DrLrr#g#" +Maze$(327) = "# # #S# ### #rrr##W#" +Maze$(328) = "#L# ### #t# # Lr#kS." +Maze$(329) = "# # # W #t# #S L####" +Maze$(330) = "#L#r# B rt# #BBL #" +Maze$(331) = "#t# # ##### #Lttt###" +Maze$(332) = "##### # #LtLt# ." +Maze$(333) = ". g# # #####LtLt# #" +Maze$(334) = "####W # #tttLttLt# #" +Maze$(335) = "#tttB # #gLtttLtt# #" +Maze$(336) = "#######.##########.#" + +'M:36 +Maze$(337) = "#######.########W#.#" +Maze$(338) = "# r r # Ss #" +Maze$(339) = "# t # # ######W# #" +Maze$(340) = "#####W# # # Bs #" +Maze$(341) = "# B # # ###### #" +Maze$(342) = "# ####### # #ktgt# #" +Maze$(343) = "# # # #L Lt# #" +Maze$(344) = "# # # # #r L # #" +Maze$(345) = "# #W## # # #L # #" +Maze$(346) = "# sS # # # L # #" +Maze$(347) = ".###D# # # # L # #" +Maze$(348) = "####.# ####.####.#.#" + +'M:44 +Maze$(349) = "####.# ####.####.#.#" +Maze$(350) = "#W## # #gg# #tt# #r#" +Maze$(351) = ".Ss # #tt# #tt#####" +Maze$(352) = "#W#### #Lt# # ttL t#" +Maze$(353) = ".Bs #tt#k#L t #" +Maze$(354) = "#W######tt### BS #" +Maze$(355) = ".S###ttttL L tttt #" +Maze$(356) = "# ###tttt L tttt #" +Maze$(357) = "# ###rrrLr L rrr #" +Maze$(358) = "# #WW rrrr L L #" +Maze$(359) = "# DSBrrrLrrL rrrr #" +Maze$(360) = "#.##################" + +'M:52 +Maze$(361) = "#.W#################" +Maze$(362) = "# Ss ." +Maze$(363) = "####W#######D#####W#" +Maze$(364) = ".k# B tttttL # s B." +Maze$(365) = "###L LL L L # ### #" +Maze$(366) = "# LL Ltttt # ### #" +Maze$(367) = "# L L LL L L# # # #" +Maze$(368) = "#rrLL L ttttL# # # #" +Maze$(369) = "# rr rr L L# # # #" +Maze$(370) = "#W############ # # #" +Maze$(371) = ".Sss # #" +Maze$(372) = "##################.#" + +'M:60 +Maze$(373) = "################W#.#" +Maze$(374) = "# sB #" +Maze$(375) = "# ################L#" +Maze$(376) = "# #ttLL LL L LL L ." +Maze$(377) = "# #W##############W#" +Maze$(378) = "# sS sS." +Maze$(379) = "#W################W#" +Maze$(380) = ".B L B." +Maze$(381) = "####################" +Maze$(382) = "#W################W#" +Maze$(383) = ".S S." +Maze$(384) = "####################" + +'M:5 (5th row over) +Maze$(385) = "##################W#" +Maze$(386) = "##################S." +Maze$(387) = "####t t rrrrt##### #" +Maze$(388) = ". B L r LW## #" +Maze$(389) = "# B L B L #" +Maze$(390) = "############### W###" +Maze$(391) = ".#g g #sB#t#" +Maze$(392) = "############# ## # #" +Maze$(393) = ". L rr rr L# # #" +Maze$(394) = "################ # #" +Maze$(395) = ". L t ttk# D #" +Maze$(396) = "##################.#" + +'M:13 +Maze$(397) = "#W################.#" +Maze$(398) = ".B . #" +Maze$(399) = "################## #" +Maze$(400) = "#W##############W# #" +Maze$(401) = ".S B #" +Maze$(402) = "#W###############WD#" +Maze$(403) = ".B L L LL L L LL S #" +Maze$(404) = "# tttttt L ttLtt ###" +Maze$(405) = "#L LL rrrr rrL #k#" +Maze$(406) = "# rrLrr L rrrr L# #" +Maze$(407) = "# LL L L L L #L#" +Maze$(408) = "################.#.#" + +'M:21 +Maze$(409) = "#W##############.#.#" +Maze$(410) = ".Sk# ttttt LLt#D# #" +Maze$(411) = "####LLLLttttL##LL# #" +Maze$(412) = "#tttrrrLLLrrLrrL # #" +Maze$(413) = "##W#############W# #" +Maze$(414) = ". Ss sS #" +Maze$(415) = "# ################ #" +Maze$(416) = "# #LtLtt tttLL LL# #" +Maze$(417) = "# # LLL LLLLL L # #" +Maze$(418) = "# # ttttLLtttt L# #" +Maze$(419) = "# #L LLL LLL tL# #" +Maze$(420) = "#.#.##############.#" + +'M:29 +Maze$(421) = "#.#.##############.#" +Maze$(422) = "# # # #" +Maze$(423) = "# # ############ # #" +Maze$(424) = ". # # t# # #" +Maze$(425) = "#L# # ## ## tt# # #" +Maze$(426) = "# # # # ## #### # #" +Maze$(427) = "# # # # ## # # #" +Maze$(428) = ". # # # ## # ##W# #" +Maze$(429) = "### # # ## # # Ss #" +Maze$(430) = "# # # ## # # ##W#" +Maze$(431) = "# D # ## # # #kS#" +Maze$(432) = "#####.##.##.#.#.##.#" + +'M:37 +Maze$(433) = "#####.##.##.#.#.##.#" +Maze$(434) = "#rrt# # ## # # # #" +Maze$(435) = "#LrL# # ## # # #B #" +Maze$(436) = "#rr # # ## # # # #" +Maze$(437) = "# LL #D# ## # # # B#" +Maze$(438) = "# LLLL # ## # # # #" +Maze$(439) = "# tLt # ## # # #B #" +Maze$(440) = "#tLLLLL# ## # # # #" +Maze$(441) = "#tttLLL# ## # # # B#" +Maze$(442) = "#LL###L# ## # # # #" +Maze$(443) = "# t#k#t# ## # # # #" +Maze$(444) = "#.##.###.##.#.#.##.#" + +'M:45 +Maze$(445) = "#.##.###.##.#.#.##.#" +Maze$(446) = "# # # # ## # # # #" +Maze$(447) = "# # # # ## # # # #" +Maze$(448) = "# # # # ## # # # #" +Maze$(449) = "# # # # ## # # W# #" +Maze$(450) = "# # # # ## # # Ss #" +Maze$(451) = "#tt# # # ## # #### #" +Maze$(452) = "#tt# # # ## # #### #" +Maze$(453) = "#tt# # # ## # #### #" +Maze$(454) = "#tt# # # ## # #W## #" +Maze$(455) = "#tt# # # ##L# Ss #" +Maze$(456) = "####.###.##.######.#" + +'M:53 +Maze$(457) = "#W##.###.##.######.#" +Maze$(458) = ".Ss D #k # #rrrr #" +Maze$(459) = "#### # #### #rrt #" +Maze$(460) = ". # # tt #r#rr #" +Maze$(461) = "# # # L#r#tttt #" +Maze$(462) = "# # # tt #r#tttt #" +Maze$(463) = "# # # L #r#tttt #" +Maze$(464) = "# r# # tt #r#t L##W#" +Maze$(465) = "# r# #L L #r#ttt#rS." +Maze$(466) = "#r # # t L#W# ##W#" +Maze$(467) = "#r # # L sSs B." +Maze$(468) = "####.###############" + +'M:61 +Maze$(469) = "##W#.###############" +Maze$(470) = "#kB# ###############" +Maze$(471) = "#L # L L#" +Maze$(472) = ". ############### #" +Maze$(473) = "#W### tttL Lrrr # #" +Maze$(474) = ".Bs #Lttt LL ttt # #" +Maze$(475) = "#W# # tttL Lttt # #" +Maze$(476) = ".S# #L L LLL L # #" +Maze$(477) = "# # #L L L L L # #" +Maze$(478) = "# # #######WD###W# #" +Maze$(479) = ". # sS sS #" +Maze$(480) = "####################" + +'M:6 +Maze$(481) = "####################" +Maze$(482) = ". ########W#W#W#W###" +Maze$(483) = "# # D #ks B S S B #" +Maze$(484) = "# # # ############ #" +Maze$(485) = "# # # gLtgtttggg # #" +Maze$(486) = "# # # rttgrrggtt # #" +Maze$(487) = "# # # LgtggLttttg# #" +Maze$(488) = "# # # LtttLLtttr # #" +Maze$(489) = "# # # rttgLLgLttr# #" +Maze$(490) = "# # ############## #" +Maze$(491) = "# # # #" +Maze$(492) = "#.#.##############.#" + +'M:14 +Maze$(493) = "#.#.##W#W#W####W##D#" +Maze$(494) = "# # # B S S LS # #" +Maze$(495) = "# # # # # # t t# # #" +Maze$(496) = "# #L# # # #tLtL#L# #" +Maze$(497) = "# # # # # #LL t# # #" +Maze$(498) = "# # # # # #LL L# # #" +Maze$(499) = "# # # # # #tLLL# #L#" +Maze$(500) = "# # # # # #LLLL# # #" +Maze$(501) = "# #L# # # #LttL# # #" +Maze$(502) = "# # # # ##k s W # #" +Maze$(503) = "# # # # ## ### S # #" +Maze$(504) = "#.#.#.#.##.###.#.#.#" + +'M:22 +Maze$(505) = "#.#.#.#.##.###.#.#.#" +Maze$(506) = "# # # ###gggg L# # #" +Maze$(507) = "# # # #gggL ggg#k# #" +Maze$(508) = "# # #.#W########## #" +Maze$(509) = "# # S # #" +Maze$(510) = "# ##WL########## #D#" +Maze$(511) = "# # Ss #" +Maze$(512) = "# # ########W#####W#" +Maze$(513) = "# # #ttttLrrSrrrr S." +Maze$(514) = "# # #############WW#" +Maze$(515) = "# # s L BB." +Maze$(516) = "#.##.###############" + +'M:30 +Maze$(517) = "#.##.###############" +Maze$(518) = "# ##sD ." +Maze$(519) = "# #t#######W########" +Maze$(520) = "# #g# #r#ttB ." +Maze$(521) = "# # # #r############" +Maze$(522) = "# # # # #L ttLttt #" +Maze$(523) = "# # # # # tttttt ." +Maze$(524) = "#L# # # # L L rr L #" +Maze$(525) = "# # # # #B L #" +Maze$(526) = "# # # # #######W####" +Maze$(527) = "# # # # # Ssk ." +Maze$(528) = "#.#.#.#.#.##########" + +'M:38 +Maze$(529) = "#.W.#.#.#.W#########" +Maze$(530) = "# S # # Ss ." +Maze$(531) = "# # # # ########## #" +Maze$(532) = "# # # # #ttLtgL#k# ." +Maze$(533) = "# # # # #LtgLgt#L# #" +Maze$(534) = "# # # # # gttgL# # #" +Maze$(535) = "# # # # #LgLggL#L# #" +Maze$(536) = "# # # ### gtt t# # #" +Maze$(537) = "# # # ### LLL # # #" +Maze$(538) = "# # # #W#D#L t #L# #" +Maze$(539) = "# # # sS# # L # # #" +Maze$(540) = "#.#.#.#.#.######.#.#" + +'M:46 +Maze$(541) = "#.#.#.#.#.######.#.#" +Maze$(542) = "# # # # # #tttt# # #" +Maze$(543) = "# # # # #LL L# # #" +Maze$(544) = "# # # # WW## rt# # #" +Maze$(545) = "# # # # SSk#tLL# # #" +Maze$(546) = "# # # # ####LLL# # #" +Maze$(547) = "# # # ### tggt# # #" +Maze$(548) = "# # # # DLL ttr# # #" +Maze$(549) = "# # # # # gLgtg# # #" +Maze$(550) = "# # # # #LggLgt# # #" +Maze$(551) = "# # # # # gLLtg# #" +Maze$(552) = "#.#.#.#.############" + +'M:54 +Maze$(553) = "#.#.#.#.W########W##" +Maze$(554) = "# # # # Ss S ." +Maze$(555) = "# # # # ########## #" +Maze$(556) = "# # # # #LLtttttg# #" +Maze$(557) = "#L# # #L# LtLggt # #" +Maze$(558) = "# # # # #LLgttgLL# #" +Maze$(559) = "# # # # # ttrrt # #" +Maze$(560) = "# # #L# #LLttLLLL# ." +Maze$(561) = ". # # # # gtrL#D## #" +Maze$(562) = "### # # # rt #L # #" +Maze$(563) = ".k# # # # rgr # L# #" +Maze$(564) = "#.#.#.#.#######.##.#" + +'M:62 +Maze$(565) = "#.#.#.#.W####W#.##.#" +Maze$(566) = "# # # # B S # ." +Maze$(567) = "# # # ####W#####W###" +Maze$(568) = "# # # #tttS S ." +Maze$(569) = "# # # ##############" +Maze$(570) = "# # # ############W#" +Maze$(571) = "# # sS." +Maze$(572) = "# # ################" +Maze$(573) = "# # ." +Maze$(574) = "# ################W#" +Maze$(575) = "# L sB." +Maze$(576) = "####################" + +'M:7 +Maze$(577) = "##W#W##W###W#W#W#W##" +Maze$(578) = "#tB Ss Ss B S B S #" +Maze$(579) = "### ## ### # # # # #" +Maze$(580) = "# # # #t# # # # # #" +Maze$(581) = "# # # # # # # # # #" +Maze$(582) = "# # # # # # # # # #" +Maze$(583) = "# # # # # # # # # #" +Maze$(584) = "# # # # # # # # # #" +Maze$(585) = "# # # # # # # # # #" +Maze$(586) = "# # # #L# # # # # #" +Maze$(587) = "# # # # # # # # # #" +Maze$(588) = "#.#.##.#.#.#.#.#.#.#" + +'M:15 +Maze$(589) = "#.#.##.#.#.#.#.#.#.#" +Maze$(590) = "# #L # # #L# # #L# #" +Maze$(591) = "# # # # # # # # #L#" +Maze$(592) = "# # L# # # # # # # #" +Maze$(593) = "# # # # # # # # # #" +Maze$(594) = "# #L # # # #t# # # #" +Maze$(595) = "# # # # # #t# # # #" +Maze$(596) = "# # L# # # # # # # #" +Maze$(597) = "# # # # # # # # # #" +Maze$(598) = "# #L # # # #t# # # #" +Maze$(599) = "# # #L# # #t#L# # #" +Maze$(600) = "#.#.##.#.#.###.#.#.#" + +'M:23 +Maze$(601) = "#.#.##.#.#.###.#.#.#" +Maze$(602) = "# #k # # # #r# # # #" +Maze$(603) = "# #### # # #r# # # #" +Maze$(604) = "# #gt# # # # # # # #" +Maze$(605) = "# #gg# # # # # # # #" +Maze$(606) = "# ## # # # # # # # #" +Maze$(607) = "# # # #r# # #" +Maze$(608) = "#W###### W####W# # #" +Maze$(609) = ".S S B # #" +Maze$(610) = "#W#######W######W# #" +Maze$(611) = ".S B L sB #" +Maze$(612) = "################.#D#" + +'M:31 +Maze$(613) = "#W##############.# #" +Maze$(614) = ".Bs #t# # #" +Maze$(615) = "#W###### ### #t# # #" +Maze$(616) = ".S #t# #t# # #" +Maze$(617) = "########## # #t# # #" +Maze$(618) = "#W######## # #t#t# #" +Maze$(619) = ".S ## # #t#g# #" +Maze$(620) = "## rrgg ## # #t#t# #" +Maze$(621) = "########## #L# #t#L#" +Maze$(622) = "#W######## # # ### #" +Maze$(623) = ".B # # ## s#" +Maze$(624) = "##########.#.#.##.##" + +'M:39 +Maze$(625) = "#W########.#.#.##.W#" +Maze$(626) = ".S #### # #k B." +Maze$(627) = "#W##### # # #####" +Maze$(628) = ".S ### # # ." +Maze$(629) = "####D# #t# # #####W#" +Maze$(630) = "#tttt# # # # sB." +Maze$(631) = "#tttt# # # #######W#" +Maze$(632) = "#tttt# # # # sS." +Maze$(633) = "#tttt# # # # #######" +Maze$(634) = "# t# # # # # #####W#" +Maze$(635) = "#tt# # # # #rrrsS." +Maze$(636) = "######.#.#.#.#######" + +'M:47 +Maze$(637) = "##W###.#.#.#.####W##" +Maze$(638) = "#kS # # sB #" +Maze$(639) = "########W# ####### #" +Maze$(640) = "# r# #L BsD # # #" +Maze$(641) = "# # #ttt## # # # #" +Maze$(642) = "# # #tttt# # # # #" +Maze$(643) = "# # #tttt# # # # #" +Maze$(644) = "# # #tLtt# # # # #" +Maze$(645) = "# # #tttL# # # # #" +Maze$(646) = "# # ###### # # # #" +Maze$(647) = "# # # # # # #" +Maze$(648) = "####.####.#.#.####.#" + +'M:55 +Maze$(649) = "##W#.####.#.#.####.#" +Maze$(650) = ". B# #### #" +Maze$(651) = "# W######## ### #" +Maze$(652) = "# B # # # ####" +Maze$(653) = "# tt # # # # k#" +Maze$(654) = "########### # # # L#" +Maze$(655) = "#W# rtttg # # # # #" +Maze$(656) = ".B# tttgg # # # #LL#" +Maze$(657) = "### tgttt D# # # #" +Maze$(658) = "# rgttt ### # # # L#" +Maze$(659) = "#gttgtt ### # #L #" +Maze$(660) = "#########.###.#.##.#" + +'M:63 +Maze$(661) = "#W#######.###.#.##.#" +Maze$(662) = ".Bs # # #" +Maze$(663) = "#W########### # # #" +Maze$(664) = ".Bs # # #" +Maze$(665) = "############# # # #" +Maze$(666) = "#W########### # # #" +Maze$(667) = ".Bs # # #" +Maze$(668) = "#W############# # #" +Maze$(669) = ".Bs ." +Maze$(670) = "#W################W#" +Maze$(671) = ".Bs B." +Maze$(672) = "####################" + +'M:8 +Maze$(673) = "#####W#W#W###W#W#W##" +Maze$(674) = "#k## S B B ##S S S #" +Maze$(675) = "# ## # #D# # # # # #" +Maze$(676) = "# ## # # # # # # # #" +Maze$(677) = "# ## # # # # # # # #" +Maze$(678) = "# ## # # # # # # # #" +Maze$(679) = "# ## # # # # # # # #" +Maze$(680) = "# ## # # # # # # # #" +Maze$(681) = "# ## # # # # # # # #" +Maze$(682) = "# ## # # # # # # # #" +Maze$(683) = "# ## # # # # # # # #" +Maze$(684) = "#.##.#.#.#.#.#.#.#.#" + +'M:16 +Maze$(685) = "#.##.#.#.#.#.#.#.#.#" +Maze$(686) = "# ## # # # # #L# #L#" +Maze$(687) = "# ## # # # # #t# # #" +Maze$(688) = "# ## # # # # #g# # #" +Maze$(689) = "# ## # # # # ### # #" +Maze$(690) = "# ## # # # # ### # #" +Maze$(691) = "# ## # #L# # ### # #" +Maze$(692) = "# ## # # # # ### # #" +Maze$(693) = "# ## # # # # ### # #" +Maze$(694) = "# ## # # # # ### # #" +Maze$(695) = "# ##L# # # # ### # #" +Maze$(696) = "#.##.#.#.#.#.###.#.#" + +'M:24 +Maze$(697) = "#.##.#.#.#.#.##W.#.#" +Maze$(698) = "# ## # # # # # S # #" +Maze$(699) = "# ## # # # # # # # #" +Maze$(700) = "# ## # # # # # # # #" +Maze$(701) = "# ## # # # # # # # #" +Maze$(702) = "# ## # # #L# # # # #" +Maze$(703) = "# ## #L# # # # # # #" +Maze$(704) = "# ## # # # # # # # #" +Maze$(705) = "# ## # # # # # # # #" +Maze$(706) = "# ## # # # # W # # #" +Maze$(707) = "# ## # # # # S # # #" +Maze$(708) = "#.##.#.#.#.#.###.#.#" + +'M:32 +Maze$(709) = "#.##.#.#.#.#.###.#.#" +Maze$(710) = "# ## # # # #D# # # #" +Maze$(711) = "# ## # # # # # # # #" +Maze$(712) = "# ## # # # #L# # # #" +Maze$(713) = "# ## #L# # # # # # #" +Maze$(714) = "# ## # # # # # # # #" +Maze$(715) = "# ## # # # # # # # #" +Maze$(716) = "# ## # # # # # # # #" +Maze$(717) = "# ## # # # # # # # #" +Maze$(718) = "# ## # # # W W # # #" +Maze$(719) = "# ##k# # # B S # # #" +Maze$(720) = "#.####.#.#.#.###.#.#" + +'M:40 +Maze$(721) = "#.####.#.#.#.###.#.#" +Maze$(722) = ". # #t# # # ### # #" +Maze$(723) = "#W# #W# # # ### # #" +Maze$(724) = ".S S # # ### # #" +Maze$(725) = "####W#W# # # ### # #" +Maze$(726) = ". BsB # # ### # #" +Maze$(727) = "#W###### # # ### # #" +Maze$(728) = ".S # # ### # #" +Maze$(729) = "######## # # ### # #" +Maze$(730) = "##W###r# # # ### # #" +Maze$(731) = ". S k# #D# # ### # #" +Maze$(732) = "#.####.#.#.#.###.#.#" + + +'M:48 +Maze$(733) = "#.####.#.#.#.###.#.#" +Maze$(734) = "# # # # # ###L# #" +Maze$(735) = "# # # # # # ###t# #" +Maze$(736) = "# # # #L# # ##### #" +Maze$(737) = "# # # # # # ###t# #" +Maze$(738) = "# # # #k# # ### # #" +Maze$(739) = "# # # ### # ### #L#" +Maze$(740) = "# # # #t# # ### # #" +Maze$(741) = "# # # #t# # ### # #" +Maze$(742) = "# # # # # # ### # #" +Maze$(743) = "# # #L# # # ### #D#" +Maze$(744) = "#.##.#.#.#.#.###.#.#" + +'M:56 +Maze$(745) = "#.##.#.#.#.#.###.#.#" +Maze$(746) = "# ## # # # #k### # #" +Maze$(747) = "# ## # # # ###W# # #" +Maze$(748) = "# ## # # # B # #" +Maze$(749) = "# ## # # ####W##D# #" +Maze$(750) = "# ## #L# #tttBttr# #" +Maze$(751) = "# ## # # #gttt L# #" +Maze$(752) = "# ## # # # trtSgL# #" +Maze$(753) = "# ## # # #rr rtrt# #" +Maze$(754) = "# #W # # #rtBgggt# #" +Maze$(755) = "# sB # # #gg ttrt# #" +Maze$(756) = "#.##.#.#.#########.#" + +'M:64 +Maze$(757) = "#.##.#.#.#########.#" +Maze$(758) = "# # # # #ttt rrt# #" +Maze$(759) = "# #L# # ####t tt# #" +Maze$(760) = "# # # # # r rrr # #" +Maze$(761) = "# t# # # #Lrttrt # #" +Maze$(762) = "#t # # # # rrLrrL# #" +Maze$(763) = "# t#k# # #Stt tt # #" +Maze$(764) = "###### # #L L# #" +Maze$(765) = ". # # # #" +Maze$(766) = "######W#.#####W# # #" +Maze$(767) = ". Ss SsD #" +Maze$(768) = "####################" +Return + +Makedotobj: +Data !?Short sword,!?Warriors sword,!?Magical sword +Data $/Amulet,%@Waters of healing,$/statue of a golden eagle +Data !?Whip,!?Knife,!?Shield +Data $/Chalice,$/bunch of golden coins,%/Healing potion +Data !?Iron fist,!?Detonator,%@Spider Antidote +Data |/Nothing at all + +Wallcols: +Data 12,4,6,2,5,7,8,14,8,11,9,1,4,2,2,1,2,3,10,1,8,8 +Data 2,13,2,5,6,7,9,11,3,3,4,6,12,9,3,5,7,2,4,12,9,4 +Data 5,8,9,7,1,3,6,2,4,5,13,11,12,11,10,9,14,15,13,1 + +Wallbord: +Data 4,12,13,14,15,1,14,2,9,2,4,7,3,13,8,9,4,2,14,8,7 +Data 1,13,3,15,4,4,10,2,4,14,1,11,14,1,1,13,12,14,14 +Data 10,2,14,14,12,9,8,11,10,14,12,9,13,14,9,1,2,3,4 +Data 5,8,8,2,14 + +Sub Cleardotarea + Line (Sx - 4, Sy)-(Sx + 23, Sy + 35), 0, BF + Return +End Sub + +Sub CopydotPlayer + Line (CIX1 + 15, CIY1 + 23)-(CIX1 + 37, CIY1 + 45), 0, BF + Circle (CIX1 + 28, CIY1 + 35), 10, 15: Paint (CIX1 + 28, CIY1 + 35), 15 + Circle (CIX1 + 28, CIY1 + 35), 10, 6: Circle (CIX1 + 28, CIY1 + 35), 9, 6 + For E = 1 To 5: Circle (CIX1 + 28, CIY1 + 35), E, 0: Next + Circle (CIX1 + 28, CIY1 + 35), 1, 0 + Get (CIX1 + 15, CIY1 + 23)-(CIX1 + 37, CIY1 + 45), Player%() + Return + +End Sub diff --git a/samples/microsoft.md b/samples/microsoft.md index 2f09efda..046f6399 100644 --- a/samples/microsoft.md +++ b/samples/microsoft.md @@ -8,7 +8,73 @@ A turn-based artillery game by Microsoft. -**[Sort demo](sort-demo/index.md)** +**[Money](money/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) + +Money manager by Microsoft. + +**[Nibbles](nibbles/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [snake](snake.md) + +Snake clone by Microsoft. + +**[Phone](phone/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) + +Simple phone directory by Microsoft. + +**[QBlocks](qblocks/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [tetris](tetris.md) + +Tetris clone by Microsoft. + +**[QBricks](qbricks/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [breakout](breakout.md) + +Breakout clone by Microsoft. + +**[QCards](qcards/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) + +A simple database using a cardfile user interface by Microsoft. + +**[QMaze](qmaze/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [maze](maze.md) + +Maze puzzle game by Microsoft. + +**[QShips](qships/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [artillery](artillery.md) + +Turn-based artillery game by Microsoft. + +**[QSpace](qspace/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [defense](defense.md) + +Space station defense game by Microsoft. + +**[QSynth](qsynth/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [sound](sound.md), [music](music.md) + +Audio synthesizer by Microsoft. + +**[Reversi](reversi/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md) + +Reversi game by Microsoft. + +**[Sort Demo](sort-demo/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [sort](sort.md) diff --git a/samples/money/img/screenshot.png b/samples/money/img/screenshot.png new file mode 100644 index 00000000..b5474353 Binary files /dev/null and b/samples/money/img/screenshot.png differ diff --git a/samples/money/index.md b/samples/money/index.md new file mode 100644 index 00000000..fc76d1d4 --- /dev/null +++ b/samples/money/index.md @@ -0,0 +1,22 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: MONEY + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Money manager by Microsoft. +``` + +### File(s) + +* [money.bas](src/money.bas) +* [money.zip](src/money.zip) + +🔗 [data management](../data-management.md) diff --git a/samples/money/src/money.bas b/samples/money/src/money.bas new file mode 100644 index 00000000..e15bbd7f --- /dev/null +++ b/samples/money/src/money.bas @@ -0,0 +1,1534 @@ +' Q B a s i c M O N E Y M A N A G E R +' +' Copyright (C) Microsoft Corporation 1990 +' +' The Money Manager is a personal finance manager that allows you +' to enter account transactions while tracking your account balances +' and net worth. +' +' To run this program, press Shift+F5. +' +' To exit QBasic, press Alt, F, X. +' +' To get help on a BASIC keyword, move the cursor to the keyword and press +' F1 or click the right mouse button. +' + + +'Set default data type to integer for faster operation +DefInt A-Z + +'Sub and function declarations +DECLARE SUB TransactionSummary (item%) +DECLARE SUB LCenter (text$) +DECLARE SUB ScrollUp () +DECLARE SUB ScrollDown () +DECLARE SUB Initialize () +DECLARE SUB Intro () +DECLARE SUB SparklePause () +DECLARE SUB Center (row%, text$) +DECLARE SUB FancyCls (dots%, Background%) +DECLARE SUB LoadState () +DECLARE SUB SaveState () +DECLARE SUB MenuSystem () +DECLARE SUB MakeBackup () +DECLARE SUB RestoreBackup () +DECLARE SUB Box (Row1%, Col1%, Row2%, Col2%) +DECLARE SUB NetWorthReport () +DECLARE SUB EditAccounts () +DECLARE SUB PrintHelpLine (help$) +DECLARE SUB EditTrans (item%) +DECLARE FUNCTION Cvdt$ (X#) +DECLARE FUNCTION Cvst$ (X!) +DECLARE FUNCTION Cvit$ (X%) +DECLARE FUNCTION Menu% (CurrChoiceX%, MaxChoice%, choice$(), ItemRow%(), ItemCol%(), help$(), BarMode%) +DECLARE FUNCTION GetString$ (row%, col%, start$, end$, Vis%, Max%) +DECLARE FUNCTION Trim$ (X$) + +'Constants +Const FALSE = 0, TRUE = Not FALSE + +'User-defined types +Type AccountType + Title As String * 20 + AType As String * 1 + Desc As String * 50 +End Type + +Type Recordtype + Date As String * 8 + Ref As String * 10 + Desc As String * 50 + Fig1 As Double + Fig2 As Double +End Type + +'Global variables +Dim Shared account(1 To 19) As AccountType 'Stores the 19 account titles +Dim Shared ColorPref 'Color Preference +Dim Shared colors(0 To 20, 1 To 4) 'Different Colors +Dim Shared ScrollUpAsm(1 To 7) 'Assembly Language Routines +Dim Shared ScrollDownAsm(1 To 7) +Dim Shared PrintErr As Integer 'Printer error flag + +Def Seg = 0 ' Turn off CapLock, NumLock and ScrollLock +KeyFlags = Peek(1047) +Poke 1047, &H0 +Def Seg + +'Open money manager data file. If it does not exist in current directory, +' goto error handler to create and initialize it. +On Error GoTo ErrorTrap +Open "money.dat" For Input As #1 +Close +On Error GoTo 0 'Reset error handler + +Initialize 'Initialize program +Intro 'Display introduction screen +MenuSystem 'This is the main program +Color 7, 0 'Clear screen and end +Cls + +Def Seg = 0 ' Restore CapLock, NumLock and ScrollLock states +Poke 1047, KeyFlags +Def Seg + +System 0 + +' Error handler for program +' If data file not found, create and initialize a new one. +ErrorTrap: +Select Case Err + ' If data file not found, create and initialize a new one. + Case 53 + Close + ColorPref = 1 + For a = 1 To 19 + account(a).Title = "" + account(a).AType = "" + account(a).Desc = "" + Next a + SaveState + Resume + Case 24, 25 + PrintErr = TRUE + Box 8, 13, 14, 69 + Center 11, "Printer not responding ... Press Space to continue" + While InKey$ <> "": Wend + While InKey$ <> " ": Wend + Resume Next + Case Else +End Select +Resume Next + + +'The following data defines the color schemes available via the main menu. +' +' scrn dots bar back title shdow choice curs cursbk shdow +Data 0,7,15,7,0,7,0,15,0,0 +Data 1,9,12,3,0,1,15,0,7,0 +Data 3,15,13,1,14,3,15,0,7,0 +Data 7,12,15,4,14,0,15,15,1,0 + +'The following data is actually a machine language program to +'scroll the screen up or down very fast using a BIOS call. +Data &HB8,&H01,&H06,&HB9,&H01,&H04,&HBA,&H4E,&H16,&HB7,&H00,&HCD,&H10,&HCB +Data &HB8,&H01,&H07,&HB9,&H01,&H04,&HBA,&H4E,&H16,&HB7,&H00,&HCD,&H10,&HCB + +'Box: +' Draw a box on the screen between the given coordinates. +Sub Box (Row1, Col1, Row2, Col2) Static + + BoxWidth = Col2 - Col1 + 1 + + Locate Row1, Col1 + Print ""; String$(BoxWidth - 2, ""); ""; + + For a = Row1 + 1 To Row2 - 1 + Locate a, Col1 + Print ""; Space$(BoxWidth - 2); ""; + Next a + + Locate Row2, Col1 + Print ""; String$(BoxWidth - 2, ""); ""; + +End Sub + +'Center: +' Center text on the given row. +Sub Center (row, text$) + Locate row, 41 - Len(text$) / 2 + Print text$; +End Sub + +'Cvdt$: +' Convert a double precision number to a string WITHOUT a leading space. +Function Cvdt$ (X#) + + Cvdt$ = Right$(Str$(X#), Len(Str$(X#)) - 1) + +End Function + +'Cvit$: +' Convert an integer to a string WITHOUT a leading space. +Function Cvit$ (X) + Cvit$ = Right$(Str$(X), Len(Str$(X)) - 1) +End Function + +'Cvst$: +' Convert a single precision number to a string WITHOUT a leading space +Function Cvst$ (X!) + Cvst$ = Right$(Str$(X!), Len(Str$(X!)) - 1) +End Function + +'EditAccounts: +' This is the full-screen editor which allows you to change your account +' titles and descriptions +Sub EditAccounts + + 'Information about each column + ReDim help$(4), col(4), Vis(4), Max(4), edit$(19, 3) + + 'Draw the screen + Color colors(7, ColorPref), colors(4, ColorPref) + Box 2, 1, 24, 80 + + Color colors(5, ColorPref), colors(4, ColorPref) + Locate 1, 1: Print Space$(80) + Locate 1, 4: Print "Account Editor"; + Color colors(7, ColorPref), colors(4, ColorPref) + + Locate 3, 2: Print "No Account Title Description A/L" + Locate 4, 2: Print "" + u$ = "##\ \\ \ ! " + For a = 5 To 23 + Locate a, 2 + X = a - 4 + Print Using u$; X; account(X).Title; account(X).Desc; account(X).AType; + Next a + + 'Initialize variables + help$(1) = " Account name | " + help$(2) = " Account description | " + help$(3) = " Account type (A = Asset, L = Liability) | " + + col(1) = 5: col(2) = 26: col(3) = 78 + Vis(1) = 20: Vis(2) = 50: Vis(3) = 1 + Max(1) = 20: Max(2) = 50: Max(3) = 1 + + For a = 1 To 19 + edit$(a, 1) = account(a).Title + edit$(a, 2) = account(a).Desc + edit$(a, 3) = account(a).AType + Next a + + finished = FALSE + + CurrRow = 1 + CurrCol = 1 + PrintHelpLine help$(CurrCol) + + 'Loop until F2 or is pressed + Do + GoSub EditAccountsShowCursor 'Show Cursor + Do 'Wait for key + Kbd$ = InKey$ + Loop Until Kbd$ <> "" + + If Kbd$ >= " " And Kbd$ < "~" Then 'If legal, edit item + GoSub EditAccountsEditItem + End If + GoSub EditAccountsHideCursor 'Hide Cursor so it can move + 'If it needs to + Select Case Kbd$ + Case Chr$(0) + "H" 'Up Arrow + CurrRow = (CurrRow + 17) Mod 19 + 1 + Case Chr$(0) + "P" 'Down Arrow + CurrRow = (CurrRow) Mod 19 + 1 + Case Chr$(0) + "K", Chr$(0) + Chr$(15) 'Left or Shift+Tab + CurrCol = (CurrCol + 1) Mod 3 + 1 + PrintHelpLine help$(CurrCol) + Case Chr$(0) + "M", Chr$(9) 'Right or Tab + CurrCol = (CurrCol) Mod 3 + 1 + PrintHelpLine help$(CurrCol) + Case Chr$(0) + "<" 'F2 + finished = TRUE + Save = TRUE + Case Chr$(27) 'Esc + finished = TRUE + Save = FALSE + Case Chr$(13) 'Return + Case Else + Beep + End Select + Loop Until finished + + If Save Then + GoSub EditAccountsSaveData + End If + + Exit Sub + + EditAccountsShowCursor: + Color colors(8, ColorPref), colors(9, ColorPref) + Locate CurrRow + 4, col(CurrCol) + Print Left$(edit$(CurrRow, CurrCol), Vis(CurrCol)); + Return + + EditAccountsEditItem: + Color colors(8, ColorPref), colors(9, ColorPref) + ok = FALSE + start$ = Kbd$ + Do + Kbd$ = GetString$(CurrRow + 4, col(CurrCol), start$, end$, Vis(CurrCol), Max(CurrCol)) + edit$(CurrRow, CurrCol) = Left$(end$ + Space$(Max(CurrCol)), Max(CurrCol)) + start$ = "" + + If CurrCol = 3 Then + X$ = UCase$(end$) + If X$ = "A" Or X$ = "L" Or X$ = "" Or X$ = " " Then + ok = TRUE + If X$ = "" Then X$ = " " + edit$(CurrRow, CurrCol) = X$ + Else + Beep + End If + Else + ok = TRUE + End If + + Loop Until ok + Return + + EditAccountsHideCursor: + Color colors(7, ColorPref), colors(4, ColorPref) + Locate CurrRow + 4, col(CurrCol) + Print Left$(edit$(CurrRow, CurrCol), Vis(CurrCol)); + Return + + + EditAccountsSaveData: + For a = 1 To 19 + account(a).Title = edit$(a, 1) + account(a).Desc = edit$(a, 2) + account(a).AType = edit$(a, 3) + Next a + SaveState + Return + +End Sub + +'EditTrans: +' This is the full-screen editor which allows you to enter and change +' transactions +Sub EditTrans (item) + + 'Stores info about each column + ReDim help$(6), col(6), Vis(6), Max(6), CurrString$(3), CurrFig#(5) + 'Array to keep the current balance at all the transactions + ReDim Balance#(1000) + + 'Open random access file + file$ = "money." + Cvit$(item) + Open file$ For Random As #1 Len = 84 + Field #1, 8 As IoDate$, 10 As IoRef$, 50 As IoDesc$, 8 As IoFig1$, 8 As IoFig2$ + Field #1, 11 As valid$, 5 As IoMaxRecord$, 8 As IoBalance$ + + 'Initialize variables + CurrString$(1) = "" + CurrString$(2) = "" + CurrString$(3) = "" + CurrFig#(4) = 0 + CurrFig#(5) = 0 + + Get #1, 1 + If valid$ <> "THISISVALID" Then + LSet IoDate$ = "" + LSet IoRef$ = "" + LSet IoDesc$ = "" + LSet IoFig1$ = MKD$(0) + LSet IoFig2$ = MKD$(0) + Put #1, 2 + LSet valid$ = "THISISVALID" + LSet IoMaxRecord$ = "1" + LSet IoBalance$ = MKD$(0) + Put #1, 1 + End If + + MaxRecord = Val(IoMaxRecord$) + + Balance#(0) = 0 + a = 1 + While a <= MaxRecord + Get #1, a + 1 + Balance#(a) = Balance#(a - 1) + CVD(IoFig1$) - CVD(IoFig2$) + a = a + 1 + Wend + GoSub EditTransWriteBalance + + help$(1) = "Date of transaction (mm/dd/yy) " + help$(2) = "Transaction reference number " + help$(3) = "Transaction description " + help$(4) = "Increase asset or debt value " + help$(5) = "Decrease asset or debt value " + + col(1) = 2 + col(2) = 11 + col(3) = 18 + col(4) = 44 + col(5) = 55 + + Vis(1) = 8 + Vis(2) = 6 + Vis(3) = 25 + Vis(4) = 10 + Vis(5) = 10 + + Max(1) = 8 + Max(2) = 6 + Max(3) = 25 + Max(4) = 10 + Max(5) = 10 + + + 'Draw Screen + Color colors(7, ColorPref), colors(4, ColorPref) + Box 2, 1, 24, 80 + + Color colors(5, ColorPref), colors(4, ColorPref) + Locate 1, 1: Print Space$(80); + Locate 1, 4: Print "Transaction Editor: " + Trim$(account(item).Title); + + Color colors(7, ColorPref), colors(4, ColorPref) + Locate 3, 2: Print " Date Ref# Description Increase Decrease Balance " + Locate 4, 2: Print "" + + u$ = "\ \\ \\ \" + u1$ = " " + u1x$ = "߳߳߳߳߳" + u2$ = "###,###.##" + u3$ = "###,###,###.##" + u4$ = " " + + CurrTopline = 1 + GoSub EditTransPrintWholeScreen + + CurrRow = 1 + CurrCol = 1 + PrintHelpLine help$(CurrCol) + "| " + + GoSub EditTransGetLine + + finished = FALSE + + + 'Loop until is pressed + Do + GoSub EditTransShowCursor 'Show Cursor, Wait for key + Do: Kbd$ = InKey$: Loop Until Kbd$ <> "" + GoSub EditTransHideCursor + + If Kbd$ >= " " And Kbd$ < "~" Or Kbd$ = Chr$(8) Then 'If legal key, edit item + GoSub EditTransEditItem + End If + + Select Case Kbd$ 'Handle Special keys + Case Chr$(0) + "H" 'up arrow + GoSub EditTransMoveUp + Case Chr$(0) + "P" 'Down arrow + GoSub EditTransMoveDown + Case Chr$(0) + "K", Chr$(0) + Chr$(15) 'Left Arrow,BackTab + CurrCol = (CurrCol + 3) Mod 5 + 1 + PrintHelpLine help$(CurrCol) + "| " + Case Chr$(0) + "M", Chr$(9) 'Right Arrow,Tab + CurrCol = (CurrCol) Mod 5 + 1 + PrintHelpLine help$(CurrCol) + "| " + Case Chr$(0) + "G" 'Home + CurrCol = 1 + Case Chr$(0) + "O" 'End + CurrCol = 5 + Case Chr$(0) + "I" 'Page Up + CurrRow = 1 + CurrTopline = CurrTopline - 19 + If CurrTopline < 1 Then + CurrTopline = 1 + End If + GoSub EditTransPrintWholeScreen + GoSub EditTransGetLine + Case Chr$(0) + "Q" 'Page Down + CurrRow = 1 + CurrTopline = CurrTopline + 19 + If CurrTopline > MaxRecord Then + CurrTopline = MaxRecord + End If + GoSub EditTransPrintWholeScreen + GoSub EditTransGetLine + Case Chr$(0) + "<" 'F2 + finished = TRUE + Case Chr$(0) + "C" 'F9 + GoSub EditTransAddRecord + Case Chr$(0) + "D" 'F10 + GoSub EditTransDeleteRecord + Case Chr$(13) 'Enter + Case Else + Beep + End Select + Loop Until finished + + Close + + Exit Sub + + + EditTransShowCursor: + Color colors(8, ColorPref), colors(9, ColorPref) + Locate CurrRow + 4, col(CurrCol) + Select Case CurrCol + Case 1, 2, 3 + Print Left$(CurrString$(CurrCol), Vis(CurrCol)); + Case 4 + If CurrFig#(4) <> 0 Then + Print Using u2$; CurrFig#(4); + Else + Print Space$(Vis(CurrCol)); + End If + Case 5 + If CurrFig#(5) <> 0 Then + Print Using u2$; CurrFig#(5); + Else + Print Space$(Vis(CurrCol)); + End If + End Select + Return + + + EditTransHideCursor: + Color colors(7, ColorPref), colors(4, ColorPref) + Locate CurrRow + 4, col(CurrCol) + Select Case CurrCol + Case 1, 2, 3 + Print Left$(CurrString$(CurrCol), Vis(CurrCol)); + Case 4 + If CurrFig#(4) <> 0 Then + Print Using u2$; CurrFig#(4); + Else + Print Space$(Vis(CurrCol)); + End If + Case 5 + If CurrFig#(5) <> 0 Then + Print Using u2$; CurrFig#(5); + Else + Print Space$(Vis(CurrCol)); + End If + End Select + Return + + + EditTransEditItem: + + CurrRecord = CurrTopline + CurrRow - 1 + Color colors(8, ColorPref), colors(9, ColorPref) + + Select Case CurrCol + Case 1, 2, 3 + Kbd$ = GetString$(CurrRow + 4, col(CurrCol), Kbd$, new$, Vis(CurrCol), Max(CurrCol)) + CurrString$(CurrCol) = new$ + GoSub EditTransPutLine + GoSub EditTransGetLine + Case 4 + start$ = Kbd$ + Do + Kbd$ = GetString$(CurrRow + 4, col(4), start$, new$, Vis(4), Max(4)) + new4# = Val(new$) + start$ = "" + Loop While new4# >= 999999.99# Or new4# < 0 + + a = CurrRecord + While a <= MaxRecord + Balance#(a) = Balance#(a) + new4# - CurrFig#(4) + CurrFig#(5) + a = a + 1 + Wend + CurrFig#(4) = new4# + CurrFig#(5) = 0 + GoSub EditTransPutLine + GoSub EditTransGetLine + GoSub EditTransPrintBalances + GoSub EditTransWriteBalance + Case 5 + start$ = Kbd$ + Do + Kbd$ = GetString$(CurrRow + 4, col(5), start$, new$, Vis(5), Max(5)) + new5# = Val(new$) + start$ = "" + Loop While new5# >= 999999.99# Or new5# < 0 + + a = CurrRecord + While a <= MaxRecord + Balance#(a) = Balance#(a) - new5# + CurrFig#(5) - CurrFig#(4) + a = a + 1 + Wend + CurrFig#(4) = 0 + CurrFig#(5) = new5# + GoSub EditTransPutLine + GoSub EditTransGetLine + GoSub EditTransPrintBalances + GoSub EditTransWriteBalance + Case Else + End Select + GoSub EditTransPrintLine + Return + + EditTransMoveUp: + If CurrRow = 1 Then + If CurrTopline = 1 Then + Beep + Else + ScrollDown + CurrTopline = CurrTopline - 1 + GoSub EditTransGetLine + GoSub EditTransPrintLine + End If + Else + CurrRow = CurrRow - 1 + GoSub EditTransGetLine + End If + Return + + EditTransMoveDown: + If (CurrRow + CurrTopline - 1) >= MaxRecord Then + Beep + Else + If CurrRow = 19 Then + ScrollUp + CurrTopline = CurrTopline + 1 + GoSub EditTransGetLine + GoSub EditTransPrintLine + Else + CurrRow = CurrRow + 1 + GoSub EditTransGetLine + End If + End If + Return + + EditTransPrintLine: + Color colors(7, ColorPref), colors(4, ColorPref) + CurrRecord = CurrTopline + CurrRow - 1 + Locate CurrRow + 4, 2 + If CurrRecord = MaxRecord + 1 Then + Print u1x$; + ElseIf CurrRecord > MaxRecord Then + Print u1$; + Else + Print Using u$; CurrString$(1); CurrString$(2); CurrString$(3); + If CurrFig#(4) = 0 And CurrFig#(5) = 0 Then + Print Using u4$ + "" + u4$ + "" + u3$; Balance#(CurrRecord) + ElseIf CurrFig#(5) = 0 Then + Print Using u2$ + "" + u4$ + "" + u3$; CurrFig#(4); Balance#(CurrRecord) + Else + Print Using u4$ + "" + u2$ + "" + u3$; CurrFig#(5); Balance#(CurrRecord) + End If + End If + Return + + EditTransPrintBalances: + Color colors(7, ColorPref), colors(4, ColorPref) + For a = 1 To 19 + CurrRecord = CurrTopline + a - 1 + If CurrRecord <= MaxRecord Then + Locate 4 + a, 66 + Print Using u3$; Balance#(CurrTopline + a - 1); + End If + Next a + Return + + EditTransDeleteRecord: + If MaxRecord = 1 Then + Beep + Else + CurrRecord = CurrTopline + CurrRow - 1 + MaxRecord = MaxRecord - 1 + a = CurrRecord + While a <= MaxRecord + Get #1, a + 2 + Put #1, a + 1 + Balance#(a) = Balance#(a + 1) - CurrFig#(4) + CurrFig#(5) + a = a + 1 + Wend + + LSet valid$ = "THISISVALID" + LSet IoMaxRecord$ = Cvit$(MaxRecord) + Put #1, 1 + GoSub EditTransPrintWholeScreen + CurrRecord = CurrTopline + CurrRow - 1 + If CurrRecord > MaxRecord Then + GoSub EditTransMoveUp + End If + GoSub EditTransGetLine + GoSub EditTransWriteBalance + End If + Return + + EditTransAddRecord: + CurrRecord = CurrTopline + CurrRow - 1 + a = MaxRecord + While a > CurrRecord + Get #1, a + 1 + Put #1, a + 2 + Balance#(a + 1) = Balance#(a) + a = a - 1 + Wend + Balance#(CurrRecord + 1) = Balance#(CurrRecord) + MaxRecord = MaxRecord + 1 + LSet IoDate$ = "" + LSet IoRef$ = "" + LSet IoDesc$ = "" + LSet IoFig1$ = MKD$(0) + LSet IoFig2$ = MKD$(0) + Put #1, CurrRecord + 2 + + LSet valid$ = "THISISVALID" + LSet IoMaxRecord$ = Cvit$(MaxRecord) + Put #1, 1 + GoSub EditTransPrintWholeScreen + GoSub EditTransGetLine + Return + + EditTransPrintWholeScreen: + temp = CurrRow + For CurrRow = 1 To 19 + CurrRecord = CurrTopline + CurrRow - 1 + If CurrRecord <= MaxRecord Then + GoSub EditTransGetLine + End If + GoSub EditTransPrintLine + Next CurrRow + CurrRow = temp + Return + + EditTransWriteBalance: + Get #1, 1 + LSet IoBalance$ = MKD$(Balance#(MaxRecord)) + Put #1, 1 + Return + + EditTransPutLine: + CurrRecord = CurrTopline + CurrRow - 1 + LSet IoDate$ = CurrString$(1) + LSet IoRef$ = CurrString$(2) + LSet IoDesc$ = CurrString$(3) + LSet IoFig1$ = MKD$(CurrFig#(4)) + LSet IoFig2$ = MKD$(CurrFig#(5)) + Put #1, CurrRecord + 1 + Return + + EditTransGetLine: + CurrRecord = CurrTopline + CurrRow - 1 + Get #1, CurrRecord + 1 + CurrString$(1) = IoDate$ + CurrString$(2) = IoRef$ + CurrString$(3) = IoDesc$ + CurrFig#(4) = CVD(IoFig1$) + CurrFig#(5) = CVD(IoFig2$) + Return +End Sub + +'FancyCls: +' Clears screen in the right color, and draws nice dots. +Sub FancyCls (dots, Background) + + View Print 2 To 24 + Color dots, Background + Cls 2 + + For a = 95 To 1820 Step 45 + row = a / 80 + 1 + col = a Mod 80 + 1 + Locate row, col + Print Chr$(250); + Next a + + View Print + +End Sub + +'GetString$: +' Given a row and col, and an initial string, edit a string +' VIS is the length of the visible field of entry +' MAX is the maximum number of characters allowed in the string +Function GetString$ (row, col, start$, end$, Vis, Max) + curr$ = Trim$(Left$(start$, Max)) + If curr$ = Chr$(8) Then curr$ = "" + + Locate , , 1 + + finished = FALSE + Do + GoSub GetStringShowText + GoSub GetStringGetKey + + If Len(Kbd$) > 1 Then + finished = TRUE + GetString$ = Kbd$ + Else + Select Case Kbd$ + Case Chr$(13), Chr$(27), Chr$(9) + finished = TRUE + GetString$ = Kbd$ + + Case Chr$(8) + If curr$ <> "" Then + curr$ = Left$(curr$, Len(curr$) - 1) + End If + + Case " " TO "}" + If Len(curr$) < Max Then + curr$ = curr$ + Kbd$ + Else + Beep + End If + + Case Else + Beep + End Select + End If + + Loop Until finished + + end$ = curr$ + Locate , , 0 + Exit Function + + + GetStringShowText: + Locate row, col + If Len(curr$) > Vis Then + Print Right$(curr$, Vis); + Else + Print curr$; Space$(Vis - Len(curr$)); + Locate row, col + Len(curr$) + End If + Return + + GetStringGetKey: + Kbd$ = "" + While Kbd$ = "" + Kbd$ = InKey$ + Wend + Return +End Function + +'Initialize: +' Read colors in and set up assembly routines +Sub Initialize + + Width , 25 + View Print + + For ColorSet = 1 To 4 + For X = 1 To 10 + Read colors(X, ColorSet) + Next X + Next ColorSet + + LoadState + + P = VarPtr(ScrollUpAsm(1)) + Def Seg = VarSeg(ScrollUpAsm(1)) + For I = 0 To 13 + Read J + Poke (P + I), J + Next I + + P = VarPtr(ScrollDownAsm(1)) + Def Seg = VarSeg(ScrollDownAsm(1)) + For I = 0 To 13 + Read J + Poke (P + I), J + Next I + + Def Seg + +End Sub + +'Intro: +' Display introduction screen. +Sub Intro + Screen 0 + Width 80, 25 + Color 7, 0 + Cls + + Center 4, "Q B a s i c" + Color 15 + Center 5, " " + Center 6, " " + Center 7, " " + Center 8, " " + Color 7 + Center 11, "A Personal Finance Manager written in" + Center 12, "MS-DOS QBasic" + Center 24, "Press any key to continue" + + SparklePause +End Sub + +'LCenter: +' Center TEXT$ on the line printer +Sub LCenter (text$) + LPrint Tab(41 - Len(text$) / 2); text$ +End Sub + +'LoadState: +' Load color preferences and account info from MONEY.DAT +Sub LoadState + + Open "money.dat" For Input As #1 + Input #1, ColorPref + + For a = 1 To 19 + Line Input #1, account(a).Title + Line Input #1, account(a).AType + Line Input #1, account(a).Desc + Next a + + Close + +End Sub + +'Menu: +' Handles Menu Selection for a single menu (either sub menu, or menu bar) +' currChoiceX : Number of current choice +' maxChoice : Number of choices in the list +' choice$() : Array with the text of the choices +' itemRow() : Array with the row of the choices +' itemCol() : Array with the col of the choices +' help$() : Array with the help text for each choice +' barMode : Boolean: TRUE = menu bar style, FALSE = drop down style +' +' Returns the number of the choice that was made by changing currChoiceX +' and returns the scan code of the key that was pressed to exit +' +Function Menu (CurrChoiceX, MaxChoice, choice$(), ItemRow(), ItemCol(), help$(), BarMode) + + currChoice = CurrChoiceX + + 'if in bar mode, color in menu bar, else color box/shadow + 'bar mode means you are currently in the menu bar, not a sub menu + If BarMode Then + Color colors(7, ColorPref), colors(4, ColorPref) + Locate 1, 1 + Print Space$(80); + Else + FancyCls colors(2, ColorPref), colors(1, ColorPref) + Color colors(7, ColorPref), colors(4, ColorPref) + Box ItemRow(1) - 1, ItemCol(1) - 1, ItemRow(MaxChoice) + 1, ItemCol(1) + Len(choice$(1)) + 1 + + Color colors(10, ColorPref), colors(6, ColorPref) + For a = 1 To MaxChoice + 1 + Locate ItemRow(1) + a - 1, ItemCol(1) + Len(choice$(1)) + 2 + Print Chr$(178); Chr$(178); + Next a + Locate ItemRow(MaxChoice) + 2, ItemCol(MaxChoice) + 2 + Print String$(Len(choice$(MaxChoice)) + 2, 178); + End If + + 'print the choices + Color colors(7, ColorPref), colors(4, ColorPref) + For a = 1 To MaxChoice + Locate ItemRow(a), ItemCol(a) + Print choice$(a); + Next a + + finished = FALSE + + While Not finished + + GoSub MenuShowCursor + GoSub MenuGetKey + GoSub MenuHideCursor + + Select Case Kbd$ + Case Chr$(0) + "H": GoSub MenuUp + Case Chr$(0) + "P": GoSub MenuDown + Case Chr$(0) + "K": GoSub MenuLeft + Case Chr$(0) + "M": GoSub MenuRight + Case Chr$(13): GoSub MenuEnter + Case Chr$(27): GoSub MenuEscape + Case Else: Beep + End Select + Wend + + Menu = currChoice + + Exit Function + + + MenuEnter: + finished = TRUE + Return + + MenuEscape: + currChoice = 0 + finished = TRUE + Return + + MenuUp: + If BarMode Then + Beep + Else + currChoice = (currChoice + MaxChoice - 2) Mod MaxChoice + 1 + End If + Return + + MenuLeft: + If BarMode Then + currChoice = (currChoice + MaxChoice - 2) Mod MaxChoice + 1 + Else + currChoice = -2 + finished = TRUE + End If + Return + + MenuRight: + If BarMode Then + currChoice = (currChoice) Mod MaxChoice + 1 + Else + currChoice = -3 + finished = TRUE + End If + Return + + MenuDown: + If BarMode Then + finished = TRUE + Else + currChoice = (currChoice) Mod MaxChoice + 1 + End If + Return + + MenuShowCursor: + Color colors(8, ColorPref), colors(9, ColorPref) + Locate ItemRow(currChoice), ItemCol(currChoice) + Print choice$(currChoice); + PrintHelpLine help$(currChoice) + Return + + MenuGetKey: + Kbd$ = "" + While Kbd$ = "" + Kbd$ = InKey$ + Wend + Return + + MenuHideCursor: + Color colors(7, ColorPref), colors(4, ColorPref) + Locate ItemRow(currChoice), ItemCol(currChoice) + Print choice$(currChoice); + Return + + +End Function + +'MenuSystem: +' Main routine that controls the program. Uses the MENU function +' to implement menu system and calls the appropriate function to handle +' the user's selection +Sub MenuSystem + + Dim choice$(20), menuRow(20), menuCol(20), help$(20) + Locate , , 0 + choice = 1 + finished = FALSE + + While Not finished + GoSub MenuSystemMain + + subchoice = -1 + While subchoice < 0 + Select Case choice + Case 1: GoSub MenuSystemFile + Case 2: GoSub MenuSystemEdit + Case 3: GoSub MenuSystemAccount + Case 4: GoSub MenuSystemReport + Case 5: GoSub MenuSystemColors + End Select + FancyCls colors(2, ColorPref), colors(1, ColorPref) + + Select Case subchoice + Case -2: choice = (choice + 3) Mod 5 + 1 + Case -3: choice = (choice) Mod 5 + 1 + End Select + Wend + Wend + Exit Sub + + + MenuSystemMain: + FancyCls colors(2, ColorPref), colors(1, ColorPref) + Color colors(7, ColorPref), colors(4, ColorPref) + Box 9, 19, 14, 61 + Center 11, "Use arrow keys to navigate menu system" + Center 12, "Press Enter to select a menu item" + + choice$(1) = " File " + choice$(2) = " Accounts " + choice$(3) = " Transactions " + choice$(4) = " Reports " + choice$(5) = " Colors " + + menuRow(1) = 1: menuCol(1) = 2 + menuRow(2) = 1: menuCol(2) = 8 + menuRow(3) = 1: menuCol(3) = 18 + menuRow(4) = 1: menuCol(4) = 32 + menuRow(5) = 1: menuCol(5) = 41 + + help$(1) = "Exit the Money Manager" + help$(2) = "Add/edit/delete accounts" + help$(3) = "Add/edit/delete account transactions" + help$(4) = "View and print reports" + help$(5) = "Set screen colors" + + Do + NewChoice = Menu((choice), 5, choice$(), menuRow(), menuCol(), help$(), TRUE) + Loop While NewChoice = 0 + choice = NewChoice + Return + + MenuSystemFile: + choice$(1) = " Exit " + + menuRow(1) = 3: menuCol(1) = 2 + + help$(1) = "Exit the Money Manager" + + subchoice = Menu(1, 1, choice$(), menuRow(), menuCol(), help$(), FALSE) + + Select Case subchoice + Case 1: finished = TRUE + Case Else + End Select + Return + + + MenuSystemEdit: + choice$(1) = " Edit Account Titles " + + menuRow(1) = 3: menuCol(1) = 8 + + help$(1) = "Add/edit/delete accounts" + + subchoice = Menu(1, 1, choice$(), menuRow(), menuCol(), help$(), FALSE) + + Select Case subchoice + Case 1: EditAccounts + Case Else + End Select + Return + + + MenuSystemAccount: + + For a = 1 To 19 + If Trim$(account(a).Title) = "" Then + choice$(a) = Right$(Str$(a), 2) + ". ------------------- " + Else + choice$(a) = Right$(Str$(a), 2) + ". " + account(a).Title + End If + menuRow(a) = a + 2 + menuCol(a) = 19 + help$(a) = RTrim$(account(a).Desc) + Next a + + subchoice = Menu(1, 19, choice$(), menuRow(), menuCol(), help$(), FALSE) + + If subchoice > 0 Then + EditTrans (subchoice) + End If + Return + + + MenuSystemReport: + choice$(1) = " Net Worth Report " + menuRow(1) = 3: menuCol(1) = 32 + help$(1) = "View and print net worth report" + + For a = 1 To 19 + If Trim$(account(a).Title) = "" Then + choice$(a + 1) = Right$(Str$(a), 2) + ". ------------------- " + Else + choice$(a + 1) = Right$(Str$(a), 2) + ". " + account(a).Title + End If + menuRow(a + 1) = a + 3 + menuCol(a + 1) = 32 + help$(a + 1) = "Print " + RTrim$(account(a).Title) + " transaction summary" + Next a + + subchoice = Menu(1, 20, choice$(), menuRow(), menuCol(), help$(), FALSE) + + Select Case subchoice + Case 1 + NetWorthReport + Case 2 TO 20 + TransactionSummary (subchoice - 1) + Case Else + End Select + Return + + MenuSystemColors: + choice$(1) = " Monochrome Scheme " + choice$(2) = " Cyan/Blue Scheme " + choice$(3) = " Blue/Cyan Scheme " + choice$(4) = " Red/Grey Scheme " + + menuRow(1) = 3: menuCol(1) = 41 + menuRow(2) = 4: menuCol(2) = 41 + menuRow(3) = 5: menuCol(3) = 41 + menuRow(4) = 6: menuCol(4) = 41 + + help$(1) = "Color scheme for monochrome and LCD displays" + help$(2) = "Color scheme featuring cyan" + help$(3) = "Color scheme featuring blue" + help$(4) = "Color scheme featuring red" + + subchoice = Menu(1, 4, choice$(), menuRow(), menuCol(), help$(), FALSE) + + Select Case subchoice + Case 1 TO 4 + ColorPref = subchoice + SaveState + Case Else + End Select + Return + + +End Sub + +'NetWorthReport: +' Prints net worth report to screen and printer +Sub NetWorthReport + Dim assetIndex(19), liabilityIndex(19) + + maxAsset = 0 + maxLiability = 0 + + For a = 1 To 19 + If account(a).AType = "A" Then + maxAsset = maxAsset + 1 + assetIndex(maxAsset) = a + ElseIf account(a).AType = "L" Then + maxLiability = maxLiability + 1 + liabilityIndex(maxLiability) = a + End If + Next a + + 'Loop until is pressed + finished = FALSE + Do + u1$ = "\ \$$###,###,###.##" + u2$ = "\ \+$$#,###,###,###.##" + + Color colors(5, ColorPref), colors(4, ColorPref) + Locate 1, 1: Print Space$(80); + Locate 1, 4: Print "Net Worth Report: " + Date$; + PrintHelpLine " " + + Color colors(7, ColorPref), colors(4, ColorPref) + Box 2, 1, 24, 40 + Box 2, 41, 24, 80 + + Locate 2, 16: Print " ASSETS " + assetTotal# = 0 + a = 1 + count1 = 1 + While a <= maxAsset + file$ = "money." + Cvit$(assetIndex(a)) + Open file$ For Random As #1 Len = 84 + Field #1, 11 As valid$, 5 As IoMaxRecord$, 8 As IoBalance$ + Get #1, 1 + If valid$ = "THISISVALID" Then + Locate 2 + count1, 3: Print Using u1$; account(assetIndex(a)).Title; CVD(IoBalance$) + assetTotal# = assetTotal# + CVD(IoBalance$) + count1 = count1 + 1 + End If + Close + a = a + 1 + Wend + + Locate 2, 55: Print " LIABILITIES " + liabilityTotal# = 0 + a = 1 + count2 = 1 + While a <= maxLiability + file$ = "money." + Cvit$(liabilityIndex(a)) + Open file$ For Random As #1 Len = 84 + Field #1, 11 As valid$, 5 As IoMaxRecord$, 8 As IoBalance$ + Get #1, 1 + If valid$ = "THISISVALID" Then + Locate 2 + count2, 43: Print Using u1$; account(liabilityIndex(a)).Title; CVD(IoBalance$) + liabilityTotal# = liabilityTotal# + CVD(IoBalance$) + count2 = count2 + 1 + End If + Close + a = a + 1 + Wend + If count2 > count1 Then count1 = count2 + Locate 2 + count1, 25: Print "--------------" + Locate 2 + count1, 65: Print "--------------" + Locate 3 + count1, 3: Print Using u2$; "Total assets"; assetTotal#; + Locate 3 + count1, 43: Print Using u2$; "Total liabilities"; liabilityTotal# + + Color colors(5, ColorPref), colors(4, ColorPref) + Locate 1, 43: Print Using u2$; " NET WORTH:"; assetTotal# - liabilityTotal# + + Do: Kbd$ = InKey$: Loop Until Kbd$ <> "" + + Select Case Kbd$ 'Handle Special keys + Case Chr$(0) + "<" 'F2 + finished = TRUE + Case Chr$(0) + "=" 'F3 + GoSub NetWorthReportPrint + Case Else + Beep + End Select + Loop Until finished + Exit Sub + + NetWorthReportPrint: + PrintHelpLine "" + + Box 8, 20, 14, 62 + Center 10, "Prepare printer on LPT1 for report" + Center 12, "Hit to print, or to abort" + + Do: Kbd$ = InKey$: Loop While Kbd$ <> Chr$(13) And Kbd$ <> Chr$(27) + + If Kbd$ = Chr$(13) Then + Box 8, 20, 14, 62 + Center 11, "Printing report..." + u0$ = " \ \ " + u1$ = " \ \ $$###,###,###.##" + u2$ = " --------------" + u3$ = " =============" + u4$ = " \ \+$$#,###,###,###.##" + PrintErr = FALSE + On Error GoTo ErrorTrap ' test if printer is connected + LPrint + If PrintErr = FALSE Then + LPrint: LPrint: LPrint: LPrint: LPrint + LCenter "Q B a s i c" + LCenter "M O N E Y M A N A G E R" + LPrint: LPrint + LCenter "NET WORTH REPORT: " + Date$ + LCenter "-------------------------------------------" + LPrint Using u0$; "ASSETS:" + assetTotal# = 0 + a = 1 + While a <= maxAsset + file$ = "money." + Cvit$(assetIndex(a)) + Open file$ For Random As #1 Len = 84 + Field #1, 11 As valid$, 5 As IoMaxRecord$, 8 As IoBalance$ + Get #1, 1 + If valid$ = "THISISVALID" Then + LPrint Using u1$; account(assetIndex(a)).Title; CVD(IoBalance$) + assetTotal# = assetTotal# + CVD(IoBalance$) + End If + Close #1 + a = a + 1 + Wend + LPrint u2$ + LPrint Using u4$; "Total assets"; assetTotal# + LPrint + LPrint + LPrint Using u0$; "LIABILITIES:" + liabilityTotal# = 0 + a = 1 + While a <= maxLiability + file$ = "money." + Cvit$(liabilityIndex(a)) + Open file$ For Random As #1 Len = 84 + Field #1, 11 As valid$, 5 As IoMaxRecord$, 8 As IoBalance$ + Get #1, 1 + If valid$ = "THISISVALID" Then + LPrint Using u1$; account(liabilityIndex(a)).Title; CVD(IoBalance$) + liabilityTotal# = liabilityTotal# + CVD(IoBalance$) + End If + Close #1 + a = a + 1 + Wend + LPrint u2$ + LPrint Using u4$; "Total liabilities"; liabilityTotal# + LPrint + + LPrint + LPrint u3$ + LPrint Using u4$; "NET WORTH"; assetTotal# - liabilityTotal# + LCenter "-------------------------------------------" + LPrint: LPrint: LPrint + End If + On Error GoTo 0 + End If + Return +End Sub + +'PrintHelpLine: +' Prints help text on the bottom row in the proper color +Sub PrintHelpLine (help$) + Color colors(5, ColorPref), colors(4, ColorPref) + Locate 25, 1 + Print Space$(80); + Center 25, help$ +End Sub + +'SaveState: +' Save color preference and account information to "MONEY.DAT" data file. +Sub SaveState + Open "money.dat" For Output As #2 + Print #2, ColorPref + + For a = 1 To 19 + Print #2, account(a).Title + Print #2, account(a).AType + Print #2, account(a).Desc + Next a + + Close #2 +End Sub + +'ScrollDown: +' Call the assembly program to scroll the screen down +Sub ScrollDown + Def Seg = VarSeg(ScrollDownAsm(1)) + Call Absolute(VarPtr(ScrollDownAsm(1))) + Def Seg +End Sub + +'ScrollUp: +' Calls the assembly program to scroll the screen up +Sub ScrollUp + Def Seg = VarSeg(ScrollUpAsm(1)) + Call Absolute(VarPtr(ScrollUpAsm(1))) + Def Seg +End Sub + +'SparklePause: +' Creates flashing border for intro screen +Sub SparklePause + + Color 4, 0 + a$ = "* * * * * * * * * * * * * * * * * " + While InKey$ <> "": Wend 'Clear keyboard buffer + + While InKey$ = "" + For a = 1 To 5 + Locate 1, 1 'print horizontal sparkles + Print Mid$(a$, a, 80); + Locate 22, 1 + Print Mid$(a$, 6 - a, 80); + + For b = 2 To 21 'Print Vertical sparkles + c = (a + b) Mod 5 + If c = 1 Then + Locate b, 80 + Print "*"; + Locate 23 - b, 1 + Print "*"; + Else + Locate b, 80 + Print " "; + Locate 23 - b, 1 + Print " "; + End If + Next b + Next a + Wend +End Sub + +'TransactionSummary: +' Print transaction summary to line printer +Sub TransactionSummary (item) + FancyCls colors(2, ColorPref), colors(1, ColorPref) + PrintHelpLine "" + Box 8, 20, 14, 62 + Center 10, "Prepare printer on LPT1 for report" + Center 12, "Hit to print, or to abort" + + Do: Kbd$ = InKey$: Loop While Kbd$ <> Chr$(13) And Kbd$ <> Chr$(27) + + If Kbd$ = Chr$(13) Then + Box 8, 20, 14, 62 + Center 11, "Printing report..." + PrintErr = FALSE + On Error GoTo ErrorTrap ' test if printer is connected + LPrint + If PrintErr = FALSE Then + Print + LPrint: LPrint: LPrint: LPrint: LPrint + LCenter "Q B a s i c" + LCenter "M O N E Y M A N A G E R" + LPrint: LPrint + LCenter "Transaction summary: " + Trim$(account(item).Title) + LCenter Date$ + LPrint + u5$ = "--------|------|------------------------|----------|----------|--------------" + LPrint u5$ + LPrint " Date | Ref# | Description | Increase | Decrease | Balance " + LPrint u5$ + u0$ = "\ \|\ \|\ \|" + u2$ = "###,###.##" + u3$ = "###,###,###.##" + u4$ = " " + + file$ = "money." + Cvit$(item) + Open file$ For Random As #1 Len = 84 + Field #1, 8 As IoDate$, 10 As IoRef$, 50 As IoDesc$, 8 As IoFig1$, 8 As IoFig2$ + Field #1, 11 As valid$, 5 As IoMaxRecord$, 8 As IoBalance$ + Get #1, 1 + If valid$ = "THISISVALID" Then + Balance# = 0 + MaxRecord = Val(IoMaxRecord$) + CurrRecord = 1 + While CurrRecord <= MaxRecord + + Get #1, CurrRecord + 1 + Fig1# = CVD(IoFig1$) + Fig2# = CVD(IoFig2$) + + LPrint Using u0$; IoDate$; IoRef$; IoDesc$; + If Fig2# = 0 And Fig1# = 0 Then + LPrint Using u4$ + "|" + u4$ + "|" + u3$; Balance# + ElseIf Fig2# = 0 Then + Balance# = Balance# + Fig1# + LPrint Using u2$ + "|" + u4$ + "|" + u3$; Fig1#; Balance# + Else + Balance# = Balance# - Fig2# + LPrint Using u4$ + "|" + u2$ + "|" + u3$; Fig2#; Balance# + End If + CurrRecord = CurrRecord + 1 + Wend + LPrint u5$ + LPrint: LPrint + End If + On Error GoTo 0 + End If + Close + End If +End Sub + +'Trin$: +' Remove null and spaces from the end of a string. +Function Trim$ (X$) + + If X$ = "" Then + Trim$ = "" + Else + lastChar = 0 + For a = 1 To Len(X$) + y$ = Mid$(X$, a, 1) + If y$ <> Chr$(0) And y$ <> " " Then + lastChar = a + End If + Next a + Trim$ = Left$(X$, lastChar) + End If + +End Function + diff --git a/samples/money/src/money.zip b/samples/money/src/money.zip new file mode 100644 index 00000000..ce38572f Binary files /dev/null and b/samples/money/src/money.zip differ diff --git a/samples/moon-lander/img/screenshot.png b/samples/moon-lander/img/screenshot.png new file mode 100644 index 00000000..5ef442ca Binary files /dev/null and b/samples/moon-lander/img/screenshot.png differ diff --git a/samples/moon-lander/index.md b/samples/moon-lander/index.md new file mode 100644 index 00000000..ea30a890 --- /dev/null +++ b/samples/moon-lander/index.md @@ -0,0 +1,28 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: MOON LANDER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Richard Frost](../richard-frost.md) + +### Description + +```text +Lunar Lander based on a 1974 program running on a DEC PDP/11 with GT40 vector display terminal at the University of Alberta. Initially written in QB4.5 (hence the convoluted code to save space), upgraded to use some QB64 features. Updated May 15, 2020 - More effects (at warp speeds) and cookies! + +Controls: +The multifarious keyboard controls are given by pressing F1 (Help) when the program is run. +``` + +### File(s) + +* [l64.bas](src/l64.bas) +* [l64.zip](src/l64.zip) + +🔗 [game](../game.md), [lander](../lander.md) + + +Reference: [qb64forum](https://qb64forum.alephc.xyz/index.php?topic=2615.0) diff --git a/samples/moon-lander/src/l64.bas b/samples/moon-lander/src/l64.bas new file mode 100644 index 00000000..953f7121 --- /dev/null +++ b/samples/moon-lander/src/l64.bas @@ -0,0 +1,6300 @@ +' Moon Lander by rfrost@mail.com + +$ExeIcon:'./l64_dat/astro.ico' +$Resize:Smooth + +DefInt A-Z +Dim Shared a ' angle of craft +Dim Shared a51i ' Area 51 initializations +Dim Shared APdisengage ' AutoPilot disengage +Dim Shared ASO ' ascent stage only +Dim Shared auto ' autopilot +Dim Shared background ' for instrument panel +Dim Shared bh ' black hole +Dim Shared bhx, bhy ' black hole +Dim Shared bbit ' blinking bit synced to time +Dim Shared bolthit, bolthitf, boltx ' Deathstar hit vehicle, feature +Dim Shared borgl, borgr, borgt ' left right top, distance +Dim Shared bstyle1, bstyle2 ' Borg matrix/lines/Moire +Dim Shared bw ' black and white +Dim Shared c ' usually color +Dim Shared canvas& ' primary screen +Dim Shared cbh ' constant black holes +Dim Shared center ' varies according to gs (graphics start) +Dim Shared chs ' parachute size +Dim Shared contact ' landed +Dim Shared convo ' conversation active LM/CM +Dim Shared cpal ' color palette, normal/green/b&w (32 color kludge/fun) +Dim Shared craft ' color +Dim Shared crash ' layer of debris +Dim Shared cwd, cwsi, cwsd ' car wash distance, angles +Dim Shared cybilltime! ' time on screen +Dim Shared darkstarc ' deathstar color set +Dim Shared darkstars ' deathstar spin rate +Dim Shared darkstart ' " thickness +Dim Shared dead$ ' end condition +Dim Shared debug$ ' messages to God +Dim Shared demo ' ground features compressed +Dim Shared doclock ' it's Howdy Doody time +Dim Shared dosbox ' flag +Dim Shared dsinit ' deathstar +Dim Shared eou ' end of universe +Dim Shared fb$ ' landing feedback/analysis +Dim Shared flx ' US/USSR flag position +Dim Shared fuel, fuel! ' color of, quantity left +Dim Shared gh, glmin, glmax ' ground height, level +Dim Shared grav! ' gravity +Dim Shared gs ' flight area x start +Dim Shared gstyle ' ground style +Dim Shared inpause ' flag +Dim Shared invincible ' impervious to threats +Dim Shared iscd ' don't attempt to write! +Dim Shared jitter ' shift-T to control +Dim Shared LEDc ' color +Dim Shared LEDtri ' tri-color flag +Dim Shared level ' surface is +Dim Shared LGMc ' Little Green Man color +Dim Shared liftoff ' AS only +Dim Shared lmsl ' LM shield/laser color +Dim Shared lob ' landed on Borg +Dim Shared lockfuel ' cheat! +Dim Shared lp, rp, xp, th1, th2 ' pads, radar, thrusters +Dim Shared magic ' cheat! (instant landing) +Dim Shared mdelay ' PgUp/PgDn controlled +Dim Shared mpath$ +Dim Shared msflag ' making surfaces +Dim Shared mstar ' make stars +Dim Shared nation ' 1 US, 2 USSR (flags & fireworks) +Dim Shared ok ' at landing, to plant flag +Dim Shared okrick ' diagnostics +Dim Shared osc ' on screen count +Dim Shared oscar ' semaphore land/sea flags +Dim Shared panelinit ' replot flag +Dim Shared paraf ' parachute flag +Dim Shared pload ' panel load flag +Dim Shared porb ' pointers/bargraphs +Dim Shared ptk ' points to kill (gasoline) ExplodeLM +Dim Shared px!, py! ' vehicle position on screen +Dim Shared ra ' random angle +Dim Shared radarf ' radar on/off +Dim Shared rads ' Luna radiation +Dim Shared radiationdeath ' flag +Dim Shared rdtime! ' fun with high res screen (my picture) +Dim Shared regen ' all star files +Dim Shared rfx, rfy ' craft jigger +Dim Shared rick ' debug flag +Dim Shared rmin, dmin ' stars +Dim Shared settings$ ' lander.set +Dim Shared sf ' surface feature +Dim Shared shield ' flag +Dim Shared shoot ' flag +Dim Shared showmap ' locations of things shown at top +Dim Shared sia ' shells in air +Dim Shared skyoff ' for faster performance +Dim Shared slash$ +Dim Shared starship ' Enterprise (double shift twice) +Dim Shared ufof ' for ufo +Dim Shared sspinit1, sspinit2 ' Surveyor +Dim Shared starfiles ' use stars1,2 or 3 (few/med/lots) +Dim Shared starinit ' flag +Dim Shared shipi&, shipx ' starship +Dim Shared starstatus ' 0 off, 1 on, 234 more info +Dim Shared suri ' surface index +Dim Shared sx0, sy0 ' LM radar/laser location +Dim Shared sx1, sy1 ' LM left landing pad +Dim Shared sx2, sy2 ' LM right landing pad +Dim Shared temp ' temperature +Dim Shared thrust! ' 0 - 100 +Dim Shared tilef ' tile variation +Dim Shared twinkle ' stars +Dim Shared vx!, vy! ' LM velocity +Dim Shared wa1 +Dim Shared warp! ' vx! >= 100 +Dim Shared wi, wi2 ' width (distance between pads) +Dim Shared wx!, wy! ' vehicle position on screen +Dim Shared x ' = suri + px! +Dim Shared xoff ' offset for v=5-20, Surv & Etna +Dim Shared zoom ' starfield + +Dim Shared blue, green, gunmetal, red, gasoline, gray2, white, gray +Dim Shared dred, gold, black2, orange, blue2, yellow, white2 + +Dim Shared q1, q2, q3, q4, h, t, th, tsix, aspect!, pf! ' constants + +q1 = 6400: q2 = 860: q3 = 639: q4 = 349: h = 100: th = 200: t = 10: tsix = 360 +pf! = .5: aspect! = 1.4: grav! = 1.6 + +qt = 2000 ' 3 arrays below weren't loading properly with q2 +Dim Shared LMx(qt), LMy(qt), LMc(qt) ' LM+exhaust x,y,color + +Dim Shared LMrx(1400), LMry(1400) ' LM+exhaust x,y after rotation +Dim Shared LMoc(705), LMci(3) ' LM colors,original colors, index +Dim Shared c!(360), s!(360) ' sines and cosines +Dim Shared ex(6), ey(6), exv(6), eyv(6), ei(6), ek(6), exl(6) ' sky objects +Dim Shared f$(40) ' support files +Dim Shared mes$(1), omes$(1), sm!(1) ' messages at screen top +Dim Shared sf(10, 2), sf$(10) ' surface features start/end/middle +Dim Shared shx(20), shy(20), sha(20) ' shells (IBM weapons) x,y,angle +Dim Shared shvx(20), shvy(20), shd(20) ' velocity, distance +Dim Shared rtl!(2), rtlc(2) ' radiation/temperature/lightning +Dim Shared gh(6400) ' ground height + +Dim clocka(2) ' clock angles +Dim cmp&(30) ' CM patterns +Dim convo$(50) ' LM/CM +Dim Shared gbuff(800) ' DS liftoff +Dim skyset1(t), skyset2(t) ' skycrud +Dim Shared p(127, 13), p2(127, 7) ' vga and cga fonts +Dim Shared tflags(30) + +begin: +GoSub init1 +Do + GoSub init2 + While Len(InKey$): Wend ' clear keyboard buffer + Do: _Limit mdelay + GoSub Autopilot + GoSub Plotscreen + GoSub KeyAndMouse + If restart Then GoTo begin ' restore defaults + If warp! < 1 Then GoSub CheckHit + Loop Until contact Or Len(dead$) + GoSub CheckDead + If contact Then + Evaluate savea, a + ma ' landing feedback contact/current + wu2! = Timer + 1 + GoSub pause ' landed, Enter for liftoff + If restart Then GoTo begin ' restore defaults + If k <> 60 Then GoSub CheckDead ' F2 demo restart + End If +Loop + +CheckDead: +z$ = Left$(Left$(dead$, 1) + " ", 1) +If InStr(" CBE", z$) = 0 Then ' not Crashed, Borg, Eaten by BH + ExplodeLM + contact = 0 +End If +dead$ = "" +Return + +Autopilot: +aboveborg = 0 +If (ek(2) = -1) Or (ek(2) > h) Then borgt = 0 +If (skyoff = 0) And (sy1 < borgt) And (px! > borgl) And (px! < borgr) Then aboveborg = 1 +super = 0 +If vert Or hover Then + GoSub GetAlt + i! = alt! / 8 + pf! ' thrust target + If jitter And (alt! < t) Then i! = i! * 2 ' optional, faster + If aboveborg Then i! = 1 + GoSub idealthrust + thrust! = sbest! + super = -(sbest! > h) ' add side thusters + If thrust! > h Then thrust! = h +End If +If thrust! < 0 Then thrust! = 0 +Return + +CutOrOutOfFuel: +If fuel! = 0 Then shield = 0 ' shields need fuel +If cut = 0 Then + cut = 1 + cvy! = vy! + ctime! = Timer + tfollow = 0 ' terrain following + thrust! = 0 +End If +Return + +idealthrust: ' for hover or descend +If (alt! < pf!) And (jitter = 0) Then i! = .05 ' soft landing +If hover Then i! = hoverc ' target +hoverc = hoverc - Sgn(hoverc) ' up/down +fmin! = q1 ' conventient large number (6400) +ma! = (vmass + fuel!) / th ' mass (actually 54% fuel) +ts! = s!((a + 270) Mod tsix) / ma! / power +If jitter Then us! = Rnd * t + 1 Else us! = .1 +If powerloss Then us! = h +For z! = 0 To (h + t) Step us! ' find best thrust 0-110 + fo! = z! * ts! + aa! = Abs(vy! + grav! + fo! - i!) + If aa! < fmin! Then fmin! = aa!: sbest! = z! + If aa! > fmin! Then Exit For +Next z! +Return + +GoSkyObject: +If (ek(p) <> -1) And (contact = 0) Then + auto = 0 + a = -ma + wa = -ma + lock1 = 0 + suri = ex(p) - center + GoSub slimit + If p > 2 Then ey(p) = th ' BH, worm, comet, alien + px! = center + If p = 2 Then py! = 130 ' above Borg + vx! = exv(p) + eyv(p) = 0 +End If +Return + +KeyAndMouse: +Do While _MouseInput + lb = Abs(_MouseButton(1)) + rb = Abs(_MouseButton(2)) + If mouseswap Then Swap lb, rb ' whatever floats your boat + If Timer < ignoreuntil! Then lb = 0: rb = 0 ' 2 lines for debouncing + If lb Or rb Then ignoreuntil! = Timer + .25 + ww = wa ' stash current wanted angle + wa = wa + lb - rb ' want angle + If wa <> ww Then ' if changed + If inpause Then i$ = Chr$(13): GoTo gotit ' either button to cause liftoff + apd = 1 ' autopilot disconnect warning + auto = 0 ' autopilot + GoTo endk ' don't bother checking keys + End If + mw = mw + _MouseWheel +Loop +If mw <> 0 Then ' wheel moved + thrust! = Int(thrust!) - mw + If thrust! < 0 Then thrust! = 0 + If thrust! > h Then thrust! = h + apd = 1 ' autopilot disconnect warning + auto = 0 ' autopilot + hover = 0 ' hover off + vert = 0 ' vertical control off + mw = 0 ' zap + GoTo endk ' don't bother checking keys +End If + +Def Seg = 0 +status = Peek(&H417) ' 7ins 6caps 5num 4scrl 3alt 2ctrl 1ls 0rs + +If ((status And 1) > 0) And ((status And 2) > 0) Then ' both shift (cookie!) + If rdtime! > 0 Then starship = 1 ' must have pressed shift-shift twice, another cookie + rdtime! = Timer + 5 ' Rick display time +End If + +If status And 8 Then start1! = Timer: mpass& = 0 ' alt, reset speed timer + +If status And 4 Then ' ctrl + i$ = Right$(" " + InKey$, 1) + kk = Asc(i$) + If (kk = 3) Or (kk = 19) Then ' c or s + nfile: + image = image + 1 + f$ = "CAP" + Right$("0000" + LTrim$(Str$(image)), 3) + ".BMP" + If _FileExists(f$) Then GoTo nfile + SaveImage f$ + If _FileExists(f$) Then mes$(1) = "Screen captured to " + f$ + GoTo endk + End If +End If + +i$ = InKey$ ' consult human +li = Len(i$) +If li = 0 Then Return + +If i$ = "|" Then MakeStarFiles ' takes hours! + +k = Asc(Right$(i$, 1)) +If k = 27 Then Quit +If inpause And (k = 32) Then + k = 13 ' transform spacebar to Enter + i$ = Right$(Chr$(0) + Chr$(k), li) ' gentlemen, we can rebuild him +End If + +gotit: +If (i$ = "\") And (shx(0) = 0) And (contact = 0) Then ' LM drops bomb + If (cwd < 50) And (sy1 > 300) Then dead$ = "Smooth move, Exlax!" 'kill self in car wash + sia = sia + 1 ' shells in air + shvx(0) = vx! + 3 + Rnd * t + shvy(0) = 0 + shx(0) = suri + sx0 + shy(0) = sy0 + shd(0) = 1 +End If + +If i$ = "[" Then bw = bw Xor 1: Setcolor ' crude method for b&w +If i$ = "]" Then + ufof = ufof Xor 1 + mes$(0) = "UFO " + OnOff$(ufof) + If ufof Then + GoSub SkyStuff + p = 6: GoSub GoSkyObject + End If +End If + +If i$ = "=" Then GoSub lmshow ' show LM data - pointless but amusing +If i$ = "'" Then pdiv = (pdiv + 1) Mod 4 ' Henon speed, also slows down thrust display +If radiationdeath Then i$ = "": Return ' you're dead and cannot pass this point + +If i$ = "~" Then darkstarc = darkstarc Xor 1 ' color +If i$ = "@" Then darkstart = darkstart Xor 1 ' thickness + +If inpause Then ' hit "p" or landed + If i$ = "b" Then ' Big Dipper + rmin = 9 ' right ascension + dmin = 30 ' declination + starinit = 0 + Return + End If + If li = 2 Then ' arrow keys move stars + rdol = rmin + dmin ' detect change + rmin = rmin + (k = 75) - (k = 77) ' left right + rmin = (rmin + 24) Mod 24 ' RA limit 0 - 24 + dmin = dmin - (k = 80) * t + (k = 72) * t ' declination up down + If dmin = h Then dmin = -80 ' limit -90 - 90 + If dmin = -h Then dmin = 80 + If (rmin + dmin) <> rdol Then starinit = 0 ' changed, replot stars + End If +End If +If li = 2 Then GoTo is2 ' extended key + +If i$ = "_" Then ' star twinkle + twinkle = twinkle Xor 1 + mes$(0) = "STAR TWINKLE " + OnOff$(twinkle) +End If +If i$ = ";" Then fpl = 1 ' force power loss +If k = 9 Then ex(1) = (suri + px!) - Sgn(exv(1)) * h ' TAB summon DS +p = InStr(")!@#$%^&*(", i$) +If p And (contact = 0) Then GetSurface p - 1 ' shifted-number for 1 of 10 surfaces +p = InStr("01234", i$) ' stars off/on/info +If p Then starstatus = p - 1 +If (k = 8) And (warp! < 1) Then ' backspace, random star position + rmin = Int(Rnd * 24) ' random RA + dmin = (Int(Rnd * 18) - 9) * t ' random dec + starinit = 0 +End If +If i$ = "." Then + tfollow = tfollow Xor 1 + auto = 0 + vert = 1 + mes$(0) = "TERRAIN FOLLOWING " + OnOff$(tfollow) +End If +p = (i$ = "<") - (i$ = ">") ' jump left/right +If (contact = 0) And (p <> 0) Then + suri = suri + 40 * p ' surface index + GoSub slimit ' limit suri + If lock1 Then hover = 1: lock1 = 0 +End If +If okrick And (warp! < 1) Then + If i$ = "+" Then + If zoom < 2 Then zoom = zoom + 1 + starinit = 0 + End If + If i$ = "-" Then + If zoom > 0 Then zoom = zoom - 1 + starinit = 0 + End If +End If +If i$ = "?" Then rick = rick Xor 1 ' show speed of processing graph +If i$ = "/" Then + cpal = (cpal + 1) Mod 4 ' cycle green/black & white/normal monitor + mes$(0) = "": mes$(1) = "" + If cpal = 1 Then mes$(0) = "GT40 mode" + If cpal = 2 Then mes$(1) = "Hyperion mode!" + If cpal = 3 Then mes$(1) = "Do not adjust your set. We control the horizontal and the vertical!" +End If +If k = 32 Then ' cycle thru features + If lock1 > 0 Then ' on auto, landing zone selected, abort landing + abort = 1 + mes$(0) = "ABORT!" + If vx! = 0 Then vx! = .01 + Return + End If + If convo Then ' or speed up rendesvous + sct! = .2 + sc! = Timer + Return + End If + + If skyoff Then tmod = t Else tmod = 16 + jf = (jf + 1) Mod tmod + ' 01234567890123456 + i$ = Mid$("mtsiHg5wleObBWoR", jf + 1, 1) ' cycle thru ground and sky features + k = Asc(i$) + If demo And (jf = 7) Then i$ = "e" ' skip LGM in demo, because it's on the grave +End If + +p = InStr("RObBWo", i$) ' jump to CM, deathstar, etc. +If p And (skyoff = 0) Then p = p - 1: GoSub GoSkyObject + +If i$ = "A" Then + lam = lam Xor 1 ' land at McDonalds + If lam And (auto = 0) Then i$ = "a" ' turn on autopilot +End If +If i$ = "a" Then ' autopilot + abort = 0 ' in case it was on + tfollow = 0 + auto = auto Xor 1 ' toggle + If auto And (radarf = 0) Then radarf = 2 + If auto = 0 Then hover = 1 ' be nice, help user + pt! = Timer ' restart countdown +End If +If i$ = "c" Then GoSub CutOrOutOfFuel +If i$ = "C" Then doclock = doclock Xor 1 +If i$ = "d" Then dump = dump Xor 1 ' fuel +If i$ = "D" Then restart = 1 ' restart with defaults +If (i$ = "E") And (starstatus > 0) Then ' end of universe + If eou = 0 Then eou = -1 Else eou = eou + 1 ' restart or speedup +End If +If i$ = "F" Then + fuel! = h + lockfuel = 1 +End If +If i$ = "f" Then lockfuel = lockfuel Xor 1 ' THIS cheat the GT40 had, using toggle switches! +If i$ = "G" Then gstyle = (gstyle + 1) Mod 6 ' ground style +If i$ = "h" Then hover = hover Xor 1: apd = 1 ' apd=autopilot disconnect warning +If i$ = "I" Then + invincible = Abs(invincible) Xor 1 + mes$(0) = "INVINCIBLE MODE " + OnOff$(invincible) + GoSub ReadLM ' to change thrusters +End If +If i$ = "j" Then + darkstars = (darkstars + 1) Mod 5 + mes$(0) = "Deathstar rotation" + Str$(darkstars) +End If +If i$ = "k" Then ' kill threats or, if none, shoot at ground feature + firel = 1 ' fire laser + For z = 1 To 20 ' IBM shells + shd(z) = 1 + Next z +End If +If i$ = "L" Then GetSurface -1 ' level ground +If (i$ = "M") And ((contact + inpause) = 0) Then ' laser level & land + magic = magic + 1 +End If +If (i$ = "n") And inpause Then nation = ((nation - 1) Xor 1) + 1 ' flag 1 US, 2 USSR +If i$ = "p" Then GoSub pause ' pause LM movement +If (i$ = "P") And (contact = 0) And (warp! < 1) And (paraf = 0) Then + paraf = 1 ' parachute! + chs = 0 + a = 0 + GoSub CutOrOutOfFuel +End If +If i$ = "q" Then Quit +If i$ = "Q" Then + oscar = oscar Xor 1 ' land or sea flags for LGM + If oscar Then z$ = "SEA" Else z$ = "LAND" + mes$(0) = "LGM flags: " + z$ +End If +If i$ = "r" Then + If cut Then ' restart engine + cut = 0 + hover = 1 + power = opower + powerloss = 0 + Else + If auto = 0 Then + radarf = (radarf + 1) Mod 3 + mes$(0) = "Radar " + Mid$("OFFON FAT", radarf * 3 + 1, 3) + End If + End If +End If +If i$ = "S" Then MakeSur: restart = 1 ' generate new surfaces +If i$ = "T" Then jitter = jitter Xor 1 ' thrust computation +If i$ = "u" Then ' instrument panel on/off + zz = gs + gs = (Sgn(gs) Xor 1) * 85 ' graphics start + + panelinit = 0 + pif = -1 + + z = (gs + 30) - px! + If (gs > 0) And (z > 0) Then + px! = px! + z + suri = suri - z + GoSub slimit + End If +End If +If i$ = "U" Then tilef = (tilef + 1) Mod 3 ' alternate tilings +If i$ = "v" Then ' vertical automatic + If tfollow Then + tfollow = 0 + mes$(0) = "TERRAIN FOLLOWING OFF" + End If + vert = vert Xor 1 + apd = 1 ' autopilot disconnect warning +End If +If i$ = "x" Then starinit = 0: starfiles = (starfiles + 1) Mod 3 ' star density +If i$ = "X" Then starinit = 0: regen = 1: Stars ' regenerate single star file +If i$ = "y" Then + mouseswap = mouseswap Xor 1 + If mouseswap Then z$ = "reversed" Else z$ = "normal" + mes$(0) = "Mouse buttons " + z$ +End If +If i$ = "Y" Then min = 3: sec = 45 ' black hole at 3:50 +If (i$ = "z") And (crash = 0) Then + mes$(0) = "" ' + mes$(1) = "" ' erase radiation messages + dead$ = "SELF-DESTRUCT" +End If + +If i$ = "}" Then + GoSub CutOrOutOfFuel + sgs = gs: gs = 0 + srf = radarf: radarf = 0 + GoSub Plotscreen + dissolve + dead$ = " " + gs = sgs: radarf = srf +End If + +' 1234567890 +p = InStr("5wlemtsiHg", i$) ' jump to feature +If p And (contact = 0) Then + sf = p + If demo And sf = 9 Then sf = t + If (sf(sf, 1) >= suri) And (sf(sf, 0) < (suri + q3)) Then ' already in vicinity of IBM + If sf = 8 Then shoot = 1 ' tell IBM to fire + If demo Then ' IBM at special location in demo mode, deal with it + px! = sf(sf, 2) - 3130 + suri = 3130 + End If + Else + px! = center ' move ship to screen center + suri = sf(sf, 0) - center - 30 - (sf = 9) * h ' move ground to IBM + End If + a = -ma ' angle = -malfunction angle + abort = 0 + wa = -ma ' want angle + lock1 = 0 ' radar lock + tmt! = 0 ' to move total + vx! = 0 ' not moving + warp! = 0 ' cancel warp +End If +GoTo endk ' done with ordinary keys + +is2: ' extended key +z = mdelay ' master delay +mdelay = mdelay - (k = 73) + (k = 81) ' PgUp/PgDn +If mdelay < 1 Then mdelay = 1 +If mdelay <> z Then ' changed + mes$(0) = "_LIMIT " + OnOff$(Sgn(mdelay)) + If mdelay Then mes$(0) = mes$(0) + LTrim$(Str$(mdelay)) +End If +If status And 3 Then ' left or right shift + If k = 72 Then k = 201 ' LM up + If k = 75 Then k = 203 ' LM left + If k = 77 Then k = 204 ' LM right +End If +If (inpause = 0) And ((k = 72) Or (k = 80)) Then ' up and down arrow + apd = 1 ' autopilot disconnect + hover = 0 + vert = 0 + thrust! = thrust! + (k = 80) - (k = 72) ' true = -1 +End If +thrust! = Int(thrust! * t) / t ' t = 10 +If (hover = 0) And (vert = 0) Then thrust! = Int(thrust!) +If thrust! > h Then thrust! = h +If (dump = 0) And (fuel! > 0) And (contact = 0) Then ' side thrust/angle + If inpause = 0 Then wa = a - (k = 75) + (k = 77) ' left/right arrows + If Abs(wa) > 99 Then wa = 99 * Sgn(wa) ' want angle, limit 99 + If a <> wa Then apd = 1 ' autopilot disconnect +End If +If k = 59 Then ' F1 help + Help + start1! = Timer: mpass& = 0 ' reset speed timer +End If +If k = 60 Then ' F2 demo + demo = demo Xor 1 + GoSub init2 + cbh = demo ' constant black holes +End If +If k = 61 Then ' F3, sky feature toggle + skyoff = skyoff Xor 1 + If skyoff = 0 Then convo = 0 + mes$(0) = "SKY OBJECTS " + OnOff$(1 - skyoff) +End If +If k = 62 Then ' F4 endless bh + cbh = cbh Xor 1 + exv(3) = 0 + mes$(0) = "CONSTANT BLACK HOLES " + OnOff$(cbh) +End If +If k = 63 Then ' F5 instrument background + f5toggle = f5toggle Xor 1 + If f5toggle = 0 Then background = background Xor 1 + If f5toggle = 1 Then porb = porb Xor 1 + pload = 0 +End If +If (k = 64) And ((ASO + inpause) = 0) Then ' F6 seperate AS/DS + GoSub liftoff + Return +End If +If k = 65 Then showmap = showmap Xor 1 ' F7 map +If k = 66 Then ' F8 shields + shield = shield Xor 1 + geof = shield * t +End If +If k = 67 Then ' F9 LED color + z$ = Right$("0" + LTrim$(Str$(LEDc)), 2) + z = InStr(LED$, z$): If z = 11 Then z = -1 + LEDc = Val(Mid$(LED$, z + 2, 2)) + LEDtri = 0 +End If +If k = 68 Then ' F10 LED tri-color + LEDtri = LEDtri Xor 1 + If LEDtri Then LEDc = green +End If +If k = 71 Then rmin = 0: dmin = 0: starinit = 0 ' Home, star RA/dec to 0 + +endk: +If k = 201 Then hoverc = hoverc - t ' move up +If k = 203 And (left = 0) Then left = 16 ' move left +If k = 204 And (right = 0) Then right = 16 ' move right +If apd Or (k = 201) Or (k = 203) Or (k = 204) Then ' blink AUTO + If auto Then APdisengage = 20 ' blink 20 times + auto = 0 ' turn it off + apd = 0 ' reset flag +End If +Return + +pause: +If inpause Then Return ' already doing this.... +dead$ = "" +inpause = 1 +pt! = Timer ' for demo mode +wu! = pt! + 1 ' delay before planting flag +Do: _Limit mdelay + GoSub KeyAndMouse + If k = 60 Then Return ' F2 demo + If (i$ > "") And (InStr("zD", i$)) Then Return ' self-destruct or restart + GoSub Plotscreen + If Len(dead$) Then Return + If auto And contact Then ' countdown to blast off + If Timer < pt! Then pt! = Timer ' midnite crossing fix + z! = Timer - pt! + z = t - z! + If z < 0 Then z = 0 + TextOnLM$ = LTrim$(Str$(z)) + If z! > t Then i$ = Chr$(13) ' like pressing the key + End If + GoSub CalcFuel +Loop Until (i$ = Chr$(13)) Or (i$ = "p") +ctime! = Timer +fb$ = "" ' feedback +inpause = 0 +c = (contact = 1) And (crash = 0) And (liftoff = 0) And (Abs(a) < 31) +If c Then GoSub liftoff +Return + +CalculateMotion: +i = 0 +If (power = opower) And (Rnd < .0003) Then + i = ((auto + contact + liftoff + vert) = 0) And ((min * 60 + sec) > t) +End If +If fpl Or i Then ' force power loss + fpl = 0 + powerloss = t + Rnd * t + ASO * 30 ' 10 TO 20%, 50% ASO + power = opower + powerloss / h * opower + mes$(0) = LTrim$(Str$(powerloss)) + "% POWER LOSS - DUMP FUEL!" +End If + +If lob Then px! = px! + exv(2) ' landed on Borg +If contact Or inpause Then GoTo other + +ta = ((a + ma) + 270) Mod tsix ' temp angle = a+malfunction angle +ma! = (vmass + fuel!) / th ' actually 54% fuel +fo! = ((thrust! + super * 5) / ma!) / power ' f = ma +If fuel! = 0 Then fo! = 0 ' nix any force if running on empty +fx! = fo! * c!(ta) / 2 +If dump And (Abs(a) < 5) Then fx! = 0 +fy! = fo! * s!(ta) + grav! ' thrust + gravity +If warp! > 0 Then fx! = fx! * (warp! * 2 + 1) ' get thru warp msgs faster +vx! = vx! - fx! +If a <> 0 Then vx! = vx! + (Rnd - pf!) / h ' help get to integer vx +If Abs(vx!) < .01 Then vx! = 0 +avx = Abs(vx!) +If (avx > 5) And (avx < 20) Then xoff = vx! Else xoff = 0 +If cut And (magic = 0) Then + cel! = Timer - ctime! ' time since cut + vy! = cvy! + grav! * (cel! * cel!) ' v = at^2 velocity = acceleration times time squared + fy! = 0 ' null y force since it's a different situation +End If +vy! = vy! + fy! +If warp! >= 1 Then vy! = 0 + +px! = px! + vx! - lob * exv(2) +py! = py! + vy! + +If (liftoff = 0) And (py! < 55) Then ' stop going off screen top + If convo = 0 Then mes$(0) = "Too high - reduce thrust!" + py! = 55 + vy! = 0 +End If + +other: +GoSub CalcFuel +If liftoff And (lob = 0) Then Return +nomove = demo And (((suri \ q3) + 1) = 5) + +zz = px! - center +z! = Abs(vx!) + +If (nomove = 0) And ((rlink > 0) Or (z! < 3) Or (z! > 20)) Then + dx! = px! - center + px! = center + tmt! = tmt! + dx! +Else + zq = 0 ' was 30 woof woof + c1 = (px! <= (gs + zq)) + c2 = (px! >= (q3 - zq)) + If c1 Or c2 Then + If c1 Then z = q3 - zq Else z = gs + zq + z = z - px! + tmt! = tmt! - z + px! = px! + z + ElseIf (zz <> 0) And (Abs(vx!) <= 5) And (nomove = 0) Then + z = zz \ 2 + 1 + tmt! = tmt! + z + px! = px! - z + End If +End If +If Abs(tmt!) >= q3 Then tmt! = Sgn(tmt!) * q3 - 1 + +If left Then ' jog left (shift left arrow) + If left = 16 Then sv! = vx! + If left > 8 Then a = 4 Else a = -4 + left = left - 1 + If left = 0 Then a = 0: vx! = sv! +End If +If right Then ' jog right (shift right arrow) + If right = 16 Then sv! = vx! + If right > 8 Then a = -4 Else a = 4 + right = right - 1 + If right = 0 Then a = 0: vx! = sv! +End If +Return + +CalcFuel: +If cut Then thrust! = 0 +If lockfuel = 0 Then + ta = Abs(a): If ta > 5 Then ta = 5 ' main angle, up to 5 + z! = (ta + super + Abs(fst)) * t ' plus 10% for thrusters + used! = (thrust! + z!) / 8000 + If ASO Then used! = used! * 2 ' burn faster for AS + If inpause Then used! = 0 + If shield Then used! = used! + .001 + fuel! = fuel! - used! * 4 + If fuel! <= 0 Then fuel! = 0: GoSub CutOrOutOfFuel +End If +Return + +Plotscreen: +If bit! = 0 Then bit! = Timer + pf! +If Timer > bit! Then + bbit = bbit Xor 1 ' toggles twice per second, used all over - instruments, IBM hazard lights, clock colon, LGM ear wiggle + bit! = 0 +End If + +bolthit = 0 +bolthitf = 0 +If (crash = 0) And (Abs(vx!) >= h) Then warp! = Abs(vx!) / h Else warp! = 0 +If warp! >= 1 Then paraf = 0 ' reckon parachute can be dropped at warp speeds + +' change styles every 10/30 seconds +If style! = 0 Then style! = Timer + t +If style! > 86400 Then style! = 1 ' midnite xing +If Timer > style! Then + bstyle1 = (bstyle1 + 1) Mod 3 ' Borg guts every 10s + If bstyle1 = 0 Then bstyle2 = bstyle2 Xor 1 ' Borg exhaust + style! = 0 +End If + +If (starstatus > 0) And (eou = 0) And (vert = 0) And (Rnd > .9999) Then ' stars on+not already falling+WHY?+rarely + mes$(0) = "THE SKY IS FALLING! THE SKY IS FALLING!" + eou = 1 +End If +GoSub CalculateMotion + +If gs Then ' graphics start not 0, instruments are visible + View + pif = (pif + 1) Mod (pdiv + 1) + If pif Then timemachine Else GoSub Instruments ' INSTRUMENTS +End If +If starstatus Then + View Screen(gs, Sgn(Len(mes$(0))) * 20)-(q3, q4) + Stars ' STARS + View Screen(gs, 0)-(q3, q4) +Else + View Screen(gs, 0)-(q3, q4) + Cls +End If + +If Len(mes$(0)) Then + View Screen(gs, 0)-(q3, 20) + Cls + View Screen(gs, 0)-(q3, q4) +End If + +Info ' INFO show timed messages at top, if any +If warp! < 1 Then ' no sky features except star streaks at warp speeds + If skyoff = 0 Then GoSub SkyStuff ' CM/DS/Bo/BH/Wo/Co + GoSub PlotGround ' GROUND/FEATURES + Shells ' SHELLS + If (invincible = 0) And (shield = 0) And (skyoff = 0) Then GoSub FiveWaysToDie +End If +If platform Then Put (pminx, pminy), gbuff(), Or ' falling descent stage +If Len(dead$) = 0 Then GoSub PlotVehicle ' VEHICLE +If (warp! < 1) And showmap And (crash = 0) Then + View + Map ' LM, ground & sky features + View Screen(gs, 0)-(q3, q4) +End If +If bolthit Then ' lightning zap from Deathstar + boltc = boltc + 1 + (boltc = 9999) + rtl!(2) = Timer + 5 + rtlc(2) = boltc + If ((invincible + shield) = 0) And (boltc >= t) Then dead$ = "Zapped!" +End If + +If okrick And (Len(debug$) > 0) Then Locate 1, 12: Print debug$; +timemachine + +Return + +SkyStuff: +If (min = 3) And (sec = 50) Then ' Tree-fiddy! (Southpark), do black hole + ex(3) = suri + t + ey(3) = h + exv(3) = t + eyv(3) = 1 +End If + +If cmleaving Then + exv(0) = exv(0) + 2 + If exv(0) = 0 Then exv(0) = 1 +End If + +Restore skycrud +If eou Then mi = 2 Else mi = 5 ' end of universe, no celestial events +For i = 0 To mi ' 0CM 1DS 2Borg 3BH 4Worm 5Comet 6Al + Read g$, skyset1(i), skyset2(i) +Next i + +For i = 0 To mi + ufof ' 0CM 1DS 2Borg 3BH 4Worm 5Comet 6Alien + xplus = skyset1(i): xminus = skyset2(i) + If (i = 3) And cbh Then ek(i) = 0 ' constant black hole + If ek(i) = -1 Then GoTo ni2 + + If (ey(i) > (q4 + 50)) Or (ey(i) < -50) Or (exv(i) = 0) Then + ei(i) = 0 ' ini + ek(i) = 9999 + nx: + ex(i) = Rnd * q1 + If Abs(ex(i) - (px! + suri)) < q3 Then GoTo nx ' start away from craft + If Abs(ex(i) - px!) < q3 Then GoTo nx ' start away from craft + If i = 2 Then ex(i) = (ex(1) + 3200) Mod q1 + ey(i) = 120 + Rnd * h ' random y 120-220 + If i = 0 Then ey(i) = 22 ' CM + If i = 1 Then ey(i) = 170 ' DS + If i = 2 Then ey(i) = th ' Borg + ' 0 1 2 3 4 5 + ' CMDeBoBHWoCoAl + c1 = Val(Mid$("04010210120502", i * 2 + 1, 2)) ' min x velocity + c2 = Val(Mid$("09030210171005", i * 2 + 1, 2)) ' max x velocity + exv(i) = Rnd * (c2 - c1) + c1 ' random in range + If Rnd > pf! Then exv(i) = -exv(i) + + z = Val(Mid$("00000003020100", i * 2 + 1, 2)) ' top range y velocity + eyv(i) = 0 + If z Then eyv(i) = Rnd * (z - 1) + 1 ' random in range + + If Rnd > pf! Then exv(i) = -exv(i) + If Rnd > pf! Then eyv(i) = -eyv(i) + If (i = 3) And cbh Then + If Rnd > pf! Then + ex(i) = suri - t + exv(i) = t + Else + ex(i) = suri + q3 + t + exv(i) = -t + End If + End If + End If + + ex(i) = ex(i) + exv(i) + ey(i) = ey(i) + eyv(i) + + If ex(i) < 0 Then + If (i = 0) And cmleaving Then + ek(i) = -1: cmleaving = 0 + Else + ex(i) = ex(i) + q1 + End If + End If + If ex(i) > q1 Then + If (i = 0) And cmleaving Then + ek(i) = -1: cmleaving = 0 + Else + ex(i) = ex(i) - q1 + End If + End If + + exl(i) = localize(ex(i), xplus, xminus) + If (i = 3) And cbh And (exl(i) = 9999) Then exv(i) = 0 + + If ek(i) <> -1 Then ek(i) = 9999 + If exl(i) <> 9999 Then + dx! = Abs(px! - exl(i)) + dy! = Abs(py! - ey(i)) + ek(i) = Sqr(dx! * dx! + dy! * dy!) + + If i = 0 Then GoSub CommandModule + If i = 1 Then DeathStar exl(i), f$(37) + If i = 2 Then Borg exl(i), ey(i) + If i = 3 Then + If (Len(mes$(0)) = 0) And (showmap = 0) And (cbh = 0) Then + mes$(0) = "DANGER, WILL ROBINSON, DANGER!" + End If + If sas = 0 Then BlackHole 0 + sas = 0 + End If + If i = 4 Then WormHole + If i = 5 Then + tx = localize(ex(5), 0, 0) + ty = ey(5) + Comet tx, ty + End If + If i = 6 Then ' traditional alien - too silly + j = Rnd * h - h \ 2 + z = ey(6) + j + If (Rnd > .9) And (z > h) And (z < 250) Then + ey(6) = z + alien = alien Xor 1 + ex(6) = ex(6) + 20 * Sgn(alien - pf!) + End If + UFO exl(6), ey(6), exv(6) + End If + End If + ni2: +Next i +Return + +FiveWaysToDie: +If (ek(2) >= 0) And (ek(2) < 20) Then ' Borg + wu! = Timer + 5 + Do: _Limit mdelay + Cls + mes$(0) = "YOU ARE BORG" + Info + Borg exl(2), ey(2) + For i = 1 To rp + p = Point(LMrx(i), LMry(i)) + If p = black2 Then c = green Else c = black2 + PSet (LMrx(i), LMry(i)), c + Next i + timemachine + Loop Until Timer > wu! + dead$ = "BORG" +End If + +If (ek(3) >= 0) And (ek(3) < 30) Then ' black hole + dead$ = "EATEN" + BlackHoleDoom +End If + +If (ek(4) >= 0) And (ek(4) < 30) Then ' wormhole + wu! = Timer + 5 + spx! = exl(4) + spy! = ey(4) + exv(4) = 0 + eyv(4) = 0 + wradar = radarf + radarf = 1 + cut = 1 + Do: _Limit mdelay + Cls + fb$ = "" + mes$(0) = "HOLY CRAP, BATMAN!" + mes$(1) = "" + Info + a = Rnd * 359 + px! = spx! + (Rnd - pf!) * 20 + py! = spy! + (Rnd - pf!) * 5 + WormHole + LMdistort ' optional + GoSub PlotVehicle + timemachine + Loop Until Timer > wu! + radarf = wradar + dead$ = "BATMAN" +End If + +If (ek(5) >= 0) And (ek(5) < 15) Then dead$ = "HIT BY COMET" +If ufof And (ek(6) >= 0) And (ek(6) < 45) Then dead$ = "HIT BY ALIEN" +Return + +GetAlt: +alt! = (gety(-(rxm + wi2)) - ((sy1 + sy2) \ 2)) / 5 +Return + +Instruments: +osc = 8 +If gs Then LoadPanel ' graphics start not zero, instrument panel is on +If (warp! > 0) And (contact = 0) Then + If warp! >= t Then + dead$ = "WARP 10" + Return + End If + Restore warp + For i = 1 To Int(warp!) + Read z$ + Next i + w$ = LTrim$(Str$(Int(warp! * h) / h)) + If Len(w$) = 1 Then w$ = w$ + ".00" + If Len(w$) = 3 Then w$ = w$ + "0" + mes$(0) = "WARP " + w$ + " - " + z$ + If gs And ((Timer Mod t) > 5) Then + Henonp f + Wave ' osc = 5 if commented out + AuHoVe auto, hover, vert, lam + GoTo clock + End If +End If + +If gs = 0 Then Return ' graphics start of 0 means the instrument panel is off + +If panelinit = 0 Then + If crash Then f = 15 Else f = ((f + 1) Mod 5) + t ' title graphic/face +End If + +Henonp f ' title graphic + +Line (0, 0)-(gs - 1, 3), blue2, BF ' clear map area + +If pdiv Then ' instrument update frequency 1-4, mainly a way to slow down erratic thrust display + j = 0 + For i = 1 To 18 ' my name in Morse + p = Val(Mid$("002032023222300032", i, 1)) ' Frost + If p < 3 Then Line (14 + j, 2)-(14 + j + p, 2), white + j = j + p + 2 + Next i +End If + +If (contact + auto + hover + vert + liftoff) = 0 Then + If (vy! > .6) And (-fy! < 0) Then PrintVGA Chr$(24), 5, 241, red, black2 + If (vy! < .4) And (-fy! > -.01) Then PrintVGA Chr$(25), 5, 250, yellow, black2 +End If + +AuHoVe auto, hover, vert, lam + +If tfollow Then ' terrain following! + For ty = glmax - 20 To glmax + For tx = 0 To gs - 1 + If Point(tx, ty) = blue Then PSet (tx, ty), red ' red bg + Next tx + Next ty + For i = 0 To 4 ' TF + p& = Val("&H" + Mid$("E744464444", i * 2 + 1, 2)) + Line (2, 339 + i)-(10, 339 + i), green, , p& * 128 + Next i +End If + +osc = 0 +c = LEDc +If (sbest! >= h) Or powerloss Then c = red +z! = thrust!: If z! > h Then z! = h ' 200 at liftoff, show 100 +PrepAndShowLED z!, 3, 1 ' thrust osc1 +PrintCGA "T", 5, -1, c, -blue, 0 ' T is for flame +i = LEDc: j = black +If jitter Then Swap i, j ' thrust calc type +Line (4, 231)-(5, 232), i, B ' left light (on = slow) +Line (13, 231)-(14, 232), j, B ' right light (on = fast) +Bar z! / h, 0 + +c = dcolor(vy!, 2, 3, 1) ' vy osc2 +z! = vy! +If Abs(z!) > 99.97 Then z! = 99.99 +PrepAndShowLED z!, 3, 2 +PrintCGA "V", 5, -1, c, -blue2, 0 +z! = (z! + 3) / 6 +Bar z!, 1 + +c = dcolor(vx!, 2, 3, 1) ' vx osc3 +If warp! Then + z! = warp! +Else + z! = vx! + rfs! +End If +PrepAndShowLED z!, 3, 2 +PrintCGA "H", 5, -1, c, -blue, 0 +z! = (z! + 3) / 6 +Bar z!, 1 + +GoSub GetAlt ' alt osc4 +If contact And (alt! > 0) Then alt! = 0 +c = dcolor(alt!, t, 3, -1) +PrepAndShowLED alt!, 4, 1 +PrintCGA "A", 5, -1, c, -blue2, 0 +If warp! Or (radarf = 0) Then z! = 0 Else z! = alt! / 60 +Bar z!, 0 + +c = dcolor(fuel!, t, 5, -1) ' fuel osc5 +PrepAndShowLED fuel!, 4, 1 +PrintCGA "F", 5, -1, c, -blue, 0 +z! = fuel! / h +Bar z!, 0 + +clock: +If Timer < start2! Then start2! = Timer ' midnite crossing +If crash = 0 Then el! = el! + (Timer - start2!) ' elapsed time +start2! = Timer +If el! >= 1 Then + While el! >= 1 ' catch-up + el! = el! - 1 + sec = (sec + 1) Mod 60 + If sec = 0 Then min = (min + 1) Mod 99 + Wend + If sec Mod 5 = 0 Then ' change title graphic + If crash Then f = 15 Else f = ((f + 1) Mod 5) + t + End If +End If +z$ = Right$("0" + LTrim$(Str$(min)), 2) + Right$("0" + LTrim$(Str$(sec)), 2) +osc = 6 +LEDdisplay z$ ' clock osc6 + +i = suri + px! +j = Abs(i - sf(5, 2)) +k = sf(5, 2) + (q1 - i) +If j <= 3200 Then dtm! = j Else dtm! = k +PrepAndShowLED dtm!, 4, 0 ' dtm osc7 +PrepAndShowLED CSng(speed), 4, 0 ' speed osc8 +ShowAngle a ' angle osc9 +panelinit = 1 +Return + +LMcolors: ' optional +If contact Or (vx! = 0) Then lbit = 0 +If (contact + vx!) = 0 Then + v1 = Rnd * 3 + v2 = Rnd * 3 + Swap LMci(v1), LMci(v2) +End If +For i = 1 To rp ' right pad + oc = LMoc(i) + LMc(i) = oc + If (oc = craft) Or (oc = red) Then ' shadow + zx = LMrx(i) - px! + 2 - xoff * (inpause = 0) + zy = LMry(i) - py! + If (oc = craft) And ((warp! > 0) Or (zy > zx)) Then + tc = gray2 + Else + tc = oc + End If + LMc(i) = tc + End If + If (i < 279) And (LMoc(i) = black2) Then ' Ascent stage cycle + lbit = (lbit + 5) Mod 4 + LMc(i) = LMci(lbit) + End If +Next i +lbit = lbit - (vx! > 0) * 2 + ASO * t +Return + +PlotVehicle: +If warp! < 1 Then + wda = 0 +Else + px! = wx!: py! = wy! + wda = warp! * 5 * s!((px! + 40) Mod tsix) +End If + +If crash Then + For i = 1 To rp + PSet (LMrx(i), LMry(i)), LMc(i) + Next i + GoTo endproc +End If + +If bolthit = 0 Then GoSub LMcolors + +i = sf(4, 2) - 50 ' left of volcano +j = sf(4, 2) + 50 ' right of volcano +k = suri + px! ' LM position +If (k > i) And (k < j) Then ' in the locality? + c = 0 ' count + For ty = py! + 8 To py! + 18 ' leg/nozzle area + For tx = px! - 17 To px! + 17 + p = Point(tx, ty) ' what color is the pixel? + c = c - (p = orange) ' hot lava + Next tx + Next ty + ' LINE (px! - 17, py! + 8)-(px! + 17, py! + 18), yellow, B ' diagnostics + If c Then ' contacted some lava + For i = rp To 1 Step -1 ' from the bottom + If LMoc(i) = craft Then ' is normal color? + LMoc(i) = red ' make red + nred = nred + 1 ' keep track of count + c = c - 1 + If c = 0 Then Exit For ' enough + End If + Next i + End If +End If + +If nred = 0 Then ' number red + temp = 0 + rtlc(1) = 0 +Else + If ASO Then z = 115 Else z = 223 ' max that COULD be normal + otemp = temp + temp = (nred * h / z) Mod 101 ' temperature + rtlc(1) = temp + If temp > otemp Then rtl!(1) = Timer + 5 + c = 24 ' gasoline + If temp > 30 Then c = 32 ' dark red + If temp > 60 Then c = 4 ' red + If temp = h Then c = 15 ' white + If bw = 0 Then Palette gasoline, c + If (temp = h) And (invincible = 0) Then dead$ = "FRIED BY VOLCANO" + For i = 0 To 20 ' cool down some + j = Rnd * rp + If LMoc(j) = red Then LMoc(j) = craft: nred = nred - 1 + Next i +End If + +n = rp ' last pixel = right pad +If fuel! > 0 Then GoSub Exhaust ' maybe vehicle only + +If n > maxn Then maxn = n + +ta = a + ma ' temp a = a + malfunction +zz = ta * -(Abs(ta) > 4) ' rotate beyond 5 degrees +ta = (zz + wda + tsix * t) Mod tsix ' keep in array bounds +c! = c!(ta) ' cosine +s! = s!(ta) ' sine +ta = zz ' angle to use + +rfx = 0 ' optional craft jitter +rfy = 0 +rfs! = 0 ' random change in vx +If (jitter = 1) And (cut = 0) Then ' not slow or engine cut + If (Rnd > .9) And (a = 0) Then ' a = angle + If Rnd > pf! Then rfx = 1 Else rfx = -1 ' half right, half left + rfs! = rfx * .01 * (Int(Rnd * 9) + 1) ' how much? .01 - .09 + End If + If Rnd > .9 Then ' y jitter, 1 chance in 10 + If Rnd > pf! Then rfy = 1 Else rfy = -1 ' half down, half up + End If +End If + +If doclock Then + i = Val(Mid$(Time$, 1, 2)) + j = Val(Mid$(Time$, 4, 2)) + k = Val(Mid$(Time$, 7, 2)) + clocka(0) = (i + j / 60) * 30 ' hour hand + clocka(1) = j * 6 ' minute hand + clocka(2) = k * 6 ' seconds + For z = 0 To 2 ' prep for radians + clocka(z) = (clocka(z) + 270) Mod tsix + Next z + ao = 0 ' angle offset +Else + ao = (ao + 1) Mod 361 +End If + +tvx = Sgn(vx!): If tvx = 0 Then tvx = 1 +tao = ao * tvx +sco = sco Xor 1 +If doclock Then sco = 0 +If sco Then tc = red Else tc = lmsl +z3 = tsix + (shield = 0) * 361 +For z2 = 0 To z3 + a2 = (z2 + tao * 5 + tsix * t) Mod tsix + 'IF a2 < 0 THEN a2 = 0 + 'IF a2 > 359 THEN a2 = 359 + tx = px! + 50 * c!(a2) * aspect! + ty = py! + 50 * s!(a2) + If ty < gety(tx) Then + If (z2 Mod 30) = 0 Then + Circle (tx, ty), 1, tc, , , .75 + If geof Then + For i = z2 - 120 To z2 Step 30 + j = (i + tsix) Mod tsix + tx2 = px! + 60 * c!(j) * aspect! + ty2 = py! + 60 * s!(j) + Line (tx, ty)-(tx2, ty2), tc + Next i + End If + End If + If doclock Then + For i = 0 To 2 + If a2 = clocka(i) Then + c = Val(Mid$("021404", i * 2 + 1, 2)) + Circle (tx, ty), 4 - i, c, , , .75 + Paint (tx, ty), c, c + End If + Next i + End If + End If +Next z2 + +For i = 1 To rp ' rp = craft right pad + LMrx(i) = px! + LMx(i) * c! + LMy(i) * s! + rfx ' x rotated + LMry(i) = py! - LMx(i) * s! + LMy(i) * c! + rfy ' y rotated + If LMry(i) > glmax Then LMry(i) = glmax ' not below ground + If i = xp Then sx0 = LMrx(i): sy0 = LMry(i) ' save radar loc + If i = lp Then sx1 = LMrx(i): sy1 = LMry(i) ' save left pad loc + If i = rp Then sx2 = LMrx(i): sy2 = LMry(i) ' save right pad loc + If bolthit Then LMc(i) = white + PSet (LMrx(i), LMry(i)), LMc(i) +Next i + +If fuel! < 95 Then GoSub flevel + +eflag = 0 ' determine flame climb +fx1 = 0 ' initialize for deflect +fx2 = 0 +phg = (sx1 + sx2) \ 2 + ta * 2 ' point hit ground + +tty! = py! + 26 + +For i = rp + 1 To n ' flame/fuel dump + x = px! + LMx(i) * c! + LMy(i) * s! + rfx ' x rotated + y = py! - LMx(i) * s! + LMy(i) * c! + rfy ' y rotated + c = LMc(i) ' fuel dump/flame + If warp! < 1 Then GoSub deflect ' deflect off ground + c = Abs(c) ' color + PSet (x, y), c ' flame particle + If i <= n3 Then ' main exhaust + If (i Mod t) = 1 Then ' every 10th pixel + Line (x - 1, y)-(x + 1, y), c ' make "+" + Line (x, y - 1)-(x, y + 1), c + End If + End If +Next i + +If rfx And dump And (a = 0) Then vx! = vx! + rfs! ' make jitter real +If rfx And (dump = 0) And (a <> 0) Then vx! = vx! + rfs! + +endproc: + +If doclock Then TextOnLM$ = Left$(Time$, 5) +If Len(TextOnLM$) Then GoSub TextOnLM + +GoSub radar + +fc = 0 ' LGM flame count +If (sf(3, 1) >= suri) And (sf(3, 0) < (suri + q3)) Then + x1 = sf(3, 0) - suri + y1 = gety(x1) - 14 + For x = x1 + 5 To x1 + 15 + For y = y1 - 9 To y1 + 12 + If Point(x, y) = yellow Then fc = fc + 1 + Next y + Next x +End If + +GoSub KillThreats + +geof = geof - 1 - (geof = 0) + +If ok And (Timer > wu2!) And (InStr(mes$(0), "IN CAR") = 0) Then FlagandFireworks + +mpass& = mpass& + 1 +If Timer <= start1! Then start1! = Timer: mpass& = 1 +speed = ((Timer - start1!) / mpass&) * h * t + +If rick Then GraphSpeed + +If magic = 1 Then ' magic landing, 1st step laser the surface to level + sf = 0 + z = suri + px! + If z > q1 Then z = z - q1 + sf(0, 0) = z - 35 ' cut out a swath 70 units wide + sf(0, 1) = z + 35 + GoSub lsurface ' apply laser + a = 0 ' angle + auto = 0 ' autopilot + vx! = 0 ' cancel any x velocity + vy! = 0 ' cancel any y velocity + py! = 331 + ASO * 9 ' ground has been cut to the lowest + cut = 1 ' signal engine off + magic = 2 +End If + +' kill surface feature +If firel And ksf And (contact = 0) And (sf(sf, 2) > 0) Then + GoSub lsurface +End If +firel = ks ' ks = keep shooting + +' terrain following +If tfollow And (contact = 0) And (dump = 0) And (liftoff = 0) Then + hover = 1 + hp = q1 + svx = Sgn(vx!) + If svx < 0 Then tx = sx1 Else tx = sx2 + la = Abs(vx!) * t + If la < t Then la = t + If la > h Then la = h + For i = -(wi + 5) To la + j = tx + i * svx + k = j + If k < 0 Then k = k + q1 + If k > q1 Then k = k - q1 + z = gety(k) + If z < hp Then hp = z: sx = j + Next i + cx = Abs(sx - tx) + If cx Then + cy = hp - t - Abs(a / 2) - sy1 + st! = cy / cx * (Abs(vx!) + 1) + If st! > 2 Then st! = 2 + If st! < -t Then st = -t + fst = -Sgn(st!) * 2 + py! = py! + st! + If py! < 250 Then py! = 250 + End If +End If +If paraf Then + If py! > 150 Then mes$(0) = "Parachutes don't work in a vacuum!" + Parachute +End If + +Return + +TextOnLM: +If (ASO = 0) And (Abs(ta) < t) Then + lt = Len(TextOnLM$) + tx = px! - lt * 2 + rfx + ty = py! + rfy + If ty > 340 Then ty = 340 + TinyFont TextOnLM$, tx, ty, white +End If +TextOnLM$ = "" +Return + +KillThreats: +killed = 0 +For i = 0 To 20 ' shells + c1 = shield And (shx(i) > 0) And (shd(i) < 70) ' shield on and shell close to LM + c2 = firel And (shx(i) > 0) ' fire laser and shell in air + If c1 Or c2 Then + killed = 1 ' found something to kill + tx = shx(i) - suri + ty = shy(i) + GoSub LMfl ' fl = fire laser + If Len(dead$) Then Return + ExplodeShell i + End If +Next i + +ks = 0 +For i = 1 To 6 + If skyoff Or (ek(i) = -1) Then GoTo ni3 + ' CM DS BO BH WO Co + If firel And (exl(i) > gs) And (exl(i) < q3) Then + killed = 1 + ks = 1 + tx = exl(i) + ty = ey(i) + If laserb = 0 Then laserb = 5 + If laserb > 0 Then + GoSub LMfl + If Len(dead$) Then Return + k = (5 - laserb) * 4 + If i > 1 Then + Circle (tx, ty), k, yellow + Paint (tx, ty), yellow, yellow + End If + laserb = laserb - 1 + End If + If laserb = 0 Then + ks = 0 + If i = 1 Then + mes$(1) = "The Dark Side has cookies!" + Else + For a2 = 0 To tsix Step 2 + x2 = tx + Rnd * h * c!(a2) * aspect! + y2 = ty + Rnd * h * s!(a2) + Line (tx, ty)-(x2, y2), gold + Next a2 + ek(i) = -1 + exv(i) = 0 + exl(i) = -1 + If (i = 2) And lob Then dead$ = "SELF-DESTRUCT" + End If + End If + End If + ni3: +Next i +If killed Then ksf = 0 Else ksf = 1 +Return + +lsurface: ' laser surface feature +z = (Rnd > .9) Or (magic = 1) ' 1 out of 10 destroys, magic always +For i = sf(sf, 0) To sf(sf, 1) + tx = i - suri + If tx < 0 Then tx = tx + q1 + ty = gety(tx) + If sf <> 3 Then ty = ty + Rnd * (q4 - ty) + If i Mod 2 Then GoSub LMfl ' fire laser + If z Then gh(i) = glmax ' level +Next i +If z Then + Smooth sf(sf, 0) - 1 ' smooth transition from where the ground has been leveled, left side + Smooth sf(sf, 1) ' , right side + sf(sf, 2) = -1 +End If +Return + +LMfl: ' fire laser +If (cwd < 50) And (sy1 > szs) Then ' in car wash? + dead$ = "REFLECTED LASER" + cwd = 999 + firel = 0 + laserb = 0 + ks = 0 + Return +End If +For zx = -1 To 1 + For zy = -1 To 1 + Line (sx0 + zx, sy0 + zy)-(tx, ty), lmsl + Next zy +Next zx +geof = t +Return + +flevel: ' make fuel level when angle > 4 +If ASO Then Return ' no fuel shown with AS +ptk = (h - fuel!) * 2.7 ' pixels to kill +z = ptk ' ptk used by ExplodeLM +x1 = px! - 16 +x2 = px! + 14 +y1 = py! - 15 +y2 = py! + 15 +For y = y1 To y2 + For x = x1 To x2 + If Point(x, y) = fuel Then + PSet (x, y), black2 + z = z - 1 + End If + Next x + If z <= 0 Then Exit For +Next y +Return + +deflect: ' flame bounce +oz = gety(-x) +If deflectat > 0 Then oz = deflectat +z = oz + +' dump side t st in pause +If (c = fuel) Or (c = -yellow) Or (c = -blue) Then + If (fx1 > 0) And (x < fx1) Then z = 0 + If (fx2 > 0) And (x > fx2) Then z = 0 + rf1 = Rnd * t + 1 + rf2 = Rnd * 20 - t + If y >= (z - 1) Then ' yep, deflect it + If x < sx1 Then + If fx1 = 0 Then fx1 = x: fy1 = LMry(th1) + x = fx1 + rf1 + y = fy1 + rf2 + Else + If fx2 = 0 Then fx2 = x: fy2 = LMry(th2) + x = fx2 - rf1 + y = fy2 + rf2 + End If + End If + Return +End If + +If y >= (z - 1) Then ' yep, deflect it + If sy1 < borgt Then ky1 = 1: GoTo isborg + If eflag = 0 Then ' limit flame climbing + eflag = 1 ' only once per position + xmin2 = phg - thrust! * 1.5 ' point hit ground + xmax2 = phg + thrust! * 1.5 + u1 = 0 ' up count l of nozzle + u2 = 0 ' up count r of nozzle + wu1 = 0 ' worst l up count + wu2 = 0 ' worst r up count + ky1 = 0 ' keep y + ky2 = 0 ' keep y + For zz = phg To phg - h Step -1 ' from LM center left + z2 = gety(-zz): If zz = phg Then lz = z2 + k1 = z2 - lz + lz = z2 + If k1 > 0 Then ' down + u1 = 0 + Else + u1 = u1 - k1 ' up + If u1 > wu1 Then wu1 = u1 ' worst up + End If + If u1 > 20 Then xmin2 = zz + 2: Exit For + If Abs(k1) > 20 Then ky1 = 1 ' 90 degrees TMA etc + Next zz + For zz = phg To phg + h ' from LM center right + z2 = gety(-zz): If zz = phg Then lz = z2 + k2 = z2 - lz + lz = z2 + If k2 > 0 Then ' down + u2 = 0 + Else + u2 = u2 - k2 ' up + If u2 > wu2 Then wu2 = u2 ' worst up + End If + If u2 > 20 Then xmax2 = zz - 2: Exit For + If Abs(k2) > 20 Then ky2 = 1 ' 90 degrees TMA etc + Next zz + End If + + isborg: + r = thrust! * 2 + (Rnd - pf!) * 80 + x = (phg - r) + Rnd * (r * 2) + k = Abs(x - phg + a * 2) / 4 + + tx = x + suri ' McDonalds + If (tx >= sf(5, 0)) And (tx <= sf(5, 1)) And (py! > 250) Then + ky1 = 0: ky2 = 0 + End If + + If (ky1 = 1) Or (ky2 = 1) Then ' keep + y = z - Rnd * k - 1: Return + End If + + x2 = (Rnd - pf!) * 20 + If x < xmin2 Then x = xmin2 + Rnd * (xmax2 - xmin2) + x2 + If x > xmax2 Then x = xmin2 + Rnd * (xmax2 - xmin2) - x2 + + If (platform > 0) And (Abs(px! - (pminx + 17)) < 20) Then + y = y - platform + Else + y = gety(-x) - Rnd * k - 1 + End If + + If (deflectat > 0) And (y > deflectat) Then y = deflectat - (y - deflectat) +End If +Return + +CWceiling: ' car wash +cwd = Abs((suri + px!) - sf(2, 2)) ' car wash distance +If ASO Then szs = 323 Else szs = 340 ' safe zone start +If (cwd < 69) And (sy1 > 304) Then ' lower than top of building + If sy1 >= q4 Then ' touched down inside + cc1 = -1 + ElseIf sy2 >= q4 Then ' touched down inside + cc2 = -1 + ElseIf sy1 > szs Then ' in safe zone + cc1 = 0 + cc2 = 0 + If cwd < 50 Then mes$(0) = "Washee washee no starchee!" + Else + If (sy1 > (szs - t)) And (sy1 <= szs) Then ' bouncing off ceiling + cc1 = 0 + cc2 = 0 + vy! = 1 + py! = py! + 2 + 'hover = 1 + End If + End If +End If +Return + +CheckHit: ' contact with ground +cc1 = ((sy1 + 1) >= gety(-sx1)) ' left pad +cc2 = ((sy2 + 1) >= gety(-sx2)) ' right pad +mingx = 0 +mingy = q1 +For zx = sx1 To sx2 ' check between pads + zy = sy1 - 2 + p = Point(zx, zy) + If p = gray Then ' got 1 + ty = gety(-zx) + If ty < mingy Then mingx = zx: mingy = ty + End If +Next zx +If mingx Then + i = mingx - sx1 + j = sx2 - mingx + If i < j Then cc1 = -1 Else cc2 = -1 +End If + +GoSub CWceiling ' car wash +If vy! < 0 Then Return ' going UP + +If cc1 Or cc2 Then ' pad(s) on ground + contact = 1 + tmt! = 0 + py! = py! + rfy ' no time to correct jitter + TexOnLM$ = "" + warp! = 0 + GoSub CutOrOutOfFuel + + If (vy! > 0) And Abs(sy1 - (ey(2) - 40)) < t Then + lob = 1 ' landed on Borg + vx! = vx! - exv(2) + End If + + If (Abs(vx!) > t) Or (vy! > 20) Then + dead$ = "HIGH SPEED IMPACT!" + Return + End If + + dp = 8 + (h - fuel!) \ 25 ' 8 - 12 + If (vy! > dp) Or (Abs(vx!) > 8) Then ' too fast given load + crash = 1 + panelinit = 0 + shield = 0 + dead$ = "CRASHED" + z = Abs(vx!) * t + Abs(vy!) * t + For i = 1 To rp ' create layer of debris + LMrx(i) = LMrx(i) + Rnd * z - (z \ 2) + LMry(i) = gety(LMrx(i)) - Rnd * 2 - 1 + Next i + If bw = 0 Then + Palette green, 0 ' blank instruments + Palette yellow, 0 + End If + Return + End If + + If (vy! > 3) Or (Abs(vx!) > 3) Then fb$ = "vehicle damaged" + + If (vy! > 4) Or (Abs(vx!) > 4) Then + fb$ = "vehicle severely damaged" + LMdistort ' randomly vary structure + vsd = 1 ' vehicle severely damaged + End If + + savea = a + ma + + If lob Then ' landed on Borg + a = 0 + If sx1 < borgl Then a = 45 + If sx2 > borgr Then a = -45 + py! = py! - t * (Abs(a) = 45) + Return + End If + + ' optional, allow ANY part of pad + If cc1 Then cd = -1: cpx = sx2: cpy = sy2 + 1 + If cc2 Then cd = 1: cpx = sx1: cpy = sy1 + 1 + For i = 1 To 4 + cpx = cpx + cd + If (cpy >= gety(-cpx)) Then + If cc1 Then cc2 = 1 Else cc1 = 1 + End If + Next i + + If Not (cc1 And cc2) Then ' only 1 pad down + npass = 0 + Do: _Limit mdelay * 2 ' settle LM + a = a + (cc1 - cc2) + pa: + npass = npass + 1 + If npass > 150 Then Exit Do + GoSub Plotscreen ' show change + If Len(dead$) Then Exit Do + If Abs(a) > 40 Then + a = 180 ' upside down + py! = glmax - ny + LMdistort ' optional + Exit Do + End If + If cc1 And (sy1 < gety(-sx1)) Then py! = py! + 1: GoTo pa + If cc2 And (sy2 < gety(-sx2)) Then py! = py! + 1: GoTo pa + cc3 = ((sy1 + 1) >= gety(-sx1)) + cc4 = ((sy2 + 1) >= gety(-sx2)) + If Abs(a) > 80 Then py! = glmax - wi2 + + z = gety(Int(px!)) - py! - ny + 5 + If (z < 0) And (paraf = 0) Then + dead$ = "PUNCTURE DAMAGE" + Return + End If + Loop Until (cc1 And cc4) Or (cc2 And cc3) + End If +End If +Return + +slimit: ' surface index bounds +z = 0 +If suri < 0 Then z = q1 +If suri >= q1 Then z = -q1 +suri = suri + z +If lock1 Then lock1 = lock1 + z +Return + +radar: ' autopilot landing here too +If contact Or liftoff Then Return +z = Sgn(vx!): If z = 0 Then z = 1 +If z = -1 Then sbl = -280 Else sbl = 220 +bt = (bt Mod 4) + 1 +div = Abs(alt!) \ 2 + bt + +If right Or left Then tvx! = sv! Else tvx! = vx! +If Abs(tvx!) > 99 Then tvx! = 99 * Sgn(tvx!) +If (tfollow = 0) And (aboveborg Or ((radarf = 0) And (auto = 0))) Then tvx! = 0 +bl = sbl * Abs(tvx!) + (sx1 - sx2) +If Abs(bl) > Abs(sbl) Then bl = sbl +If auto = 0 Then lock1 = 0 +If lock1 = 0 Then rxm = sx2 + bl Else rxm = lock1 - suri + +level = 1 +For j = 0 To wi ' width (distance between pads) + tx = rxm + j + ty = gety(-tx) + If aboveborg And (sx1 >= borgl) And (sx2 <= borgr) Then ty = borgt + If j = 0 Then cmp = ty + If Abs(cmp - ty) > 1 Then level = 0 +Next j + +If level Then + If auto And (lock1 = 0) Then ' automatic yet no current lock + lock1 = suri + rxm - Sgn(rxm) * 2 * (vx! <> 0) ' lock onto level ground + End If + rbeam = green ' radar beam color +Else + lock1 = 0 ' not level, cancel lock + rbeam = red ' radar beam color +End If + +rpass = rpass Xor 1 +If level And (vx! = 0) Then + div = div \ 2 + If div < 1 Then div = 1 + If rpass Then rbeam = 0 +End If + +For i = 0 To (wi + 1) Step 5 + If vx! > 0 Then tx = rxm + i Else tx = rxm + wi - i + If aboveborg Then + tx = sx1 + i + ty = borgt + Else + ty = gety(tx) + End If + If (warp! < 1) And (ty > sy0) And (radarf > 0) Then GoSub rbeam +Next i + +If auto = 0 Then GoTo end6 +If aboveborg Or (abort = 0) Then GoTo skipit + +abort: +hover = 1 +hoverc = 0 +lock1 = 0 + +i = (py! > 120) ' too low +j = Not ((vx! = 0) And (level = 1)) And (Abs(vx!) < (ideal! - .05)) ' too slow +k = (Abs(vx!) > (ideal! + .05)) ' too fast +If i Then wa = -ma: hoverc = -3 +If j Then wa = 4 * -z + ma +If k Then + wa = Abs(vx!) * z - ma + If Abs(wa) > 20 Then wa = 20 * z +End If +If i Or j Or k Then abort = 1: GoTo end6 +abort = 0 + +skipit: +If lam Then ' land at McDonalds + dis = Abs((suri + rxm) - sf(5, 2)) + If dis > 80 Then level = 0: lock1 = 0 +End If +wa = -ma ' want angle = -malfunction angle + +If dflag Then dump = 0: dflag = 0 +If level = 0 Then ' locked onto a target + abort = 1 +Else + ddd = Abs(px! - rxm) + If (ddd < 120) And (lock1 > 0) And (auto = 1) And (fuel! > 70) Then + dump = 1 + dflag = 1 + End If + If ddd < h Then ' 100 clicks away + hover = 0 ' stop hovering + vert = 1 ' start moving down + dist = sx1 - rxm ' distance to target + thv! = Abs(dist) / 27 ' to horizontal velocity + If thv! < .08 Then mu = 1 Else mu = 4 + If thv! < .01 Then mu = 0 + If aboveborg = 0 Then + If Abs(vx!) > thv! Then wa = wa + mu * z + End If + End If +End If +end6: +GoSub angle +Return + +rbeam: +dx! = (tx - sx0) / div +dy! = (ty - sy0) / div +For j = 1 To q1 + tx = sx0 + j * dx! + ty = sy0 + j * dy! + my = gety(-tx) + If ty >= my Then + If (tx < rxm) Or (tx > (rxm + wi + 1)) Then level = 0: rbeam = red + Exit For + End If + If i And (rbeam > 0) Then + PSet (tx, ty), rbeam + If radarf = 2 Then PSet (tx + 1, ty), rbeam + End If +Next j +Return + +angle: +If dump Then Return +cf = 0 +If a <> wa Then ' current angle, wanted angle + w = a ' was = angle + a = a + Sgn(wa - a) + change = a - w + If change Then + cf = 1 + a1 = Abs(w + ma) + a2 = Abs(a + ma) + If (a1 > 4) Or (a2 > 4) Then wan = 3 ' activate up/down + End If +End If + +If liftoff Or ((auto = 0) And (vert = 1) And (ma = 0)) Then Return +cp = (a <> 0) And (Rnd < .01) ' clear problem + +If cf Or cp Then + If cp Or (Rnd < .01) Then + z = ma + If cp Then ma = 0 Else ma = a + If ma <> z Then ' new malfunction angle + If ma Then + z$ = LTrim$(Str$(-ma)) + If ma < 0 Then z$ = "+" + z$ + mes$(0) = "DANGER! STUCK THRUSTER " + z$ + If auto Then a = a - ma: wa = a - ma ' immediate correct + Else + mes$(0) = "THRUSTERS OK" + If auto Then a = a + z: wa = a + z ' immediate correct + End If + End If + End If +End If +Return + +Exhaust: +If inpause Then tflame = blue Else tflame = flame + +If cut Then thrust! = 0 +d = thrust! - (Rnd * 20 - t) * (thrust! > 0) +x = (LMx(lp) + LMx(rp)) \ 2 ' halfway between pads + +If ASO Then ' ascent stage only + i = 30 ' divisor for exhaust width + j = 1 ' throwing x off up to this amount + k = 3 ' flame decrement + y = ny + 1 ' starting y +Else + i = 20 ' divisor for exhaust width + j = 2 ' throwing x off up to this amount + k = 2 ' flame decrement + y = ny - 3 ' starting y +End If + +While d > 0 ' until thrust decremented to 0 + p = d \ i + For z = -1 To 1 Step 2 + For jj = 0 To 3 + n = n + 1 ' add to vehicle daa + If n > 1400 Then End ' beyond array size + LMx(n) = x + p * z + Rnd * (j * 2) - j + LMy(n) = y + Rnd * 2 + If (powerloss > 0) And (Rnd < .3) Then zz = orange Else zz = tflame + LMc(n) = zz ' yellow normally, blue during pause + If Rnd > .95 Then ' some way off plume for realism + LMx(n) = LMx(n) - Rnd * 80 + 40 + LMy(n) = LMy(n) + 5 + End If + Next jj + Next z + y = y + 1 ' next flame row + d = d - k ' decrement temp thrust +Wend +n3 = n ' main/side thrusters + +' if there's a thruster malfunction, may have both thrusters active +If (ma = 0) Or (a = 0) Or (Sgn(a) = Sgn(ma)) Then + ta = a + ma + pass = 1 +Else + ta = a + pass = 2 +End If +If dump Then ta = t + +dors: ' dump fuel or sideways motion +If liftoff Then ta = 0 +If rfx And (dump = 0) Then ta = rfs! * 50 +If (contact = 1) And (dump = 0) Then ta = 0: wan = 0: super = 0 +If ta <> 0 Then + If ta < 0 Then th0 = th1: z! = -2 + If ta > 0 Then th0 = th2: z! = 2 + zz = ta: If zz > t Then ta = t + tt = Abs(zz * 4 + 4 * Sgn(ta)) + If Abs(zz) > 20 Then tt = t + Do + n = n + 1 + LMx(n) = LMx(th0) + z! + Rnd * 2 - 1 + LMy(n) = LMy(th0) + (Rnd * 2 - 1) * (Abs(ta) > 2) + If dump Then + tc = fuel + z = 20 - 20 * s!(90 + (LMx(n) - LMx(th0)) * 1.8) + If a = 180 Then z = -z + LMy(n) = LMy(n) + z + Else + tc = -tflame + End If + LMc(n) = tc + tt = tt - 1 + z! = z! * 1.15 + Loop Until (tt = 0) Or (Abs(z!) > 40) + If dump Then + ta = -ta + If lockfuel = 0 Then fuel! = fuel! - .1 + (fuel! > 5) * 2 + If ta = -t Then GoTo dors + If fuel! < 1 Then dump = 0 + End If +End If +pass = pass - 1 +If pass Then ta = ma: GoTo dors +noside: + +' super - use side thrusters to augment main thrust when more than +' 100% thrust is called for +If dump Then Return +If fst Or super Or (wan > 0) Then ' up/down to change angle beyond 5 degrees + If change > 0 Then th1d = -1: th2d = 1 + If change < 0 Then th2d = -1: th1d = 1 + If super Then th1d = 1: th2d = 1 + If fst Then th1d = fst: th2d = fst: fst = 0 + For z = 0 To 6 + n = n + 1 + LMx(n) = LMx(th1) + Rnd * 2 + LMy(n) = LMy(th1) + th1d * (z + Rnd * 2) + 2 + LMc(n) = tflame ' blue flame in pause + n = n + 1 ' other thruster opposite + LMx(n) = LMx(th2) + Rnd * 2 - 2 + LMy(n) = LMy(th2) + th2d * (z + Rnd * 2) + 2 + LMc(n) = tflame + Next z + wan = wan - 1 + If wan = 1 Then change = -change +End If + +Return + +init1: ' only done once +Data convo,f1,f2,lmx1,lmy1,lmc1,lmx2,lmy2,lmc2 +Data h1,h2,h3,h4,h5,h6,cybill,surv2,cm,rad,af2,sf2,panel +Data sd,sl,s0,s1,s2,s3,s4,s5,s6,s7,s8,s9,panel0,panel1 +Data dstarm,stars,lanblank,alien + +$If WIN Then + slash$ = "\" +$Else + slash$ = "/" +$End If + +mpath$ = _CWD$ +If Right$(mpath$, 1) = slash$ Then mpath$ = Left$(mpath$, Len(mpath$) - 1) ' root (maybe USB stick?), take off slash +mpath$ = mpath$ + slash$ + "L64_DAT" + slash$ + +Restore init1 +If _FileExists("rick.txt") Then okrick = 1 +tc$ = UCase$(Command$ + " ") +If Left$(tc$, 1) = "/" Then tc$ = " " +If InStr(tc$, "DOS") Then dosbox = 0 ' use large star file +If InStr(tc$, "BOX") Then dosbox = 1 ' use small star file +If InStr(tc$, "CD ") Then iscd = 1 ' simulate CD +If InStr(tc$, "UFO ") Then ufof = 1 ' +If _FileExists("cd.dat") Then iscd = 1 ' include/create this file for CD/DVD distribution (read only) + +z = 0 +For i = 1 To 40 + Read f$(i) + If i = 38 Then ' stars + j = 2 - dosbox ' 1=small, 2=medium, 3=huge + f$(i) = f$(i) + Chr$(48 + j) + End If + f$(i) = mpath$ + UCase$(f$(i) + ".dat") + If _FileExists(f$(i)) = 0 Then ' file missing + z = z + 1 + If z = 1 Then Cls + Print f$(i) + End If +Next i +If z Then + Print + Print "mpath$ = "; mpath$ + Print "Above file(s) missing" + Sleep + System +End If + +s& = VarSeg(p(0, 0)) +o& = VarPtr(p(0, 0)) +Def Seg = s& +BLoad f$(2), o& +z$ = "386C6C38" ' degree symbol +For i = 0 To 3 + p(0, i) = Val("&H" + Mid$(z$, i * 2 + 1, 2)) +Next i + +s& = VarSeg(p2(0, 0)) +o& = VarPtr(p2(0, 0)) +Def Seg = s& +BLoad f$(3), o& + +canvas& = _NewImage(640, 350, 9) +Screen canvas& +_AllowFullScreen , Off +_ScreenMove _Middle +_MouseHide +_MouseMove 1, 1 +_Title "Lander" +Randomize Timer +auto = 0 ' full automatic +background = 1 ' textured LED displays +cbh = 0 ' constant black holes +darkstars = 1 ' spin +darkstart = 1 ' thickness of lines +demo = 0 ' cram onto one page +doclock = 0 ' shield effect +gh = 9 +gs = 85 ' graphics start +glmax = q4 ' ground level max +glmin = glmax - 49 ' ground level min +gs = 85 ' graphics start (flying area) +'gstyle = 5 +invincible = 1 ' easier for beginner, thrusters gold +jitter = 1 ' thrust calc +LED$ = "021404120115" ' color sequence - gr ye re or gun wh +LEDc = green ' +LEDtri = 0 ' off +mdelay = t ' master delay +opower = 62 ' original thrust factor +pdiv = 0 ' instrument update +radarf = 1 +segs$ = "abcdefg" ' for 7 segment displays +settings$ = mpath$ + "LANDER.SET" +shield = 0 ' Star Trek! +showmap = 0 ' silly legend at top +skyoff = 1 ' DS, BH, Wo, Co +starfiles = 1 ' dat1, dat2, dat3 +starstatus = 1 ' show stars only, no names/info +twinkle = 1 ' stars +zoom = 1 ' starfield 6 hours 45 degrees + +black = 0: blue = 1: green = 2: gunmetal = 3: red = 4: gasoline = 5 +gray2 = 6: white = 7: gray = 8: dred = 9: gold = 10: black2 = 11 +orange = 12: blue2 = 13: yellow = 14: white2 = 15 + +craft = white: flame = yellow: fuel = gasoline: LEDc = green +LMci(0) = gray2 ' ASO shifting colors +LMci(1) = gold +LMci(2) = gray2 +LMci(3) = black2 + +If _FileExists(settings$) Then + Open settings$ For Input As #1 + nflags = 0 + Do + If EOF(1) Then Exit Do + Input #1, g$ + If EOF(1) Then Exit Do + nflags = nflags + 1 + Input #1, tflags(nflags) + Loop + Close #1 +End If + +auto = tflags(1) +background = tflags(2) +cbh = tflags(3) +demo = tflags(4) +doclock = tflags(5) +invincible = tflags(6) +jitter = tflags(7) +LEDc = tflags(8) +LEDtri = tflags(9) +radarf = tflags(10) +shield = tflags(11) +showmap = tflags(12) +starstatus = tflags(13) +zoom = tflags(14) +skyoff = tflags(15) +gstyle = tflags(16) +mouseswap = tflags(17) +porb = tflags(18) +starfiles = tflags(19) +mdelay = tflags(20) +fsf = tflags(21) + +If fsf Then + _FullScreen +Else + If _FullScreen = 0 Then _FullScreen _Off +End If + +For i = 0 To tsix ' sines and cosines, table faster + s!(i) = Sin(_D2R(i)) + c!(i) = Cos(_D2R(i)) +Next i + +clines = 0 +Open f$(1) For Input As #1 ' convo.dat, LM/CM chatter +While Not (EOF(1)) + clines = clines + 1 + Line Input #1, convo$(clines) +Wend +Close #1 + +s& = VarSeg(cmp&(0)) ' Command Module +o& = VarPtr(cmp&(0)) +Def Seg = s& ' cm.dat +BLoad f$(18), o& + +If (restart = 0) And ((Rnd > .9) Or (InStr(LCase$(Command$), "regen"))) Then MakeSur ' new surfaces +gh = 9 ' which surface to use (1-9) +restart = 0 +start1! = Timer +Return + +init2: ' each cycle +a = 0 ' angle +a51i = 0 +ASO = 0 ' ascent stage only = false +boltc = 0 ' lightning count +center = 362 +contact = 0 ' with ground +convo = 0 ' with CM +crash = 0 +cut = 0 ' engine +dump = 0 ' fuel +eou = 0 ' end of universe +fb$ = "" ' landing feedback +flx = 0 ' where to plot flag +fuel! = h +hover = 1 ' start safe +ideal! = 2.7 ' autopilot speed +inpause = 0 +jf = -1 ' jump to feature +LGMc = 1 ' little green man color +lmsl = blue ' LM shield & laser +lob = 0 ' landed on Borg +lock1 = 0 ' radar tracking +lockfuel = 0 +ma = 0 ' malfunction angle +magic = 0 ' landing +mes$(0) = "" ' messages ^ landing eval +mes$(1) = "" ' radiation, landing comments +ok = 0 ' landing status +panelinit = 0 ' instruments +paraf = 0 ' parachute flag +pif = -1 ' counter for instruments +platform = 0 ' for detached DS +power = opower ' thrust factor +powerloss = 0 ' random malfunction +px! = 320 ' vehicle x +py! = 70 ' vehicle y +radiationdeath = 0 ' rads > 1000 +rads = 0 ' radiation count +rlink = 0 ' LM/CM radio link +rmin = Rnd * 23 ' stars right ascension 0 - 23 +dmin = (Int(Rnd * 18) - 9) * t ' stars declination -90 to 90 +sia = 0 ' shells in air +sspinit1 = 0 +sspinit2 = 0 +starinit = 0 +tfollow = 0 ' terrain following +tmt! = 0 ' to move total +wa = 0 ' wanted angle +vert = 1 ' vertical autopilot on +vsd = 0 ' vehicle severely damaged + +Setcolor +GetSurface gh + +If demo Then + auto = 0 + px! = sf(6, 2) - 3130 ' TMA + py! = 130 + sf = 6 ' surface feature + suri = 3130 ' surface index + vx! = 0 ' not moving + vy! = 0 +Else + a = Rnd + t + If Rnd > pf! Then a = -a + sf = 4 + suri = Rnd * q1 + px! = 320 + thrust! = 95 + vx! = Sgn(a) * 5 + vy! = Rnd + 1 +End If + +Erase exv, ei, ek, rtl!, rtlc, shx, shd + +mes$(0) = "F1 FOR HELP AND INFORMATION" +If ufof > 0 Then mes$(1) = "Alien on the loose!" ' 10% active +If LEDtri Then LEDc = green +GoSub ReadLM +start2! = Timer ' elapsed time clock +sec = 0 +min = 0 +Return + +PlotGround: +If crash = 0 Then + surd = Sgn(tmt!) ' direction + tomo = Int(Abs(tmt!)) ' to move + If tomo > (q3 - gs) Then tomo = q3 - gs + tmt! = tmt! - tomo * surd ' to move total + suri = suri + tomo * surd ' surface index + GoSub slimit ' limit values to 0-6399 +End If + +If gh = -1 Then ' ground height = flat + Line (gs, q4)-(q3, q4), gray + GoTo stuff +End If + +For x = gs To q3 ' graphics start to 639 + z = (suri + x) Mod q1 + tc = gray + If (z >= sf(5, 0)) And (z <= sf(5, 1)) Then + PSet (x, glmax), tc ' optional McD fix + Else + If (z >= sf(7, 0)) And (z <= sf(7, 1)) Then ' Surveyor + y = glmax + Else + y = gety(x) + End If + Select Case gstyle + Case Is = 0 ' solid + Line (x, y)-(x, glmax), tc + Case Is = 5 ' solid + Line (x, y)-(x, glmax), tc + Case Is = 1 ' fancy + Line (x, glmax)-(x, y), black2 + Line -(x, glmax), tc, , z + y + PSet (x, y), tc + Case Is = 2 + Line (x, y)-(x, glmax), tc + ty = y + 5 + If ty < glmax Then + Line (x, ty)-(x, glmax - 1), black, , &HFEFE + End If + Case Else ' minimal or tiling + Line (x, glmax)-(x, y), black2 + Line -(x, y + 3), tc + End Select + End If +Next x + +If gstyle > 3 Then Tile + +stuff: +For i = 1 To t + ' Surv before IBM+TMA, IBM before TMA, LGM last + ' 1 2 3 4 5 6 7 8 9 0 + j = Val(Mid$("01070802040506091003", (i - 1) * 2 + 1, 2)) + z = Val(Mid$("80000080000080000000", (j - 1) * 2 + 1, 2)) + fb = sf(j, 0) - z + fe = sf(j, 1) + z + c1 = (fe >= (suri + gs)) And (fb <= (suri + q3)) + c2 = ((fe + q1) >= (suri + gs)) And ((fb + q1) <= (suri + q3)) + If c1 Or c2 Then + sf = 0 + If sf(j, 2) = -1 Then GoTo nf + sf = j + x = sf(sf, 0) - suri + z = sf(sf, 1) - suri + + If (j = 1) And (x < 0) And (suri > 3000) Then x = x + q1: z = z + q1 + bolthitf = (skyoff = 0) And (boltx >= x) And (boltx <= z) And (exl(1) <> 9999) + If j = 1 Then + Area51 f$(40) + If (cut = 0) And (Left$(mes$(1), 7) = "AREA 51") Then + GoSub CutOrOutOfFuel + End If + End If + If j = 2 Then CarWash + If j = 3 Then LGM fc + If j = 4 Then Volcano + If j = 5 Then McD + If j = 6 Then TMA + If j = 7 Then Surveyor + If j = 8 Then IBM + If j = 9 Then Hollywood + If j = t Then Grave x, fb$ + End If + nf: +Next i +Return + +CommandModule: ' 27 * 9 +If ek(0) = -1 Then Return +cminview = 1 +tx = localize(ex(0), 14, 14) +If tx = 999 Then cminview = 0: GoTo nocm +x1 = tx - 14 +x2 = tx + 14 + +View Screen(gs + 1, 0)-(q3, q4) ' protect panel +Line (x1 + 0, 18)-(x1 + 26, 26), black2, BF +For z = 1 To 27 + Line (x1 + z, 17)-(x1 + z, 26), white, , cmp&(z) +Next z + +CMshadow tx, x1, x2 ' optional + +sd! = Abs(exv(0)) - Abs(vx!) ' speed diff +dbc = Abs(px! - tx) + +If (py! < h) And (dbc < 50) And (Abs(sd!) < .06) Then + rlink = t + Line (LMrx(1), LMry(1))-(tx + 8, 27), green, , Rnd * &H7FFF + If (cmleaving + convo) = 0 Then + mes$(0) = "Establishing link with Campbell soup cans and string" + sct! = 2 + convo = 1 + End If + If sc! = 0 Then sc! = Timer + sct! ' start conversation in xs + If Timer > sc! Then + convo = convo + 1 + If convo > (clines + 1) Then + sc! = 0 + convo = 0 + cmleaving = 1 + Else + mes$(0) = convo$(convo) + sc! = Timer + sct! + End If + End If +End If + +nocm: +rlink = rlink - 1 - (rlink = 0) ' allows brief radio interruption +If rlink = 0 Then ' lost awhile ago + If convo Then mes$(0) = " " ' clear current dialogue + convo = 0 ' stop conversation + sc! = 0 ' talk timer +End If + +If cmleaving And cminview Then ' CM exhaust + ty = 22 + Line (x1, ty - 2)-(x1, ty + 2), yellow + Line -(x1 - 15, ty), yellow + Line -(x1, ty - 2), yellow +End If +Return + +liftoff: ' forced seperation or surface launch +If (contact Or liftoff) And (cwd < 69) And (py! > 322) Then + dead$ = "HIT CAR WASH" + Return +End If + +If contact Then vx! = 0 +If lob Then vx! = exv(2): a = 0 ' landed on Borg + +goy = -h ' AS go y +If ASO Then ' ascent stage only + If fuel! = 0 Then Return + thrust! = h + falling = 0 + platform = 0 + If lob Then pminy = borgt +Else + power = opower + thrust! = th ' simulate explosive seperation + platform = 22 ' deflect flame from DS + If contact Then + falling = 0 ' DS already on surface + Else + falling = 1 ' DS in air + goy = py! - 20 ' go y - not to screen top + End If + Line (gs, 30)-(q3, q4), 0, BF ' erase "space" area + pminx = q1: pmaxx = -pminx + pminy = q1: pmaxy = -pmaxy + For i = 279 To rp ' draw descent stage + c = LMc(i) + If c < 0 Then c = fuel + PSet (LMrx(i), LMry(i)), c + If LMrx(i) < pminx Then pminx = LMrx(i) + If LMrx(i) > pmaxx Then pmaxx = LMrx(i) + If LMry(i) < pminy Then pminy = LMry(i) + If LMry(i) > pmaxy Then pmaxy = LMry(i) + Next i + GoSub flevel + If platform > 0 Then deflectat = pminy + zz = pmaxy - pminy + Get (pminx, pminy)-(pmaxx, pmaxy), gbuff() ' save descent stage + Line (gs, 30)-(q3, q4), 0, BF ' erase "space" area + + ta = (a + tsix) Mod tsix + px! = px! - t * s!(ta) + py! = py! - 15 * c!(ta) ' explosive seperation +End If + +wASO = ASO +ASO = 1 +GoSub ReadLM +If wASO = 0 Then fuel! = h +If vsd Then LMdistort + +If contact Then + dropvx! = 0 + If lob And (Abs(px! - center) > 2) Then dropvx! = exv(1) + dropvy! = 0 +Else + dropvx! = vx! + dropvy! = vy! +End If + +If lob Or (contact = 0) Then + wa = 0 +Else + wa = Sgn(-exv(0)) * 20 ' want angle + If wa = 0 Then wa = -20 +End If + +sauto = auto: auto = 1 +contact = 0 +cut = 0 +dump = 0 +hover = 0 +liftoff = 1 +lminx = pminx +lock1 = 0 +lockfuel = 0 +lpass = 0 +If wASO = 0 Then ma = 0 +mes$(0) = "" +mes$(1) = "" +np = 0 +paraf = 0 +pcontact = 0 +powerloss = 0 +psuri = suri +py! = py! - 2 ' fool CheckHit +svert = vert +vert = 0 + +Do: _Limit mdelay * 1.5 + If py! < 280 Then GoSub angle ' make a=wa (angle=wanted) + GoSub Plotscreen + np = np + 1 + If np >= t Then GoSub CheckHit + z = (sy1 + sy2) / 2 - 2 + If (deflectat > 0) And (z > deflectat) And (z > deflectat) Then contact = 1 + If contact Then dead$ = "NOT YOUR DAY": Exit Do + lpass = lpass + 1 + If thrust! = th Then thrust! = h + If vsd Then ' very severe damage + thrust! = h - (lpass + Rnd) ' slowly drop power + If thrust! < 50 Then thrust! = 50 + Rnd + If Rnd > .95 Then + dead$ = "STRUCTURAL FAILURE" + Exit Do + End If + End If + GoSub KeyAndMouse + If Len(dead$) Then GoTo endl + If lob Or ((platform > 0) And (falling = 1)) Then + pminx = pminx + dropvx! + pmaxx = pmaxx + dropvx! + pminy = pminy + dropvy! + pmaxy = pmaxy + dropvy! + If lob = 0 Then + dropvy! = dropvy! + .6 + dropy! = gety(-(pminx + nx)) + If pmaxy < dropy! Then + lminx = pminx + lminy = dropy! - zz + deflectat = pminy + Else + pminx = lminx + pminy = lminy + psuri = suri + pcontact = 1 + falling = 0 + End If + End If + Else + pminx = lminx + (psuri - suri) + End If + If cut Then lpass = 0 + If wASO Then + If (py! <= goy) And (cut = 0) Then Exit Do + Else + If pcontact Or (pminx < gs) Or (pminx > 580) Then Exit Do + If (cut = 0) And (py! <= goy) Then + hover = 1 + GoSub Autopilot + If falling = 0 Then Exit Do + End If + End If +Loop Until (alt! > h) Or Len(dead$) + +endl: +auto = sauto +crash = 0 +deflectat = 0 +liftoff = 0 +lock1 = 0 +platform = 0 +vert = svert +Return + +ReadLM: +LMbloads +If ASO Then ' ascent stage only + lp = 294 + nx = 16 + ny = 9 + rp = 302 + th1 = 170 + th2 = 198 + vmass = 60 +Else ' AS&DS 34*36 + lp = 696 ' left pad + nx = 17 ' center x (for rotating) + ny = 18 ' center y + rp = 705 ' right pad + th1 = 449 ' left thruster + th2 = 483 ' right thruster + vmass = h ' full mass +End If + +nred = 0 ' number red (volcanic heating) +temp = 0 ' temperature +If bw = 0 Then Palette gasoline, 24 +xp = 97 ' radar +wi = LMx(rp) - LMx(lp) + 1 ' width +wi2 = wi \ 2 + +If invincible Then c = gold Else c = gray ' thruster color +For i = 1 To rp + LMx(i) = LMx(i) - nx + LMy(i) = LMy(i) - ny + If (LMc(i) = gray) Or (LMc(i) = gold) Then LMc(i) = c ' thrusters + If LMc(i) < 0 Then LMc(i) = fuel ' fuel + LMoc(i) = LMc(i) +Next i +GoSub LMcolors +Return +' -------------------------------------------------------------------------- +d1: +Data 27,"Elapsed time" +Data 36,"Distance to McD" +Data 45,"CPU" +Data 54,"Rads/temperature" +Data 86,"Fuel" +Data 126,"Altitude" +Data 166,"Horizontal velocity" +Data 206,"Vertical velocity" +Data 244,"Main thrust" +Data 277,"Sideways thrust" +Data 307,"Autopilot (full)" +Data 322,"Hover control" +Data 337,"Vertical automatic" + +Data "Scored on vertical & horizontal speed:" +Data "0.00 - 0.50 Excellent" +Data "0.51 - 1.00 Good" +Data "1.01 - 2.00 Fair" +Data "2.01 - 3.00 Poor" +Data "" +Data "Landing surface should be near flat," +Data with required ending angle under 5. +Data "" +Data Based on a 1974 program running on a +Data DEC PDP/11 with GT40 vector display +Data terminal at the University of Alberta. +Data The graphic at top left is usually a Henon +Data "plot, dealing with the stability of orbits." +Data The face appearing in TMA-1 when it shoots +Data "is Cybill Shepherd. If you land on TMA-1," +Data it displays a Mandelbrot. The semaphores +Data "use proper flag positions, and the Morse" +Data code in the McDonalds sign is real too. +Data "Little Green Man can be turned into a pile" +Data of ashes. Beware the beach balls of IBM! +Data "" +Data F2 for a demo mode showing most features. +Data "" +Data "Esc or <: Back to Lander > Next page" + +d2: +Data "ud main thrust" +Data "<> side thrust/angle" +Data "Shift ud move up" +Data "Shift <> move left/right" +Data "<> ground back/forward" +Data "space abort/feature cycle" +Data "Bkspace random star position" +Data "Esc quit" +Data "01234 stars off/on/info" +Data "aA autopilot on/off/McD" +Data "b goto Borg" +Data "B goto black hole" +Data "c cut engine" +Data "C clock(s) on/off" +Data "d dump fuel" +Data "D restart with defaults" +Data "fF fuel lock/unlimited" +Data "G new ground" +Data "h hover" +Data "I invincible mode" +Data "k kill (fire laser)" +Data "wlemtsiHg goto surface feature" +Data "L level ground" +Data "M Magic landing!" +Data "n nation (flag)" +Data "o goto comet" +Data "O goto Deathstar" +Data "p pause" +Data "P parachute" +Data "r radar" +Data "R rendesvous with CM" +Data "T thrust accuracy" +Data "u instruments" +Data "v vertical automatic" +Data "y swap mouse buttons" +Data "z self-destruct" +Data ". terrain following" +Data "F2 demo mode (compressed)" +Data "F3 sky features" +Data "F4 constant black holes" +Data "F5 panel/instruments" +Data "F6 drop descent stage" +Data "F7 map at top" +Data "F8 shields (uses fuel)" +Data "F9/F10 LED color/tri-color" +Data "PgDn/Up slower/faster" +Data "< Previous page > Next page" + +d3: +Data "/ green/amber/b&w/regular screen" +Data "+ zoom in starfield" +Data "- zoom out starfield" +Data "\ drop bomb" +Data ". terrain following" +Data "_ star twinkle" +Data "j DeathStar rotation" +Data "| generate all star files (hours!)" +Data "x more/less stars" +Data "X regenerate current star file" +Data "Q oscar (LGM flag colors)" +Data "= show LM data" +Data "[ crude black & white" +Data "] UFO toggle" +Data "} dissolve screen" +Data "U ground tiling style" +Data "ctrl-c or -s: SCREEN capture" +Data "alt-Enter: fullscreen toggle" +Data "" +Data "< Previous page > Next page" + +d4: +Data " Programmed by: R. Frost" +Data " Edmonton, Alberta, Canada" +Data "" +Data " rfrost@mail.com " +Data "" +Data "" +Data " 1) 2001 A Space Odyssey: TMA-1, HAL, CM/LM chatter" +Data " 2) Star Trek: warp messages, phasers, shield, Borg" +Data " 3) Lost in Space: black hole warning" +Data " 4) Southpark: black hole at 3:50 (Tree-fiddy! - Chef)" +Data " 5) Simpsons: LGM saying he has semaphore flags" +Data " 6) Rocky & Bullwinkle: a hall of Montezuma (car wash)" +Data " 7) Bonanza: car wash traverse generates a Hop Sing quote" +Data " 8) SCTV: CM/LM chatter" +Data " 9) a McDonalds on the Moon, and an instrument for it" +Data "10) Little Green Man wiggles ears & reacts to LM exhaust" +Data "11) pirate books & movies: CM/LM chatter" +Data "12) Command Module leaves you stranded" +Data "13) a Steve Martin quote precedes black hole death" +Data "14) half the time the USSR flag is planted" +Data "15) Cybil Shepherd's face appears in TMA-1 when it fires" +Data "16) Halley's Comet is renamed Halle Berry" +Data "17) digital, analog, and binary clocks!" +Data "18) End Of The Universe is signaled by Chicken Little" +Data "19) Mt. Etna spews volcanic cheese" +Data "20) a parachute that doesn't work in a vacuum" +Data "21) Area 51 is the first level landing zone" +Data "22) IBM weapon is a fishing float or beach ball" +Data "" +Data "< Previous page Esc or >: Back to Lander" + +leds: +Data a,0,-2,1,-2 +Data b,1,-2,1,-1 +Data c,1,-1,1,0 +Data d,0,0,1,0 +Data e,0,-1,0,0 +Data f,0,-2,0,-1 +Data g,0,-1,1,-1 + +Data 0,abcdef,1,bc,2,abged,3,abgcd,4,fgbc,5,acdfg,6,acdefg,7,abc,8,abcdefg,9,abcdfg,10,g,11,def + +features: +' x y lz +Data "Area 51",65,40,45 +Data "Car Wash",100,44,130 +Data "Little Green Man",12,0,70 +Data "Etna",10,49,20 +Data "McDonalds",38,0,80 +Data "TMA-1",45,71,80 +Data "Surveyor",28,0,80 +Data "IBM",50,45,90 +Data "Hollywood",170,0,0 +Data "a grave",68,49,98 + +MorseData: +Data a,.-,b,-...,c,-.-.,d,-..,e,.,f,..-.,g,--. +Data h,....,i,..,j,.---,k,-.-,l,.-..,m,--,n,-. +Data o,---,p,.--.,q,--.-,r,-.-,s,...,t,-,u,..- +Data v,...-,w,.--,x,-..-,y,-.--,z,--..,1,.----,2,..--- +Data 3,...--,4,....-,5,.....,6,-...,7,--..,8,---..,9,----. +Data 0,-----,!,..--.,$,...-..-,&,.-... + +warp: +Data "The Rockwell warranty is now void" +Data "Hope we don't collide with Klingons!" +Data "You need a vacation, Jim! - Bones!" +Data "It's a long way to Tipperary!" +Data "Do we know this universe? - Spock" +Data "My miniskirt is getting shorter! - Uhuru" +Data "Da engines kanna tayke much more! - Scotty" +Data "Keptin, are you insane? - Chekhov" +Data "Hit 10 and we die!" + +radcomments: +Data "has caused genetic damage" +Data "causes glowing in the dark" +Data "5 years" +Data "1 year" +Data "6 months" +Data "1 month" +Data "1 week" +Data "8 hours" +Data "5 minutes" +Data "has killed you - press Esc" + +skycrud: +Data CM,14,14 +Data DS,150,150 +Data BO,58,46 +Data BH,200,200 +Data Wo,90,90 +Data Co,20,100 +Data AL,40,40 +Data ZZ,1,1 + +semadata: +Data a 1,225,180 +Data b 2,270,180 +Data c 3,315,180 +Data d 4,0,180 +Data e 5,180,45 +Data f 6,180,90 +Data g 7,180,135 +Data h 8,270,225 +Data i 9,225,315 +Data j,0,90 +Data k 0,225,0 +Data l,225,45 +Data m,225,90 +Data n,225,135 +Data o,270,315 +Data p,270,0 +Data q,270,45 +Data r,270,90 +Data s,270,135 +Data t,315,0 +Data u,315,45 +Data v,0,135 +Data w,45,90 +Data x,45,135 +Data y,315,90 +Data z,135,90 +Data " ",180,180 +Data !,0,0 + +say: +Data "The time is 1234" +Data "Welcome to the Moon" +Data "I am a little green man" +Data "I have semaphore flags" +Data "R Frost is a nerd!" +Data "abcdefghijklmnopqrstuvwxyz" +Data end + +BigM: ' 37 * 16 +Data " X X " +Data " X X X X " +Data " X X X X " +Data " X X X X " +Data " X X X X " +Data " X X X X " +Data " X X X X " +Data " X X X X " +Data " X X X X " +Data " X X X X " +Data " X X X X " +Data " X XXX X " +Data " X X " +Data " X X " +Data "X X" +Data "X X" +Data x +' 1234567890123456789012345678901234567 +' 1 2 3 +tinyfontd: +Data 0,7,5,5,5,7 +Data 1,2,6,2,2,7 +Data 2,7,1,7,4,7 +Data 3,7,1,7,1,7 +Data 4,5,5,7,1,1 +Data 5,7,4,7,1,7 +Data 6,7,4,7,5,7 +Data 7,7,1,1,1,1 +Data 8,7,5,7,5,7 +Data 9,7,5,7,1,7 +Data .,0,0,0,0,2 +Data -,0,0,1,0,0 +Data ":",0,2,0,2,0 +Data " ",0,0,0,0,0 + +lmshow: +View +For pass = 1 To 2 + Cls + For i = 1 To rp + x = (LMx(i) + 17 - ASO) * 16 + 30 + (pass = 2) + y = (LMy(i) + 18 - ASO * 9) * 8 + t + If pass = 1 Then z$ = LTrim$(Str$(LMc(i))) Else z$ = Right$(" " + Str$(i), 3) + If Len(z$) = 1 Then z$ = "0" + z$ + c = LMc(i) + TinyFont z$, x + 3, y + 3, c + Next i + For i = 1 To 35 ' line of numbers at top + z$ = Right$(" " + LTrim$(Str$(i)), 2) + TinyFont z$, (i - 1) * 16 + 33, 4, gray + x = (i - 1) * 16 + 30 + 16 + Line (x, 0)-(x, 320), red + Next i + For i = 1 To 36 ' columb of numbers at left + z$ = Right$(" " + LTrim$(Str$(i)), 2) + TinyFont z$, 8, i * 8 + 13, gray + y = i * 8 + t + 8 + 1 + Line (0, y)-(q3, y), red + Next i + Line (0, 0)-(q3, 320), red, B + _Display + Sleep +Next pass +Return +' -------------------------------------------------------------------------------------------------------x +Sub Area51 (tf$) Static + If a51i = 0 Then + pi! = _D2R(180) + zz! = Atn(1) / 45 * 3 + ac1 = red + ac2 = white2 + fc$ = "0105030709101412" + a51i = 1 + End If + + If bolthitf Then GoTo aother + + tx = x + 33 + For i = 20 To h Step 5 + z = (z + 2) Mod 45 + For j = 0 To 1 + Swap ac1, ac2 + For k = 0 To 3 + aa = k * 45 + z + a1! = _D2R(aa) - zz! + a2! = _D2R(aa) + zz! + If j Then + a1! = pi! - a1! + a2! = pi! - a2! + End If + If a1! < 0 Then a1! = 0 + If a2! < 0 Then a2! = 0 + If a2! < a1! Then Swap a1!, a2! + Circle (tx, 308), i, ac1, a1!, a2! + Next k + Next j + Next i + + If invincible Then GoTo aother + dx! = px! - tx + dy! = 280 - py! + If (Abs(dx!) < 81) And (Abs(dy!) < 61) And (liftoff = 0) Then + If contact = 0 Then mes$(1) = "AREA 51 ELEVATOR ACTIVATED" + _Delay .1 + For tx2 = sx1 To sx2 Step 1 + Line (tx2, sy1 + 2)-(tx, 309), gray + Next tx2 + If sy1 > 310 Then + Line (sx1 - 1, sy1 + 2)-(tx, 309), black + Line (sx2 + 1, sy1 + 2)-(tx, 309), black + End If + px! = px! - Sgn(dx!) + If Abs(dx!) < 2 Then + If py! > 280 Then j = 0 Else j = 2 + Else + If py! > 280 Then j = -2 Else j = 1 + End If + py! = py! + j + a = 0 + thrust! = 0 + vx! = 0 + vy! = 0 + b2b = 1 + GoTo bingo + End If + + aother: + If bb2! = 0 Then bb2! = Timer + 2 + If Timer > bb2! Then + bb2! = Timer + 2 + b2b = 1 - b2b + End If + + bingo: + If contact Then b2b = 1 + If b2b Then + If bolthitf Then tc = white Else tc = dred + For i = 1 To 4 + tx = x + i * t + 3 + PrintVGA Mid$("AREA", i, 1), tx, 313, white2, tc + Next i + For nu = 0 To 1 + For ty = 0 To 4 + bp = Val("&H" + Mid$("26227E8E2E", nu * 5 + ty + 1, 1)) + sp = 1 + For tx = 1 To 4 + If bp And 1 Then + tx2 = x + 52 - tx * 4 - nu * 16 + ty2 = 309 + ty * 5 + 15 + Line (tx2, ty2)-Step(3, 4), tc, BF + If sp Then sp = 0: Line (tx2 + 4, ty2)-Step(0, 4), white2 + End If + bp = bp \ 2 + Next tx + Next ty + Next nu + Else + Open tf$ For Input As #5 ' alien.dat (head) + zc = (zc + 1) Mod 8 ' color + For i = 1 To 32 + Line Input #5, z$ + For j = 1 To Len(z$) + c$ = Mid$(z$, j, 1) + If c$ <> "." Then ' . = transparent + If c$ = " " Then + tc = Val(Mid$(fc$, zc * 2 + 1, 2)) + If bolthitf Then tc = white + ElseIf c$ = "r" Then ' spooky eyes + tc = red + Else + tc = black2 ' eyes/nose/mouth + End If + x2 = x + j + t + y2 = 312 + i + PSet (x2, y2), tc + End If + Next j + Next i + Close #5 + End If +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub AuHoVe (auto, hover, vert, lam) + For i = 0 To 2 + z$ = Mid$(" AUTOHOVER VERT", i * 5 + 1, 5) + If i = 0 Then k = auto + If i = 1 Then k = hover + If i = 2 Then k = vert + + ty = 307 + i * 15 + PrintCGA z$, 4, ty, gunmetal, black2, 0 + + If k Then + c1 = green + c2 = black2 + Else + c1 = black2 + c2 = red + End If + + If crash Then c1 = black2: c2 = black2 + + If lam And k And (i = 0) Then c1 = gold ' land at McD + + PrintCGA "ON ", 57, ty - 4, c1, -1, 0 + + ' blink OFF to indicate a keyboard command turned it off + If (i = 0) And (APdisengage > 0) And (c2 = red) Then + c2 = (APdisengage Mod 2) * red + APdisengage = APdisengage - 1 + End If + PrintCGA "OFF", 57, ty + 3, c2, -1, 0 + + tx1 = 48: ty1 = ty + 5 ' switches + If i = 1 Then c = blue2 Else c = blue ' background + If k Then ta = 285 Else ta = 75 ' up & down angles + tx2 = tx1 + 5 * c!(ta) + ty2 = ty1 + 5 * s!(ta) + For k = 0 To 1 + Line (tx1 + 2, ty1)-(tx2 + k + 2, ty2), white ' plot switch + Next k + Line (tx1 + 1, ty1)-(tx2 + 1, ty2), black2 ' outline left + Line (tx1 + 3, ty1)-(tx2 + 4, ty2), black2 ' outline right + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Bar (xdat!, cl) + xmax = gs - t ' graphics start - ten + xmin = xmax - 50 + ymax = 273 - osc * 39 + ymin = ymax - t + 'xcen = xmin + (xmax - xmin) / 2 ' center line + xbar = xmin + xdat! * (xmax - xmin) ' data + If xbar < xmin Then xbar = xmin ' limit min + If xbar > xmax Then xbar = xmax ' limit max + + If porb Then ' led bar + If LEDtri = 0 Then c = LEDc + If cl Then ' center line + Line (xbar - 1, ymin + 4)-(xbar + 1, ymin + 7), c, BF + Else + Line (xmin, ymin + 5)-(xbar, ymin + 7), c, BF + End If + Else ' mechanical pointer + If (osc = 4) And (radarf = 0) Then ' altitude with radar off + tc1 = gray + tc2 = black + Else ' normal + tc1 = white + tc2 = white + End If + Line (xbar, ymin + 4)-(xbar - 4, ymin + 8), tc1 + Line -(xbar + 4, ymin + 8), tc1 + Line -(xbar, ymin + 4), tc1 + Paint (xbar, ymin + 5), tc2, tc1 + End If +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub BlackHole (freeze) Static + If ei(3) = 0 Then + Dim tc(2) + ei(3) = 1 + l! = aspect! + tx = 30 + Rnd * 40 + If Rnd > .7 Then tx = tx + Rnd * h + If Rnd > .7 Then tx = tx + Rnd * h ' intentional repeat + v! = tx / l! + s1! = l! / t: r = Rnd * 90: ri = Rnd * 8 + 2 + bc = bc + 1 + (bc = 6) * 7 + z$ = "020105040906010613070603091301070605121404" ' colors + For i = 0 To 2 + tc(i) = Val(Mid$(z$, bc * 6 + i * 2 + 1, 2)) + Next i + d1 = Rnd * 2 + 1 + d2 = Rnd * 2 + 1 + End If + + x0 = localize(ex(3), 0, 0) + y0 = ey(3) + + tri = ri + If freeze Then tri = tri \ 2 ' rotation increment + r = (r + tri) Mod tsix ' rotation + dtlt! = -30 - 30 * Abs(c!((r * 3 + 50) Mod tsix)) ' tilt + dtlti = (dtlt! + tsix) Mod tsix + crot! = c!(r) + srot! = s!(r) + ctlt! = c!(dtlti) / d1 + stlt! = s!(dtlti) / d2 + co = (co + 1) Mod tsix + + bhx = 0: bhy = bhx + For pass = 0 To 1 ' 90 degrees apart + For za! = -l! To l! Step s1! + pd = 0 ' pen up + For zb! = -l! To l! Step s1! + x1! = za! + y1! = zb! + If pass Then Swap x1!, y1! + x! = x1! * crot! + y1! * srot! + y! = y1! * crot! - x1! * srot! + q! = -.8 / (x1! * x1! + y1! * y1!) + .8 + z! = q! * ctlt! - y! * stlt! + y! = y! * ctlt! + q! * stlt! + s! = (l! * 2) / ((l! * 2) + y!) + xx = x0 + x! * v! * s! + yy = y0 - z! * v! * s! + x! = za! * 1.8: x! = x! * x! + y! = zb! * 1.8: y! = y! * y! + tc = tc((x! + y! + co) Mod 3) + If pd Then Line -(xx, yy), tc Else PSet (xx, yy) + c1 = (xx > -120) And (xx < 770) + c2 = (yy > -120) And (yy < 470) + If c1 And c2 Then ' on screen + bh = 1 + If (Abs(za!) < .1) And (yy > bhy) Then + bhx = xx + bhy = yy + End If + End If + pd = 1 ' pen down + Next zb! + Next za! + Next pass +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub BlackHoleDoom ' fall in while shrinking + fb$ = "" ' silence feedback, if any + sgs = gs ' save graphics start (going to kill panel here) + gs = 0 ' kills panel + View + Dim LMxi!(q2), LMyi!(q2) + For i = 1 To rp ' rp=right pad (end of LM data) + LMxi!(i) = (exl(3) - LMrx(i)) / 50 + LMyi!(i) = ((ey(3) + bhy) \ 2 - LMry(i)) / 50 + Next i + For pass = 1 To 50 + Cls + mes$(0) = "Let's get SMALL! - Steve Martin" + For i = 1 To rp + x = LMrx(i) + LMxi!(i) * pass + y = LMry(i) + LMyi!(i) * pass + c = LMc(i) + If (c = gasoline) And (Rnd > pf!) Then c = 0 + PSet (x, y), c + Next i + GoSub ibd + wu! = Timer + .1 + Do: _Limit mdelay + GoSub ibd + i$ = InKey$ + If (i$ = "q") Or (i$ = Chr$(27)) Then Quit + Loop Until Timer > wu! + Next pass + mes$(0) = dead$ + mes$(1) = "" + gs = sgs + Exit Sub + + ibd: + Info + BlackHole 1 + timemachine + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Borg (lbx, bmy) Static + If borginit = 0 Then + z$ = Space$(t) + "WE ARE THE BORG - RESISTANCE IS FUTILE" + Space$(50) + moire = 0: moired = 1: xn = 19: yn = 8: zz = 13: p0 = &HAAAA + Dim mat$(yn) + For i = 1 To yn + mat$(i) = String$(xn, Asc("0")) + Next i + borginit = 1 ' direction for guts + End If + p1 = &H5555: p2 = &HAAAA + + borgt = bmy - 40 ' top + borgl = lbx - 40 ' left side + borgr = lbx + 52 ' right side + + x1 = lbx - 46: y1 = bmy - 34: x2 = lbx + 46: y2 = bmy + 34 + + For i = 0 To zz + tx1 = x1 + i: tx2 = x2 + i: ty1 = y1 - i: ty2 = y2 - i + If (tx1 + 2) < gs Then Swap p1, p2 + Line (tx1, ty1)-(tx1, ty2), black2 ' left + Line (tx1, ty1)-(tx1, ty2), dred, , p0 + Line (tx1 + 2, ty2)-(tx2, ty2), black2 ' bottom + Line (tx1 + 2, ty2)-(tx2, ty2), dred, , p1 + Next i + For i = 0 To zz + tx2 = x2 + i: ty1 = y1 - i + 2: ty2 = y2 - i + Line (tx2, ty1)-(tx2, ty2), red ' right + tx1 = x1 + i: tx2 = x2 + i: ty1 = y1 - i + Line (tx1, ty1)-(tx2, ty1), red ' top + Next i + Line (x2 + 1, y1)-(x2 + zz, y1 - zz + 1), black2 ' top right diag + Line (x1 + 1, y2)-(x1 + zz, y2 - zz + 1), black2 ' bottom left diag + + x1 = x1 + 8: y1 = y1 + 1: y2 = y2 - 8 ' inside of craft + + Line (x1 + 4, y1)-(x2 - 1, y2 - 4), black2, BF ' blank interior + Select Case bstyle1 + Case Is = 0 ' ala Matrix + ' 84 60 + For y = 0 To yn - 1 + mat$(y) = mat$(y + 1) + Next y + For x = 1 To xn + Mid$(mat$(yn), x, 1) = Chr$(48 + Rnd) + Next x + For y = 0 To yn + ty = y1 + y * 6 + TinyFont mat$(y), x1 + 5, ty + 1, blue + Next y + Case Is = 1 ' Moire + moire = moire + moired + If Abs(moire) > t Then moired = -moired + For ty = y1 To y2 + For tx = x1 To x2 - 1 + z1! = tx / (moire + 40): z1! = z1! * z1! + z2! = ty / (moire + 40): z2! = z2! * z1! + If ((z1! + z2!) Mod 4) Then + If ((z1! + z2!) Mod 2) Then tc = blue Else tc = dred + PSet (tx, ty), tc + End If + Next tx + Next ty + Case Is = 2 ' boxes + x2 = x2 - 3: xs = x2 - x1: ys = y2 - y1 + For z = 1 To h + bx1 = x1 + Rnd * xs + 2 + by1 = y1 + Rnd * ys + 2 + bx2 = bx1 + (Rnd - pf!) * xs / z * t + 2 + by2 = by1 + (Rnd - pf!) * ys / z * t + 2 + If bx2 < x1 Then bx2 = x1 + If bx2 > x2 Then bx2 = x2 + If by2 < y1 Then by2 = y1 + If by2 > y2 Then by2 = y2 + c = 1 + Sgn(z Mod 2) * 12 + If Rnd > .95 Then c = gunmetal + Line (bx1, by1)-(bx2, by2), c, B + Next z + End Select + + For k = -30 To 30 Step 15 ' exhaust, 5 flames + bit = bit Xor 1 ' alternate + For i = 0 To 20 + ba1 = (ba1 + i) Mod tsix + zzz = ((20 - i) / 4) * Sin(_D2R(ba1)) + ty0 = y2 + i + 8 + bit + 1 + tx1 = lbx - zzz + k + tx2 = lbx + zzz + k + Line (tx1, ty0)-(tx2, ty0), blue, , Rnd * &H7FFF + Next i + Next k + ' scroll Borg message along top and right side of craft + ti = (ti Mod (50 * 16)) + 8 ' index into text, speed 1-?? + tx1 = lbx - 46 - 3 + ty1 = bmy - 31 + + PrintLines z$, ti, ti + 90, tx1, ty1 - 1, black2, -88, 2, 2 ' top + PrintLines z$, ti, ti + 90, tx1, ty1 - 0, white2, -88, 2, 2 + + tx1 = lbx + 46 - 2: ty1 = bmy - 32 ' right + PrintLines z$, ti + 91, ti + 91 + 67, tx1, ty1, black2, -99, 2, 2 + +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub CarWash + Dim cwpat&(7) + cwpat&(0) = &HFFFF + cwpat&(1) = &H1111 + cwpat&(2) = &H2222 + cwpat&(3) = &H4444 + cwpat&(4) = &H8888 + cwpat&(5) = cwpat&(3) + cwpat&(6) = cwpat&(2) + cwpat&(7) = cwpat&(1) + + x1 = x + 1 + x2 = x1 + 99 + y0 = 305 + If bolthitf Then tc = white Else tc = gunmetal + Line (x, y0 - 19)-(x2, y0 - 1), tc, BF ' sign background + PrintCGA "MONTEZUMA", x + 14, 286, orange, black2, 0 + + If bbit Then + c1 = green + c2 = blue + c3 = green + Else + c1 = black2 + c2 = -1 + c3 = gunmetal + End If + PrintCGA "Car Wash", x + 17, 294, c1, c2, 0 + Line (x, y0 - 19)-(x2, y0 - 1), c3, B + + If bolthitf Then tc = white Else tc = blue2 + Line (x, y0)-(x2, q4), tc, BF ' spray zone + Line (x1, y0)-(x1, q4), white, , cwpat&(1) ' left side &H1111 + Line (x2, y0)-(x2, q4), white, , cwpat&(1) ' right side + + If cwsi = 0 Then cwsi = 1 ' spray angle increment + cwsd = cwsd + cwsi ' spray direction + If (cwsd = 0) Or (cwsd = t) Then cwsi = -cwsi ' hit limits, reverse + For z = 1 To 5 + x1 = x + z * t + 24 + For i = -4 To 4 Step 2 + td = cwsd - 5 + i + If z Mod 2 = 0 Then + td = -td + up = 0 ' use pattern + Else + iz = (iz + 1) Mod th + up = iz Mod 7 + 1 + End If + ra = (90 + td * 3) Mod tsix + tx = 64 * c!(ra) * 1.1 + ty = y0 + 64 * s!(ra) + Line (x1, y0)-(x1 + tx, ty), gunmetal, , cwpat&(up) ' along top + Line (x + 0, y0)-(x1 + tx \ 2, ty), gunmetal, , cwpat&(up) ' tl + Line (x + h, y0)-(x1 + tx \ 2, ty), gunmetal, , cwpat&(up) ' tr + tx = x1 + 20 * c!(ra) * 1.2 + ty = q4 - 20 * s!(ra) \ 2 + Line (x1, q4)-(tx, ty), white ' bottom + Next i + iz = iz + 1 + Next z +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub CMshadow (tx2, x1, x2) + z = (Timer Mod 17) + 1 ' rotation 1 + If z < t Then + Line (tx2 - 4, 17 + z)-(tx2 - 1, 17 + z), white + End If + z = ((z + 8) Mod 17) + 1 ' rotation 2 + If z < t Then + Line (tx2 + 6, 17 + z)-(tx2 + 8, 17 + z), white + End If + For tx = x1 To x2 ' shadow + For ty = 17 To 26 + pp = Point(tx, ty) + zx = tx - x1 - (x2 - x1) \ 2 + zy = ty - 22 + If (pp = white) And (zy > (zx + 4)) Then PSet (tx, ty), gray2 + Next ty + Next tx +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Comet (comx, comy) + If crash Then tc = white Else tc = green + For i = 0 To 1 + Circle (comx, comy), i + 1, tc, , , .78 + c$ = Mid$("HalleBerry", i * 5 + 1, 5) + tx = comx + t + ty = comy + i * 8 + If (tx > gs) And (tx < 590) And (ty > 0) And (ty < 330) Then PrintCGA c$, tx, ty, white2, gunmetal, 0 + Next i + For ta = -t To t Step 5 ' tail, -10 to 10 + zz = 50 + Rnd * tw ' vary tail length + r! = _D2R(140 + ta * 4) + x1 = comx + 3 * Cos(r!) ' tail start + y1 = comy + 3 * Sin(r!) + r! = _D2R(140 + ta \ 2) + x2 = comx + zz * Cos(r!) ' tail end + y2 = comy + zz * Sin(r!) + Line (x1, y1)-(x2, y2), white2, , Rnd * &H7FFF + Next ta +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub contour Static + wa1 = (wa1 + 5) Mod tsix + wx! = 320 + 70 * s!(wa1) + wy! = 175 + 70 * c!(wa1) + Dim distance(360), elevation(360), active(10), angle(10) + e0 = 320 + n = 6: GoSub genang + For i = 1 To n + angle = angle(i) + angle = (angle + tsix) Mod tsix + active(i) = angle + distance(angle) = 50 + Rnd * 150 + elevation(angle) = 100 + Rnd * 150 + Next i + n = n + 1 + active(n) = active(1) + distance(active(n)) = distance(active(1)) + elevation(active(n)) = elevation(active(1)) + For i = 1 To n + angle1 = active(i - 1) + angle2 = active(i) + ddif! = distance(angle2) - distance(angle1) + edif! = elevation(angle2) - elevation(angle1) + If i = n Then angle2 = angle2 + tsix + a! = 0: ai! = 90 / (angle2 - angle1) + For z = Int(angle1) To angle2 + na = z Mod tsix + a! = (a! + ai!) Mod tsix + aa = Abs(a! Mod tsix) + z! = s!(aa) * s!(aa) + distance(na) = distance(angle1) + ddif! * z! + elevation(na) = elevation(angle1) + edif! * z! + Next z + Next i + For el = -200 To 220 + zz = 155 * s!((Abs(el) * 3) Mod tsix) + 100 + bb = bb Xor 1 + If bb Then c& = _RGB32(0, 0, zz) Else c& = _RGB32(zz, 0, 0) + For mangle = 0 To tsix + angle = mangle Mod tsix + distance = distance(angle) + elevation = elevation(angle) + epf! = distance / (e0 - elevation) + d! = distance - ((el - elevation) * epf!) + tx = px! + d! * c!(angle) + ty = py! - d! * s!(angle) + If mangle Then Line -(tx, ty), c& Else PSet (tx, ty), c& + Next mangle + Next el + Exit Sub + + genang: + zz = 420 / n + For i = 2 To n + ta = (i - 2) * zz + Int(Rnd * 10) - 5 + 30 + angle(i) = Int(ta Mod tsix) + Next i + sort: + sorted = 1 + For i = 1 To n - 1 + a1 = angle(i) + a2 = angle(i + 1) + If a1 > a2 Then sorted = 0: Swap angle(i), angle(i + 1) + Next i + If sorted = 0 Then GoTo sort + For i = 1 To n - 1 + a1 = angle(i) + a2 = angle(i + 1) + If (a2 - a1) < 20 Then GoTo genang + Next i + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub CybillPix (pfile$) Static ' Sheperd when TMA fires + If cpinit = 0 Then + z = 1225 + Dim cbuff(z) + s& = VarSeg(cbuff(0)) + o& = VarPtr(cbuff(0)) + Def Seg = s& + BLoad pfile$, o& + cpinit = 1 + End If + If ((x + 5) >= gs) And (x < 600) Then Put (x + 5, 289), cbuff(), PSet +End Sub +' -------------------------------------------------------------------------------------------------------x +Function dcolor (v!, z1, z2, d) ' determine color for various displays + dcolor = LEDc ' normal + If liftoff = 0 Then + tv! = Abs(v!) + If d = 1 Then ' problem higher + If tv! > z1 Then dcolor = yellow ' warning + If tv! > z2 Then dcolor = red ' serious warning + Else ' problem lower + If tv! < z1 Then dcolor = yellow ' warning + If tv! < z2 Then dcolor = red ' serious warning + End If + End If +End Function +' -------------------------------------------------------------------------------------------------------x +Sub DeathStar (dtx, tf$) Static ' relies on data files + If dsinit = 0 Then ' one time initializations + Dim tc(1) + xc = 320: yc = 175: dty = 170 + xs = 130: ys = 110: bs = ys - t: rs = 8000 + wx1 = xc - xs: wx2 = xc + xs + wy1 = yc - ys: wy2 = yc + ys + Close #8 + ReDim buff&(rs) + Open tf$ For Binary As #8 + dsinit = 1 + End If + + If darkstarc = 0 Then c1 = black2: c2 = blue: c3 = blue2 + If darkstarc = 1 Then c1 = gunmetal: c2 = red: c3 = dred + tc(0) = c2: tc(1) = c3 + + Circle (dtx, dty + 6), xs, black2 ' define area + For z = -1 To 1 Step 2 ' circle may be barely on screen + Paint (dtx + z * (xs - 1), dty), c1, black2 ' far left & far right + Next z + + xx = dtx - xc + yy = dty - yc + zz = (zz + darkstars) Mod 49 ' 0-48 images + rn& = zz * rs * 4 + 1 + Get #8, rn&, buff&() + n = -1 + For i = wx1 To wx2 + tx = xx + i + If tx > q3 Then GoTo bork + For j = wy1 To wy2 Step 15 + For k = 0 To 1 + n = n + 1 + If (buff&(n) > 0) And (tx >= gs) Then + Line (tx, j)-(tx, j + 15), tc(k), , buff&(n) + If darkstart Then Line (tx, j + 1)-(tx, j + 16), tc(k), , buff&(n) + End If + Next k + Next j + Next i + bork: + GoSub Title + + boltx = q1 ' handy large value + + If Rnd > .7 Then ' lightning bolt + a! = 90 + (Rnd * 20) - t ' starting angle + r! = bs ' starting radius + bolty = q1 ' handy large value + For i = -h To h ' -100 to 100 + tx = dtx + i + ty = gety(tx) + If ty <= bolty Then + If (bolty = q1) Or (Rnd > .8) Then boltx = tx + bolty = ty + End If + Next i + Do + xx = dtx + r! * Cos(_D2R(a!)) * aspect! + yy = dty + r! * Sin(_D2R(a!)) + If yy > q4 Then Exit Do ' q4 = 349 + a! = a! + Rnd * 2 - 1 + Sgn(xx - boltx) * .05 + r! = r! + Rnd * 2.18 - 1 + If r! < bs Then r! = bs + GoSub dot + Loop + End If + + nc = Rnd * 3 ' "internal" lightning + For s = 0 To nc + Do + a! = Rnd * tsix + Loop Until Abs(a! - 90) > 20 + td = bs \ 2 + Rnd * bs \ 2 + If Rnd > .8 Then td = Rnd * bs + r! = td + qq = 6 + Do + xx = dtx + r! * Cos(_D2R(a!)) * aspect! + yy = dty + r! * Sin(_D2R(a!)) + GoSub dot + a! = a! + Rnd * 2.15 - 1 + r! = r! - Rnd * 2.18 + qq + qq = qq - 1 - (qq = 1) + Loop Until r! < td + Next s + Exit Sub + + dot: + dx! = px! - xx + dy! = py! - yy + dd! = Sqr(dx! * dx! + dy! * dy!) + tcc = 1 - (Rnd > pf!) * 14 + If (shield = 0) And (dd! < 15) Then bolthit = 1 + If shield And (dd! <= 70) Then + tcc = green + If Rnd > .95 Then Line (sx0 + xoff, sy0 + vy!)-(xx, yy), red + End If + PSet (xx, yy), tcc + Return + + Title: + If atu = 0 Then atu = t: ati = 1 + atu = atu + ati + If (atu = t) Or (atu = 25) Then ati = -ati + t$ = "STARBUCKS" ' was EPCOR, then DEATHSTAR + For i = 1 To Len(t$) + z$ = Mid$(t$, i, 1) + aa = -90 + (i - Len(t$) \ 2 - 1) * atu + tx = dtx + bs * Cos(_D2R(aa)) * aspect! - 5 + ty = dty + bs * Sin(_D2R(aa)) + PrintVGA z$, tx, ty, c3, white + Next i + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub dissolve Static ' called with } + Dim Buffer As _MEM + Buffer = _MemImage(0) + np = 0 + Do + For y = _Height - 8 To 0 Step -1 + For x = 0 To _Width + f& = y * _Width + x + t& = f& + Int(Rnd * 2 + 4) * _Width + d = _MemGet(Buffer, Buffer.OFFSET + f&, _Unsigned _Byte) + _MemPut Buffer, Buffer.OFFSET + t&, d As _UNSIGNED _BYTE + Next x + Next y + If np = 0 Then + For x = 0 To _Width * 4 + _MemPut Buffer, Buffer.OFFSET + x, 0 As _UNSIGNED _BYTE + o2& = _Width * _Height - 1 - x + _MemPut Buffer, Buffer.OFFSET + o2&, 0 As _UNSIGNED _BYTE + Next x + End If + timemachine + np = np + 1 + If InKey$ = Chr$(27) Then System + Loop Until np > 120 + _MemFree Buffer +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Evaluate (savea, z) ' landing analysis + If (Abs(z) > 4) And (crash = 0) Then + If Abs(savea) > 4 Then + z$ = "contact angle " + LTrim$(Str$(-savea)) + Chr$(248) + GoSub tackon + End If + If Abs(z) > 4 Then + z$ = "ending angle " + LTrim$(Str$(-(z))) + Chr$(248) + GoSub tackon + End If + End If + + If Abs(vx!) > 3 Then z$ = "horizontal velocity": GoSub tackon + If Abs(vy!) > 3 Then z$ = "vertical velocity": GoSub tackon + ok = -(Len(fb$) = 0) + z! = Abs(vx!) + If (z! <= 3) And (vy! <= 3) Then score = 5: z$ = "Poor" + If (z! <= 2) And (vy! <= 2) Then score = 4: z$ = "Fair" + If (z! <= 1) And (vy! <= 1) Then score = 3: z$ = "Good" + If (z! <= pf!) And (vy! <= pf!) Then score = 2: z$ = "Excellent" + If (z! < .1) And (vy! < .1) Then score = 1: z$ = "Fantastic" + If magic Then z$ = "Magic" + If ok = 0 Then z$ = "Bad" + z$ = z$ + " landing" + If crash Then fb$ = "": z$ = "CRASHED" + + If lob Then + z$ = z$ + " on Borg": GoSub tackon + GoTo eother + End If + + v$ = "" ' verb + n$ = "" ' noun + ldis = q1 ' last distance + + For i = 1 To t ' 5wlemtsihg + tx = sf(i, 2) - suri ' point of interest middle + If tx < 0 Then tx = tx + q1 + poi$ = sf$(i) ' name of poi + dis = Abs(px! - tx) + If (poi$ = "") Or (dis > ldis) Then GoTo ni + ldis = dis + If dis < h Then + n$ = poi$ + don = (sf(i, 2) - sf(i, 0)) + wi2 ' distance to be "on" + If dis < don Then + ' pad 349 LGM Surveyor + If (Abs(sy1 - q4) < 20) And (i <> 3) And (i <> 7) Then + v$ = "in" + Else + v$ = "on" + End If + Else + v$ = "at" + End If + If ok Then + If (i = 1) Then mes$(1) = "MIB will visit you shortly!" + If (i = 3) And (LGMc = gray) Then n$ = "the ashes of " + n$ + If (i = 4) And (v$ = "on") Then mes$(1) = "On a volcano? Are you crazy?" + If (i = 5) Then mes$(1) = "Buzz wants a Happy Meal!" + If (i = t) And (v$ = "on") Then + mes$(1) = "Rude to land on a tombstone!" + End If + End If + End If + ni: + Next i + + z$ = RTrim$(z$ + " " + v$ + " " + n$): GoSub tackon + + If v$ = "in" Then ' handle oddball cases + If n$ = sf$(6) Then mes$(1) = "The aliens will not be pleased!" + If n$ = sf$(8) Then mes$(1) = "Merged with the machine!" + If n$ = sf$(t) Then mes$(1) = "Desecration of a grave!" + End If + + eother: + If fuel! = 0 Then z$ = "ran out of fuel!": GoSub tackon + Exit Sub + + tackon: + If Len(fb$) Then z$ = ", " + z$ + fb$ = fb$ + z$ + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub ExplodeLM + Dim LMxi!(q2), LMyi!(q2) + CountFuel = 0 + For i = 1 To rp ' for each pixel, a direction + ta = Rnd * tsix ' pick an angle, any angle + If contact Then ta = Rnd * 180 + 180 ' upward only if on ground + tf = Rnd * 20 + 2 ' force + LMxi!(i) = tf * c!(ta) ' x increment + LMyi!(i) = tf * s!(ta) + If LMc(i) = fuel Then ' color + CountFuel = CountFuel + 1 + If CountFuel < ptk Then LMc(i) = 0 ' points to kill + End If + Next i + contact = 0 + fb$ = "" ' eval feedback + sgs = gs + gs = 0 ' full screen + View + For pass = 1 To 40 ' expanding debris + Cls + mes$(0) = dead$ + mes$(1) = "" + Info ' say why exploding + For i = 1 To rp + LMrx(i) = LMrx(i) + LMxi!(i) + LMry(i) = LMry(i) + LMyi!(i) + LMyi!(i) = LMyi!(i) - grav! * (warp! = 0) + x = (LMrx(i) - h) * aspect! + y = LMry(i) + s = i Mod 5 ' size + Line (x, y)-(x + s, y + s), LMc(i), BF + z1 = ((Rnd * t) - 5) * 3 + z2 = ((Rnd * t) - 5) * 3 + Line (x + z1, y + z2)-(x + z1 + s, y + z2 + s), LMc(i), BF + Next i + Line (0, 0)-(q3, q4), 0, B ' erase ugly border + timemachine + w! = Timer + .02: While Timer < w!: Wend + Next pass + gs = sgs +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub ExplodeShell (s) ' not contact - when LM fires at them + tx = shx(s) - suri + ty = shy(s) + Line (tx - 5, ty - 5)-(tx + 5, ty + 5), black2, BF ' erase shell + + For d = t To 30 Step 2 ' distance + For z = 0 To 40 - d ' particles at above distance + ang = Rnd * tsix ' angle + tx2 = tx + d * c!(ang) * aspect! + ty2 = ty + d * s!(ang) + bit = bit Xor 1 + If bit Then c = red Else c = yellow + PSet (tx2, ty2), c + Next z + Next d + shx(s) = 0 + shd(s) = q1 ' 6400, any large number + sia = sia - 1 ' shells in air +End Sub +' -------------------------------------------------------------------------------------------------------x +Function FileCheck$ (f$) + + If _FileExists(f$) = 0 Then + Locate 10, 1 + Color 15, 0 + Print f$ + _Display + Sleep + System + End If + + 'i = 0 + 'If _FileExists(LCase$(f$)) Then f$ = LCase$(f$): i = 1 + 'If _FileExists(UCase$(f$)) Then f$ = UCase$(f$): i = 1 + 'If i = 0 Then f$ = "" + FileCheck$ = f$ +End Function +' -------------------------------------------------------------------------------------------------------x +Sub FlagandFireworks Static ' after good landing + If fmax = 0 Then + fs = 60: fq = 600: fmax = fs + Dim flagb(fq) + Dim ve!(fs), ho!(fs), pe(fs), x!(fs), y!(fs), c(fs) + End If + + If flx = 0 Then ' initialize + z = Sgn(sf(sf, 2) - (px! + suri)) ' to plant flag opposite feature + If z = 0 Then z = -1 ' optional, prevent middle + For i = -1 To 1 Step 2 ' check sides + tx = px! + i * z * 22 + ty = gety(-tx) + ' prevent PUT beyond 580 for grave in demo mode + If (tx < 580) And (Abs(ty - sy1) < t) Then + flx = tx + fly = ty + rev = 0 + If nation = 1 Then nation = 2 Else nation = 1 + initfw = 0 + Exit Sub + End If + Next i + Exit Sub + End If + + If liftoff Then GoTo pflag ' no fireworks when LM is lifting off + + If initfw = 0 Then ' fireworks launch & init + ve! = Rnd * 5 + 16 - lob * 8 ' vertical velocity + ho! = Rnd * 5 + 2 ' horizontal velocity + x!(0) = px! ' initial x, middle of craft + y!(0) = py! - 15 + ASO * 7 ' initial y, top of craft + ea = -(Rnd * t) ' explode at 0-10 + If lho! > 0 Then ho! = -ho! ' reverse direction half the time + lho! = ho! + Do ' launch + x!(0) = x!(0) + ho! / t ' t = 10 + y!(0) = y!(0) - ve! / t + ve! = ve! - .1 ' slow down + PSet (x!(0), y!(0)), yellow ' launch track + Loop Until ve! < ea ' explode + For i = 1 To fmax + z = nation - 1 + z = z * 6 + (i Mod (3 - z)) * 2 + 1 ' color index + ' rewhblreye + c(i) = Val(Mid$("0415010414", z, 2)) ' color + z! = Rnd * 5 + 1 ' velocity + ta = (i * 6) Mod tsix ' angle + ve!(i) = z! * c!(ta) ' vertical velocity + ho!(i) = z! * s!(ta) * 1.8 ' horizontal velocity + x!(i) = x!(0) + ho!(i) * 2 + xe! ' start of arm + y!(i) = y!(0) + ve!(i) * 2 + ye! + pe(i) = Rnd * 5 + t ' persistance of arm + Next i + initfw = 1 ' mark initialized + End If + + f = 1 ' assume done + For q = 0 To 1 ' show shell exploding + For i = 1 To fmax ' arms + If pe(i) Then ' persistance of arm + f = 0 ' not done + pe(i) = pe(i) - 1 ' persistance + x!(i) = x!(i) + ho!(i) + y!(i) = y!(i) + ve!(i) + ve!(i) = ve!(i) + .4 ' gravity modifies vertical + If Rnd > .1 Then + Line (x!(i), y!(i))-(x!(i) + Rnd, y!(i) + Rnd), c(i), B + End If + End If + Next i + Next q + If f Then initfw = 0 ' end of this one, start another + + pflag: ' plant/show flag + If sn <> nation Then ' new, or user changed it + sn = nation ' save current nation + s& = VarSeg(flagb(0)) ' segment + o& = VarPtr(flagb(0)) ' offset + Def Seg = s& ' set segment + BLoad f$(19 + nation), o& ' load array 20=USA 21=USSR + sx = 0 + rev = 0 + End If + + ReDim f2(600) ' FLAG + ty = fly - 80 + Line (flx - 1, fly)-(flx - 1, ty), white ' pole + zx = flx - rev * 71 + Get (zx, ty)-(zx + 70, ty + 32), f2() ' was flx + Put (zx, ty), flagb(), PSet ' flag + + ' optional move flag to left of pole + If (flx < px!) And (rev = 0) And (liftoff = 0) Then + For rx = 0 To 69 + For ry = 0 To 32 + p = Point(flx + rx, ty + ry) + PSet (flx - rx - 2, ty + ry), p + Next ry + Next rx + Put (flx, ty), f2(), PSet ' restore original area + Get (flx - 71, ty)-(flx - 2, ty + 32), flagb() ' get new + rev = 1 + zx = flx - 71 + End If + ReDim f2(0) + + sx = sx + t ' optional unfurl flag + If sx > 70 Then sx = 70 + If sx < 70 Then + If rev Then + Line (zx, ty)-(zx + 71 - sx, ty + 32), 0, BF + Else + Line (zx + sx, ty)-(zx + 71, ty + 32), 0, BF + End If + End If +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub GetSurface (gh) ' load surface array + Dim lz(t) ' landing zones + f$ = mpath$ + "s" + LTrim$(Str$(gh)) + ".dat" ' 0 - 10 + If gh < 0 Then f$ = mpath$ + "SL.DAT" ' l for level + If demo Then f$ = mpath$ + "SD.DAT" ' d for demo + Close #6 + Open f$ For Random As #6 Len = 2 + For i = 0 To 6399 + Get #6, i + 1, gh(i) + Next i + For i = 1 To t ' create landing zones + If demo Then ' compress onto 1 page + lz(i) = 3050 + (i - 1) * 80 + Else + lz(i) = 320 + (i - 1) * (q3 + 1) ' 1 per page + End If + Next i + If demo Then ' all on one page + Swap lz(9), lz(t) ' move grave 1 page left + Swap lz(2), lz(4) ' move car wash 2 pages right + End If + Restore features + For i = 1 To t + Read sf$(i), x, y, lz ' sf = special feature + sf(i, 0) = lz(i) - x \ 2 ' start + If demo And (i = 9) Then sf(i, 0) = 3750 ' Hollywood + sf(i, 1) = sf(i, 0) + x ' end + sf(i, 2) = sf(i, 0) + x \ 2 ' middle + Next i + If demo Then ' move LGM to top of grave + sf(3, 0) = sf(t, 0) + 14 ' x left + sf(3, 1) = sf(t, 1) + 14 ' x right + sf(3, 2) = sf(t, 2) + 14 ' x middle + End If + sspinit2 = 0 +End Sub +' -------------------------------------------------------------------------------------------------------x +Function gety (x) ' ground level for given x + ax = Abs(x) + xx = (suri + ax) Mod q1 + If sy1 > 310 Then + c1 = (xx >= sf(2, 0)) ' car wash start + c2 = (xx <= sf(2, 1)) ' car wash end + If c1 And c2 Then + If ASO Then z = 320 Else z = 338 ' safe zone start different with ascent stage only + If sy1 > z Then + gety = q4 ' 349, max y + Exit Function + End If + End If + End If + If x < 0 Then + c1 = (ek(2) <> -1) And (ek(2) < h) + c2 = (skyoff = 0) And (sy1 < borgt) And (ax > borgl) And (ax < borgr) + If c1 And c2 Then + gety = borgt + Exit Function + End If + End If + gety = gh(xx) +End Function +' -------------------------------------------------------------------------------------------------------x +Sub GraphSpeed Static ' pointless with QB64, but handy with QB4.5 + If speedi = 0 Then + spq = t: psp = 500 + Dim spt!(spq) + Dim pspeed(psp) + Dim m(3) As _MEM + m(0) = _Mem(spt!(0)) + m(1) = _Mem(spt!(1)) + m(2) = _Mem(pspeed(0)) + m(3) = _Mem(pspeed(1)) + speedi = 1 + End If + + If spt! = 0 Then + spt! = Timer + zmin! = h + zran! = 2 + sphac = psp + 1 + Else + _MemCopy m(1), m(1).OFFSET, 4 * spq To m(0), m(0).OFFSET + _MemCopy m(3), m(3).OFFSET, 2 * psp To m(2), m(2).OFFSET + + If spt! > Timer Then spt! = Timer + spt!(spq) = (Timer - spt!) * h * t + spt! = Timer + z! = 0 + For i = 1 To spq + z! = z! + spt!(i) + Next i + pspeed(psp) = z! / spq + spmin = q1: spmax = -spmin + sphac = sphac - 1 - (sphac = 0) + + If rick = 0 Then Exit Sub + + For i = sphac To psp + spx = 113 + i + spy = zmin! + (pspeed(i) - zmin!) / zran! + If i = sphac Then + PSet (spx, spy), orange + Else + Line -(spx, spy), orange + End If + If pspeed(i) <= spmin Then spmin = pspeed(i): spminx = spx: spminy = spy + If pspeed(i) >= spmax Then spmax = pspeed(i): spmaxx = spx: spmaxy = spy + Next i + + spsta = Fix(spmin / h) * h + spend = Int(spmax / h + pf!) * h + spend = spend - (spend = spsta) * h + For i = spsta To spend Step h + spy = zmin! + (i - zmin!) / zran! + Line (110, spy)-(614, spy), green, , &H1111 + z$ = Right$(" " + Str$(i), 4) + TinyFont z$, 87, spy - 2, orange + TinyFont z$, 620, spy - 2, orange + Next i + + z$ = LTrim$(Str$(spmin)) + ty = spminy - 15 + TinyFont z$, spminx + 5, ty, orange + Line (spminx, ty + 5)-(spminx, ty - 5), orange + + z$ = LTrim$(Str$(spmax)) + ty = spmaxy + 15 + If ty > q4 Then ty = q4 - 20 + TinyFont z$, spmaxx + 5, ty, orange + Line (spmaxx, ty)-(spmaxx, ty + t), orange + End If +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Grave (x, fb$) Static ' JFK's grave + tx1 = x: If tx1 < gs Then tx1 = gs + tx2 = x + 68: If tx2 > q3 Then tx2 = q3 + If tx1 >= tx2 Then Exit Sub + View Screen(tx1, 300)-(tx2, q4) + If bolthitf Then + tc = white: tc2 = white + Else + tc = gray: tc2 = gasoline + End If + Line (x, 300)-(x + 68, q4), tc, BF + Line (x + 2, 302)-(x + 66, 347), black2, B + For x1 = 0 To 1 + For y1 = 0 To 1 + x2 = x + x1 * 68 - 4 + y2 = 300 + y1 * 42 - 1 + Line (x2, y2)-(x2 + 9, y2 + 9), tc2, BF + Line (x2, y2)-(x2 + 9, y2 + 9), black2, B + Next y1 + Next x1 + + For z = 0 To 1 + Line (x + z, 300 + z)-(x + 68 - z, q4 - z), tc2, B + Next z + + If InStr(fb$, "g on a ") = 0 Then + z$ = " JFK R.I.P. 1917 1963" + Else + If (Timer Mod 10) < 5 Then + z$ = "B FROST R.I.P. 1952 2006" + Else + z$ = "R FROST R.I.P. 1957 2022" + End If + End If + + PrintVGA Left$(z$, 7), x + 5, 317, black2, white2 + + For i = 0 To 1 ' spooky wave effect for dates + d$ = Mid$(z$, i * 9 + 10, 9) + c1 = black2: c2 = gasoline + For j = 1 To 9 + c$ = Mid$(d$, j, 1) + ta = (ta + 23) Mod tsix + zz = (3 + 3 * Sin(ta * Atn(1) / 45)) * i + tx = x + (j - 2) * 6 + 12 + ty = 304 + i * 24 + zz + PrintCGA c$, tx, ty, c1, c2, 0 + Next j + Next i + View Screen(gs, 0)-(q3, q4) +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Help + View: Cls + hp = 1 + Do + Cls + If hp = 1 Then GoSub Help1 + If hp = 2 Then GoSub Help2 + If hp = 3 Then GoSub Help3 + If hp = 4 Then GoSub credits + timemachine + Do: _Limit 30 + i$ = InKey$ + Loop Until Len(i$) + If Len(i$) = 1 Then k = Asc(i$) Else k = Asc(Right$(i$, 1)) + hp = hp + (k = 75) - (k = 77) + If (k = 27) Or (hp < 1) Or (hp > 4) Then Exit Do + Loop + Cls + Exit Sub + ' -------------------------------------------------------------------------- + ReadAndReplace: + Read z$ + z = InStr(z$, "ground") + p = InStr(z$, "<"): If (p > 0) And (z = 0) Then Mid$(z$, p, 1) = Chr$(27) + p = InStr(z$, ">"): If (p > 0) And (z = 0) Then Mid$(z$, p, 1) = Chr$(26) + Return + ' -------------------------------------------------------------------------- + Help1: + Restore d1 + ReDim gbuff2(8000) + s& = VarSeg(gbuff2(0)) + o& = VarPtr(gbuff2(0)) + Def Seg = s& + BLoad mpath$ + "PANEL.DAT", o& + Put (0, 0), gbuff2(0) + ReDim gbuff2(0) + Line (85, 0)-(260, q4), gray, BF + For i = 1 To 13 ' define the panel first + Read ty, z$ + If i < 5 Then + sprint2 z$, 90, ty, white, 0 + Else + If i = 9 Then z$ = Chr$(24) + Chr$(25) + z$ ' up & down arrow keys + If i = 10 Then z$ = Chr$(27) + Chr$(26) + z$ ' left & right arrow keys + sprint z$, 90, ty, white, 0 + If (i = 9) Or (i = 10) Then sprint Left$(z$, 2), 90, ty, red, 0 + If i > 10 Then sprint Left$(z$, 1), 90, ty, red, 0 + End If + Next i + Line (261, 0)-(639, q4), blue2, BF ' summary of program + ty = 11: c = white + For i = 1 To 25 + GoSub ReadAndReplace + p = InStr(z$, "*auto") + If p Then qm$ = Chr$(34): Mid$(z$, p, 6) = qm$ + "auto" + qm$ + sprint z$, 275, ty, c, 0 + ty = ty + 9 - (z$ <> "") * 5 + Next i + Return + ' -------------------------------------------------------------------------- + Help2: + Restore d2 + c1 = gray + c2 = black + z$ = "KEYBOARD COMMANDS" + GoSub pageprep + tx = 40: ty = 26 + For i = 1 To 46 + GoSub ReadAndReplace + p = InStr(z$, "ud") + If p Then Mid$(z$, p, 2) = Chr$(24) + Chr$(25) + If i = 3 Then Mid$(z$, 8, 1) = " " + e = InStr(z$, "main t") + InStr(z$, "side t") + If e Then c = green Else c = white + If InStr("ahv", Left$(z$, 1)) Then c = gasoline + sprint2 z$, tx, ty, c, 0 + ty = ty + 11: If ty > 276 Then tx = 340: ty = 26 + Next i + Line (50, 300)-(585, 300), 0 + Line (55, 302)-(590, 302), 0 + GoSub ReadAndReplace + sprint2 "When landed or paused, arrow keys move stars", 135, 282, white, 0 + ty = 310 + sprint z$, 350, ty, white, 0 + sprint "essential", 50, ty, green, 0 + sprint "other flight", 150, ty, gasoline, 0 + Return + + Help3: + Restore d3 + c1 = gray + c2 = black + z$ = "MORE KEYBOARD COMMANDS" + GoSub pageprep + tx = 200: ty = 36: c2 = blue + For i = 1 To 20 + GoSub ReadAndReplace + If i = 20 Then ty = 310: c2 = black + sprint z$, tx, ty, white, c2 + ty = ty + 14 + Next i + + Line (50, 300)-(585, 300), 0 + Line (55, 302)-(590, 302), 0 + Return + ' -------------------------------------------------------------------------- + credits: + Restore d4 + c1 = dred + c2 = white + z$ = "AUTHOR & HUMOUR SUMMARY" + GoSub pageprep: x1 = 86: ty = 40 + For i = 1 To 30 + GoSub ReadAndReplace + If i = 30 Then + x1 = 320 - Len(z$) * 4 - 8 + x2 = 320 + Len(z$) * 4 + 8 + ty = 330 + Line (x1, ty)-(x2, ty + 11), dred, BF + End If + sprint2 z$, x1 + 8, ty, c2, 0 + ty = ty + t + Next i + Return + ' -------------------------------------------------------------------------- + pageprep: + Cls: Paint (1, 1), c1 + x1 = 30: y1 = 5: x2 = 610: y2 = 345 + For q = 2 To 20 Step 4 + Line (x1 - q, y1 + q)-(x2 + q, y2 - q), c1, B + Line (x1 - q + 1, y1 + q + 1)-(x2 + q + 1, y2 - q + 1), c2, B + Next q + z = Len(z$) + 2: x1 = 320 - z * 4: x2 = 320 + z * 4 + Line (x1, 9)-(x2, 22), c1, BF + sprint z$, x1 + 8, t, white, -c2 + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Henonp (f) Static ' pretty pictures at top left, Henon plots + + If henoni = 0 Then ' one time initializations + z = 20000 + Dim tb(z) + henoni = 1 + End If + + s& = VarSeg(tb(0)) ' for BLOADING images + o& = VarPtr(tb(0)) + Def Seg = s& + + If crash Then GoTo nosp ' gonna show something else + wts = (wts + 1) Mod 3 ' what to show + For pass = 1 To 2 + For i = 0 To 2 + If ((i = wts) Or (pass = 2)) And (Timer < rtl!(i)) Then + Select Case i + Case Is = 0 ' radiation + BLoad f$(19), o& ' rad.dat + Put (0, 0), tb(0), PSet + gotblank = 0 + Case Is = 1 ' thermometer + GoSub loadblank + Line (20, 28)-(26, 56), 0, BF ' shadow + Line (20, 26)-(24, 56), 0, BF ' erase old + Line (20, 26)-(24, 56), red, B ' outline + Circle (23, 60), 5, 0 ' bulb shadow + Circle (24, 60), 5, 0 ' bulb shadow + Circle (22, 59), 5, red ' bulb + Paint (22, 59), red, red ' bulb fill + ty = 56 - rtlc(1) / 100 * 30 ' reading + Line (20, ty)-(24, 56), red, BF + Case Is = 2 ' lightning count + GoSub loadblank + uc = uc Xor 1 + If uc Then tc = yellow Else tc = gold + PSet (17, 27) ' draw lightning bolt + Line -(33, 27), tc + Line -(24, 43), tc + Line -(29, 43), tc + Line -(16, 63), tc + Line -(21, 47), tc + Line -(13, 47), tc + Line -(17, 27), tc + Paint (22, 47), tc, tc + End Select + z = rtlc(i) ' 0rads 1temperature 2bolts + lf = -1 + PrepAndShowLED CSng(z), 4, 10 + Exit Sub + End If + Next i + Next pass + + nosp: ' no special = Henon plots + If f <> lf Then + tf$ = f$(f) + BLoad tf$, o& + gotblank = 0 + lf = f + End If + hc = (hc + 1) Mod 13 ' h1-h5 contain 13 images each + If crash Then hc = 0 ' h6.dat only has one page + Put (0, 0), tb(hc * 1500), PSet ' includes + PrepAndShowLED 0, 4, 0 + Exit Sub + + loadblank: ' not really blank - has program name + If gotblank = 0 Then ' and clock/McD/speed/count box + BLoad f$(39), o& ' is lanblank.dat + gotblank = 1 + End If + Put (0, 0), tb(0), PSet + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Hollywood + For i = 1 To 9 + tx = x + i * 16 + ty = gety(tx) - 14 + PrintVGA Mid$("HOLLYWOOD", i, 1), tx - 4, ty, white, black + Line (tx, ty + 9)-(tx, ty + 22), gray2 + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub IBM Static + Dim a(1) + x0 = x + y0 = 304 + If bolthitf Then tc = white Else tc = gasoline ' lightning bolt from deathstar + Line (x0, y0)-(x0 + 50, y0 + 45), tc, BF ' entire area + Line (x0, y0)-(x0 + 50, y0 + 45), gray, B ' outline + + Line (x0, y0 - 1)-(x0, y0 - 30), gray2 ' light towers + Line (x0 + 50, y0 - 1)-(x0 + 50, y0 - 30), gray2 + + If bbit Then ' global seconds toggle + PSet (x0, y0 - 30), red ' lights on towers + PSet (x0 + 50, y0 - 30), red + ltoggle = ltoggle Xor 1 + If ltoggle Then + PSet (x0, y0 - 31), red + PSet (x0 + 50, y0 - 31), red + Line (x0 - 2, y0 - 30)-Step(4, 0), red + Line (x0 + 48, y0 - 30)-Step(4, 0), red + End If + End If + + If a(0) = 0 Then a(0) = 30: a(1) = 150 ' initial marker positions + If Rnd > pf! Then ' reel mark direction&speed + tdir = Sgn(Rnd - pf!) * Int(Rnd * 4 + 2) + If Rnd > .8 Then tdir = 0 ' sometimes not moving + End If + Line (x0 + 6, y0 + 15)-(x0 + 19, y0 + 21), black2 ' tape + Line -(x0 + 33, y0 + 21), black2 + Line -(x0 + 44, y0 + 15), black2 + Line (x0 + 24, y0 + 19)-Step(3, 1), dred, BF ' head + For i = 0 To 1 ' reels/rollers + a(i) = (a(i) + t * tdir + tsix) Mod tsix ' marker angle + x = x0 + 13 + i * 24 + y = y0 + 11 + For d! = 5 To 9 + Circle (x, y), d!, white, , , .73 ' reel + Circle (x, y), d!, white, , , .68 + Circle (x, y), d!, white, , , .62 + Next d! + x1 = x + 3 * s!(a(i)) * grav! + y1 = y + 3 * c!(a(i)) + x2 = x + 6 * s!(a(i)) * grav! + y2 = y + 6 * c!(a(i)) + Line (x1, y1)-(x2, y2), black2 ' rotation marker + For d = 0 To 4 ' hub + Circle (x, y), d, dred, , , .73 + Circle (x, y), d, dred, , , .68 + Next d + Next i + + If sia > 0 Then ' shells in air = building gets MEAN title + PrintLines "HAL", 0, 47, x0 + 1, y0 + 39, red, white, 1, 2 + Else + PrintLines "IBM", 0, 47, x0, y0 + 39, blue, white, 1, 2 + End If + + ' binary clock + z$ = Time$ ' hh:mm:ss + z$ = Left$(z$, 2) + Mid$(z$, 4, 2) + Right$(z$, 2) ' hhmmss + For i = 1 To 6 + v = Val(Mid$(z$, i, 1)) ' value + x = x0 + i * 5 + 2 - (i > 2) * 5 - (i > 4) * 5 ' column + z = Val(Mid$("132323", i, 1)) ' rows for this column + For j = 0 To z + If v And 1 Then c = red Else c = black2 ' red = on + v = v \ 2 + y = glmax - 2 - j * 2 + Line (x - 1, y)-(x + 1, y), c, B ' show bit + Next j + Next i + + If ttf! < -2 Then fat! = Timer + 10 + ttf! = fat! - Timer ' time to fire + If fat! > 86400 Then fat! = t: ttf! = 0 + + If (ttf! > 0) And (ttf! < 1) Then ' optional radar + sky = (sky + 1) Mod tsix + x1 = x0 + 25 + For sky2 = 0 To 180 Step 5 + zz = (sky + sky2) Mod 180 + x2 = x1 + q2 * c!(zz) + y2 = (y0 - 1) - q2 * s!(zz) - 1 + Line (x1, y0 - 1)-(x2, y2), red, , &H1111 + Next sky2 + End If + + If pat1& = 0 Then pat1& = &H5555: pat2& = &HAAAA + Swap pat1&, pat2& ' countdown to firing + z! = ttf!: If z! < 0 Then z! = 0 + tx = x0 + z! / t * 48 + If tx > (x0 + 48) Then tx = xo + 48 ' crude fix for a midnite crossing + ty = y0 + 1 + Line (x0 + 1, ty)-(tx, ty), black2, , pat1& + Line (x0 + 1, ty)-(tx, ty), red, , pat2& + + If (sia < 20) And (shoot Or (ttf! <= 0)) Then ' initialize shell + shoot = 0 + For s = 1 To 20 + If shx(s) = 0 Then + sia = sia + 1 ' shells in air + shx(s) = suri + x0 + 25 + shy(s) = 320 + shellv = (-32 + (Rnd - pf!) * t) * t ' velocity + ta = 0 + If Rnd > .1 Then ' smart 10% (good aim) + If Rnd > pf! Then + ta = -Rnd * 25 + Else + ta = Rnd * 50 ' above or below + End If + ta = ta + (Rnd - pf!) * 4 ' vary it a little + End If + dx = px! - shx(s) + suri + dy = shy(s) - py! + If dy = 0 Then dy = 1 + shella = _R2D(Atn(dx / dy)) + (90 - 5 * Sgn(dx) + ta) + If py! > 280 Then + shella = 90 + (Rnd - pf!) * 40 + shellv = shellv * .75 + End If + shella = (shella + tsix) Mod tsix + shvx(s) = (shellv / t) * c!(shella) + shvy(s) = (shellv / t) * s!(shella) + shd(s) = q1 + Exit For + End If + Next s + End If +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Info Static ' show messages + Dim lenmes(1) + If Len(fb$) Then mes$(0) = UCase$(fb$): sm!(0) = mTIMER + + For i = 0 To 1 + If mes$(i) <> omes$(i) Then sm!(i) = 0 + lenmes(i) = Len(mes$(i)) + If lenmes(i) And (sm!(i) = 0) Then + sm!(i) = Timer + omes$(i) = mes$(i) + End If + el! = Timer - sm!(i) + If el! > 5 Then mes$(i) = "": sm!(i) = 0 + Next i + tcenter = (q3 + gs) \ 2 ' center of "space" area + If lenmes(0) Then + c1 = white2: c2 = gray + z$ = LTrim$(mes$(0)) + l3$ = Left$(z$, 3) + If l3$ = "CM:" Then c1 = red ' rendesvous chatter + If l3$ = "DAN" Then c1 = red ' Danger, Will Robinson + If c1 = red Then c2 = black2 + If (convo > 0) Or (InStr("EstWARRad", l3$) > 0) Then + PrintVGA z$, tcenter - lenmes(0) * 4, 5, c1, -1 + Else + If lenmes(0) > (34 - (gs = 0) * 5) Then + tcol = (tcol + 4) Mod (lenmes(0) * t) + z$ = Space$(4) + z$ + PrintLines z$, tcol, tcol + 40 * 16, gs, 20, c1, c2, 2, 2 + Else + tx = tcenter - Len(z$) * 8 + 'LINE (gs, 6)-(q3, 17), 0, BF + PrintLines z$, 0, lenmes(0) * 16 - 1, tx, 20, c1, c2, 2, 2 + End If + End If + End If + + If lenmes(1) Then ' subordinate msg + If lenmes(0) Then ty = 30 Else ty = 5 + PrintVGA mes$(1), tcenter - lenmes(1) * 4, ty, red, dred + End If + + If (invincible = 0) And (rads >= h) And (Timer < rtl!(0)) Then + z = rads \ h + If z >= t Then radiationdeath = 1: z = t ' >= ten + If z <= t Then ' <= ten + Restore radcomments + For i = 1 To z + Read z$ + Next i + If Val(Left$(z$, 1)) Then ' does it start with a #? + z$ = "ensures your death within " + z$ ' yes, tack on phrase + End If + mes$(1) = "Radiation exposure " + z$ + "!" + End If + End If +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub LEDdisplay (t$) Static + If LEDinit = 0 Then + Dim segment(6, 3), number$(11) + Restore leds + For i = 0 To 6 + Read g$ + For j = 0 To 3 + Read segment(i, j) + Next j + Next i + For i = 0 To 11 + Read g$, number$(i) + Next i + LEDinit = 1 + End If + + If (osc < 6) Or (osc = t) Then ' fuel,alt,h,v,thrust,angle + tc = c: If LEDtri = 0 Then tc = LEDc + If osc = t Then ' angle + segx = 14: segy = 14 ' segment size + tx = 92 - Len(t$) * segx * 2 + ty = 298 + Else + tl = (Len(t$) - Sgn(InStr(t$, "."))) * 16 + tx = gs - tl + ty = 296 - osc * 39 + segx = 8: segy = 8 + End If + Else ' 6clock 7dtm 8speed 9rads + If osc = 9 Then tc = red Else tc = orange + If crash Then tc = white2 + tx = 50 + ty = 35 + (osc - 6) * 9 + If osc = 9 Then ty = 62 + segx = 4: segy = 3 + End If + + If crash And (osc <> 6) Then Exit Sub ' allow clock + + dpp = 0 ' decimal point + For si = 1 To Len(t$) + z$ = Mid$(t$, si, 1) + If z$ = "." Then ' plot sub can't handle decimal + tx1 = tx + (si - 1) * 16 - 5 + Line (tx1, ty - 1)-(tx1 + 1, ty), tc, BF + dpp = 1 + Else + z = Val(z$) + If z$ = "-" Then z = t + If z$ = "L" Then z = 11 ' "L" for lock fuel and level ground + If z$ <> " " Then GoSub leddigit + End If + Next si + + If osc = 6 Then ' colon for clock + If crash Then bbit = 1 + PSet (tx + 14, ty - 4), tc * bbit + PSet (tx + 14, ty - 2), tc * bbit + End If + Exit Sub + + leddigit: + For i = 1 To Len(number$(z)) + seg$ = Mid$(number$(z), i, 1) + If InStr("abcdefg", z$) Then seg$ = z$ ' for wave effect + segn = Asc(seg$) - 97 + x0 = tx + (si - 1 - dpp) * (segx * 2) + x1 = x0 + segment(segn, 0) * segx + y1 = ty + segment(segn, 1) * segy + x2 = x0 + segment(segn, 2) * segx + y2 = ty + segment(segn, 3) * segy + If x1 < x2 Then + Line (x1 + 1, y1)-(x2 - 1, y1), tc ' horizontal + If osc = t Then ' angle (very thick) + Line (x1 + 2, y1 - 1)-(x2 - 2, y1 - 1), tc + Line (x1 + 2, y1 + 1)-(x2 - 2, y1 + 1), tc + End If + Else + Line (x1, y1 + 1)-(x1, y2 - 1), tc ' vertical + If osc = t Then ' angle (very thick) + Line (x1 - 1, y1 + 2)-(x1 - 1, y2 - 2), tc + Line (x1 + 1, y1 + 2)-(x1 + 1, y2 - 2), tc + End If + End If + Next i + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub LGM (fc) Static ' little green man + + x = x - 5 + If LGMc = gray Then ' LGM toasted - show pile of ashes + y1 = gety(x + t) - 1 + For y = 0 To 5 + Line (x + y, y1 - y)-(x + 15 - y, y1 - y), gray + p = Val(Mid$("162341", y + 1, 1)) + PSet (x + y + p, y1 - y), black2 + PSet (x + y + p + 3, y1 - y), black2 + Next y + Exit Sub + End If + + If sema$ = "" Then ' initialize + Dim a(28, 1) ' angles + Restore semadata + For i = 1 To 28 ' read angles + Read z$, a(i, 0), a(i, 1) + Next i + Do + Read z$ + If z$ = "end" Then Exit Do + sema$ = sema$ + " " + z$ + " " + Loop + lc$ = Chr$(255): i = 0 ' lc = last character, i = index + End If + + If crash Then LGMc = dred ' white2 as many other colors g1 + If Timer < sema! Then sema! = Timer ' midnite crossing fix + If (Timer - sema!) > semat! Then ' signal next letter + sema! = Timer + If fc = 0 Then ' flame count + semat! = .3 + tsema$ = sema$ + If si > 0 Then i = si - 1: si = 0 + Else + semat! = .2 ' 0.2 seconds between letters + If fc < 5 Then ' flame count + If tsema$ <> "help " Then tsema$ = "!" + toast = 0 + Else + tsema$ = "help " + toast = toast + 1 + If toast > 2 Then toast = 0: LGMc = LGMc + 1 + End If + End If + i = (i Mod Len(tsema$)) + 1 + p = InStr(tsema$, "time is") + If p Then + z$ = Mid$(Time$, 1, 2) + Mid$(Time$, 4, 2) + Mid$(tsema$, p + 8, 4) = z$ + End If + y1 = gety(x) - 14 + If demo Then y1 = 286 + c$ = Mid$(tsema$, i, 1) + d = Asc(LCase$(c$)) - 96 + If d < 1 Then d = 27 + If c$ = "!" Then d = 28 + p = InStr("1234567890", c$): If p Then d = p - (c$ = "0") + If oscar Then + c1 = red + c2 = gold + Else + c1 = blue + c2 = white + End If + If (c$ <> " ") And (c$ = lc$) Then Swap c1, c2 + lc$ = c$ + End If + + c = Val(Mid$("021412040906110015", (LGMc - 1) * 2 + 1, 2)) + If bolthitf Then c = white + If c = black2 Then co = gray2 Else co = black2 + Circle (x + t, y1 - 6), 4, c ' head + Paint (x + t, y1 - 6), c, c ' fill in head + PSet (x + 8, y1 - 7), co ' left eye + PSet (x + 12, y1 - 7), co ' right eye + Line (x + 9, y1 - 5)-(x + 11, y1 - 5), co ' mouth + Line (x + 5, y1)-(x + 15, y1 + 12), c, BF ' body + If c = black2 Then + Circle (x + t, y1 - 6), 5, co ' eye + Line (x + 5, y1)-(x + 15, y1 + 12), co, B ' body + End If + + If (d = 27) And (c <> black2) And (fc = 0) Then ' wiggle ears + x2 = x + 5 - bbit + x3 = x + 14 + bbit + y2 = y1 - 8 + bbit + Line (x2, y2)-(x2 + 1, y2 + 1), c, BF + Line (x3, y2)-(x3 + 1, y2 + 1), c, BF + End If + + If fc Then ' optional flame effect + If fc > t Then di = 4 Else di = t ' flame count + For tx = x + 5 To x + 15 + For ty = y1 - 9 To y1 + 12 + p = Point(tx, ty) + z = (z + 1) Mod q1 + If p = c Then + tc = (ty + tx + z) Mod di + If tc = 0 Then PSet (tx, ty), gold + If tc = 1 Then PSet (tx, ty), black2 + End If + Next ty + Next tx + End If + + If c = black2 Then c = gray2 + For j = 0 To 1 ' arms & flags + a1 = a(d, j) - 90 + x2 = x + j * 20 + x3 = x2 + 26 * Cos(_D2R(a1)) + y2 = y1 + 25 * Sin(_D2R(a1)) + Line (x2, y1)-(x3, y2), c ' arm + If j = 0 Then s = 1: If InStr("wxz", c$) Then s = -s + If j = 1 Then s = -1: If InStr("hio89", c$) Then s = -s + For q = 0 To 3 + a1 = a1 - 90 * s + x4 = x3 + t * Cos(_D2R(a1)) + y4 = y2 + t * Sin(_D2R(a1)) + Line -(x4, y4), gunmetal + If q = 1 Then + sx = x4: sy = y4 + r! = _D2R(a1 - 45 * s) + rx = x3 + 5 * Cos(r!) + ry = y2 + 5 * Sin(r!) + End If + If q = 3 Then + r! = _D2R(a1 - 45 * s) + yx = x3 + 5 * Cos(r!) + yy = y2 + 5 * Sin(r!) + End If + x3 = x4: y2 = y4 + Next q + Line -(sx, sy), gunmetal + Paint (rx, ry), c1, gunmetal + Paint (yx, yy), c2, gunmetal + Next j + + If c$ = UCase$(c$) Then + x2 = x + 5 + Sgn(InStr("ACDHJMNOPSUV0123456789", c$)) ' letter centering + y2 = y1 + 2 + Else + x2 = x + 6 - Sgn(InStr("ijlnv", c$)) ' as above + y2 = y1 - Sgn(InStr("gjpqy", c$)) + 2 + End If + + If LGMc = 4 Then tc = gold Else tc = red + Call PrintVGA(c$, x2, y2, tc, black2) +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub LMbloads + p = ASO * 3 + 4 + + s& = VarSeg(LMx(0)) + o& = VarPtr(LMx(0)) + Def Seg = s& + BLoad f$(p), o& + + s& = VarSeg(LMy(0)) + o& = VarPtr(LMy(0)) + Def Seg = s& + BLoad f$(p + 1), o& + + s& = VarSeg(LMc(0)) + o& = VarPtr(LMc(0)) + Def Seg = s& + BLoad f$(p + 2), o& +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub LMdistort + For i = 1 To rp + If (LMc(i) = craft) And (Rnd > .6) Then + LMx(i) = LMx(i) + Rnd * 3 - 1 + LMy(i) = LMy(i) + Rnd * 3 - 1 + End If + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub LoadPanel Static + If pload = 0 Then + z = 12500 + ReDim pb(z) + tf$ = mpath$ + "PANEL" + Chr$(48 + background) + ".DAT" + s& = VarSeg(pb(0)) + o& = VarPtr(pb(0)) + Def Seg = s& + BLoad tf$, o& + pload = 1 + End If + Put (0, 67), pb(), PSet +End Sub +' -------------------------------------------------------------------------------------------------------x +Function localize (tx, p, m) + z0 = 9999 ' assume out of range + z1 = suri - m ' surface index - minus + z2 = suri + p + q3 ' surface index + plus + For z = -1 To 1 ' page before, current, next + zx = tx + z * q1 + If (zx <= z2) And (zx >= z1) Then z0 = tx - suri + q1 * z + Next z + localize = z0 ' return 9999 or calculated +End Function +' -------------------------------------------------------------------------------------------------------x +Sub MakeStarFiles ' takes a LONG time + If iscd Then Exit Sub + savestarfiles = starfiles + ts$ = Time$ + mstar = 0 + For starfiles = 0 To 2 + For rmin = 0 To 23 + For dmin = -90 To 90 Step 10 + mstar = mstar + 1 ' for progress bar + starinit = 0 + regen = 1 + Stars + If InKey$ = Chr$(27) Then System ' Esc aborts + Next dmin + Next rmin + Next starfiles + mstar = 0 + sprint ts$, 200, 100, red, black + sprint Time$, 200, 120, red, black + timemachine + Sleep ' lets user see how LONG it took + starfiles = savestarfiles: starinit = 0: rmin = 0: dmin = 0 +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub MakeSur + If iscd Then Exit Sub + Dim z!(t), a1(t), v1(t), lz(t) + msflag = 1 + View + Cls + For gh = -2 To 9 ' -2 demo, -1 flat, 0-9 rocks + z$ = "Creating surfaces" + Str$(gh + 3) + " of 12" + Line (s, 0)-(q3, 20), 0, BF + PrintVGA z$, 320 - Len(z$) * 4, 2, white, black + timemachine + + If InKey$ = Chr$(27) Then Quit + f$ = "s" + LTrim$(Str$(gh)) + If gh = -2 Then f$ = "sd" + If gh = -1 Then f$ = "sl" + f$ = mpath$ + f$ + ".dat" + Close #6 + Open f$ For Random As #6 Len = 2 + For i = 1 To q1 ' 6400, 10 pages + Put #6, i, glmax + Next i + If gh < 0 Then GoTo keepflat + For i = 1 To 4 ' make sine waves + z!(i) = Rnd * 36 / 550 + a1(i) = Rnd * tsix + v1(i) = Rnd * gh * 2 + Next i + For i = 0 To q1 + z! = 0 + For j = 1 To 4 + y! = v1(j) * Sin((i - a1(j)) * z!(j)) + z! = z! + y! * 4 + Next j + If (i > 5320) And (i < 5560) Then z! = z! / 4 - 40 ' make Hollywood higher + z = glmax - Abs(z!) + If z < glmin Then z = glmin + Put #6, i + 1, z + Next i + Smooth 5319 + Smooth 5559 + keepflat: + If gh = -2 Then tz = 3130 Else tz = 2240 + For i = -51 To 51 ' volcano + z = glmax - (51 - Abs(i)) + Put #6, tz + i, z + Next i + Smooth 2240 - 50 + Smooth 2240 + 50 + z = 302 + For i = -5 To 5 ' volcano top + Put #6, tz + i, z + Next i + If gh > -1 Then ' ground height not flat, add rocks/small craters + For i = -1 To 1 Step 2 ' up or down + rocks = Rnd * h + h ' rocks & indentations + For j = 1 To rocks + rx = Rnd * 6380 + t + zz = Rnd * 4 + 1 + For k = -zz To zz + Get #6, rx + k, z + z = z - zz * i + Abs(k) * i + If z < glmin Then z = glmin + If z > glmax Then z = glmax + Put #6, rx + k, z + Next k + Next j + Next i + End If + Smooth q1 - 1 ' 6399 - 0 transition + + For i = 1 To t ' create landing zones + If gh = -2 Then ' compress onto 1 page + lz(i) = 3050 + (i - 1) * 80 + Else + lz(i) = 320 + (i - 1) * (q3 + 1) ' 1 per page + End If + Next i + If gh = -2 Then ' demo terrain + Swap lz(9), lz(t) ' move grave 1 page left + Swap lz(2), lz(4) ' move car wash 2 pages right + End If + + hs = 0 + Restore features + For i = 1 To t ' 10 features, create landing zones beside each + Read z$, x, y, lz + sf(i, 0) = lz(i) - x \ 2 ' start + sf(i, 1) = sf(i, 0) + x ' end + sf(i, 2) = (sf(i, 0) + sf(i, 1)) \ 2 ' middle + If i = 4 Then GoTo isvolcano + For x2 = -lz To lz + z = hs * (y = 0) * (i <> 5) + If i = 3 Then z = 40 ' LGM + If i = 4 Then z = 50 - Abs(x2) / 2 + If gh <> -2 Then + z = glmax - z + Put #6, sf(i, 2) + x2, z + End If + Next x2 + For x2 = sf(i, 0) To sf(i, 1) ' target + Get #6, x2 + 1, z + z = z + y * (y <> 0) + Put #6, x2 + 1, z + Next x2 + If gh <> -2 Then + Smooth sf(i, 2) - lz + Smooth sf(i, 2) + lz + End If + isvolcano: + Next i + + Smooth sf(1, 0) ' Area 51 + Smooth sf(1, 1) + + Restore BigM ' McDonalds + y = 0 + Do + Read z$ + If z$ = "x" Then Exit Do + y = y + 1 + For x = 1 To Len(z$) + If Mid$(z$, x, 1) = "X" Then + z = glmax + y - 38 + Put #6, sf(5, 0) + x + 1, z + End If + Next x + Loop + + suri = 0 + For i = 1 To q1 ' optional, show progress + Get #6, i + 1, y + y = gh * 25 + y / 6 + 20 + PSet (i \ t, y), 1 + Next i + Next gh + msflag = 0 + 'timemachine + 'SLEEP +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Mandel ' appears in TMA-1 when landed on + xd! = .044 + yd! = .036 + zz! = Timer * 4 + Line (x, glmax - 1)-(x + 45, glmax - 71), black2, BF + For xx = 0 To 23 + For yy = 0 To 70 + MandelX! = -2 + yy * yd! + MandelY! = -1 + xx * xd! + Real# = 0 + Imag# = 0 + Itera = 20 + Do + Itera = Itera - 1 + hold# = Imag# + Imag# = (Real# * Imag#) * 2 + MandelY! + Real# = Real# * Real# - hold# * hold# + MandelX! + Size# = (Real# * Real# + Imag# * Imag#) - 4 + Loop Until (Itera = 0) Or (Size# > 0) + If Size# > 0 Then + tc = (Itera + zz!) Mod 15 + 1 + ty = glmax - 71 + yy + PSet (x + xx, ty), tc ' left half + PSet (x + 45 - xx, ty), tc ' right half + End If + Next yy + Next xx +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Map ' location of features at top + Line (0, 0)-(gs - 1, 1), blue2, BF + For i = 1 To 17 + ufof + If i <= t Then ' surface features + tx = sf(i, 2) + If tx = -1 Then GoTo skipf ' destroyed + tc = blue + z$ = sf$(i) ' surface feature name + If i = 3 Then z$ = "LGM" ' shorten some names + If i = 5 Then z$ = "McD" + If i = 7 Then z$ = "SSC" + GoTo wubba + End If + If i = (17 + ufof) Then + tc = white + tx = (suri + px!) Mod (q1 + 1) + z$ = "LM" + Else ' sky feature + If skyoff Then GoTo skipf + j = i - 11 + If (ek(j) = -1) Or eou Then GoTo skipf ' destroyed or not present + If j Then tc = red Else tc = green ' CM green, rest red + tx = ex(j) + ' 1 2 3 4 5 6 + ' 12345123451234512345123451234512345 + z$ = RTrim$(Mid$("CM DS Borg BH Worm CometAlien", j * 5 + 1, 5)) + If j = 0 Then z$ = z$ + Str$(exv(0)) ' CM + velocity + End If + + wubba: + tx = tx \ t + Line (tx, 0)-(tx + 1, 1), tc, BF + zz = Len(mes$(0)) + Len(mes$(1)) - (liftoff = 1) ' quash names when messages active and during liftoff + If (zz = 0) And (tx > (gs + 6)) Then PrintLines z$, 0, Len(z$) * 8, tx - 6, 16, tc, -99, 0, 1 + skipf: + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub McD Static ' 37 * 16 + If McDi = 0 Then ' initialize + z$ = " Burger, fries & Coke only $1.99!" + For i = 1 To Len(z$) ' Morse code + c$ = Mid$(z$, i, 1) + Restore MorseData + For j = 1 To 39 + Read d$, x$ + If d$ = LCase$(c$) Then m$ = m$ + x$ + " " + Next j + Next i + McDi = 1 + End If + + mp = (mp + 4) Mod 320 ' show ad in text + x2 = x + 38 + If bolthitf Then tc = white Else tc = gold + Line (x, glmax)-(x2, glmax - 19), tc, BF ' clear sign area + PrintLines z$, mp, mp + 37, x, glmax - 1, red, black2, 1, 1 + + For mx = x To x2 - 1 ' arch & red neon + my = gety(mx) + arch = (arch + 1) Mod t + If arch < 2 Then tc = red Else tc = gold + If bolthitf Then tc = white + If mx > x Then Line (mx, my)-(mx, my + 2), tc + tmx = x + x2 - mx - 2 + If tmx > x Then Line (tmx, glmax - 19)-(tmx + 2, glmax - 18), tc, BF + Next mx + + y = glmax - 1 ' show ad in Morse + i = 0 + z = (z Mod Len(m$)) + 1 + Do + j = ((z + i) Mod Len(m$)) + 1 + i = i + 1 + p = InStr(".- ", Mid$(m$, j, 1)) - 1 + If p < 2 Then Line (x, y)-(x + p * 2, y), black2 + x = x + (p + 1) * 2 + Loop Until (x + 2) > x2 +End Sub +' -------------------------------------------------------------------------------------------------------x +Function OnOff$ (v) + OnOff$ = Mid$("OFFON ", v * 3 + 1, 3) +End Function +' -------------------------------------------------------------------------------------------------------x +Sub Parachute Static ' because it's funny + If contact Then + cy! = cy! + 5 + If cy! > 500 Then cy! = 500: chs = 1: paraf = 0 + chs = chs - 1 + Else + cy! = py! - h + If (py! > 120) And (chs < 40) Then chs = chs + 2 + End If + For ta = 0 To tsix + r! = _D2R(ta) / 2 + tx = px! + chs * Cos(r!) * 2 + ty = cy! - chs * Sin(r!) + PSet (tx, ty), gray2 + If (ta / 20) Mod 2 Then tc = red Else tc = white2 + Line -(tx, cy!), tc + If (ta Mod 40) = 0 Then Line -(px! - ASO, cy! + 82 + ASO * t), gray2 + Next ta +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub PrepAndShowLED (t!, nd, dp) Static + osc = osc + 1 + If dp = t Then dp = 0: osc = 9 + + ti = Fix(t!) + z! = Abs(t! - ti) + s$ = Space$(6) + If (t! < 0) And (ti = 0) Then + t1$ = Right$(s$ + "-" + LTrim$(Str$(ti)), nd) + Else + t1$ = Right$(s$ + LTrim$(Str$(ti)), nd) + End If + + t2a$ = LTrim$(Str$(Int(z! * (t ^ dp)))) + If Len(t2a$) < dp Then t2a$ = Right$("000" + t2a$, dp) + t2$ = Left$(LTrim$(t2a$) + "0000", dp) + If dp = 0 Then z$ = t1$ Else z$ = t1$ + "." + t2$ + + If z$ = " -0.00" Then z$ = " 0.00" + + If (osc = 9) And (t! = 0) Then ' usually count for rads, lightning + cylon = (cylon + 1) Mod 6 ' when blank, cycle a "-" + zz = Val(Mid$("123432", cylon + 1, 1)) + z$ = " " + Mid$(z$, zz, 1) = "-" + End If + + If osc = 4 Then + If (liftoff = 0) And level Then Mid$(z$, 1, 1) = "L" ' altitude + If radarf = 0 Then z$ = " ----" + End If + + If (osc = 5) And lockfuel Then Mid$(z$, 1, 1) = "L" ' fuel + + If warp! > 0 Then + If osc = 4 Then z$ = " ----" ' suppress altitude + If osc = 7 Then z$ = "----" ' distance to McDonalds + End If + + LEDdisplay z$ +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub PrintCGA (c$, x, y, tc1, tc2, compress) Static ' CGA font, 8 * 8 + c1 = tc1 + c2 = tc2 + If y = -1 Then ' single char panel stuff - F for Fuel, etc. + c2 = -1 + y = 263 - osc * 39 + tx1 = x - 3 + tx2 = x + 11 + ty1 = y + ty2 = y + t + If bbit And (LEDc = green) And (radarf > 0) And (contact = 0) And ((c1 = red) Or (c1 = yellow)) Then + Line (tx1 + 1, ty1 + 1)-(tx2 - 1, ty2 - 1), c1, BF + c1 = black2 + Else + If (osc = 4) And (radarf = 0) Then c1 = gray Else c1 = white + End If + End If + + If y + 9 > glmax Then Exit Sub + tx = x + 1 + + For i = 1 To Len(c$) + d = Asc(Mid$(c$, i, 1)) + For k = 0 To 7 + If p2(d, k) Or (compress = 0) Then + If c2 >= 0 Then + Line (tx + 1, y + 2)-(tx + 1, y + t), c2, , p2(d, k) + End If + Line (tx, y + 1)-(tx, y + 9), c1, , p2(d, k) + tx = tx + 1 + End If + Next k + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub PrintLines (d$, i1, i2, x1, y1, c1, c2, sd, s) Static + ' chars, index1, index2, x,y, color 1, color 2, shadow distance,size + slant = -(c2 < -20) + For i = i1 To i2 - 1 + z = i \ (8 * s) + 1 + If z > Len(d$) Then d = 32 Else d = Asc(Mid$(d$, z, 1)) + If d = 248 Then d = 0 ' degree symbol + m& = _SHL(1, (7 - (i \ s) Mod 8)) + p& = 0 + For j = 0 To 13 + p& = p& * 2 + Sgn((p(d, 13 - j) And m&)) + Next j + If c2 = -99 Then ' vertical + ty1 = y1 + (i - i1) + ty2 = ty1 - slant * 13 + Line (x1, ty1)-(x1 + 13, ty2), c1, , p& * 2 + Else ' horizontal + tx1 = x1 + i - i1 + 1 + tx2 = tx1 + slant * 15 + ty2 = y1 - 15 + Line (tx1, y1)-(tx2, ty2), c1, , p& + If c2 >= 0 Then Line (tx1 + sd, y1)-(tx2 + sd, ty2), c2, , p& + End If + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub PrintVGA (z$, tx, ty, c1, c2) ' VGA font, 8 * 14 + PrintLines z$, 0, Len(z$) * 8 - 1, tx, ty + 13, c1, c2, 1, 1 +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Quit ' save current configuration then exit to system + Screen 0, 0, 0, 0 + Cls + Close + If iscd Then System ' can't save config to a CD + + Open settings$ For Output As #1 + z = auto: d$ = "auto": GoSub pconfig ' 1 full autopilot + z = background: d$ = "panel": GoSub pconfig ' 2 instrument panel + z = cbh: d$ = "cbh": GoSub pconfig ' 3 constant black holes + z = demo: d$ = "skyf": GoSub pconfig ' 4 0 off 1 all features + z = doclock: d$ = "clock": GoSub pconfig ' 5 clock display on DS + z = invincible: d$ = "invincible": GoSub pconfig ' 6 invincible + z = jitter: d$ = "thrust": GoSub pconfig ' 7 thrust calculation + z = LEDc: d$ = "ledc": GoSub pconfig ' 8 LED color + z = LEDtri: d$ = "ledtri": GoSub pconfig ' 9 LED tri-color + z = radarf: d$ = "radar": GoSub pconfig ' 10 radar visible + z = shield: d$ = "shield": GoSub pconfig ' 11 Star Trek! + z = showmap: d$ = "map": GoSub pconfig ' 12 feature locations at screen top + z = starstatus: d$ = "stari": GoSub pconfig ' 13 0off 1names 2info 3info 4grid + z = zoom: d$ = "starz": GoSub pconfig ' 14 starfield + z = skyoff: d$ = "skys": GoSub pconfig ' 15 sky objects + z = gstyle: d$ = "gstyle": GoSub pconfig ' 16 ground type + z = mouseswap: d$ = "mouse": GoSub pconfig ' 17 mouse buttons + z = porb: d$ = "porb": GoSub pconfig ' 18 pointers or bars for instruments + z = starfiles: d$ = "stars": GoSub pconfig ' 19 star quantity + z = mdelay: d$ = "speed": GoSub pconfig ' 20 system speed + z = Sgn(_FullScreen): d$ = "fullscreen": GoSub pconfig ' 21 fullscreen + + Close + System + + pconfig: ' prints to the config file + Print #1, d$; ","; z + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub SaveImage (f$) ' this sub from qb64.org website (modified) + If iscd Then Exit Sub + View Screen(0, 0)-(q3, q4) + bpp& = 8 + tx& = 640 + ty& = 350 + ' XXXX 1XXXX + ' 12345678901234 + b$ = "BM????_RGF????" + MKL$(40) + MKL$(tx&) + MKL$(ty&) + MKI$(1) + MKI$(bpp&) + MKL$(0) + "????" + String$(16, 0) 'partial BMP header info(???? to be filled later) + For c& = 0 To 255 ' read BGR color settings from JPG image + 1 byte spacer(CHR$(0)) + cv& = _PaletteColor(c&, 0) ' color attribute to read + b$ = b$ + Chr$(_Blue32(cv&)) + Chr$(_Green32(cv&)) + Chr$(_Red32(cv&)) + Chr$(0) 'spacer byte + Next + Mid$(b$, 11, 4) = MKL$(Len(b$)) ' image pixel data offset (BMP header) + If ((x& * 3) Mod 4) Then padder$ = String$(4 - ((x& * 3) Mod 4), 0) + For py& = ty& - 1 To 0 Step -1 + z$ = "" + For px& = 0 To tx& - 1 + c& = Point(px&, py&) ' 2 bit values are large LONG values + z$ = z$ + Chr$(Abs(c&) Mod 256) + Next px& + d$ = d$ + z$ + padder$ + Next py& + Mid$(b$, 35, 4) = MKL$(Len(d$)) ' image size (BMP header) + b$ = b$ + d$ ' total file data bytes to create file + Mid$(b$, 3, 4) = MKL$(Len(b$)) ' size of data file (BMP header) + f& = FreeFile + Open f$ For Output As #f&: Close #f& ' erases an existing file + Open f$ For Binary As #f& + Put #f&, , b$ + Close #f& + View Screen(gs, 0)-(q3, q4) +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Setcolor + ' b g g r g g w g d g b o b y w + ' l r u e a y h y r o k r 2 e h + ' 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 + If bw Then ' + z$ = "070707075607070756070007565656" ' black and white (because I can!) + Else + z$ = "010249042456075632380052085407" ' color + 'z$ = "010249322456075632380052085407" ' color + End If + For i = 0 To 14 + Palette i + 1, Val(Mid$(z$, i * 2 + 1, 2)) + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Shells Static + For s = 0 To 20 ' 0 element is bomb, others from IBM + If shx(s) = 0 Then GoTo nextshell ' never active or already exploded + shvy(s) = shvy(s) + grav! ' gravity + shx(s) = shx(s) + shvx(s) + shy(s) = shy(s) + shvy(s) + tsx = shx(s) - suri + tsy = shy(s) + + If (s > 0) And (crash = 0) Then + dx! = tsx - px! + dy! = (tsy - py!) * aspect! + shd(s) = Sqr(dx! * dx! + dy! * dy!) + If (invincible = 0) And (shd(s) < 20) Then + dead$ = "HAL KILLED YOU" + Exit Sub + End If + End If + + If (tsy > 0) And (shvy(s) > 0) And ((tsy + shvy(s)) > gety(tsx)) Then + tsy = gety(tsx) + For a2 = 0 To tsix Step 30 ' explode, make star + bit = bit Xor 1 ' toggle + d2 = bit * t + t / 2 + x2 = tsx + d2 * c!(a2) * aspect! + y2 = tsy + d2 * s!(a2) + If a2 Then Line -(x2, y2), gold Else PSet (x2, y2), gold + Next a2 + Paint (tsx, tsy), gold, gold + shx(s) = 0 + sia = sia - 1 + If s = 0 Then GoSub makecrater + Else ' show shell + If shvx(s) < 0 Then ai = -30 Else ai = 30 ' spin + sha(s) = (sha(s) + ai + tsix) Mod tsix + ss = 3 + (s = 0) * 2 + For i = 0 To 1 + If i Then cc = red Else cc = gold + a1 = (sha(s) + i * 180) Mod tsix ' angle 1 + a2 = a1 + 150 ' angle 2 + ex = tsx + ss * c!(a1) * aspect! ' 1 of the endpoints + ey = tsy + ss * s!(a1) ' a line from an endpoint to + For j = a1 To a2 Step t ' each point on the half circle + zk = j Mod tsix ' seemed easier than a paint + zx = tsx + ss * c!(zk) * aspect! + zy = tsy + ss * s!(zk) + Line (zx, zy)-(ex, ey), cc + Next j + Next i + End If + nextshell: + Next s + Exit Sub + + makecrater: + dd = Abs(sf(sf, 2) - suri - tsx) ' distance to current surface feature + If dd < t Then sf(sf, 2) = -1 ' under ten from a surface feature, kill feature + + zz = 40 ' distance +- impact + r1 = Rnd * 40 + r2 = Rnd * 40 + 40 + For crx = -zz To zz + ta = (crx * 2 + 270) Mod tsix ' angle + tx = tsx + crx + ty = gety(tc) - r1 - r2 * s!(ta) + If ty > glmax Then ty = glmax + ti = ((suri + tx + q1) Mod q1) + gh(ti) = ty + If iscd = 0 Then Put #6, ti + 1, ty + Next crx + + ti = (suri + tsx - zz - 1 + q1) Mod q1 + Smooth ti + ti = (suri + tsx + zz) Mod q1 + Smooth ti + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub ShowAngle (a) + zc = dcolor(CSng(a), 0, 4, 1) + c = zc + If (bbit = 0) And (contact = 0) Then c = black ' blink + If a = 0 Then z$ = " " + If a > 0 Then z$ = Chr$(17) + " " ' point left + If a < 0 Then z$ = " " + Chr$(16) ' point right + PrintVGA z$, 7, 270, c, black2 + If LEDtri Then c = zc Else c = LEDc + osc = t + a$ = LTrim$(Str$(-a)) + LEDdisplay a$ +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Smooth (p1) ' ground transistions + p2 = p1 + 1 + zz = t + i1 = (p1 - zz + q1) Mod q1 + i2 = (p2 + zz + q1) Mod q1 + If msflag Then ' making surfaces, array not valid + Get #6, i1 + 1, y1 + Get #6, i2 + 1, y2 + Else + y1 = gh(i1) + y2 = gh(i2) + End If + m! = (y1 + y2) / 2 + d! = (y1 - y2) / zz / 2 + For x = 1 To zz + s! = d! * (zz - x) + i1 = (p2 + zz - x + q1) Mod q1 + i2 = (p1 - zz + x + q1) Mod q1 + gh(i1) = m! - s! + gh(i2) = m! + s! + If iscd = 0 Then + Put #6, i1 + 1, gh(i1) + Put #6, i2 + 1, gh(i2) + End If + Next x +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub sprint (z$, tx, ty, c1, c2) ' VGA font + For i = 1 To Len(z$) + d = Asc(Mid$(z$, i, 1)) + If d = 248 Then d = 0 ' degree symbol + x = tx + (i - 1) * 8 + For byte = 0 To 13 + y = ty + byte + p& = (p(d, byte) And 255) * 128 + If c2 >= 0 Then Line (x + 1, y)-(x + 8, y), c2, , p& + Line (x, y)-(x + 7, y), c1, , p& + Next byte + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub sprint2 (c$, tx, ty, c1, c2) ' CGA font + For i = 1 To Len(c$) + d = Asc(Mid$(c$, i, 1)) + If d = 248 Then d = 0 ' degree symbol + For k = 0 To 7 + tx2 = tx + (i - 1) * 8 + k + ty2 = ty + 2 + p& = p2(d, k) + If c2 >= 0 Then + Line (tx2 + 1, ty2 + 1)-(tx2 + 1, ty2 + 9), c2, , p& + End If + Line (tx2, ty2)-(tx2, ty2 + 8), c1, , p& + Next k + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Stars Static + + ' - starstatus 0 off, 1 on, 2+names, 3+RA & Dec & grid, 4+Mag + ' - encodes magnitude into xy array by making negative + ' - stars1 1797, stars2 16571, stars3 87470 + + If sinit = 0 Then + sinit = 1 + qq = 18000 + Dim starx(qq), stary(qq), starn(30), star$(2, 50) + starmax = qq: namemax = 100 + gc = blue ' grid color + sc = gray2 ' star info color + End If + + nh = 12 / (zoom + 1) ' hours (RA) + nd = 90 / (zoom + 1) ' degrees (Dec) + + If eou <> 0 Then ' End of Universe + alldown = 1 + For star = 1 To nstars + sy = stary(star) + ay = Abs(sy) + If ay < q4 Then ' less than screen bottom + stary(star) = stary(star) + Sgn(stary(star)) + alldown = 0 ' not done + End If + Next star + If alldown Then Cls: Exit Sub + End If + + If regen = 0 Then Cls + tss = starstatus + If starinit = 0 Then + starinit = 1 + eou = 0 ' End of Universe + alldown = 0 + nstars = 0 + named = 0 + rmax! = rmin + nh ' hours + dmax! = dmin + nd ' degrees + n1& = 0 + isred1 = 0: isred2 = 0 + rmin$ = Right$("00" + LTrim$(Str$(rmin)), 2) ' 0 - 24 + dmin$ = Right$("000" + LTrim$(Str$(dmin)), 3) ' -90 to 90 + zz$ = LTrim$(Str$(starfiles)) + rmin$ + dmin$ + ".DAT" + If (warp! >= 1) And (starfiles = 2) Then tfs = 1 Else tfs = starfiles + Select Case tfs + Case Is = 0 + th! = 5.07: tf$ = mpath$ + "STARS1.DAT": d$ = mpath$ + "STARS1" + slash$: nl& = 1797 + Case Is = 1 + th! = 7.07: tf$ = mpath$ + "STARS2.DAT": d$ = mpath$ + "STARS2" + slash$: nl& = 16571 + Case Is = 2 + th! = 8.07: tf$ = mpath$ + "STARS3.DAT": d$ = mpath$ + "STARS3" + slash$: nl& = 87470 + End Select + + tf1$ = d$ + "SI" + zz$ + tf2$ = d$ + "SX" + zz$ + tf3$ = d$ + "SY" + zz$ + isstari = _FileExists(tf1$) + _FileExists(tf2$) + _FileExists(tf3$) + If regen Then isstari = 0 + If isstari = -3 Then + GoSub readstar + GoTo plot + End If + regen = 0 + For i = 0 To qq + starx(i) = 0 + stary(i) = 0 + Next i + tf = FreeFile + Open tf$ For Input As #tf + Do + Input #tf, r!, d!, m!, dis$, n$ + n1& = n1& + 1 + If (starfiles > -1) And ((n1& Mod h) = 1) Then + zz1 = h + t ' hundred + 10 = 110 + zz2 = zz1 + n1& / nl& * 500 + Line (gs, 0)-(639, 40), black, BF + Line (zz1, t)-(zz1 + 500, 13), red, B + Line (zz1, t)-(zz2, 13), red, BF + PrintCGA "Loading stars...", 300, 14, red, black, 0 + PrintCGA tf1$, 110, 14, red, black, 0 + If mstar > 0 Then ' regenerating all starfiles, show progress + zz2 = zz1 + mstar / 1368 * 500 + Line (zz1, 27)-(zz1 + 500, 30), red, B + Line (zz1, 27)-(zz2, 30), red, BF + End If + timemachine + End If + + sa = (Left$(n$, 1) = "*") ' show always (low mag) + tt! = th! ' temp threshold + If Abs(d!) > 70 Then tt! = tt! + 2 + If Abs(d!) > 80 Then tt! = tt! + 2 + abd = Abs(d!): tt! = tt! - (abd > 70) - (abd > 80) + If sa Or (m! <= tt!) Then ' show always or bright + For z1 = 0 To 1 ' why why why? + For z2 = 0 To 1 + tr! = r! + z1 * 24 + td! = d! + z2 * 180 + If (tr! > rmin) And (tr! < rmax!) And (td! > dmin) And (td! < dmax!) Then sr = z1: sd = z2 + Next z2 + Next z1 + tx = q3 - (r! - rmin + sr * 24) / nh * q3 + ty = q4 - (d! - dmin + sd * 180) / nd * q4 + If (tx > 0) And (tx < q3) And (ty > 0) And (ty < q4) Then + If m! <= 3 Then tx = -tx + If m! <= 2 Then ty = -ty + nstars = nstars + 1 + starx(nstars) = tx + stary(nstars) = ty + If sa Then n$ = Right$(n$, Len(n$) - 1) ' show always, remove asterisk + If Len(n$) And (sa Or (m! < 2)) And (named < namemax) Then + named = named + 1 + starn(named) = nstars + star$(0, named) = n$ + If n$ = "Antares" Then isred1 = nstars + If n$ = "Mira" Then isred2 = nstars + star$(1, named) = LTrim$(Str$(m!)) + " " + dis$ ' + "P " + y$ + "L" + star$(2, named) = LTrim$(Str$(r!)) + " " + LTrim$(Str$(d!)) + End If + End If + End If + Loop Until EOF(tf) Or (nstars = starmax) + Close #tf + End If + + If isstari = 0 Then GoSub writestar + + plot: + Cls + 'IF okrick THEN + ' _PRINTSTRING (90, 30), tf1$ + STR$(zoom) + STR$(nh) + STR$(nd) + ' _PRINTSTRING (90, 50), STR$(rmax!) + STR$(dmax!) + 'END IF + tss = starstatus + If auto And (gstyle = 0) Then tss = 4 + + If tss > 2 Then ' optional grids + For i = 0 To nh ' vertical lines + tx = (i / nh * q3) Mod (q3 + 1) + Line (tx, 0)-(tx, q4), gc, , &H1111 + z = rmax! - i: z = z + (z > 23) * 24 ' optional labeling + TinyFont Str$(z), tx - 2, 0, -gc + Next i + z! = nd / t + For de! = 0 To z! ' horizontal lines + ty = q4 - ((de! / z! * q4) Mod (q4 + 1)) + Line (gs, ty)-(q3, ty), gc, , &H1111 + z = dmin + de! * t ' optional lableling + z = z + ((z > 90) - (z < -90)) * 180 + z$ = Str$(z) + TinyFont z$, q3 - Len(z$) * 4 - 2, ty + 2, -gc + Next de! + End If + + For star = 1 To nstars + stx = starx(star): ax = Abs(stx) + sty = stary(star): ay = Abs(sty) + + If warp! >= 1 Then + tx = ax + Sgn(-vx!) * warp! * 2 + If ay < glmax Then Line (ax, ay)-(tx, ay), gray2 + If tx < 1 Then tx = tx + (q3 + 1) + If tx > q3 Then tx = tx - (q3 + 1) + starx(star) = tx * Sgn(stx + .01) + Else + If zoom = 1 Then ax = (ax - 320) * 2: ay = (ay - 175) * 2 + If zoom = 2 Then ax = (ax - 433) * 3: ay = (ay - 233) * 3 + m = 3 + (stx < 0) + (sty < 0) ' magnitude + If m < 3 Then tc = white2 Else tc = gray2 ' slightly different brightness + If twinkle And (Rnd > .95) Then tc = black2 + If star = isred1 Then tc = red ' Mira and Antares + If star = isred2 Then tc = red + If m = 1 Then ' small cross if < 2 + Line (ax - 1, ay)-(ax + 1, ay), tc + Line (ax, ay - 1)-(ax, ay + 1), tc + Else ' bright or dim point + PSet (ax, ay), tc + End If + ' IF (star MOD 37) = 0 THEN TinyFont STR$(star), ax, ay, sc ' diagnostic + For i = 1 To named ' show names & info + If star = starn(i) Then + For j = 0 To tss - 2 + If j Then + ty = ay + j * 9 + (j = 2) * 3 + 1 + TinyFont star$(j, i), ax, ty, sc + Else + PrintCGA star$(j, i), ax, ay + j * 9, sc, -1, 1 + End If + Next j + End If + Next i + End If + Next star + If rick Then ' show counts + z$ = LTrim$(Str$(starfiles)) + Str$(nstars) + Str$(starmax) + Str$(named) + Str$(th!) + TinyFont z$, 86, 20, red + End If + Exit Sub + + readstar: + tf = FreeFile + Open tf1$ For Input As #tf + Input #tf, nstars, named, isred1, isred2 + n1 = nstars + For i = 1 To named + Input #tf, starn(i) + For j = 0 To 2 + Input #tf, star$(j, i) + Next j + Next i + Close #tf + Open tf2$ For Binary As #tf + Get #tf, , starx() + Close #tf + Open tf3$ For Binary As #tf + Get #tf, , stary() + Close #tf + Return + ' ----------------------------------------------------------------------------------- + writestar: + tf = FreeFile + Open tf1$ For Output As #tf + Print #tf, nstars; ","; named; ","; isred1; ","; isred2 + For i = 1 To named + Print #tf, starn(i); + For j = 0 To 2 + Print #tf, ","; star$(j, i); + Next j + Print #tf, Chr$(13); + Next i + Close #tf + + Open tf2$ For Binary As #tf + Put #tf, , starx() + Close #tf + + Open tf3$ For Binary As #tf + Put #tf, , stary() + Close #tf + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Surveyor Static + Dim SSp&(1, 26), x(1), y(1) + If sspinit1 = 0 Then + s& = VarSeg(SSp&(0, 0)) + o& = VarPtr(SSp&(0, 0)) + Def Seg = s& + BLoad f$(17), o& ' surv2.dat + sc = white + sspinit1 = 1 + End If + + x0 = x + ti = suri + x0 - 1 + If ti > q1 Then ti = ti - q1 + y0 = gh(ti) + + For i = 0 To 26 + tx = x0 + i + Line (tx, y0 - 21)-(tx, y0 - 5), sc, , SSp&(0, i) + Line (tx, y0 - 16)-(tx, y0 - 0), sc, , SSp&(1, i) + Next i + + ' modify ground to include Surveyor + If (x0 >= gs) And (x0 < 604) And (sspinit2 = 0) Then + For tx = x0 To x0 + 32 + For ty = y0 - 20 To glmax + If Point(tx, ty) = sc Then + z = (suri + tx) Mod q1 + gh(z) = ty + Exit For + End If + Next ty + Next tx + sspinit2 = 1 + End If + + For tx = x0 To x0 + 26 ' optional shadow + For ty = y0 - 21 To y0 + p = Point(tx, ty) + If p = sc Then + zx = tx - (x0 + 13) + zy = ty - (y0 - t) + If zy > (zx + 4) Then PSet (tx, ty), gray + End If + Next ty + Next tx + + attack = 0 + sdd = q1 + For i = 180 To 355 Step 5 ' rays + ra = i + Rnd * 5 + z = 25 + Rnd * t + For j = 0 To 1 + x(j) = (x + t) + z * c!(ra) * aspect! + y(j) = y0 + z * s!(ra) - 1 + z = z + Rnd * 30 + t + Next j + xs! = (x(1) - x(0)) / 20 + ys! = (y(1) - y(0)) / 20 + For j = 0 To 19 + tx = x(0) + j * xs! + ty = y(0) + j * ys! + x! = px! - tx + y! = (py! - ty) * aspect! + dd = Sqr(x! * x! + y! * y!) + If dd < sdd Then sdd = dd + If (shield = 0) Or (dd > 70) Or (j = 0) Then PSet (tx, ty), gunmetal + If shield And ((dd = 70) Or ((j = 0) And (dd < 70))) Then + Line (sx0 + xoff, sy0 + vy!)-(tx, ty), lmsl + If Rnd < .7 Then + PSet Step(0, 0), red + Else + Line (tx - 1, ty)-(tx + 1, ty), red + Line (tx, ty - 1)-(tx, ty + 1), red + End If + Exit For + End If + Next j + If sdd < 20 Then attack = 1 + Next i + If attack And (crash = 0) And (shield = 0) Then + oldr = rads + rads = rads + Rnd * t + 1 + If rads > 9999 Then rads = 9999 + If rads > oldr Then + rtl!(0) = Timer + 5 + rtlc(0) = rads + panelinit = 0 + End If + End If +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Tile Static ' Truchet tiling + If tinit = 0 Then + s = 7 + Dim t(1, s, s) + For i = 0 To 1 + For j = 0 To 1 + For k = 0 To 90 Step t + ta = k + j * 180 + tx = j * s + (s \ 2) * c!(ta) + ty = j * s + (s \ 2) * s!(ta) + If i Then ty = s - ty + t(i, tx, ty) = 1 + Next k + Next j + Next i + tinit = 1 + End If + + If gstyle = 4 Then tc = gray Else tc = black2 + For xo = gs To q3 Step s + For yo = glmax To (glmin - 50) Step -s + Select Case tilef ' static, change when moving, always changing + Case Is = 0 + bp = gety(xo) + yo + z1 = bp Mod 128 + z2 = (bp Mod 12) + 1 + td = p(z1, z2) + kk = Sgn(td And _SHL(1, (bp Mod 8))) + Case Is = 1 + bp = Sqr(xo * yo) + z1 = bp Mod 128 + z2 = (bp Mod 12) + 1 + td = p(z1, z2) + kk = Sgn(td And _SHL(1, (bp Mod 8))) + Case Is = 2 + kk = Rnd ' + End Select + For i = 0 To s + tx = xo + i + yy = gety(tx) + 1 + For j = 0 To s + ty = yo - j + If ty <= yy Then Exit For + If t(kk, i, j) Then + zz = tx + suri + c1 = (sf(5, 2) = -1) Or (zz < sf(5, 0)) Or (zz > sf(5, 1)) ' McD + c2 = (sf(7, 2) = -1) Or (zz < sf(7, 0)) Or (zz > sf(7, 1)) ' Surv + If c1 And c2 Then PSet (tx, ty), tc + End If + Next j + Next i + Next yo + Next xo +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub TMA Static + Dim tmaa!(10), tmab!(10), tmac(10) + If ok And (InStr(fb$, "on TMA") > 0) Then ' landed, do Mandelbrot instead of moire + Mandel + GoTo tmaother + End If + If zdc = 0 Then ' then initialize + nc = Rnd * 2 + 1 ' use 2-3 colors + lc = -1 ' last color, prevent repeats + For z = 0 To nc + tmaa!(z) = Rnd + 4 + tmab!(z) = (Rnd - pf!) / 8 + Do + c = Rnd * 14 + 1 + If c = gray2 Then c = gray ' stars use gray2 + If c = white2 Then c = white ' stars use white2 + If c <> lc Then lc = c: Exit Do + Loop + tmac(z) = c + Next z + End If + + zdc = (zdc + 1) Mod 50 + For z = 0 To 2 + tmaa!(z) = tmaa!(z) + tmab!(z) + Next z + y0 = glmax - 72 + y1 = y0 + 1 + y2 = glmax - 1 + Line (x, glmax)-(x + 46, glmax), gray + + For gx = x To x + 45 + x2! = gx / tmaa!(0) + x2! = x2! * x2! + For gy = y1 To y2 + y2! = gy / tmaa!(0) + y2! = y2! * y2! + tcc = Abs((x2! + y2!) / tmaa!(1)) Mod (nc + 1) + PSet (gx, gy), tmac(tcc) + Next gy + Next gx + + If Timer < cybilltime! Then CybillPix f$(16) Else gotpix = 0 + + tmaother: + If bolthitf Then Line (x, y0)-(x + 45, glmax), white, BF + + For s = 0 To 20 ' shells + If (shx(s) > 0) And (shd(s) < 80) Then + tarx = shx(s) - suri + tary = shy(s) + If (s > 0) Or (shy(s) > 200) Then + GoSub tmafl + ExplodeShell s ' show it exploded + End If + End If + Next s + + For i = 2 To 6 ' not DS! + If (ek(i) > 0) And (ek(i) < 30) Then + tarx = exl(i) ' where to shoot + tary = ey(i) + GoSub tmafl ' fire laser + ek(i) = 0 + ex(i) = 0 ' mark destroyed + exv(i) = 0 + End If + Next i + Exit Sub + + tmafl: ' fire laser + For gx = x To x + 45 Step 2 ' along top of TMA1 + Line (gx, y1 - 1)-(tarx, tary), blue ' nice blue + Next gx + If gotpix = 0 Then ' not showing Cybill + cybilltime! = Timer + 2 ' keep on screen for 2 sec + gotpix = 1 ' flag onscreen + End If + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub TinyFont (d$, tx, ty, tc) Static ' 3*5 font for countdown, clock, Borg + If fontinit = 0 Then ' initialize + Dim sp(13, 4) + Restore tinyfontd + For n = 0 To 13 + Read g$ + For i = 0 To 4 + Read z + sp(n, i) = z * 4096 + Next i + Next n + fontinit = 1 + End If + + For z = 1 To Len(d$) + z$ = Mid$(d$, z, 1) + zz = InStr(".-: ", z$) + If zz Then d = zz + 9 Else d = Val(z$) + If (tc = 1) And (Rnd > .9) Then ttc = 3 Else ttc = tc ' Borg effect (some bright) + For i = 0 To 4 + x2 = tx + z * 4 + j - 4 + Line (x2, ty + i)-(x2 + 4, ty + i), Abs(ttc), , sp(d, i) + Next i + Next z +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub timemachine ' xlate to 32 bit color for green screen, warp effects + Dim oc&(15) + For i = 0 To 15 + Out &H3C7, i + tred = Inp(&H3C9) * 4: tgrn = Inp(&H3C9) * 4: tblu = Inp(&H3C9) * 4 + coav = (tred + tgrn + tblu) \ 3 ' color average + If cpal = 0 Then + oc&(i) = _RGB32(tred, tgrn, tblu) ' regular color + ElseIf cpal = 1 Then + oc&(i) = _RGB32(0, coav, 0) ' shades of green + ElseIf cpal = 2 Then + oc&(i) = _RGB32(coav, coav \ 2, 0) ' shades of orange + Else + oc&(i) = _RGB32(coav, coav, coav) ' black and white + End If + Next i + + Dim m As _MEM + m = _MemImage(canvas&) ' canvas& = _NewImage(640, 350, 9) + Do: _Limit q4 ' 349 (h/100 too little, slows down program!) + tempimage& = _NewImage(640, 350, 32) + Loop Until tempimage& < -1 ' try until valid (can fail to make screen) + Screen tempimage& + For y = 0 To q4 ' replot each pixel of old to new screen + For x = 0 To q3 + a& = y * 640 + x + dd = _MemGet(m, m.OFFSET + a&, _Unsigned _Byte) + PSet (x, y), oc&(dd) + Next x + Next y + + If (Len(dead$) = 0) And (warp! >= 1) Then + View Screen(gs, Sgn(Len(mes$(0))) * 20)-(q3, q4) ' protect instrument panel, top line if message active + If warp! >= 9 Then contour Else warpx + View Screen(gs, 0)-(q3, q4) ' back to normal, only instrument panel protected + End If + + If (rdtime! > 0) And (Timer < rdtime!) And _FileExists(mpath$ + "rick.jpg") Then + i& = _LoadImage(mpath$ + "rick.jpg") ' 87 * 93 pix of author + If i& < -1 Then + tx = _Width - 87 + _PutImage (tx, 0)-(tx + 87, 93), i&, 0 + _FreeImage i& + _PrintString (tx + 24, 100), "What?" + End If + End If + + If starship And _FileExists(mpath$ + "starship.jpg") Then + If shipi& = 0 Then shipi& = _LoadImage(mpath$ + "starship.jpg") ' 296 * 91 + shipx = shipx + 4 + ty1 = py! - 50: ty2 = ty1 + 91 + shipo = shipx - 100 + q = 2 + gs = 0 + If shipi& < -1 Then _PutImage (shipo, ty1 \ q)-(shipo + 296 \ q, ty2 \ q), shipi&, 0 + If shipx > 750 Then shipx = 0: starship = 0 + End If + + _Display ' show new image + Screen canvas& ' back to old mode so the rest of the program can run + _MemFree m ' would run out of memory otherwise + _FreeImage tempimage& + +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub UFO (tx0, ty0, txi) Static ' so pathetic a graphic that it's funny, maybe + aa = (aa + 5) Mod tsix + tx = tx0 + t * Cos(_D2R(aa)) + ty = ty0 + t * Sin(_D2R(aa)) + For i = 0 To 55 + Circle (tx, ty), i, gunmetal, , , .15 + Next i + For i = 8 To 15 + If i Mod 2 Then tc = orange Else tc = black2 + Circle (tx, ty - 12), i, tc, , , .35 + Next i + tc = Val(Mid$("020414", (ty Mod 3) * 2 + 1, 2)) + p = (p + 1) Mod 5 + If txi < 0 Then tp = 4 - p Else tp = p + For z = -2 To 2 + tx2 = tx + z * 16 + Circle (tx2, ty), 5 - Abs(z), black2, , , .7 + If tp = (z + 2) Then tc2 = tc Else tc2 = black2 + Paint (tx2, ty), tc2, black2 + Circle (tx2, ty), 5 - Abs(z), tc2, , , .7 + Next z + Line (tx - 30, ty + 8)-(tx - 35, ty + 20), orange ' legs + Line (tx - 37, ty + 20)-(tx - 31, ty + 20), orange + Line (tx + 30, ty + 8)-(tx + 35, ty + 20), orange ' pads + Line (tx + 32, ty + 20)-(tx + 38, ty + 20), orange +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Volcano Static + + If vinit = 0 Then + q = q3 * 2 ' 640*2=1280 + Dim vox!(q), voy!(q), vxi!(q), vyi!(q) + vinit = 1 + End If + + vx = sf(4, 2) + If Abs((Timer Mod t) - (Rnd * t)) > 5 Then + For i = 0 To q + If vyi!(i) < -3 Then k! = .6 Else k! = .8 ' kill some + If (vox!(i) = 0) Or (Rnd > k!) Then ' dead or kill + vox!(i) = vx + Rnd * t - 5 ' initial x + voy!(i) = gety(Int(vox!(i) - suri)) - 1 ' initial y + ta = Rnd * 40 + 70 ' angle + r! = _D2R(ta) + vxi!(i) = (Rnd * t + 1) * Cos(r!) ' x velocity + vyi!(i) = (Rnd * t + 2) * Sin(r!) ' y velocity + End If + Next i + End If + + For i = 0 To q + tx = vox!(i) - suri ' local x + ty = voy!(i) ' local y + If shield Then z = 0: GoSub protect + If ty > q4 Then ' off screen + vox!(i) = 0 ' flag for init + Else + If (tx >= gs) And (tx <= q3) Then + If vyi!(i) < -(Rnd * 4) Then + c = gunmetal + If (ty > gety(tx)) And (gstyle = 0) Then c = black ' black on white + Else + c = orange + End If + PSet (tx, ty), c + If i Mod 2 Then Line -Step(Rnd * 2 - 1, Rnd * 2 - 1), c + End If + End If + vyi!(i) = vyi!(i) - .25 ' decelerate + vox!(i) = vox!(i) - vxi!(i) ' new x + voy!(i) = voy!(i) - vyi!(i) ' new y + Next i + Exit Sub + + protect: + dx! = px! - tx ' distance x + dy! = (py! - ty) * aspect! ' distance y + dd = Sqr(dx! * dx! + dy! * dy!) ' distance + If dd < 70 Then ' at shield + z = 1 + vyi!(i) = 0 + ty = ty - Sgn(dy!) + GoTo protect + End If + If z Then ' laser + vxi!(i) = Sgn(dx!) * (5 + Rnd * 5) + Line (sx0 + xoff, sy0 + vy!)-(tx, ty), lmsl + End If + Return +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub warpx Static + wa1 = (wa1 + 5) Mod tsix + wa2 = wa1 + wx! = 320 + 70 * s!(wa1) + wy! = 175 + 70 * c!(wa1) + wc1 = 200 + For wd1 = 64 To 600 Step 8 + wa2 = wa2 + 2 + wc1 = (wc1 + 27) Mod 512 + wc2 = Abs(wc1 - 256) + wc& = _RGB32(wc2, 1, 1) + wd2 = 20 * s!((Abs(wa1 - 256) * 5) Mod tsix) + wd3 = wd1 + wd2 + For z = 0 To 4 + wde = (wa2 + 90 * z) Mod tsix + wtx = wx! + wd3 * s!(wde) + wty = wy! + wd3 * c!(wde) + If z = 0 Then PSet (wtx, wty), wc& Else Line -(wtx, wty), wc& + Next z + Next wd1 +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub Wave Static ' funny effect for warp speeds + tdg = (tdg Mod 4) + 1 + For i = 1 To 22 + ' 1234567890123456789012 + ' TTTTHHHHHVVVVVAAAAFFFF + osc = Val(Mid$("1111222223333344445555", i, 1)) + wll = Val(Mid$("45555", osc, 1)) + adg = (tdg + wll) Mod 4 + 1 - (wll = 4) + z$ = Mid$("agdgagdg", adg, wll) + LEDdisplay z$ + Next i +End Sub +' -------------------------------------------------------------------------------------------------------x +Sub WormHole Static + If eou Then Exit Sub ' end of universe + + If ei(4) = 0 Then + nc: + c1 = Rnd * 14 + 1 + c2 = Rnd * 14 + 1 + If c1 = c2 Then GoTo nc + If (c1 = black2) Or (c1 = gray) Then GoTo nc + If (c2 = black2) Or (c2 = gray) Then GoTo nc + ei(4) = 1 + End If + + tx = localize(ex(4), 0, 0) + wy = ey(4) + ba = (ba + 30) Mod tsix + For ta = 0 To 720 Step 2 + For d = 0 To 3 + baa = (ta + ba + d * 90) Mod tsix + tx1 = tx + ta / 8 * c!(baa) + ty1 = wy + ta / 40 * s!(baa) + If d Mod 2 Then c = c1 Else c = c2 + PSet (tx1, ty1), c + Next d + Next ta +End Sub + diff --git a/samples/moon-lander/src/l64.zip b/samples/moon-lander/src/l64.zip new file mode 100644 index 00000000..66efdcf8 Binary files /dev/null and b/samples/moon-lander/src/l64.zip differ diff --git a/samples/multi-mill/index.md b/samples/multi-mill/index.md index c65ca7d2..81499c5b 100644 --- a/samples/multi-mill/index.md +++ b/samples/multi-mill/index.md @@ -1,12 +1,12 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: MULTI-MILL ![screenshot.png](img/screenshot.png) ### Author -[🐝 Rho Sigma](../rho-sigma.md) +[🐝 RhoSigma](../rhosigma.md) ### Description diff --git a/samples/music.md b/samples/music.md new file mode 100644 index 00000000..71e10aa7 --- /dev/null +++ b/samples/music.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: MUSIC + +**[QSynth](qsynth/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [sound](sound.md), [music](music.md) + +Audio synthesizer by Microsoft. diff --git a/samples/mystify/index.md b/samples/mystify/index.md index acbf4701..8a2a902b 100644 --- a/samples/mystify/index.md +++ b/samples/mystify/index.md @@ -1,12 +1,12 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: MYSTIFY ![screenshot.png](img/screenshot.png) ### Author -[🐝 Rho Sigma](../rho-sigma.md) +[🐝 RhoSigma](../rhosigma.md) ### Description diff --git a/samples/nibbles/img/screenshot.png b/samples/nibbles/img/screenshot.png new file mode 100644 index 00000000..db207228 Binary files /dev/null and b/samples/nibbles/img/screenshot.png differ diff --git a/samples/nibbles/index.md b/samples/nibbles/index.md new file mode 100644 index 00000000..377b0d84 --- /dev/null +++ b/samples/nibbles/index.md @@ -0,0 +1,21 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: NIBBLES + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Snake clone by Microsoft. +``` + +### File(s) + +* [nibbles.bas](src/nibbles.bas) + +🔗 [game](../game.md), [snake](../snake.md) diff --git a/samples/nibbles/src/nibbles.bas b/samples/nibbles/src/nibbles.bas new file mode 100644 index 00000000..bbdaaad0 --- /dev/null +++ b/samples/nibbles/src/nibbles.bas @@ -0,0 +1,717 @@ +' Q B a s i c N i b b l e s +' +' Copyright (C) Microsoft Corporation 1990 +' +' Nibbles is a game for one or two players. Navigate your snakes +' around the game board trying to eat up numbers while avoiding +' running into walls or other snakes. The more numbers you eat up, +' the more points you gain and the longer your snake becomes. +' +' To run this game, press Shift+F5. +' +' To exit QBasic, press Alt, F, X. +' +' To get help on a BASIC keyword, move the cursor to the keyword and press +' F1 or click the right mouse button. +' + +'Set default data type to integer for faster game play +DefInt A-Z + +'User-defined TYPEs +Type snakeBody + row As Integer + col As Integer +End Type + +'This type defines the player's snake +Type snaketype + head As Integer + length As Integer + row As Integer + col As Integer + direction As Integer + lives As Integer + score As Integer + scolor As Integer + alive As Integer +End Type + +'This type is used to represent the playing screen in memory +'It is used to simulate graphics in text mode, and has some interesting, +'and slightly advanced methods to increasing the speed of operation. +'Instead of the normal 80x25 text graphics using chr$(219) "", we will be +'using chr$(220)"" and chr$(223) "" and chr$(219) "" to mimic an 80x50 +'pixel screen. +'Check out sub-programs SET and POINTISTHERE to see how this is implemented +'feel free to copy these (as well as arenaType and the DIM ARENA stmt and the +'initialization code in the DrawScreen subprogram) and use them in your own +'programs +Type arenaType + realRow As Integer 'Maps the 80x50 point into the real 80x25 + acolor As Integer 'Stores the current color of the point + sister As Integer 'Each char has 2 points in it. .SISTER is +End Type '-1 if sister point is above, +1 if below + +'Sub Declarations +DECLARE SUB SpacePause (text$) +DECLARE SUB PrintScore (NumPlayers%, score1%, score2%, lives1%, lives2%) +DECLARE SUB Intro () +DECLARE SUB GetInputs (NumPlayers, speed, diff$, monitor$) +DECLARE SUB DrawScreen () +DECLARE SUB PlayNibbles (NumPlayers, speed, diff$) +DECLARE SUB Set (row, col, acolor) +DECLARE SUB Center (row, text$) +DECLARE SUB Initialize () +DECLARE SUB SparklePause () +DECLARE SUB Level (WhatToDO, sammy() AS snaketype) +DECLARE SUB InitColors () +DECLARE SUB EraseSnake (snake() AS ANY, snakeBod() AS ANY, snakeNum%) +DECLARE FUNCTION StillWantsToPlay () +DECLARE FUNCTION PointIsThere (row, col, backColor) + +'Constants +Const TRUE = -1 +Const FALSE = Not TRUE +Const MAXSNAKELENGTH = 1000 +Const STARTOVER = 1 ' Parameters to 'Level' SUB +Const SAMELEVEL = 2 +Const NEXTLEVEL = 3 + +'Global Variables +Dim Shared arena(1 To 50, 1 To 80) As arenaType +Dim Shared curLevel, colorTable(10) + +Randomize Timer +GoSub ClearKeyLocks +Intro +GetInputs NumPlayers, speed, diff$, monitor$ +GoSub SetColors +DrawScreen + +Do + PlayNibbles NumPlayers, speed, diff$ +Loop While StillWantsToPlay + +GoSub RestoreKeyLocks +Color 15, 0 +Cls +End + +ClearKeyLocks: +Def Seg = 0 ' Turn off CapLock, NumLock and ScrollLock +KeyFlags = Peek(1047) +Poke 1047, &H0 +Def Seg +Return + +RestoreKeyLocks: +Def Seg = 0 ' Restore CapLock, NumLock and ScrollLock states +Poke 1047, KeyFlags +Def Seg +Return + +SetColors: +If monitor$ = "M" Then + Restore mono +Else + Restore normal +End If + +For a = 1 To 6 + Read colorTable(a) +Next a +Return + +'snake1 snake2 Walls Background Dialogs-Fore Back +mono: Data 15,7,7,0,15,0 +normal: Data 14,13,12,1,15,4 +End + +'Center: +' Centers text on given row +Sub Center (row, text$) + Locate row, 41 - Len(text$) / 2 + Print text$; +End Sub + +'DrawScreen: +' Draws playing field +Sub DrawScreen + + 'initialize screen + View Print + Color colorTable(1), colorTable(4) + Cls + + 'Print title & message + Center 1, "Nibbles!" + Center 11, "Initializing Playing Field..." + + 'Initialize arena array + For row = 1 To 50 + For col = 1 To 80 + arena(row, col).realRow = Int((row + 1) / 2) + arena(row, col).sister = (row Mod 2) * 2 - 1 + Next col + Next row +End Sub + +'EraseSnake: +' Erases snake to facilitate moving through playing field +Sub EraseSnake (snake() As snaketype, snakeBod() As snakeBody, snakeNum) + + For c = 0 To 9 + For b = snake(snakeNum).length - c To 0 Step -10 + tail = (snake(snakeNum).head + MAXSNAKELENGTH - b) Mod MAXSNAKELENGTH + Set snakeBod(tail, snakeNum).row, snakeBod(tail, snakeNum).col, colorTable(4) + Next b + _Delay .03 + Next c + +End Sub + +'GetInputs: +' Gets player inputs +Sub GetInputs (NumPlayers, speed, diff$, monitor$) + + Color 7, 0 + Cls + + Do + Locate 5, 47: Print Space$(34); + Locate 5, 20 + Input "How many players (1 or 2)"; num$ + Loop Until Val(num$) = 1 Or Val(num$) = 2 + NumPlayers = Val(num$) + + Locate 8, 21: Print "Skill level (1 to 100)" + Locate 9, 22: Print "1 = Novice" + Locate 10, 22: Print "90 = Expert" + Locate 11, 22: Print "100 = Twiddle Fingers" + Locate 12, 15: Print "(Computer speed may affect your skill level)" + Do + Locate 8, 44: Print Space$(35); + Locate 8, 43 + Input gamespeed$ + Loop Until Val(gamespeed$) >= 1 And Val(gamespeed$) <= 100 + speed = Val(gamespeed$) + + speed = (100 - speed) * 2 + 1 + + Do + Locate 15, 56: Print Space$(25); + Locate 15, 15 + Input "Increase game speed during play (Y or N)"; diff$ + diff$ = UCase$(diff$) + Loop Until diff$ = "Y" Or diff$ = "N" + + Do + Locate 17, 46: Print Space$(34); + Locate 17, 17 + Input "Monochrome or color monitor (M or C)"; monitor$ + monitor$ = UCase$(monitor$) + Loop Until monitor$ = "M" Or monitor$ = "C" + +End Sub + +'InitColors: +'Initializes playing field colors +Sub InitColors + + For row = 1 To 50 + For col = 1 To 80 + arena(row, col).acolor = colorTable(4) + Next col + Next row + + Cls + + 'Set (turn on) pixels for screen border + For col = 1 To 80 + Set 3, col, colorTable(3) + Set 50, col, colorTable(3) + Next col + + For row = 4 To 49 + Set row, 1, colorTable(3) + Set row, 80, colorTable(3) + Next row + +End Sub + +'Intro: +' Displays game introduction +Sub Intro + Screen 0 + Width 80, 25 + Color 15, 0 + Cls + + Center 4, "Q B a s i c N i b b l e s" + Color 7 + Center 6, "Copyright (C) Microsoft Corporation 1990" + Center 8, "Nibbles is a game for one or two players. Navigate your snakes" + Center 9, "around the game board trying to eat up numbers while avoiding" + Center 10, "running into walls or other snakes. The more numbers you eat up," + Center 11, "the more points you gain and the longer your snake becomes." + Center 13, " Game Controls " + Center 15, " General Player 1 Player 2 " + Center 16, " (Up) (Up) " + Center 17, "P - Pause " + Chr$(24) + " W " + Center 18, " (Left) " + Chr$(27) + " " + Chr$(26) + " (Right) (Left) A D (Right) " + Center 19, " " + Chr$(25) + " S " + Center 20, " (Down) (Down) " + Center 24, "Press any key to continue" + + Play "MBT160O1L8CDEDCDL4ECC" + SparklePause + +End Sub + +'Level: +'Sets game level +Sub Level (WhatToDO, sammy() As snaketype) Static + + Select Case (WhatToDO) + + Case STARTOVER + curLevel = 1 + Case NEXTLEVEL + curLevel = curLevel + 1 + End Select + + sammy(1).head = 1 'Initialize Snakes + sammy(1).length = 2 + sammy(1).alive = TRUE + sammy(2).head = 1 + sammy(2).length = 2 + sammy(2).alive = TRUE + + InitColors + + Select Case curLevel + Case 1 + sammy(1).row = 25: sammy(2).row = 25 + sammy(1).col = 50: sammy(2).col = 30 + sammy(1).direction = 4: sammy(2).direction = 3 + + + Case 2 + For i = 20 To 60 + Set 25, i, colorTable(3) + Next i + sammy(1).row = 7: sammy(2).row = 43 + sammy(1).col = 60: sammy(2).col = 20 + sammy(1).direction = 3: sammy(2).direction = 4 + + Case 3 + For i = 10 To 40 + Set i, 20, colorTable(3) + Set i, 60, colorTable(3) + Next i + sammy(1).row = 25: sammy(2).row = 25 + sammy(1).col = 50: sammy(2).col = 30 + sammy(1).direction = 1: sammy(2).direction = 2 + + Case 4 + For i = 4 To 30 + Set i, 20, colorTable(3) + Set 53 - i, 60, colorTable(3) + Next i + For i = 2 To 40 + Set 38, i, colorTable(3) + Set 15, 81 - i, colorTable(3) + Next i + sammy(1).row = 7: sammy(2).row = 43 + sammy(1).col = 60: sammy(2).col = 20 + sammy(1).direction = 3: sammy(2).direction = 4 + + Case 5 + For i = 13 To 39 + Set i, 21, colorTable(3) + Set i, 59, colorTable(3) + Next i + For i = 23 To 57 + Set 11, i, colorTable(3) + Set 41, i, colorTable(3) + Next i + sammy(1).row = 25: sammy(2).row = 25 + sammy(1).col = 50: sammy(2).col = 30 + sammy(1).direction = 1: sammy(2).direction = 2 + + Case 6 + For i = 4 To 49 + If i > 30 Or i < 23 Then + Set i, 10, colorTable(3) + Set i, 20, colorTable(3) + Set i, 30, colorTable(3) + Set i, 40, colorTable(3) + Set i, 50, colorTable(3) + Set i, 60, colorTable(3) + Set i, 70, colorTable(3) + End If + Next i + sammy(1).row = 7: sammy(2).row = 43 + sammy(1).col = 65: sammy(2).col = 15 + sammy(1).direction = 2: sammy(2).direction = 1 + + Case 7 + For i = 4 To 49 Step 2 + Set i, 40, colorTable(3) + Next i + sammy(1).row = 7: sammy(2).row = 43 + sammy(1).col = 65: sammy(2).col = 15 + sammy(1).direction = 2: sammy(2).direction = 1 + + Case 8 + For i = 4 To 40 + Set i, 10, colorTable(3) + Set 53 - i, 20, colorTable(3) + Set i, 30, colorTable(3) + Set 53 - i, 40, colorTable(3) + Set i, 50, colorTable(3) + Set 53 - i, 60, colorTable(3) + Set i, 70, colorTable(3) + Next i + sammy(1).row = 7: sammy(2).row = 43 + sammy(1).col = 65: sammy(2).col = 15 + sammy(1).direction = 2: sammy(2).direction = 1 + + Case 9 + For i = 6 To 47 + Set i, i, colorTable(3) + Set i, i + 28, colorTable(3) + Next i + sammy(1).row = 40: sammy(2).row = 15 + sammy(1).col = 75: sammy(2).col = 5 + sammy(1).direction = 1: sammy(2).direction = 2 + + Case Else + For i = 4 To 49 Step 2 + Set i, 10, colorTable(3) + Set i + 1, 20, colorTable(3) + Set i, 30, colorTable(3) + Set i + 1, 40, colorTable(3) + Set i, 50, colorTable(3) + Set i + 1, 60, colorTable(3) + Set i, 70, colorTable(3) + Next i + sammy(1).row = 7: sammy(2).row = 43 + sammy(1).col = 65: sammy(2).col = 15 + sammy(1).direction = 2: sammy(2).direction = 1 + + End Select +End Sub + +'PlayNibbles: +' Main routine that controls game play +Sub PlayNibbles (NumPlayers, speed, diff$) + + 'Initialize Snakes + Dim sammyBody(MAXSNAKELENGTH - 1, 1 To 2) As snakeBody + Dim sammy(1 To 2) As snaketype + sammy(1).lives = 5 + sammy(1).score = 0 + sammy(1).scolor = colorTable(1) + sammy(2).lives = 5 + sammy(2).score = 0 + sammy(2).scolor = colorTable(2) + + Level STARTOVER, sammy() + startRow1 = sammy(1).row: startCol1 = sammy(1).col + startRow2 = sammy(2).row: startCol2 = sammy(2).col + + curSpeed = speed + + 'play Nibbles until finished + + SpacePause " Level" + Str$(curLevel) + ", Push Space" + gameOver = FALSE + Do + If NumPlayers = 1 Then + sammy(2).row = 0 + End If + + number = 1 'Current number that snakes are trying to run into + nonum = TRUE 'nonum = TRUE if a number is not on the screen + + playerDied = FALSE + PrintScore NumPlayers, sammy(1).score, sammy(2).score, sammy(1).lives, sammy(2).lives + Play "T160O1>L20CDEDCDL10ECC" + + Do + 'Print number if no number exists + If nonum = TRUE Then + Do + numberRow = Int(Rnd(1) * 47 + 3) + NumberCol = Int(Rnd(1) * 78 + 2) + sisterRow = numberRow + arena(numberRow, NumberCol).sister + Loop Until Not PointIsThere(numberRow, NumberCol, colorTable(4)) And Not PointIsThere(sisterRow, NumberCol, colorTable(4)) + numberRow = arena(numberRow, NumberCol).realRow + nonum = FALSE + Color colorTable(1), colorTable(4) + Locate numberRow, NumberCol + Print Right$(Str$(number), 1); + count = 0 + End If + + 'Delay game + _Delay .016 + .00042 * curSpeed + + 'Get keyboard input & Change direction accordingly + kbd$ = InKey$ + Select Case kbd$ + Case "w", "W": If sammy(2).direction <> 2 Then sammy(2).direction = 1 + Case "s", "S": If sammy(2).direction <> 1 Then sammy(2).direction = 2 + Case "a", "A": If sammy(2).direction <> 4 Then sammy(2).direction = 3 + Case "d", "D": If sammy(2).direction <> 3 Then sammy(2).direction = 4 + Case Chr$(0) + "H": If sammy(1).direction <> 2 Then sammy(1).direction = 1 + Case Chr$(0) + "P": If sammy(1).direction <> 1 Then sammy(1).direction = 2 + Case Chr$(0) + "K": If sammy(1).direction <> 4 Then sammy(1).direction = 3 + Case Chr$(0) + "M": If sammy(1).direction <> 3 Then sammy(1).direction = 4 + Case "p", "P": SpacePause " Game Paused ... Push Space " + Case Else + End Select + + For a = 1 To NumPlayers + 'Move Snake + Select Case sammy(a).direction + Case 1: sammy(a).row = sammy(a).row - 1 + Case 2: sammy(a).row = sammy(a).row + 1 + Case 3: sammy(a).col = sammy(a).col - 1 + Case 4: sammy(a).col = sammy(a).col + 1 + End Select + + 'If snake hits number, respond accordingly + If numberRow = Int((sammy(a).row + 1) / 2) And NumberCol = sammy(a).col Then + Play "MBO0L16>CCCE" + If sammy(a).length < (MAXSNAKELENGTH - 30) Then + sammy(a).length = sammy(a).length + number * 4 + End If + sammy(a).score = sammy(a).score + number + PrintScore NumPlayers, sammy(1).score, sammy(2).score, sammy(1).lives, sammy(2).lives + number = number + 1 + If number = 10 Then + For b = 1 To NumPlayers + EraseSnake sammy(), sammyBody(), b + Next b + Locate numberRow, NumberCol: Print " " + Level NEXTLEVEL, sammy() + PrintScore NumPlayers, sammy(1).score, sammy(2).score, sammy(1).lives, sammy(2).lives + SpacePause " Level" + Str$(curLevel) + ", Push Space" + If NumPlayers = 1 Then sammy(2).row = 0 + number = 1 + If diff$ = "Y" Then curSpeed = curSpeed - 10 + End If + nonum = TRUE + If curSpeed < 1 Then curSpeed = 1 + End If + Next a + + For a = 1 To NumPlayers + 'If player runs into any point, or the head of the other snake, it dies. + If PointIsThere(sammy(a).row, sammy(a).col, colorTable(4)) Or (sammy(1).row = sammy(2).row And sammy(1).col = sammy(2).col) Then + Play "MBO0L32EFGEFDC" + Color , colorTable(4) + Locate numberRow, NumberCol + Print " " + + playerDied = TRUE + sammy(a).alive = FALSE + sammy(a).lives = sammy(a).lives - 1 + + 'Otherwise, move the snake, and erase the tail + Else + sammy(a).head = (sammy(a).head + 1) Mod MAXSNAKELENGTH + sammyBody(sammy(a).head, a).row = sammy(a).row + sammyBody(sammy(a).head, a).col = sammy(a).col + tail = (sammy(a).head + MAXSNAKELENGTH - sammy(a).length) Mod MAXSNAKELENGTH + Set sammyBody(tail, a).row, sammyBody(tail, a).col, colorTable(4) + sammyBody(tail, a).row = 0 + Set sammy(a).row, sammy(a).col, sammy(a).scolor + End If + Next a + + Loop Until playerDied + + curSpeed = speed ' reset speed to initial value + + For a = 1 To NumPlayers + EraseSnake sammy(), sammyBody(), a + + 'If dead, then erase snake in really cool way + If sammy(a).alive = FALSE Then + 'Update score + sammy(a).score = sammy(a).score - 10 + PrintScore NumPlayers, sammy(1).score, sammy(2).score, sammy(1).lives, sammy(2).lives + + If a = 1 Then + SpacePause " Sammy Dies! Push Space! --->" + Else + SpacePause " <---- Jake Dies! Push Space " + End If + End If + Next a + + Level SAMELEVEL, sammy() + PrintScore NumPlayers, sammy(1).score, sammy(2).score, sammy(1).lives, sammy(2).lives + + 'Play next round, until either of snake's lives have run out. + Loop Until sammy(1).lives = 0 Or sammy(2).lives = 0 + +End Sub + +'PointIsThere: +' Checks the global arena array to see if the boolean flag is set +Function PointIsThere (row, col, acolor) + If row <> 0 Then + If arena(row, col).acolor <> acolor Then + PointIsThere = TRUE + Else + PointIsThere = FALSE + End If + End If +End Function + +'PrintScore: +' Prints players scores and number of lives remaining +Sub PrintScore (NumPlayers, score1, score2, lives1, lives2) + Color 15, colorTable(4) + + If NumPlayers = 2 Then + Locate 1, 1 + Print Using "#,###,#00 Lives: # <--JAKE"; score2; lives2 + End If + + Locate 1, 49 + Print Using "SAMMY--> Lives: # #,###,#00"; lives1; score1 +End Sub + +'Set: +' Sets row and column on playing field to given color to facilitate moving +' of snakes around the field. +Sub Set (row, col, acolor) + If row <> 0 Then + arena(row, col).acolor = acolor 'assign color to arena + realRow = arena(row, col).realRow 'Get real row of pixel + topFlag = arena(row, col).sister + 1 / 2 'Deduce whether pixel + 'is on top, or bottom + sisterRow = row + arena(row, col).sister 'Get arena row of sister + sisterColor = arena(sisterRow, col).acolor 'Determine sister's color + + Locate realRow, col + + If acolor = sisterColor Then 'If both points are same + Color acolor, acolor 'Print chr$(219) "" + Print Chr$(219); + Else + If topFlag Then 'Since you cannot have + If acolor > 7 Then 'bright backgrounds + Color acolor, sisterColor 'determine best combo + Print Chr$(223); 'to use. + Else + Color sisterColor, acolor + Print Chr$(220); + End If + Else + If acolor > 7 Then + Color acolor, sisterColor + Print Chr$(220); + Else + Color sisterColor, acolor + Print Chr$(223); + End If + End If + End If + End If +End Sub + +'SpacePause: +' Pauses game play and waits for space bar to be pressed before continuing +Sub SpacePause (text$) + + Color colorTable(5), colorTable(6) + Center 11, "" + Center 12, " " + Left$(text$ + Space$(29), 29) + " " + Center 13, "" + While InKey$ <> "": Wend + While InKey$ <> " ": Wend + Color 15, colorTable(4) + + For i = 21 To 26 ' Restore the screen background + For j = 24 To 56 + Set i, j, arena(i, j).acolor + Next j + Next i + +End Sub + +'SparklePause: +' Creates flashing border for intro screen +Sub SparklePause + + Color 4, 0 + a$ = "* * * * * * * * * * * * * * * * * " + While InKey$ <> "": Wend 'Clear keyboard buffer + + While InKey$ = "" + For a = 1 To 5 + Locate 1, 1 'print horizontal sparkles + Print Mid$(a$, a, 80); + Locate 22, 1 + Print Mid$(a$, 6 - a, 80); + + For b = 2 To 21 'Print Vertical sparkles + c = (a + b) Mod 5 + If c = 1 Then + Locate b, 80 + Print "*"; + Locate 23 - b, 1 + Print "*"; + Else + Locate b, 80 + Print " "; + Locate 23 - b, 1 + Print " "; + End If + Next b + _Delay .06 + Next a + Wend + +End Sub + +'StillWantsToPlay: +' Determines if users want to play game again. +Function StillWantsToPlay + + Color colorTable(5), colorTable(6) + Center 10, "" + Center 11, " G A M E O V E R " + Center 12, " " + Center 13, " Play Again? (Y/N) " + Center 14, "" + + While InKey$ <> "": Wend + Do + kbd$ = UCase$(InKey$) + Loop Until kbd$ = "Y" Or kbd$ = "N" + + Color 15, colorTable(4) + Center 10, " " + Center 11, " " + Center 12, " " + Center 13, " " + Center 14, " " + + If kbd$ = "Y" Then + StillWantsToPlay = TRUE + Else + StillWantsToPlay = FALSE + Color 7, 0 + Cls + End If + +End Function + diff --git a/samples/pattern/index.md b/samples/pattern/index.md index 5dd47908..a1476aa9 100644 --- a/samples/pattern/index.md +++ b/samples/pattern/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: MANDALA 9 LINE +## SAMPLE: PATTERN ![screenshot.png](img/screenshot.png) diff --git a/samples/philipp-strathausen.md b/samples/philipp-strathausen.md new file mode 100644 index 00000000..43cad166 --- /dev/null +++ b/samples/philipp-strathausen.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES BY PHILIPP STRATHAUSEN + +**[QTrek](qtrek/index.md)** + +[🐝 Philipp Strathausen](philipp-strathausen.md) 🔗 [game](game.md), [space shooter](space-shooter.md) + +Star Trek-like game by Philipp Strathausen. diff --git a/samples/phone/img/screenshot.png b/samples/phone/img/screenshot.png new file mode 100644 index 00000000..564bfef2 Binary files /dev/null and b/samples/phone/img/screenshot.png differ diff --git a/samples/phone/index.md b/samples/phone/index.md new file mode 100644 index 00000000..30769289 --- /dev/null +++ b/samples/phone/index.md @@ -0,0 +1,22 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: PHONE + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Simple phone directory by Microsoft. +``` + +### File(s) + +* [phone.bas](src/phone.bas) +* [phone.zip](src/phone.zip) + +🔗 [data management](../data-management.md) diff --git a/samples/phone/src/phone.bas b/samples/phone/src/phone.bas new file mode 100644 index 00000000..ca8fd676 --- /dev/null +++ b/samples/phone/src/phone.bas @@ -0,0 +1,523 @@ +'For faster operation +DefInt A-Z + +'Declaration of sub programs +DECLARE SUB ScrollDown () +DECLARE SUB Initialize () +DECLARE SUB PhoneEditor () +DECLARE FUNCTION GetString$ (row, col, start$, end$, vis, max) + +'Declaration of constants +Const TRUE = -1 +Const false = Not TRUE + +'declaration of global arrays +Dim Shared ScrollUpAsm(1 To 7) 'Stores asm routine to scroll up +Dim Shared ScrollDownAsm(1 To 7) 'Stores asm routine to scroll down + +'Program +Initialize +PhoneEditor + +'assembly routines +Data &HB8,&H01,&H06,&HB9,&H00,&H02,&HBA,&H4F,&H17,&HB7,&H00,&HCD,&H10,&HCB +Data &HB8,&H01,&H07,&HB9,&H00,&H02,&HBA,&H4F,&H17,&HB7,&H00,&HCD,&H10,&HCB + +' Max Chars Max +' Title$ Column Visible Chars +Data "Name",2,19,30 +Data "Phone",22,19,20 +Data "Address",42,19,30 +Data "City",62,9,20 +Data "St",72,2,2 +Data "Zip",75,5,5 + +'This funtion gets string input at location row,col. The string to +'input is at most MAX characters long, and no more than VIS chars may be +'displayed. The initial string is sent in START$, and the resulting +'string is returned as END$ +'The function itself returns the keystroke that was used to exit this +'routine, for example, arrow keys, function keys, return, escape, etc... +' +Function GetString$ (row, col, start$, end$, vis, max) + + 'establish current string + curr$ = LTrim$(Left$(start$, max)) + + 'force cursor to exist + Locate , , 1 + + finished = false + Do + GoSub GetStringShowText + GoSub GetStringGetKey + + If Len(kbd$) > 1 Then 'Exit if special key + finished = TRUE + GetString$ = kbd$ + Else + Select Case kbd$ + Case Chr$(13), Chr$(27), Chr$(9) 'Exit if special key + finished = TRUE + GetString$ = kbd$ + + Case Chr$(8) 'Handle backspace + If curr$ <> "" Then + curr$ = Left$(curr$, Len(curr$) - 1) + End If + + Case " " TO "}" 'Handle any text key + If Len(curr$) < max Then + curr$ = curr$ + kbd$ + End If + + Case Else 'Beep for anything else + Beep + End Select + End If + + Loop Until finished + + end$ = curr$ + Exit Function + + + GetStringShowText: 'Show at most VIS chars + Locate row, col 'of string + If Len(curr$) > vis Then + Print Right$(curr$, vis); + Else + Print curr$; Space$(vis - Len(curr$)); + Locate row, col + Len(curr$) + End If + Return + + + GetStringGetKey: 'Standard inkey loop + Do + kbd$ = InKey$ + Loop While kbd$ = "" + Return + +End Function + +Sub Initialize + + 'set up screen + Width , 25 + View Print + Locate , , 1 + + 'read in first asm routine + P = VarPtr(ScrollUpAsm(1)) + Def Seg = VarSeg(ScrollUpAsm(1)) + For i = 0 To 13 + Read j + Poke (P + i), j + Next i + + 'read in second asm routine + P = VarPtr(ScrollDownAsm(1)) + Def Seg = VarSeg(ScrollDownAsm(1)) + For i = 0 To 13 + Read j + Poke (P + i), j + Next i + + 'return segment to normal + Def Seg + +End Sub + +Sub PhoneEditor + + 'Dimension arrays + Dim edit$(6) 'Current line being edited + Dim Title$(6) 'Column titles + Dim col(6) 'Column locations + Dim vis(6) 'Maximum visible chars + Dim max(6) 'Maximum chars allowes + Dim io$(6) 'Used to RANDOM access file I/O + Dim name1$(6) 'Temp storage to print names + Dim name2$(6) 'Temp storage to print names + Dim index(2000) 'Tells the editor where to find name on disk + Dim key$(2000) 'Used for sorting + + 'prepare screen + For a = 1 To 6 + Read Title$(a), col(a), vis(a), max(a) + Next a + + u1$ = "\ \\ \\ \\ \\\\ \" + u2$ = "Ĵ" + u3$ = "" + + Color 14, 1 + Cls + + Print Using u1$; Title$(1); Title$(2); Title$(3); Title$(4); Title$(5); Title$(6); + Print u2$ + Locate 25, 1 + Print " "; + + 'Open random access file + Open "Phone.dat" For Random As #1 Len = 107 + Field #1, 30 As io$(1), 20 As io$(2), 30 As io$(3), 15 As io$(4), 2 As io$(5), 5 As io$(6) + Field #1, 11 As ioValid$, 5 As ioMaxRecord$ + + 'get first record, if it's a new file, it will initialize it. + 'Record #1 contains the code word "THISISVALID" indicating the file is + 'properly initialized, and the number of records in the file + Get #1, 1 + If ioValid$ <> "THISISVALID" Then + For a = 1 To 6 + LSet io$(a) = "" + Next a + Put #1, 2 + LSet ioValid$ = "THISISVALID" + RSet ioMaxRecord$ = "1" + Put #1, 1 + End If + + maxRecord = Val(ioMaxRecord$) + + 'Set up initial index + For a = 1 To maxRecord + index(a) = a + Next a + + + 'Initialize editor variables + currTopLine = 1 + GoSub printWholeScreen + + currRow = 1 + currCol = 1 + GoSub GetLine + + finished = false + + 'Main editor loop + Do + GoSub ShowCursor + GoSub EditItem + GoSub HideCursor + + 'Respond to user keystroke + Select Case kbd$ + Case Chr$(0) + "H" 'up + GoSub MoveUp + Case Chr$(0) + "P" 'down + GoSub MoveDown + Case Chr$(0) + "K", Chr$(0) + Chr$(15) 'left or backtab + currCol = (currCol + 4) Mod 6 + 1 + Case Chr$(0) + "M", Chr$(9) 'right, or tab + currCol = (currCol) Mod 6 + 1 + Case Chr$(0) + "G" 'Home + currCol = 1 + Case Chr$(0) + "O" 'End + currCol = 6 + Case Chr$(0) + "I" 'Page up + currRow = 1 + currTopLine = currTopLine - 22 + If currTopLine < 1 Then + currTopLine = 1 + End If + GoSub printWholeScreen + currRow = 1 + GoSub GetLine + Case Chr$(0) + "Q" 'Page Down + currRow = 1 + currTopLine = currTopLine + 22 + If currTopLine > maxRecord Then + currTopLine = maxRecord + End If + GoSub printWholeScreen + currRow = 1 + GoSub GetLine + Case Chr$(0) + "<" 'F2 + finished = TRUE + Case Chr$(0) + "?" 'F5 + GoSub sort + Case Chr$(0) + "@": 'F6 + GoSub PrintPhoneBook + Case Chr$(0) + "C" 'F9 + GoSub AddRecord + Case Chr$(0) + "D" + GoSub DeleteRecord 'F10 + Case Chr$(13) 'Enter + Case Else + Beep + End Select + Loop Until finished + Close + Exit Sub + + + MoveUp: + If currRow = 1 Then + If currTopLine = 1 Then + Beep + Else + ScrollDown + currTopLine = currTopLine - 1 + GoSub GetLine + GoSub PrintLine + End If + Else + currRow = currRow - 1 + GoSub GetLine + End If + Return + + MoveDown: + If (currRow + currTopLine - 1) >= maxRecord Then + Beep + Else + If currRow = 22 Then + ScrollDown + currTopLine = currTopLine + 1 + GoSub GetLine + GoSub PrintLine + Else + currRow = currRow + 1 + GoSub GetLine + End If + End If + Return + + PrintPhoneBook: + Cls + Print "THIS IS A TEMPORARY PRINT ROUTINE" + + For a = 1 To maxRecord Step 2 + If a <= maxRecord Then + Get #1, index(a) + 1 + For b = 1 To 6 + name1$(b) = RTrim$(io$(b)) + Next b + Else + For b = 1 To 6 + name1$(b) = "" + Next b + End If + If a + 1 <= maxRecord Then + Get #1, index(a + 1) + 1 + For b = 1 To 6 + name2$(b) = RTrim$(io$(b)) + Next b + Else + For b = 1 To 6 + name2$(b) = "" + Next b + End If + u$ = "\" + Space$(35) + "\\" + Space$(38) + "\" + Print Using u$; name1$(1); name2$(1) + Print Using u$; name1$(3); name2$(3) + Print Using u$; name1$(4) + "," + name1$(5) + " " + name1$(6); name2$(4) + "," + name2$(5) + " " + name2$(6) + Print Using u$; name1$(2); name2$(2) + Print + Print + Input a$ + Next a + + GoSub printWholeScreen + Return + + ShowCursor: + Color 0, 7 + Locate currRow + 2, col(currCol) + Print Left$(edit$(currCol) + Space$(vis(currCol)), vis(currCol)); + Return + + HideCursor: + Color 14, 1 + Locate currRow + 2, col(currCol) + Print Left$(edit$(currCol) + Space$(vis(currCol)), vis(currCol)); + Return + + EditItem: + 'Wait for a keystroke + Color 0, 7 + Do + kbd$ = InKey$ + Loop Until kbd$ <> "" + + 'if a text char, edit the line, else return + If kbd$ >= " " And kbd$ <= "~" Then + kbd$ = GetString$(currRow + 2, col(currCol), kbd$, back$, vis(currCol), max(currCol)) + edit$(currCol) = back$ + GoSub putLine + End If + Return + + + PrintLine: + Color 14, 1 + currRecord = currTopLine + currRow - 1 + Locate currRow + 2, 1 + If currRecord = maxRecord + 1 Then + Print u3$; + ElseIf currRecord > maxRecord Then + Print Space$(80); + Else + Print Using u1$; edit$(1); edit$(2); edit$(3); edit$(4); edit$(5); edit$(6); + End If + Return + + + DeleteRecord: + If maxRecord = 1 Then + Beep + Else + currRecord = currTopLine + currRow - 1 'init currRecord + maxRecord = maxRecord - 1 'Decrement maxRecord + theRecord = index(currRecord) 'Save pointer to currRecord + + 'Removing a name leaves a hole. So... + 'Squeeze actual physical data records on disk + For a = index(currRecord) To maxRecord + Get #1, a + 2 + Put #1, a + 1 + Next a + + 'Squeeze the index stored in memory. + For a = currRecord To maxRecord + index(a) = index(a + 1) + Next a + + 'Now that the actuall records were moved on disk, we need to + 'decrement the value of every pointer in the index array + 'that pointed to a name that was moved. + For a = 1 To maxRecord + If index(a) > theRecord Then + index(a) = index(a) - 1 + End If + Next a + + 'Update record#1 + LSet ioValid$ = "THISISVALID" + RSet ioMaxRecord$ = Str$(maxRecord) + Put #1, 1 + + 'Reprint screen, restablish cursor position + GoSub printWholeScreen + currRecord = currTopLine + currRow - 1 + If currRecord > maxRecord Then + GoSub MoveUp + End If + GoSub GetLine + End If + Return + + + AddRecord: + If maxRecord < 2000 Then + currRecord = currTopLine + currRow - 1 'Establish current record# + maxRecord = maxRecord + 1 'Increment maxRecord + For a = 1 To 6 'Clear IO buffer + LSet io$(a) = "" + Next a + Put #1, maxRecord + 1 'Insert into last pos in file + + 'We just added the new record to the physical file, now we + 'need to make room in the index + a = maxRecord + While a > currRecord + index(a + 1) = index(a) + a = a - 1 + Wend + + 'Assign new spot in index to the new record + index(currRecord + 1) = maxRecord + + 'Update first record + LSet ioValid$ = "THISISVALID" + RSet ioMaxRecord$ = Str$(maxRecord) + Put #1, 1 + + GoSub printWholeScreen + GoSub GetLine + Else + Beep + End If + Return + + + + printWholeScreen: + temp = currRow + For currRow = 1 To 22 + currRecord = currTopLine + currRow - 1 + If currRecord <= maxRecord Then + GoSub GetLine + End If + GoSub PrintLine + Next currRow + currRow = temp + Return + + + putLine: + currRecord = currTopLine + currRow - 1 + For a = 1 To 6 + LSet io$(a) = edit$(a) + Next a + Put #1, index(currRecord) + 1 + Return + + GetLine: + currRecord = currTopLine + currRow - 1 + Get #1, index(currRecord) + 1 + For a = 1 To 6 + edit$(a) = io$(a) + Next a + Return + + + sort: + 'Scan database, collect the strings from the current col in key$() + For a = 1 To maxRecord + Get #1, index(a) + 1 + key$(a) = io$(currCol) + Next a + + 'do the bubble sort + Do + swapFlag = false + For i = 1 To maxRecord - 1 + If key$(i) > key$(i + 1) Then + Swap key$(i), key$(i + 1) + Swap index(i), index(i + 1) + swapFlag = TRUE + End If + Next i + Loop Until Not swapFlag + + 'Reprint the screen + currTopLine = 1 + GoSub printWholeScreen + currRow = 1 + GoSub GetLine + Return + +End Sub + +Sub ScrollDown + + 'Call the asm routine stored in the array + Def Seg = VarSeg(ScrollDownAsm(1)) + Call Absolute(VarPtr(ScrollDownAsm(1))) + Def Seg + +End Sub + +Sub ScrollUp + + 'call the asm routnie stored in the array + Def Seg = VarSeg(ScrollUpAsm(1)) + Call Absolute(VarPtr(ScrollUpAsm(1))) + Def Seg + +End Sub + diff --git a/samples/phone/src/phone.zip b/samples/phone/src/phone.zip new file mode 100644 index 00000000..323366f6 Binary files /dev/null and b/samples/phone/src/phone.zip differ diff --git a/samples/pipes-puzzle/index.md b/samples/pipes-puzzle/index.md index 13c39acc..a321d94f 100644 --- a/samples/pipes-puzzle/index.md +++ b/samples/pipes-puzzle/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: PIPES PUZZLE (MAZE CONNECT) +## SAMPLE: PIPES PUZZLE ![gameplay.png](img/gameplay.png) diff --git a/samples/pixelplus/img/screenshot.png b/samples/pixelplus/img/screenshot.png new file mode 100644 index 00000000..c134f6f7 Binary files /dev/null and b/samples/pixelplus/img/screenshot.png differ diff --git a/samples/pixelplus/index.md b/samples/pixelplus/index.md new file mode 100644 index 00000000..d2b696f8 --- /dev/null +++ b/samples/pixelplus/index.md @@ -0,0 +1,53 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: PIXELPLUS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Chris Chadwick](../chris-chadwick.md) + +### Description + +```text +'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +' PIXELplus 256 User Subroutines & Functions +' FREEWARE version 1.0 - (C)1995 Chris Chadwick. All rights reserved. +' For QBASIC, QuickBASIC and Visual BASIC for MS-DOS +' +' Consult your PIXELplus 256 User's Manual for full details on how to +' incorporate and use the routines contained in this file. +' +' Note: The routines contained in this file do not contain error +' checking. This makes the code easier to understand. +' +' *** BEFORE RUNNING THE DEMONSTRATION *** +' Running the demonstration requires access to four files which should have +' been supplied with this FREEWARE version of PIXELplus 256. They are: +' +' CHARSET1.PUT +' CHARSET2.PUT +' CHARSET3.PUT +' STANDARD.PAL +' +' In your PIXELplus 256 directory (usually C:\PP256), the three .PUT files +' should be located in the IMAGES subdirectory, and the .PAL file should be +' located in the PALETTES subdirectory. If you have PIXELplus 256 +' installed in a directory other than C:\PP256 then the value of Path$ +' (see (*) below) should be altered appropriately before running the +' demonstration. +' +' Note that CHARSET2.PUT is only a partial character set image file that +' does not include lower case letters so text to be displayed using it +' should only contain upper case letters. +' +'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +``` + +### File(s) + +* [pp256img.zip](src/pp256img.zip) +* [usersubs.bas](src/usersubs.bas) + +🔗 [graphics](../graphics.md), [bitmap](../bitmap.md) diff --git a/samples/pixelplus/src/pp256img.zip b/samples/pixelplus/src/pp256img.zip new file mode 100644 index 00000000..1632c01c Binary files /dev/null and b/samples/pixelplus/src/pp256img.zip differ diff --git a/samples/pixelplus/src/usersubs.bas b/samples/pixelplus/src/usersubs.bas new file mode 100644 index 00000000..028f4dde --- /dev/null +++ b/samples/pixelplus/src/usersubs.bas @@ -0,0 +1,1326 @@ +'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +' PIXELplus 256 User Subroutines & Functions +' FREEWARE version 1.0 - (C)1995 Chris Chadwick. All rights reserved. +' For QBASIC, QuickBASIC and Visual BASIC for MS-DOS +' +' Consult your PIXELplus 256 User's Manual for full details on how to +' incorporate and use the routines contained in this file. +' +' Note: The routines contained in this file do not contain error +' checking. This makes the code easier to understand. +' +' *** BEFORE RUNNING THE DEMONSTRATION *** +' Running the demonstration requires access to four files which should have +' been supplied with this FREEWARE version of PIXELplus 256. They are: +' +' CHARSET1.PUT +' CHARSET2.PUT +' CHARSET3.PUT +' STANDARD.PAL +' +' In your PIXELplus 256 directory (usually C:\PP256), the three .PUT files +' should be located in the IMAGES subdirectory, and the .PAL file should be +' located in the PALETTES subdirectory. If you have PIXELplus 256 +' installed in a directory other than C:\PP256 then the value of Path$ +' (see (*) below) should be altered appropriately before running the +' demonstration. +' +' Note that CHARSET2.PUT is only a partial character set image file that +' does not include lower case letters so text to be displayed using it +' should only contain upper case letters. +' +'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +$Resize:Smooth + +'Variable type to hold screen design item data. +Type DesignType + ImageNo As Integer + Xpos As Integer + Ypos As Integer + DisAct As Integer +End Type + +DECLARE SUB InitPaletteData (FileName$, PaletteArray&()) +DECLARE SUB InitDesignData (FileName$, DesignArray() AS DesignType) +DECLARE SUB InitImageData (FileName$, ImageArray%()) +DECLARE SUB MakeImageIndex (ImageArray%(), IndexArray%()) +DECLARE SUB DisplayDesign (DesignArray() AS DesignType, ImageArray%(), ImageIndex%(), ClsAction%) +DECLARE SUB ChangePalette (PaletteArray&()) +DECLARE SUB FadePalette (Direction%, PaletteArray&()) +DECLARE SUB RotatePalette (StartAttr%, EndAttr%, Direction%, PaletteArray&()) +DECLARE SUB CharPrint (Text$, Fore%, Back%, CursorPos%, ImageArray%()) +DECLARE SUB CharPrintXY (x%, y%, Text$, Fore%, Back%, CursorPos%, ImageArray%()) +DECLARE SUB Scroller (ScrollAct%, ImageArray%(), IndexArray%()) +DECLARE SUB WizzText (Text$, TopLine%, ImageArray%(), IndexArray%()) +DECLARE SUB GraphicText (x%, y%, Text$, CursorPos%, ImageArray%(), IndexArray%()) +DECLARE FUNCTION GetDepth% (ImNo%, ImageArray%(), IndexArray%()) +DECLARE FUNCTION GetWidth% (ImNo%, ImageArray%(), IndexArray%()) + +DefInt A-Z + +'Constants for subroutine parameters. +Const INITSCROLL = 0, UPDATESCROLL = 1 +Const OVERPRINT = -1 +Const CENTRETEXT = -1, FROMCURSOR = -2 +Const FADEDOWN = 0, FADEUP = 1 +Const ROTATELEFT = 0, ROTATERIGHT = 1 +Const NEWLINE = 0, TEXTEND = 1 + +'Change to 320x200, 256 colour VGA screen mode. +Screen 13 +_FullScreen _SquarePixels , _Smooth +Cls + +'(*) If necessary, change Path$ to the path where +' you have PIXELplus 256 installed. +Path$ = "." + +'Load standard palette. +ReDim StandardPal&(1 To 1) +Call InitPaletteData(Path$ + "\palettes\standard.pal", StandardPal&()) +Call ChangePalette(StandardPal&()) + +'Load character set used by CharPrint() and CharPrintXY() routines. +ReDim Set1Data(1 To 1) +Call InitImageData(Path$ + "\images\charset1.put", Set1Data()) + +'Load bitmapped character set used by WizzText() and Scroller() routines. +'This is a partial character set containing ASCII characters 32 (space) +'to 90 (Z) only. +ReDim Set2Data(1 To 1) +ReDim Set2Index(1 To 1) +Call InitImageData(Path$ + "\images\charset2.put", Set2Data()) +Call MakeImageIndex(Set2Data(), Set2Index()) + +'Load bitmapped character set used by GraphicText() routine. +ReDim Set3Data(1 To 1) +ReDim Set3Index(1 To 1) +Call InitImageData(Path$ + "\images\charset3.put", Set3Data()) +Call MakeImageIndex(Set3Data(), Set3Index()) + +'Initialize images used in GAME OVER screen design. +ReDim ImageData(1 To 1) +ReDim ImageIndex(1 To 1) +Restore SDImageData +Call InitImageData("", ImageData()) +Call MakeImageIndex(ImageData(), ImageIndex()) + +'Initialize alternative palette. +ReDim NewPal&(1 To 1) +Restore NewPaletteData +Call InitPaletteData("", NewPal&()) + +'Initialize GAME OVER screen design. +ReDim GODesign(1 To 1) As DesignType +Restore DesignData +Call InitDesignData("", GODesign()) + +'*** Draw page 1 of demonstration *** + +'Draw a background image so overprinting can be demonstrated properly. +For n = 1 To 12 + Line (0, 51 + n)-Step(318, 0), 30 - n + Line (0, 53 - n)-Step(318, 0), 30 - n +Next n + +'Demonstrate CharPrint() subroutine. +Call CharPrint("CharPrint() can be used as an", 40, 0, NEWLINE, Set1Data()) +Call CharPrint("alternative to BASIC's own PRINT", 40, 0, NEWLINE, Set1Data()) +Call CharPrint("statement. A user-defined character set", 40, 0, NEWLINE, Set1Data()) +Call CharPrint("is used and text can either be displayed", 40, 0, NEWLINE, Set1Data()) +Call CharPrint("with a ", 40, 0, TEXTEND, Set1Data()) +Call CharPrint("BACKGROUND", 40, 44, TEXTEND, Set1Data()) +Call CharPrint(" colour or...", 40, 0, NEWLINE, Set1Data()) +Locate 7, 10 +Call CharPrint("O V E R P R I N T E D", 40, OVERPRINT, NEWLINE, Set1Data()) +Locate 9 +Call CharPrint("on the existing screen image.", 40, 0, NEWLINE, Set1Data()) + +'Demonstrate CharPrintXY() subroutine. +Call CharPrintXY(0, 90, "CharPrintXY() is the same as", 33, 44, NEWLINE, Set1Data()) +Call CharPrintXY(2, 99, "CharPrint() except it allows text", 33, 44, NEWLINE, Set1Data()) +Call CharPrintXY(5, 109, "to be displayed at a graphics", 33, 44, NEWLINE, Set1Data()) +Call CharPrintXY(9, 120, "screen coordinate.", 33, 44, NEWLINE, Set1Data()) +Call CharPrintXY(CENTRETEXT, 135, "Single lines of", 33, 0, NEWLINE, Set1Data()) +Call CharPrintXY(CENTRETEXT, FROMCURSOR, "text can", 33, 0, NEWLINE, Set1Data()) +Call CharPrintXY(CENTRETEXT, FROMCURSOR, "also be automatically", 33, 0, NEWLINE, Set1Data()) +Call CharPrintXY(CENTRETEXT, FROMCURSOR, "centred on-screen", 33, 0, NEWLINE, Set1Data()) +Call CharPrintXY(CENTRETEXT, FROMCURSOR, "by using CharPrintXY()", 33, 0, NEWLINE, Set1Data()) + +'Demonstrate Scroller() subroutine and wait for a key press. +Restore ScrollMess1 +Call Scroller(INITSCROLL, Set2Data(), Set2Index()) +Do + Call Scroller(UPDATESCROLL, Set2Data(), Set2Index()) +Loop While InKey$ = "" + +'*** Draw page 2 of demonstration *** +Cls + +'Demonstrate GraphicText() subroutine. +Call GraphicText(0, 0, "The GraphicText() subroutine is used to display", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(FROMCURSOR, FROMCURSOR, "text that uses a bitmapped character set...", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(CENTRETEXT, 32, "WHICH CAN BE ANY", NEWLINE, Set2Data(), Set2Index()) +Call GraphicText(CENTRETEXT, 48, "SIZE YOU LIKE!", NEWLINE, Set2Data(), Set2Index()) +Call GraphicText(0, 72, "Use GraphicText() to display", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(1, 81, "fancy text at any position", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(5, 91, "on the screen by using", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(9, 102, "graphics screen coordinates.", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(0, 120, "Notice how text is displayed proportionally so", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(FROMCURSOR, FROMCURSOR, "narrow characters like 'i' are still displayed with", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(FROMCURSOR, FROMCURSOR, "the same spacing as wide characters like 'm'.", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(CENTRETEXT, 156, "There's an automatic", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(CENTRETEXT, FROMCURSOR, "centring option", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(CENTRETEXT, FROMCURSOR, "too!", NEWLINE, Set3Data(), Set3Index()) + +'Demonstrate Scroller() subroutine and wait for a key press. +Restore ScrollMess2 +Call Scroller(INITSCROLL, Set2Data(), Set2Index()) +Do + Call Scroller(UPDATESCROLL, Set2Data(), Set2Index()) +Loop While InKey$ = "" + +'*** Draw page 3 of demonstration *** +Cls + +'Demonstrate WizzText() subroutine. +Call WizzText("THE WIZZTEXT()", 30, Set2Data(), Set2Index()) +Call WizzText("SUBROUTINE CAN BE", 50, Set2Data(), Set2Index()) +Call WizzText("USED TO DISPLAY", 70, Set2Data(), Set2Index()) +Call WizzText("AND CENTRE SINGLE", 90, Set2Data(), Set2Index()) +Call WizzText("LINES OF BITMAPPED", 110, Set2Data(), Set2Index()) +Call WizzText("TEXT IN A MORE", 130, Set2Data(), Set2Index()) +Call WizzText("EXCITING WAY!", 150, Set2Data(), Set2Index()) + +'Demonstrate Scroller() subroutine and wait for a key press. +Restore ScrollMess2 +Call Scroller(INITSCROLL, Set2Data(), Set2Index()) +Do + Call Scroller(UPDATESCROLL, Set2Data(), Set2Index()) +Loop While InKey$ = "" + +'*** Draw page 4 of demonstration *** +Cls + +'Draw a palette grid showing all 256 available colours. +For rr = 0 To 15 + For cc = 0 To 15 + Line (32 + cc * 16, 40 + rr * 8)-Step(14, 6), (rr * 16) + cc, BF + Next cc +Next rr + +'Display explanation text. +Call GraphicText(0, 8, "Using the ChangePalette() subroutine allows you", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(FROMCURSOR, FROMCURSOR, "to quickly change palettes...", NEWLINE, Set3Data(), Set3Index()) + +'Demonstrate ChangePalette() subroutine. +For n = 1 To 5 + Sleep 1 + Call ChangePalette(StandardPal&()) + Sleep 1 + Call ChangePalette(NewPal&()) +Next n + +'Clear old text from top of screen. +Line (0, 0)-(319, 38), 0, BF + +'Display explanation text. +Call GraphicText(0, 8, "Use the RotatePalette() subroutine to shift a", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(FROMCURSOR, FROMCURSOR, "range of colours to the left or right...", NEWLINE, Set3Data(), Set3Index()) + +'Demonstrate RotatePalette() subroutine. +For n = 1 To 8 + Sleep 1 + Call RotatePalette(32, 47, ROTATERIGHT, NewPal&()) +Next n +For n = 1 To 8 + Sleep 1 + Call RotatePalette(32, 47, ROTATELEFT, NewPal&()) +Next n + +'Clear old text from top of screen. +Line (0, 0)-(319, 38), 0, BF + +'Display explanation text. +Call GraphicText(0, 8, "Use the FadePalette() subroutine to gradually", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(FROMCURSOR, FROMCURSOR, "fade out the display...", NEWLINE, Set3Data(), Set3Index()) + +'Demonstrate FadePalette() subroutine. +Sleep 3 +Call FadePalette(FADEDOWN, NewPal&()) +Line (0, 0)-(319, 38), 0, BF +Call GraphicText(0, 8, "...then gradually fade it back in!", NEWLINE, Set3Data(), Set3Index()) +Sleep 1 +Call FadePalette(FADEUP, NewPal&()) + +'Demonstrate Scroller() subroutine and wait for a key press. +Restore ScrollMess2 +Call Scroller(INITSCROLL, Set2Data(), Set2Index()) +Do + Call Scroller(UPDATESCROLL, Set2Data(), Set2Index()) +Loop While InKey$ = "" + +'*** Draw page 5 of demonstration *** +Cls + +'Display explanation text. +Call GraphicText(0, 0, "This is a simple screen design and shows how", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(FROMCURSOR, FROMCURSOR, "RotatePalette() can be used to create", NEWLINE, Set3Data(), Set3Index()) +Call GraphicText(FROMCURSOR, FROMCURSOR, "very colourful effects...", NEWLINE, Set3Data(), Set3Index()) + +'Display GAME OVER screen design. +Call DisplayDesign(GODesign(), ImageData(), ImageIndex(), 0) + +'Demonstrate Scroller() and RotatePalette() subroutines +'while waiting for a key press. +Restore ScrollMess2 +Call Scroller(INITSCROLL, Set2Data(), Set2Index()) +Do + 'Scroller() is called more often than RotatePalette() so that + 'the palette isn't rotated too quickly. + Call Scroller(UPDATESCROLL, Set2Data(), Set2Index()) + Call Scroller(UPDATESCROLL, Set2Data(), Set2Index()) + Call RotatePalette(176, 255, ROTATERIGHT, NewPal&()) +Loop While InKey$ = "" + +'Fade and blank screen before ending. +Call FadePalette(FADEDOWN, NewPal&()) +Cls + +'Restore standard palette. +Call ChangePalette(StandardPal&()) + + +'*** Message text for Scroller() subroutine (upper case only) *** +ScrollMess1: +Data "THIS IS A SCROLLING MESSAGE DISPLAYED USING THE SCROLLER() ROUTINE..." +Data " " +ScrollMess2: +Data "PRESS A KEY TO CONTINUE..." +Data " " +Data "" + +'*** Data for images used in GAME OVER screen design *** +SDImageData: +Data 360 +Data 128,16,0,0,-8448,-8225,-8225,223,0,0,0,-8448,-8225,-8739,-8739,-8225,223,0,0,-8225 +Data -8739,-9253,-9253,-8739,-8225,0,-8448,-8737,-9253,-9767,-9767,-9253,-8227,223,-8448,-9251,-9767,-10538,-10538,-9767 +Data -8741,223,-8225,-9251,-10535,-11052,-11052,-9770,-8741,-8225,-8737,-9765,-11050,-11564,-11054,-10540,-9255,-8227,-8737,-9765 +Data -11050,-12078,-11568,-10540,-9255,-8227,-8737,-9765,-11050,-12078,-11568,-10540,-9255,-8227,-8737,-9765,-11050,-11564,-11054,-10540 +Data -9255,-8227,-8225,-9251,-10535,-11052,-11052,-9770,-8741,-8225,-8448,-9251,-9767,-10538,-10538,-9767,-8741,223,-8448,-8737 +Data -9253,-9767,-9767,-9253,-8227,223,0,-8225,-8739,-9253,-9253,-8739,-8225,0,0,-8448,-8225,-8739,-8739,-8225 +Data 223,0,0,0,-8448,-8225,-8225,223,0,0,128,16,-1,-1,255,0,0,-256,-1,-1 +Data -1,255,0,0,0,0,-256,-1,-1,0,0,0,0,0,0,-1,255,0,0,0 +Data 0,0,0,-256,255,0,0,0,0,0,0,-256,0,0,0,0,0,0,0,0 +Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +Data 255,0,0,0,0,0,0,-256,255,0,0,0,0,0,0,-256,-1,0,0,0 +Data 0,0,0,-1,-1,255,0,0,0,0,-256,-1,-1,-1,255,0,0,-256,-1,-1 +Data 112,14,-8996,-11563,-9772,-8740,-10533,-11310,-9769,-10021,-11053,-9255,-9765,-10794,-11053,-9255,-10793,-10283,-10792,-11309 +Data -10027,-11050,-9000,-10796,-11050,-11309,-10797,-9254,-11563,-9003,-11309,-11821,-10542,-8998,-9250,-11308,-9002,-11049,-11566,-10798 +Data -8228,-9762,-10540,-8741,-9507,-10537,-10797,-8484,-11046,-10798,-8996,-8996,-9509,-9512,-9507,-11820,-10799,-9765,-9514,-8997 +Data -8483,-10788,-12079,-10029,-10791,-9517,-8996,-8226,-11301,-11311,-10283,-10795,-9259,-10022,-8484,-11303,-10541,-11306,-10029,-9255 +Data -10538,-9509,-10795,-10793,-11309,-9770,-8996,-9768,-10791,-9515,-10533,-9771,-10021,-8482,-9251,-11307,-8487,-10018,-10536,-11046 + +'*** Alternative palette data *** +NewPaletteData: +Data 0,2752512,10752,2763264,42,2752554,5418,2763306 +Data 1381653,4134165,1392405,4144917,1381695,4134207,1392447,4144959 +Data 8751,271408,534065,862258,1124915,1387572,1650229,1912886 +Data 2240824,2503481,2766138,3028795,3291452,3619645,3882302,4144959 +Data 4128768,4128784,4128799,4128815,4128831,3080255,2031679,1048639 +Data 63,4159,7999,12095,16191,16175,16159,16144 +Data 16128,1064704,2047744,3096320,4144896,4140800,4136704,4132864 +Data 4136735,4136743,4136751,4136759,4136767,3612479,3088191,2563903 +Data 2039615,2041663,2043711,2045759,2047807,2047799,2047791,2047783 +Data 2047775,2572063,3096351,3620639,4144927,4142879,4140831,4138783 +Data 4140333,4140337,4140342,4140346,4140351,3812671,3550527,3222847 +Data 2960703,2961727,2963007,2964031,2965311,2965306,2965302,2965297 +Data 2965293,3227437,3555117,3817261,4144941,4143661,4142637,4141357 +Data 1835008,1835015,1835022,1835029,1835036,1376284,917532,458780 +Data 921130,986666,986667,1052203,1052459,1117996,1183532,1183532 +Data 1249069,1249069,1314605,1314606,1380398,1445934,1445935,1511471 +Data 1511471,1577008,1642544,1642544,1708337,1708337,1773873,1839410 +Data 1839410,1904946,1904947,1970483,1970739,2036276,2101812,2101812 +Data 2167349,2167349,2232885,2298422,2298678,2364214,2364215,2429751 +Data 2429751,2495288,2560824,2560824,2626617,2626617,2692153,2757690 +Data 2757690,2823226,2823227,2888763,2954555,2954556,3020092,3020092 +Data 3085629,3085629,3151165,3216702,3216958,3282494,3282495,3348031 +Data 4128768,3867648,3606528,3280128,3019008,2757888,2496768,2235648 +Data 1909248,1648128,1387008,1125888,864768,538368,277248,16128 +Data 16132,16136,16140,16144,16148,16152,16156,16160 +Data 16163,16167,16171,16175,16179,16183,16187,16191 +Data 15167,14143,13119,12095,11071,10047,9023,7999 +Data 7231,6207,5183,4159,3135,2111,1087,63 +Data 262207,524351,786495,1048639,1310783,1572927,1835071,2097215 +Data 2293823,2555967,2818111,3080255,3342399,3604543,3866687,4128831 +Data 4128827,4128823,4128819,4128815,4128811,4128807,4128803,4128799 +Data 4128796,4128792,4128788,4128784,4128780,4128776,4128772,4128768 + +'*** GAME OVER screen design data *** +DesignData: +Data 346 +Data 2,72,40,5,1,72,40,3,2,64,32,5,1,64,32,3,2,56,32,5 +Data 1,56,32,3,2,48,32,5,1,48,32,3,2,40,32,5,1,40,32,3 +Data 2,32,40,5,1,32,40,3,2,32,48,5,1,32,48,3,2,32,56,5 +Data 1,32,56,3,2,32,64,5,1,32,64,3,2,32,72,5,1,32,72,3 +Data 2,32,80,5,1,32,80,3,2,40,88,5,1,40,88,3,2,48,88,5 +Data 1,48,88,3,2,56,88,5,1,56,88,3,2,64,88,5,1,64,88,3 +Data 2,72,80,5,1,72,80,3,2,72,72,5,1,72,72,3,2,72,64,5 +Data 1,72,64,3,2,64,64,5,1,64,64,3,2,56,64,5,1,56,64,3 +Data 2,96,88,5,1,96,88,3,2,96,80,5,1,96,80,3,2,96,72,5 +Data 1,96,72,3,2,96,64,5,1,96,64,3,2,96,56,5,1,96,56,3 +Data 2,96,48,5,1,96,48,3,2,104,40,5,1,104,40,3,2,112,32,5 +Data 1,112,32,3,2,120,32,5,1,120,32,3,2,128,40,5,1,128,40,3 +Data 2,136,48,5,1,136,48,3,2,136,56,5,1,136,56,3,2,136,64,5 +Data 1,136,64,3,2,136,72,5,1,136,72,3,2,136,80,5,1,136,80,3 +Data 2,136,88,5,1,136,88,3,2,128,64,5,1,128,64,3,2,120,64,5 +Data 1,120,64,3,2,112,64,5,1,112,64,3,2,104,64,5,1,104,64,3 +Data 2,160,88,5,1,160,88,3,2,160,80,5,1,160,80,3,2,160,72,5 +Data 1,160,72,3,2,160,64,5,1,160,64,3,2,160,56,5,1,160,56,3 +Data 2,160,48,5,1,160,48,3,2,160,40,5,1,160,40,3,2,160,32,5 +Data 1,160,32,3,2,168,40,5,1,168,40,3,2,176,48,5,1,176,48,3 +Data 2,184,56,5,1,184,56,3,2,192,48,5,1,192,48,3,2,200,40,5 +Data 1,200,40,3,2,208,32,5,1,208,32,3,2,208,40,5,1,208,40,3 +Data 2,208,48,5,1,208,48,3,2,208,56,5,1,208,56,3,2,208,64,5 +Data 1,208,64,3,2,208,72,5,1,208,72,3,2,208,80,5,1,208,80,3 +Data 2,208,88,5,1,208,88,3,2,232,32,5,1,232,32,3,2,232,40,5 +Data 1,232,40,3,2,232,48,5,1,232,48,3,2,232,56,5,1,232,56,3 +Data 2,232,64,5,1,232,64,3,2,232,72,5,1,232,72,3,2,232,80,5 +Data 1,232,80,3,2,232,88,5,1,232,88,3,2,240,88,5,1,240,88,3 +Data 2,248,88,5,1,248,88,3,2,256,88,5,1,256,88,3,2,264,88,5 +Data 1,264,88,3,2,272,88,5,1,272,88,3,2,240,32,5,1,240,32,3 +Data 2,248,32,5,1,248,32,3,2,256,32,5,1,256,32,3,2,264,32,5 +Data 1,264,32,3,2,272,32,5,1,272,32,3,2,240,64,5,1,240,64,3 +Data 2,248,64,5,1,248,64,3,2,256,64,5,1,256,64,3,2,264,64,5 +Data 1,264,64,3,2,68,112,5,1,68,112,3,2,60,112,5,1,60,112,3 +Data 2,52,112,5,1,52,112,3,2,44,112,5,1,44,112,3,2,36,120,5 +Data 1,36,120,3,2,36,128,5,1,36,128,3,2,36,136,5,1,36,136,3 +Data 2,36,144,5,1,36,144,3,2,36,152,5,1,36,152,3,2,36,160,5 +Data 1,36,160,3,2,44,168,5,1,44,168,3,2,52,168,5,1,52,168,3 +Data 2,60,168,5,1,60,168,3,2,68,168,5,1,68,168,3,2,76,160,5 +Data 1,76,160,3,2,76,152,5,1,76,152,3,2,76,144,5,1,76,144,3 +Data 2,76,136,5,1,76,136,3,2,76,128,5,1,76,128,3,2,76,120,5 +Data 1,76,120,3,2,100,112,5,1,100,112,3,2,100,120,5,1,100,120,3 +Data 2,100,128,5,1,100,128,3,2,100,136,5,1,100,136,3,2,100,144,5 +Data 1,100,144,3,2,100,152,5,1,100,152,3,2,108,160,5,1,108,160,3 +Data 2,116,168,5,1,116,168,3,2,124,168,5,1,124,168,3,2,132,160,5 +Data 1,132,160,3,2,140,152,5,1,140,152,3,2,140,144,5,1,140,144,3 +Data 2,140,136,5,1,140,136,3,2,140,128,5,1,140,128,3,2,140,120,5 +Data 1,140,120,3,2,140,112,5,1,140,112,3,2,164,112,5,1,164,112,3 +Data 2,164,120,5,1,164,120,3,2,164,128,5,1,164,128,3,2,164,136,5 +Data 1,164,136,3,2,164,144,5,1,164,144,3,2,164,152,5,1,164,152,3 +Data 2,164,160,5,1,164,160,3,2,164,168,5,1,164,168,3,2,172,168,5 +Data 1,172,168,3,2,180,168,5,1,180,168,3,2,188,168,5,1,188,168,3 +Data 2,196,168,5,1,196,168,3,2,204,168,5,1,204,168,3,2,172,112,5 +Data 1,172,112,3,2,180,112,5,1,180,112,3,2,188,112,5,1,188,112,3 +Data 2,196,112,5,1,196,112,3,2,204,112,5,1,204,112,3,2,172,144,5 +Data 1,172,144,3,2,180,144,5,1,180,144,3,2,188,144,5,1,188,144,3 +Data 2,196,144,5,1,196,144,3,2,236,112,5,1,236,112,3,2,244,112,5 +Data 1,244,112,3,2,252,112,5,1,252,112,3,2,260,112,5,1,260,112,3 +Data 2,268,120,5,1,268,120,3,2,268,128,5,1,268,128,3,2,268,136,5 +Data 1,268,136,3,2,260,144,5,1,260,144,3,2,252,144,5,1,252,144,3 +Data 2,244,144,5,1,244,144,3,2,236,144,5,1,236,144,3,2,268,168,5 +Data 1,268,168,3,2,260,160,5,1,260,160,3,2,252,152,5,1,252,152,3 +Data 2,228,112,5,1,228,112,3,2,228,120,5,1,228,120,3,2,228,128,5 +Data 1,228,128,3,2,228,136,5,1,228,136,3,2,228,144,5,1,228,144,3 +Data 2,228,152,5,1,228,152,3,2,228,160,5,1,228,160,3,2,228,168,5 +Data 1,228,168,3,3,0,38,1,3,0,52,1,3,0,66,1,3,0,80,1 +Data 3,0,94,1,3,0,108,1,3,0,122,1,3,0,136,1,3,0,150,1 +Data 3,0,164,1,3,306,38,1,3,306,52,1,3,306,66,1,3,306,80,1 +Data 3,306,94,1,3,306,108,1,3,306,122,1,3,306,136,1,3,306,150,1 +Data 3,306,164,1 + +'* ChangePalette() subroutine: +'* Quickly changes the current colour palette to the colours held in +'* a palette array. +'* +'* Parameters: +'* PaletteArray&() - Long integer array holding the colours to be used as +'* the new colour palette. This array must have previously +'* been initialized by calling InitPaletteData(). +'* +Sub ChangePalette (PaletteArray&()) + + 'Break down all 256 colours into their RGB values. + Dim RGBval(0 To 255, 0 To 2) + For n = 0 To 255 + c& = PaletteArray&(n) + b = c& \ 65536: c& = c& - b * 65536 + g = c& \ 256: c& = c& - g * 256 + r = c& + RGBval(n, 0) = r + RGBval(n, 1) = g + RGBval(n, 2) = b + Next n + + 'Write colours directly to the video card. + Wait &H3DA, &H8, &H8: Wait &H3DA, &H8 + For n = 0 To 255 + Out &H3C8, n 'Select attribute. + Out &H3C9, RGBval(n, 0) 'Write red. + Out &H3C9, RGBval(n, 1) 'Write green. + Out &H3C9, RGBval(n, 2) 'Write blue. + Next n + +End Sub + +'* CharPrint() subroutine: +'* Displays a text string using a character set designed with PIXELplus 256. +'* Text can be displayed using both a foreground and background colour, or +'* can be overprinted on the existing screen image using the foreground +'* colour. +'* +'* Parameters: +'* Text$ - The text string to be displayed. +'* Fore - The foreground colour to display text in. +'* Back - The background colour to display text in or use OVERPRINT +'* to have the text overprinted on the existing screen image. +'* CursorPos - Dictates where the text cursor should be left after +'* the text has been displayed: +'* Use NEWLINE to move the cursor to the start of a new line. +'* Use TEXTEND to leave the cursor directly after the last +'* character displayed. +'* ImageArray() - Image array holding the character set to be used. Each +'* character must be an 8x8 image and be in the standard +'* ASCII order, starting with the space character. +'* +Sub CharPrint (Text$, Fore, Back, CursorPos, ImageArray()) + + 'Create an 8x8 image array to build a character in. + Dim NewChar(1 To 34) + NewChar(1) = 64: NewChar(2) = 8 + + 'Convert text cursor position to graphics (x,y) coordinates. + x = (Pos(0) - 1) * 8: y = (CsrLin - 1) * 8 + + 'Get high byte equivalent of Fore & Back colours. + HighFore = 0: HighBack = 0 + Def Seg = VarSeg(HighFore) + Poke VarPtr(HighFore) + 1, Fore + Def Seg = VarSeg(HighBack) + Poke VarPtr(HighBack) + 1, Back + Def Seg + + If Back = OVERPRINT Then + '*** Overprint text onto existing screen image *** + + 'Loop to build and display each character of Text$. + For j = 1 To Len(Text$) + Get (x, y)-Step(7, 7), NewChar(1) + + BasePtr = (Asc(Mid$(Text$, j, 1)) - 32) * 34 + + 'Build new character image in NewChar(). + For n = 3 To 34 + PixPair = ImageArray(BasePtr + n) + + If (PixPair And &HFF) Then + LowByte = Fore + Else + LowByte = NewChar(n) And &HFF + End If + + If (PixPair And &HFF00) Then + NewChar(n) = HighFore Or LowByte + Else + NewChar(n) = (NewChar(n) And &HFF00) Or LowByte + End If + Next n + + 'Display the character. + Put (x, y), NewChar(1), PSet + + 'Find screen coordinates for next character. + If x = 312 Then + x = 0 + If y <> 192 Then y = y + 8 + Else + x = x + 8 + End If + Next j + Else + '*** Display text using foreground & background colours *** + + 'Loop to build and display each character of Text$. + For j = 1 To Len(Text$) + BasePtr = (Asc(Mid$(Text$, j, 1)) - 32) * 34 + + 'Build new character image in NewChar(). + For n = 3 To 34 + PixPair = ImageArray(BasePtr + n) + + If (PixPair And &HFF) Then + LowByte = Fore + Else + LowByte = Back + End If + + If (PixPair And &HFF00) Then + NewChar(n) = HighFore Or LowByte + Else + NewChar(n) = HighBack Or LowByte + End If + Next n + + 'Display the character. + Put (x, y), NewChar(1), PSet + + 'Find screen coordinates for next character. + If x = 312 Then + x = 0 + If y <> 192 Then y = y + 8 + Else + x = x + 8 + End If + Next j + End If + + 'Update text cursor to required position before exiting. + c = (x \ 8) + 1: r = (y \ 8) + 1 + If CursorPos = NEWLINE Then + 'Check a new line is actually required. + If c <> 1 Then + c = 1 + If r < 25 Then r = r + 1 + End If + End If + Locate r, c + +End Sub + +'* CharPrintXY() subroutine: +'* Displays a text string at a graphics screen coordinate, using a character +'* set designed with PIXELplus 256. Text can be displayed using both a +'* foreground and background colour, or can be overprinted on the existing +'* screen image using the foreground colour. +'* +'* Parameters: +'* x - Horizontal coordinate of where printing should start or: +'* Use FROMCURSOR to use the current graphics cursor X +'* coordinate. +'* Use CENTRETEXT to have the text centred. +'* y - Vertical coordinate of where printing should start or +'* use FROMCURSOR to use the current graphics cursor Y +'* coordinate. +'* Text$ - The text string to be displayed. +'* Fore - The foreground colour to display text in. +'* Back - The background colour to display text in or use OVERPRINT +'* to have the text overprinted on the existing screen image. +'* CursorPos - Dictates where the graphics cursor should be left after +'* the text has been displayed: +'* Use NEWLINE to move the cursor to the start of a new line. +'* Use TEXTEND to leave the cursor directly after the last +'* character displayed. +'* ImageArray() - Image array holding the character set to be used. Each +'* character must be an 8x8 image and be in the standard +'* ASCII order, starting with the space character. +'* +Sub CharPrintXY (x, y, Text$, Fore, Back, CursorPos, ImageArray()) + + MessLen = Len(Text$) + If x = CENTRETEXT Then + 'Find start X coordinate for centred text. + w = MessLen * 8 + x = (320 - w) \ 2 + ElseIf x = FROMCURSOR Then + 'Use current X coordinate. + x = Point(0) + End If + + 'Use current Y coordinate if requested. + If y = FROMCURSOR Then y = Point(1) + + 'Create an 8x8 image array to build a character in. + Dim NewChar(1 To 34) + NewChar(1) = 64: NewChar(2) = 8 + + 'Get high byte equivalent of Fore & Back colours. + HighFore = 0: HighBack = 0 + Def Seg = VarSeg(HighFore) + Poke VarPtr(HighFore) + 1, Fore + Def Seg = VarSeg(HighBack) + Poke VarPtr(HighBack) + 1, Back + Def Seg + + If Back = OVERPRINT Then + '*** Overprint text onto existing screen image *** + + 'Loop to build and display each character of Text$. + For j = 1 To Len(Text$) + Get (x, y)-Step(7, 7), NewChar(1) + + BasePtr = (Asc(Mid$(Text$, j, 1)) - 32) * 34 + + 'Build new character image in NewChar(). + For n = 3 To 34 + PixPair = ImageArray(BasePtr + n) + + If (PixPair And &HFF) Then + LowByte = Fore + Else + LowByte = NewChar(n) And &HFF + End If + + If (PixPair And &HFF00) Then + NewChar(n) = HighFore Or LowByte + Else + NewChar(n) = (NewChar(n) And &HFF00) Or LowByte + End If + Next n + + 'Display the character. + Put (x, y), NewChar(1), PSet + + 'Find screen coordinates for next character. + If x >= 305 Then + x = 0 + If y >= 185 Then y = 192 Else y = y + 8 + Else + x = x + 8 + End If + Next j + Else + '*** Display text using foreground & background colours *** + + 'Loop to build and display each character of Text$. + For j = 1 To Len(Text$) + BasePtr = (Asc(Mid$(Text$, j, 1)) - 32) * 34 + + 'Build new character image in NewChar(). + For n = 3 To 34 + PixPair = ImageArray(BasePtr + n) + + If (PixPair And &HFF) Then + LowByte = Fore + Else + LowByte = Back + End If + + If (PixPair And &HFF00) Then + NewChar(n) = HighFore Or LowByte + Else + NewChar(n) = HighBack Or LowByte + End If + Next n + + 'Display the character. + Put (x, y), NewChar(1), PSet + + 'Find screen coordinates for next character. + If x >= 305 Then + x = 0 + If y >= 185 Then y = 192 Else y = y + 8 + Else + x = x + 8 + End If + Next j + End If + + 'Update graphics cursor to required position before exiting. + If CursorPos = NEWLINE Then + 'Check a new line is actually required. + If x <> 0 Then + x = 0 + If y < 185 Then y = y + 8 + End If + End If + PSet (x, y), Point(x, y) + +End Sub + +'* DisplayDesign() subroutine: +'* Displays the screen design held in DesignArray() using the images held +'* in ImageArray(). +'* +'* Parameters: +'* DesignArray() - Dynamic, DesignType array holding screen design data. +'* ImageArray() - Dynamic, integer array holding the images to use for +'* displaying the screen design. +'* IndexArray() - Dynamic, integer array holding the index for images in +'* ImageArray(). +'* ClsAction - A non-zero value causes the screen to be cleared before +'* the screen design is displayed. +'* +Sub DisplayDesign (DesignArray() As DesignType, ImageArray(), ImageIndex(), ClsAction) + + 'Only clear the screen if requested to. + If ClsAction Then Cls + + LastItem = UBound(DesignArray) + + 'Loop to display all items in the screen design. + For n = 1 To LastItem + ImageNo = DesignArray(n).ImageNo + Xpos = DesignArray(n).Xpos + Ypos = DesignArray(n).Ypos + DisAct = DesignArray(n).DisAct + + 'Mask-out high byte of DisAct to find display action code. + Select Case (DisAct And &HFF) + Case 1 + Put (Xpos, Ypos), ImageArray(ImageIndex(ImageNo)), PSet + Case 2 + Put (Xpos, Ypos), ImageArray(ImageIndex(ImageNo)), PReset + Case 3 + Put (Xpos, Ypos), ImageArray(ImageIndex(ImageNo)), Or + Case 4 + Put (Xpos, Ypos), ImageArray(ImageIndex(ImageNo)), Xor + Case 5 + Put (Xpos, Ypos), ImageArray(ImageIndex(ImageNo)), And + End Select + Next n + +End Sub + +'* FadePalette() subroutine: +'* Gradually fades the current display in or out by fading all the colours in +'* the currently active palette down (fade to black) or up (restore colours). +'* +'* Parameters: +'* Direction - Dictates what direction the currently active colour +'* palette should be faded in: +'* Use FADEDOWN to fade down all colours to black. +'* Use FADEUP to fade up all colours from black to their +'* true colours. +'* PaletteArray&() - Palette array holding the colours of the currently +'* active colour palette. +'* +Sub FadePalette (Direction, PaletteArray&()) + + If Direction = FADEDOWN Then + '*** Fade palette down *** + + 'Break down all 256 colours into their RGB values and + 'calculate how much each will need fading down by. + Dim RGBval!(0 To 255, 0 To 2) + Dim SubVal!(0 To 255, 0 To 2) + For n = 0 To 255 + c& = PaletteArray&(n) + b = c& \ 65536: c& = c& - b * 65536 + g = c& \ 256: c& = c& - g * 256 + r = c& + RGBval!(n, 0) = r + RGBval!(n, 1) = g + RGBval!(n, 2) = b + SubVal!(n, 0) = r / 63 + SubVal!(n, 1) = g / 63 + SubVal!(n, 2) = b / 63 + Next n + + 'Fade down all 256 colours in 63 steps. + For j = 1 To 63 + 'Calculate new faded down RGB values. + For n = 0 To 255 + RGBval!(n, 0) = RGBval!(n, 0) - SubVal!(n, 0) + RGBval!(n, 1) = RGBval!(n, 1) - SubVal!(n, 1) + RGBval!(n, 2) = RGBval!(n, 2) - SubVal!(n, 2) + Next n + + 'Write faded down colours directly to the video card. + Wait &H3DA, &H8, &H8: Wait &H3DA, &H8 + For n = 0 To 255 + Out &H3C8, n 'Select attribute. + Out &H3C9, RGBval!(n, 0) 'Write red. + Out &H3C9, RGBval!(n, 1) 'Write green. + Out &H3C9, RGBval!(n, 2) 'Write blue. + Next n + Next j + Else + '*** Fade palette up *** + + 'Break down all 256 colours into their RGB values and + 'calculate how much each will need fading up by. + Dim RGBval!(0 To 255, 0 To 2) + Dim AddVal!(0 To 255, 0 To 2) + For n = 0 To 255 + c& = PaletteArray&(n) + b = c& \ 65536: c& = c& - b * 65536 + g = c& \ 256: c& = c& - g * 256 + r = c& + AddVal!(n, 0) = r / 63 + AddVal!(n, 1) = g / 63 + AddVal!(n, 2) = b / 63 + Next n + + 'Fade up all 256 colours in 63 steps. + For j = 1 To 63 + 'Calculate new faded up RGB values. + For n = 0 To 255 + RGBval!(n, 0) = RGBval!(n, 0) + AddVal!(n, 0) + RGBval!(n, 1) = RGBval!(n, 1) + AddVal!(n, 1) + RGBval!(n, 2) = RGBval!(n, 2) + AddVal!(n, 2) + Next n + + 'Write faded up colours directly to the video card. + Wait &H3DA, &H8, &H8: Wait &H3DA, &H8 + For n = 0 To 255 + Out &H3C8, n 'Select attribute. + Out &H3C9, RGBval!(n, 0) 'Write red. + Out &H3C9, RGBval!(n, 1) 'Write green. + Out &H3C9, RGBval!(n, 2) 'Write blue. + Next n + Next j + End If + +End Sub + +'* GetDepth() function: +'* Returns the depth (in pixels) of any image contained in an image array. +'* +'* Parameters: +'* ImNo - The number of the image to return the depth of. +'* ImageArray() - Image array that contains the image. +'* IndexArray() - Index array for the images in ImageArray(). +'* +Function GetDepth (ImNo, ImageArray(), IndexArray()) + + GetDepth = ImageArray(IndexArray(ImNo) + 1) + +End Function + +'* GetWidth() function: +'* Returns the width (in pixels) of any image contained in an image array. +'* +'* Parameters: +'* ImNo - The number of the image to return the width of. +'* ImageArray() - Image array that contains the image. +'* IndexArray() - Index array for the images in ImageArray(). +'* +Function GetWidth (ImNo, ImageArray(), IndexArray()) + + GetWidth = ImageArray(IndexArray(ImNo)) \ 8 + +End Function + +'* GraphicText() subroutine: +'* Displays a text string at a graphics screen coordinate, using a bitmapped +'* character set. +'* +'* Parameters: +'* x - Horizontal coordinate of where printing should start or: +'* Use FROMCURSOR to use the current graphics cursor X +'* coordinate. +'* Use CENTRETEXT to have the text centred. +'* y - Vertical coordinate of where printing should start or +'* use FROMCURSOR to use the current graphics cursor Y +'* coordinate. +'* Text$ - The text string to be displayed. +'* CursorPos - Dictates where the graphics cursor should be left after +'* the text has been displayed: +'* Use NEWLINE to move the cursor to the start of a new line. +'* Use TEXTEND to leave the cursor directly after the last +'* character displayed. +'* ImageArray() - Image array holding the character set to be used. Each +'* character must in the standard ASCII order, starting with +'* the space character. +'* IndexArray() - Index array for the character images in ImageArray(). +'* +Sub GraphicText (x, y, Text$, CursorPos, ImageArray(), IndexArray()) + + MessLen = Len(Text$) + If x = CENTRETEXT Then + 'Find start X coordinate for centred text. + w = 0 + For n = 1 To MessLen + CharNo = Asc(Mid$(Text$, n, 1)) - 31 + w = w + GetWidth(CharNo, ImageArray(), IndexArray()) + Next n + x = (320 - w) \ 2 + ElseIf x = FROMCURSOR Then + 'Use current X coordinate. + x = Point(0) + End If + + 'Use current Y coordinate if requested. + If y = FROMCURSOR Then y = Point(1) + + CharDepth = GetDepth(1, ImageArray(), IndexArray()) + + 'Loop to display each character of Text$. + For n = 1 To MessLen + CharNo = Asc(Mid$(Text$, n, 1)) - 31 + CharWidth = GetWidth(CharNo, ImageArray(), IndexArray()) + + 'Screen coordinate management for current character. + If x + CharWidth > 320 Then + x = 0 + If (y + CharDepth + CharDepth - 1) > 199 Then + y = 200 - CharDepth + Else + y = y + CharDepth + End If + End If + + Put (x, y), ImageArray(IndexArray(CharNo)), PSet + x = x + CharWidth + Next n + + 'Ensure x and y are valid screen coordinates. + If x > 319 Then + x = 0 + If (y + CharDepth + CharDepth - 1) > 199 Then + y = 200 - CharDepth + Else + y = y + CharDepth + End If + End If + + 'Update graphics cursor to required position before exiting. + If CursorPos = NEWLINE Then + 'Check a new line is actually required. + If x <> 0 Then + x = 0 + If (y + CharDepth + CharDepth - 1) > 199 Then + y = 200 - CharDepth + Else + y = y + CharDepth + End If + End If + End If + PSet (x, y), Point(x, y) + +End Sub + +'* InitDesignData() subroutine: +'* Initializes a DesignType array with screen design data - this must be done +'* before displaying a screen design using the DisplayDesign() routine. The +'* calling value of FileName$ dictates whether the data should be read +'* directly from a screen design file or from DATA statements (see below). +'* +'* Parameters: +'* FileName$ - The name of the screen design file to load. This must +'* include the path to the file if it does not reside in the +'* current directory. If FileName$ is an empty string (""), +'* screen design data is read from DATA statements. +'* DesignArray() - Dynamic, DesignType array to hold the screen design data. +'* +'* Note: Before calling InitDesignData() to initialize a screen design from +'* DATA statements, use an appropriate RESTORE statement to ensure the +'* correct DATA statements are read. +'* +Sub InitDesignData (FileName$, DesignArray() As DesignType) + + If FileName$ <> "" Then + '***** Read screen design data from file ***** + + 'Establish size of DesignType array required. + FileNo = FreeFile + Open FileName$ For Binary As #FileNo + ItemCount = (LOF(FileNo) - 7) \ 8 + Close #FileNo + ReDim DesignArray(0 To ItemCount) As DesignType + + 'Load screen design data directly into array memory. + Def Seg = VarSeg(DesignArray(0)) + BLoad FileName$, 0 + Def Seg + Else + '***** Read screen design data from DATA statements ***** + + 'Establish size of DesignType array required. + Read ItemCount + ReDim DesignArray(0 To ItemCount) As DesignType + + 'READ screen design DATA into array. + For n = 1 To ItemCount + Read ImageNo, Xpos, Ypos, DisAct + DesignArray(n).ImageNo = ImageNo + DesignArray(n).Xpos = Xpos + DesignArray(n).Ypos = Ypos + DesignArray(n).DisAct = DisAct + Next n + End If + +End Sub + +'* InitImageData() subroutine: +'* Initializes an integer array with image data - this must be done before +'* displaying an image using the PUT(graphics) statement. The calling value +'* of FileName$ dictates whether the data should be read directly from an +'* image file or from DATA statements (see below). +'* +'* Parameters: +'* FileName$ - The name of the image file to load. This must include the +'* path to the file if it does not reside in the current +'* directory. If FileName$ is an empty string (""), image +'* data is read from DATA statements. +'* ImageArray() - Dynamic, integer array to hold the image data. +'* +'* Note: Before calling InitImageData() to initialize images from DATA +'* statements, use an appropriate RESTORE statement to ensure the +'* correct DATA statements are read. +'* +Sub InitImageData (FileName$, ImageArray()) + + If FileName$ <> "" Then + '***** Read image data from file ***** + + 'Establish size of integer array required. + FileNo = FreeFile + Open FileName$ For Binary As #FileNo + Ints = (LOF(FileNo) - 7) \ 2 + Close #FileNo + ReDim ImageArray(1 To Ints) + + 'Load image data directly into array memory. + Def Seg = VarSeg(ImageArray(1)) + BLoad FileName$, 0 + Def Seg + Else + '***** Read image data from DATA statements ***** + + 'Establish size of integer array required. + Read IntCount + ReDim ImageArray(1 To IntCount) + + 'READ image DATA into array. + For n = 1 To IntCount + Read x + ImageArray(n) = x + Next n + End If + +End Sub + +'* InitPaletteData() subroutine: +'* Initializes a long integer array with palette colour data - this must be +'* done before changing palettes with the PALETTE USING statement. The +'* calling value of FileName$ dictates whether the data should be read +'* directly from a palette file or from DATA statements (see below). +'* +'* Parameters: +'* FileName$ - The name of the palette file to load. This must include +'* the path to the file if it does not reside in the +'* current directory. If FileName$ is an empty string (""), +'* palette data is read from DATA statements. +'* PaletteArray&() - Dynamic, long integer array to hold palette data. +'* +'* Note: Before calling InitPaletteData() to initialize a palette from DATA +'* statements, use an appropriate RESTORE statement to ensure the +'* correct DATA statements are read. +'* +Sub InitPaletteData (FileName$, PaletteArray&()) + + 'Size array to hold all 256 colours. + ReDim PaletteArray&(0 To 255) + + If FileName$ <> "" Then + '*** Read palette data from file *** + FileNo = FreeFile + Open FileName$ For Binary As #FileNo + For n = 0 To 255 + Get #FileNo, , colour& + PaletteArray&(n) = colour& + Next n + Close #FileNo + Else + '*** Read palette data from DATA statements *** + For n = 0 To 255 + Read colour& + PaletteArray&(n) = colour& + Next n + End If + +End Sub + +'* MakeImageIndex() subroutine: +'* Constructs an image position index for the images held in an image array. +'* +'* Parameters: +'* ImageArray() - Dynamic, integer array holding images to be indexed. +'* IndexArray() - Dynamic, integer array to hold the index for images in +'* ImageArray(). +'* +Sub MakeImageIndex (ImageArray(), IndexArray()) + + 'The index will initially be built in a temporary array, allowing + 'for the maximum 1000 images per file. + Dim Temp(1 To 1000) + Ptr& = 1: IndexNo = 1: LastInt = UBound(ImageArray) + Do + Temp(IndexNo) = Ptr& + IndexNo = IndexNo + 1 + + 'Evaluate descriptor of currently referenced image to + 'calculate the beginning of the next image. + x& = (ImageArray(Ptr&) \ 8) * (ImageArray(Ptr& + 1)) + 4 + If x& Mod 2 Then x& = x& + 1 + Ptr& = Ptr& + (x& \ 2) + Loop While Ptr& < LastInt + + LastImage = IndexNo - 1 + + 'Copy the image index values into the actual index array. + ReDim IndexArray(1 To LastImage) + For n = 1 To LastImage + IndexArray(n) = Temp(n) + Next n + +End Sub + +'* RotatePalette() subroutine: +'* Rotates a contiguous range of colour attributes in the currently +'* active palette to the left or right. +'* +'* Parameters: +'* StartAttr - First attribute of the range to be rotated. +'* EndAttr - Last attribute of the range to be rotated. +'* Direction - Dictates what direction the selected colours should +'* be rotated in: +'* Use ROTATELEFT to rotate colours to the left. +'* Use ROTATERIGHT to rotate colours to the right. +'* PaletteArray&() - Palette array holding the colours of the currently +'* active colour palette. +'* +Sub RotatePalette (StartAttr, EndAttr, Direction, PaletteArray&()) + + 'Rotate affected colours in PaletteArray&() in the requested direction. + If Direction = ROTATERIGHT Then + '*** Rotate right *** + Lastc& = PaletteArray&(EndAttr) + For n = EndAttr To StartAttr + 1 Step -1 + PaletteArray&(n) = PaletteArray&(n - 1) + Next n + PaletteArray&(StartAttr) = Lastc& + Else + '*** Rotate left *** + Lastc& = PaletteArray&(StartAttr) + For n = StartAttr To EndAttr - 1 + PaletteArray&(n) = PaletteArray&(n + 1) + Next n + PaletteArray&(EndAttr) = Lastc& + End If + + 'Break down the colours into their RGB values. + Dim RGBval(StartAttr To EndAttr, 0 To 2) + For n = StartAttr To EndAttr + c& = PaletteArray&(n) + b = c& \ 65536: c& = c& - b * 65536 + g = c& \ 256: c& = c& - g * 256 + r = c& + RGBval(n, 0) = r + RGBval(n, 1) = g + RGBval(n, 2) = b + Next n + + 'Write colours directly to the video card. + Wait &H3DA, &H8, &H8: Wait &H3DA, &H8 + For n = StartAttr To EndAttr + Out &H3C8, n 'Select attribute. + Out &H3C9, RGBval(n, 0) 'Write red. + Out &H3C9, RGBval(n, 1) 'Write green. + Out &H3C9, RGBval(n, 2) 'Write blue. + Next n + +End Sub + +'* Scroller() subroutine: +'* Displays a scrolling message along the bottom of the screen, using a +'* bitmapped character set. +'* +'* Parameters: +'* ScrollAct - Dictates what action should be done: +'* Use INITSCROLL to initialize a new scroller message. +'* Use UPDATESCROLL to update the scroller display. +'* ImageArray() - Image array holding the character set to be used. Each +'* character must be a 16x8 image and be in the standard +'* ASCII order, starting with the space character. +'* IndexArray() - Index array for the character images in ImageArray(). +'* +'* Note: Before calling Scroller() to initialize a new scrolling message +'* from DATA statements, use an appropriate RESTORE statement to +'* ensure the correct DATA statements are read. +'* +Sub Scroller (ScrollAct, ImageArray(), IndexArray()) + + 'Retain variable settings between calls. + Static MessChar(), FirstX, CharPtr, MessLen, ScrollMess$ + + If ScrollAct = INITSCROLL Then + '*** Initialize scroller *** + ReDim MessChar(1 To 19) + For n = 1 To 19: MessChar(n) = 1: Next n + + 'Read entire scroller text into ScrollMess$ from module-level DATA. + ScrollMess$ = "" + Do + Read x$ + ScrollMess$ = ScrollMess$ + x$ + Loop Until x$ = "" + + MessLen = Len(ScrollMess$) + CharPtr = 1 + FirstX = 16 + Else + '*** Update scroller message display *** + x = FirstX + Wait &H3DA, &H8, &H8: Wait &H3DA, &H8 + For n = 1 To 19 + Put (x, 192), ImageArray(MessChar(n)), PSet + x = x + 16 + Next n + + 'Display two end characters (spaces) to tidy up message appearance. + Put (0, 192), ImageArray(IndexArray(1)), PSet + Put (304, 192), ImageArray(IndexArray(1)), PSet + + 'Variable management ready for next Scroller(UPDATESCROLL) call. + FirstX = FirstX - 2 + If FirstX = 0 Then + FirstX = 16 + For n = 1 To 18 + MessChar(n) = MessChar(n + 1) + Next n + + If CharPtr > MessLen Then CharPtr = 1 + MessChar(19) = IndexArray(Asc(Mid$(ScrollMess$, CharPtr, 1)) - 31) + CharPtr = CharPtr + 1 + End If + End If + +End Sub + +'* WizzText() subroutine: +'* Centres a single line of text on the screen using a bitmapped character +'* set. Each character is whizzed across the screen in turn (from right to +'* left) to it's destination position. +'* +'* Parameters: +'* Text$ - The single line text message to be displayed. +'* TopLine - Screen Y coordinate to be the top line for the displayed +'* text message. +'* ImageArray() - Image array holding the character set to be used. Each +'* character must be a 16x8 image and be in the standard +'* ASCII order, starting with the space character. +'* IndexArray() - Index array for the character images in ImageArray(). +'* +Sub WizzText (Text$, TopLine, ImageArray(), IndexArray()) + + 'Calculate X coordinate for first character. + MessLen = Len(Text$) + HomeX = (320 - (MessLen * 16)) \ 2 + + 'Loop to display each character of Text$. + For n = 1 To MessLen + x$ = Mid$(Text$, n, 1) + + 'Ignore space characters. + If x$ <> Chr$(32) Then + CharIdx = IndexArray(Asc(x$) - 31) + OldX = 304 + + 'Move character across the screen to destination position. + For x = 304 To HomeX Step -8 + Wait &H3DA, &H8, &H8: Wait &H3DA, &H8 + Line (OldX, TopLine)-Step(15, 7), 0, BF + Put (x, TopLine), ImageArray(CharIdx), PSet + OldX = x + Next x + End If + + HomeX = HomeX + 16 + Next n + +End Sub + diff --git a/samples/plasma-non-pal/index.md b/samples/plasma-non-pal/index.md index eb04e764..b77cd7df 100644 --- a/samples/plasma-non-pal/index.md +++ b/samples/plasma-non-pal/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: NON-PALETTE ROTATED PLASMA +## SAMPLE: PLASMA NON-PAL ![screenshot.png](img/screenshot.png) diff --git a/samples/plasma.md b/samples/plasma.md index 8c8dc4f1..c88ed012 100644 --- a/samples/plasma.md +++ b/samples/plasma.md @@ -2,7 +2,7 @@ ## SAMPLES: PLASMA -**[Non-Palette Rotated Plasma](plasma-non-pal/index.md)** +**[Plasma Non-Pal](plasma-non-pal/index.md)** [🐝 Relsoft](relsoft.md) 🔗 [screensaver](screensaver.md), [plasma](plasma.md) diff --git a/samples/platform.md b/samples/platform.md new file mode 100644 index 00000000..6f93a994 --- /dev/null +++ b/samples/platform.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: PLATFORM + +**[Platform](platform/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [platform](platform.md) + +# Platform What does a 2D platform game take? Made with QB64. diff --git a/samples/platform/img/ss1.png b/samples/platform/img/ss1.png new file mode 100644 index 00000000..e573cfdc Binary files /dev/null and b/samples/platform/img/ss1.png differ diff --git a/samples/platform/img/ss2.png b/samples/platform/img/ss2.png new file mode 100644 index 00000000..d2f513be Binary files /dev/null and b/samples/platform/img/ss2.png differ diff --git a/samples/platform/index.md b/samples/platform/index.md new file mode 100644 index 00000000..679caee3 --- /dev/null +++ b/samples/platform/index.md @@ -0,0 +1,34 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: PLATFORM + +![ss1.png](img/ss1.png) + +### Author + +[🐝 Fellippe Heitor](../fellippe-heitor.md) + +### Description + +```text +# Platform + +What does a 2D platform game take? + +Made with QB64. +``` + +### File(s) + +* [mrjumps.bas](src/mrjumps.bas) +* [platform.bas](src/platform.bas) +* [platform.zip](src/platform.zip) + +### Additional Image(s) + +![ss2.png](img/ss2.png) + +🔗 [game](../game.md), [platform](../platform.md) + + +Reference: [github.com](https://github.com/FellippeHeitor/Platform) diff --git a/samples/platform/src/mrjumps.bas b/samples/platform/src/mrjumps.bas new file mode 100644 index 00000000..220b319e --- /dev/null +++ b/samples/platform/src/mrjumps.bas @@ -0,0 +1,410 @@ +Option _Explicit + +Const FALSE = 0, TRUE = Not false + +Screen _NewImage(800, 450, 32) + +Type newLevel + As _Unsigned Long landColor, grassColor, waterColor + As Long symbolSpacingX, symbolSpacingY +End Type + +Type object + As Long id, w, h, img + As Single x, xv, y, yv + As _Byte imgPointer, standing, alive + As _Unsigned Long color +End Type + +Const idPlatform = 1 +Const idGoal = 2 +Const idAirJump = 3 +Const idInfiniteJumps = 4 +Const idSpike = 5 +Const idCloud = 6 +Const idScene = 7 +Const idSky = 8 +Const idWater = 9 + +Dim Shared As Long thisLevel, arenaWidth, i, totalObjects, airJumps, hero, goal +Dim Shared As Single x, y, camera, gravity +Dim Shared As _Byte drowned, restartRequested, shadowCast +Dim Shared As String platformDecoration, goalGlyph, airJumpGlyph +Dim Shared As newLevel levelData +Dim Shared As object obj(100), shadowCastOn + +Randomize Timer + +goalGlyph = "C" + Str$(_RGB32(255, 255, 255)) + "e10f10g10 h8e8f6g6 h4 e4f2g1" +airJumpGlyph = "C" + Str$(_RGB32(255, 255, 255)) + "e10f10g10h10" +gravity = .8 +thisLevel = 1 + +Restart: +setLevel thisLevel + +Do + processInput + doPhysics + adjustCamera + drawObjects + If restartRequested Then restartRequested = FALSE: GoTo Restart + If Not drowned Then drawHero + checkVictory + + If Not obj(hero).alive Then + _PrintString (0, 0), "Dead" + _PrintString (0, 20), Str$((obj(hero).x / arenaWidth) * 100) + "%" + ElseIf obj(hero).standing Then + _PrintString (0, 0), "Standing" + End If + + _Display + _Limit 60 +Loop + +Sub addWater + Dim this As Long + this = newObject + obj(this).id = idWater + obj(this).img = _NewImage(_Width, _Height, 32) + _Dest obj(this).img + Line (0, _Height - _Height / 4)-Step(_Width, _Height / 4), darken(levelData.waterColor, 55), BF + Line (0, _Height - _Height / 4)-Step(_Width, _Height / 7), darken(levelData.waterColor, 70), BF + Line (0, _Height - _Height / 4)-Step(_Width, _Height / 9), darken(levelData.waterColor, 85), BF + Line (0, _Height - _Height / 4)-Step(_Width, _Height / 11), levelData.waterColor, BF + _Dest 0 +End Sub + +Sub drawObjects + For i = 1 To totalObjects + Select Case obj(i).id + Case idPlatform + _PutImage (obj(i).x + camera, obj(i).y), obj(i).img + Case idGoal + Draw "bm" + Str$(obj(goal).x + camera) + "," + Str$(obj(goal).y + obj(goal).h / 2) + Draw goalGlyph + Case idAirJump + Draw "bm" + Str$(obj(i).x + camera) + "," + Str$(obj(i).y + obj(i).h / 2) + Draw airJumpGlyph + Case idCloud + obj(i).x = obj(i).x - obj(i).xv + If obj(i).x + obj(i).w < 0 Then obj(i).x = arenaWidth + Line (obj(i).x + camera / 2.5, obj(i).y)-Step(obj(i).w, obj(i).h), _RGBA32(255, 255, 255, 30), BF + Case idScene + _PutImage (obj(i).x + camera / obj(i).xv, obj(i).y), obj(i).img + Case idSky + Line (0, 0)-(_Width, _Height), obj(i).color, BF + Case idWater + _PutImage , obj(i).img + End Select + Next +End Sub + +Sub processInput + Dim button As _Byte + + If _KeyHit = 27 Then + obj(hero).alive = TRUE + obj(hero).yv = 0 + restartRequested = TRUE + Exit Sub + End If + + If obj(hero).alive = FALSE Then Exit Sub + + 'keep hero moving forward + If obj(hero).x + obj(hero).w < arenaWidth + _Width Then obj(hero).x = obj(hero).x + 5 + + 'If _KeyDown(19712) Then 'character goes left, screen goes right + ' obj(hero).x = obj(hero).x + 5 + 'End If + + 'If _KeyDown(19200) Then 'character goes right, screen goes left + ' obj(hero).x = obj(hero).x - 5 + 'End If + + Static lastJump!, jumpKeyDown As _Byte + Const jumpFactor = 3 + + While _MouseInput: Wend + button = _MouseButton(1) Or _KeyDown(32) + + If button Then '18432 + If jumpKeyDown = FALSE And (obj(hero).standing = TRUE Or airJumps > 0) Then + If airJumps > 0 Then airJumps = airJumps - 1 + jumpKeyDown = TRUE + obj(hero).standing = FALSE + lastJump! = 0 + obj(hero).yv = obj(hero).yv - gravity * jumpFactor + Else + lastJump! = lastJump! + 1 + If lastJump! < 7 Then + obj(hero).yv = obj(hero).yv - gravity * jumpFactor + End If + End If + Else + jumpKeyDown = FALSE + End If +End Sub + +Sub adjustCamera + camera = _Width / 4 - obj(hero).x + If camera > 0 Then camera = 0 + If camera < -arenaWidth Then camera = -arenaWidth +End Sub + +Sub drawHero + Dim shadow As object + Line (obj(hero).x + camera, obj(hero).y)-Step(obj(hero).w, obj(hero).h), obj(hero).color, BF + + If obj(hero).alive Then + If shadowCast Then + 'shadow already cast on a platform + shadow.x = (obj(hero).x + 1) + camera + shadow.y = shadowCastOn.y + 5 + shadow.w = obj(hero).w - 2 + Do While shadow.x < shadowCastOn.x + camera + shadow.x = shadow.x + 1 + shadow.w = shadow.w - 1 + Loop + Do While shadow.x + shadow.w > shadowCastOn.x + shadowCastOn.w + camera + shadow.w = shadow.w - 1 + Loop + Line (shadow.x, shadow.y)-Step(shadow.w, 2), _RGBA32(0, 0, 0, 30), BF + Else + 'cast shadow on water + Line ((obj(hero).x + 1) + camera, _Height - _Height / 4 + _Height / 22)-Step(obj(hero).w - 2, 2), _RGBA32(0, 0, 0, 30), BF + End If + End If +End Sub + +Sub doPhysics + Dim j As Long + + If Not obj(hero).alive Then Exit Sub + + Const gravityCap = 15 + + obj(hero).standing = FALSE + drowned = FALSE + If obj(hero).y + obj(hero).yv + gravity > _Height - _Height / 4 + _Height / 22 Then drowned = TRUE: obj(hero).alive = FALSE: Exit Sub + + shadowCast = FALSE + For j = 1 To totalObjects + If obj(j).id = idPlatform Then + If obj(hero).x + obj(hero).w > obj(j).x And obj(hero).x < obj(j).x + obj(j).w Then + shadowCast = TRUE + shadowCastOn = obj(j) + + If obj(hero).y + obj(hero).yv + gravity < obj(j).y - (obj(hero).h - 5) Then + Exit For + ElseIf obj(hero).y + obj(hero).yv + gravity <= obj(j).y - (obj(hero).h - 20) Then + obj(hero).standing = TRUE + obj(hero).y = obj(j).y - (obj(hero).h - 5) + Exit For + ElseIf obj(hero).y >= obj(j).y - (obj(hero).h - 20) Then + obj(hero).alive = FALSE + Exit For + End If + End If + End If + Next + + If Not obj(hero).standing Then + obj(hero).yv = obj(hero).yv + gravity + If obj(hero).yv > gravityCap Then obj(hero).yv = gravityCap + obj(hero).y = obj(hero).y + obj(hero).yv + obj(hero).color = _RGB32(255, 255, 255) + Else + obj(hero).yv = 0 + obj(hero).color = _RGB32(200, 200, 200) + End If +End Sub + +Function hit%% (obj1 As object, obj2 As object) + hit%% = obj1.x + obj1.w > obj2.x And obj1.x <= obj2.x + obj2.w And obj1.y + obj1.h > obj2.y And obj1.y < obj2.y + obj2.h +End Function + +Function darken~& (WhichColor~&, ByHowMuch%) + darken~& = _RGB32(_Red32(WhichColor~&) * (ByHowMuch% / 100), _Green32(WhichColor~&) * (ByHowMuch% / 100), _Blue32(WhichColor~&) * (ByHowMuch% / 100)) +End Function + + +Sub setLevel (level As Long) + 'the order of creation of objects is also the draw order + + Dim totalPlatforms As Long + Dim this As Long, firstPlatform As Long + + resetObjects + Select Case level + Case 1 + arenaWidth = 3200 + totalPlatforms = 30 + levelData.landColor = _RGB32(194, 127, 67) + levelData.waterColor = _RGB32(33, 166, 188) + levelData.grassColor = _RGB32(83, 161, 72) + + this = newObject + obj(this).id = idSky + obj(this).color = _RGB32(67, 200, 205) + + addScene level + + addWater + + addClouds 5 + + platformDecoration = "c" + Str$(_RGB32(166, 111, 67)) + " bd5 e10r1g10r1e10r1g10r1e10r1g10r1e10r1g10" + levelData.symbolSpacingX = 11 + levelData.symbolSpacingY = 11 + For i = 1 To totalPlatforms + this = newObject + obj(this).id = idPlatform + obj(this).w = Rnd * 200 + 100 + obj(this).w = obj(this).w - (obj(this).w Mod 20) + If i = 1 Then + firstPlatform = this + obj(this).h = 200 + obj(this).x = Rnd * (arenaWidth / totalPlatforms) + Else + obj(this).h = Rnd * 50 + 50 + obj(this).x = obj(this - 1).x + obj(this - 1).w + (Rnd * (arenaWidth / (totalPlatforms * 1.5))) + End If + obj(this).y = (_Height - _Height / 4 + (_Height / 20)) - obj(this).h + drawPlatform obj(this) + Next + + goal = newObject + obj(goal).id = idGoal + obj(goal).x = arenaWidth + obj(goal).y = _Height / 2 + obj(goal).h = 20 + obj(goal).w = 20 + + hero = newObject + obj(hero).x = obj(firstPlatform).x + obj(hero).y = obj(firstPlatform).y - 25 + obj(hero).w = 15 + obj(hero).h = 30 + obj(hero).alive = TRUE + obj(hero).standing = TRUE + End Select +End Sub + +Function newObject& + totalObjects = totalObjects + 1 + If totalObjects > UBound(obj) Then + ReDim _Preserve obj(totalObjects + 99) As object + End If + newObject& = totalObjects +End Function + +Sub resetObjects + Dim emptyObject As object + For i = 1 To UBound(obj) + If obj(i).img < -1 And obj(i).imgPointer = FALSE Then _FreeImage obj(i).img + obj(i) = emptyObject + Next + totalObjects = 0 +End Sub + +Sub drawPlatform (this As object) + this.img = _NewImage(this.w, this.h, 32) + _Dest this.img + Line (0, 10)-Step(this.w - 1, this.h - 1), levelData.landColor, BF + For x = -10 To this.w Step levelData.symbolSpacingX + For y = 15 To this.h + 10 Step levelData.symbolSpacingY + PSet (x, y), 0 + Draw platformDecoration + Next + Next + Line (0, 0)-Step(this.w - 1, 20), levelData.grassColor, BF + Line (0, 0)-Step(this.w - 1, 10), _RGBA32(255, 255, 255, 30), BF + Line (0, 10)-Step(5, this.h), _RGBA32(255, 255, 255, 30), BF + Line (this.w - 6, 10)-Step(5, this.h), _RGBA32(0, 0, 0, 30), BF + + Line (0, 5)-(5, 0), _RGB32(255, 0, 255) + Paint (0, 0), _RGB32(255, 0, 255), _RGB32(255, 0, 255) + Line (_Width - 1, 5)-(_Width - 6, 0), _RGB32(255, 0, 255) + Paint (_Width - 1, 0), _RGB32(255, 0, 255), _RGB32(255, 0, 255) + Line (0, this.h - 4)-Step(this.w, 3), _RGB32(255, 0, 255), BF + _ClearColor _RGB32(255, 0, 255) + Line (0, this.h - 5)-Step(this.w - 1, 5), _RGBA32(0, 0, 0, 30), BF + _Dest 0 +End Sub + +Sub addClouds (max As Long) + Dim this As Long + + For i = 1 To max + this = newObject + obj(this).id = idCloud + obj(this).x = Rnd * arenaWidth + obj(this).y = Rnd * (_Height / 2) + obj(this).h = 30 + obj(this).w = arenaWidth / max + obj(this).xv = Rnd + Next +End Sub + +Sub addScene (level As Long) + Dim this As Long, firstItem As Long + + Select Case level + Case 1 + 'green mountains, 2 layers + + 'farther range + For i = 1 To 20 + this = newObject + If i = 1 Then + firstItem = this + obj(this).img = _NewImage(_Width, _Height, 32) + _Dest obj(this).img + Line (0, _Height - 1)-(_Width / 2, 0), _RGB32(100, 150, 122) + Line -(_Width - 1, _Height - 1), _RGB32(100, 150, 122) + Line -(0, _Height - 1), _RGB32(100, 150, 122) + Paint (_Width / 2, _Height / 2), _RGB32(100, 150, 122), _RGB32(100, 150, 122) + _Dest 0 + Else + obj(this).img = obj(firstItem).img + obj(this).imgPointer = TRUE + End If + + obj(this).id = idScene + obj(this).x = Rnd * arenaWidth + obj(this).y = Rnd * (_Height / 2) + obj(this).xv = 2.5 + Next + + 'closer range + For i = 1 To 20 + this = newObject + If i = 1 Then + firstItem = this + obj(this).img = _NewImage(_Width, _Height, 32) + _Dest obj(this).img + Line (0, _Height - 1)-(_Width / 2, 0), _RGB32(78, 111, 67) + Line -(_Width - 1, _Height - 1), _RGB32(78, 111, 67) + Line -(0, _Height - 1), _RGB32(78, 111, 67) + Paint (_Width / 2, _Height / 2), _RGB32(78, 111, 67), _RGB32(78, 111, 67) + _Dest 0 + Else + obj(this).img = obj(firstItem).img + obj(this).imgPointer = TRUE + End If + + obj(this).id = idScene + obj(this).x = Rnd * arenaWidth + obj(this).y = Rnd * (_Height / 2) + obj(this).xv = 2 + Next + End Select +End Sub + +Sub checkVictory + If hit(obj(hero), obj(goal)) Then _AutoDisplay: _PrintString (_Width / 2 - _PrintWidth("Level complete!") / 2, _Height / 2 - _FontHeight / 2), "Level complete!": restartRequested = TRUE: Sleep +End Sub + diff --git a/samples/platform/src/platform.bas b/samples/platform/src/platform.bas new file mode 100644 index 00000000..4e9c0433 --- /dev/null +++ b/samples/platform/src/platform.bas @@ -0,0 +1,340 @@ +Const FALSE = 0, TRUE = Not FALSE + +Const objHero = 1 +Const objEnemy = 2 +Const objFloor = 3 +Const objBonus = 4 +Const objBackground = 5 +Const objBlock = 6 + +Dim Shared kinds(1 To 6) As String +kinds(1) = "Hero" +kinds(2) = "Enemy" +kinds(3) = "Floor" +kinds(4) = "Bonus" +kinds(5) = "Background" +kinds(6) = "Block" + +Const objShapeRect = 0 +Const objShapeRound = 1 +Const g = 1 + +Type Objects + kind As Integer + shape As Integer + x As Integer + xv As Single + y As Integer + yv As Single + w As Integer + h As Integer + color As _Unsigned Long + landedOn As Long + taken As _Byte +End Type + +ReDim Shared Object(1 To 100) As Objects +Dim Shared TotalObjects As Long +Dim Shared Hero As Long, NewObj As Long +Dim Shared Dead As _Byte, CameraX As Long, CameraY As Long +Dim Shared Points As Long + +Screen _NewImage(800, 600, 32) +_PrintMode _KeepBackground + +Do + Level = Level + 1 + SetLevel Level + + Do + ProcessInput + DoPhysics + UpdateScreen + _Limit 35 + Loop +Loop + +System + +Function AddObject (Kind As Integer, x As Single, y As Single, w As Single, h As Single, c As _Unsigned Long) + TotalObjects = TotalObjects + 1 + If TotalObjects > UBound(Object) Then + ReDim _Preserve Object(1 To UBound(Object) + 99) As Objects + End If + + Object(TotalObjects).kind = Kind + + Object(TotalObjects).x = x + Object(TotalObjects).y = y + Object(TotalObjects).w = w + Object(TotalObjects).h = h + Object(TotalObjects).color = c + + AddObject = TotalObjects +End Function + +Sub ProcessInput + Static JumpButton As _Byte + If _KeyDown(19712) And Not Dead Then + If _KeyDown(100306) Then + Object(Hero).x = Object(Hero).x + 1 + Do While _KeyDown(19712): Loop + Else + If Object(Hero).xv < 0 Then + Object(Hero).xv = Object(Hero).xv + 2 + Else + Object(Hero).xv = 4 + End If + End If + End If + If _KeyDown(19200) And Not Dead Then + If _KeyDown(100306) Then + Object(Hero).x = Object(Hero).x - 1 + Do While _KeyDown(19200): Loop + Else + If Object(Hero).xv > 0 Then + Object(Hero).xv = Object(Hero).xv - 2 + Else + Object(Hero).xv = -4 + End If + End If + End If + If _KeyDown(18432) And Not Dead Then + If Not JumpButton Then + JumpButton = TRUE + If Object(Hero).landedOn > 0 Then Object(Hero).yv = -20: Object(Hero).landedOn = 0 + End If + ElseIf Not _KeyDown(18432) Then + If JumpButton Then JumpButton = FALSE + End If + If _KeyDown(13) And Dead Then + Dead = 0 + Object(Hero).x = 25 + Object(Hero).y = _Height - _Height / 5 - 22 + Object(Hero).yv = 0 + Object(Hero).xv = 0 + Object(Hero).landedOn = 0 + End If + If _KeyDown(27) Then System +End Sub + +Sub DoPhysics + For i = 1 To TotalObjects + If Object(i).kind = objHero Or Object(i).kind = objEnemy Then + + If Object(i).kind = objEnemy Then + If Object(Hero).x < Object(i).x Then Object(i).xv = -1.5 Else Object(i).xv = 1.5 + End If + + Object(i).x = Object(i).x + Object(i).xv + Object(i).y = Object(i).y + Object(i).yv + + If Object(i).landedOn = 0 Then + Object(i).yv = Object(i).yv + g + End If + + For j = 1 To TotalObjects + + If Object(i).yv < 0 Then + If Object(j).kind = objBlock Then + If Object(i).x + Object(i).w > Object(j).x And Object(i).x < Object(j).x + Object(j).w Then + If Object(i).y > Object(j).y And Object(i).y < Object(j).y + Object(j).h + 1 Then + Object(i).yv = 2 + Object(i).y = Object(i).y + 2 + If Object(j).taken = FALSE Then + Object(j).taken = TRUE + Object(j).color = _RGB32(122, 100, 78) + End If + Exit For + End If + End If + End If + End If + + If Object(i).kind = objHero And Object(j).kind = objBonus And Object(j).taken = FALSE Then + If Object(i).y + Object(i).h >= Object(j).y And Object(i).y <= Object(j).y + Object(j).h Then + If Object(i).x + Object(i).w > Object(j).x And Object(i).x < Object(j).x + Object(j).w Then + Object(j).taken = TRUE + Points = Points + 10 + Exit For + End If + End If + End If + + If Object(i).xv > 0 Then + If Object(j).kind = objBlock Or Object(j).kind = objEnemy Then + If Object(i).y + Object(i).h >= Object(j).y And Object(i).y <= Object(j).y + Object(j).h Then + If Object(i).x + Object(i).w > Object(j).x And Object(i).x < Object(j).x + Object(j).w Then + Object(i).x = Object(j).x - Object(i).w - 1 + Object(i).xv = 0 + If Object(i).kind = objHero And Object(j).kind = objEnemy And Object(j).taken = FALSE Then Dead = TRUE: Object(j).taken = TRUE + Exit For + End If + End If + End If + ElseIf Object(i).xv < 0 Then + If Object(j).kind = objBlock Then + If Object(i).y + Object(i).h >= Object(j).y And Object(i).y <= Object(j).y + Object(j).h Then + If Object(i).x + Object(i).w > Object(j).x And Object(i).x < Object(j).x + Object(j).w Then + Object(i).x = Object(j).x + Object(j).w + 1 + Object(i).xv = 0 + If Object(i).kind = objHero And Object(j).kind = objEnemy And Object(j).taken = FALSE Then Dead = TRUE: Object(j).taken = TRUE + Exit For + End If + End If + End If + End If + + If Object(i).yv >= 0 Then + If Object(j).kind = objFloor Or Object(j).kind = objBlock Then + If Object(i).x + Object(i).w >= Object(j).x And Object(i).x <= Object(j).x + Object(j).w Then + If Object(i).y + Object(i).h > Object(j).y And Object(i).y < Object(j).y + Object(j).h Then + Object(i).y = Object(j).y - Object(i).h - 1 + Object(i).yv = 0 + Object(i).landedOn = j + Exit For + End If + Else + If Object(i).landedOn = j Then + Object(i).landedOn = 0 + Exit For + End If + End If + End If + End If + Next + + If Object(Hero).y > _Height Then Dead = TRUE + + If Object(i).xv > 0 Then Object(i).xv = Object(i).xv - 1 + If Object(i).xv < 0 Then Object(i).xv = Object(i).xv + 1 + If Object(i).yv <> 0 Then Object(i).yv = Object(i).yv + g + End If + Next + + If Object(Hero).x + CameraX > _Width / 2 Then + CameraX = _Width / 2 - Object(Hero).x + ElseIf Object(Hero).x + CameraX < _Width / 5 Then + CameraX = _Width / 5 - Object(Hero).x + End If + + If Object(Hero).y + CameraY < _Height / 3 Then + CameraY = -Object(Hero).y + _Height / 3 + ElseIf Object(Hero).y + CameraY > _Height / 2 Then + CameraY = _Height / 2 - Object(Hero).y + End If + + If CameraX > 0 Then CameraX = 0 + If CameraY < 0 Then CameraY = 0 +End Sub + +Sub UpdateScreen + Cls + + Dim this As Objects + + For i = 1 To TotalObjects + this = Object(i) + If this.kind > 0 Then + If this.kind = objBackground Then + thisCameraX = CameraX / 2 + thisCameraY = CameraY / 2 + Else + thisCameraX = CameraX + thisCameraY = CameraY + End If + If (this.kind = objEnemy Or this.kind = objBonus) And this.taken Then GoTo Continue + If this.x + this.w + thisCameraX < 0 And this.shape <> objShapeRound Then + GoTo Continue + ElseIf thisCameraX + this.x + this.w + this.w / 2 < 0 And this.shape = objShapeRound Then + GoTo Continue + End If + If this.x + thisCameraX > _Width Then GoTo Continue + If this.shape = objShapeRect Then + Line (this.x + thisCameraX, this.y + thisCameraY)-Step(this.w, this.h), this.color, BF + Line (this.x + thisCameraX, this.y + thisCameraY)-Step(this.w, this.h), _RGB32(0, 0, 0), B + '_PRINTSTRING (this.x + CameraX, this.y), LTRIM$(STR$(this.x)) + STR$(this.x + this.w) + ElseIf this.shape = objShapeRound Then + For k = 1 To this.w + Circle (thisCameraX + this.x + this.w / 2, thisCameraY + this.y + this.h / 2), k, this.color, , , this.w / this.h + Next + Circle (thisCameraX + this.x + this.w / 2, thisCameraY + this.y + this.h / 2), this.w, _RGB32(0, 0, 0), , , this.w / this.h + End If + 'IF this.kind = objHero AND this.landedOn > 0 THEN _PRINTSTRING (this.x + CameraX, this.y - _FONTHEIGHT), "Landed on" + STR$(this.landedOn) + Print i; kinds(this.kind) + End If + Continue: + Next + + Print "CameraX"; CameraX + Print "CameraY"; CameraY + + If Dead Then + _PrintString (_Width / 2 - _PrintWidth("You're dead!") / 2, _Height / 2 - _FontHeight), "You're dead!" + _PrintString (_Width / 2 - _PrintWidth("(hit ENTER)") / 2, _Height / 2 + _FontHeight), "(hit ENTER)" + End If + + If Points > 0 Then _PrintString (0, 0), Str$(Points) + + _Display +End Sub + +Sub SetLevel (__Level As Integer) + Dim Level As Integer, MaxLevels As Integer + + MaxLevels = 1 + + If __Level > MaxLevels Then + Level = _Ceil(Rnd * MaxLevels) + Else + Level = __Level + End If + + Select Case Level + Case 1 + NewObj = AddObject(objBackground, 0, 0, _Width * 2, _Height, _RGB32(61, 161, 222)) + + For i = 1 To 10 + NewObj = AddObject(objBackground, Rnd * _Width * 2, Rnd * -_Height, 50, 100, _RGB32(255, 255, 255)) + Object(NewObj).shape = objShapeRound + Next + + NewObj = AddObject(objFloor, 20, _Height - _Height / 5, _Width * 1.5, 150, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 1300, _Height - _Height / 5, _Width * 1.5, 150, _RGB32(111, 89, 50)) + + NewObj = AddObject(objFloor, 110, 400, 110, 10, _RGB32(111, 89, 50)) + + NewObj = AddObject(objFloor, 400, 400, 110, 10, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 575, 330, 110, 10, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 700, 260, 110, 10, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 875, 200, 110, 10, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 1000, 140, 110, 10, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 1175, 70, 110, 10, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 1000, 10, 110, 10, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 875, -50, 110, 10, _RGB32(111, 89, 50)) + NewObj = AddObject(objFloor, 700, -110, 110, 10, _RGB32(111, 89, 50)) + + NewObj = AddObject(objBlock, 20, 400, 25, 25, _RGB32(216, 166, 50)) + + NewObj = AddObject(objBlock, 200, _Height - _Height / 5 - 16, 15, 15, _RGB32(216, 166, 50)) + NewObj = AddObject(objBlock, 216, _Height - _Height / 5 - 16, 15, 15, _RGB32(216, 166, 50)) + NewObj = AddObject(objBlock, 232, _Height - _Height / 5 - 16, 15, 15, _RGB32(216, 166, 50)) + NewObj = AddObject(objBlock, 216, _Height - _Height / 5 - 32, 15, 15, _RGB32(216, 166, 50)) + NewObj = AddObject(objBlock, 232, _Height - _Height / 5 - 32, 15, 15, _RGB32(216, 166, 50)) + NewObj = AddObject(objBlock, 232, _Height - _Height / 5 - 48, 15, 15, _RGB32(216, 166, 50)) + + NewObj = AddObject(objBonus, 800, 270, 15, 10, _RGB32(249, 244, 55)) + Object(NewObj).shape = objShapeRound + + NewObj = AddObject(objBonus, 820, 320, 15, 10, _RGB32(249, 244, 55)) + Object(NewObj).shape = objShapeRound + + NewObj = AddObject(objBonus, 1200, _Height - _Height / 5 - 22, 15, 10, _RGB32(249, 244, 55)) + Object(NewObj).shape = objShapeRound + + NewObj = AddObject(objEnemy, 1200, _Height - _Height / 5 - 22, 15, 10, _RGB32(150, 89, 238)) + + Hero = AddObject(objHero, 25, _Height - _Height / 5 - 22, 10, 20, _RGB32(127, 244, 127)) + End Select +End Sub + diff --git a/samples/platform/src/platform.zip b/samples/platform/src/platform.zip new file mode 100644 index 00000000..d810a18d Binary files /dev/null and b/samples/platform/src/platform.zip differ diff --git a/samples/platformer.md b/samples/platformer.md index f84c3965..80e975eb 100644 --- a/samples/platformer.md +++ b/samples/platformer.md @@ -2,7 +2,7 @@ ## SAMPLES: PLATFORMER -**[ArcDemo](arc-demo/index.md)** +**[Arc Demo](arc-demo/index.md)** [🐝 Tsiplacov Sergey](tsiplacov-sergey.md) 🔗 [game](game.md), [platformer](platformer.md) diff --git a/samples/pong.md b/samples/pong.md index f2dab496..c4c7ffb7 100644 --- a/samples/pong.md +++ b/samples/pong.md @@ -2,7 +2,7 @@ ## SAMPLES: PONG -**[4 Player Pong](four-player-pong/index.md)** +**[Four Player Pong](four-player-pong/index.md)** [🐝 Matthew](matthew.md) 🔗 [game](game.md), [pong](pong.md) diff --git a/samples/puzzle.md b/samples/puzzle.md index 66f99630..b4f032fb 100644 --- a/samples/puzzle.md +++ b/samples/puzzle.md @@ -2,7 +2,7 @@ ## SAMPLES: PUZZLE -**[Pipes Puzzle (Maze Connect)](pipes-puzzle/index.md)** +**[Pipes Puzzle](pipes-puzzle/index.md)** [🐝 Dav](dav.md) 🔗 [game](game.md), [puzzle](puzzle.md) diff --git a/samples/qbascii/img/screenshot.png b/samples/qbascii/img/screenshot.png new file mode 100644 index 00000000..dfeb0c9f Binary files /dev/null and b/samples/qbascii/img/screenshot.png differ diff --git a/samples/qbascii/index.md b/samples/qbascii/index.md new file mode 100644 index 00000000..5da9295d --- /dev/null +++ b/samples/qbascii/index.md @@ -0,0 +1,29 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QBASCII + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Jeremy Munn](../jeremy-munn.md) + +### Description + +```text +'***************************************************************************** +' Name: QBASCII.BAS +' Author: Jeremy Munn +' Date: 07/28/2012 +' Description: ASCII drawing program with save & load features. +'***************************************************************************** +``` + +### File(s) + +* [qbascii.bas](src/qbascii.bas) + +🔗 [drawing](../drawing.md), [ascii](../ascii.md) + + +Reference: [github.com](https://github.com/FellippeHeitor/cant-contain-me) diff --git a/samples/qbascii/src/qbascii.bas b/samples/qbascii/src/qbascii.bas new file mode 100644 index 00000000..e771dfcf --- /dev/null +++ b/samples/qbascii/src/qbascii.bas @@ -0,0 +1,1083 @@ +'***************************************************************************** +' Name: QBASCII.BAS +' Author: Jeremy Munn +' Date: 07/28/2012 +' Description: ASCII drawing program with save & load features. +'***************************************************************************** + +$NoPrefix +DefInt A-Z + +'***************************************************************************** +' CONSTANTS +'***************************************************************************** +' Common constants +Const FALSE = 0, TRUE = Not FALSE + +' Keys constants +Const KEYS.TAB = 9 +Const KEYS.RETURN = 13 +Const KEYS.ESCAPE = 27 +Const KEYS.SPACE = 32 +Const KEYS.UP = 72 +Const KEYS.LEFT = 75 +Const KEYS.RIGHT = 77 +Const KEYS.DOWN = 80 +Const KEYS.PAGEUP = 73 +Const KEYS.PAGEDOWN = 81 +Const KEYS.BACKSPACE = 8 +Const KEYS.INSERT = 82 +Const KEYS.DELETE = 83 +Const KEYS.HOME = 71 +Const KEYS.END = 79 + +Const KEYS.CTRL.N = 14 +Const KEYS.CTRL.O = 15 +Const KEYS.CTRL.S = 19 +Const KEYS.CTRL.Q = 17 + +Const KEYS.CTRL.LEFT = 115 +Const KEYS.CTRL.RIGHT = 116 +Const KEYS.CTRL.PAGEUP = 132 +Const KEYS.CTRL.PAGEDOWN = 118 +Const KEYS.CTRL.HOME = 119 +Const KEYS.CTRL.END = 117 + +Const KEYS.F1 = 59 + +' Style constants +Const STYLE.FILL.NONE = 1 +Const STYLE.FILL.SOLID = 2 +Const STYLE.BORDER.SINGLE = 4 +Const STYLE.BORDER.DOUBLE = 8 +Const STYLE.BORDER.SOLID = 16 +Const STYLE.BORDER.MIXED = 32 +Const STYLE.BORDER.MIXEDINV = 64 + +' Program-specific constants +Const SCREEN.WIDTH = 80 +Const SCREEN.HEIGHT = 25 + +'***************************************************************************** +' USER-DEFINED TYPES +'***************************************************************************** +Type AsciiType + code As Integer + row As Integer + col As Integer + fg As Integer + bg As Integer +End Type + +'***************************************************************************** +' SUB / FUNCTION DECLARATIONS +'***************************************************************************** +DECLARE SUB Mouse (funk) + +DECLARE SUB AddAsciiToBuffer (pAscii AS AsciiType) +DECLARE SUB Center (pRow, pText$) +DECLARE SUB ClearAsciiBuffer (pBufferId, pLength) +DECLARE SUB DrawAscii (pAscii AS AsciiType) +DECLARE SUB DrawWindow (pR1, pC1, pR2, pC2, pStyle, pTitle$) +DECLARE SUB GetAsciiFromBuffer (pAscii AS AsciiType) +DECLARE SUB ShowAsciiSelection (pAscii AS AsciiType) +DECLARE SUB Init () +DECLARE SUB LoadFile () +DECLARE SUB SaveFile () +DECLARE SUB ShiftAsciiColumn (pRow, pCol, pLength) +DECLARE SUB DrawRow (pRow) +DECLARE SUB DrawStatusBar (pAscii AS AsciiType, showStatus) +DECLARE SUB ShowUsage () + + +DECLARE FUNCTION GetRowFromBuffer (pBufferId) +DECLARE FUNCTION GetColFromBuffer (pBufferId) +DECLARE FUNCTION GetRowColBuffer (pRow, pCol) +DECLARE FUNCTION ConfirmQuit () +DECLARE FUNCTION ConfirmNewFile () +DECLARE FUNCTION QBInput$ (pLength, pDefault$) +DECLARE FUNCTION Trim$ (pString$) + +'***************************************************************************** +' GLOBAL VARIABLES +'***************************************************************************** +Dim Shared gBlankAscii As AsciiType +Dim Shared gAsciiBuffer(SCREEN.WIDTH * SCREEN.HEIGHT) As AsciiType +Dim Shared gFileName$ +Dim Shared mouseV, mouseH, mouseB + +'***************************************************************************** +' INITIALIZE +'***************************************************************************** +Screen 0: Color 7, 0: Cls +Mouse 0 + +Dim ascii As AsciiType, oldAscii As AsciiType + +gFileName$ = "UNTITLED.QBA" +gBlankAscii.code = 0 +gBlankAscii.fg = 7 +gBlankAscii.bg = 0 + +ascii.code = 1 +ascii.row = 12 +ascii.col = 40 +ascii.fg = 7 +ascii.bg = 0 + +oldAscii = ascii +oldMouseV = mouseV +oldMouseH = mouseH +oldMouseB = mouseB +ClearAsciiBuffer -1, -1 +isInsertMode = FALSE +isDeleteMode = FALSE +isQuit = FALSE + +'***************************************************************************** +' MAIN +'***************************************************************************** +DrawAscii oldAscii +DrawAscii ascii + +oldAscii = ascii +GetAsciiFromBuffer oldAscii + +needsRender = TRUE + +Do + keyPress$ = InKey$ + Mouse 3 + + If oldMouseV <> mouseV Or oldMouseH <> mouseH Or oldMouseB <> mouseB Then + needsRender = TRUE + + If mouseV <> ascii.row Then + If mouseV > 0 And mouseV <= SCREEN.HEIGHT Then + ascii.row = mouseV + End If + End If + + If mouseH <> ascii.col Then + If mouseH > 0 And mouseH <= SCREEN.WIDTH Then + ascii.col = mouseH + End If + End If + + If mouseB = 1 And Not isInsertMode Then + AddAsciiToBuffer ascii + End If + + If mouseB = 2 And Not isInsertMode Then + isDeleteMode = TRUE + bufferId = GetRowColBuffer(ascii.row, ascii.col) + ClearAsciiBuffer bufferId, 1 + Else + isDeleteMode = FALSE + End If + End If + + If keyPress$ > "" Then + needsRender = TRUE + + Select Case Asc(keyPress$) + + Case KEYS.TAB + If Not isInsertMode Then + ShowAsciiSelection ascii + End If + + Case KEYS.ESCAPE + pShowStatus = Not pShowStatus + + If Not pShowStatus Then + DrawStatusBar ascii, FALSE + End If + + Case KEYS.SPACE + If Not isInsertMode Then + AddAsciiToBuffer ascii + Else + If ascii.col < SCREEN.WIDTH Then + bufferId = GetRowColBuffer(ascii.row, SCREEN.WIDTH) + + 'Only shift if the last column is blank + If gAsciiBuffer(bufferId).code = gBlankAscii.code Then + ShiftAsciiColumn ascii.row, ascii.col, 1 + ascii.col = ascii.col + 1 + End If + End If + End If + + Case KEYS.BACKSPACE + If isInsertMode Then + If ascii.col > 1 Then + ShiftAsciiColumn ascii.row, ascii.col, -1 + ascii.col = ascii.col - 1 + End If + End If + + Case Is > 32 + If Not isInsertMode Then + ascii.code = Asc(keyPress$) + End If + + Case Else + Select Case Asc(Right$(keyPress$, 1)) + + Case KEYS.UP + ascii.row = ascii.row - 1 + If ascii.row < 1 Then ascii.row = SCREEN.HEIGHT + + Case KEYS.DOWN + ascii.row = ascii.row + 1 + If ascii.row > SCREEN.HEIGHT Then ascii.row = 1 + + Case KEYS.RIGHT + ascii.col = ascii.col + 1 + If ascii.col > SCREEN.WIDTH Then ascii.col = 1 + + Case KEYS.LEFT + ascii.col = ascii.col - 1 + If ascii.col < 1 Then ascii.col = SCREEN.WIDTH + + Case KEYS.CTRL.LEFT + 'starting at current position -1, find the previous non-space char + 'if already at first non-space char, set row, col to first + bufferId = GetRowColBuffer(ascii.row, ascii.col) + For i = bufferId - 1 To 1 Step -1 + If gAsciiBuffer(i).code > gBlankAscii.code Then + Exit For + End If + Next i + + If i < 1 Then i = 1 + + ascii.row = GetRowFromBuffer(i) + ascii.col = GetColFromBuffer(i) + + Case KEYS.CTRL.RIGHT + 'starting at current position +1, find the next non-space char + 'if already at last non-space char, set row, col to last + bufferId = GetRowColBuffer(ascii.row, ascii.col) + For i = bufferId + 1 To UBound(gAsciiBuffer) + If gAsciiBuffer(i).code > gBlankAscii.code Then + Exit For + End If + Next i + + If i > UBound(gAsciiBuffer) Then i = UBound(gAsciiBuffer) + + ascii.row = GetRowFromBuffer(i) + ascii.col = GetColFromBuffer(i) + + Case KEYS.HOME + 'left-to-right, find first blank char + 'if ascii.col already at first blank char, set col to 1 + 'if blank char not found, set col to 1 + For c = 1 To SCREEN.WIDTH + bufferId = GetRowColBuffer(ascii.row, c) + If gAsciiBuffer(bufferId).code <> gBlankAscii.code Then + If ascii.col = c Then c = 1 + Exit For + End If + Next c + + If c > SCREEN.WIDTH Then c = 1 + + ascii.col = c + + Case KEYS.END + 'right-to-left, find first blank char + 'if ascii.col already at last blank char, set col to last col + 'if blank char not found, set col to last col + For c = SCREEN.WIDTH To 1 Step -1 + bufferId = GetRowColBuffer(ascii.row, c) + If gAsciiBuffer(bufferId).code <> gBlankAscii.code Then + If ascii.col = c Then c = SCREEN.WIDTH + Exit For + End If + Next c + + If c < 1 Then c = SCREEN.WIDTH + + ascii.col = c + + Case KEYS.CTRL.HOME + 'start from buffer(1) loop until non-space char + 'if already at first non-space char, set row, col to 1 + For i = 1 To UBound(gAsciiBuffer) + If gAsciiBuffer(i).code <> 32 Then + bufferRow = GetRowFromBuffer(i) + bufferCol = GetColFromBuffer(i) + + If ascii.row = bufferRow And ascii.col = bufferCol Then + i = 1 + End If + + Exit For + End If + Next i + + If i > UBound(gAsciiBuffer) Then i = 1 + + ascii.row = GetRowFromBuffer(i) + ascii.col = GetColFromBuffer(i) + + Case KEYS.CTRL.END + 'start from UBOUND(buffer) loop down until non-space char + 'if already at last non-space char, set row, col to last + For i = UBound(gAsciiBuffer) To 1 Step -1 + If gAsciiBuffer(i).code <> 32 Then + bufferRow = GetRowFromBuffer(i) + bufferCol = GetColFromBuffer(i) + + If ascii.row = bufferRow And ascii.col = bufferCol Then + i = UBound(gAsciiBuffer) + End If + + Exit For + End If + Next i + + If i < 1 Then i = UBound(gAsciiBuffer) + + ascii.row = GetRowFromBuffer(i) + ascii.col = GetColFromBuffer(i) + + Case KEYS.PAGEUP + ascii.fg = ascii.fg + 1 + If ascii.fg > 15 Then ascii.fg = 0 + + Case KEYS.PAGEDOWN + ascii.fg = ascii.fg - 1 + If ascii.fg < 0 Then ascii.fg = 15 + + Case KEYS.CTRL.PAGEUP + ascii.bg = ascii.bg + 1 + If ascii.bg > 7 Then ascii.bg = 0 + + Case KEYS.CTRL.PAGEDOWN + ascii.bg = ascii.bg - 1 + If ascii.bg < 0 Then ascii.bg = 7 + + Case KEYS.CTRL.N + If ConfirmNewFile Then Run + + Case KEYS.CTRL.O + LoadFile + + Case KEYS.CTRL.S + SaveFile + + Case KEYS.CTRL.Q + isQuit = ConfirmQuit + + Case KEYS.INSERT + isInsertMode = Not isInsertMode + DrawAscii oldAscii + + Case KEYS.DELETE + If Not isInsertMode Then + bufferId = GetRowColBuffer(ascii.row, ascii.col) + ClearAsciiBuffer bufferId, 1 + Else + ShiftAsciiColumn ascii.row, ascii.col + 1, -1 + End If + + 'Only shift if the last column is blank + 'IF gAsciiBuffer(bufferId).code = gBlankAscii.code THEN + ' ShiftAsciiColumn ascii.row, ascii.col, 1 + ' ascii.col = ascii.col + 1 + 'END IF + + Case KEYS.F1 + ShowUsage + + End Select + End Select + End If 'IF keyPress$ > "" + + If needsRender Then + If Not isInsertMode Then + DrawAscii oldAscii + DrawAscii ascii + End If + + If pShowStatus Then + DrawStatusBar ascii, TRUE + + 'need this extra DrawAscii call because ascii would get overwritten + ' after DrawStatusBar + 'DrawAscii ascii + End If + + needsRender = FALSE + End If + + If isInsertMode Then + Locate ascii.row, ascii.col, 1, 29, 31 + ElseIf isDeleteMode Then + Locate ascii.row, ascii.col, 1, 1, 4 + Else + Locate , , 0 ' Turn the cursor off + End If + + oldAscii = ascii + GetAsciiFromBuffer oldAscii + + oldMouseV = mouseV + oldMouseH = mouseH + oldMouseB = mouseB +Loop Until isQuit + +'***************************************************************************** +' CLEANUP +'***************************************************************************** +Color 7, 0 +Locate , , 0 ' Turn the cursor off +System 0 + +Sub AddAsciiToBuffer (pAscii As AsciiType) + bufferId = GetRowColBuffer(pAscii.row, pAscii.col) + + gAsciiBuffer(bufferId).code = pAscii.code + gAsciiBuffer(bufferId).row = pAscii.row + gAsciiBuffer(bufferId).col = pAscii.col + gAsciiBuffer(bufferId).fg = pAscii.fg + gAsciiBuffer(bufferId).bg = pAscii.bg +End Sub + +Sub Center (pRow, pText$) + iLength = Len(pText$) + + If iLength < 1 Or iLength > 80 Then iLength = 80 + If pRow < 1 Or pRow > 25 Then pRow = CsrLin + + iRelPos = (SCREEN.WIDTH / 2) - (iLength / 2) + + Locate pRow, iRelPos + Print pText$; +End Sub + +Sub ClearAsciiBuffer (pBufferId, pLength) + bufferStart = 1 + If pBufferId > 0 Then bufferStart = pBufferId + + bufferLength = UBound(gAsciiBuffer) + If pLength > 0 Then bufferLength = pLength + + For i = bufferStart To (bufferStart + bufferLength) - 1 + gBlankAscii.row = GetRowFromBuffer(i) + gBlankAscii.col = GetColFromBuffer(i) + + gAsciiBuffer(i) = gBlankAscii + DrawAscii gAsciiBuffer(i) + Next i +End Sub + +Function ConfirmNewFile + newFile = FALSE + PCopy 0, 1 + Color 15, 4 + Locate , , 0 ' Turn the cursor off + DrawWindow 10, 14, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "Start New File" + Center 12, "Are you sure you want to start a new file? (Y/N)" + ans$ = Input$(1) + If UCase$(ans$) = "Y" Then newFile = TRUE + PCopy 1, 0 + ConfirmNewFile = newFile +End Function + +Function ConfirmQuit + isQuit = FALSE + PCopy 0, 1 + Color 15, 4 + Locate , , 0 ' Turn the cursor off + DrawWindow 10, 20, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "Quit QBASCII" + Center 12, "Are you sure you want to quit? (Y/N)" + ans$ = Input$(1) + If UCase$(ans$) = "Y" Then isQuit = TRUE + PCopy 1, 0 + ConfirmQuit = isQuit +End Function + +Sub DrawAscii (pAscii As AsciiType) + Color pAscii.fg, pAscii.bg + Locate pAscii.row, pAscii.col, 0 'Make sure the cursor is off + Print Chr$(pAscii.code); +End Sub + +Sub DrawRow (pRow) + bufferId = GetRowColBuffer(pRow, 1) + Dim rowAscii As AsciiType + For i = 1 To SCREEN.WIDTH + rowAscii.row = pRow + rowAscii.col = i + + GetAsciiFromBuffer rowAscii + DrawAscii rowAscii + Next i +End Sub + +Sub DrawStatusBar (pAscii As AsciiType, pShowStatus) + Static row + Static oldRow + + If Not pShowStatus Then + DrawRow row + Exit Sub + End If + + If row = 0 Then + oldRow = 25 + row = 25 + End If + + If pAscii.row = 25 Then + oldRow = row + row = 1 + + If row <> oldRow Then + DrawRow oldRow + End If + + ElseIf pAscii.row = 1 Then + oldRow = row + row = 25 + + If row <> oldRow Then + DrawRow oldRow + End If + End If + + Color 0, 7 + Locate row, 1 + Print "Char: "; Chr$(pAscii.code); " "; + Print "Code: "; + Print Using "###"; pAscii.code; + Print " row: ";: Print Using "##"; pAscii.row; + Print " col: ";: Print Using "##"; pAscii.col; + Print " FG: ";: Color pAscii.fg, 0: Print Chr$(219); + Color 0, 7 + Print " BG: ";: Color pAscii.bg, 0: Print Chr$(219); + Color 0, 7: + Print " "; + Print Using "File: \ \"; gFileName$; +End Sub + +Sub DrawWindow (pR1, pC1, pR2, pC2, pStyle, pTitle$) + Dim styles$ + + Select Case pStyle + Case Is > STYLE.BORDER.MIXEDINV + styles$ = Chr$(205) + Chr$(179) + Chr$(213) + Chr$(184) + Chr$(212) + Chr$(190) + pStyle = pStyle - STYLE.BORDER.MIXEDINV + Case Is > STYLE.BORDER.MIXED + styles$ = Chr$(196) + Chr$(186) + Chr$(214) + Chr$(183) + Chr$(211) + Chr$(189) + pStyle = pStyle - STYLE.BORDER.MIXED + Case Is > STYLE.BORDER.DOUBLE + styles$ = Chr$(205) + Chr$(186) + Chr$(201) + Chr$(187) + Chr$(200) + Chr$(188) + pStyle = pStyle - STYLE.BORDER.DOUBLE + Case Is > STYLE.BORDER.SINGLE + styles$ = Chr$(196) + Chr$(179) + Chr$(218) + Chr$(191) + Chr$(192) + Chr$(217) + pStyle = pStyle - STYLE.BORDER.SINGLE + Case Is > STYLE.BORDER.SOLID + styles$ = Chr$(219) + Chr$(219) + Chr$(219) + Chr$(219) + Chr$(219) + Chr$(219) + pStyle = pStyle - STYLE.BORDER.SOLID + End Select + + If pR2 = -1 Then + pR2 = SCREEN.HEIGHT - pR1 + End If + + If pC2 = -1 Then + pC2 = SCREEN.WIDTH - pC1 + End If + + Locate pR1, pC1: Print Mid$(styles$, 3, 1); + For col = pC1 + 1 To pC2 - 1 + Locate pR1, col: Print Mid$(styles$, 1, 1); + Next col + + If pTitle$ <> "" Then + pTitle$ = "[ " + pTitle$ + " ]" + iCenter = pC1 + ((pC2 - pC1) \ 2) + Locate pR1, iCenter - (Len(pTitle$) \ 2) + Print pTitle$; + End If + + Locate pR1, pC2: Print Mid$(styles$, 4, 1); + For row = pR1 + 1 To pR2 - 1 + Locate row, pC1: Print Mid$(styles$, 2, 1); + If pStyle = STYLE.FILL.SOLID Then + Print String$(pC2 - pC1 - 1, " "); + End If + Locate row, pC2: Print Mid$(styles$, 2, 1); + Next row + Locate pR2, pC1: Print Mid$(styles$, 5, 1); + For col = pC1 + 1 To pC2 - 1 + Locate pR2, col: Print Mid$(styles$, 1, 1); + Next col + Locate pR2, pC2: Print Mid$(styles$, 6, 1); +End Sub + +Sub GetAsciiFromBuffer (pAscii As AsciiType) + bufferId = GetRowColBuffer(pAscii.row, pAscii.col) + + pAscii.code = gAsciiBuffer(bufferId).code + pAscii.row = gAsciiBuffer(bufferId).row + pAscii.col = gAsciiBuffer(bufferId).col + pAscii.fg = gAsciiBuffer(bufferId).fg + pAscii.bg = gAsciiBuffer(bufferId).bg +End Sub + +Function GetColFromBuffer (pBufferId) + row = GetRowFromBuffer(pBufferId) + GetColFromBuffer = SCREEN.WIDTH - ((row * SCREEN.WIDTH) - pBufferId) +End Function + +Function GetRowColBuffer (pRow, pCol) + GetRowColBuffer = (SCREEN.WIDTH * pRow) - SCREEN.WIDTH + pCol +End Function + +Function GetRowFromBuffer (pBufferId) + GetRowFromBuffer = Int((pBufferId - 1) / SCREEN.WIDTH) + 1 +End Function + +Sub LoadFile + PCopy 0, 1 + Color 15, 1 + Locate , , 0 ' Turn the cursor off + DrawWindow 10, 23, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "Load QBASCII File" + Center 12, "Filename: " + Space$(12) + Locate , Pos(0) - 12 + Color 15, 0 + Print Space$(12); + Locate , Pos(0) - 12 'Locate to beginning of input + Color 15, 0 + fileInput$ = QBInput$(12, gFileName$) + PCopy 1, 0 + If fileInput$ <> "" Then + isValidFile = TRUE + isFileFound = FALSE + + If Not UCase$(Right$(Trim$(fileInput$), 4)) = ".QBA" Then + If Len(fileInput$) <= 8 Then + fileInput$ = fileInput$ + ".QBA" + Else + isValidFile = FALSE + End If + End If + + If isValidFile Then + gFileName$ = UCase$(fileInput$) + Open gFileName$ For Binary As #1 + If LOF(1) > 0 Then isFileFound = TRUE + Close #1 + + If isFileFound Then + Open gFileName$ For Random As #1 Len = Len(gBlankAscii) + For i = 1 To SCREEN.WIDTH * SCREEN.HEIGHT + Get #1, i, gAsciiBuffer(i) + Next i + Close #1 + + For i = 1 To SCREEN.WIDTH * SCREEN.HEIGHT + DrawAscii gAsciiBuffer(i) + Next i + + PCopy 0, 1 + Color 15, 1 + DrawWindow 11, 25, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "" + Center 12, gFileName$ + " Loaded" + Sleep 2 + PCopy 1, 0 + Else + Kill gFileName$ + PCopy 0, 1 + Color 15, 4 + DrawWindow 11, 25, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "" + Center 12, "File not found: " + gFileName$ + Sleep 2 + PCopy 1, 0 + End If 'isFileFound + Else + PCopy 0, 1 + Color 15, 4 + DrawWindow 11, 25, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "" + Center 12, "Invalid File Name" + Sleep 2 + PCopy 1, 0 + End If 'isValidFile + End If 'fileInput$ <> "" +End Sub + +Sub Mouse (funk) + '"QBMouse.bas" Written 1999 by: Daryl R. Dubbs + + 'SHARED mouseH, mouseV, mouseB + Static crsr 'track whether Cursor is shown + If funk% = 1 Then crsr = 1 'show Cursor + If funk% = 2 And crsr = 0 Then Exit Sub 'don't hide cursor more than onced + If funk% = 2 And crsr = 1 Then crsr = 0 'Hide cursor + + Poke 100, 184: Poke 101, funk: Poke 102, 0 'Poke machine code necessary for + Poke 103, 205: Poke 104, 51: Poke 105, 137 'using the mouse into memeory + Poke 106, 30: Poke 107, 170: Poke 108, 10 'starting at offset 100 in the + Poke 109, 137: Poke 110, 14: Poke 111, 187 'current segment. This code + Poke 112, 11: Poke 113, 137: Poke 114, 22 'then executed as a unit, via the + Poke 115, 204: Poke 116, 12: Poke 117, 203 'statement "Call Absolute" + Call Absolute(100) 'Call machine code + + mouseB = Peek(&HAAA) 'Get values for buttons + mouseH = CInt((Peek(&HBBB) + Peek(&HBBC) * 256) / 8) 'Horizontal position (2 bytes) + mouseV = CInt((Peek(&HCCC) + Peek(&HCCD) * 256) / 8) 'Vertical position (2 bytes) +End Sub + +Function QBInput$ (pLength, pDefault$) + inputLength = pLength + defaultLength = Len(pDefault$) + + If defaultLength > inputLength Then inputLength = defaultLength + + inputText$ = Space$(inputLength) + + If defaultLength > 0 Then Mid$(inputText$, 1) = pDefault$ + + iCsrPos = 0 + rowOffset = CsrLin + colOffset = Pos(0) + + Locate , , 1, 0, 1 + Print inputText$; + Do + keyPress$ = InKey$ + + If keyPress$ > "" Then + Select Case Asc(keyPress$) + + Case KEYS.ESCAPE + inputText$ = "" + isCancel = TRUE + + Case KEYS.RETURN + isReturn = TRUE + + Case KEYS.BACKSPACE + If iCsrPos > 0 Then + iCsrPos = iCsrPos - 1 + For i = iCsrPos To inputLength - 1 + Mid$(inputText$, i + 1) = Mid$(inputText$, i + 2, 1) + Next i + Mid$(inputText$, inputLength) = " " + Else + End If + + ' 0-9 A-Z, a-z + Case 48 TO 57, 65 TO 90, 97 TO 122 + If isInsert Then + If iCsrPos < inputLength Then iCsrPos = iCsrPos + 1 + Mid$(inputText$, iCsrPos) = keyPress$ + Else + If Right$(inputText$, 1) = " " Then + If iCsrPos < inputLength Then + iCsrPos = iCsrPos + 1 + If iCsrPos <> inputLength Then + s$ = Mid$(inputText$, iCsrPos, inputLength - 1) + Mid$(inputText$, iCsrPos + 1) = s$ + End If + Mid$(inputText$, iCsrPos) = keyPress$ + End If + End If + End If + + If iCsrPos = inputLength Then iCsrPos = iCsrPos - 1 + + Case Else + + Select Case Asc(Right$(keyPress$, 1)) + + Case KEYS.INSERT + isInsert = Not isInsert + + Case KEYS.DELETE + For i = iCsrPos To inputLength - 1 + If i = inputLength - 1 Then + Mid$(inputText$, inputLength) = " " + Else + Mid$(inputText$, i + 1) = Mid$(inputText$, i + 2, 1) + End If + Next i + + Case KEYS.HOME + iCsrPos = 0 + + Case KEYS.END + iCsrPos = inputLength - 1 + + Case KEYS.LEFT + If iCsrPos > 0 Then iCsrPos = iCsrPos - 1 + + Case KEYS.RIGHT + If iCsrPos < inputLength - 1 Then iCsrPos = iCsrPos + 1 + + End Select + + End Select + + Locate , colOffset: Print inputText$; + + End If + + If isInsert Then + Locate , , 1, 0, 31 + Else + Locate , , 1, 29, 31 + End If + Locate rowOffset, colOffset + iCsrPos + + Loop Until isCancel Or isReturn + + 'Turn cursor off + Locate , , 0 + + QBInput = LTrim$(RTrim$(inputText$)) +End Function + +Sub SaveFile + PCopy 0, 1 + Color 15, 1 + Locate , , 0 ' Turn the cursor off + DrawWindow 10, 23, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "Save QBASCII File" + Center 12, "Filename: " + Space$(12) + Locate , Pos(0) - 12 + Color 15, 0 + Print Space$(12); + Locate , Pos(0) - 12 + fileInput$ = QBInput$(12, gFileName$) + PCopy 1, 0 + If fileInput$ <> "" Then + isValidFile = TRUE + isFileFound = FALSE + + If Not UCase$(Right$(Trim$(fileInput$), 4)) = ".QBA" Then + If Len(fileInput$) <= 8 Then + fileInput$ = fileInput$ + ".QBA" + Else + isValidFile = FALSE + End If + End If + + If isValidFile Then + gFileName$ = UCase$(fileInput$) + Open gFileName$ For Random As #1 Len = Len(gBlankAscii) + For i = 1 To UBound(gAsciiBuffer) + Put #1, i, gAsciiBuffer(i) + Next i + Close #1 + + PCopy 0, 1 + Color 15, 1 + DrawWindow 11, 25, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "" + Center 12, gFileName$ + " Saved" + Sleep 2 + PCopy 1, 0 + Else + PCopy 0, 1 + Color 15, 4 + DrawWindow 11, 25, -1, -1, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "" + Center 12, "Invalid File Name" + Sleep 2 + PCopy 1, 0 + End If 'isValidFile + End If 'fileInput$ <> "" +End Sub + +Sub ShiftAsciiColumn (pRow, pCol, pShiftDir) + bufferId = GetRowColBuffer(pRow, pCol) + pLength = SCREEN.WIDTH - pCol + + If pShiftDir > 0 Then + For i = bufferId + pLength To bufferId Step -1 + gAsciiBuffer(i).code = gAsciiBuffer(i - 1).code + gAsciiBuffer(i).fg = gAsciiBuffer(i - 1).fg + gAsciiBuffer(i).bg = gAsciiBuffer(i - 1).bg + DrawAscii gAsciiBuffer(i) + Next i + + ClearAsciiBuffer bufferId, 1 + Else + For i = bufferId - 1 To bufferId + pLength + gAsciiBuffer(i).code = gAsciiBuffer(i + 1).code + gAsciiBuffer(i).fg = gAsciiBuffer(i + 1).fg + gAsciiBuffer(i).bg = gAsciiBuffer(i + 1).bg + + If gAsciiBuffer(i).col = SCREEN.WIDTH Then + ClearAsciiBuffer i, 1 + Else + DrawAscii gAsciiBuffer(i) + End If + Next i + End If +End Sub + +Sub ShowAsciiSelection (pAscii As AsciiType) + rowOffset = 4 + colOffset = 22 + colSpacing = 2 + rowMax = 15 + colMax = 17 + + PCopy 0, 1 + Color 15, 1 + DrawWindow rowOffset, colOffset, rowOffset + 18, colOffset + 36, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "Select an ASCII char" + + Color 7, 1 + For r = 1 To rowMax + For c = 1 To colMax + asciiCode = asciiCode + 1 + Locate r + rowOffset, c * colSpacing + colOffset + + Select Case asciiCode + Case 1 TO 6, 8, 14 TO 27, Is > 33 + Print Chr$(asciiCode); + Case Else + Print Chr$(32); + End Select + + Next c + Next r + + isSelected = FALSE + isDone = FALSE + selCode = pAscii.code + selRow = (selCode + colMax - 1) \ colMax + selCol = selCode - (selRow * colMax - colMax) + needsRender = TRUE + + Do + keyPress$ = InKey$ + Mouse 3 + + If oldMouseV <> mouseV Or oldMouseH <> mouseH Or oldMouseB <> mouseB Then + needsRender = TRUE + + If mouseV <> selRow Then + If mouseV > 0 And mouseV <= rowMax Then + selRow = mouseV + End If + End If + + If mouseH <> selCol Then + If mouseH > 0 And mouseH <= colMax Then + selCol = mouseH + End If + End If + + If mouseB = 1 Then + isSelected = TRUE + End If + End If + + If keyPress$ > "" Then + needsRender = TRUE + Select Case Asc(keyPress$) + Case KEYS.ESCAPE, KEYS.TAB + isDone = TRUE + Case KEYS.RETURN + isSelected = TRUE + Case Else + Select Case Asc(Right$(keyPress$, 1)) + Case KEYS.UP + selRow = selRow - 1 + If selRow < 1 Then selRow = rowMax + Case KEYS.DOWN + selRow = selRow + 1 + If selRow > rowMax Then selRow = 1 + Case KEYS.LEFT + selCol = selCol - 1 + If selCol < 1 Then selCol = colMax + Case KEYS.RIGHT + selCol = selCol + 1 + If selCol > colMax Then selCol = 1 + End Select + End Select + End If + + If needsRender Then + selCode = selRow * colMax - colMax + selCol + + Select Case selCode + Case 1 TO 6, 8, 14 TO 27, Is > 33 + Case Else + selCode = 32 + End Select + + Color 15, 1: Locate rowOffset + 17, colOffset + 9 + Print "ASCII: "; Chr$(selCode); " Code:"; selCode; + + Locate rowOffset + selRow, colOffset + selCol * colSpacing, 1, 0, 4 + + needsRender = FALSE + End If + + If isSelected Then + pAscii.code = selCode + End If + + oldMouseV = mouseV + oldMouseH = mouseH + oldMouseB = mouseB + Loop Until isSelected Or isDone + + Locate , , 0 ' Turn the cursor off + PCopy 1, 0 +End Sub + +Sub ShowUsage + PCopy 0, 1 + Color 15, 1 + Locate , , 0 ' Turn the cursor off + DrawWindow 2, 6, 24, 75, STYLE.BORDER.MIXEDINV + STYLE.FILL.SOLID, "Using QBASCII" + Locate 3, 8 + Print " Show usage (this screen)"; + Locate 4, 8 + Print " Show / Hide status bar"; + Locate 6, 8 + Print " Quit"; + Locate 7, 8 + Print " New file"; + Locate 8, 8 + Print " Open file"; + Locate 9, 8 + Print " Save file"; + Locate 11, 8 + Print " ,,, Move in specified direction"; + Locate 12, 8 + Print " Plot ASCII char at position"; + Locate 13, 8 + Print " ASCII char selection window"; + Locate 14, 8 + Print " , Change char foreground color"; + Locate 15, 8 + Print " Change char background color"; + Locate 16, 8 + Print " , Move to previous / next char"; + Locate 17, 8 + Print " , Move to first / last char on row"; + Locate 18, 8 + Print " , Move to first / last char on screen"; + Locate 20, 8 + Print " Toggle insert mode"; + Locate 21, 8 + Print " (insert mode) Insert a space at position"; + Locate 22, 8 + Print " (insert mode) Remove char to left of position"; + Locate 23, 8 + Print " (insert mode) Remove char at position"; + + ans$ = Input$(1) + PCopy 1, 0 +End Sub + diff --git a/samples/qbguy.md b/samples/qbguy.md index dd8c59fd..3fcd5b39 100644 --- a/samples/qbguy.md +++ b/samples/qbguy.md @@ -2,7 +2,7 @@ ## SAMPLES BY QBGUY -**[Mandelbrot Set](mandelbrot-set-2008/index.md)** +**[Mandelbrot Set 2008](mandelbrot-set-2008/index.md)** [🐝 qbguy](qbguy.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) diff --git a/samples/qblocks/img/screenshot.png b/samples/qblocks/img/screenshot.png new file mode 100644 index 00000000..fca35d1d Binary files /dev/null and b/samples/qblocks/img/screenshot.png differ diff --git a/samples/qblocks/index.md b/samples/qblocks/index.md new file mode 100644 index 00000000..1155c96b --- /dev/null +++ b/samples/qblocks/index.md @@ -0,0 +1,21 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QBLOCKS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Tetris clone by Microsoft. +``` + +### File(s) + +* [qblocks.bas](src/qblocks.bas) + +🔗 [game](../game.md), [tetris](../tetris.md) diff --git a/samples/qblocks/src/qblocks.bas b/samples/qblocks/src/qblocks.bas new file mode 100644 index 00000000..b40d40e9 --- /dev/null +++ b/samples/qblocks/src/qblocks.bas @@ -0,0 +1,1178 @@ +' QBLOCKS.BAS +' +' Press Page Down for information on running and modifying QBlocks. +' +' To run this game, press Shift+F5. +' +' To exit this program, press ALT, F, X. +' +' To get help on a BASIC keyword, move the cursor to the keyword and press +' F1 or click the right mouse button. +' +' Suggested Changes +' ----------------- +' +' There are many ways that you can modify this BASIC game. The CONST +' statements below these comments and the DATA statements at the end +' of this screen can be modified to change the following: +' +' Block shapes +' Block rotation +' Number of different block shapes +' Score needed to advance to next level +' Width of the game well +' Height of the game well +' Songs played during game +' +' On the right side of each CONST statement, there is a comment that tells +' you what it does and how big or small you can set the value. Above the +' DATA statements, there are comments that tell you the format of the +' information stored there. +' +' On your own, you can also add exciting sound and visual effects or make any +' other changes that your imagination can dream up. By reading the +' Learn BASIC Now book, you'll learn the techniques that will enable you +' to fully customize this game and to create games of your own. +' +' If the game won't run after you have changed it, you can exit without +' saving your changes by pressing Alt, F, X and choosing NO. +' +' If you do want to save your changes, press Alt, F, A and enter a filename +' for saving your version of the program. Before you save your changes, +' however, you should make sure they work by running the program and +' verifying that your changes produce the desired results. Also, always +' be sure to keep a backup of the original program. +' +DefInt A-Z + +' Here are the BASIC CONST statements you can change. The comments tell +' you the range that each CONST value can be changed, or any limitations. +Const WELLWIDTH = 10 ' Width of playing field (well). Range 5 to 13. +Const WELLHEIGHT = 21 ' Height of playing field. Range 4 to 21. +Const NUMSTYLES = 7 ' Number of unique shapes. Range 1 to 20. Make sure you read the notes above the DATA statements at the end of the main program before you change this number! +Const WINGAME = 1000000 ' Points required to win the game. Range 200 to 9000000. +Const NEXTLEVEL = 300 ' Helps determine when the game advances to the next level. (Each cleared level gives player 100 points) Range 100 to 2000. +Const BASESCORE = 1000 ' Number of points needed to advance to first level. +Const ROTATEDIR = 1 ' Control rotation of blocks. Can be 1 for clockwise, or 3 for counterclockwise. +' The following sound constants are used by the PLAY command to +' produce music during the game. To change the sounds you hear, change +' these constants. Refer to the online help for PLAY for the correct format. +' To completely remove sound from the game set the constants equal to null. +' For example: PLAYINTRO = "" +Const PLAYCLEARROW = "MBT255L16O4CDEGO6C" ' Tune played when a row is cleared. Range unlimited. +Const PLAYINTRO = "MBT170O1L8CO2CO1CDCA-A-FGFA-F" ' Song played at game start. Range unlimited. +Const PLAYGAMEOVER = "MBT255L16O6CO4GEDC" ' Song when the game is lost. Range unlimited. +Const PLAYNEWBLOCK = "MBT160L28N20L24N5" ' Song when a new block is dropped. Range unlimited. +Const PLAYWINGAME = "T255L16O6CO4GEDCCDEFGO6CEG" ' Song when game is won. Range unlimited. + +' The following CONST statements should not be changed like the ones above +' because the program relies on them being this value. +Const FALSE = 0 ' 0 means FALSE. +Const TRUE = Not FALSE ' Anything but 0 can be thought of as TRUE. +Const SPACEBAR = 32 ' ASCII value for space character. Drops the shape. +Const DOWNARROW = 80 ' Down arrow key. Drops the shape. +Const RIGHTARROW = 77 ' Right arrow key. Moves the shape right. +Const UPARROW = 72 ' Up arrow key. Rotates the shape. +Const LEFTARROW = 75 ' Left arrow key. Moves the shape left. +Const DOWNARROW2 = 50 ' 2 key. Drops the shape. +Const RIGHTARROW2 = 54 ' 6 key. Moves the shape right. +Const UPARROW2 = 56 ' 8 key. Rotates the shape. +Const LEFTARROW2 = 52 ' 4 key. Moves the shape left. +Const UPARROW3 = 53 ' 5 key. Rotates the shape. +Const QUIT = "Q" ' Q key. Quits the game. +Const PAUSE = "P" ' P key. Pauses the game. +Const XMATRIX = 3 ' Width of the matrix that forms each falling unit. See the discussions in Suggested Changes #2 and #3. +Const YMATRIX = 1 ' Depth of the matrix that forms each falling unit. +Const BYTESPERBLOCK = 76 ' Number of bytes required to store one block in Screen mode 7. +Const BLOCKVOLUME = (XMATRIX + 1) * (YMATRIX + 1) ' Number of blocks in each shape. +Const ELEMENTSPERBLOCK = BLOCKVOLUME * BYTESPERBLOCK \ 2 ' Number of INTEGER array elements needed to store an image of a shape. +Const XSIZE = 13 ' Width, in pixels, of each block. QBlocks assumes that the entire screen is 25 blocks wide. Since the screen is 320 pixels wide, each block is approximately 13 pixels wide. +Const YSIZE = 8 ' Height, in pixels, of each block. Again, QBlocks assumes that screen is 25 blocks high. At 200 pixels down, each block is exactly 8 pixels high. +Const XOFFSET = 10 ' X position, in blocks, of the well. +Const YOFFSET = 2 ' Y position, in blocks, of the well. +Const WELLX = XSIZE * XOFFSET ' X position, in pixels, of the start of the well. +Const WELLY = YSIZE * YOFFSET ' Y position. +Const TILTVALUE = 9999000 ' Points required for QBlocks to tilt. +Const WELLCOLOR7 = 0 ' Well color for SCREEN 7. +Const WELLCOLOR1 = 0 ' Well color for SCREEN 1. +Const BORDERCOLOR1 = 8 ' Border color for SCREEN 1. +Const BORDERCOLOR7 = 15 ' Border color for SCREEN 7. + +Type BlockType ' Block datatype. + X As Integer ' Horizontal location within the well. + Y As Integer ' Vertical location within the well. + Style As Integer ' Define shape (and color, indirectly). + Rotation As Integer ' 4 possible values (0 to 3). +End Type + +' SUB and FUNCTION declarations +DECLARE FUNCTION CheckFit () +DECLARE FUNCTION GameOver () +DECLARE SUB AddBlockToWell () +DECLARE SUB CheckForFullRows () +DECLARE SUB Center (M$, Row) +DECLARE SUB DeleteChunk (Highest%, Lowest%) +DECLARE SUB DisplayIntro () +DECLARE SUB DisplayGameTitle () +DECLARE SUB DisplayChanges () +DECLARE SUB DrawBlock (X, Y, FillColor) +DECLARE SUB InitScreen () +DECLARE SUB MakeInfoBox () +DECLARE SUB NewBlock () +DECLARE SUB PerformGame () +DECLARE SUB RedrawControls () +DECLARE SUB Show (b AS BlockType) +DECLARE SUB UpdateScoring () +DECLARE SUB PutBlock (b AS BlockType) +DECLARE SUB DrawAllShapes () +DECLARE SUB DrawPattern (Patttern) +DECLARE SUB DrawPlayingField () + +' DIM SHARED indicates that a variable is available to all subprograms. +' Without this statement, a variable used in one subprogram cannot be +' used by another subprogram or the main program. +Dim Shared Level As Integer ' Difficulty level. 0 is slowest, 9 is fastest. +Dim Shared WellBlocks(WELLWIDTH, WELLHEIGHT) As Integer ' 2 dimensional array to hold the falling shapes that have stopped falling and become part of the well. +Dim Shared CurBlock As BlockType ' The falling shape. +Dim Shared BlockShape(0 To XMATRIX, 0 To YMATRIX, 1 To NUMSTYLES) ' Holds the data required to make each shape. Values determined by the DATA statements at the end of this window. +Dim Shared PrevScore As Long ' Holds the previous level for scoring purposes. +Dim Shared Score As Long ' Score. +Dim Shared ScreenWidth As Integer ' Width of the screen, in character-sized units. +Dim Shared ScreenMode As Integer ' Value of the graphics screen mode used. +Dim Shared WellColor As Integer ' Color inside the well. +Dim Shared BorderColor As Integer ' Color of well border and text. +Dim Shared OldBlock As BlockType ' An image of the last CurBlock. Used to erase falling units when they move. +Dim Shared TargetTime As Single ' Time to move the shape down again. +Dim Shared GameTiltScore As Long ' Holds the value that this game will tilt at. +Dim Shared Temp(11175) As Integer ' Used by several GET and PUT statements to store temporary screen images. +Dim Shared BlockColor(1 To NUMSTYLES) As Integer ' Block color array +Dim Shared BlockImage((NUMSTYLES * 4 + 3) * ELEMENTSPERBLOCK) As Integer ' Holds the binary image of each rotation of each shape for the PutBlock subprogram to use. +Dim KeyFlags As Integer ' Internal state of the keyboard flags when game starts. Hold the state so it can be restored when the games ends. +Dim BadMode As Integer ' Store the status of a valid screen mode. + + +On Error GoTo ScreenError ' Set up a place to jump to if an error occurs in the program. +BadMode = FALSE +ScreenMode = 8 +Screen ScreenMode ' Attempt to go into SCREEN 7 (EGA screen). +If BadMode = TRUE Then ' If this attempt failed. + ScreenMode = 1 + BadMode = FALSE + Screen ScreenMode ' Attempt to go into SCREEN 1 (CGA screen). +End If +On Error GoTo 0 ' Turn off error handling. + +If BadMode = TRUE Then ' If no graphics adapter. + Cls + Locate 10, 12: Print "CGA, EGA Color, or VGA graphics required to run QBLOCKS.BAS" +Else + Randomize Timer ' Create a new sequence of random numbers based on the clock. + DisplayIntro ' Show the opening screen. + + Def Seg = 0 ' Set the current segment to the low memory area. + KeyFlags = Peek(1047) ' Read the location that holds the keyboard flag. + If (KeyFlags And 32) = 0 Then ' If the NUM LOCK key is off + Poke 1047, KeyFlays Or 32 ' set the NUM LOCK key to on. + End If + Def Seg ' Restore the default segment. + + ' Read the pattern for each QBlocks shape. + For i = 1 To NUMSTYLES ' Loop for the each shape + For j = 0 To YMATRIX ' and for the Y and X dimensions of + For k = 0 To XMATRIX ' each shape. + Read BlockShape(k, j, i) ' Actually read the data. + Next k + Next j + Next i + DrawAllShapes ' Draw all shapes in all four rotations. + PerformGame ' Play the game until the player quits. + DisplayChanges ' Show the suggested changes. + + Def Seg = 0 ' Set the current segment back to low memory where the keyboard flags are. + Poke 1047, KeyFlags And 233 ' Set the NUM LOCK key back to where it was at the game start. + Def Seg ' Restore the current segment back to BASIC's data group area. + + If ScreenMode = 7 Then Palette ' Restore the default color palette if SCREEN 7 was used. + +End If + +End ' End of the main program code. + + +' The DATA statements below define the block shapes used in the game. +' Each shape contains 8 blocks (4 x 2). A "1" means that there +' is a block in that space; "0" means that the block is blank. The pattern +' for Style 1, for example, creates a shape that is 4 blocks wide. +' To change an existing block's shape, change a "0" to a "1" or a "1" to +' a "0". To add new shapes, insert new DATA statements with the same format +' as those below, after the last group of DATA statements (style 7). Be sure +' to change the NUMSTYLES constant at the beginning of this program to reflect +' the new number of block shapes for the game. +' IMPORTANT! Creating a completely blank block will cause QBlocks to fail. + +' Data for Style 1: Long +Data 1,1,1,1 +Data 0,0,0,0 + +' Data for Style 2: L Right +Data 1,1,1,0 +Data 0,0,1,0 + +' Data for Style 3: L Left +Data 0,1,1,1 +Data 0,1,0,0 + +' Data for Style 4: Z Right +Data 1,1,0,0 +Data 0,1,1,0 + +' Data for Style 5: Z Left +Data 0,1,1,0 +Data 1,1,0,0 + +' Data for Style 6: T +Data 1,1,1,0 +Data 0,1,0,0 + +' Data for Style 7: Square +Data 0,1,1,0 +Data 0,1,1,0 + + +ScreenError: ' QBlocks uses this error handler to determine the highest available video mode. +BadMode = TRUE +Resume Next + +'---------------------------------------------------------------------------- +' AddBlockToWell +' +' After a shape stops falling, put it into the WellBlocks array +' so later falling shapes know where to stop. +' +' PARAMETERS: None. +'---------------------------------------------------------------------------- +Sub AddBlockToWell + + For i = 0 To XMATRIX ' Loop through all elements in the array. + For j = 0 To YMATRIX + If BlockShape(i, j, CurBlock.Style) = 1 Then ' If there is a block in that space. + Select Case CurBlock.Rotation ' Use the Rotation to determine how the blocks should map into the WellBlocks array. + Case 0 ' No rotation. + WellBlocks(CurBlock.X + i, CurBlock.Y + j) = CurBlock.Style + Case 1 ' Rotated 90 degrees clockwise. + WellBlocks(CurBlock.X - j + 2, CurBlock.Y + i - 1) = CurBlock.Style + Case 2 ' Rotated 180 degrees. + WellBlocks(CurBlock.X - i + 3, CurBlock.Y - j + 1) = CurBlock.Style + Case 3 ' Rotated 270 degrees clockwise. + WellBlocks(CurBlock.X + j + 1, CurBlock.Y - i + 2) = CurBlock.Style + End Select + End If + Next j + Next i +End Sub + +'---------------------------------------------------------------------------- +' Center +' +' Centers a string of text on a specified row. +' +' PARAMETERS: Text$ - Text to display on the screen. +' Row - Row on the screen where the text$ is +' displayed. +'---------------------------------------------------------------------------- +Sub Center (text$, Row) + + Locate Row, (ScreenWidth - Len(text$)) \ 2 + 1 + Print text$; + +End Sub + +'---------------------------------------------------------------------------- +' CheckFit +' +' Checks to see if the shape will fit into its new position. +' Returns TRUE if it fits and FALSE if it does not fit. +' +' PARAMETERS: None +' +'---------------------------------------------------------------------------- +Function CheckFit + + CheckFit = TRUE ' Assume the shape will fit. + + For i = 0 To XMATRIX ' Loop through all the blocks in the + For j = 0 To YMATRIX ' shape and see if any would + ' overlap blocks already in the well. + If BlockShape(i, j, CurBlock.Style) = 1 Then ' 1 means that space, within the falling shape, is filled with a block. + Select Case CurBlock.Rotation ' Base the check on the rotation of the shape. + Case 0 ' No rotation. + NewX = CurBlock.X + i + NewY = CurBlock.Y + j + Case 1 ' Rotated 90 degrees clockwise, or 270 degrees counterclockwise. + NewX = CurBlock.X - j + 2 + NewY = CurBlock.Y + i - 1 + Case 2 ' Rotated 180 degrees. + NewX = CurBlock.X - i + 3 + NewY = CurBlock.Y - j + 1 + Case 3 ' Rotated 270 degrees clockwise, or 90 degrees counterclockwise. + NewX = CurBlock.X + j + 1 + NewY = CurBlock.Y - i + 2 + End Select + + ' Set CheckFit to false if the block would be out of the well. + If (NewX > WELLWIDTH - 1 Or NewX < 0 Or NewY > WELLHEIGHT - 1 Or NewY < 0) Then + CheckFit = FALSE + Exit Function + + ' Otherwise, set CheckFit to false if the block overlaps + ' an existing block. + ElseIf WellBlocks(NewX, NewY) Then + CheckFit = FALSE + Exit Function + End If + + End If + Next j + Next i + +End Function + +'---------------------------------------------------------------------------- +' CheckForFullRows +' +' Checks for filled rows. If a row is filled, delete it and move +' the blocks above down to fill the deleted row. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub CheckForFullRows + + Dim RowsToDelete(WELLHEIGHT) ' Temporary array to track rows that should be deleted. + NumRowsToDelete = 0 + i = WELLHEIGHT ' Begin scanning from the bottom up. + Do + DeleteRow = TRUE ' Assume the row should be deleted. + j = 0 + Do ' Scan within each row for blocks. + DeleteRow = DeleteRow * Sgn(WellBlocks(j, i)) ' If any position is blank, DeleteRow is 0 (FALSE). + j = j + 1 + Loop While DeleteRow = TRUE And j < WELLWIDTH + + If DeleteRow = TRUE Then + ' Walk up the rows and copy them down in the WellBlocks array. + NumRowsToDelete = NumRowsToDelete + 1 ' Number of rows to delete. + RowsToDelete(i - NumDeleted) = TRUE ' Mark the rows to be deleted, compensating for rows that have already been deleted below it. + NumDeleted = NumDeleted + 1 ' Compensates for rows that have been deleted already. + + ' Logically delete the row by moving all WellBlocks values down. + For Row = i To 1 Step -1 + For Col = 0 To WELLWIDTH + WellBlocks(Col, Row) = WellBlocks(Col, Row - 1) + Next Col + Next Row + Else ' This row will not be deleted. + i = i - 1 + End If + Loop While i >= 1 ' Stop looping when the top of the well is reached. + + If NumRowsToDelete > 0 Then + Score = Score + 100 * NumRowsToDelete ' Give 100 points for every row. + + ' Set Highest and Lowest such that any deleted row will initially set them. + Highest = -1 + Lowest = 100 + + ' Find where the highest and lowest rows to delete are. + For i = WELLHEIGHT To 1 Step -1 + If RowsToDelete(i) = TRUE Then + If i > Highest Then Highest = i + If i < Lowest Then Lowest = i + End If + Next i + + If (Highest - Lowest) + 1 = NumRowsToDelete Then ' Only one contiguous group of rows to delete. + DeleteChunk Highest, Lowest + Else ' Two groups of rows to delete. + ' Begin at Lowest and scan down for a row NOT to be deleted. + ' Then delete everything from Lowest to the row not to be deleted. + i = Lowest + Do While i <= Highest + If RowsToDelete(i) = FALSE Then + DeleteChunk i - 1, Lowest + Exit Do + Else + i = i + 1 + End If + Loop + + ' Now look for the second group and delete those rows. + Lowest = i + Do While RowsToDelete(Lowest) = FALSE + Lowest = Lowest + 1 + Loop + DeleteChunk Highest, Lowest + + End If + End If + +End Sub + +'---------------------------------------------------------------------------- +' DeleteChunk +' +' Deletes a group of one or more rows. +' +' PARAMETERS: Highest - Highest row to delete (physically lowest +' on screen). +' Lowest - Lowest row to delete (physically highest +' on screen). +'---------------------------------------------------------------------------- +Sub DeleteChunk (Highest, Lowest) + + ' GET the image of the row to delete. + Get (WELLX, Lowest * YSIZE + WELLY)-(WELLX + WELLWIDTH * XSIZE, (Highest + 1) * YSIZE + WELLY - 1), Temp() + Play PLAYCLEARROW + + ' Flash the rows 3 times. + For Flash = 1 To 3 + Put (WELLX, Lowest * YSIZE + WELLY), Temp(), PReset + DelayTime! = Timer + .02 + Do While Timer < DelayTime!: Loop + Put (WELLX, Lowest * YSIZE + WELLY), Temp(), PSet + DelayTime! = Timer + .02 + Do While Timer < DelayTime!: Loop + Next Flash + + ' Move all the rows above the deleted ones down. + Get (WELLX, WELLY)-(WELLX + WELLWIDTH * XSIZE, Lowest * YSIZE + WELLY), Temp() + Put (WELLX, (Highest - Lowest + 1) * YSIZE + WELLY), Temp(), PSet + 'Erase the area above the block which just moved down. + Line (WELLX, WELLY)-(WELLX + WELLWIDTH * XSIZE, WELLY + (Highest - Lowest + 1) * YSIZE), WellColor, BF +End Sub + +'---------------------------------------------------------------------------- +' DisplayChanges +' +' Displays list of changes that the player can easily make. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayChanges + + DisplayGameTitle ' Print game title. + + Color 7 + Center "The following game characteristics can be easily changed from", 5 + Center "within the QuickBASIC Interpreter. To change the values of ", 6 + Center "these characteristics, locate the corresponding CONST or DATA", 7 + Center "statements in the source code and change their values, then ", 8 + Center "restart the program (press Shift + F5). ", 9 + + Color 15 + Center "Block shapes ", 11 + Center "Block rotation ", 12 + Center "Number of different block shapes ", 13 + Center "Score needed to advance to next level", 14 + Center "Width of the game well ", 15 + Center "Height of the game well ", 16 + Center "Songs played during game ", 17 + + Color 7 + Center "The CONST statements and instructions on changing them are ", 19 + Center "located at the beginning of the main program. ", 20 + + Do While InKey$ = "": Loop ' Wait for any key to be pressed. + Cls ' Clear screen. + +End Sub + +'---------------------------------------------------------------------------- +' DisplayGameTitle +' +' Displays title of the game. +' +' PARAMETERS: None. +'---------------------------------------------------------------------------- +Sub DisplayGameTitle + + Screen 0 + Width 80, 25 ' Set width to 80, height to 25. + Color 4, 0 ' Set colors for red on black. + Cls ' Clear the screen. + ScreenWidth = 80 ' Set screen width variable to match current width. + + ' Draw outline around screen with extended ASCII characters. + Locate 1, 2 + Print Chr$(201); String$(76, 205); Chr$(187); + For i% = 2 To 24 + Locate i%, 2 + Print Chr$(186); Tab(79); Chr$(186); + Next i% + Locate 25, 2 + Print Chr$(200); String$(76, 205); Chr$(188); + + 'Print game title centered at top of screen + Color 0, 4 + Center " Microsoft ", 1 + Center " Q B L O C K S ", 2 + Center " Press any key to continue ", 25 ' Center prompt on line 25. + Color 7, 0 + +End Sub + +'---------------------------------------------------------------------------- +' DisplayIntro +' +' Explains the object of the game and how to play. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayIntro + + Cls + DisplayGameTitle + + Center "QBlocks challenges you to keep the well from filling. Do this by", 5 + Center "completely filling rows with blocks, making the rows disappear. ", 6 + Center "Move and rotate the falling shapes to get them into the best ", 7 + Center "position. The game will get faster as you score more points. ", 8 + + Color 4 ' Change foreground color for line to red. + Center String$(74, 196), 11 ' Put horizontal red line on screen. + Color 7 ' White (7) letters. ' Change foreground color back to white + Center " Game Controls ", 11 ' Display game controls. + Center " General Block Control ", 13 + Center " (Rotate)", 15 + Center " P - Pause " + Chr$(24) + " (or 5) ", 16 + Center " Q - Quit (Left) " + Chr$(27) + " " + Chr$(26) + " (Right) ", 17 + Center " " + Chr$(25), 18 + Center " (Drop) ", 19 + + Do ' Wait for any key to be pressed. + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Q" Then 'Allow player to quit now + Cls + Locate 10, 30: Print "Really quit? (Y/N)"; + Do + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Y" Then + Cls + End + End If + End If + +End Sub + +'---------------------------------------------------------------------------- +' DrawAllShapes +' +' Quickly draws all shapes in all four rotations. Uses GET +' to store the images so they can be PUT onto the screen +' later very quickly. +' +' PARAMETERS: None. +'---------------------------------------------------------------------------- +Sub DrawAllShapes + + Dim b As BlockType + Screen ScreenMode ' Set the appropriate screen mode. + + ' On EGA and VGA systems, appear to blank the screen. + If ScreenMode = 7 Then + Dim Colors(0 To 15) ' DIM an array of 16 elements. By default, all elements are 0. + Palette Using Colors() ' Redefine the colors all to 0. + For i = 1 To NUMSTYLES ' Set block colors EGA, VGA + BlockColor(i) = ((i - 1) Mod 7) + 1 + Next i + Else + For i = 1 To NUMSTYLES 'Set block colors for CGA + BlockColor(i) = ((i - 1) Mod 3) + 1 + Next i + End If + + Cls + Count = 0 ' Count determines how many shapes have been drawn on the screen and vertically where. + For shape = 1 To NUMSTYLES ' Loop through all shapes. + + RtSide = 4 + Do + If BlockShape(RtSide - 1, 0, shape) = 1 Or BlockShape(RtSide - 1, 1, shape) = 1 Then Exit Do + RtSide = RtSide - 1 + Loop Until RtSide = 1 + + LtSide = 0 + Do + If BlockShape(LtSide, 0, shape) = 1 Or BlockShape(LtSide, 1, shape) = 1 Then Exit Do + LtSide = LtSide + 1 + Loop Until LtSide = 3 + + For Rotation = 0 To 3 ' Loop through all rotations. + b.X = Rotation * 4 + 2 ' Determine where to put the shape. + b.Y = Count + 2 + b.Rotation = Rotation + b.Style = shape + Show b ' Draw the shape. + + X = b.X: Y = b.Y + Select Case Rotation ' Based on Rotation, determine where the shape really is on the screen. + Case 0 ' No rotation. + x1 = X: x2 = X + RtSide: y1 = Y: y2 = Y + 2 + Case 1 ' Rotated 90 degrees clockwise. + x1 = X + 1: x2 = X + 3: y1 = Y - 1: y2 = Y + RtSide - 1 + Case 2 ' 180 degrees. + x1 = X: x2 = X + 4 - LtSide: y1 = Y: y2 = Y + 2 + Case 3 ' Rotated 270 degrees clockwise. + x1 = X + 1: x2 = X + 3: y1 = Y - 1: y2 = Y + 3 - LtSide + End Select + + ' Store the image of the rotated shape into an array for fast recall later. + Get (x1 * XSIZE, y1 * YSIZE)-(x2 * XSIZE, y2 * YSIZE), BlockImage(((shape - 1) * 4 + Rotation) * ELEMENTSPERBLOCK) + + Next Rotation + + Count = Count + 5 ' Increase Count by 5 to leave at least one blank line between shapes. + If Count = 20 Then ' No space for any more shapes. + Cls + Count = 0 + End If + + Next shape + + Cls + + ' Changes the color palette if SCREEN is used. + If ScreenMode = 7 Then + Palette ' Restore default color settings. + Palette 6, 14 ' Make brown (6) look like yellow (14). + Palette 14, 15 ' Make yellow (14) look like bright white (15). + End If + +End Sub + +'---------------------------------------------------------------------------- +' DrawBlock +' +' Draws one block of a QBlocks shape. +' +' PARAMETERS: X - Horizontal screen location. +' Y - Vertical screen location. +' FillColor - The primary color of the block. +' The top and left edges will be the +' brighter shade of that color. +'---------------------------------------------------------------------------- +Sub DrawBlock (X, Y, FillColor) + + Line (X * XSIZE + 2, Y * YSIZE + 2)-((X + 1) * XSIZE - 2, (Y + 1) * YSIZE - 2), FillColor, BF + Line (X * XSIZE + 1, Y * YSIZE + 1)-((X + 1) * XSIZE - 1, Y * YSIZE + 1), FillColor + 8 + Line (X * XSIZE + 1, Y * YSIZE + 1)-(X * XSIZE + 1, (Y + 1) * YSIZE - 1), FillColor + 8 + +End Sub + +'---------------------------------------------------------------------------- +' DrawPattern +' +' Draws a background pattern that is 32 pixels wide by 20 pixels +' deep. Gets the pattern and duplicates it to fill the screen. +' +' PARAMETERS: Pattern - Which of the 10 available patterns to +' draw. +'---------------------------------------------------------------------------- +Sub DrawPattern (Pattern) + + Cls + X = 1: Y = 1 + Dim Temp2(215) As Integer ' Create an array to store the image. + + ' Draw the pattern specified. + Select Case Pattern + Case 0 + j = Y + 21 + For i = X To X + 27 Step 3 + j = j - 2 + Line (i, j)-(i, Y + 19), 12, BF + Next i + Line (X, Y)-(X + 30, Y + 19), 4, B + Line (X + 1, Y + 1)-(X + 31, Y + 18), 4, B + Case 1 + Line (X, Y)-(X + 8, Y + 12), 1, BF + Line (X + 9, Y + 8)-(X + 24, Y + 20), 2, BF + Line (X + 25, Y)-(X + 32, Y + 12), 3, BF + Case 2 + Line (X, Y)-(X + 29, Y + 18), X / 32 + 1, B + Line (X + 1, Y + 1)-(X + 28, Y + 17), X / 32 + 2, B + Case 3 + For i = 0 To 9 Step 2 + Line (X + i, Y + i)-(X + 29 - i, Y + 18 - i), i, B + Next i + Case 4 + j = 0 + For i = 1 To 30 Step 3 + Line (X + i, Y + j)-(X + 30 - i, Y + j), i + Line (X + i, Y + 19 - j)-(X + 30 - i, Y + 19 - j), i + j = j + 2 + Next i + Case 5 + Line (X, Y)-(X + 29, Y + 4), 1, BF + Line (X, Y)-(X + 4, Y + 18), 1, BF + Line (X + 7, Y + 7)-(X + 29, Y + 11), 5, BF + Line (X + 7, Y + 7)-(X + 11, Y + 18), 5, BF + Line (X + 14, Y + 14)-(X + 29, Y + 18), 4, BF + Case 6 + Line (X + 15, Y)-(X + 17, Y + 19), 1 + Line (X, Y + 9)-(X + 31, Y + 11), 2 + Line (X, Y + 1)-(X + 31, Y + 18), 9 + Line (X + 30, Y)-(X + 1, Y + 19), 10 + Case 7 + For i = 1 To 6 + Circle (X + 16, Y + 10), i, i + Next i + Case 8 + For i = X To X + 30 Step 10 + Circle (i, Y + 9), 10, Y / 20 + 1 + Next i + Case 9 + Line (X + 1, Y)-(X + 1, Y + 18), 3 + Line (X + 1, Y)-(X + 12, Y + 18), 3 + Line (X + 1, Y + 18)-(X + 12, Y + 18), 3 + Line (X + 30, Y)-(X + 30, Y + 18), 3 + Line (X + 30, Y)-(X + 19, Y + 18), 3 + Line (X + 30, Y + 18)-(X + 19, Y + 18), 3 + Line (X + 4, Y)-(X + 26, Y), 1 + Line (X + 4, Y)-(X + 15, Y + 18), 1 + Line (X + 26, Y)-(X + 15, Y + 18), 1 + End Select + + Get (0, 0)-(31, 19), Temp2() ' GET the image. + + ' Duplicate the image 10 times across by 10 times down. + For H = 0 To 319 Step 32 + For V = 0 To 199 Step 20 + Put (H, V), Temp2(), PSet + Next V + Next H + +End Sub + +'---------------------------------------------------------------------------- +' DrawPlayingField +' +' Draws the playing field, including the well, the title, the +' score/level box, etc. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DrawPlayingField + + Select Case ScreenMode ' Choose the screen colors based on the current mode. + Case 7 + WellColor = WELLCOLOR7 + BorderColor = BORDERCOLOR7 + + Case Else ' Setup for SCREEN 1. + WellColor = WELLCOLOR1 + BorderColor = BORDERCOLOR1 + End Select + + ScreenWidth = 40 ' Set to proper width and colors. + + ' Draw the background pattern. + DrawPattern Level + + ' Draw the well box. + Line (WELLX - 1, WELLY - 5)-(WELLX + WELLWIDTH * XSIZE + 1, WELLY + WELLHEIGHT * YSIZE + 1), WellColor, BF + Line (WELLX - 1, WELLY - 5)-(WELLX + WELLWIDTH * XSIZE + 1, WELLY + WELLHEIGHT * YSIZE + 1), BorderColor, B + + ' Draw the title box. + Line (XSIZE, WELLY - 5)-(XSIZE * 8, WELLY + 12), WellColor, BF + Line (XSIZE, WELLY - 5)-(XSIZE * 8, WELLY + 12), BorderColor, B + + ' Draw the scoring box. + Line (XSIZE, WELLY + 20)-(WELLX - 2 * XSIZE, 78), WellColor, BF + Line (XSIZE, WELLY + 20)-(WELLX - 2 * XSIZE, 78), BorderColor, B + + MakeInfoBox ' Draw the Information Box. + + Color 12 + Locate 3, 5: Print "QBLOCKS" ' Center the program name on line 2. + Color BorderColor + + ' Draw the scoring area. + Locate 6, 4: Print "Score:"; + Locate 7, 4: Print Using "#,###,###"; Score + Locate 9, 4: Print Using "Level: ##"; Level + +End Sub + +'---------------------------------------------------------------------------- +' GameOver +' +' Ends the game and asks the player if he/she wants to play +' again. GameOver returns TRUE if the player wishes to stop +' or FALSE if the player wants another game. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Function GameOver + + Play PLAYGAMEOVER ' Play the game over tune. + MakeInfoBox + + Do While InKey$ <> "": Loop ' Clear the keyboard buffer. + + ' Put Game Over messages into the InfoBox. + Locate 14, 4: Print "Game Over" + Locate 17, 6: Print "Play" + Locate 18, 5: Print "again?" + Locate 20, 6: Print "(Y/N)" + + ' Wait for the player to press either Y or N. + Do + a$ = UCase$(InKey$) ' UCASE$ assures that the key will be uppercase. This eliminates the need to check for y and n in addition to Y and N. + Loop Until a$ = "Y" Or a$ = "N" + + If a$ = "Y" Then ' If player selects "Y", + GameOver = FALSE ' game is not over, + Else ' otherwise + GameOver = TRUE ' the game is over. + End If + +End Function + +'---------------------------------------------------------------------------- +' InitScreen +' +' Draws the playing field and ask for the desired starting level. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub InitScreen + + DrawPlayingField ' Draw playing field assuming Level 0. + + ' Prompt for starting level. + Color 12 ' Change foreground color to bright red. + Locate 14, 5: Print "Select"; + Locate 16, 5: Print "start"; + Locate 18, 5: Print "level?"; + Locate 20, 5: Print "(0 - 9)"; + Color BorderColor ' Restore the default text color to BorderColor (white). + Level = TRUE ' Use level as flag as well as a real value. Level remain TRUE if Q (Quit) is pressed instead of a level. + + ' Get a value for Level or accept a Q. + Do + a$ = UCase$(InKey$) + Loop While (a$ > "9" Or a$ < "0") And a$ <> "Q" + + If a$ = "Q" Then + Exit Sub + Else + Level = Val(a$) + End If + + If Level > 0 Then DrawPlayingField ' Draw new playing field because the background pattern depends on the level. + RedrawControls ' Draw the controls. + +End Sub + +'---------------------------------------------------------------------------- +' MakeInfoBox +' +' Draws the information box. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub MakeInfoBox + + Line (WELLX - 9 * XSIZE, 90)-(WELLX - 2 * XSIZE, 185), WellColor, BF ' Clear the Info area. + Line (WELLX - 9 * XSIZE, 90)-(WELLX - 2 * XSIZE, 185), BorderColor, B ' Draw a border around it. + +End Sub + +'---------------------------------------------------------------------------- +' NewBlock +' +' Initializes a new falling shape about to enter the well. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub NewBlock + + CurBlock.Style = Int(Rnd(1) * NUMSTYLES) + 1 ' Randomly pick a block style. + CurBlock.X = (WELLWIDTH \ 2) - 1 ' Put the new shape in the horizontal middle of the well + CurBlock.Y = 0 ' and at the top of the well. + CurBlock.Rotation = 0 ' Begin with no rotation. + + Play PLAYNEWBLOCK + +End Sub + +'---------------------------------------------------------------------------- +' PerformGame +' +' Continues to play the game until the player quits. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub PerformGame + + Do ' Loop for repetitive games + a$ = "" + Erase WellBlocks ' Set all the elements in the WellBlocks array to 0. + Score = 0 ' Clear initial score. + Level = 0 ' Assume Level 0. + PrevScore = BASESCORE - NEXTLEVEL ' Set score needed to get to first level + GameTiltScore = WINGAME ' Set the initial win game value. + + InitScreen ' Prepare the screen and get the difficulty level. + If Level = -1 Then Exit Sub ' Player pressed Q instead of a level. + + TargetTime = Timer + 1 / (Level + 1) ' TargetTime is when the falling shape will move down again. + Do ' Create new falling shapes until the game is over. + DoneWithThisBlock = FALSE ' This falling shape is not done falling yet. + NewBlock ' Create a new falling unit. + If CheckFit = FALSE Then Exit Do ' If it does not fit, then the game is over. + PutBlock CurBlock ' Display the new shape. + + Do ' Continue dropping the falling shape. + OldBlock = CurBlock ' Save current falling shape for possible later use. + Do ' Loop until enough time elapses. + + ValidEvent = TRUE ' Assume a key was pressed. + ans$ = UCase$(InKey$) + + If ans$ = PAUSE Or ans$ = QUIT Then + MakeInfoBox + + ' SELECT CASE will do different actions based on the + ' value of the SELECTED variable. + Select Case ans$ + Case PAUSE + Sound 1100, .75 + Locate 16, 6: Print "GAME"; + Locate 18, 5: Print "PAUSED"; + Do While InKey$ = "": Loop ' Wait until another key is pressed. + Case QUIT + ' Play sounds to tell the player that Q was pressed. + Sound 1600, 1 + Sound 1000, .75 + + ' Confirm that the player really wants to quit. + Locate 15, 5: Print "Really"; + Locate 17, 6: Print "quit?"; + Locate 19, 6: Print "(Y/N)"; + Do + a$ = UCase$(InKey$) + Loop Until a$ <> "" + If a$ = "Y" Then Exit Sub + End Select + RedrawControls ' Redraw controls if either Q or P is pressed. + + Else ' A key was pressed but not Q or P. + ans = Asc(Right$(Chr$(0) + ans$, 1)) ' Convert the key press to an ASCII code for faster processing. + Select Case ans + Case DOWNARROW, DOWNARROW2, SPACEBAR ' Drop shape immediately. + Do ' Loop to drop the falling unit one row at a time. + CurBlock.Y = CurBlock.Y + 1 + Loop While CheckFit = TRUE ' Keep looping while the falling unit isn't stopped. + CurBlock.Y = CurBlock.Y - 1 ' Went one down too far, restore to previous. + TargetTime = Timer - 1 ' Ensure that the shape falls immediately. + Case RIGHTARROW, RIGHTARROW2 + CurBlock.X = CurBlock.X + 1 ' Move falling unit right. + Case LEFTARROW, LEFTARROW2 + CurBlock.X = CurBlock.X - 1 ' Move falling unit left. + Case UPARROW, UPARROW2, UPARROW3 + CurBlock.Rotation = ((CurBlock.Rotation + ROTATEDIR) Mod 4) ' Rotate falling unit. + Case Else + ValidEvent = FALSE + End Select + + If ValidEvent = TRUE Then + If CheckFit = TRUE Then ' If the move is valid and the shape fits in the new position, + PutBlock OldBlock ' erase the shape from its old position + PutBlock CurBlock ' and display it in the new position. + OldBlock = CurBlock + Else + CurBlock = OldBlock ' If it does not fit then reset CurBlock to the OldBlock. + End If + End If + End If + + Loop Until Timer >= TargetTime ' Keep repeating the loop until it is time to drop the shape. This allows many horizontal movements and rotations per vertical step. + + TargetTime = Timer + 1 / (Level + 1) ' The player has less time between vertical movements as the skill level increases. + CurBlock.Y = CurBlock.Y + 1 ' Try to drop the falling unit one row. + + If CheckFit = FALSE Then ' Cannot fall any more. + DoneWithThisBlock = TRUE ' Done with this block. + CurBlock = OldBlock + End If + + PutBlock OldBlock ' Erase the falling shape from the old position, + PutBlock CurBlock ' and display it in the new position. + OldBlock = CurBlock + + Loop Until DoneWithThisBlock ' Continue getting keys and moving shapes until the falling shape stops. + + AddBlockToWell ' Shape has stopped so logically add it to the well. + CheckForFullRows ' Check to see if a row(s) is now full. If so, deletes it. + UpdateScoring ' Use the UpdateScoring subprogram to add to the score. + + If Score >= GameTiltScore Then ' See if the score has hit the tilt score. + + Play PLAYWINGAME + MakeInfoBox + Locate 13, 5: Print Using "#######"; Score + Play PLAYWINGAME + + If GameTiltScore = TILTVALUE Then ' If the player has tilted the game. + Locate 15, 4: Print "GAME TILT" + Locate 17, 5: Print "You are" + Locate 18, 4: Print "Awesome!" + Locate 20, 4: Print "Press any" + Locate 21, 6: Print "key..." + Play PLAYWINGAME + Do While InKey$ = "": Loop + Exit Sub + Else ' If they just met the WINGAME value. + Locate 15, 4: Print "YOU WON!" + Locate 17, 5: Print "Want to" + Locate 18, 4: Print "continue" + Locate 20, 6: Print "(Y/N)" + + Do ' DO loop to wait for the player to press anything. + a$ = UCase$(InKey$) ' The UCASE$ function assures that a$ always has an uppercase letter in it. + Loop Until a$ <> "" + + If a$ <> "Y" Then Exit Do ' Exit this main loop if the player pressed anything but Y. + + GameTiltScore = TILTVALUE ' Reset to the tilt value. + + RedrawControls + End If + End If + + Loop ' Unconditional loop. Each game is stopped by the EXIT DO command at the top of this loop that executes when a new block will not fit in the well. + Loop Until GameOver ' GameOver is always TRUE (-1) unless the user presses X or the well is full. + +End Sub + +'---------------------------------------------------------------------------- +' PutBlock +' +' Uses very fast graphics PUT command to draw the shape. +' +' PARAMETERS: B - Block to be put onto the screen. +'---------------------------------------------------------------------------- +Sub PutBlock (b As BlockType) + + Select Case b.Rotation ' Base exact placement on the rotation. + Case 0 ' No rotation. + x1 = b.X: y1 = b.Y + Case 1 ' Rotated 90 degrees clockwise, or 270 degrees counterclockwise. + x1 = b.X + 1: y1 = b.Y - 1 + Case 2 ' Rotated 180 degrees. + x1 = b.X: y1 = b.Y + Case 3 ' Rotated 270 degrees clockwise, or 90 degrees counterclockwise. + x1 = b.X + 1: y1 = b.Y - 1 + End Select + + ' Actually PUT the rotated shape on the screen. The XOR option makes the + ' new image blend with whatever used to be there in such a way that + ' identical colors cancel each other out. Therefore, one PUT with the XOR + ' option can draw an object while the second PUT to that same location + ' erases it without affecting anything else near it. Often used for animation. + + Put (x1 * XSIZE + WELLX, y1 * YSIZE + WELLY), BlockImage(((b.Style - 1) * 4 + b.Rotation) * ELEMENTSPERBLOCK), Xor ' XOR mixes what used to be there on the screen with the new image. Two identical colors cancel each other. + +End Sub + +'---------------------------------------------------------------------------- +' RedrawControls +' +' Puts control keys information into the information box. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub RedrawControls + + ' Draw the InfoBox and erase anything that used to be in it. + MakeInfoBox + + ' Print the key assignments within the Info Box. + Color BorderColor + Locate 13, 4: Print "Controls" + Locate 14, 4: Print "--------" + Locate 15, 4: Print Chr$(24) + " = Turn" + Locate 16, 4: Print Chr$(27) + " = Left" + Locate 17, 4: Print Chr$(26) + " = Right" + Locate 18, 4: Print Chr$(25) + " = Drop" + Locate 20, 4: Print "P = Pause" + Locate 21, 4: Print "Q = Quit" + +End Sub + +'---------------------------------------------------------------------------- +' Show +' +' Draws the falling shape one block at a time. Only used by +' DisplayAllShapes. After that, PutBlock draws all falling +' shapes. +' +' PARAMETERS: B - Block to be put onto the screen. +'---------------------------------------------------------------------------- +Sub Show (b As BlockType) + + ' Loop through all possible block locations. + For i = 0 To XMATRIX + For j = 0 To YMATRIX + + If BlockShape(i, j, b.Style) = 1 Then ' 1 means there is a block there. + Select Case b.Rotation ' Exact screen position is determined by the rotation. + Case 0 ' No rotation. + DrawBlock b.X + i, b.Y + j, BlockColor(b.Style) + Case 1 ' Rotated 90 degrees clockwise, or 270 degrees counterclockwise. + DrawBlock b.X - j + 2, b.Y - 1 + i, BlockColor(b.Style) + Case 2 ' Rotated 180 degrees. + DrawBlock b.X + 3 - i, b.Y - j + 1, BlockColor(b.Style) + Case 3 ' Rotated 270 degrees clockwise, or 90 degrees counterclockwise. + DrawBlock b.X + j + 1, b.Y - i + 2, BlockColor(b.Style) + End Select + End If + Next j + Next i + +End Sub + +'--------------------------------------------------------------------------- +' UpdateScoring +' +' Puts the new score on the screen. Checks if the new score forces +' a new level. If so, change the background pattern to match the +' new level. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub UpdateScoring + + ' Increase the level if the score is high enough and the level is not + ' maximum already. + If Level < 9 And Score >= (NEXTLEVEL * (Level + 1) + PrevScore) Then + + ' Store the entire well image to quickly PUT it back after the + ' background changes. + Get (WELLX, WELLY)-(WELLX + WELLWIDTH * XSIZE, WELLY + WELLHEIGHT * YSIZE), Temp() + + PrevScore = Score ' Save previous Score for next level. + Level = Level + 1 + DrawPlayingField ' Draw playing field again, this time with the new background pattern. + Put (WELLX, WELLY), Temp() ' Restore the image of the old well. + + RedrawControls ' Show the controls again. + End If + + Locate 7, 4: Print Using "#,###,###"; Score ' Print the score and level. + +End Sub + diff --git a/samples/qbricks/img/screenshot.png b/samples/qbricks/img/screenshot.png new file mode 100644 index 00000000..402019f0 Binary files /dev/null and b/samples/qbricks/img/screenshot.png differ diff --git a/samples/qbricks/index.md b/samples/qbricks/index.md new file mode 100644 index 00000000..2cc07f0b --- /dev/null +++ b/samples/qbricks/index.md @@ -0,0 +1,21 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QBRICKS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Breakout clone by Microsoft. +``` + +### File(s) + +* [qbricks.bas](src/qbricks.bas) + +🔗 [game](../game.md), [breakout](../breakout.md) diff --git a/samples/qbricks/src/qbricks.bas b/samples/qbricks/src/qbricks.bas new file mode 100644 index 00000000..f21ada54 --- /dev/null +++ b/samples/qbricks/src/qbricks.bas @@ -0,0 +1,1143 @@ +' QBRICKS.BAS +' +' Copyright (C) 1990 Microsoft Corporation. All Rights Reserved. +' +' Score points in QBricks by deflecting the ball into the brick walls. +' Hit the special bricks or clear all the bricks to advance to the next +' level. +' +' To run this game, press Shift+F5. +' +' To exit this program, press Alt, F, X. +' +' To get help on a BASIC keyword, move the cursor to the keyword and press +' F1 or click the right mouse button. +' +' To view suggestions on changing this game, press Page Down. +' +' +' Suggested Changes +' ----------------- +' +' There are many ways that you can modify this BASIC game. The CONST +' statements below these comments and the DATA statements at the end +' of this screen can be modified to change the following: +' Block patterns +' Length of paddles +' Number of special bricks +' Shape of the special bricks +' End-of-level bonus multiplier +' Paddle color +' Ball color +' Ball speed +' +' On the right side of each CONST statement, there is a comment that tells +' you what it does and how large or small you can set the value. Above the +' DATA statements, there are comments that tell you the format of the +' information stored there. +' +' On your own, you can also add exciting sounds and visual effects or make any +' other changes that your imagination can dream up. By reading the +' "Learn BASIC Now" book, you'll learn the techniques that will enable you +' to fully customize this game and to create games of your own. +' +' +' If the game won't run after you have changed it, you can exit without +' saving your changes by pressing Alt, F, X and choosing NO. +' +' If you do want to save your changes, press Alt, F, A and enter a filename +' for your version of the program. Before you save your changes, however, +' you should make sure they work by running the program and verifying that +' your changes produce the desired results. Also, always be sure to keep +' a backup of the original program. +' +DefInt A-Z + +Const INITIALBALLSPEED = .07 ' Initial speed of the ball in seconds. Range 0 (fastest) - .20 (slowest) +Const BALLCOLOR = 12 ' Ball color. Ranges from 1 to 15 but not BGCOLOR. +Const BGCOLOR = 0 ' Background color of the game. Range 0 to 7. +Const PLAYERCOLOR1 = 2 ' Paddle color for player 1. Range 1 to 15 but not BGCOLOR. +Const PLAYERCOLOR2 = 3 ' Paddle color for player 2. Range 1 to 15 but not BGCOLOR. +Const PADDLELENGTH1 = 50 ' Starting paddle length for player 1. Range 24 to 240. +Const PADDLELENGTH2 = 50 ' Starting paddle length for player 2. Range 24 to 120. +Const NUMSPECIALBRICKS = 1 ' Number of special bricks in each level. Range 0 to 50. Higher numbers make the game easier. +Const SPECIALCHAR = 14 ' ASCII value of the special character. 14 is a musical note. Try 3 for a heart or 2 for a smiley face. +Const BONUSMULTIPLIER = 500 ' Minimum bonus amount for each round. Range 0 to 1000 in increments of 100. +Const PADDLEHORIZONTALMOVE = 24 ' Number of spaces paddle moves left or right each time the left or right key is pressed. Range 1 to 30. +Const INITNUMBALLS = 3 ' Initial number of balls. Range 1 to 50. +Const LEVELNEWBALL = 3 ' Level interval at which an extra ball is awarded. +Const CUTLEVEL = 6 ' Level interval at which the paddle size is reduced. Range 2 to 10. +Const PADDLECUT = 33 ' The percent that the paddle will be reduced by. Range 0 to 99. For example, at 33, a paddle that is 50 pixels wide will become 33 pixels wide. +Const DEFAULTPLAYERS = 1 ' Default number of players. Range 1 or 2. +' The following sound constants are used by the PLAY command to +' produce music during the game. To change the sounds you hear, change +' these constants. Refer to the online help for PLAY for the correct format. +' To completely remove sound from the game set the constants equal to null. +' For example: STARTSOUND = "" +Const STARTSOUND = "MBT180O2L8CDEDCDFECDCL4EL8C" ' Music played when QBricks begins. +Const PADDLEHITSOUND = "MBT120 L64 o3 g" ' Music played when the ball hits the paddle. +Const BLOCKHITSOUND = "MB T255 L8 o" ' Music played when the ball hits a brick. +Const NEXTLEVELSOUND = "MB T240 L2 N30 N34 N38 N45" ' Music played between levels. +Const GAMEOVERSOUND = "T255 L16 O3 C O2 GEDC" ' Music played when the game is over. + +' The following are general constants and their values should not be changed. +Const TRUE = -1 ' QuickBASIC Interpreter uses -1 to mean TRUE. +Const FALSE = 0 ' 0 means FALSE. +Const PADDLEVERTICALMOVE = 4 ' Distance paddle moves up or down each time the Up key or Down key is pressed. +Const MAXLEVEL = 5 ' Level when the brick patterns start over. +Const SCREENWIDTH = 40 ' Maximum width of the screen in characters. +Const SCORECOLOR = 15 ' Color of the players' scores, level number and balls left displayed at the bottom of the screen. +Const MAXBLOCKROW = 9 ' Lowest row that has bricks on it. +Const STARTBRICKROW = 2 ' Highest row with bricks on it. +Const BRICKSIZE = 2 ' Width of a brick in character-sized units. +Const PIXELSIZE = 8 ' Number of pixels per brick. +Const MAXROW = 184 ' The highest (in pixels) a paddle can move. +Const MINROW = (MAXBLOCKROW + 2) * 8 ' The lowest (in pixels) a paddle can move. +Const UP1 = 104 ' ASCII code for UP key - Up for player 1. +Const DOWN1 = 112 ' ASCII code for DOWN key - Down for player 1. +Const LEFT1 = 107 ' ASCII code for LEFT key - Left for player 1. +Const RIGHT1 = 109 ' ASCII code for RIGHT key - Right for player 1. +Const UP2 = 101 ' ASCII code for e - Up for player 2. +Const LEFT2 = 115 ' ASCII code for s - Left for player 2. +Const RIGHT2 = 102 ' ASCII code for f - Right for player 2. +Const DOWN2 = 100 ' ASCII code for d - Down for player 2. +Const PAUSE = 112 ' ASCII code for p - Pause. +Const QUIT = 113 ' ASCII code for q - Quit. + +' DECLARE statements tell the main program that subprograms and functions +' exist and defines what data types they use. +DECLARE SUB BallHitPaddle (Player) ' Checks to see if the ball hit a paddle. If it did, deflect the ball. +DECLARE SUB Center (text$, Row) ' Centers a line of text on a given row. +DECLARE SUB DisplayChanges () ' Shows what changes can be made to this program. +DECLARE SUB DisplayGameTitle () ' Displays the title of the game. +DECLARE SUB DisplayIntro () ' Shows how to play the game. Used at the start of the game or when the Help key is pressed. +DECLARE SUB DrawBall (BallX, BallY) ' Draws or erases the ball. +DECLARE SUB DrawBrick (BrickX, BrickY, BrickColor) ' Draws or erases a brick. +DECLARE SUB DrawPaddle (PColor, PlayerNum) ' Draws or erases a paddle. +DECLARE SUB EraseBall (X, Y) ' Erases the ball. +DECLARE SUB EraseBrick (X, Y) ' Erases a brick after the ball hits it. The brick is physically erased by the DrawBrick subprogram. +DECLARE SUB GameOver () ' Checks to see if the game is over. If it is, ask player if he/she wants to play again. +DECLARE SUB GameParamSetup () ' Determine the speed of the computer, set the graphics mode, etc. +DECLARE SUB GetGameOptions () ' Asks for the number of players. +DECLARE SUB HorizontalScroll (display$, Row) ' Generic subprogram to move a line of text across the screen. +DECLARE SUB MovePaddle (NewX, NewY, PlayerNum) ' Moves the paddle(s). Checks that paddles do not overlap and that paddle is completely on the screen. +DECLARE SUB NewBall () ' Launches a new ball at the start of the game, between levels, or after a ball passes the paddles. +DECLARE SUB NextLevel () ' Adds bonus points, draws new brick pattern, etc. after each level is complete. +DECLARE SUB RedrawPaddles () ' Redraws the paddle(s). +DECLARE SUB SetDefaultPaddle () ' Positions the paddle(s) to initial point. +DECLARE SUB UpdateScreen () ' Redraws the score and levels. Used after a brick is hit or bonus points awarded. + +' Structure used for the paddles and the ball. +Type PositionType + X As Integer ' Horizontal (X) position of the paddle, in pixels. + Y As Integer ' Vertical (Y) position of the paddle, in pixels. + OldX As Integer ' Last X position. Used to erase the paddle or ball. + OldY As Integer ' Last Y position. Used to erase the paddle or ball. + Size As Integer ' Size of the paddles. + PColor As Integer ' Color of the ball or the paddle. + XOffset As Integer ' Increment of horizontal ball movement. + YOffset As Integer ' Increment of vertical ball movement. + speed As Single ' Interval, in seconds, between actual ball movements. + Score As Long ' Score for each player. + NumBricksHit As Integer ' Number of bricks each player has hit. +End Type + +' DIM SHARED indicates that a variable is available to all subprograms. +' Without this statement, a variable used in one subprogram cannot be +' used by another subprogram or the main program. +Dim Shared TempPADDLELENGTH As Integer ' Keeps the true length of the paddle. +Dim Shared ScreenMode As Integer ' Graphics screen mode used. +Dim Shared ScreenWide As Integer ' Width of the screen in characters +Dim Shared GraphicsWidth As Integer ' Width of the screen in pixels. +Dim Shared UsableWidth As Integer ' GraphicsWidth after assuming a small border around the screen. +Dim Shared Ball As PositionType ' Variable for the ball. +Dim Shared Bricks(25, 20) As Integer ' Array to represent all of the bricks on the screen. The values determine brick color. Blank spaces are filled with the background color (BgColor). +Dim Shared NumBalls As Integer ' Number of balls left. +Dim Shared Again As Integer ' Flag used to decide if the game should continue. +Dim Shared NeedBall As Integer ' Flag used to determine if a new ball is needed? +Dim Shared Level As Integer ' Current play level. +Dim Shared LevelCount As Long ' Number of bricks hit in the current level. +Dim Shared MAXLEVELCount As Long ' Maximum number of bricks in the current level. +Dim Shared TimeToMoveBall As Single ' Interval, in seconds, between ball movements. +Dim Shared special As String ' Special character. +Dim Shared JustHit As Integer ' Flag used to see if ball hit a paddle so the same paddle cannot hit the ball again until it hits the other paddle, a brick, or bounces off the top. +Dim Shared NumberOfPlayers As Integer ' Number of players. +Dim Shared LastHitBy As Integer ' Which player hit the ball last. +Dim Shared LevelOver As Integer ' Flag that is TRUE when a level is completed. +Dim Shared ActualBallSpeed As Single ' Initial ball speed after determining the machine speed. +Dim Shared Ballshape(20) As Integer ' Array in which the ball image is stored. +Dim Shared EraseBallOK As Integer ' Flag to decide if the ball's last position should be erased. +Dim Shared LastX As Integer ' Flag that determines if the ball has just deflected horizontally off a brick. +Dim Shared LastY As Integer ' Flag that determines if the ball has just deflected vertically off a brick. +Dim BadMode As Integer ' Flag used to determine which graphics mode to use. +Dim KeyFlags As Integer ' Holds the status of various keys, including Num Lock. + +Randomize Timer ' Seed the random number generator. + +special = "" ' Build the string used to display the special bricks. +For X = 1 To BRICKSIZE + special = special + Chr$(SPECIALCHAR) ' Add the SPECIALCHAR to the string. +Next X ' Repeat until the loop is done BRICKSIZE times. + +' Determine which graphics mode to use. +On Error GoTo ScreenError ' Set up a place to jump to if an error occurs in the program. +BadMode = FALSE ' Assume that the graphics mode is okay. +ScreenMode = 7 ' Set mode to 7 (an EGA mode). +Screen ScreenMode ' Attempt SCREEN 7. +If BadMode = TRUE Then ' If this attempt failed: + ScreenMode = 1 ' try mode 1 (a CGA mode), + BadMode = FALSE ' assume that graphics mode is okay, + Screen ScreenMode ' attempt SCREEN 1. +End If +On Error GoTo 0 ' Turn off error handling. + +If BadMode = TRUE Then ' If no graphics adapter... + Cls + Locate 11, 13: Print "CGA, EGA Color, or VGA graphics required to run QBRICKS.BAS" +Else + Def Seg = 0 ' Save the keyboard flags but force them all off for this game. + KeyFlags = Peek(1047) ' Read the location that stores the keyboard flag. + Poke 1047, &H0 ' Force them off. + Def Seg ' Restore the default segment. + + DisplayIntro ' Display the introduction screen now. + GetGameOptions ' Ask how many players. + + Dim Shared Paddle(NumberOfPlayers) As PositionType ' Array used to represent the paddles. + Level = 0 ' Start at the first level + Again = TRUE ' Set the flag used to continue the game. + NextLevel ' Set up the next level. + + Do + 'The code below moves the ball. + If Timer >= TimeToMoveBall Then ' Time to move the ball again? + TimeToMoveBall = Timer + Ball.speed ' Decide when to move the ball again. + LevelOver = FALSE ' Flag that is false unless a level has just been cleared. + DeflectY = FALSE ' Flag that determines if the ball's vertical direction (Y) should be reversed. + DeflectX = FALSE + + Ball.X = Ball.X + Ball.XOffset ' Updates the ball's horizontal and vertical location. + Ball.Y = Ball.Y + Ball.YOffset + + ' Horizontally off the screen? + If Ball.X < 4 Or Ball.X > UsableWidth Then + DeflectX = TRUE + LastX = FALSE + LastY = FALSE + End If + + ' At the top of the screen? + If Ball.Y < 4 Then + DeflectY = TRUE ' Deflect the ball + JustHit = FALSE ' Allow a paddle to hit the ball + LastX = FALSE + LastY = FALSE + ElseIf Ball.Y > MAXROW Then GameOver 'If not, did the ball just pass the lowest point that the paddles can go? + End If + + BallX = Ball.X \ 16 ' Determines where the ball is relative to the bricks (20 bricks fit on the 320 pixel screen so each brick is 16 pixels wide). + BallY = Ball.Y \ 8 ' Similar to above but for the Y direction. The screen is 200 pixels high. + + LevelOver = FALSE ' Assume that the level is not over yet. + + If Bricks(BallY, BallX) <> BGCOLOR Then ' Hit a brick? + ' Yes. Hit a brick. + If EraseBallOK Then DrawBall Ball.OldX, Ball.OldY ' Erase the ball. + EraseBrick BallX, BallY ' Erase the brick. + EraseBallOK = FALSE ' Since the new ball location was never drawn, EraseBallOK must be FALSE to keep the game from trying to erase it. + WhereX = Ball.X Mod 16 ' Horizontal position within the brick. + + ' If the ball hits the left or right edge, try to bounce by + ' changing the horizontal offset. If that just happened, + ' change the vertical offset instead. + If (Not LastX And (WhereX = 0 Or WhereX = 12)) Or LastY Then + DeflectX = TRUE ' Change X direction. + LastX = TRUE ' Mark last deflection as in the X direction. + Else ' If the ball hit the middle of a block... + DeflectY = TRUE ' Change Y direction. + LastY = TRUE ' Mark last deflection as in the Y direction. + End If + Else + If EraseBallOK Then DrawBall Ball.OldX, Ball.OldY ' Erase the old position of the ball unless another part of the program said not to erase it. + DrawBall Ball.X, Ball.Y ' Draw ball in the new location. + Ball.OldX = Ball.X ' Update the old X and Y positions. + Ball.OldY = Ball.Y + EraseBallOK = TRUE ' Assume that it is okay to delete the ball next time. + LastX = FALSE ' Reset LastX and LastY so they'll be clear next time. + LastY = FALSE + End If + + ' The FOR...NEXT loop below tests to see if the new ball position + ' has hit a paddle. If so, update ball and paddle. + For Player = 1 To NumberOfPlayers + BallHitPaddle Player + Next Player + + ' Change the direction of the ball as appropriate. + If DeflectY And Not LevelOver Then Ball.YOffset = -Ball.YOffset + If DeflectX Then Ball.XOffset = -Ball.XOffset + End If + + k$ = InKey$ ' Get keypress. + + If Len(k$) > 0 Then ' Only execute the code below if a key was pressed. + If Asc(k$) = 0 Then ' This returns the ASC code of the left-most character in the string. It is 0 if the key was an extended ASCII key - like the cursor keys. + Select Case Asc(LCase$(Right$(k$, 1))) ' Use the right-most character to decide what key was pressed. + Case LEFT1 + MovePaddle -PADDLEHORIZONTALMOVE, 0, 1 + Case RIGHT1 + MovePaddle PADDLEHORIZONTALMOVE, 0, 1 + Case UP1 + MovePaddle 0, -PADDLEVERTICALMOVE, 1 + Case DOWN1 + MovePaddle 0, PADDLEVERTICALMOVE, 1 + End Select + Else ' The first character was not ASCII 0 so the key was a normal letter or number. + If NumberOfPlayers = 2 Then ' Only execute if two people are playing. + Select Case Asc(LCase$(Right$(k$, 1))) ' Use the ASCII value to evaluate which key was pressed. + Case LEFT2 ' The letter s. + MovePaddle -PADDLEHORIZONTALMOVE, 0, 2 + Case RIGHT2 ' The letter f. + MovePaddle PADDLEHORIZONTALMOVE, 0, 2 + Case UP2 ' The letter e. + MovePaddle 0, -PADDLEVERTICALMOVE, 2 + Case DOWN2 ' The letter d. + MovePaddle 0, PADDLEVERTICALMOVE, 2 + End Select + End If + Select Case Asc(LCase$(Right$(k$, 1))) 'Regardless of the number of players, check for Quit and Pause. + Case PAUSE + If ScreenMode <> 1 Then Color 12 + BACKGROUNDCOLOR ' Change colors. + + Sound 1100, .75 ' Tone at 1100 hertz for 75 clock ticks. + Center "* PAUSED *", MINROW \ 8 + 2 ' Display pause message. + While InKey$ = "": Wend ' Wait for a keypress. + + Color BGCOLOR ' Restore normal colors. + Center Space$(10), MINROW \ 8 + 2 + + ' Ensures that the ball isn't duplicated if it is directly under the "* PAUSED *" text. + If EraseBallOK Then + EraseBall Ball.X, Ball.Y + DrawBall Ball.X, Ball.Y + End If + + RedrawPaddles ' Draw the paddles again in case the PAUSED message overwrote them. + Case QUIT + If ScreenMode = 1 Then ' Set the correct color scheme. + Color BGCOLOR + Else + Color 3 + BGCOLOR, BGCOLOR + End If + + Sound 1700, 1 ' Tone at 1700 hertz for 1 clock tick. + Sound 1100, .75 ' Tone at 1100 hertz for .75 clock ticks. + Center "Really quit? (Y/N) ", (MINROW \ 8 + 2) ' Display prompt. + Do + k$ = UCase$(InKey$) ' Wait for desired key to be pressed. + Loop While k$ = "" + Center Space$(19), (MINROW \ 8 + 2) ' Clear prompt off of the screen. + + If k$ = "Y" Then ' Does player want to quit? + Again = FALSE ' Set Again (for ' PLAY AGAIN' ) so that the game will not restart. + NumBalls = -1 ' Set number of balls to ending amount. + End If + + ' Ensures that the ball isn't duplicated if it is directly under the "Really Quit? (Y/N)" text. + If EraseBallOK Then + EraseBall Ball.X, Ball.Y + DrawBall Ball.X, Ball.Y + End If + + RedrawPaddles ' Draw paddles again. + End Select + End If + End If + + If NeedBall Then ' See if a new ball is needed. + NeedBall = FALSE ' Reset flag. + NewBall ' Launch a new ball. + End If + Loop While Again + + DisplayChanges ' Display suggested changes screen. + + Def Seg = 0 ' Restore the previous flag settings. + Poke 1047, KeyFlags + Def Seg ' Restore the default segment. + +End If + +End + + +' The following is the data for all 5 of the brick patterns used in the game. +' The data for each pattern must be 7 rows by 20 columns (delimited by commas). +' A "0" is used for a blank brick. Any other number represents a color +' code for that brick (range 1 - 15). + +' Data for Screen 1 +Data 4,5,3,3,3,3,0,0,0,0,0,0,0,0,3,3,3,3,5,4 +Data 0,4,5,3,3,3,2,2,0,0,0,0,2,2,3,3,3,5,4,0 +Data 0,0,4,5,3,3,3,2,3,0,0,3,2,3,3,3,5,4,0,0 +Data 0,0,4,5,3,3,3,3,3,3,3,3,3,3,3,3,5,4,0,0 +Data 0,0,0,0,4,5,5,3,3,3,3,3,5,5,5,4,0,0,0,0 +Data 0,0,0,0,0,0,4,5,5,3,3,5,5,4,0,0,0,0,0,0 +Data 0,0,0,0,0,0,0,4,4,4,4,4,4,0,0,0,0,0,0,0 + +' Data for Screen 2 +Data 1,1,1,1,1,0,0,0,1,1,1,1,0,0,0,1,1,1,1,1 +Data 9,9,9,9,9,0,0,0,9,9,9,9,0,0,0,9,9,9,9,9 +Data 5,5,5,5,5,0,0,0,5,5,5,5,0,0,0,5,5,5,5,5 +Data 13,13,13,13,13,0,0,0,13,13,13,13,0,0,0,13,13,13,13,13 +Data 3,3,3,3,3,0,0,0,3,3,3,3,0,0,0,3,3,3,3,3 +Data 11,11,11,11,11,0,0,0,11,11,11,11,0,0,0,11,11,11,11,11 +Data 11,11,11,11,11,0,0,0,11,11,11,11,0,0,0,11,11,11,11,11 + +' Data for Screen 3 +Data 1,1,8,8,8,1,1,0,0,5,5,0,0,1,1,8,8,8,1,1 +Data 5,1,1,8,1,1,5,0,0,5,5,0,0,5,1,1,8,1,1,5 +Data 0,5,1,1,1,5,0,0,5,5,5,5,0,0,5,1,1,1,5,0 +Data 0,5,5,1,5,5,0,0,5,1,1,5,0,0,5,5,1,5,5,0 +Data 0,0,5,1,5,0,0,5,5,1,1,5,5,0,0,5,1,5,0,0 +Data 0,0,0,5,0,0,0,5,1,8,8,1,5,0,0,0,5,0,0,0 +Data 0,0,0,5,0,0,1,1,8,8,8,8,1,1,0,0,5,0,0,0 + +' Data for Screen 4 +Data 5,2,14,9,0,0,0,0,9,14,14,9,0,0,0,0,9,14,2,5 +Data 5,5,2,14,14,0,0,14,14,2,2,14,14,0,0,14,14,2,5,5 +Data 0,5,5,2,2,9,9,2,2,9,9,2,2,9,9,2,2,5,5,0 +Data 0,0,5,5,5,5,5,9,9,5,5,9,9,5,5,5,5,5,0,0 +Data 0,5,5,2,2,9,9,2,2,9,9,2,2,9,9,2,2,5,5,0 +Data 5,5,2,14,14,0,0,14,14,2,2,14,14,0,0,14,14,2,5,5 +Data 5,2,14,9,0,0,0,0,9,14,14,9,0,0,0,0,9,14,2,5 + +' Data for Screen 5 +Data 0,0,0,1,0,0,0,1,0,0,0,0,1,0,0,0,1,0,0,0 +Data 1,0,1,9,1,0,1,9,1,0,0,1,9,1,0,1,9,1,0,1 +Data 9,1,9,5,9,1,9,5,9,1,1,9,5,9,1,9,5,9,1,9 +Data 5,9,5,13,5,9,5,13,5,9,9,5,13,5,9,5,13,5,9,5 +Data 13,5,13,4,13,5,13,4,13,5,5,13,4,13,5,13,4,13,5,13 +Data 4,13,4,0,4,13,4,0,4,13,13,4,0,4,13,4,0,4,13,4 +Data 0,4,0,0,0,4,0,0,0,4,4,0,0,0,4,0,0,0,4,0 + + +ScreenError: ' Screen test error-handling routine. +BadMode = TRUE +Resume Next + +'---------------------------------------------------------------------------- +' BallHitPaddle +' +' Deflects the ball if the ball hits the paddle. +' +' PARAMETERS: Player - Which player's paddle to check +'---------------------------------------------------------------------------- +Sub BallHitPaddle (Player) + + ' Checks if the paddle and the ball overlap. + If Abs(Paddle(Player).Y - Ball.Y) < 8 And Ball.X >= Paddle(Player).X And Ball.X <= Paddle(Player).X + Paddle(Player).Size Then + DrawPaddle Paddle(Player).PColor, Player + + ' Players can only hit the ball once before the ball must hit the top, + ' a brick, or another paddle. + + If EraseBallOK Then DrawBall Ball.X, Ball.Y ' Erase the ball if appropriate. + EraseBallOK = FALSE ' Make sure that main ball control section does not try to erase a ball that was already erased. + + If JustHit <> Player Then + Ball.YOffset = -Ball.YOffset ' Deflect the ball. + JustHit = Player ' JustHit assures that the same player doesn't hit the ball more than once before the ball hits a brick, the top, or the other paddle. + LastHitBy = Player ' Used to assign scores properly. + Play PADDLEHITSOUND + DrawPaddle Paddle(Player).PColor, Player + LastX = FALSE + LastY = FALSE + End If + End If + +End Sub + +'---------------------------------------------------------------------------- +' Center +' +' Centers a string of text on a specified row. +' +' PARAMETERS: Row - Row (line) to put the text on +' Text$ - Text to be centered +'---------------------------------------------------------------------------- +Sub Center (text$, Row) + + Locate Row, (ScreenWide \ 2) - Len(text$) \ 2 + 1 ' Calculate the position on the screen where the text should be centered + Print text$; + +End Sub + +'---------------------------------------------------------------------------- +' DisplayChanges +' +' Displays list of changes that the player can easily make. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayChanges + + DisplayGameTitle ' Print game title. + + Color 7 ' White text. + Center "The following game characteristics can be easily changed from", 5 + Center "within the QuickBASIC Interpreter. To change the values of ", 6 + Center "these characteristics, locate the corresponding CONST or DATA", 7 + Center "statements in the source code and change their values, then ", 8 + Center "restart the program (press Shift+F5). ", 9 + + Color 15 + Center "Block patterns ", 11 + Center "Length of paddles ", 12 + Center "Number of special bricks ", 13 + Center "Shape of the special bricks ", 14 + Center "End-of-level bonus multiplier", 15 + Center "Paddle color ", 16 + Center "Ball color ", 17 + Center "Ball speed ", 18 + + Color 7 ' White letters. + Center "The CONST statements and instructions on changing them are ", 20 + Center "located at the beginning of the main program. ", 21 + + Do While InKey$ = "": Loop ' Wait for any keypress. + Cls + +End Sub + +'---------------------------------------------------------------------------- +' DisplayGameTitle +' +' Displays the title of the game. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayGameTitle + + Screen 0 ' Set Screen mode 0. + Width 80, 25 ' Set width to 80, height to 25. + Color 4, 0 ' Set colors for red on black. + Cls ' Clear the screen. + ScreenWide = 80 ' Set screen width variable to match current width. + + ' Draw an outline around screen with extended ASCII characters. + Locate 1, 2 + Print Chr$(201); String$(76, 205); Chr$(187); ' Draw top border. + For X = 2 To 24 ' Draw left and right borders. + Locate X, 2 + Print Chr$(186); Tab(79); Chr$(186); + Next X + Locate 25, 2 + Print Chr$(200); String$(76, 205); Chr$(188); ' Draw bottom border. + + ' Print game title centered at top of screen. + Color 0, 4 ' Set colors to black (0) on red (4) letters. + Center " Microsoft ", 1 ' Center game title on lines + Center " Q B R I C K S ", 2 ' 1 and 2. + Center " Press any key to continue ", 25 ' Center prompt on line 25. + Color 7, 0 + +End Sub + +'---------------------------------------------------------------------------- +' DisplayIntro +' +' Explains the object of the game and how to play. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayIntro + + DisplayGameTitle ' Display game title. + + Color 7 + Center "Copyright (C) 1990 Microsoft Corporation. All Rights Reserved.", 4 + Center "Score points by deflecting the ball into the brick walls. In a ", 6 + Center "two-player game, the player to hit the ball last gets the points. ", 7 + Center "Hit the special bricks (" + Chr$(SPECIALCHAR) + ") or clear all the bricks to advance to ", 8 + Center "the next level. Ball speed increases every level and the paddles(s)", 9 + Center "shorten after a certain level. Bonus balls are awarded for clearing", 10 + Center "several levels. The game ends when all balls have been played. ", 11 + + Color 4 + Locate 13, 4 + Print String$(74, 196) ' Put horizontal red line on screen. + Color 7 ' Change foreground color back to white. + Center " Game Controls ", 13 ' Display game controls. + Center "General Player 1 Player 2 ", 15 + Center " (Up) (Up) ", 17 + Center "P - Pause " + Chr$(24) + " E ", 18 + Center " Q - Quit (Left) " + Chr$(27) + " " + Chr$(26) + " (Right) (Left) S F (Right) ", 19 + Center " " + Chr$(25) + " D ", 20 + Center " (Down) (Down) ", 21 + + Play STARTSOUND ' Play melody for introduction. + Do ' Wait for any key to be pressed. + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Q" Then 'Allow player to quit now + Cls + Locate 10, 30: Print "Really quit? (Y/N)"; + Do + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Y" Then + Cls + End + End If + End If + +End Sub + +'---------------------------------------------------------------------------- +' DrawBall +' +' Draws or erases the ball. By default, PUT replaces the new graphic +' image with whatever was already on the screen. The first PUT statement +' draws the object; the second PUT statement to the same location erases +' the object without affecting any other objects. +' +' PARAMETERS: BallX - X (horizontal) location of the ball, in pixels +' BallY - Y (vertical) location of the ball, in pixels +'---------------------------------------------------------------------------- +Sub DrawBall (BallX, BallY) + + Put (BallX, BallY), Ballshape() + +End Sub + +'---------------------------------------------------------------------------- +' DrawBrick +' +' Draws or erases a brick. +' +' PARAMETERS: BrickX - X location of the brick, in logical units +' BrickY - Y location of the ball, in screen rows +' BrickColor - Color to draw the brick +'---------------------------------------------------------------------------- +Sub DrawBrick (BrickX, BrickY, BrickColor) + + ' Calculate screen locations from the logical location of the brick. + X = BrickX * PIXELSIZE * BRICKSIZE + Y = BrickY * PIXELSIZE + Size = BRICKSIZE * PIXELSIZE + + ' Decide if erasing or drawing a brick. + If BrickColor = BGCOLOR Then + Line (X, Y)-(X + Size, Y + PIXELSIZE - 1), BGCOLOR, BF + Else ' Draw the brick... + Line (X + 1, Y + 1)-(X + Size - 1, Y + PIXELSIZE - 1), 15, B + Paint (X + 2, Y + 2), BrickColor, 15 + Line (X + 1, Y + PIXELSIZE - 1)-(X + Size - 1, Y + PIXELSIZE - 1), 7 + Line (X + Size - 1, Y + 1)-(X + Size - 1, Y + PIXELSIZE - 1), 7 + End If + +End Sub + +'---------------------------------------------------------------------------- +' DrawPaddle +' +' Draws or erases a paddle. +' +' PARAMETERS: PColor - Paddle color. Erases the paddle if PColor is set to +' the background color (BgColor) +' Player - Which paddle to affect +'---------------------------------------------------------------------------- +Sub DrawPaddle (PColor, Player) + + Line (Paddle(Player).X, Paddle(Player).Y)-(Paddle(Player).X + Paddle(Player).Size, Paddle(Player).Y + 1), PColor, BF + +End Sub + +'---------------------------------------------------------------------------- +' EraseBall +' +' Erases the ball by drawing a square filled with the background color +' over the ball. +' +' PARAMETERS: X - X (horizontal) location of the ball, in pixels +' Y - Y (vertical) location of the ball, in pixels +'---------------------------------------------------------------------------- +Sub EraseBall (X, Y) + + Line (X, Y)-(X + 2, Y + 2), BGCOLOR, BF + +End Sub + +'---------------------------------------------------------------------------- +' EraseBrick +' +' Logically erases a brick struck by the ball. Calls DrawBrick +' to physically erase the brick. +' +' PARAMETERS: X - Logical horizontal location (column) of the brick +' Y - Logical vertical location (row) of the brick +'---------------------------------------------------------------------------- +Sub EraseBrick (X, Y) + + If LevelOver = TRUE Then Exit Sub ' Just to be sure a new level does not + ' immediately erase bricks. + + BrickHit = Bricks(Y, X) ' Store the value of the brick that was hit in case it was a special brick. + LevelCount = LevelCount + BrickHit ' Add the brick color value to the LevelCount total. This is necessary to know when to stop a round if no special bricks are used. + Bricks(Y, X) = BGCOLOR ' Logically erase the brick. + DrawBrick X, Y, BGCOLOR ' Physically erase the brick. + + Octave$ = Str$(Y Mod 7) + Play BLOCKHITSOUND + Octave$ + " c" + + ' Score the hit. + Paddle(LastHitBy).Score = Paddle(LastHitBy).Score + 10 * Y + Paddle(LastHitBy).NumBricksHit = Paddle(LastHitBy).NumBricksHit + 1 + UpdateScreen + JustHit = FALSE ' Set JustHit to FALSE to allow a paddle to hit the ball. + + ' See if the brick was a special brick or all the bricks have been hit. + If BrickHit = 1000 Or LevelCount = MAXLEVELCount Then + NextLevel ' Go to next level + LevelOver = TRUE + End If + +End Sub + +'---------------------------------------------------------------------------- +' GameOver +' +' Checks to see if the game should be considered over. If yes, end game. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub GameOver + + DrawBall Ball.X, Ball.Y ' Ensure that the ball is fully erased. + + NumBalls = NumBalls - 1 ' Reduce the number of balls remaining by one. + UpdateScreen ' Update display to show correct number of balls remaining. + + If NumBalls < 1 Then ' If player has no more balls left, + Play GAMEOVERSOUND + DrawBall Ball.X, Ball.Y ' Erases the ball that was just drawn. + DrawBall Ball.OldX, Ball.OldY ' Erases the last real ball position. + + ' Set up information for a one player print out + Locate 25, 1: Print Space$(SCREENWIDTH); + DrawPaddle BGCOLOR, 1 ' Erase paddle 1. + Play1Bricks$ = "Bricks hit:" + Right$((Space$(2) + Str$(Paddle(1).NumBricksHit)), 4) + Play1Score$ = "Score:" + Right$((Space$(9) + Str$(Paddle(1).Score)), 9) + + If NumberOfPlayers = 1 Then + Center "Player 1 stats", MAXBLOCKROW + 6 ' Print the statistics. + Center Play1Bricks$, MAXBLOCKROW + 8 + Center Play1Score$, MAXBLOCKROW + 10 + End$ = "" + Else ' Generate strings for the 2 player statistics. + Play2Bricks$ = Play1Bricks$ + " Bricks hit:" + Right$((Space$(2) + Str$(Paddle(2).NumBricksHit)), 4) + Play2Score$ = Play1Score$ + " Score:" + Right$((Space$(9) + Str$(Paddle(2).Score)), 9) + DrawPaddle BGCOLOR, 2 ' Erase paddle 2. + + WhoWon$ = "Tie Game. Nobody" ' Assume tie game. + If Paddle(1).Score > Paddle(2).Score Then ' Player 1 won. + WhoWon$ = "Player 1" + ElseIf Paddle(1).Score < Paddle(2).Score Then 'Player 2 won. + WhoWon$ = "Player 2" + End If + + Center "Player 1 stats" + Space$(6) + "Player 2 stats ", MAXBLOCKROW + 6 + Center Play2Bricks$, MAXBLOCKROW + 8 ' Print the two-player stats. + Center Play2Score$, MAXBLOCKROW + 10 + End$ = WhoWon$ + " is the winner!" ' Display winner. + End If + + Center End$, MAXBLOCKROW + 2 ' Show winner if two-player game, otherwise print a space. + Center "Last level played: " + Str$(Level), MAXBLOCKROW + 4 ' Show the last level. + Center "Play again? (Y/N)", 24 ' Center prompt for Play Again. + + Do + k$ = UCase$(InKey$) ' Accept a key from the player. + Loop While k$ <> "Y" And k$ <> "N" ' Wait for either Y or N. + + Again = FALSE + + If k$ = "Y" Then ' Does user wish to play again? + Again = TRUE ' Yes, restart game. + Level = 0 + NextLevel + End If + NeedBall = FALSE ' Not out of balls. + Else + NeedBall = TRUE ' Out of balls. + End If + +End Sub + +'---------------------------------------------------------------------------- +' GameParamSetup +' +' Initializes game values and player paddle values before game begins. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub GameParamSetup + + Paddle(1).PColor = PLAYERCOLOR1 ' Set up paddle colors for player 1. + TempPADDLELENGTH = PADDLELENGTH1 ' Store the length of the paddle. + + If NumberOfPlayers = 2 Then ' Do only if there are two players. + Paddle(2).PColor = PLAYERCOLOR2 ' Set up paddle colors for player 2. + TempPADDLELENGTH = PADDLELENGTH2 ' Store the length of the paddle. + End If + + ScreenWide = SCREENWIDTH ' Make the ScreenWide variable equal to the true SCREENWIDTH. + GraphicsWidth = ScreenWide * PIXELSIZE ' Determine how many pixels wide the screen is. + UsableWidth = GraphicsWidth - 7 + Ball.PColor = BALLCOLOR ' Set the color, speed, and number of balls. + NumBalls = INITNUMBALLS + + ' Determine machine performance in a generic manner... + X! = Timer + For g! = 1 To 500 + Next g! + X! = Timer - X! + Select Case X! + Case 0 TO .39 ' For 386-type machines. + ActualBallSpeed = INITIALBALLSPEED + Case Is < .5 ' For PC/AT-type machines. + ActualBallSpeed = INITIALBALLSPEED / 2 + Case Else ' For XT-type machines. + ActualBallSpeed = 0 + End Select + Ball.speed = ActualBallSpeed ' Set the actual start-up speed. + + For Indx = 1 To NumberOfPlayers ' Set scores and paddle sizes to initial values. + Paddle(Indx).Size = TempPADDLELENGTH + Paddle(Indx).Score = 0 + Paddle(Indx).NumBricksHit = 0 + Next Indx + + Screen ScreenMode ' Use the best graphics mode available. + If ScreenMode = 7 Then + Color BGCOLOR, BGCOLOR ' Set appropriate colors. + Else + Color BGCOLOR + End If + + Cls ' Draw the ball and store it in an array for fast animation. + Line (50, 49)-(50, 51), Ball.PColor + Line (49, 50)-(51, 50), Ball.PColor + Get (49, 49)-(51, 51), Ballshape() + +End Sub + +'---------------------------------------------------------------------------- +' GetGameOptions +' +' Asks how many people will be playing. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub GetGameOptions + + Color 7 ' Set colors for screen to be cleared. + Cls + + Locate 9, 32: Print "Default is"; DEFAULTPLAYERS + Color 15 + Do + Locate 8, 24: Print Space$(50) + Locate 8, 24 + Input "How many players? (1 or 2) ", PaddleHold$ + Loop Until PaddleHold$ = "1" Or PaddleHold$ = "2" Or Len(PaddleHold$) = 0 + NumberOfPlayers = Val(PaddleHold$) + If NumberOfPlayers = 0 Then NumberOfPlayers = DEFAULTPLAYERS + +End Sub + +'---------------------------------------------------------------------------- +' HorizontalScroll +' +' Displays a string moving across the screen at a given line. +' +' PARAMETERS: M$ - String to be displayed +' Row - Screen row where string is displayed +'---------------------------------------------------------------------------- +Sub HorizontalScroll (M$, Row) + + M$ = Space$(ScreenWide + 2) + M$ ' Add ending spaces for display. + For i = 1 To Len(M$) - 1 ' Loop through the message in m$. + Locate Row, 1 ' Position the message on passed row value. + Print Mid$(M$, Len(M$) - i, ScreenWide - 1) ' Use the MID$() function to print a SCREENWIDTH-1 character piece of the entire message. The piece is determined by the value of X. + Delay! = Timer + .05 ' Delay the printing of each letter by .1 second. + Do While Timer < Delay!: k$ = InKey$: Loop ' Clears keyboard buffer. + Next i + RedrawPaddles ' In case the text covered the paddle(s). + +End Sub + +'---------------------------------------------------------------------------- +' MovePaddle +' +' Checks to see if the paddle can be displayed at the new location. If so, draw it. +' +' PARAMETERS: NewX - X offset from current paddle position +' NewY - Y offset from current paddle position +' PlayerNum - Which player's paddle to move +'---------------------------------------------------------------------------- +Sub MovePaddle (NewX, NewY, PlayerNum) + + ' Use temporary variables in case the paddle cannot move to the new location. + TempX = Paddle(PlayerNum).X + NewX ' Set temporary variables in case the paddle + TempY = Paddle(PlayerNum).Y + NewY ' cannot move to the new location + + OppOver = FALSE ' Assume that paddles do not overlap. + OppUnder = FALSE + + If NumberOfPlayers = 2 Then + OppNum = 3 - PlayerNum ' Get number of opponent. + + ' Is opponent under this paddle? + If TempX >= Paddle(OppNum).X And TempX <= (Paddle(OppNum).X + Paddle(OppNum).Size - 1) Then + OppUnder = TRUE + End If + + ' Or above this paddle? + If TempX <= Paddle(OppNum).X And (TempX + Paddle((PlayerNum)).Size - 1) >= Paddle(OppNum).X Then + OppOver = TRUE + End If + + ' Cannot move vertically into the other paddle. + If NewX = 0 And TempY = Paddle(OppNum).Y And (OppOver Or OppUnder) Then Exit Sub + + ' Cannot move horizontally into the other paddle + If NewY = 0 And TempY = Paddle(OppNum).Y And OppUnder Then TempX = Paddle(OppNum).X + Paddle(OppNum).Size + If NewY = 0 And TempY = Paddle(OppNum).Y And OppOver Then TempX = Paddle(OppNum).X - Paddle(OppNum).Size + End If + + ' Do not move paddle if new position is out of bounds. + If TempY > MAXROW Or TempY < MINROW Then Exit Sub + If TempX < 1 Then TempX = 1 + If TempX + Paddle(PlayerNum).Size >= GraphicsWidth Then TempX = GraphicsWidth - Paddle(PlayerNum).Size + + ' Erase old paddle location, update the paddle location, and draw the paddle at the new location. + DrawPaddle BGCOLOR, PlayerNum + Paddle(PlayerNum).OldX = Paddle(PlayerNum).X + Paddle(PlayerNum).OldY = Paddle(PlayerNum).Y + Paddle(PlayerNum).X = TempX + Paddle(PlayerNum).Y = TempY + BallHitPaddle PlayerNum ' Check to see if the paddle is hitting the ball now. + DrawPaddle Paddle(PlayerNum).PColor, PlayerNum + +End Sub + +'---------------------------------------------------------------------------- +' NewBall +' +' Launches a new ball at the start of the game, to start a new +' level, or when a player misses the ball. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub NewBall + + ' Set the new location of the ball. + Ball.X = Int(Rnd(1) * 20) * 4 + 120 ' Make the ball roughly centered. + Ball.Y = MINROW - 8 + Ball.OldX = Ball.X + Ball.OldY = Ball.Y + + Ball.XOffset = 4 ' Set the offsets of the ball. + Ball.YOffset = 4 + + ' Determine left or right movement. + If Rnd(1) > .5 Then Ball.XOffset = -Ball.XOffset + + SetDefaultPaddle + + DrawBall Ball.X, Ball.Y ' Draw the ball. + UpdateScreen ' Update information displayed on the screen. + JustHit = FALSE ' Have not hit anything yet. + + For Indx = 1 To 2 ' Generate two beeps. + Sound 300, .4 + Restart& = Timer + .9 ' Calculate amount of time to wait before starting ball moving. + Do + ClearKeyBuffer$ = InKey$ ' Clear the keyboard buffer. + Loop While Timer < Restart& + Next Indx + + ' Two quick beeps to warn the player(s) that the round is about to start. + Sound 300, .4 + Sound 400, .2 + + Do While InKey$ <> "": Loop ' Clear the keyboard buffer just in case. + + EraseBall Ball.X, Ball.Y ' Erase the ball. + EraseBallOK = FALSE ' Be sure that the ball updating code does not try to erase a ball that wasn't drawn. + +End Sub + +'---------------------------------------------------------------------------- +' NextLevel +' +' Prepares to begin a new level by awarding bonus points, drawing new brick +' walls, etc. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub NextLevel + + Level = Level + 1 + If Level = 1 Then ' First round. + GameParamSetup + Else + Play NEXTLEVELSOUND + LevelEnd$ = " Level" + Str$(Level - 1) + " completed! " + Str$((Level - 1) * BONUSMULTIPLIER) + " Bonus Points! " + HorizontalScroll LevelEnd$, 15 ' Display prompt saying level is complete. + Ball.speed = Int(ActualBallSpeed * (.95 ^ Level) * 100 + .5) / 100 ' Increase ball speed. + + For Indx = 1 To (BONUSMULTIPLIER * (Level - 1)) \ 100 ' Add bonus points. + Paddle(LastHitBy).Score = Paddle(LastHitBy).Score + 100 + UpdateScreen + Sound (Indx * 25 + 15), 1 / Indx * 18.2 ' Play the sound while adding bonus. + PauseLen# = Timer + 1 / Indx + While Timer < PauseLen#: Wend + Next Indx + EraseBallOK = TRUE + End If + + Cls + + For Y = 0 To 25 ' Clear bricks in the array. + For X = 0 To 20 + Bricks(Y, X) = BGCOLOR + Next X + Next Y + + If Level Mod CUTLEVEL = 0 Then ' See if it is time to shorten the paddles. + TempPADDLELENGTH = TempPADDLELENGTH * ((100 - PADDLECUT) / 100) ' Decrease paddle size. + If TempPADDLELENGTH < 8 Then TempPADDLELENGTH = 8 ' But no shorter than 8 pixels. + + For Indx = 1 To NumberOfPlayers ' Set both paddles to the same length. + Paddle(Indx).Size = TempPADDLELENGTH + Next Indx + End If + + ' See if it is time for a bonus ball. + If Level Mod LEVELNEWBALL = 0 Then NumBalls = NumBalls + 1 + If Level Mod MAXLEVEL = 1 Then Restore ' Have all designs been shown ? + + MAXLEVELCount = 0 ' Reset brick counting variables. + LevelCount = 0 + + For Y = STARTBRICKROW To MAXBLOCKROW - 1 ' Draw new brick pattern. + For X = 0 To 19 + Read C ' Get data for new block. + Bricks(Y, X) = (C Mod 32) + BGCOLOR + If Bricks(Y, X) <> BGCOLOR Then + MAXLEVELCount = MAXLEVELCount + (C Mod 32) ' Add the value to MAXLEVELCount so that the end of the level can be detected if there are no special bricks. + + ' Draw the brick using the correct number of colors for this screen mode. + If ScreenMode = 1 Then + DrawBrick X, Y, Bricks(Y, X) Mod 3 + 1 + Else + DrawBrick X, Y, Bricks(Y, X) Mod 16 + End If + End If + Next X + Next Y + + ' Put the special bricks on the screen, replacing existing bricks. + Indx = 1 + Do While Indx <= NUMSPECIALBRICKS + Do + ' Select random X and Y positions of the special brick. + XRandom = Int(Rnd(1) * 20) + YRandom = Int(Rnd(1) * 5) + STARTBRICKROW + Loop While Bricks(YRandom, XRandom) = BGCOLOR Or Bricks(YRandom, XRandom) = 1000 ' Make sure the special brick goes into an existing bricks that has not already been used by another special brick. + + If ScreenMode <> 1 Then Color 14 ' Set color of special bricks. + Locate YRandom + 1, XRandom * BRICKSIZE + 1 ' Move cursor to location of brick. + Print special; ' Print the special brick. + Bricks(YRandom, XRandom) = 1000 ' Put 1000 into the Bricks array where the special brick is so that EraseBrick can detect when a special brick is hit. + Indx = Indx + 1 + Loop + + NewBall ' Get a new ball. + +End Sub + +'---------------------------------------------------------------------------- +' RedrawPaddles +' +' Draws the paddles. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub RedrawPaddles + + For paddles = 1 To NumberOfPlayers + DrawPaddle Paddle(paddles).PColor, paddles + Next paddles + +End Sub + +'---------------------------------------------------------------------------- +' SetDefaultPaddle +' +' Puts the paddle(s) into their respective starting places. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub SetDefaultPaddle + + For i = 1 To NumberOfPlayers ' Clear the current paddles. + DrawPaddle BGCOLOR, i + Next i + + If NumberOfPlayers = 2 Then ' Set the default position of the paddle(s). + For PaddleNumber = 1 To NumberOfPlayers + Paddle(PaddleNumber).X = (((GraphicsWidth - 80) \ PaddleNumber) - TempPADDLELENGTH) ' Sets the horizontal position of the paddle(s). + Paddle(PaddleNumber).Y = MAXROW + Next PaddleNumber + Else + Paddle(1).X = (GraphicsWidth - TempPADDLELENGTH) / 2 + Paddle(1).Y = MAXROW + End If + + RedrawPaddles ' Show them again. + +End Sub + +'---------------------------------------------------------------------------- +' UpdateScreen +' +' Puts new scores, levels, and ball counts on the screen. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub UpdateScreen + + If ScreenMode <> 1 Then Color SCORECOLOR ' Set screen color for messages. + Locate 25, 1 + + ' Display the data a little differently for one-player and two-player games. + If NumberOfPlayers = 1 Then + Print Using "Balls:###"; NumBalls; + Print Using " Level:###"; Level; + If Paddle(1).Score > 9999000 Then Paddle(1).Score = 0 + Print Using " Player 1:#,###,###"; Paddle(1).Score; + Else + If Paddle(2).Score > 999000 Then Paddle(2).Score = 0 + Print Using "Play2:###,###"; Paddle(2).Score; + Print Using " B:###"; NumBalls; + Print Using " L:###"; Level; + If Paddle(1).Score > 999000 Then Paddle(1).Score = 0 + Print Using " Play1:###,###"; Paddle(1).Score; + End If + +End Sub + diff --git a/samples/qcards/img/screenshot.png b/samples/qcards/img/screenshot.png new file mode 100644 index 00000000..7327ed3b Binary files /dev/null and b/samples/qcards/img/screenshot.png differ diff --git a/samples/qcards/index.md b/samples/qcards/index.md new file mode 100644 index 00000000..a75e5b10 --- /dev/null +++ b/samples/qcards/index.md @@ -0,0 +1,22 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QCARDS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +A simple database using a cardfile user interface by Microsoft. +``` + +### File(s) + +* [qcards.bas](src/qcards.bas) +* [qcards.zip](src/qcards.zip) + +🔗 [data management](../data-management.md) diff --git a/samples/qcards/src/qcards.bas b/samples/qcards/src/qcards.bas new file mode 100644 index 00000000..27a75ba7 --- /dev/null +++ b/samples/qcards/src/qcards.bas @@ -0,0 +1,1412 @@ +'* QCards - A simple database using a cardfile user interface. +'* Each record in the database is represented by a card. The user +'* can scroll through the cards using normal scrolling keys. +'* Other commands allow the user to edit, add, sort, find, or +'* delete cards. +'* +'* Input: Keyboard - user commands and entries +'* File - database records +'* +'* Output: Screen - card display and help +'* File - database records +'* + +' The module-level code begins here. + +'*************** Declarations and definitions begin here ************ + +DefInt A-Z 'Resets default data type from single precision to integer + +' Define names similar to keyboard names with equivalent key codes. +Const SPACE = 32, ESC = 27, ENTER = 13, TABKEY = 9 +Const DOWN = 80, UP = 72, LEFT = 75, RIGHT = 77 +Const HOME = 71, ENDK = 79, PGDN = 81, PGUP = 73 +Const INS = 82, DEL = 83, NULL = 0 +Const CTRLD = 4, CTRLG = 7, CTRLH = 8, CTRLS = 19, CTRLV = 22 + +' Define English names for color-specification numbers. Add BRIGHT to +' any color to get bright version. +Const BLACK = 0, BLUE = 1, GREEN = 2, CYAN = 3, RED = 4, MAGENTA = 5 +Const YELLOW = 6, WHITE = 7, BRIGHT = 8 + +' Assign colors to different kinds of text. By changing the color +' assigned, you can change the color of the QCARDS display. The +' initial colors are chosen because they work for color or +' black-and-white displays. +Const BACKGROUND = BLACK, NORMAL = WHITE, HILITE = WHITE + BRIGHT +' Codes for normal and highlight (used in data statements) +Const CNORMAL = 0, CHILITE = 1 + +' Screen positions - Initialized for 25 rows. Screen positions can be +' modified for 43-row mode if you have an EGA or VGA adapter. +Const HELPTOP = 15, HELPBOT = 23, HELPLEFT = 60, HELPWID = 20 +Const CARDSPERSCREEN = 7, LASTROW = 25 + +' Miscellaneous symbolic constants +Const FALSE = 0, TRUE = Not FALSE +Const CURSORON = 1, CURSOROFF = 0 + +' File names +Const TMPFILE$ = "$$$87y$.$5$" ' Unlikely file name +Const DISKFILE$ = "QCARDS.DAT" +' Field names +Const NPERSON = 0, NNOTE = 1, NMONTH = 2, NDAY = 3 +Const NYEAR = 4, NPHONE = 5, NSTREET = 6, NCITY = 7 +Const NSTATE = 8, NZIP = 9, NFIELDS = NZIP + 1 + +' Declare user-defined type (a data structure) for random-access +' file records. +Type PERSON + CardNum As Integer 'First element is card number + Names As String * 37 'Names (in order for alpha. sort) + Note As String * 31 'Note about person + Month As Integer 'Birth month + Day As Integer 'Birth day + Year As Integer 'Birth year + Phone As String * 12 'Phone number + Street As String * 29 'Street address + City As String * 13 'City + State As String * 2 'State + Zip As String * 5 'Zip code +End Type + +' SUB procedure declarations begin here. + +DECLARE SUB Alarm () + +DECLARE SUB DirectionKey (Choice$, TopCard%, LastCard%) +DECLARE SUB AsciiKey (Choice$, TopCard%, LastCard%) +DECLARE SUB CleanUp (LastCard%) +DECLARE SUB ClearHelp () +DECLARE SUB DrawCards () +DECLARE SUB EditCard (Card AS PERSON) +DECLARE SUB InitIndex (LastCard%) +DECLARE SUB PrintLabel (Card AS PERSON) +DECLARE SUB SortIndex (SortField%, LastCard%) +DECLARE SUB ShowViewHelp () +DECLARE SUB ShowTopCard (WorkCard AS PERSON) +DECLARE SUB ShowEditHelp () +DECLARE SUB ShowCmdLine () +DECLARE SUB ShowCards (TopCard%, LastCard%) + +' FUNCTION procedure declarations begin here. +DECLARE FUNCTION EditString$ (InString$, Length%, NextField%) +DECLARE FUNCTION FindCard% (TopCard%, LastCard%) +DECLARE FUNCTION Prompt$ (Msg$, Row%, Column%, Length%) +DECLARE FUNCTION SelectField% () + +' Procedure declarations end here. + + +' Define a dummy record as a work card. +Dim Card As PERSON + +'*************** Declarations and definitions end here ************** + +' The execution-sequence logic of QCARDS begins here. + +' Open data file QCARDS.DAT for random access using file #1 + +Open DISKFILE$ For Random As #1 Len = Len(Card) + + +' To count records in file, divide the length of the file by the +' length of a single record; use integer division (\) instead of +' normal division (/). Assign the resulting value to LastCard. + +LastCard = LOF(1) \ Len(Card) + + + + +' Redefine the Index array to hold the records in the file plus +' 20 extra (the extra records allow the user to add cards). +' This array is dynamic - this means the number of elements +' in Index() varies depending on the size of the file. +' Also, Index() is a shared procedure, so it is available to +' all SUB and FUNCTION procedures in the program. +' +' Note that an error trap lets QCARDS terminate with an error +' message if the memory available is not sufficient. If no +' error is detected, the error trap is turned off following the +' REDIM statement. + +On Error GoTo MemoryErr +ReDim Shared Index(1 To LastCard + 20) As PERSON +On Error GoTo 0 + + +' Use the block IF...THEN...ELSE statement to decide whether +' to load the records from the disk file QCARDS.DAT into the +' array of records called Index() declared earlier. In the IF +' part, you will check to see if there are actually records +' in the file. If there are, LastCard will be greater than 0, +' and you can call the InitIndex procedure to load the records +' into Index(). LastCard is 0 if there are no records in the +' file yet. If there are no records in the file, the ELSE +' clause is executed. The code between ELSE and END IF starts +' the Index() array at card 1. + +If LastCard <> 0 Then + Call InitIndex(LastCard) +Else + Card.CardNum = 1 + Index(1) = Card + Put #1, 1, Card +End If + + + +' Use the DrawCards procedure to initialize the screen +' and draw the cards. Then, set the first card as the top +' card. Finally, pass the variables TopCard and LastCard +' as arguments to the ShowCards procedure. The call to +' ShowCards places all the data for TopCard on the front +' card on the screen, then it places the top-line +' information (the person's name) on the remaining cards. + +Call DrawCards +TopCard = 1 +Call ShowCards(TopCard, LastCard) + + + +' Keep the picture on the screen forever with an unconditional +' DO...LOOP statement. The DO part of the statement goes on +' the next code line. The LOOP part goes just before the END +' statement. This loop encloses the central logic that lets +' a user interact with QCARDS. + +Do + + + + ' Get user keystroke with a conditional DO...LOOP statement. + ' Within the loop, use the INKEY$ function to capture a user + ' keystroke, which is then assigned to a string variable. The + ' WHILE part of the LOOP line keeps testing the string + ' variable. Until a key is pressed, INKEY$ keeps returning a + ' null (that is a zero-length) string, represented by "". + ' When a key is pressed, INKEY$ returns a string with a + ' length greater than zero, and the loop terminates. + + ' DO...LOOP with test at the bottom of the loop + Do + Choice$ = InKey$ + Loop While Choice$ = "" + + + + + ' Use the LEN function to find out whether Choice$ is greater + ' than a single character (i.e. a single byte). If Choice$ is + ' a single character (that is, it is less than 2 bytes long), + ' the key pressed was an ordinary "typewriter keyboard" + ' character (these are usually called ASCII keys because they + ' are part of the ASCII character set). When the user enters + ' an ASCII character, it indicates a choice of one of the QCARDS + ' commands from the command line at the bottom of the screen. + ' If the user did press an ASCII key, use the LCASE$ function + ' to convert it to lower case (in the event the capital letter + ' was entered). + ' + ' The ELSE clause is only executed if Choice$ is longer than a + ' single character (and therefore not a command-line key). + ' If Choice$ is not an ASCII key, it represents an "extended" + ' key. (The extended keys include the DIRECTION keys on the + ' numeric keypad, which is why QCARDS looks for them.) The + ' RIGHT$ function is then used trim away the extra byte, + ' leaving a value that may correspond to one of the DIRECTION + ' keys. Use a SELECT CASE construction to respond to those key- + ' presses that represent numeric-keypad DIRECTION keys. + + If Len(Choice$) = 1 Then + ' Handle ASCII keys. + Call AsciiKey(Choice$, TopCard, LastCard) + + Else + ' Convert 2-byte extended code to 1-byte ASCII code and handle. + Choice$ = Right$(Choice$, 1) + Call DirectionKey(Choice$, TopCard, LastCard) + + + End If + + + ' Adjust the cards according to the key pressed by the user, + ' then call the ShowCards procedure to show adjusted stack. + + If TopCard < 1 Then TopCard = LastCard + TopCard + If TopCard > LastCard Then TopCard = TopCard - LastCard + If TopCard <= 0 Then TopCard = 1 + Call ShowCards(TopCard, LastCard) + + + ' This is the bottom of the unconditional DO loop. + +Loop + +End + +' The execution sequence of the module-level code ends here. +' The program may terminate elsewhere for legitimate reasons, +' but the normal execution sequence ends here. Statements +' beyond the END statement are executed only in response to +' other statements. + +' This first label, MemoryErr, is an error handler. + +MemoryErr: +Print "Not enough memory. Can't read file." +End + +' Data statements for screen output - initialized for 25 rows. Can be +' modified for 43-row mode if you have an EGA or VGA adapter. + +CardScreen: +Data " Ŀ" +Data " " +Data " ͵" +Data " " +Data " ͵ " +Data " " +Data " ͵ " +Data " " +Data " ͵ " +Data " " +Data " ͵ " +Data " " +Data "͵ " +Data " _____________________________________ " +Data "͵ " +Data " Note: _______________________________ " +Data " " +Data " Birth: __/__/__ Phone: ___-___-____ " +Data " " +Data " Street: _____________________________ " +Data " " +Data " City: ____________ ST: __ Zip: _____ " +Data "" + +' Color codes and strings for view-mode help + +ViewHelp: +Data 0,"Select card with:" +Data 1," UP" +Data 1," DOWN" +Data 1," PGUP" +Data 1," PGDN" +Data 1," HOME" +Data 1," END" +Data 1,"" +Data 1,"" + +' Color codes and strings for edit-mode help + +EditHelp: +Data 0,"Next field:" +Data 1," TAB" +Data 0,"Accept card:" +Data 1," ENTER" +Data 0,"Edit field:" +Data 1," DEL BKSP" +Data 1," RIGHT LEFT" +Data 1," HOME END" +Data 1," INS ESC" + +' Row, column, and length of each field + +FieldPositions: +Data 14,6,37: ' Names +Data 16,12,31: ' Note +Data 18,13,2: ' Month +Data 18,16,2: ' Day +Data 18,19,2: ' Year +Data 18,31,12: ' Phone +Data 20,14,29: ' Street +Data 22,12,13: ' City +Data 22,29,2: ' State +Data 22,38,5: ' Zip +Data 0,0,0 + +Sub Alarm + ' The Alarm procedure uses the SOUND statement to send + ' signals to the computer's speaker and sound an alarm + ' + ' + ' Parameters: None + ' + ' Output: Sends an alarm to the user + + ' Change the numbers to vary the sound + For Tone = 600 To 2000 Step 40 + Sound Tone, Tone / 7000 + Next Tone + + +End Sub + +'* +'* AsciiKey - Handles ASCII keys. You can add new commands by +'* assigning keys and actions here and adding them to the command +'* line displayed by the ShowCmdLine SUB. For example, you could add +'* L (for Load new file) to prompt the user for a new database file. +'* +'* Params: UserChoice$ - key pressed by the user +'* TopCard - the number of the current record +'* LastCard - the number of records +'* +Sub AsciiKey (UserChoice$, TopCard%, LastCard%) + Dim WorkCard As PERSON + + Select Case LCase$(UserChoice$) + ' Edit the current card. + Case "e" + Call ShowEditHelp + Tmp$ = Prompt$("Editing Card...", LASTROW, 1, 0) + Call EditCard(Index(TopCard)) + Put #1, Index(TopCard).CardNum, Index(TopCard) + Locate , , CURSOROFF + Call ShowViewHelp + + ' Add and edit a blank or duplicate card. + Case "a", "c" + If UserChoice$ = "c" Then + WorkCard = Index(TopCard) ' Duplicate of top card + Else + WorkCard.CardNum = 0 ' Initialize new card. + WorkCard.Names = "" + WorkCard.Note = "" + WorkCard.Month = 0 + WorkCard.Day = 0 + WorkCard.Year = 0 + WorkCard.Phone = "" + WorkCard.Street = "" + WorkCard.City = "" + WorkCard.State = "" + WorkCard.Zip = "" + End If + TopCard = LastCard + 1 + LastCard = TopCard + Index(TopCard) = WorkCard + Index(TopCard).CardNum = TopCard + Call ShowCards(TopCard, LastCard) + Call ShowEditHelp + Tmp$ = Prompt$("Editing Card...", LASTROW, 1, 0) + Call EditCard(Index(TopCard)) + Put #1, Index(TopCard).CardNum, Index(TopCard) + Locate , , CURSOROFF + Call ShowViewHelp + + ' Move deleted card to end and adjust last card. + Case "d" + For Card = TopCard To LastCard - 1 + Swap Index(Card + 1), Index(Card) + Next Card + LastCard = LastCard - 1 + + ' Find a specified card. + Case "f" + Call ShowEditHelp + Tmp$ = "Enter fields for search (blank fields are ignored)" + Tmp$ = Prompt$(Tmp$, LASTROW, 1, 0) + Card = FindCard(TopCard, LastCard) + If Card Then + TopCard = Card + Else + Beep + Call ClearHelp + Tmp$ = "Can't find card. Press any key..." + Tmp$ = Prompt$(Tmp$, LASTROW, 1, 1) + End If + Locate , , CURSOROFF + Call ShowViewHelp + + ' Sorts cards by a specified field. + Case "s" + Call ClearHelp + Tmp$ = "TAB to desired sort field, then press ENTER" + Tmp$ = Prompt$(Tmp$, LASTROW, 1, 0) + Call SortIndex(SelectField, LastCard) + TopCard = 1 + Call ShowViewHelp + + ' Prints address of top card on printer. + Case "p" + Call PrintLabel(Index(TopCard)) + + ' Terminates the program. + Case "q", Chr$(ESC) + Call CleanUp(LastCard) + Locate , , CURSORON + Cls + End + Case Else + Beep + End Select + +End Sub + +'* +'* CleanUp - Writes all records from memory to a file. Deleted +'* records (past the last card) will not be written. The valid records +'* are written to a temporary file. The old file is deleted, and the +'* new file is given the old name. +'* +'* Params: LastCard - the number of valid records +'* +'* Output: Valid records to DISKFILE$ through TMPFILE$ +'* +Sub CleanUp (LastCard) + + ' Write records to temporary file in their current sort order. + Open TMPFILE$ For Random As #2 Len = Len(Index(1)) + For Card = 1 To LastCard + Put #2, Card, Index(Card) + Next + + ' Delete old file and replace it with new version. + Close + Kill DISKFILE$ + Name TMPFILE$ As DISKFILE$ + +End Sub + +'* +'* ClearHelp - Writes spaces to the help area of the screen. +'* +'* Params: None +'* +'* Output: Blanks to the screen +'* +Sub ClearHelp + + ' Clear key help + Color NORMAL, BACKGROUND + For Row = HELPTOP To HELPBOT + Locate Row, HELPLEFT + Print Space$(HELPWID) + Next + + ' Clear command line + Locate LASTROW, 1 + Print Space$(80); + +End Sub + +Sub DirectionKey (Choice$, TopCard%, LastCard%) + Select Case Choice$ + Case Chr$(DOWN) + TopCard = TopCard - 1 + Case Chr$(UP) + TopCard = TopCard + 1 + Case Chr$(PGDN) + TopCard = TopCard - CARDSPERSCREEN + Case Chr$(PGUP) + TopCard = TopCard + CARDSPERSCREEN + Case Chr$(HOME) + TopCard = LastCard + Case Chr$(ENDK) + TopCard = 1 + Case Else + Call Alarm + End Select + +End Sub + +'* +'* DrawCards - Initializes screen by setting the color, setting the +'* width and height, clearing the screen, and hiding the cursor. Then +'* writes card text and view-mode help to the screen. +'* +'* Params: None +'* +'* Output: Text to the screen +'* +Sub DrawCards + + ' Clear screen to current color. + Width 80, LASTROW + Color NORMAL, BACKGROUND + Cls + Locate , , CURSOROFF, 0, 7 + + ' Display line characters that form cards. + Restore CardScreen + For Row = 1 To 23 + Locate Row, 4 + Read Tmp$ + Print Tmp$; + Next + + ' Display help. + Call ShowViewHelp + +End Sub + +'* +'* EditCard - Edits each field of a specified record. +'* +'* Params: Card - the record to be edited +'* +'* Return: Since Card is passed by reference, the edited version is +'* effectively returned. +'* +Sub EditCard (Card As PERSON) + + ' Set NextFlag and continue editing each field. + ' NextFlag is cleared when the user presses ENTER. + + NextFlag = TRUE + Do + + Restore FieldPositions + + ' Start with first field. + Read Row, Column, Length + Locate Row, Column + ' Edit string fields directly. + Card.Names = EditString(RTrim$(Card.Names), Length, NextFlag) + ' Result of edit determines whether to continue. + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + Card.Note = EditString(RTrim$(Card.Note), Length, NextFlag) + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + ' Convert numeric fields to strings for editing. + Tmp$ = LTrim$(Str$(Card.Month)) + Tmp$ = EditString(Tmp$, Length, NextFlag) + ' Convert result back to number. + Card.Month = Val(Tmp$) + Locate Row, Column + Print Using "##_/"; Card.Month; + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + Tmp$ = LTrim$(Str$(Card.Day)) + Tmp$ = EditString(Tmp$, Length, NextFlag) + Card.Day = Val(Tmp$) + Locate Row, Column + Print Using "##_/"; Card.Day; + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + Tmp$ = LTrim$(Str$(Card.Year)) + Tmp$ = EditString(Tmp$, Length, NextFlag) + Card.Year = Val(Tmp$) + Locate Row, Column + Print Using "##"; Card.Year; + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + Card.Phone = EditString(RTrim$(Card.Phone), Length, NextFlag) + RSet Card.Phone = Card.Phone + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + Card.Street = EditString(RTrim$(Card.Street), Length, NextFlag) + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + Card.City = EditString(RTrim$(Card.City), Length, NextFlag) + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + Card.State = EditString(RTrim$(Card.State), Length, NextFlag) + If NextFlag = FALSE Then Exit Sub + + Read Row, Column, Length + Locate Row, Column + Card.Zip = EditString(RTrim$(Card.Zip), Length, NextFlag) + If NextFlag = FALSE Then Exit Sub + + Loop + +End Sub + +'* +'* EditString$ - Edits a specified string. This function +'* implements a subset of editing functions used in the QuickBASIC +'* environment and in Windows. Common editing keys are recognized, +'* including direction keys, DEL, BKSP, INS (for insert and overwrite +'* modes), ESC, and ENTER. TAB is recognized only if the NextField +'* flag is set. CTRL-key equivalents are recognized for most keys. +'* A null string can be specified if no initial value is desired. +'* You could modify this function to handle additional QB edit +'* commands, such as CTRL+A (word back) and CTRL+F (word forward). +'* +'* Params: InString$ - The input string (can be null) +'* Length - Maximum length of string (the function beeps and +'* refuses additional keys if the user tries to enter more) +'* NextField - Flag indicating on entry whether to accept TAB +'* key; on exit, indicates whether the user pressed +'* TAB (TRUE) or ENTER (FALSE) +'* +'* Input: Keyboard +'* Ouput: Screen - Noncontrol keys are echoed. +'* Speaker - beep if key is invalid or string is too long +'* +'* Return: The edited string +'* +Function EditString$ (InString$, Length, NextField) + Static Insert + + ' Initialize variables and clear field to its maximum length. + Work$ = InString$ + Row = CsrLin: Column = Pos(0) + FirstTime = TRUE + P = Len(Work$): MaxP = P + Print Space$(Length); + + ' Since Insert is STATIC, its value is maintained from one + ' call to the next. Insert is 0 (FALSE) the first time the + ' function is called. + If Insert Then + Locate Row, Column, CURSORON, 6, 7 + Else + Locate Row, Column, CURSORON, 0, 7 + End If + + ' Reverse video on entry. + Color BACKGROUND, NORMAL + Print Work$; + + ' Process keys until either TAB or ENTER is pressed. + Do + + ' Get a key -- either a one-byte ASCII code or a two-byte + ' extended code. + Do + Choice$ = InKey$ + Loop While Choice$ = "" + + 'Translate two-byte extended codes to the one meaningful byte. + If Len(Choice$) = 2 Then + Choice$ = Right$(Choice$, 1) + Select Case Choice$ + + ' Translate extended codes to ASCII control codes. + Case Chr$(LEFT) + Choice$ = Chr$(CTRLS) + Case Chr$(RIGHT) + Choice$ = Chr$(CTRLD) + Case Chr$(INS) + Choice$ = Chr$(CTRLV) + Case Chr$(DEL) + Choice$ = Chr$(CTRLG) + + ' Handle HOME and END keys, since they don't have + ' control codes. Send NULL as a signal to ignore. + Case Chr$(HOME) + P = 0 + Choice$ = Chr$(NULL) + Case Chr$(ENDK) + P = MaxP + Choice$ = Chr$(NULL) + + ' Make other key choices invalid. + Case Else + Choice$ = Chr$(1) + End Select + End If + + ' Handle one-byte ASCII codes. + Select Case Asc(Choice$) + + ' If it is null, ignore it. + Case NULL + + ' Accept field (and card if NextField is used). + Case ENTER + NextField = FALSE + Exit Do + + ' Accept the field unless NextField is used. If NextField + ' is cleared, TAB is invalid. + Case TABKEY + If NextField Then + Exit Do + Else + Beep + End If + + ' Restore the original string. + Case ESC + Work$ = InString$ + Locate Row, Column, CURSOROFF + Print Space$(MaxP) + Exit Do + + ' CTRL+S or LEFT arrow moves cursor to left. + Case CTRLS + If P > 0 Then + P = P - 1 + Locate , P + Column + Else + Beep + End If + + ' CTRL+D or RIGHT arrow moves cursor to right. + Case CTRLD + If P < MaxP Then + P = P + 1 + Locate , P + Column + Else + Beep + End If + + ' CTRL+G or DEL deletes character under cursor. + Case CTRLG + If P < MaxP Then + Work$ = Left$(Work$, P) + Right$(Work$, MaxP - P - 1) + MaxP = MaxP - 1 + Else + Beep + End If + + ' CTRL+H or BKSP deletes character to left of cursor. + Case CTRLH, 127 + If P > 0 Then + Work$ = Left$(Work$, P - 1) + Right$(Work$, MaxP - P) + P = P - 1 + MaxP = MaxP - 1 + End If + + ' CTRL+V or INS toggles between insert & overwrite modes. + Case CTRLV + Insert = Not Insert + If Insert Then + Locate , , , 6, 7 + Else + Locate , , , 0, 7 + End If + + ' Echo ASCII characters to screen. + Case Is >= SPACE + + ' Clear the field if this is first keystroke, then + ' start from the beginning. + If FirstTime Then + Locate , Column + Color NORMAL, BACKGROUND + Print Space$(MaxP); + Locate , Column + P = 0: MaxP = P + Work$ = "" + End If + + ' If insert mode and cursor not beyond end, insert + ' character. + If Insert Then + If MaxP < Length Then + Work$ = Left$(Work$, P) + Choice$ + Right$(Work$, MaxP - P) + MaxP = MaxP + 1 + P = P + 1 + Else + Beep + End If + + Else + ' If overwrite mode and cursor at end (but + ' not beyond), insert character. + If P = MaxP Then + If MaxP < Length Then + Work$ = Work$ + Choice$ + MaxP = MaxP + 1 + P = P + 1 + Else + Beep + End If + + ' If overwrite mode and before end, overwrite + ' character. + Else + Mid$(Work$, P + 1, 1) = Choice$ + P = P + 1 + End If + End If + + ' Consider other key choices invalid. + Case Else + Beep + End Select + + ' Print the modified string. + Color NORMAL, BACKGROUND + Locate , Column, CURSOROFF + Print Work$ + " "; + Locate , Column + P, CURSORON + FirstTime = FALSE + + Loop + + ' Print the final string and assign it to function name. + Color NORMAL, BACKGROUND + Locate Row, Column, CURSOROFF + Print Work$; + EditString$ = Work$ + Locate Row, Column + +End Function + +'* +'* FindCard - Finds a specified record. The user specifies as many +'* fields to search for as desired. The search begins at the card +'* after the current card and proceeds until the specified record or +'* the current card is reached. Specified records are retained between +'* calls to make repeat searching easier. This SUB could be enhanced +'* to find partial matches of string fields. +'* +'* Params: TopCard - number of top card +'* LastCard - number of last card +'* +'* Params: None +'* +'* Return: Number (zero-based) of the selected field +'* +Function FindCard% (TopCard%, LastCard%) + + Static TmpCard As PERSON, NotFirst + + ' Initialize string fields to null on the first call. (Note that + ' the variables TmpCard and NotFirst, declared STATIC above, + ' retain their values between subsequent calls.) + If NotFirst = FALSE Then + TmpCard.Names = "" + TmpCard.Note = "" + TmpCard.Phone = "" + TmpCard.Street = "" + TmpCard.City = "" + TmpCard.State = "" + TmpCard.Zip = "" + NotFirst = TRUE + End If + + ' Show top card, then use EditCardFunction to specify fields + ' for search. + Call ShowTopCard(TmpCard) + Call EditCard(TmpCard) + + ' Search until a match is found or all cards have been checked. + Card = TopCard + Do + Card = Card + 1 + If Card > LastCard Then Card = 1 + Found = 0 + + ' Test name to see if it's a match. + Select Case RTrim$(UCase$(TmpCard.Names)) + Case "", RTrim$(UCase$(Index(Card).Names)) + Found = Found + 1 + Case Else + End Select + + ' Test note text. + Select Case RTrim$(UCase$(TmpCard.Note)) + Case "", RTrim$(UCase$(Index(Card).Note)) + Found = Found + 1 + Case Else + End Select + + ' Test month. + Select Case TmpCard.Month + Case 0, Index(Card).Month + Found = Found + 1 + Case Else + End Select + + ' Test day. + Select Case TmpCard.Day + Case 0, Index(Card).Day + Found = Found + 1 + Case Else + End Select + + ' Test year. + Select Case TmpCard.Year + Case 0, Index(Card).Year + Found = Found + 1 + Case Else + End Select + + ' Test phone number. + Select Case RTrim$(UCase$(TmpCard.Phone)) + Case "", RTrim$(UCase$(Index(Card).Phone)) + Found = Found + 1 + Case Else + End Select + + ' Test street address. + Select Case RTrim$(UCase$(TmpCard.Street)) + Case "", RTrim$(UCase$(Index(Card).Street)) + Found = Found + 1 + Case Else + End Select + + ' Test city. + Select Case RTrim$(UCase$(TmpCard.City)) + Case "", RTrim$(UCase$(Index(Card).City)) + Found = Found + 1 + Case Else + End Select + + ' Test state. + Select Case RTrim$(UCase$(TmpCard.State)) + Case "", RTrim$(UCase$(Index(Card).State)) + Found = Found + 1 + Case Else + End Select + + ' Test zip code. + Select Case TmpCard.Zip + Case "", RTrim$(UCase$(Index(Card).Zip)) + Found = Found + 1 + Case Else + End Select + + ' If match is found, set function value and quit, else + ' next card. + If Found = NFIELDS - 1 Then + FindCard% = Card + Exit Function + End If + + Loop Until Card = TopCard + + ' Return FALSE when no match is found. + FindCard% = FALSE + +End Function + +'* +'* InitIndex - Reads records from file and assigns each value to +'* array records. Index values are set to the actual order of the +'* records in the file. The order of records in the array may change +'* because of sorting or additions, but the CardNum field always +'* has the position in which the record actually occurs in the file. +'* +'* Params: LastCard - number of records in array +'* +'* Input: File DISKFILE$ +'* +Sub InitIndex (LastCard) Static + Dim Card As PERSON + + For Record = 1 To LastCard + + ' Read a record from the file and put each field in the array. + Get #1, Record, Card + Index(Record).CardNum = Record + Index(Record).Names = Card.Names + Index(Record).Note = Card.Note + Index(Record).Month = Card.Month + Index(Record).Day = Card.Day + Index(Record).Year = Card.Year + Index(Record).Phone = Card.Phone + Index(Record).Street = Card.Street + Index(Record).City = Card.City + Index(Record).State = Card.State + Index(Record).Zip = Card.Zip + + Next Record + +End Sub + +'* +'* PrintLabel - Prints the name, address, city, state, and zip code +'* from a card. This SUB could easily be modified to print a return +'* address or center the address on an envelope. +'* +'* Params: Card - all the data about a person +'* +'* Output: Printer +'* +Sub PrintLabel (Card As PERSON) + + LPrint Card.Names + LPrint Card.Street + LPrint Card.City; ", "; Card.State; Card.Zip + LPrint + +End Sub + +'* +'* Prompt$ - Prints a prompt at a specified location on the screen +'* and (optionally) gets a user response. This function can take one +'* of three different actions depending on the length parameter. +'* +'* Params: Msg$ - message or prompt (can be "" for no message) +'* Row +'* Column +'* Length - one of the following: +'* <1 - Don't wait for response +'* 1 - Get character response +'* >1 - Get string response up to length +'* +'* Output: Keyboard +'* Output: Screen - noncontrol characters echoed +'* +'* Return: String entered by user +'* +Function Prompt$ (Msg$, Row, Column, Length) + + Locate Row, Column + Print Msg$; + + Select Case Length + Case Is <= 0 ' No return + Prompt$ = "" + Case 1 ' Character return + Locate , , CURSORON + Prompt$ = Input$(1) + Case Else ' String return + Prompt$ = EditString("", Length, FALSE) + End Select + +End Function + +'* +'* SelectField - Enables a user to select a field using TAB key. +'* TAB moves to the next field. ENTER selects the current field. +'* +'* Params: None +'* +'* Return: Number (zero-based) of the selected field +'* +Function SelectField% + + ' Get first cursor position and set first FieldNum. + Restore FieldPositions + Read Row, Column, Length + FieldNum = 0 + + ' Rotate cursor through fields. + Do + + ' Set cursor on current field. + Locate Row, Column, CURSORON + + ' Get a TAB or ENTER. + Do + Ky = Asc(Input$(1)) + Loop Until (Ky = ENTER) Or (Ky = TABKEY) + + ' If ENTER pressed, turn off cursor and return field. + If Ky = ENTER Then + + Locate , , CURSOROFF + SelectField% = FieldNum + Exit Function + + ' Otherwise, it was TAB, so advance to next field. + Else + + FieldNum = FieldNum + 1 + Read Row, Column, Length + If Row = 0 Then + Restore FieldPositions + Read Row, Column, Length + FieldNum = 0 + End If + + End If + + Loop + +End Function + +'* +'* ShowCards - Shows all the fields of the top card and the top +'* field of the other visible cards. +'* +'* Params: TopCard - number of top card +'* LastCard - number of last card +'* +'* Output: Screen +'* +Sub ShowCards (TopCard, LastCard) + + ' Show each field of top card. + Call ShowTopCard(Index(TopCard)) + + ' Show the Names field for other visible cards. + Card = TopCard + Restore FieldPositions + Read Row, Column, Length + For Count = 2 To CARDSPERSCREEN + + ' Show location and card number for next highest card. + Row = Row - 2: Column = Column + 3 + Card = Card + 1 + If Card > LastCard Then Card = 1 + + Locate Row, Column + Print Space$(Length) + + Locate Row, Column + Print Index(Card).Names + + Next Count + +End Sub + +'* +'* ShowCmdLine - Puts command line on screen with highlighted key +'* characters. Modify this SUB if you add additional commands. +'* +'* Params: None +'* +'* Output: Screen +'* +Sub ShowCmdLine + + Locate LASTROW, 1 + Color HILITE, BACKGROUND: Print " E"; + Color NORMAL, BACKGROUND: Print "dit Top "; + Color HILITE, BACKGROUND: Print "A"; + Color NORMAL, BACKGROUND: Print "dd New "; + Color HILITE, BACKGROUND: Print "C"; + Color NORMAL, BACKGROUND: Print "opy to New "; + Color HILITE, BACKGROUND: Print "D"; + Color NORMAL, BACKGROUND: Print "elete "; + Color HILITE, BACKGROUND: Print "F"; + Color NORMAL, BACKGROUND: Print "ind "; + Color HILITE, BACKGROUND: Print "S"; + Color NORMAL, BACKGROUND: Print "ort "; + Color HILITE, BACKGROUND: Print "P"; + Color NORMAL, BACKGROUND: Print "rint "; + Color HILITE, BACKGROUND: Print "Q"; + Color NORMAL, BACKGROUND: Print "uit "; + +End Sub + +'* +'* ShowEditHelp - Reads colors and strings for edit-mode help and +'* puts them on screen. +'* +'* Params: None +'* +'* Output: Screen +'* +Sub ShowEditHelp + + ' Clear old help and display new. + ClearHelp + Restore EditHelp + For Row = HELPTOP To HELPBOT + Read Clr + If Clr = CNORMAL Then + Color NORMAL, BACKGROUND + Else + Color HILITE, BACKGROUND + End If + Locate Row, HELPLEFT + Read Tmp$ + Print Tmp$; + Next + + ' Restore normal color. + Color NORMAL, BACKGROUND + +End Sub + +'* +'* ShowTopCard - Shows all the fields of the top card. +'* +'* Params: WorkCard - record to be displayed as top card +'* +'* Output: Screen +'* +Sub ShowTopCard (WorkCard As PERSON) + + ' Display each field of current card. + Restore FieldPositions + Read Row, Column, Length + Locate Row, Column + Print Space$(Length); + Locate Row, Column + Print WorkCard.Names; + + Read Row, Column, Length + Locate Row, Column + Print Space$(Length); + Locate Row, Column + Print WorkCard.Note; + + Read Row, Column, Length + Locate Row, Column + Print Space$(Length); + Locate Row, Column + Print Using "##_/"; WorkCard.Month; WorkCard.Day; + Print Using "##"; WorkCard.Year; + Read Row, Column, Length, Row, Column, Length + + Read Row, Column, Length + Locate Row, Column + Print Space$(Length); + Locate Row, Column + Print WorkCard.Phone; + + Read Row, Column, Length + Locate Row, Column + Print Space$(Length); + Locate Row, Column + Print WorkCard.Street; + + Read Row, Column, Length + Locate Row, Column + Print Space$(Length); + Locate Row, Column + Print WorkCard.City; + + Read Row, Column, Length + Locate Row, Column + Print Space$(Length); + Locate Row, Column + Print WorkCard.State; + + Read Row, Column, Length + Locate Row, Column + Print Space$(Length) + Locate Row, Column + Print WorkCard.Zip; + +End Sub + +'* +'* ShowViewHelp - Reads colors and strings for view-mode help and +'* puts them on screen. +'* +'* Params: None +'* +'* Output: Screen +'* +Sub ShowViewHelp + + ' Clear old help and display new. + ClearHelp + Restore ViewHelp + For Row = HELPTOP To HELPBOT + Read Clr + If Clr = CNORMAL Then + Color NORMAL, BACKGROUND + Else + Color HILITE, BACKGROUND + End If + Locate Row, HELPLEFT + Read Tmp$ + Print Tmp$; + Next + + ' Restore color and show command line. + Color NORMAL, BACKGROUND + ShowCmdLine + +End Sub + +'* +'* SortIndex - Sorts all records in memory according to a specified +'* field. After the sort, the first record in memory becomes the top +'* card. Note that although the order is changed in memory, the order +'* remains the same in the file. The true file order is shown by the +'* CardNum field of each record. This SUB uses the Shell sort +'* algorithm. +'* +'* Params: SortField - 0-based number of the field to sort on +'* LastCard - number of last card +'* +Sub SortIndex (SortField, LastCard) + + ' Set comparison offset to half the number of records. + Offset = LastCard \ 2 + + ' Loop until offset gets to zero. + Do While Offset > 0 + + Limit = LastCard - Offset + + Do + + ' Assume no switches at this offset. + Switch = FALSE + + ' Compare elements for the specified field and switch + ' any that are out of order. + For i = 1 To Limit + Select Case SortField + Case NPERSON + If Index(i).Names > Index(i + Offset).Names Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NNOTE + If Index(i).Note > Index(i + Offset).Note Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NMONTH + If Index(i).Month > Index(i + Offset).Month Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NDAY + If Index(i).Day > Index(i + Offset).Day Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NYEAR + If Index(i).Year > Index(i + Offset).Year Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NPHONE + If Index(i).Phone > Index(i + Offset).Phone Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NSTREET + If Index(i).Street > Index(i + Offset).Street Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NCITY + If Index(i).City > Index(i + Offset).City Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NSTATE + If Index(i).State > Index(i + Offset).State Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + Case NZIP + If Index(i).Zip > Index(i + Offset).Zip Then + Swap Index(i), Index(i + Offset) + Switch = i + End If + End Select + + Next i + + ' Sort on next pass only to location where last switch + ' was made. + Limit = Switch + + Loop While Switch + + ' No switches at last offset. Try an offset half as big. + Offset = Offset \ 2 + Loop + +End Sub + diff --git a/samples/qcards/src/qcards.zip b/samples/qcards/src/qcards.zip new file mode 100644 index 00000000..fc5cb186 Binary files /dev/null and b/samples/qcards/src/qcards.zip differ diff --git a/samples/qdigger/img/ss1.png b/samples/qdigger/img/ss1.png new file mode 100644 index 00000000..c0cb301c Binary files /dev/null and b/samples/qdigger/img/ss1.png differ diff --git a/samples/qdigger/img/ss2.png b/samples/qdigger/img/ss2.png new file mode 100644 index 00000000..cea6c9c9 Binary files /dev/null and b/samples/qdigger/img/ss2.png differ diff --git a/samples/qdigger/img/ss3.png b/samples/qdigger/img/ss3.png new file mode 100644 index 00000000..c01790fc Binary files /dev/null and b/samples/qdigger/img/ss3.png differ diff --git a/samples/qdigger/index.md b/samples/qdigger/index.md new file mode 100644 index 00000000..7a35bbbc --- /dev/null +++ b/samples/qdigger/index.md @@ -0,0 +1,30 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QDIGGER + +![ss1.png](img/ss1.png) + +### Author + +[🐝 RETROQB45](../retroqb45.md) + +### Description + +```text +A DIGGER game clone by RETROQB45. +``` + +### File(s) + +* [qdigger.bas](src/qdigger.bas) +* [qdigger.zip](src/qdigger.zip) + +### Additional Image(s) + +![ss2.png](img/ss2.png) +![ss3.png](img/ss3.png) + +🔗 [game](../game.md), [digger](../digger.md) + + +Reference: [1](ttps://en.wikipedia.org/wiki/Chaotic_scattering) diff --git a/samples/qdigger/src/qdigger.bas b/samples/qdigger/src/qdigger.bas new file mode 100644 index 00000000..ba3887b6 --- /dev/null +++ b/samples/qdigger/src/qdigger.bas @@ -0,0 +1,3189 @@ +$Resize:Smooth +$ExeIcon:'.\ARCTIC_OLD.ico' +_Title "QDigger" + +DefInt A-Z + +' options +Const lifecost = 5000 +Const emercost = 25 +Const emer8cost = 250 +Const goldcost = 500 +Const monstercost = 250 +Const eatcost = 250 +Const bonuscost = 1000 +Const hiscorefile$ = "qdigger.sco" + +' "system" constants +Const FALSE = 0, TRUE = Not FALSE, OLD = -2 +Const scrmode = 1, nopal = TRUE +Const namelen = 14 + +'colors in colortable +Const blackclr = 0 +Const greenclr = 1 +Const redclr = 2 +Const goldclr = 3 + +Type SCORETYPE + uname As String * Namelen + score As Long +End Type +Type PICPAR + sequence As Integer + frame As Integer +End Type +Type TIMEINT + starttime As Single + interval As Single +End Type +Type DIGGERTYPE + x As Integer + y As Integer + startx As Integer + starty As Integer + dx As Integer + dy As Integer + pic As PICPAR + mode As Integer + eye As Integer + lives As Integer + score As Long + teye As TIMEINT +End Type +Type ENEMYTYPE + x As Integer + y As Integer + stpx As Integer + stpy As Integer + trgx As Integer + trgy As Integer + dir As Integer + pic As PICPAR + chaseflee As Integer + mode As Integer + thob As TIMEINT + tdead As TIMEINT +End Type +Type NESTTYPE + x As Integer + y As Integer + COUNT As Integer +End Type +Type PICKUPTYPE + x As Integer + y As Integer + mode As Integer + pic As PICPAR + use As Integer + misc As Integer + fally As Integer + dx As Integer + dy As Integer + dir As Integer + t As TIMEINT +End Type +Type BONUSTYPE + x As Integer + y As Integer + use As Integer + iwait As Single + ilen As Single + t As TIMEINT +End Type + +'enemy states +Const enm.creating = 1 +Const enm.nobbin = 2 +Const enm.hobbin = 3 +Const enm.dying = 4 +Const enm.dead = 5 + +' mazecell inner stats +Const mz.filled = -1 +Const mz.empty = 0 +Const mz.half = 1 +Const mz.init = -100 + +Const gr.winner = 1 +Const gr.gameover = 2 +Const gr.abort = 0 + +Const hiscorec = 10 +Const scores.y = 8 +Const scores.x = 40 + +'ADD constants +Const newemerald = 1 +Const newbag = 2 +Const newnobbin = 4 +Const newgold = 5 + +'sound codes +Const snd.emerald = 1 +Const snd.gold = 2 +Const snd.bonus = 3 +Const snd.dead = 5 +Const snd.killenemy = 7 +Const snd.bagswing = 6 +Const snd.bagshift = 4 +Const snd.bagfall = 8 +Const snd.baglanding = 9 +Const snd.hit = 10 +Const snd.shoot = 11 +Const snd.dig = 12 + +' palette modes +Const pal.loading = -1 +Const pal.normal = 0 +Const pal.bonus = 1 + +' digger constants +Const diggerspeedy = 3 +Const diggerspeedx = 4 +Const dgr.left = 1 +Const dgr.right = 2 +Const dgr.up = 3 +Const dgr.down = 4 +Const dgr.dead = 5 +Const dgr.falling = 6 + +' playing screen & maze properties +Const viewx = 12, viewy = 6 ' from left&top of playing field +Const cellw = 15 + 5 ' = 20 ' screen cell size +Const cellh = 14 + 4 ' = 18 +Const mazex = 15 ' maze size +Const mazey = 10 + +' game field size +Const f.x = 0 +Const f.y = 12 +Const f.w = cellw * mazex + 20 +Const f.h = cellh * mazey + 8 + +' time intervals, their modification params, and extreme values +Const tim.s.eye = 5 +Const tim.s.hobbin = 3 +Const tim.s.nobbin = 15 +Const tim.d.nobbin = -1 +Const tim.d.hobbin = 1 +Const tim.min.nobbin = 7 +Const tim.max.hobbin = 7 + +' animation indexes +Const ani.stat = 0 +Const ani.bgrs = 1 +Const ani.dgrleft = 2 +Const ani.dgrright = 3 +Const ani.dgrup = 4 +Const ani.dgrdown = 5 +Const anid.withouteye = 4 +Const ani.dgrxleft = 6 +Const ani.dgrxright = 7 +Const ani.dgrxup = 8 +Const ani.dgrxdown = 9 +Const ani.dgrdie = 10 +Const ani.nobbin = 11 +Const ani.nobbindie = 12 +Const ani.hobbinleft = 13 +Const ani.hobbinright = 14 +Const ani.hobbindieleft = 15 +Const ani.hobbindieright = 16 +Const ani.emerald = 17 +Const ani.bag = 19 +Const ani.bagleft = 18 +Const ani.bagright = 20 +Const ani.bagfall = 21 +Const ani.bonus = 22 +Const ani.coins = 23 +Const ani.expl = 24 +Const ani.fire = 25 +Const ani.dig = 26 +Const iblob.down = 79 +Const iblob.left = iblob.down - 3 +Const iblob.right = iblob.down - 2 +Const iblob.up = iblob.down - 1 + +Const img1 = 0 +Const framec = 1 +Const mask = 1 +Const pic = 0 + +Const opened = 0 +Const leftwall = 1 +Const rightwall = 2 +Const upperwall = 4 +Const lowerwall = 8 +Const filled = 16 + +' bag movement modes +Const bagm.normal = 0 +Const bagm.swinging = 1 +Const bagm.left = 2 +Const bagm.right = 3 +Const bagm.falling = 4 + +Const maxcol = 15 + +Const emerw = 14, emerh = 10 +Const goldw = 17, goldh = 15 +Const imgw = 16, imgh = 16 + +Const gs.play = 0 +Const gs.pause = 1 +Const gs.killed = 2 +Const gs.restart = 3 +Const gs.newgame = 10 +Const gs.quit = 100 + +Const eyem.normal = 0 +Const eyem.expl = 1 +Const eyew = 8, eyeh = 8 + +'$DYNAMIC +Dim Shared mapon As Integer +Dim Shared eye As PICKUPTYPE +Dim Shared bonus As BONUSTYPE +Dim Shared tim.hobbin As Single, tim.nobbin As Single, tim.eye As Single +Dim Shared maze(-1 To mazex * 2 + 1, -1 To mazey * 2 + 1) As Integer +Dim Shared graph(15835) As Integer, graphindex +Dim Shared img(90, 1) As Integer, imgc +Dim Shared anim(70, 1) As Integer + +Dim Shared digger As DIGGERTYPE +Dim Shared enemy(1 To 5) As ENEMYTYPE, enemyc +Dim Shared bag(1 To 20) As PICKUPTYPE, bagc +Dim Shared gold(1 To 20) As PICKUPTYPE, goldc +Dim Shared emerald(1 To 100) As PICKUPTYPE, emeraldc +Dim Shared nest As NESTTYPE + +Dim Shared hiscore(hiscorec - 1) As SCORETYPE +Dim Shared levidx(1 To 256) As Integer + +Dim Shared bgrc, curbgr, consemer +Dim Shared curlevel, bonusmode, bonusscore +Dim Shared levelpack$, nosound +Dim Shared tcons As TIMEINT +Dim Shared gamestate +Dim Shared gameresult + +'if your BASIC is qbasic.exe, simply comment next line. +cmd$ = Command$ + +If cmd$ = "/?" Then + Print "Runs QDigger game." + Print + Print "QDIGGER [levelpackfile]" + Print + Print "You are Digger, an explorer of an old abandoned mine. This mine contains many" + Print "levels, and many treasures buried inside. You must collect all emeralds" + Print "moving from stage to stage; they cost 25 points each, and if you pick eight" + Print "of them in a short time, you will get 250 bonus points. But be careful!" + Print "Avoid Nobbins, angry mine monsters, they chase you to kill you. Sometimes" + Print "they become extremely wild, and turn into wild wall-breaking Hobbins... =/" + Print "You can use your fire against enemies by pressing . Remember, if you" + Print "push big brown bag down, it will tear apart and gold coins appear, they cost" + Print "500 points. There are some other features, reveal them yourself." + End +End If + +nosound = TRUE +Open "qdigger.ini" For Binary Access Read As #1 +Seek #1, 1 +a$ = Chr$(0) +Get #1, , a$ +Close #1 +If a$ <> Chr$(0) Then nosound = FALSE + +levelpack$ = cmd$ +INIT +Do + curlevel = 0 + SETPAL pal.normal + RESTOREFIELD + NEWGAME + ADDSCORE -1 + CHECKNEWHISCORE digger.score, gameresult + If gamestate <> gs.quit Then SHOWHISCORE +Loop Until gamestate = gs.quit +QUIT + + +DataLevidx: +Data 43 +Data 01,02,03,04,05,06,07,08,06,07,08 +Data 05,06,07,08 +Data 05,06,07,08 +Data 05,06,07,08 +Data 05,06,07,08 +Data 05,06,07,08 +Data 05,06,07,08 +Data 05,06,07,08 +Data 05,06,07,08 + +DataLevels: + +Data "_mine #1" +Data " :::$::::: e" +Data " ::77::7:: :$::" +Data " $:77::7:: ::::" +Data " ::77$:7$: :777" +Data " ::77::7:: :777" +Data " :77::7:: :777" +Data ": ::::$:$: ::::" +Data ": ::::: ::::" +Data "7::: ::::: :::7" +Data "77:: d ::77" + +Data "_mine #2" +Data " ::$:$:: e" +Data ":77:: ::::::: :" +Data ":77:: :77777: :" +Data "$77$: :77777: :" +Data "7777: ::::::: :" +Data "7777: :$:: :" +Data ":77:: :77: ::::" +Data ":$$:: 7777 :77:" +Data "7:::: :77: :77:" +Data "77::: d ::::" + +Data "_mine #3" +Data " $:$:$ e" +Data "77:: :7:7: :$$:" +Data "7::: :7:7: :77:" +Data ":$$: :7:7: 7777" +Data "7777 :7:7: 7777" +Data "7777 :77:" +Data ":77::7: :7::77:" +Data ":77::7: :7:::::" +Data "7::::7: :7::::7" +Data "77:::7:d:7:::77" + +Data "_mine #4" +Data " $7777$7777$ " +Data "7 ::7777777:: 7" +Data "7 :77777: 7" +Data "7:: ::777:: ::7" +Data "::: :7: :::" +Data "::$:: :$: ::$::" +Data "::7:: 777 ::7::" +Data ":777: :777:" +Data "77777:7 7:77777" +Data "77777:7d7:77777" + +Data "_mine #5" +Data " e" +Data " $7777$ 777777 " +Data " 777777 :77$7: " +Data " :7777: 77$777 " +Data " 777777 :7777: " +Data " :7777: $77777 " +Data " 77$777 :7777: " +Data " :77$7: 777777 " +Data " 777777 777777 " +Data " d " + +Data "_mine #6" +Data " e" +Data " 7$77 : : 77$7 " +Data " 777: $ $ :777 " +Data " 777 : : 777 " +Data " 77: :7 7: :77 " +Data " 77 :7 7: 77 " +Data " 7: :77 77: :7 " +Data " 7 $77 77$ 7 " +Data " 7 7777 7777 7 " +Data " d " + +Data "_mine #7" +Data " 77777 77777 e" +Data ": 7$7$7 7$7$7 :" +Data "$ 77777 77777 $" +Data "7 7777 7777 7" +Data "77 :777 777: 77" +Data "77 77 77 77" +Data "7777 :7 7: 7777" +Data "7777 : : 7777" +Data "77777 : : 77777" +Data "77777 d 77777" + +Data "_mine #8" +Data " e" +Data " :77$77777$77: " +Data " 7777$7777 " +Data " $ :7777777: $ " +Data " 7 77777 7 " +Data " 77$ :777: $77 " +Data " 777 7 777 " +Data " 7777: : :7777 " +Data " 77777 : 77777 " +Data " d " + +Data "_end" + +DataGfx: +'stats = 0 +Data 11 +Data 12,12 +Data "011111111000" +Data "111111111100" +Data "110000001100" +Data "110000001100" +Data "110000001100" +Data "110000111100" +Data "110000111100" +Data "110000111100" +Data "110000111100" +Data "110000111100" +Data "111111111100" +Data "011111111000" +Data 12,12 +Data "000001100000" +Data "000001100000" +Data "000001100000" +Data "000001100000" +Data "000001100000" +Data "000011100000" +Data "000011100000" +Data "000011100000" +Data "000011100000" +Data "000011100000" +Data "000011100000" +Data "000011100000" +Data 12,12 +Data "011111111000" +Data "111111111100" +Data "110000001100" +Data "000000001100" +Data "000000001100" +Data "000000001100" +Data "011111111100" +Data "111111111000" +Data "111100000000" +Data "111100000000" +Data "111111111100" +Data "011111111100" +Data 12,12 +Data "011111100000" +Data "111111110000" +Data "110000110000" +Data "110000110000" +Data "000000110000" +Data "001111111000" +Data "001111111100" +Data "000000011100" +Data "110000011100" +Data "110000011100" +Data "111111111100" +Data "011111111000" +Data 12,12 +Data "110000000000" +Data "110000000000" +Data "110000110000" +Data "110000110000" +Data "110000110000" +Data "110000110000" +Data "110000110000" +Data "111111111100" +Data "011111111100" +Data "000001110000" +Data "000001110000" +Data "000001110000" +Data 12,12 +Data "011111110000" +Data "111111110000" +Data "110000000000" +Data "110000000000" +Data "110000000000" +Data "111111111000" +Data "011111111100" +Data "000000111100" +Data "110000111100" +Data "110000111100" +Data "111111111100" +Data "011111111000" +Data 12,12 +Data "011111111000" +Data "111111111100" +Data "110000001100" +Data "110000001100" +Data "110000000000" +Data "111111111000" +Data "111111111100" +Data "110000111100" +Data "110000111100" +Data "110000111100" +Data "111111111100" +Data "011111111000" +Data 12,12 +Data "011111111000" +Data "011111111100" +Data "000000001100" +Data "000000001100" +Data "000000001100" +Data "000000001100" +Data "000000011100" +Data "000000011100" +Data "000000011100" +Data "000000011100" +Data "000000011100" +Data "000000011100" +Data 12,12 +Data "000111110000" +Data "001111111000" +Data "001100011000" +Data "001100011000" +Data "001100011000" +Data "001111111000" +Data "011111111100" +Data "110000011100" +Data "110000011100" +Data "110000011100" +Data "111111111100" +Data "011111111000" +Data 12,12 +Data "011111111000" +Data "111111111100" +Data "110000001100" +Data "110000001100" +Data "110000001100" +Data "111111111100" +Data "011111111100" +Data "000000111100" +Data "000000111100" +Data "000000111100" +Data "000000111100" +Data "000000111100" +Data 16,12 +Data "4444444033044444" +Data "4444440333304444" +Data "0000040300300444" +Data "1111102222222044" +Data "1111112222222204" +Data "0000112222222220" +Data "1111112222222222" +Data "1111102002222002" +Data "0000040330220330" +Data "4444403003003003" +Data "4444403003003003" +Data "4444440330440330" + +'backgrounds = 1 +Data 8 +Data 20,4 +Data "22333333222233333322" +Data "32233332233223333223" +Data "33223322333322332233" +Data "33322223333332222333" +Data 20,4 +Data "11221122112211221122" +Data "21122112211221122112" +Data "22112211221122112211" +Data "21122112211221122112" +Data 20,4 +Data "22332233223322332233" +Data "32233223322332233223" +Data "33223322332233223322" +Data "23322332233223322332" +Data 20,4 +Data "11333333111133333311" +Data "31133331133113333113" +Data "33113311333311331133" +Data "33311113333331111333" +Data 20,4 +Data "22333333222233333322" +Data "31133331133113333113" +Data "33223322333322332233" +Data "33311113333331111333" +Data 20,4 +Data "11221122112211221122" +Data "21122112211221122112" +Data "11221122112211221122" +Data "21122112211221122112" +Data 20,4 +Data "22332233223322332233" +Data "31133113311331133113" +Data "33113311331133113311" +Data "23322332233223322332" +Data 20,4 +Data "33223322332233223322" +Data "23322332233223322332" +Data "22332233223322332233" +Data "23322332233223322332" + +'digger: left = 2 +Data 3 +Data 16,15 +Data "4444444444444444" +Data "4444444033044444" +Data "4444440333304444" +Data "4444440300304444" +Data "4444440300304444" +Data "0000040300300444" +Data "1111102222222044" +Data "1111112222222204" +Data "0000112222222220" +Data "1111112222222002" +Data "1111102002220330" +Data "0000040330203003" +Data "4444403003003003" +Data "4444403003040330" +Data "4444440330444004" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444033044444" +Data "4444440333304444" +Data "4000040300304444" +Data "0111100300300444" +Data "0111112222222044" +Data "4001112222222204" +Data "4440112222222220" +Data "4001112002222222" +Data "0111110330022002" +Data "0111103003000330" +Data "4000003003003003" +Data "4444440330403003" +Data "4444444004440330" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444400444444" +Data "4400444033044444" +Data "4011040333304444" +Data "4011100300300444" +Data "4401112222222044" +Data "4440112222222204" +Data "4440112222222220" +Data "4440112222222002" +Data "4401112002220330" +Data "4011100330203003" +Data "4011003003003003" +Data "4400403003040330" +Data "4444440330444004" + +'digger: right = 3 +Data 3 +Data 16,15 +Data "4444444444444444" +Data "4444403304444444" +Data "4444033330444444" +Data "4444030030444444" +Data "4444030030444444" +Data "4440030030400000" +Data "4402222222011111" +Data "4022222222111111" +Data "0222222222110000" +Data "2002222222111111" +Data "0330222002011111" +Data "3003020330400000" +Data "3003003003044444" +Data "0330403003044444" +Data "4004440330444444" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444403304444444" +Data "4444033330444444" +Data "4444030030440004" +Data "4440030030001110" +Data "4402222222111110" +Data "4022222222111004" +Data "0222222222110444" +Data "2222222002111004" +Data "2002220330111110" +Data "0330203003001110" +Data "3003003003040004" +Data "3003040330444444" +Data "0330444004444444" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444403304440044" +Data "4444033330401104" +Data "4440030030011104" +Data "4402222222111044" +Data "4022222222110444" +Data "0222222222110444" +Data "2002222222110444" +Data "0330222002111044" +Data "3003020330011104" +Data "3003003003001104" +Data "0330403003040044" +Data "4004440330444444" + +'digger: up = 4 +Data 3 +Data 16,15 +Data "4440110110444444" +Data "4440110110444444" +Data "4440110110444444" +Data "4440110110444444" +Data "4004011104444444" +Data "0330222220000444" +Data "3003022223333044" +Data "3003022220003304" +Data "0330222220003304" +Data "4000222223333044" +Data "4400222220000444" +Data "4033022220444444" +Data "0300302204444444" +Data "0300302044444444" +Data "4033020444444444" +Data 16,15 +Data "4401104011044444" +Data "4401104011044444" +Data "4401110111044444" +Data "4401111111044444" +Data "4400111110444444" +Data "4033022220004444" +Data "0300302223330444" +Data "0300302220033044" +Data "4033022220033044" +Data "4400022223330444" +Data "4000222220004444" +Data "0330222220444444" +Data "3003022204444444" +Data "3003022444444444" +Data "0330224444444444" +Data 16,15 +Data "4400444440044444" +Data "4011044401104444" +Data "4011100011104444" +Data "4401111111044444" +Data "4000111110444444" +Data "0330222220044444" +Data "3003022223304444" +Data "3003022220330444" +Data "0330222220330444" +Data "4000222223304444" +Data "4400222220044444" +Data "4033022220444444" +Data "0300302204444444" +Data "0300302044444444" +Data "4033020444444444" + +'digger: down = 5 +Data 3 +Data 16,15 +Data "4444444402033044" +Data "4444444020300304" +Data "4444440220300304" +Data "4444402222033044" +Data "4400002222200444" +Data "4033332222200044" +Data "0330002222203304" +Data "0330002222030034" +Data "4033332222030034" +Data "4400002222203304" +Data "4444440111040044" +Data "4444401111104444" +Data "4444401101104444" +Data "4444401101104444" +Data "4444401101104444" +Data 16,15 +Data "4444444402203304" +Data "4444444022030034" +Data "4444440222030034" +Data "4444402222203304" +Data "4440002222200044" +Data "4403332222000444" +Data "4033002222033044" +Data "4033002220300304" +Data "4403332220300304" +Data "4440002222033044" +Data "4444401111000444" +Data "4444011101110444" +Data "4444011040110444" +Data "4444011040110444" +Data "4444011040110444" +Data 16,15 +Data "4444444402033044" +Data "4444444020300304" +Data "4444440220300304" +Data "4444402222033044" +Data "4444002222200444" +Data "4440332222200044" +Data "4403302222203304" +Data "4403302222030034" +Data "4440332222030034" +Data "4444002222203304" +Data "4444401111100044" +Data "4444011111110444" +Data "4440111000111044" +Data "4440110444011044" +Data "4444004444400444" + +'digger: leftx = 6 +Data 3 +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444400444444" +Data "4444444033044444" +Data "0000040333300444" +Data "1111102222222044" +Data "1111112222222204" +Data "0000112222222220" +Data "1111112222222002" +Data "1111102002220330" +Data "0000040330203003" +Data "4444403003003003" +Data "4444403003040330" +Data "4444440330444004" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444400444444" +Data "4000044033044444" +Data "0111100333300444" +Data "0111112222222044" +Data "4001112222222204" +Data "4440112222222220" +Data "4001112002222222" +Data "0111110330022002" +Data "0111103003000330" +Data "4000003003003003" +Data "4444440330403003" +Data "4444444004440330" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4400444400444444" +Data "4011044033044444" +Data "4011100333300444" +Data "4401112222222044" +Data "4440112222222204" +Data "4440112222222220" +Data "4440112222222002" +Data "4401112002220330" +Data "4011100330203003" +Data "4011003003003003" +Data "4400403003040330" +Data "4444440330444004" + +'digger: rightx = 7 +Data 3 +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444440044444444" +Data "4444403304444444" +Data "4440033330400000" +Data "4402222222011111" +Data "4022222222111111" +Data "0222222222110000" +Data "2002222222111111" +Data "0330222002011111" +Data "3003020330400000" +Data "3003003003044444" +Data "0330403003044444" +Data "4004440330444444" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444440044444444" +Data "4444403304440004" +Data "4440033330001110" +Data "4402222222111110" +Data "4022222222111004" +Data "0222222222110444" +Data "2222222002111004" +Data "2002220330111110" +Data "0330203003001110" +Data "3003003003040004" +Data "3003040330444444" +Data "0330444004444444" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444440044440044" +Data "4444403304401104" +Data "4440033330011104" +Data "4402222222111044" +Data "4022222222110444" +Data "0222222222110444" +Data "2002222222110444" +Data "0330222002111044" +Data "3003020330011104" +Data "3003003003001104" +Data "0330403003040044" +Data "4004440330444444" + +'digger: upx = 8 +Data 3 +Data 16,15 +Data "4440110110444444" +Data "4440110110444444" +Data "4440110110444444" +Data "4440110110444444" +Data "4004011104444444" +Data "0330222220444444" +Data "3003022223044444" +Data "3003022223304444" +Data "0330222223304444" +Data "4000222223044444" +Data "4400222220444444" +Data "4033022220444444" +Data "0300302204444444" +Data "0300302044444444" +Data "4033020444444444" +Data 16,15 +Data "4401104011044444" +Data "4401104011044444" +Data "4401110111044444" +Data "4401111111044444" +Data "4400111110444444" +Data "4033022220444444" +Data "0300302223044444" +Data "0300302223304444" +Data "4033022223304444" +Data "4400022223044444" +Data "4000222220444444" +Data "0330222220444444" +Data "3003022204444444" +Data "3003022044444444" +Data "0330220444444444" +Data 16,15 +Data "4400444440044444" +Data "4011044401104444" +Data "4011100011104444" +Data "4401111111044444" +Data "4000111110444444" +Data "0330222220444444" +Data "3003022223044444" +Data "3003022223304444" +Data "0330222223304444" +Data "4000222223044444" +Data "4400222220444444" +Data "4033022220444444" +Data "0300302204444444" +Data "0300302044444444" +Data "4033020444444444" + +'digger: downx = 9 +Data 3 +Data 16,15 +Data "4444444402033044" +Data "4444444020300304" +Data "4444440220300304" +Data "4444402222033044" +Data "4444402222200444" +Data "4444032222200044" +Data "4440332222203304" +Data "4440332222030034" +Data "4444032222030034" +Data "4444402222203304" +Data "4444440111040044" +Data "4444401111104444" +Data "4444401101104444" +Data "4444401101104444" +Data "4444401101104444" +Data 16,15 +Data "4444444402203304" +Data "4444444022030034" +Data "4444440222030034" +Data "4444402222203304" +Data "4444402222200044" +Data "4444032222000444" +Data "4440332222033044" +Data "4440332220300304" +Data "4444032220300304" +Data "4444402222033044" +Data "4444401111000444" +Data "4444011101110444" +Data "4444011040110444" +Data "4444011040110444" +Data "4444011040110444" +Data 16,15 +Data "4444444402033044" +Data "4444444020300304" +Data "4444440220300304" +Data "4444402222033044" +Data "4444402222200444" +Data "4444032222200044" +Data "4440332222203304" +Data "4440332222030034" +Data "4444032222030034" +Data "4444402222203304" +Data "4444401111100044" +Data "4444011111110444" +Data "4440111000111044" +Data "4440110444011044" +Data "4444004444400444" + +'digger: die = 10 +Data 6 +Data 16,15 +Data "4444444004444004" +Data "4444440330440330" +Data "4444403303003333" +Data "4400003333003303" +Data "0011100330220330" +Data "1111112002222002" +Data "1100112222222220" +Data "0011112222222204" +Data "1111102222222044" +Data "1100040300330444" +Data "0044440030300444" +Data "4444440300330444" +Data "4444444033330444" +Data "4444444403304444" +Data "4444444440044444" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444440004444444" +Data "4444001110044444" +Data "4400113331100444" +Data "4011333333311044" +Data "4013333333331044" +Data "0000000000000004" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444440004444444" +Data "4444001110044444" +Data "4400113331100444" +Data "4011333333311044" +Data "4013333333331044" +Data "0100003333333104" +Data "0103303033333104" +Data "0000000000000004" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444440004444444" +Data "4444001110044444" +Data "4400113331100444" +Data "4011333333311044" +Data "4013333333331044" +Data "0100003333333104" +Data "0103303033333104" +Data "0100003030000104" +Data "0100333030330104" +Data "0000000000000004" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444440004444444" +Data "4444001110044444" +Data "4400113331100444" +Data "4011333333311044" +Data "4013333333331044" +Data "0100003333333104" +Data "0103303033333104" +Data "0100003030000104" +Data "0100333030330104" +Data "0103033030000104" +Data "0103303030333104" +Data "0133333030333104" +Data "0000000000000004" +Data 16,15 +Data "4444440004444444" +Data "4444001110044444" +Data "4400113331100444" +Data "4011333333311044" +Data "4013333333331044" +Data "0100003333333104" +Data "0103303033333104" +Data "0100003030000104" +Data "0100333030330104" +Data "0103033030000104" +Data "0103303030333104" +Data "0133333030333104" +Data "0133333330333104" +Data "0133333333333104" +Data "0000000000000004" + +'nobbin: walk = 11 +Data 3 +Data 16,15 +Data "4440004444000444" +Data "4403330000333044" +Data "4033333113333304" +Data "4030033113003304" +Data "4030033113003304" +Data "4403331111333044" +Data "4440111111110444" +Data "4440011111100444" +Data "4402201001022044" +Data "4022001111002204" +Data "4022040110402204" +Data "4022044004022220" +Data "4022044440222222" +Data "0222204444000000" +Data "2222220444444444" +Data 16,15 +Data "4440004444000444" +Data "4403330000333044" +Data "4033333113333304" +Data "4033003113300304" +Data "4033003113300304" +Data "4403331111333044" +Data "4440111111110444" +Data "4440011001100444" +Data "4402201001022044" +Data "4022001111002204" +Data "4022040110402204" +Data "4022044004402204" +Data "0222244444022220" +Data "2222224440222222" +Data "0000004444000000" +Data 16,15 +Data "4440004444000444" +Data "4403330000333044" +Data "4033003113300304" +Data "4033003113300304" +Data "4033333113333304" +Data "4403331111333044" +Data "4440111001110444" +Data "4440011001100444" +Data "4402201001022044" +Data "4022001001002204" +Data "4022040110402204" +Data "0222204004402204" +Data "2222220444402204" +Data "0000004444022220" +Data "4444444440222222" + +'nobbin: die = 12 +Data 1 +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4440004444000444" +Data "4403330000333044" +Data "4030033113300304" +Data "4030033113300304" +Data "4033333113333304" +Data "4403331111333044" +Data "4440111001110444" +Data "4440011001100444" +Data "4402201001022044" +Data "4022001001002204" +Data "0222200110022220" +Data "2222220000222222" +Data "0000004444000000" + +'hobbin: left = 13 +Data 3 +Data 16,15 +Data "4444010333010444" +Data "4440103333301044" +Data "4440103300301104" +Data "4401103300301110" +Data "4011110333011110" +Data "0111111000111110" +Data "4022222111111104" +Data "4400000211111044" +Data "4022222111110444" +Data "4401111111104444" +Data "4440000220044444" +Data "4444440220444444" +Data "4444440220444444" +Data "4444402222044444" +Data "4444022222204444" +Data 16,15 +Data "4444010333010444" +Data "4440103333301044" +Data "4401103003301104" +Data "4011103003301110" +Data "0111110333011110" +Data "0222111000111110" +Data "4000222111111104" +Data "4444000211111044" +Data "4400022111110444" +Data "4022211111104444" +Data "4411100220044444" +Data "4440040220444444" +Data "4444402222044444" +Data "4444022222204444" +Data "4444400000044444" +Data 16,15 +Data "4444010333010444" +Data "4440103003301044" +Data "4401103003301104" +Data "4011103333301110" +Data "0221110333011110" +Data "4002211000111110" +Data "4440022111111104" +Data "4444000211111044" +Data "4400022111110444" +Data "4402211111104444" +Data "4421100220044444" +Data "4440002222044444" +Data "4444022222204444" +Data "4444400000044444" +Data "4444444444444444" + +'hobbin: right = 14 +Data 3 +Data 16,15 +Data "4440103330104444" +Data "4401033333010444" +Data "4011030033010444" +Data "0111030033011044" +Data "0111103330111104" +Data "0111110001111110" +Data "4011111112222204" +Data "4401111120000044" +Data "4440111112222204" +Data "4444011111111044" +Data "4444400220000444" +Data "4444440220444444" +Data "4444440220444444" +Data "4444402222044444" +Data "4444022222204444" +Data 16,15 +Data "4440103330104444" +Data "4401033333010444" +Data "4011033003011444" +Data "0111033003011144" +Data "0111103330111114" +Data "0111110001112224" +Data "4011111112220044" +Data "4401111120004444" +Data "4440111112200044" +Data "4444011111122204" +Data "4444400220011144" +Data "4444440220400444" +Data "4444402222044444" +Data "4444022222204444" +Data "4444400000044444" +Data 16,15 +Data "4440103330104444" +Data "4401033003010444" +Data "4011033003011044" +Data "0111033333011104" +Data "0111103330111220" +Data "0111110001122004" +Data "4011111112200444" +Data "4401111120044444" +Data "4440111112200444" +Data "4444011111122004" +Data "4444400220011204" +Data "4444402222000044" +Data "4444022222204444" +Data "4444400000044444" +Data "4444444444444444" + +'hobbin: dieleft = 15 +Data 1 +Data 16,14 +Data "4444400000004444" +Data "4444010333010444" +Data "4440103003301044" +Data "4401103003301104" +Data "4011103333301110" +Data "0221110333011110" +Data "4002211000111110" +Data "4440022111111104" +Data "4440022211111044" +Data "4402221111110444" +Data "4222111111104444" +Data "4400002222044444" +Data "4444022222204444" +Data "4444400000044444" + +'hobbin: dieright = 16 +Data 1 +Data 16,15 +Data "4444444444444444" +Data "4444000000044444" +Data "4440103330104444" +Data "4401033003010444" +Data "4011033003011044" +Data "0111033333011104" +Data "0111103330111220" +Data "0111110001122004" +Data "4011111112200444" +Data "4401111122244444" +Data "4440111111222444" +Data "4444011111112224" +Data "4444402222000004" +Data "4444022222204444" +Data "4444400000044444" + +'emerald = 17 +Data 1 +Data 14,10 +Data "44400000000044" +Data "44001111111004" +Data "40011311111100" +Data "00113111111110" +Data "40011311110100" +Data "44001111101004" +Data "44400111010044" +Data "44440011100444" +Data "44444001004444" +Data "44444400044444" + +'goldbag: moveleft = 18 +Data 1 +Data 16,15 +Data "4444400004444444" +Data "4444033330444444" +Data "4444403304444444" +Data "4444033330044444" +Data "4440333333304444" +Data "4403330033330444" +Data "4030000000033044" +Data "0300330033333304" +Data "0300000000003304" +Data "0333330033003304" +Data "0300330033003304" +Data "0330000000033044" +Data "4033330033330444" +Data "4400333333004444" +Data "4444000000444444" + +'goldbag: normal = 19 +Data 1 +Data 16,15 +Data "4444400000044444" +Data "4444403333044444" +Data "4444440330444444" +Data "4444003333004444" +Data "4440333333330444" +Data "4403333003333044" +Data "4033000000003304" +Data "0330033003333330" +Data "0330000000000330" +Data "0333333003300330" +Data "0330033003300330" +Data "0333000000003330" +Data "4033333003333304" +Data "4400333333330044" +Data "4444000000004444" + +'goldbag: moveright = 20 +Data 1 +Data 16,15 +Data "4444444000044444" +Data "4444440333304444" +Data "4444440033044444" +Data "4444403333304444" +Data "4444033333330444" +Data "4440333300333044" +Data "4403300000000304" +Data "4033003300333330" +Data "4033000000000030" +Data "4033333300330030" +Data "4033003300330030" +Data "4403300000000304" +Data "4440333300333044" +Data "4444003333300444" +Data "4444440000044444" + +'goldbag: fall = 21 +Data 1 +Data 16,15 +Data "4444403003044444" +Data "4444440330444444" +Data "4444440330444444" +Data "4444403333044444" +Data "4444033333304444" +Data "4440333003330444" +Data "4403000000003044" +Data "4030033003333304" +Data "4030000000000304" +Data "4033333003300304" +Data "4030033003300304" +Data "4403000000003044" +Data "4440333003330444" +Data "4444033333304444" +Data "4444400330044444" + +'bonus = 22 +Data 1 +Data 16,15 +Data "4000000011100004" +Data "0000000111110000" +Data "0000000110110000" +Data "0000001100011000" +Data "0000001100001100" +Data "0000011000101101" +Data "0000011000011110" +Data "0010110100001100" +Data "0001111000022200" +Data "0002220000233220" +Data "0023322002332222" +Data "0223222202222222" +Data "0222222200222220" +Data "0022222000022200" +Data "4002220000000004" + +'falling coins = 23 +Data 3 +Data 16,15 +Data "4444444004444444" +Data "4444440330444444" +Data "4444003333044444" +Data "4440330333044444" +Data "4403333030304444" +Data "4033333303330444" +Data "4033333303333044" +Data "4403333033333044" +Data "4440330033330444" +Data "4403003300004444" +Data "4033330303304444" +Data "4333333033330444" +Data "0333333033333044" +Data "4033330333333044" +Data "4403303033330444" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444004444" +Data "4444004440330444" +Data "4440330403333044" +Data "4403333033333304" +Data "4033333303333304" +Data "4033333300333044" +Data "4403333033030444" +Data "4400330333304444" +Data "4033003333030444" +Data "4333300330333044" +Data "0333330003333304" +Data "4033330303333304" +Data "4403303330333044" +Data 16,15 +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4444444444444444" +Data "4440044444400444" +Data "4403304000033044" +Data "4033330330333304" +Data "0333333033033330" +Data "0333333033303330" +Data "4033330033300004" +Data "4003300333033304" +Data "0330030000333330" +Data "0333330330333330" +Data "4033303333033304" + +'explosion = 24 +Data 3 +Data 8,8 +Data "00444400" +Data "03000030" +Data "40322304" +Data "44022044" +Data "40322304" +Data "03000030" +Data "00444400" +Data "44444444" +Data 8,8 +Data "30444403" +Data "03044030" +Data "40244204" +Data "44044044" +Data "40244204" +Data "03044030" +Data "30444403" +Data "44444444" +Data 8,8 +Data "20444402" +Data "03044030" +Data "40444404" +Data "44444444" +Data "40444404" +Data "03044030" +Data "20444402" +Data "44444444" + +' fire = 25 +Data 3 +Data 8,8 +Data "40033004" +Data "02302332" +Data "03233030" +Data "33033323" +Data "03303330" +Data "03033030" +Data "43032304" +Data "44444444" +Data 8,8 +Data "40232424" +Data "03302232" +Data "00223024" +Data "33032322" +Data "22302032" +Data "22032202" +Data "42432024" +Data "44444444" +Data 8,8 +Data "40220224" +Data "02032202" +Data "20222022" +Data "23032220" +Data "02222322" +Data "22032203" +Data "40222024" +Data "44444444" + +' digleft = 26 +Data 1 +Data 8,18 +Data "44444400" +Data "44440000" +Data "44400000" +Data "44000000" +Data "44000000" +Data "40000000" +Data "00000000" +Data "00000000" +Data "00000000" +Data "00000000" +Data "00000000" +Data "00000000" +Data "40000000" +Data "44000000" +Data "44000000" +Data "44400000" +Data "44444004" +Data "44440044" + +' digright = 27 +Data 1 +Data 8,18 +Data "44004444" +Data "00004444" +Data "00000444" +Data "00000044" +Data "00000044" +Data "00000004" +Data "00000000" +Data "00000000" +Data "00000000" +Data "00000000" +Data "00000000" +Data "00000000" +Data "00000004" +Data "00000044" +Data "00000444" +Data "00000444" +Data "40044444" +Data "00444444" + +'digup = 28 +Data 1 +Data 24,6 +Data "444444444000000444444444" +Data "444444400000000004444444" +Data "444444000000000000044444" +Data "444000000000000000000444" +Data "440000000000000000004444" +Data "444400000000000000000044" + +'digdown = 29 +Data 1 +Data 24,6 +Data "444000000000000000000444" +Data "440000000000000000004444" +Data "444400000000000000000044" +Data "444440000000000000044444" +Data "444444400000000004444444" +Data "444444444000000444444444" + +Rem $STATIC +Sub ADDOBJ (obj, cx, cy) + GETCELLCOORDS cx, cy, x, y + Select Case obj + Case newnobbin + enemyc = enemyc + 1 + enemy(enemyc).mode = enm.nobbin + enemy(enemyc).x = x: enemy(enemyc).y = y + enemy(enemyc).stpx = x: enemy(enemyc).stpy = y + enemy(enemyc).trgx = cx: enemy(enemyc).trgy = cy + enemy(enemyc).thob.starttime = Timer: enemy(enemyc).thob.interval = tim.nobbin + enemy(enemyc).pic.sequence = ani.nobbin: enemy(enemyc).pic.frame = 0 + Case newemerald + emeraldc = emeraldc + 1 + emerald(emeraldc).x = x: emerald(emeraldc).y = y + 3 ' +3 - ⮡ 業 ⪨ + emerald(emeraldc).mode = 0 + emerald(emeraldc).pic.sequence = ani.emerald + emerald(emeraldc).pic.frame = 0 + DRAWPIC emerald(emeraldc).x, emerald(emeraldc).y, emerald(emeraldc).pic, FALSE + Case newbag + bagc = bagc + 1 + bag(bagc).x = x + bag(bagc).y = y + bag(bagc).mode = gld.normal + bag(bagc).misc = 0 + bag(bagc).fally = 0 + bag(bagc).pic.sequence = ani.bag + DRAWPIC x, y, bag(bagc).pic, FALSE + Case newgold + goldc = goldc + 1 + gold(goldc).x = x + gold(goldc).y = y + gold(goldc).pic.sequence = ani.coins + gold(goldc).pic.frame = -1 + gold(goldc).t.interval = 10 + gold(goldc).t.starttime = Timer + End Select +End Sub + +Sub ADDSCORE (amount) + Static addition As Long + Static t As TIMEINT: t.interval = .01 + Static newlife As Long + Static palflag + If amount < 0 Then + digger.score = digger.score + addition + SHOWSCORE digger.score, digger.lives + addition = 0 + Else + addition = addition + amount + If TEVENT(t) Then + If digger.score = 0 Then newlife = lifecost + If palflag >= 1 Then + palflag = palflag - 1 + If palflag = 0 And bonusmode = FALSE Then SETPAL pal.normal + End If + If digger.score + addition >= newlife Then + SETPAL pal.bonus + palflag = 3 + newlife = newlife + lifecost + If digger.lives < 9 Then digger.lives = digger.lives + 1 + End If + For i = 1 To addition \ 5 + 1 + If addition <= 0 Then Exit For + addition = addition - 1 + digger.score = digger.score + 1 + Next + End If + End If +End Sub + +Sub ANIMATE (x, y, P As PICPAR, redr) + If redr Then + If P.frame >= 0 Then ERASEPIC x, y, P + P.frame = (P.frame + 1) Mod anim(P.sequence, framec) + DRAWPIC x, y, P, FALSE + Else + P.frame = (P.frame + 1) Mod anim(P.sequence, framec) + End If +End Sub + +Function BOXCOLL (x, y, w, h, ax, ay, aw, ah) + x2 = x + w - 1 + y2 = y + h - 1 + ax2 = ax + aw - 1 + ay2 = ay + ah - 1 + If x > ax Then xr1 = x Else xr1 = ax + If y > ay Then yr1 = y Else yr1 = ay + If x2 < ax2 Then xr2 = x2 Else xr2 = ax2 + If y2 < ay2 Then yr2 = y2 Else yr2 = ay2 + wr = xr2 - xr1 + hr = yr2 - yr1 + If wr < 0 Or hr < 0 Then BOXCOLL = FALSE Else BOXCOLL = TRUE +End Function + +Function CHECKBAGSHIFT (x, y, dir) + For i = 1 To bagc + If BOXCOLL(x + dir, y, imgw, imgh, bag(i).x, bag(i).y, cellw - 1, cellh) Then + If bag(i).mode = bagm.normal And dir <> 0 Then r = SHIFTBAG(i, dir * diggerspeedx) + CHECKBAGSHIFT = TRUE + Exit Function + End If + Next + CHECKBAGSHIFT = FALSE +End Function + +Sub CHECKBONUS (x, y, scoreflag) + If bonus.use Then + bx = bonus.x + by = bonus.y + If BOXCOLL(x, y, imgw, imgh, bx, by, imgw, imgh) Then + ERASEIMG bx, by, anim(ani.bonus, img1) + bonusmode = TRUE + bonus.use = FALSE + bonus.t.starttime = Timer + If scoreflag Then ADDSCORE bonuscost + SETPAL pal.bonus + Else + DRAWIMG bx, by, anim(ani.bonus, img1), FALSE + End If + End If +End Sub + +Sub CHECKEMERALDS (plx, ply, scoreflag) + For i = emeraldc To 1 Step -1 + If BOXCOLL(plx, ply, imgw, imgh, emerald(i).x, emerald(i).y, emerw, emerh) Then + If scoreflag Then + ADDSCORE emercost + consemer = consemer + 1 + tcons.starttime = Timer + If consemer = 8 Then ADDSCORE emer8cost: consemer = 0 + PLAYSOUND snd.emerald + End If + ERASEPIC emerald(i).x, emerald(i).y, emerald(i).pic + Swap emerald(emeraldc), emerald(i) + emeraldc = emeraldc - 1 + End If + Next +End Sub + +Sub CHECKGOLD (plx, ply, scoreflag) + For i = goldc To 1 Step -1 + If BOXCOLL(plx, ply, imgw + 2, imgh + 2, gold(i).x, gold(i).y + imgh * .4, imgw + 3, imgh * (1 - .4)) Then + If scoreflag Then ADDSCORE goldcost + PLAYSOUND snd.gold + ERASEPIC gold(i).x, gold(i).y, gold(i).pic + REDRAW gold(i).x, gold(i).y, emerald(), emeraldc + Swap gold(goldc), gold(i) + goldc = goldc - 1 + End If + Next +End Sub + +Sub CHECKKILL + Const d = 4 + For i = enemyc To 1 Step -1 + If (enemy(i).mode = enm.hobbin Or enemy(i).mode = enm.nobbin) And BOXCOLL(enemy(i).x + d, enemy(i).y + d, imgw - d * 2, imgh - d * 2, digger.x, digger.y, imgw, imgh) Then + If Not bonusmode Then + gamestate = gs.killed + ERASEPIC enemy(i).x, enemy(i).y, enemy(i).pic + ERASEPIC digger.x, digger.y, digger.pic + digger.pic.sequence = ani.dgrdie + digger.pic.frame = -1 + digger.mode = dgr.dead + PLAYSOUND snd.dead + Exit For + Else + ERASEPIC enemy(i).x, enemy(i).y, enemy(i).pic + Swap enemy(i), enemy(enemyc) + enemyc = enemyc - 1 + bonusscore = bonusscore + eatcost + ADDSCORE bonusscore + End If + End If + Next +End Sub + +Sub CHECKNEWHISCORE (score As Long, gameresult) + ' score = hiscore(hiscorec - 1).score + 1 + cw = 8: ch = 14 + If score > hiscore(hiscorec - 1).score Then + For i = 0 To hiscorec - 1 + If hiscore(i).score < score Then + For j = hiscorec - 1 To i + 1 Step -1 + hiscore(j) = hiscore(j - 1) + Next + hiscore(i).score = score + View + Line (cw * 10 - 8, ch * 4)-Step(cw * 22 + 1 + 16, ch * 6 + 1), 0, BF + If gameresult = gr.gameover Then + Locate 10, 14: Print " GAME OVER! " + ElseIf gameresult = gr.winner Then + Locate 10, 14: Print "CONGRATULATIONS!" + Else + Locate 10, 14: Print " HIGH SCORE!! " + End If + Line (cw * 10 + 2 - 8, ch * 4 + 2)-Step(cw * 22 - 3 + 16, ch * 6 - 3), 2, B + Locate 13, 14: Print "Enter your name:" + Locate 15, 15: Print String$(namelen, ".") + Do + Do: k$ = InKey$: Loop While Len(k$) = 0 + Select Case Asc(k$) + Case Is >= 32: If Len(name$) < namelen Then name$ = name$ + k$ + Case 8: If Len(name$) > 0 Then name$ = Left$(name$, Len(name$) - 1) + End Select + Locate 15, 15: Print name$ + String$(namelen - Len(name$), ".") + Loop Until k$ = Chr$(13) + hiscore(i).uname = name$ + String$(namelen - Len(name$), ".") + UPDATESCORES + Exit For + End If + Next + End If +End Sub + +Sub CLOSELEVEL + If levelpack$ <> "" Then Close #1 +End Sub + +Sub DELAY (sec!) + ct! = Timer + Do Until ct! + sec! <= Timer + a = Len(InKey$) + Loop +End Sub + +Sub DRAWHOLE (x, y) + SCANMAZECELL x, y, 0, l, r, u, d + SCANMAZECELL x + 1, y, rc, 0, 0, 0, 0 + SCANMAZECELL x - 1, y, lc, 0, 0, 0, 0 + SCANMAZECELL x, y + 1, dc, 0, 0, 0, 0 + SCANMAZECELL x, y - 1, uc, 0, 0, 0, 0 + GETCELLCOORDS x, y, cx, cy + If l = FALSE Or (x = 0 And (y = 0 Or y = mazey - 1 Or r = FALSE)) Then + For i = cx - 5 To cx + 10 Step diggerspeedx + DRAWIMG i, cy - 1, iblob.left, FALSE + Next + End If + If r = FALSE Or (x = mazex - 1 And (y = 0 Or y = mazey - 1 Or l = FALSE)) Then + If lc = mz.empty Then delta = 1 Else delta = 0 + For i = cx + 10 + 1 - diggerspeedx * (3 + delta) To cx + 10 + 1 Step diggerspeedx + DRAWIMG i, cy - 1, iblob.right, FALSE + Next + End If + If u = FALSE Or (y = 0 And (x = mazex - 1 Or x = 0)) Then + If uc = FALSE Then delta = 1 Else delta = 0 + For i = cy - 3 - diggerspeedy * delta To cy - 3 + diggerspeedy * 4 Step diggerspeedy + DRAWIMG cx - 5, i, iblob.up, FALSE + Next + End If + If d = FALSE Or (y = 0 And (x = mazex - 1 Or x = 0)) Then + If dc = mz.empty And u = FALSE Then delta = 1 Else delta = 0 + For i = cy + 12 - diggerspeedy * (4) To cy + 12 + diggerspeedy * delta Step diggerspeedy + DRAWIMG cx - 5, i, iblob.down, FALSE + Next + End If +End Sub + +Sub DRAWIMG (x, y, imgn, disablemask) + If Not disablemask Then Put (x, y), graph(img(imgn, mask)), And + Put (x, y), graph(img(imgn, pic)), Or +End Sub + +Sub DRAWPIC (x, y, P As PICPAR, disablemask) + If P.frame >= 0 Then DRAWIMG x, y, anim(P.sequence, img1) + P.frame, disablemask +End Sub + +Sub ERASEIMG (x, y, im) + Put (x, y), graph(img(im, mask)), And +End Sub + +Sub ERASEPIC (x, y, P As PICPAR) + ERASEIMG x, y, anim(P.sequence, img1) + P.frame +End Sub + +Sub FILLBGR (num) + n = anim(ani.bgrs, img1) + num + GETIMAGE n, w, h, idx + For y = 0 To f.h - 1 Step h + For x = 0 To f.w - 1 Step w + Put (x, y), graph(idx), PSet + Next + Next +End Sub + +Sub FILLMAZECELL (x, y, i, l, r, u, d) + If x < 0 Or y < 0 Or x > mazex - 1 Or y > mazey - 1 Then Exit Sub + x2 = x * 2 + y2 = y * 2 + If i <> OLD Then + Select Case i + Case mz.init: maze(x2, y2) = mz.filled + Case mz.filled: If maze(x2, y2) <> mz.empty And maze(x2, y2) <> mz.half Then maze(x2, y2) = i + Case mz.half: If maze(x2, y2) <> mz.empty Then maze(x2, y2) = i + Case mz.empty: maze(x2, y2) = i + End Select + End If + If l <> OLD Then + If x2 <> 0 Then maze(x2 - 1, y2) = l Else maze(x2 - 1, y2) = TRUE + End If + If r <> OLD Then + If x2 <> (mazex - 1) * 2 Then maze(x2 + 1, y2) = r Else maze(x2 + 1, y2) = TRUE + End If + If u <> OLD Then + If y2 <> 0 Then maze(x2, y2 - 1) = u Else maze(x2, y2 - 1) = TRUE + End If + If d <> OLD Then + If y2 <> (mazey - 1) * 2 Then maze(x2, y2 + 1) = d Else maze(x2, y2 + 1) = TRUE + End If +End Sub + +Sub GETCELLCOORDS (x, y, rx, ry) + rx = x * cellw + viewx + ry = y * cellh + viewy +End Sub + +Sub GETIMAGE (i, x, y, idx) + idx = img(i, pic) + Def Seg = VarSeg(graph(idx)) + x = Peek(VarPtr(graph(idx))) \ 2 + y = Peek(VarPtr(graph(idx)) + 2) + Def Seg +End Sub + +Sub GETINPUTS + Static cheat$, i$ + Static tch As TIMEINT + Static tctl As TIMEINT + tctl.interval = .045 + tch.interval = 1 + z$ = InKey$ + If z$ <> "" Then i$ = z$ + If gamestate <> gs.play Then i$ = "" + If z$ = Chr$(0) + Chr$(59) Then + If gamestate = gs.play Then + gamestate = gs.pause + SHOWHISCORE + gamestate = gs.play + End If + Else + Select Case z$ + Case Chr$(0) + Chr$(68): gamestate = gs.quit: gameresult = gr.abort + Case Chr$(0) + Chr$(63): gamestate = gs.newgame + Case Chr$(0) + Chr$(66): nosound = Not nosound + Case " " + GETMAZECELL digger.x, digger.y, dx, dy + SCANMAZECELL dx - 1, dy, l, 0, 0, 0, 0 + SCANMAZECELL dx + 1, dy, r, 0, 0, 0, 0 + SCANMAZECELL dx, dy - 1, u, 0, 0, 0, 0 + SCANMAZECELL dx, dy + 1, d, 0, 0, 0, 0 + l = (l = mz.empty) + d = (d = mz.empty) + u = (u = mz.empty) + r = (r = mz.empty) + IF (digger.mode = dgr.left AND digger.x > imgw AND l) OR (digger.mode = dgr.up AND digger.y > imgh AND u) OR (digger.mode = dgr.right AND digger.x < f.w - imgw * 2 AND r) OR (digger.mode = dgr.down AND digger.y < f.h - imgh * 2 AND d) THEN _ + + If digger.eye Then + digger.eye = FALSE + digger.teye.starttime = Timer + Select Case digger.mode + Case dgr.left: SHOOT -1, 0 + Case dgr.right: SHOOT 1, 0 + Case dgr.up: SHOOT 0, -1 + Case dgr.down: SHOOT 0, 1 + End Select + ERASEPIC digger.x, digger.y, digger.pic + digger.pic.sequence = digger.pic.sequence + anid.withouteye + DRAWPIC digger.x, digger.y, digger.pic, TRUE + End If + End If + End Select + End If + + If gamestate = gs.play And (z$ >= "a" And z$ <= "z") Or (z$ >= "0" And z$ <= "9") Then + tch.starttime = Timer + cheat$ = cheat$ + z$ + Select Case cheat$ + Case "afterlong": Locate 11, 20: Input " level"; li: curlevel = li: LOADLEVEL li: cheat$ = "": Exit Sub + Case "thecure": digger.lives = 9: cheat$ = "" + Case "nomercy": digger.teye.interval = 0: digger.eye = TRUE: cheat$ = "" + Case "nlev": NEXTLEVEL: cheat$ = "": Exit Sub + End Select + Else + If z$ <> "" Then + cheat$ = "" + ElseIf TEVENT(tch) Then + cheat$ = "" + End If + If TEVENT(tctl) And gamestate = gs.play Then + Select Case i$ + Case Chr$(0) + Chr$(72): MOVEDIGGER 0, -1 + Case Chr$(0) + Chr$(75): MOVEDIGGER -1, 0 + Case Chr$(0) + Chr$(80): MOVEDIGGER 0, 1 + Case Chr$(0) + Chr$(77): MOVEDIGGER 1, 0 + End Select + i$ = "" + If Not digger.eye Then + If TEVENT(digger.teye) Then + digger.eye = TRUE + ERASEPIC digger.x, digger.y, digger.pic + digger.pic.sequence = digger.pic.sequence - anid.withouteye + DRAWPIC digger.x, digger.y, digger.pic, TRUE + End If + End If + End If + End If +End Sub + +Function GETLEVIDX$ (num) + If levelpack$ = "" Then + GETLEVIDX$ = NUMTOSTR(levidx(num) + 0) + Else + GETLEVIDX$ = NUMTOSTR$(num + 0) + End If +End Function + +Sub GETMAZECELL (x, y, rx, ry) + If x - viewx < 0 Then + rx = -1 + Else + rx = (x - viewx) \ cellw + End If + If y - viewy < 0 Then + ry = -1 + Else + ry = (y - viewy) \ cellh + End If +End Sub + +Function GETPATH (sx, sy, tx, ty, PL) Static + Const x = 0, y = 1, size = mazex * mazey + Dim d(3, 1), wl(3) + Dim mzf(mazex, mazey) + Dim pp(size, 1, 0 To 1) + Dim bx(20), by(20) + + For i = 0 To mazex - 1 + For j = 0 To mazey - 1 + mzf(i, j) = 0 + Next + Next + + dc = 4 + d(0, x) = -1: d(0, y) = 0 + d(1, x) = 1: d(1, y) = 0 + d(2, x) = 0: d(2, y) = -1 + d(3, x) = 0: d(3, y) = 1 + + pf = 1 + pp(0, x, 0) = tx + pp(0, y, 0) = ty + pc1 = 1 + w = 0 + mzf(tx, ty) = w + 1 + For j = 1 To bagc: GETMAZECELL bag(j).x, bag(j).y, bx(j), by(j): Next + Do + w = w + 1 + If pf = 0 Then + pf = 1 + pf2 = 0 + Else + pf = 0 + pf2 = 1 + End If + pc = pc1 + pc1 = 0 + fw = FALSE + For i = 0 To pc - 1 + SCANMAZECELL pp(i, x, pf), pp(i, y, pf), 0, wl(0), wl(1), wl(2), wl(3) + For j = 1 To bagc + If bx(j) = pp(i, x, pf) And by(j) = pp(i, y, pf) Then + wl(2) = TRUE + wl(3) = TRUE + Exit For + End If + Next + For dr = 0 To dc - 1 + x1 = pp(i, x, pf) + d(dr, x) + y1 = pp(i, y, pf) + d(dr, y) + If x1 >= 0 And y1 >= 0 And x1 <= mazex - 1 And y1 <= mazey - 1 Then + If mzf(x1, y1) = 0 Then + SCANMAZECELL x1, y1, v, 0, 0, 0, 0 + If wl(dr) = FALSE And v = mz.empty Then + If x1 = sx And y1 = sy Then + Select Case dr + Case 0: dirc = 1 + Case 1: dirc = 0 + Case 2: dirc = 3 + Case 3: dirc = 2 + End Select + PL = w + GETPATH = dirc + GoTo exitfunc + End If + pp(pc1, x, pf2) = x1 + pp(pc1, y, pf2) = y1 + mzf(x1, y1) = w + 1 + pc1 = pc1 + 1 + End If + End If + End If + Next + Next + Loop Until pc1 = 0 + PL = -1 + GETPATH = -1 + GoTo exitfunc + exitfunc: + Exit Function + DRW: + Const cw = 5, ch = 5 + Const mvx = 639 - mazex * cw, mvy = 349 - mazey * ch + View (mvx, mvy)-(mvx + mazex * cw, mvy + mazey * ch) + For q = 0 To mazex - 1 + For j = 0 To mazey - 1 + Select Case mzf(q, j) + Case Is = 0: col = goldclr + Case Is <> 0: col = greenclr + End Select + Line (q * cw, j * ch)-Step(cw, ch), col, BF + Next + Next + RESTOREFIELD + Return +End Function + +Sub GETRANDOMCELL (dx, dy) + Do + dx = Int(Rnd * mazex) + dy = Int(Rnd * mazey) + SCANMAZECELL dx, dy, v, 0, 0, 0, 0 + Loop Until v = mz.empty +End Sub + +Function IMGSIZE (w, h) Static + size = (4 + Int((w * 8 + 7) \ 8) * h) \ 2 + 1 + IMGSIZE = size +End Function + +Sub INIT + Randomize Timer + Out &H60, &HF3: s! = Timer: Do: Loop While s! + .1 > Timer: Out &H60, 0 + Screen scrmode + _AllowFullScreen _SquarePixels , _Smooth + LOADLEVIDX + LOADGRAPHICS + LOADSCORES hiscorefile, hiscore() +End Sub + +Sub INITDIGGER + digger.dx = -1 + digger.pic.sequence = ani.dgrleft: digger.mode = dgr.left + digger.eye = TRUE + digger.x = digger.startx + digger.y = digger.starty +End Sub + +Sub LOADGRAPHICS + graphindex = 0 + animc = 0 + Restore DataGfx + For i = 1 To 30 + Read framecount + anim(animc, framec) = framecount + anim(animc, img1) = imgc + animc = animc + 1 + For f = 1 To framecount + LOADIMAGE w, h, index + Next + Next + bgrc = anim(ani.bgrs, framec) + curbgr = -1 + Cls +End Sub + +Sub LOADIMAGE (w, h, index) + + Read w, h + For y = 0 To h - 1 + Read B$ + For x = 0 To w - 1 + c = Asc(Mid$(B$, x + 1, 1)) - Asc("0") + c1 = 0 + Select Case c + Case 0: c = 0 + Case 1: c = greenclr + Case 2: c = redclr + Case 3: c = goldclr + Case 4: c = 0: c1 = maxcol + End Select + PSet (x, y), c + PSet (x + w, y), c1 + Next + Next + + index = imgc + + ' save image + img(imgc, pic) = graphindex + Get (0, 0)-(w - 1, h - 1), graph(graphindex) + graphindex = graphindex + IMGSIZE(w, h) + + ' save mask + img(imgc, mask) = graphindex + Get (0 + w, 0)-(w - 1 + w, h - 1), graph(graphindex) + graphindex = graphindex + IMGSIZE(w, h) + + imgc = imgc + 1 +End Sub + +Sub LOADLEVEL (levidx As Integer) + If Not OPENLEVEL(GETLEVIDX$(levidx)) Then + For i = 1 To digger.lives: ADDSCORE lifecost: Next + WINGAME + gameresult = gr.winner: gamestate = gs.quit + Else + eye.use = FALSE + + tim.nobbin = tim.s.nobbin + tim.nobbin = fnmax(tim.s.nobbin - levidx / 2, 10) + If tim.nobbin < tim.min.nobbin Then tim.nobbin = tim.min.nobbin + tim.hobbin = tim.s.hobbin + levidx * tim.d.hobbin: If tim.hobbin > tim.max.hobbin Then tim.hobbin = tim.max.hobbin + gamestate = gs.play + bonus.use = FALSE + emeraldc = 0 + bagc = 0 + goldc = 0 + enemyc = 0 + For i = 0 To mazex - 1 + For j = 0 To mazey - 1 + FILLMAZECELL i, j, mz.init, TRUE, TRUE, TRUE, TRUE + Next + Next + curbgr = (levidx - 1) Mod bgrc + FILLBGR curbgr + bonus.t.starttime = Timer + For y = 0 To 9 + s$ = READLEVELSTR$ + If Left$(s$, 1) = "_" Then + y = y - 1 + '' script '' + ' no additional commands. ' + Else + '' level_data '' + For x = 0 To 14 + ch$ = Mid$(s$, x + 1, 1) + Select Case ch$ + Case "#", " ": FILLMAZECELL x, y, mz.empty, TRUE, TRUE, TRUE, TRUE + Case "e": + nest.x = x + nest.y = y + GETCELLCOORDS x, y, bonus.x, bonus.y + bonus.use = FALSE + bonus.iwait = levidx * 5 + 30 + bonus.t.interval = bonus.iwait + bonus.ilen = 20 - levidx: If bonus.ilen < 3 Then bonus.ilen = 3 + nest.COUNT = levidx \ 3 + 2: If nest.COUNT > 5 Then nest.COUNT = 5 + FILLMAZECELL x, y, mz.empty, TRUE, TRUE, TRUE, TRUE + Case "d": + GETCELLCOORDS x, y, digger.startx, digger.starty + FILLMAZECELL x, y, mz.empty, FALSE, FALSE, TRUE, TRUE + Case "7": ADDOBJ newemerald, x, y + Case "$": ADDOBJ newbag, x, y + End Select + Next + End If + Next + bonusmode = FALSE + bonusscore = 0 + SETPAL pal.normal + CLOSELEVEL + For i = 0 To mazey - 1 + For j = 0 To mazex - 1 + SCANMAZECELL j, i, v, 0, 0, 0, 0 + SCANMAZECELL j - 1, i, l, 0, 0, 0, 0 + SCANMAZECELL j + 1, i, r, 0, 0, 0, 0 + SCANMAZECELL j, i - 1, u, 0, 0, 0, 0 + SCANMAZECELL j, i + 1, d, 0, 0, 0, 0 + If v = mz.empty Then + n = l + r + u + d + FILLMAZECELL j, i, mz.empty, (l = mz.filled), (r = mz.filled), (u = mz.filled), (d = mz.filled) + If r = mz.empty Or l = mz.empty Then FILLMAZECELL j, i, mz.empty, FALSE, FALSE, OLD, OLD + If n < -2 Then FILLMAZECELL j, i, mz.empty, FALSE, FALSE, FALSE, FALSE + End If + Next + Next + GETMAZECELL digger.startx, digger.starty, cx, cy + FILLMAZECELL cx, cy, mz.empty, FALSE, FALSE, OLD, OLD + GETMAZECELL bonus.x, bonus.y, cx, cy + FILLMAZECELL cx, cy, mz.empty, FALSE, FALSE, OLD, OLD + For i = 0 To mazey - 1 + For j = 0 To mazex - 1 + SCANMAZECELL j, i, v, 0, 0, 0, 0 + If v = mz.empty Then DRAWHOLE j, i + a$ = InKey$ + Next + Next + INITDIGGER + End If +End Sub + +Sub LOADLEVIDX + Restore DataLevidx + Read c + For i = 1 To c + Read levidx(i) + Next +End Sub + +Sub LOADSCORES (file$, scorebuf() As SCORETYPE) + Open hiscorefile$ For Binary As #1 + For i = 0 To hiscorec - 1 + Get #1, , hiscore(i) + Next + Close #1 +End Sub + +Sub MOVEBAGS + For i = bagc To 1 Step -1 + Select Case bag(i).mode + Case bagm.normal + GETMAZECELL bag(i).x, bag(i).y, mx, my + SCANMAZECELL mx, my + 1, f, 0, 0, 0, 0 + GETCELLCOORDS mx, my, bx, by + If f <> mz.filled And bag(i).x = bx And bag(i).y = by Then + bag(i).mode = bagm.swinging + bag(i).misc = 0 + FILLMAZECELL mx, my, mz.empty, OLD, OLD, OLD, FALSE + End If + Case bagm.swinging + ERASEPIC bag(i).x, bag(i).y, bag(i).pic + Select Case bag(i).misc Mod 3 + Case 0: bag(i).pic.sequence = ani.bagleft + Case 1: bag(i).pic.sequence = ani.bag + Case 2: bag(i).pic.sequence = ani.bagright + End Select + bag(i).misc = bag(i).misc + 1 + If bag(i).misc > 6 Then + bag(i).mode = bagm.falling + bag(i).pic.sequence = ani.bagfall + GETMAZECELL bag(i).x, bag(i).y, 0, bag(i).fally + For B = 0 To 4: DRAWIMG bag(i).x - 5, bag(i).y + 12 - B * diggerspeedy, iblob.up, FALSE: Next + End If + DRAWPIC bag(i).x, bag(i).y, bag(i).pic, TRUE + REDRAW bag(i).x, bag(i).y, emerald(), emeraldc + PLAYSOUND snd.bagswing + Case bagm.falling + 'erase bag and dig through soil under it. + ERASEPIC bag(i).x, bag(i).y, bag(i).pic + For B = 0 To 2 + DRAWIMG bag(i).x - 5, bag(i).y + 12 - B * diggerspeedy, iblob.up, FALSE + Next + + 'move bag + bag(i).y = bag(i).y + diggerspeedy * 2 + If BOXCOLL(digger.x, digger.y, imgw, imgh, bag(i).x, bag(i).y, imgw, imgh) Then + digger.mode = dgr.falling + ERASEPIC digger.x, digger.y, digger.pic + digger.pic.sequence = ani.dgrdie + digger.pic.frame = 0 + digger.x = bag(i).x + digger.y = bag(i).y + gamestate = gs.killed + End If + + 'check for landing + GETMAZECELL bag(i).x, bag(i).y, bx, by + SCANMAZECELL bx, by + 1, v, 0, 0, 0, 0 + FILLMAZECELL bx, by, mz.empty, OLD, OLD, 2 * (by = bag(i).fally), 2 * (v = mz.filled) + f = TRUE + If v = mz.filled Then + PLAYSOUND snd.baglanding + If digger.x = bag(i).x And digger.y = bag(i).y Then + PLAYSOUND snd.dead + digger.mode = dgr.dead + End If + If by - bag(i).fally > 1 Then + GETMAZECELL bag(i).x, bag(i).y, x, y + ADDOBJ newgold, x, y + f = FALSE + Else + bag(i).mode = bagm.normal + bag(i).pic.sequence = ani.bag + End If + End If + + 'check for enemy killing + For j = 1 To enemyc + If BOXCOLL(bag(i).x, bag(i).y, imgw, imgh, enemy(j).x, enemy(j).y, imgw, imgh) And enemy(j).mode <> enm.dead Then + ' if bag is falling, enemy is falling with it, else ... + If f And bag(i).mode <> bagm.normal Then + enemy(j).mode = enm.dying + ERASEPIC enemy(j).x, enemy(j).y, enemy(j).pic + enemy(j).y = bag(i).y + enemy(j).x = bag(i).x ' <== if not, enemy can corrupt ground + If enemy(j).mode = enm.nobbin Then + enemy(j).pic.sequence = ani.nobbindie + ElseIf enemy(j).mode = enm.hobbin Then + enemy(j).pic.sequence = enm.nobbin + End If + enemy(j).pic.frame = 0 + DRAWPIC enemy(j).x, enemy(j).y, enemy(j).pic, TRUE + Else + ' ... else enemy is dead + enemy(j).mode = enm.dead + enemy(j).tdead.starttime = Timer: enemy(j).tdead.interval = .5 + ERASEPIC enemy(j).x, enemy(j).y, enemy(j).pic + enemy(j).y = bag(i).y + End If + End If + Next + + If f Then + DRAWPIC digger.x, digger.y, digger.pic, TRUE + DRAWPIC bag(i).x, bag(i).y, bag(i).pic, FALSE + REDRAW bag(i).x, bag(i).y, emerald(), emeraldc + Else + Swap bag(i), bag(bagc) + bagc = bagc - 1 + MOVEGOLD + End If + Case bagm.left, bagm.right + moveit = TRUE + If bag(i).mode = bagm.left Then dx = -diggerspeedx Else dx = diggerspeedx + ERASEPIC bag(i).x, bag(i).y, bag(i).pic + + ' if collides to digger or enemy, don't move + If BOXCOLL(bag(i).x + dx, bag(i).y, cellw, cellh, digger.x, digger.y, imgw, imgh) And digger.x * Sgn(dx) > (bag(i).x + dx) * Sgn(dx) Then moveit = FALSE + For j = 1 To enemyc + If BOXCOLL(bag(i).x + dx, bag(i).y, cellw, cellh, enemy(j).x, enemy(j).y, imgw, imgh) And enemy(j).mode <> bagm.dead Then moveit = FALSE + Next + + If moveit = TRUE Then + If dx > 0 Then For j = 0 To 10 Step diggerspeedx: DRAWIMG bag(i).x - j + 3, bag(i).y - 1, iblob.left, FALSE: Next Else For j = 0 To 10 Step diggerspeedx: DRAWIMG bag(i).x + imgw - 8 - j + 3, bag(i).y - 1, iblob.right, FALSE: Next + bag(i).x = bag(i).x + dx + + ' check whether shift has been done + GETMAZECELL bag(i).x, bag(i).y, bgx, bgy + GETCELLCOORDS bgx, bgy, bgx0, bgy0 + If bag(i).x = bgx0 Then + bag(i).mode = bagm.normal + bag(i).pic.sequence = ani.bag + SCANMAZECELL bgx, bgy + 1, v, 0, 0, 0, 0 + FILLMAZECELL bgx, bgy, FALSE, (Not (dx > 0)) * 2, (Not (dx < 0)) * 2, OLD, OLD + If v <> mz.filled Then + bag(i).mode = bagm.falling + bag(i).fally = bgy + End If + End If + DRAWPIC bag(i).x, bag(i).y, bag(i).pic, FALSE + REDRAW bag(i).x - dx, bag(i).y, emerald(), emeraldc + REDRAW bag(i).x, bag(i).y, emerald(), emeraldc + PLAYSOUND snd.bagshift + Else + If bag(i).mode = bagm.left Then + bag(i).mode = bagm.right + bag(i).pic.sequence = ani.bagright + Else + bag(i).mode = bagm.left + bag(i).pic.sequence = ani.bagleft + End If + DRAWPIC bag(i).x, bag(i).y, bag(i).pic, FALSE + REDRAW bag(i).x, bag(i).y, emerald(), emeraldc + End If + End Select + Next +End Sub + +Sub MOVEDIGGER (dx, dy) + ' *** check for out of bounds *** ' + PLAYSOUND snd.dig + newx = digger.x + diggerspeedx * dx + newy = digger.y + diggerspeedy * dy + GETMAZECELL newx, newy, nx, ny + GETCELLCOORDS nx, ny, n1x, n1y + If nx < 0 Or ny < 0 Or ((nx >= mazex - 1 And newx <> n1x And dx > 0) Or (ny >= mazey - 1 And newy <> n1y And dy > 0)) Then Exit Sub + + ' *** adjust for maze cells *** ' + If ((n1y <> newy And dx <> 0) Or (n1x <> newx And dy <> 0)) And (dx <> digger.dx Or dy <> digger.dy) Then + ' *** if not in cell, move it in currently used direction + dx = digger.dx + dy = digger.dy + amode = digger.pic.sequence + Else + ' *** if in cell, change direction *** ' + If dx < 0 Then digger.mode = dgr.left: amode = ani.dgrleft + If dx > 0 Then digger.mode = dgr.right: amode = ani.dgrright + If dy < 0 Then digger.mode = dgr.up: amode = ani.dgrup + If dy > 0 Then digger.mode = dgr.down: amode = ani.dgrdown + If Not digger.eye Then amode = amode + anid.withouteye + End If + + ' *** calculate new position *** ' + newx = digger.x + diggerspeedx * dx + newy = digger.y + diggerspeedy * dy + + ' *** check gold bags *** ' + If CHECKBAGSHIFT(newx, newy, dx) Then Exit Sub + + digger.dx = dx + digger.dy = dy + + ' *** adjust maze *** ' + GETMAZECELL newx - 1, newy, clx, cy + GETMAZECELL newx, newy - 1, cx, cuy + GETMAZECELL digger.x - 1, digger.y, olx, oy + GETMAZECELL digger.x, digger.y - 1, ox, ouy + If dx < 0 Then + If clx <> olx Then FILLMAZECELL clx + 1, cy, mz.empty, FALSE, OLD, OLD, OLD + SCANMAZECELL clx, cy, v, 0, 0, 0, 0 + FILLMAZECELL clx, cy, (2 * (olx <> clx) + 1) * mz.half * Abs(v), OLD, FALSE, OLD, OLD + End If + If dx > 0 Then + If ox <> cx Then FILLMAZECELL cx, cy, mz.empty, OLD, FALSE, OLD, OLD + SCANMAZECELL cx + 1, cy, v, 0, 0, 0, 0 + FILLMAZECELL cx + 1, cy, (2 * (ox <> cx) + 1) * mz.half * Abs(v), FALSE, OLD, OLD, OLD + End If + If dy < 0 Then + If cuy <> ouy Then FILLMAZECELL cx, cuy + 1, mz.empty, OLD, OLD, FALSE, OLD + SCANMAZECELL cx, cuy, v, 0, 0, 0, 0 + FILLMAZECELL cx, cuy, (2 * (ouy <> cuy) + 1) * mz.half * Abs(v), OLD, OLD, OLD, FALSE + End If + If dy > 0 Then + If cy <> oy Then FILLMAZECELL cx, cy, mz.empty, OLD, OLD, OLD, FALSE + SCANMAZECELL cx, cy + 1, v, 0, 0, 0, 0 + FILLMAZECELL cx, cy + 1, (2 * (oy <> cy) + 1) * mz.half * Abs(v), OLD, OLD, FALSE, OLD + End If + 'DRAWMAZE + + ' *** dig through the ground *** ' + Select Case digger.mode + Case dgr.left: DRAWIMG newx - 5, newy - 1, iblob.left, FALSE + Case dgr.right: DRAWIMG newx + 10 + 1, newy - 1, iblob.right, FALSE + Case dgr.up: DRAWIMG newx - 5, newy - 3, iblob.up, FALSE + Case dgr.down: DRAWIMG newx - 5, newy + 12, iblob.down, FALSE + End Select + + ERASEPIC digger.x, digger.y, digger.pic + digger.x = newx + digger.y = newy + digger.pic.sequence = amode + DRAWPIC digger.x, digger.y, digger.pic, TRUE + + CHECKEMERALDS digger.x, digger.y, TRUE + CHECKGOLD digger.x, digger.y, TRUE +End Sub + +Sub MOVEENEMIES + Dim w(3) + Dim delta(3, 1) + Const xd = 0, yd = 1 + delta(0, xd) = -1 + delta(1, xd) = 1 + delta(2, yd) = -1 + delta(3, yd) = 1 + For i = enemyc To 1 Step -1 + If (enemy(i).stpx = enemy(i).x And enemy(i).stpy = enemy(i).y) And gamestate = gs.play And enemy(i).mode <> enm.dying Then + If TEVENT(enemy(i).thob) Then + enemy(i).thob.starttime = Timer + If Not bonusmode Then + If enemy(i).mode = enm.nobbin Then + ERASEPIC enemy(i).x, enemy(i).y, enemy(i).pic + enemy(i).pic.sequence = ani.hobbinleft + enemy(i).pic.frame = 0 + enemy(i).mode = enm.hobbin + enemy(i).chaseflee = TRUE + enemy(i).thob.interval = tim.hobbin + Else + ERASEPIC enemy(i).x, enemy(i).y, enemy(i).pic + enemy(i).pic.sequence = ani.nobbin + enemy(i).pic.frame = 0 + enemy(i).mode = enm.nobbin + enemy(i).thob.interval = tim.nobbin + End If + End If + End If + GETMAZECELL enemy(i).x, enemy(i).y, cx, cy + If enemy(i).mode = enm.nobbin Then + If Int(Rnd * 1000) < 70 Or (cx = enemy(i).trgx And cy = enemy(i).trgy) Or enemy(i).chaseflee = TRUE Then + If Int(Rnd * 100) < (20 + 15 * (enemy(i).chaseflee = TRUE)) And Not bonusmode Then + enemy(i).chaseflee = FALSE + GETRANDOMCELL dx, dy + enemy(i).trgx = dx + enemy(i).trgy = dy + Else + enemy(i).chaseflee = TRUE + GETMAZECELL digger.x, digger.y, dx, dy + If bonusmode Then + temp = GETPATH(cx, cy, dx, dy, pl0) + If pl0 <> -1 Then + SCANMAZECELL cx, cy, 0, w(0), w(1), w(2), w(3) + f = FALSE + Do + For j = 0 To 3 + If w(j) = FALSE Then + SCANMAZECELL cx + delta(j, xd), cy + delta(j, yd), v, 0, 0, 0, 0 + If v = mz.empty Then + temp = GETPATH(dx, dy, cx + delta(j, xd), cy + delta(j, yd), PL) + If PL > pl0 Then + If Int(Rnd * 3) = 0 Then + dx = cx + delta(j, xd) + dy = cy + delta(j, yd) + Exit Do + End If + f = TRUE + End If + End If + End If + Next ' j + If Not f Then + enemy(i).trgx = cx + enemy(i).trgy = cy + Exit Do + End If + Loop + Else + GETRANDOMCELL dx, dy + enemy(i).trgx = dx + enemy(i).trgy = dy + enemy(i).chaseflee = FALSE + End If + Else + enemy(i).chaseflee = TRUE + End If + End If + End If + FILLMAZECELL cx, cy, mz.empty, OLD, OLD, OLD, OLD + SCANMAZECELL dx, dy, v, 0, 0, 0, 0 + Do + If enemy(i).chaseflee = TRUE Then + If v <> mz.empty Then + If digger.dx <> 0 Then + dx = dx + 1 + ElseIf digger.dy <> 0 Then + dy = dy + 1 + End If + End If + + r = GETPATH(cx, cy, dx, dy, 0) + enemy(i).trgx = dx + enemy(i).trgy = dy + Else + r = GETPATH(cx, cy, enemy(i).trgx, enemy(i).trgy, 0) + End If + If r = -1 Then + GETRANDOMCELL dx, dy + enemy(i).chaseflee = FALSE + enemy(i).trgx = dx + enemy(i).trgy = dy + Else + Exit Do + End If + Loop + Select Case r + Case 0: cx = cx - 1 + Case 1: cx = cx + 1 + Case 2: cy = cy - 1 + Case 3: cy = cy + 1 + End Select + ElseIf enemy(i).mode = enm.hobbin Then ' it's hobbin + d = enemy(i).dir + FILLMAZECELL cx, cy, FALSE, (d <> 1) * 2, (d <> 2) * 2, (d <> 3) * 2, (d <> 4) * 2 + Do + enemy(i).chaseflee = Int(Rnd * 200) < 20 - 160 * enemy(i).chaseflee + If enemy(i).chaseflee = TRUE Then + rx = Abs(digger.x - enemy(i).x) + ry = Abs(digger.y - enemy(i).y) + btime! = Timer + Do + enemy(i).dir = Int(Rnd * 4) + 1 + Select Case enemy(i).dir + Case 1, 2: + If Not ((enemy(i).dir = 1 And cx = 0) Or (enemy(i).dir = 2 And cx = mazex - 1)) Then + If (Abs(digger.x - (enemy(i).x - ((enemy(i).dir = 2) * 2 + 1) * diggerspeedx)) - rx) * Sgn(bonusmode * 2 + 1) < 0 Then Exit Do + End If + Case 3, 4: + If Not ((enemy(i).dir = 3 And cy = 0) Or (enemy(i).dir = 4 And cy = mazey - 1)) Then + If (Abs(digger.y - (enemy(i).y - ((enemy(i).dir = 4) * 2 + 1) * diggerspeedy)) - ry) * Sgn(bonusmode * 2 + 1) < 0 Then Exit Do + End If + End Select + If btime! + .1 < Timer Then + enemy(i).chaseflee = FALSE + Exit Do + End If + Loop + Else + If enemy(i).dir = 0 Or Int(Rnd * 5) = 2 Then enemy(i).dir = Int(Rnd * 4) + 1 + End If + Select Case enemy(i).dir + Case 1: If cx = 0 Then enemy(i).dir = 0 Else cx = cx - 1 + Case 2: If cx = mazex - 1 Then enemy(i).dir = 0 Else cx = cx + 1 + Case 3: If cy = 0 Then enemy(i).dir = 0 Else cy = cy - 1 + Case 4: If cy = mazey - 1 Then enemy(i).dir = 0 Else cy = cy + 1 + End Select + d = enemy(i).dir + FILLMAZECELL cx, cy, OLD, (d <> 2) * 2, (d <> 1) * 2, (d <> 4) * 2, (d <> 3) * 2 + Loop Until enemy(i).dir <> 0 + End If + GETCELLCOORDS cx, cy, enemy(i).stpx, enemy(i).stpy + End If + If enemy(i).mode = enm.dead Then + If TEVENT(enemy(i).tdead) Then + ERASEPIC enemy(i).x, enemy(i).y, enemy(i).pic + REDRAWOBJS gold(), goldc, FALSE + REDRAWOBJS bag(), bagc, FALSE + Swap enemy(i), enemy(enemyc) + enemyc = enemyc - 1 + ADDSCORE monstercost + Else + DRAWPIC enemy(i).x, enemy(i).y, enemy(i).pic, FALSE + REDRAWOBJS gold(), goldc, FALSE + End If + Else + If enemy(i).mode <> enm.dying And enemy(i).mode <> enm.dead Then + nx = enemy(i).x + diggerspeedx * Sgn(enemy(i).stpx - enemy(i).x) + ny = enemy(i).y + diggerspeedy * Sgn(enemy(i).stpy - enemy(i).y) + ERASEPIC enemy(i).x - 1, enemy(i).y, enemy(i).pic + If enemy(i).mode = enm.hobbin Or Not CHECKBAGSHIFT(nx, ny, Sgn(enemy(i).stpx - enemy(i).x)) Then + If enemy(i).mode = enm.hobbin Then + For j = bagc To 1 Step -1 + If bag(j).mode <> bagm.falling And BOXCOLL(nx, ny, imgw, imgh, bag(j).x + 1, bag(j).y + 1, imgw - 2, imgh - 2) Then + ERASEPIC bag(j).x, bag(j).y, bag(j).pic + Swap bag(bagc), bag(j) + bagc = bagc - 1 + End If + Next + Select Case enemy(i).dir + Case 1: DRAWIMG nx - 5, ny - 1, iblob.left, FALSE + Case 2: DRAWIMG nx + 10 + 1, ny - 1, iblob.right, FALSE + Case 3: DRAWIMG nx - 5, ny - 3, iblob.up, FALSE + Case 4: DRAWIMG nx - 5, ny + 12, iblob.down, FALSE + End Select + If nx < enemy(i).x Then enemy(i).pic.sequence = ani.hobbinleft + If nx > enemy(i).x Then enemy(i).pic.sequence = ani.hobbinright + End If + CHECKGOLD nx, ny, FALSE + CHECKEMERALDS nx, ny, FALSE + enemy(i).x = nx + enemy(i).y = ny + ANIMATE enemy(i).x, enemy(i).y, enemy(i).pic, FALSE + End If + DRAWPIC enemy(i).x - 1, enemy(i).y, enemy(i).pic, FALSE + End If + End If + Next +End Sub + +Sub MOVEEYE + ERASEPIC eye.x, eye.y, eye.pic + REDRAW eye.x, eye.y, bag(), bagc + REDRAW eye.x, eye.y, emerald(), emeraldc + REDRAW eye.x, eye.y, gold(), goldc + ANIMATE eye.x, eye.y, eye.pic, FALSE + If eye.mode = eyem.normal Then + eye.x = eye.x + eye.dx * diggerspeedx * 2 + eye.y = eye.y + eye.dy * diggerspeedy * 2 + For i = enemyc To 1 Step -1 + If BOXCOLL(enemy(i).x, enemy(i).y, imgw, imgh, eye.x, eye.y, eyew, eyeh) Then + ERASEPIC enemy(i).x - 1, enemy(i).y, enemy(i).pic + eye.pic.sequence = ani.expl + eye.pic.frame = 0 + eye.mode = eyem.expl + ADDSCORE monstercost + Swap enemy(i), enemy(enemyc) + enemyc = enemyc - 1 + PLAYSOUND snd.hit + PLAYSOUND snd.killenemy + Exit For + End If + Next + GETMAZECELL eye.x - (eye.dx > 0) * (diggerspeedx + eyew + 5), eye.y - (eye.dy > 0) * (diggerspeedy + eyeh + 5), x, y + SCANMAZECELL x, y, i, 0, 0, 0, 0 + If i = mz.filled Then + PLAYSOUND snd.hit + eye.pic.sequence = ani.expl + eye.pic.frame = 0 + eye.mode = eyem.expl + End If + Else + If eye.pic.frame = anim(ani.expl, framec) - 1 Then eye.use = FALSE + End If + If eye.use Then DRAWPIC eye.x, eye.y, eye.pic, FALSE +End Sub + +Sub MOVEGOLD + For i = goldc To 1 Step -1 + If gold(i).pic.frame <> 2 Then + ANIMATE gold(i).x, gold(i).y, gold(i).pic, TRUE + REDRAW gold(i).x, gold(i).y, bag(), bagc + DRAWPIC gold(i).x, gold(i).y, gold(i).pic, FALSE + REDRAW gold(i).x, gold(i).y, emerald(), emeraldc + End If + GETMAZECELL gold(i).x, gold(i).y, x, y + SCANMAZECELL x, y + 1, v, 0, 0, 0, 0 + If v <> mz.filled Then gold(i).t.interval = 5 + If TEVENT(gold(i).t) Then + ERASEPIC gold(i).x, gold(i).y, gold(i).pic + REDRAW gold(i).x, gold(i).y, bag(), bagc + REDRAW gold(i).x, gold(i).y, emerald(), emeraldc + Swap gold(i), gold(goldc) + goldc = goldc - 1 + End If + Next +End Sub + +Sub NEWGAME + Dim tbags As TIMEINT + Dim tstat As TIMEINT + Dim tdgra As TIMEINT + Dim tgold As TIMEINT + Dim tbon As TIMEINT + Dim tenem As TIMEINT + Dim teani As TIMEINT + Dim tenew As TIMEINT + RESTOREFIELD + gameresult = 0 + tbon.interval = .1 + tbags.interval = .1 + tstat.interval = .05 + tdgra.interval = .08 + tgold.interval = .1 + tcons.interval = 1 + tenem.interval = .045 + teani.interval = .1 + tenew.interval = 3 + tim.eye = 1 + digger.lives = 0 + digger.score = 0 + digger.teye.interval = tim.eye + NEXTLEVEL + Do + ADDSCORE 0 + GETINPUTS + If gamestate = gs.newgame Or gamestate = gs.quit Then Exit Sub + If gamestate <> gs.killed Then + If emeraldc = 0 Then + NEXTLEVEL + If gamestate = gs.quit Then Exit Sub + End If + If bonusmode Then + s! = (bonus.t.interval - (Timer - bonus.t.starttime)) * 2 + If s! < 9 And Abs(Int(s!) - s!) < .2 Then SETPAL s! Mod 2 + End If + If TEVENT(tenew) Then + If enemyc < nest.COUNT And Not bonusmode Then ADDOBJ newnobbin, nest.x, nest.y + 'REDRAWOBJS emerald(), emerc, FALSE + End If + tenem.interval = .045 + If TEVENT(tenem) Then + MOVEENEMIES + If eye.use Then MOVEEYE + CHECKKILL + End If + If TEVENT(bonus.t) Then + If bonusmode Then + bonusmode = FALSE + SETPAL pal.normal + bonus.t.starttime = Timer + bonus.iwait = bonus.iwait + 5 + bonus.t.interval = bonus.iwait + Else + bonus.t.interval = bonus.ilen + bonus.t.starttime = Timer + bonus.use = TRUE + End If + End If + If TEVENT(tbon) Then CHECKBONUS digger.x, digger.y, TRUE + If TEVENT(tcons) Then consemer = 0 ' <== remove emerald octave + Else + tdgra.interval = .14 + If digger.pic.frame = anim(ani.dgrdie, framec) - 1 Then + If Not RESTART Then Exit Sub + tdgra.interval = .08 + End If + End If + If TEVENT(tgold) Then + MOVEGOLD + If gamestate <> gs.play Then DRAWPIC digger.x, digger.y, digger.pic, FALSE + End If + If TEVENT(tbags) Then MOVEBAGS + If TEVENT(tstat) Then + SHOWSCORE digger.score, digger.lives + End If + If TEVENT(tdgra) And digger.mode <> dgr.falling Then + ANIMATE digger.x, digger.y, digger.pic, TRUE + End If + Loop +End Sub + +Sub NEXTLEVEL + curlevel = curlevel + 1 + LOADLEVEL curlevel +End Sub + +Function NUMTOSTR$ (n As Long) + NUMTOSTR = LTrim$(RTrim$(Str$(n))) +End Function + +Function OPENLEVEL (idx$) + If levelpack$ = "" Then + Restore DataLevels + Do + Read s$ + s$ = LTrim$(RTrim$(s$)) + If s$ = "_end" Then + OPENLEVEL = FALSE + Exit Function + End If + Loop Until s$ = "_mine #" + idx$ + OPENLEVEL = TRUE + Else + 'read from file + Open levelpack$ For Input As #1 + Do + Line Input #1, s$ + s$ = LTrim$(RTrim$(s$)) + If s$ = "_end" Then + OPENLEVEL = FALSE + Close #1 + Exit Function + End If + Loop Until s$ = "_mine #" + idx$ + OPENLEVEL = TRUE + End If +End Function + +Sub PLAYSOUND (sndcode) + If nosound Then Exit Sub + Select Case sndcode + 'CASE snd.dig: SOUND 37, RND * .03 + .01 + Case snd.killenemy: For i = 85 To 100: Sound ((i - 84) ^ 3) / 40 + 37 + (i Mod 3) * 40, i / 400: Next + Case snd.shoot: Sound 1000 + Rnd * 1000 + 37, .3 + Case snd.hit: Sound Rnd * 1000 + 237, Rnd * .04 + .04 + Case snd.dead: For j = 0 To 14: Sound Abs(Sin(j / 5)) * 2700 + 37, .21: Next + Case snd.bagshift: Sound Rnd * 100 + 37, Rnd * .04 + .04 + Case snd.baglanding: For j = 1 To 10: Sound Rnd * 200 + 40, Rnd * .17: Next + Case snd.emerald: a = Rnd * 1400: For i = 1 To 70: Sound i + 37 + (i Mod 3) * 100 + 8000 + a, i / 2800: Next + Case snd.gold: a = 30: For i = 1 To 10: a = a * 1.5: Sound a + Rnd * 200 + 400, .1: Next + End Select +End Sub + +Sub QUIT + Screen 0 + Width 80, 25 + Print "QDigger v1.4b, 2002-2008" + Print "Better luck next time!" + End +End Sub + +Function READLEVELSTR$ + If levelpack$ = "" Then + Read s$ + READLEVELSTR$ = s$ + Else + Line Input #1, s$ + READLEVELSTR$ = s$ + End If +End Function + +Sub REDRAW (x, y, obj() As PICKUPTYPE, objc) + For j = 1 To objc + If BOXCOLL(x, y, cellw, cellh, obj(j).x, obj(j).y, imgw, imgh) Then + DRAWPIC obj(j).x, obj(j).y, obj(j).pic, FALSE + Exit Sub + End If + Next +End Sub + +Sub REDRAWOBJS (arr() As PICKUPTYPE, n, maskfl) + For i = 1 To n + DRAWPIC arr(i).x, arr(i).y, arr(i).pic, Not maskfl + Next +End Sub + +Function RESTART + DELAY 1 + While InKey$ <> "": Wend + digger.lives = digger.lives - 1 + If digger.lives < 0 Then + digger.lives = 0 + RESTART = FALSE + gameresult = gr.gameover + Exit Function + End If + If bonus.use = FALSE Then bonus.t.starttime = Timer + For i = 1 To enemyc + ERASEPIC enemy(i).x, enemy(i).y, enemy(i).pic + Next + For i = bagc To 1 Step -1 + If bag(i).mode = bagm.falling Then + ERASEPIC bag(i).x, bag(i).y, bag(i).pic + Swap bag(i), bag(bagc) + bagc = bagc - 1 + End If + Next + enemyc = 0 + If eye.use Then + ERASEPIC eye.x, eye.y, eye.pic + eye.use = FALSE + End If + ERASEPIC digger.x, digger.y, digger.pic + INITDIGGER + gamestate = gs.play + REDRAWOBJS gold(), goldc, TRUE + REDRAWOBJS bag(), bagc, TRUE + REDRAWOBJS emerald(), emeraldc, TRUE + While Len(InKey$) <> 0: Wend + RESTART = TRUE +End Function + +Sub RESTOREFIELD + View (f.x, f.y)-(f.x + f.w - 1, f.y + f.h - 1) +End Sub + +Sub SCANMAZECELL (cx, cy, inner, lw, rw, uw, dw) + cx2 = cx * 2 + cy2 = cy * 2 + If cx < 0 Or cy < 0 Or cx > mazex - 1 Or cy > mazey - 1 Then + inner = mz.filled + lw = TRUE + rw = TRUE + uw = TRUE + dw = TRUE + Else + inner = maze(cx2, cy2) + lw = maze(cx2 - 1, cy2) + rw = maze(cx2 + 1, cy2) + uw = maze(cx2, cy2 - 1) + dw = maze(cx2, cy2 + 1) + End If +End Sub + +Sub SETPAL (palmode As Integer) + Select Case palmode + Case pal.normal: Color , 0 + Case pal.bonus: Color , 1 + End Select +End Sub + +' +' this function checks whether bag #num can be moved in (dir) direction. +' can't move (FALSE) if: +' bag's direction (dir) = 0 +' bag is on the end of the maze +' bag collides with the digger or an enemy +' else +' accept (TRUE); change bag mode and params +' +Function SHIFTBAG (num, dir) + If dir = 0 Then SHIFTBAG = FALSE: Exit Function + + GETMAZECELL bag(num).x, bag(num).y, bx, by + If bx = 0 Or bx = mazex - 1 Then SHIFTBAG = FALSE: Exit Function + + If BOXCOLL(bag(num).x + dir, bag(num).y, cellw, cellh, digger.x, digger.y, imgw, imgh) Then SHIFTBAG = FALSE: Exit Function + For i = 1 To bagc + If i <> num Then + If BOXCOLL(bag(num).x + dir, bag(num).y, cellw, cellh, bag(i).x, bag(i).y, cellw - 1, imgh) And bag(i).mode = bagm.normal And bag(num).x * Sgn(dir) < bag(i).x * Sgn(dir) Then + If SHIFTBAG(i, dir) = FALSE Then SHIFTBAG = FALSE: Exit Function + End If + End If + Next + + SHIFTBAG = TRUE + GETMAZECELL bag(num).x, bag(num).y, cx, cy + FILLMAZECELL cx, cy, FALSE, OLD, OLD, OLD, OLD + If dir < 0 Then + bag(num).mode = bagm.left + bag(num).pic.sequence = ani.bagleft + GETCELLCOORDS bx, by, x, y + If x = bag(num).x And y = bag(num).y Then d = 1 Else d = 0 + GETCELLCOORDS bx - d, by, bag(num).dx, 0 + Else + bag(num).mode = bagm.right + bag(num).pic.sequence = ani.bagright + GETCELLCOORDS bx + 1, by, bag(num).dx, 0 + End If +End Function + +Sub SHOOT (dx, dy) + If eye.use Then Exit Sub + eye.x = digger.x - 5 * (dx = 0 And dy < 0) - imgw * (dx > 0) + eyew * (dx < 0) + eye.y = digger.y - 2 * (dy = 0) - imgh * (dy > 0) + eyeh * (dy < 0) + eye.dx = dx + eye.dy = dy + eye.use = TRUE + eye.mode = eyem.normal + eye.pic.sequence = ani.fire + eye.pic.frame = 0 + PLAYSOUND snd.shoot +End Sub + +Sub SHOWHISCORE + cw = 8: ch = 14 + Dim buf(IMGSIZE(cw * 22 + 1 + 16 + 8 + 16 + 8, 117 + 16 + 8)) + View + Get (cw * 10 - 16 - 8 - 8, 45 - 16)-(cw * 10 - 16 - 8 - 8 + cw * 22 + 1 + 16 + 8 + 16 + 8, 45 - 16 + 117 + 16 + 8), buf() + Line (cw * 10 - 16 - 8 - 8, 45 - 16)-Step(cw * 22 + 1 + 16 + 8 + 16 + 8, 117 + 16 + 8), 0, BF + Line (cw * 10 - 16 - 8 - 8 + 2, 45 + 2 - 16)-Step(cw * 22 + 8 + 1 + 16 + 16 + 8 - 4, 117 + 16 - 4 + 8), 1, B + Line (127 - 16, 64 - 8)-Step(87, 0), 2 + Locate 7, 15: Print "HIGH SCORES" + For i = 0 To hiscorec - 1 + If Left$(hiscore(i).uname, 1) = Chr$(0) And hiscore(i).score = 0 Then Exit For + Locate 10 + i, 11: Print hiscore(i).uname; " "; NUMTOSTR$(hiscore(i).score) + Next + While InKey$ <> "": Wend + While InKey$ = "": Wend + Put (cw * 10 - 16 - 8 - 8, 45 - 16), buf(), PSet + RESTOREFIELD +End Sub + +Sub SHOWSCORE (score As Long, lives As Integer) + Dim ind(1 To 8) As Integer + Dim im(0 To 10, 0 To 2) As Integer + a$ = LTrim$(RTrim$(Str$(score))) + a$ = String$(7 - Len(a$), "0") + a$ + For i = 1 To Len(a$) + ind(i) = Asc(Mid$(a$, i, 1)) - Asc("0") + img0 + Next + indc = Len(a$) + + For i = 0 To 10 + GETIMAGE anim(ani.stat, img1) + i, im(i, 1), im(i, 2), im(i, 0) + Next + + View (0, 0)-(f.w + f.x - 1, 14) + x = f.x + For i = 1 To indc + Put (x, 0), graph(im(ind(i), 0)), PSet + x = x + im(ind(i), 1) + 3 + Next + View (7 * 15 + f.x + 2, 0)-(319, 13) + GETIMAGE anim(ani.stat, img1) + 10, w, 0, idx + For i = 0 To lives - 1 + Put (i * (w + 5), 0), graph(idx), PSet + Next + Line (lives * (w + 5), 0)-Step(w * 2, 11), 0, BF + RESTOREFIELD +End Sub + +Function TEVENT (t As TIMEINT) + Dim tmr As Single + tmr = Timer + If tmr >= t.starttime + t.interval Or Abs(tmr - t.starttime) > 10000 Then + t.starttime = Timer + TEVENT = TRUE + Else + TEVENT = FALSE + End If +End Function + +Sub UPDATESCORES + Open hiscorefile$ For Binary Access Write As #1 + Seek #1, 1 + For i = 0 To hiscorec - 1 + Put #1, , hiscore(i) + Next + Close #1 + LOADSCORES hiscorefile, hiscore() +End Sub + +Sub WINGAME + View + ww = 200 - 2: wh = 65: wx = (320 - ww) / 2 + 9: wy = (200 - wh) / 2 - 2 + Line (wx, wy)-Step(ww, wh), 0, BF + Line (wx + 1, wy + 1)-Step(ww - 2, wh - 2), 3, B + Line (wx + 1, wy + 1)-Step(ww - 2, wh - 2), 2, B , &HAAAF + Locate 12, 17: Print "WELL DONE!" + Locate 14, 13: Print "you win the game!!" + While i$ <> Chr$(13) And i$ <> " ": i$ = InKey$: Wend +End Sub + +Function fnmax (x, y) + If x > y Then fnmax = x Else fnmax = y +End Function + diff --git a/samples/qdigger/src/qdigger.zip b/samples/qdigger/src/qdigger.zip new file mode 100644 index 00000000..5434a3a4 Binary files /dev/null and b/samples/qdigger/src/qdigger.zip differ diff --git a/samples/qmaze/img/screenshot.png b/samples/qmaze/img/screenshot.png new file mode 100644 index 00000000..b93a3e09 Binary files /dev/null and b/samples/qmaze/img/screenshot.png differ diff --git a/samples/qmaze/index.md b/samples/qmaze/index.md new file mode 100644 index 00000000..cecbe1dd --- /dev/null +++ b/samples/qmaze/index.md @@ -0,0 +1,21 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QMAZE + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Maze puzzle game by Microsoft. +``` + +### File(s) + +* [qmaze.bas](src/qmaze.bas) + +🔗 [game](../game.md), [maze](../maze.md) diff --git a/samples/qmaze/src/qmaze.bas b/samples/qmaze/src/qmaze.bas new file mode 100644 index 00000000..920cdd72 --- /dev/null +++ b/samples/qmaze/src/qmaze.bas @@ -0,0 +1,1902 @@ +' QMAZE.BAS +' +' Copyright (C) 1990 Microsoft Corporation. All Rights Reserved. +' +' Race through a maze that pits your skill against the clock, or a friend. +' The object is to finish the maze before time runs out or before your +' opponent finishes. +' +' To run this game, press Shift+F5. +' +' To exit this program, press Alt, F, X. +' +' To get help on a BASIC keyword, move the cursor to the keyword and press +' F1 or click the right mouse button. +' +' To view suggestions on changing this game, press Page Down. +' +' +' Suggested Changes +' ----------------- +' +' There are many ways that you can modify this BASIC game. The CONST +' statements below these comments and the DATA statements at the end +' of the main program can be modified to change the following: +' Songs played during this game +' Size of the maze game grid +' How quickly the monsters move +' Initial time allowed per maze +' Color of Player 1 +' Color of Player 2 +' Color of the Monsters +' Maze dimensions at each difficulty level +' Amount of time path preview is shown +' +' On the right side of each CONST statement, there is a comment that tells +' you what it does and how large or small you can set the value. Above the +' DATA statements, there are comments that tell you the format of the +' information stored there. +' +' On your own, you can also add exciting sound and visual effects or make any +' other changes that your imagination can dream up. By reading the +' "Learn BASIC Now" book, you'll learn the techniques that will enable you +' to fully customize this game and to create games of your own. +' +' If the game won't run after you have changed it, you can exit without +' saving your changes by pressing Alt, F, X and choosing NO. +' +' If you do want to save your changes, press Alt, F, A and enter a filename +' for your version of the program. Before you save your changes, +' however, you should make sure they work by running the program and +' verifying that your changes produce the desired results. Also, always +' be sure to keep a backup of the original program. +' +DefInt A-Z + +' Here are the BASIC CONST statements you can change. +Const BLOCKSIZE = 8 ' Maze grid element size. Range: 4 to 8. With a smaller block size a larger maze can be created by modifying the DATA statements at the end of the main program. +Const DEFAULTTIME = 60 ' Seconds allowed to complete a maze at level 1. Decreases by 5 seconds in each later level. Range 30 to 100. +Const DEFAULTMONSTERTIME = .5 ' Range: .2 to 3.0 A lower number makes the monsters move faster. +Const SHOWDELAY = .2 ' Seconds that the maze solution will be shown. Range 0 to 10. +Const DEFAULTPLAYERS = 1 ' Range 1 to 2. +Const DEFAULTLEVEL = 1 ' Range 1 to 5. +Const DEFAULTMONSTERS = 0 ' Range 0 to 10. +Const DEFAULTSHOWMAZE = -1 ' Range 0 (FALSE) or -1 (TRUE). +Const DEFAULTNUMMAZES = 1 ' Range 1 to 10. +Const MAZECOLOR7 = 7 ' Color of the maze (EGA, VGA graphics). Range: 1 to 15, but not the same as GameBkGround7. +Const PLAYER1COLOR7 = 10 ' Color of player 1 (EGA, VGA graphics). Range: 1 to 15, but not the same as GameBkGround7. +Const PLAYER2COLOR7 = 13 ' Color of player 2 (EGA, VGA graphics). Range: 1 to 15, but not the same as GameBkGround7. +Const MONSTERCOLOR7 = 12 ' Color of the monsters (EGA, VGA graphics). Range: 1 to 15, but not the same as GameBkGround7. +Const MAZECOLOR1 = 3 ' Color of the maze (CGA graphics). Range 1 to 3, but not the same as GameBkGround1. +Const PLAYER1COLOR1 = 1 ' Color of player 1 (CGA graphics). Range: 1 to 3, but not the same as GameBkGround1. +Const PLAYER2COLOR1 = 2 ' Color of player 2 (CGA graphics). Range: 1 to 3, but not the same as GameBkGround1. +Const MONSTERCOLOR1 = 3 ' Color of the monsters (CGA graphics). Range: 1 to 3, but not the same as GameBkGround1. +' The following sound constants are used by the PLAY command to +' produce music during the game. To change the sounds you hear, change +' these constants. Refer to the online help for PLAY for the correct format. +' To completely remove sound from the game set the constants equal to null. +' For example: STARTOFGAMESOUND = "" +Const STARTOFGAMESOUND = "MBT145O1L8B-O2DL4E-L8O1A-O2CL4D-L8O2CEFE-DO1B-O2CO1B-" ' Played during Displayintro subroutine. +Const ENDOFGAMESOUND = "MBT200O1L6EBAEL7A" ' Played when all the mazes have been played or 'Q' was chosen when the game was paused. +Const ENDOFMAZESOUND = "MBT190n70n60n50n40" ' Played when a maze is completed +Const PLAYERDEATHSOUND = "MBT255o0l10n10l7n7l10n4" ' Played when you lose a life or run out of time. +Const PLAYEROUTSOUND = "MBT140L64n40n35n30" ' Played when a player exits the maze + +'The next section contains CONST statements that are not changeable. +Const FALSE = 0 ' FALSE for Boolean operations. +Const TRUE = -1 ' TRUE for Boolean operations. +Const UP2 = 18 ' Keyboard scan code for the E key. +Const DOWN2 = 32 ' Keyboard scan code for the D key. +Const LEFT2 = 31 ' Keyboard scan code for the S key. +Const RIGHT2 = 33 ' Keyboard scan code for the F key. +Const CTOP = 1 ' Keyboard code for up in internal maze directions. +Const CBOTTOM = 2 ' Keyboard code for down in internal maze directions. +Const CLEFT = 3 ' Keyboard code for left in internal maze directions. +Const CRIGHT = 4 ' Keyboard code for right in internal maze directions. +Const MAXMONSTERS = 10 ' Maximum number of monsters. +Const MAXLEVEL = 5 ' Maximum number of levels. +Const MAXMAZES = 10 ' Maximum number of mazes. +Const SCREENWIDTH = 80 ' Text mode screen width. +Const GAMEBKGROUND7 = 1 ' Color to use to erase objects (EGA, VGA graphics). +Const GAMEBKGROUND1 = 0 ' Color to use to erase objects (CGA graphics). In CGA mode, 0 means the color of the background. + +' DECLARE statement tell the main program that subprograms and +' functions exist and defines what data types they use. +DECLARE SUB BustOut (x%, y%) +DECLARE SUB CancelDirection (move AS ANY, direction%) +DECLARE SUB Center (text$, row%) +DECLARE SUB ChangeWall (x%, y%, direction%, RepCh%) +DECLARE SUB ClosePath (move AS ANY) +DECLARE SUB CompleteMaze () +DECLARE SUB ConvertDirToXY (direction%, xmove%, ymove%) +DECLARE SUB DisplayChanges () +DECLARE SUB DisplayGameTitle () +DECLARE SUB DisplayIntro () +DECLARE SUB DisplayWinner () +DECLARE SUB DrawMonster (x%, y%, WhatColor%) +DECLARE SUB DrawPlayer (Player%, WhatColor%) +DECLARE SUB GenerateMaze () +DECLARE SUB GenerateMove (move AS ANY) +DECLARE SUB GetGameOptions () +DECLARE SUB InitVariables () +DECLARE SUB Keys (onoff%) +DECLARE SUB MonsterControl () +DECLARE SUB PlayGame () +DECLARE SUB PopMove (move AS ANY) +DECLARE SUB PrintBlock (block AS ANY, x%, y%, WhatColor%) +DECLARE SUB PrintMaze () +DECLARE SUB ProcessPlayerInput (i%) +DECLARE SUB UpdatePosition (Dir%, Plr%) +DECLARE FUNCTION CheckForClosedArea% (move AS ANY) +DECLARE FUNCTION CreatePath% () +DECLARE FUNCTION GetMonsterDirection% (x%, y%, direction%) +DECLARE FUNCTION NumberOfWalls% (x%, y%) +DECLARE FUNCTION ValidBustDir% (x%, y%) + +' This section contains TYPE definitions: +Type MazeType ' This type contains maze information of a single block. + top As Integer ' Tells if top block side exists. + Bottom As Integer ' Tells if bottom block side exists. + Left As Integer ' Tells if left block side exists. + Right As Integer ' Tells if right block side exists. +End Type + +Type MoveType ' MoveType contains information about moves within the maze. + x As Integer ' X coordinate of a move. + y As Integer ' Y coordinate of a move. + direction As Integer ' Direction of a move 1 to 4. + Spaces As Integer ' Number of hexes to move in a row during maze creation. + top As Integer ' Tells if top block side exists. + Bottom As Integer ' Tells if bottom block side exists. + Left As Integer ' Tells if left block side exists. + Right As Integer ' Tells if right block side exists. +End Type + +Type PlayerType ' This type is used to keep track of information about each player. + x As Integer ' Player's horizontal position. + y As Integer ' Player's vertical position. + PColor As Integer ' Player's color. + Dead As Integer ' -1 means the player is dead, 0 means the player is alive. + TimeLeft As Integer ' Temporary time left for each player. + Done As Integer ' -1 means the player is done with current maze, 0 means the player is not done. + Score As Long ' Player points. +End Type + +Type MonsterType ' This type is used to keep track of information about each monster. + x As Integer ' Monster's horizontal position. + y As Integer ' Monster's vertical position. + direction As Integer ' Monster's direction of movement. + Active As Integer ' -1 means the monster is active, 0 means the monster is frozen and inactive. +End Type + +Clear , , 5120 'Set up a large stack for all key processing. + +' This section contains COMMON SHARED variables. +Dim Shared MazeWidth As Integer ' Width of maze, in blocks. +Dim Shared MazeHeight As Integer ' Height of maze, in blocks. +Dim Shared PathLength As Integer ' Minimum number of blocks the valid path must be go before trying to turn. +Dim Shared TurnRate As Integer ' Maximum number of blocks the valid path may go before trying to turn +Dim Shared ShowMaze As Integer ' -1 cause the full maze to be shown, 0 causes only the outer edge to be shown. +Dim Shared Level As Integer ' Play level. +Dim Shared AvailMonsters As Integer ' Number of monsters. +Dim Shared NumOfPlayers As Integer ' Number of players. +Dim Shared NumOfMazes As Integer ' Number of mazes to run before completing a level. +Dim Shared MazeTime As Integer ' Time allowed to complete a maze. +Dim Shared StackPointer As Integer ' Points to current place on the stack. +Dim Shared MazeOver As Integer ' -1 means an event has ended one run through a maze. +Dim Shared GameOver As Integer ' -1 means an event has caused the game to end. +Dim Shared MazesFinished As Integer ' Number of mazes completed. +Dim Shared NumMonsters As Integer ' Number of monsters currently on the screen. +Dim Shared MazeColor As Integer ' Color of maze. +Dim Shared GameBkGround As Integer ' Background color. +Dim Shared MonsterColor As Integer ' Color of the monsters. +Dim Shared ScreenMode As Integer ' Screen mode. +Dim Shared EntryX As Integer ' X coordinate of the maze entrance. +Dim Shared EntryY As Integer ' Y coordinate of the maze entrance. +Dim Shared ExitX As Integer ' X coordinate of the maze exit. +Dim Shared ExitY As Integer ' Y coordinate of the maze exit. +Dim Shared StartX As Integer ' X coordinate of the maze. +Dim Shared StartY As Integer ' Y coordinate of the maze. +Dim Shared CountDown As Integer ' Number of seconds left to complete a maze. +Dim Shared MazeError As Integer ' Indicates if a maze error occurred. +Dim Shared MonsterUpdateTime As Single ' Delay between monster movements. +Dim Shared ContinueDirection As Single ' Probability of the monster continuing in the same direction. +Dim Shared Player(1 To 2) As PlayerType ' Information about each player. +Dim Shared PlayerMove(1 To 2) As Integer ' Temporary user move from the queue. +ReDim Shared stackVar(0) As MoveType ' All maze creation moves. +ReDim Shared MazeArray(0, 0) As MazeType ' Maze information. +ReDim Shared Monsters(0) As MonsterType ' Monster information. +Dim KeyFlags As Integer ' Internal state of keyboard flags when game starts. Hold the state so it can be restored when the game ends. +Dim BadMode As Integer ' Store the status of a valid screen mode. + +' The module-level code of QMAZE begins here! + +Randomize Timer Mod 32768 ' Causes the mazes to be different. + +'Determines which graphics mode to use. +On Error GoTo ScreenError ' Set an error trap for testing valid screen mode. +BadMode = FALSE ' Assume the graphics mode is okay. +ScreenMode = 7 ' First try mode 7. +Screen ScreenMode ' Attempt to go into SCREEN 7 (EGA screen). +If BadMode = TRUE Then ' If this attempt failed. + ScreenMode = 1 ' Try mode 1 - a CGA screen. + BadMode = FALSE ' Again, assume that graphics mode is okay. + Screen ScreenMode ' Attempt to go into SCREEN 1. +End If +On Error GoTo 0 ' Turn off error handling. + +If BadMode = TRUE Then ' If no graphics adapter... + Cls + Locate 10, 13: Print "CGA, EGA Color, or VGA graphics required to run QMAZE.BAS" +Else + Def Seg = 0 ' Set the current segment to the low memory area. + KeyFlags = Peek(1047) ' Read the location that stores the keyboard flag. + Poke 1047, &H0 ' Force them off. + Def Seg ' Restore the default segment. + + DisplayIntro ' Display the introduction screen now. + Do + GetGameOptions ' Get the user choices for game. + InitVariables ' Initialize keys and variables. + Do + Screen ScreenMode ' Set appropriate screen mode. + Color GameBkGround, 1 + Cls ' Clear the screen. + GenerateMaze ' Create a new maze. + PlayGame ' Play the current maze. + DisplayWinner ' Show who won, etc. + Loop While Not GameOver + + Locate 22, 11 ' See if player wants to play again. + Print "Play again? (Y/N)" + Do + k$ = UCase$(InKey$) ' Wait for any key to be pressed. + Loop While (k$ <> "Y" And k$ <> "N") + If k$ = "Y" Then GameOver = FALSE + Loop While Not GameOver + + DisplayChanges ' Display suggested changes screen. + Cls + + Def Seg = 0 ' Restore the previous flag settings. + Poke 1047, KeyFlags + Def Seg + +End If + +End + +' The subroutines below are called when the player presses a key to move. + +MovePlayer1Up: +PlayerMove(1) = CTOP +ProcessPlayerInput 1 +Return + +MovePlayer1Down: +PlayerMove(1) = CBOTTOM +ProcessPlayerInput 1 +Return + +MovePlayer1Left: +PlayerMove(1) = CLEFT +ProcessPlayerInput 1 +Return + +MovePlayer1Right: +PlayerMove(1) = CRIGHT +ProcessPlayerInput 1 +Return + +MovePlayer2Up: +PlayerMove(2) = CTOP +ProcessPlayerInput 2 +Return + +MovePlayer2Down: +PlayerMove(2) = CBOTTOM +ProcessPlayerInput 2 +Return + +MovePlayer2Left: +PlayerMove(2) = CLEFT +ProcessPlayerInput 2 +Return + +MovePlayer2Right: +PlayerMove(2) = CRIGHT +ProcessPlayerInput 2 +Return + +PauseGame: +Keys (2) ' Ensure that no other interrupts happen at the same time. +Timer Off +Sound 1100, .75 ' Tone at 1100 hertz for 75 clock ticks. +Center Space$(13) + "* PAUSED *" + Space$(13), 1 'Display pause message. +While InKey$ = "": Wend ' Wait for a key to be pressed. +Center Space$(36), 1 ' Clear prompt. +Keys (1) ' Allow interrupts to fire normally. +Timer On +Return + +QuitGame: +Keys (2) ' Ensure that no other interrupts happen at the same time. +Timer Off +Sound 600, .5 +Sound 800, .5 +Center Space$(10) + "Really quit? (Y/N)" + Space$(10), 1 ' Display prompt. +Do + k$ = UCase$(InKey$) ' Wait for desired key to be pressed. +Loop While k$ = "" +Center Space$(39), 1 ' Clear prompt from the screen. + +If k$ = "Y" Then GameOver = TRUE +Keys (1) ' Turn keys back on. +Timer On +Return + +TimerUpdate: +Sound 500, .1 +CountDown = CountDown - 1 ' Reduce the time-left variable by one. +Locate 1, 13: Print CountDown +Return + +ScreenError: ' Screen test error handling routine. +BadMode = TRUE +Resume Next + +MazeErrorHandler: ' Maze creation error handler. +MazeError = TRUE +Resume Next + + +' The following Data Statements contain information about the Mazes at +' different levels. The Data is read in from GetGameOptions. Each row of +' DATA is information for a level. The first row for Level one and so +' on. The entries are read from left to right into the following variables: +' mazeWidth, mazeHeight, pathLength, TurnRate. +' +' THESE DATA STATEMENTS MAY BE CHANGED WITHIN LIMITS +' +' The first entry is the width of the maze. Range 20 to 38 +' The second entry is the height of the maze. Range 15 to 20 +' The third entry is the minimum length of the path. Range 25 to 60 +' The greater the value the harder the maze is. The smaller the maze +' the shorter the PathLength should be. +' +' WARNING: A Large PathLength with a small maze can cause the maze +' generator to produce an error. +' +' The fourth entry is the turn rate of the correct path. Range 3 to 7. +' +Data 20,20,30,3 +Data 25,20,40,3 +Data 30,20,50,5 +Data 35,20,60,7 +Data 35,20,60,5 + +' The total number of levels can be changed if extra DATA statements are added +' after the existing ones. They must have the same format as the existing +' DATA statements. You must also change the constant maxLevel to add +' additional levels. + +'--------------------------------------------------------------------------- +' BustOut +' +' Starts at a given block and creates a path (removing walls) until it +' encounters a block that does not have four walls. Uses the SHARED +' TurnRate variable to decide how far to go in one direction before turning. +' This keeps the rest of the maze consistent with the valid path. +' +' PARAMETERS: X - X coordinate of the starting block +' Y - Y coordinate of the starting block +'--------------------------------------------------------------------------- +Sub BustOut (x, y) + + BustedOut = FALSE + currx = x ' Set current X & Y position. + curry = y + Do While Not BustedOut + direction = ValidBustDir(currx, curry) ' Set direction. + ConvertDirToXY direction, xmove, ymove ' Convert direction to coordinates. + Spaces = Int(Rnd(1) * TurnRate) + 1 + ValidMove = TRUE + BlocksOpened = 1 + Do While BlocksOpened <= Spaces And ValidMove + ChangeWall currx, curry, direction, 0 + currx = currx + xmove + curry = curry + ymove + If currx + xmove < 1 Or currx + xmove > MazeWidth Or curry + ymove < 1 Or curry + ymove > MazeHeight Then + ValidMove = FALSE + End If + If MazeArray(currx, curry).top + MazeArray(currx, curry).Bottom + MazeArray(currx, curry).Left + MazeArray(currx, curry).Right <> 3 Then + ValidMove = FALSE + BustedOut = TRUE + End If + BlocksOpened = BlocksOpened + 1 + Loop + Loop + +End Sub + +'-------------------------------------------------------------------------- +' +' CancelDirection +' +' Takes a direction value and cancels it as a valid move +' direction in the move type variable which is passed to it. +' +' PARAMETERS: move - Allowable directions to move +' direction - Direction to cancel legal move +'-------------------------------------------------------------------------- +Sub CancelDirection (move As MoveType, direction) + + Select Case direction ' Determine direction. + Case CTOP + move.top = 1 ' Cancel move up. + Case CBOTTOM + move.Bottom = 1 ' Cancel move down. + Case CLEFT + move.Left = 1 ' Cancel move left. + Case CRIGHT + move.Right = 1 ' Cancel move right. + End Select + +End Sub + +'-------------------------------------------------------------------------- +' Center +' +' Centers the given text string on the indicated row. +' +' PARAMETERS: text$ - The text to be centered +' row - The screen row to print on +'-------------------------------------------------------------------------- +Sub Center (text$, row) + + ' Calculate the starting column. Subtract the string length from + ' ScreenWidth the divide that value by 2. + + Locate row%, (SCREENWIDTH - Len(text$)) \ 2 + 1 + + Print text$; ' Print the text. + +End Sub + +'--------------------------------------------------------------------------- +' ChangeWall +' +' Replaces a wall given the coordinates and the direction to replace. +' The routine actually has to replace two walls. It needs to replace +' the adjoining wall in the adjoining block. +' +' PARAMETERS: x - X coordinate of the block whose wall +' will be replaced +' y - Y coordinate of the block whose wall +' will be replaced +' direction - Direction of the wall to be replaced +' repch - Designates whether to replace or erase +' (1 = replace, 0 = remove) +'--------------------------------------------------------------------------- +Sub ChangeWall (x, y, direction, RepCh) + + Select Case direction + Case CTOP + MazeArray(x, y).top = RepCh + MazeArray(x, y - 1).Bottom = RepCh + Case CBOTTOM + MazeArray(x, y).Bottom = RepCh + MazeArray(x, y + 1).top = RepCh + Case CLEFT + MazeArray(x, y).Left = RepCh + MazeArray(x - 1, y).Right = RepCh + Case CRIGHT + MazeArray(x, y).Right = RepCh + MazeArray(x + 1, y).Left = RepCh + End Select + +End Sub + +'-------------------------------------------------------------------------- +' CheckForClosedArea +' +' Prevents the path from shutting itself into a closed area from which it +' might take a while to back its way out of. While this routine does not +' wholly prevent this, it eliminates many of the possibilities which take +' time to check. The routine accomplishes this by checking to see if the +' current move will cause the path to touch itself. If the path is going +' to touch, it retraces the path until it comes to the block which was +' touched. If any of the blocks along the way back has an untouched block +' (four walls) on opposite sides of it, it can be assumed that the move has +' a high chance of causing the path to enclose itself. +' +' PARAMETERS: move - Starting location to check path +'-------------------------------------------------------------------------- +Function CheckForClosedArea (move As MoveType) + + CheckForClosedArea = FALSE + + ConvertDirToXY move.direction, xmove, ymove ' Get the location of where the current move goes. + currx = move.x + xmove * move.Spaces + curry = move.y + ymove * move.Spaces + Touching = FALSE + + 'Check to see if moving up or down + If move.direction = CTOP Or move.direction = CBOTTOM Then + + If currx + 1 <= MazeWidth Then ' Check the right side to find if wall is touched. + If NumberOfWalls(currx + 1, curry) <> 4 Then + TouchedX = currx + 1 + TouchedY = curry + Touching = TRUE + End If + End If + + If currx - 1 >= 1 Then ' Check the left side to find if wall is touched. + If NumberOfWalls(currx - 1, curry) <> 4 Then + TouchedX = currx - 1 + TouchedY = curry + Touching = TRUE + End If + End If + + For xcheck = -1 To 1 ' Check ahead-left, straight-ahead and ahead-right to find if wall is touched. + If curry + ymove >= 1 And curry + ymove <= MazeHeight And currx + xcheck >= 1 And currx + xcheck <= MazeWidth Then + If NumberOfWalls(currx + xcheck, curry + ymove) <> 4 Then + TouchedX = currx + xcheck + TouchedY = curry + ymove + Touching = TRUE + End If + End If + Next xcheck + End If + + + If move.direction = CLEFT Or move.direction = CRIGHT Then ' Check to see if moving left or right + + If curry + 1 <= MazeHeight Then ' Check top to find if wall is touched. + If NumberOfWalls(currx, curry + 1) <> 4 Then + TouchedX = currx + TouchedY = curry + 1 + Touching = TRUE + End If + End If + + If curry - 1 >= 1 Then ' Check bottom to find if wall is touched. + If NumberOfWalls(currx, curry - 1) <> 4 Then + TouchedX = currx + TouchedY = curry - 1 + Touching = TRUE + End If + End If + + + For ycheck = -1 To 1 ' Check ahead-top, straight-ahead and ahead-bottom to find if wall is touched. + If currx + xmove >= 1 And currx + xmove <= MazeWidth And curry + ycheck >= 1 And curry + ycheck <= MazeHeight Then + If NumberOfWalls(currx + xmove, curry + ycheck) <> 4 Then + TouchedX = currx + xmove + TouchedY = curry + ycheck + Touching = TRUE + End If + End If + Next ycheck + End If + + If Not Touching Then Exit Function ' If the wall hasn't been touched, there is no problem. + + ' There was a touch, so check for an untouched box on opposite side for each block in the path. + SavePointer = StackPointer 'Ensure the move stack is returned to its proper position. + Dim CheckMove As MoveType + CheckMove = move + UntouchedBlocks = FALSE + FoundTouch = FALSE + + ' Loop until either the block that was touched is found, or we find a block with untouched blocks on opposite sides. + While Not UntouchedBlocks And Not FoundTouch + ConvertDirToXY CheckMove.direction, xmove, ymove + currx = CheckMove.x + curry = CheckMove.y + SpacesChecked = 1 + + ' Check through all the blocks in one move. + Do While Not UntouchedBlocks And Not FoundTouch And SpacesChecked <= CheckMove.Spaces + currx = currx + xmove + curry = curry + ymove + + If currx = TouchedX And curry = TouchedY Then ' Found the place where the wall is touched. + FoundTouch = TRUE + Exit Do + End If + ' Get the number of walls for each block on all sides of the path block. Edges count as untouched blocks. + If currx + 1 <= MazeWidth Then + RightBox = NumberOfWalls(currx + 1, curry) + Else + RightBox = 4 + End If + If currx - 1 >= 1 Then + LeftBox = NumberOfWalls(currx - 1, curry) + Else + LeftBox = 4 + End If + If curry + 1 <= MazeHeight Then + BottomBox = NumberOfWalls(currx, curry + 1) + Else + BottomBox = 4 + End If + If curry - 1 >= 1 Then + TopBox = NumberOfWalls(currx, curry - 1) + Else + TopBox = 4 + End If + + If RightBox = 4 And LeftBox = 4 Then ' Check to see if opposite blocks are untouched. + UntouchedBlocks = TRUE + CheckForClosedArea = TRUE + End If + If TopBox = 4 And BottomBox = 4 Then + UntouchedBlocks = TRUE + CheckForClosedArea = TRUE + End If + SpacesChecked = SpacesChecked + 1 + Loop + PopMove CheckMove + Wend + StackPointer = SavePointer ' Restore the stack to its original place. + +End Function + +'--------------------------------------------------------------------------- +' ClosePath +' +' Puts back all the walls opened by a given move. This is used when a +' move is popped off the stack because it has no more valid directions. +' +' PARAMETERS: move - The move to close path from +'-------------------------------------------------------------------------- +Sub ClosePath (move As MoveType) + + ConvertDirToXY move.direction, xmove, ymove + x = move.x + y = move.y + For i = 1 To move.Spaces + ChangeWall x, y, move.direction, 1 + x = x + xmove + y = y + ymove + PrintBlock MazeArray(x, y), x, y, MazeColor + Next i + +End Sub + +'--------------------------------------------------------------------------- +' CompleteMaze +' +' Finishes breaking out the walls of the maze after a valid path has been +' found. It does this by first picking random points along the valid path +' and calling the BustOut routine from these points. This helps ensure that +' there will be many alternative accessible paths. After it chooses the +' random points, it checks each block in the maze to make sure that it +' does not have four walls. If there are blocks with four walls, the +' BustOut routine is called with this block as a starting point. +' +' PARAMETERS: None +'--------------------------------------------------------------------------- +Sub CompleteMaze + + Dim TempMove As MoveType + SavePointer = StackPointer ' Preserve the stack pointer. + + Do While SavePointer > 1 ' Loop from the end of the path back to the beginning. + + 'Choose which block on the valid path to start the BustOut routine. + Interval = TurnRate + Int(Rnd(1) * TurnRate) + 1 + SpacesPassed = 0 + While SpacesPassed < Interval And StackPointer > 1 + PopMove TempMove + SpacesPassed = SpacesPassed + TempMove.Spaces + Wend + If StackPointer <= 1 Then Exit Do + BustOut TempMove.x, TempMove.y + Loop + + StackPointer = SavePointer ' Restore the stack pointer. + For ycheck = 1 To MazeHeight ' Check each block in the maze to ensure that it does not have four walls. + For xcheck = 1 To MazeWidth + If MazeArray(xcheck, ycheck).top + MazeArray(xcheck, ycheck).Bottom + MazeArray(xcheck, ycheck).Left + MazeArray(xcheck, ycheck).Right = 4 Then + BustOut xcheck, ycheck + End If + Next xcheck + Next ycheck + +End Sub + +'---------------------------------------------------------------------------- +' ConvertDirToXY +' +' Converts directions into the horizontal and vertical movements needed +' to move in a specified direction. +' +' PARAMETERS: Direction - Movement direction +' xmove - X coordinate of next position +' ymove - Y coordinate of next position +'---------------------------------------------------------------------------- +Sub ConvertDirToXY (direction, xmove, ymove) + + Select Case direction + Case CTOP + ymove = -1: xmove = 0 + Case CBOTTOM + ymove = 1: xmove = 0 + Case CLEFT + ymove = 0: xmove = -1 + Case CRIGHT + ymove = 0: xmove = 1 + Case Else + ymove = 0: xmove = 0 + End Select + +End Sub + +'--------------------------------------------------------------------------- +' CreatePath +' +' This is the main controlling routine which determines a valid path through +' the maze. It contains two main loops. The outer loop is executed once +' for each move. The inner loop is executed once for each block in the move. +' The basic flow of the loops is as follows. First, a random move is +' generated. The move is then checked to make sure it doesn't run into a +' wall or try to enclose itself. If the move passes the tests, it is added +' to the stack of moves. If the end of the path is on an edge, and the path +' has travelled the minimum distance, then the path is done. If a move does +' not pass a test, then the move is deleted and the previous move is told +' that it cannot move in that direction. If all of the directions have been +' used up, then that move is removed from the stack, and the move previous +' to that is told it can't move in that direction. By doing this, it is +' assured that the maze will eventually be solved. However, It may take +' the maze generator a while to back all the way out of situations where +' it loops on itself. Routines were added to try to cut down on this +' happening to some degree of success. However, small mazes with long +' minimum path lengths may still take a while to generate. If an error is +' generated during maze creation then FALSE is returned by CreatePath, +' ELSE CreatePath is TRUE. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Function CreatePath + + On Error GoTo MazeErrorHandler ' Initialize error trapping. + + touched = FALSE + currx = EntryX + curry = EntryY + Dim CurrMove As MoveType + Dim newmove As MoveType + CurrMove.x = EntryX + CurrMove.y = EntryY + finished = FALSE + TimeOfMaze! = Timer ' Initialize error detection. + MazeError = FALSE + + ' Loop until an edge is found after travelling the minimum path length . + While Not finished + ValidMove = FALSE + GenerateMove CurrMove 'Get a move to check. + 'Loop until a valid move is generated + While ValidMove = FALSE + 'Perform Error checking + If (Timer - TimeOfMaze! > 8) Or (MazeError = TRUE) Then + CreatePath = FALSE + Exit Function + End If + + ConvertDirToXY CurrMove.direction, xmove, ymove + ValidMove = TRUE + SpacesChecked = 1 + currx = CurrMove.x + curry = CurrMove.y + + ' Check each block in the move. + Do While SpacesChecked <= CurrMove.Spaces And ValidMove + currx = currx + xmove + curry = curry + ymove + + ' Ensure no wall was run into. If it was, change the spaces so move stops at the wall. + If currx < 1 Or currx > MazeWidth Or curry < 1 Or curry > MazeHeight Then + CurrMove.Spaces = SpacesChecked - 1 + Exit Do + End If + + ' Check to see if our own path has been run into. + If NumberOfWalls(currx, curry) <> 4 Then + + ' If moved one space, then it is not a valid direction, cancel it. + If SpacesChecked = 1 Then + ValidMove = FALSE + CancelDirection CurrMove, CurrMove.direction + + ' If there are no more directions to choose from, get rid of the last move. + If CurrMove.top + CurrMove.Bottom + CurrMove.Left + CurrMove.Right = 4 Then + PopMove CurrMove + totalpathlen = totalpathlen - CurrMove.Spaces + CancelDirection CurrMove, CurrMove.direction + ClosePath CurrMove + End If + GenerateMove CurrMove ' Generate a new move to check. + Else + ' Change the spaces before crossing out own path. + CurrMove.Spaces = SpacesChecked - 1 + Exit Do + End If + Else + SpacesChecked = SpacesChecked + 1 + End If + Loop + + ' Make sure that the path is not closing itself off. + If ValidMove And CheckForClosedArea(CurrMove) Then + ValidMove = FALSE + CancelDirection CurrMove, CurrMove.direction + GenerateMove CurrMove + End If + Wend + + If StackPointer < PathLength * 10 Then ' Push the move now. + StackPointer = StackPointer + 1 + stackVar(StackPointer) = CurrMove + Else + MazeError = TRUE + End If + + ' Process the current move here. + ConvertDirToXY CurrMove.direction, xmove, ymove + x = CurrMove.x + y = CurrMove.y + For i = 1 To CurrMove.Spaces + ChangeWall x, y, CurrMove.direction, 0 + x = x + xmove + y = y + ymove + PrintBlock MazeArray(x, y), x, y, MazeColor ' Show the path block. + Next i + + currx = CurrMove.x + CurrMove.Spaces * xmove + curry = CurrMove.y + CurrMove.Spaces * ymove + newmove.x = currx + newmove.y = curry + totalpathlen = totalpathlen + CurrMove.Spaces + CurrMove = newmove + + ' Check to see if we are at a wall. + If currx = MazeWidth Or curry = MazeHeight Or currx = 1 Or curry = 1 Then + + ' If so, is it time to exit? + If totalpathlen >= PathLength Then + ExitX = currx + ExitY = curry + finished = TRUE + If ExitY = MazeHeight Then + MazeArray(ExitX, ExitY).Bottom = 0 + ElseIf ExitY = 1 Then + MazeArray(ExitX, ExitY).top = 0 + ElseIf ExitX = MazeWidth Then + MazeArray(ExitX, ExitY).Right = 0 + ElseIf ExitX = 1 Then + MazeArray(ExitX, ExitY).Left = 0 + End If + Else + ' Ensure we turn away from the exit to prevent the path from + ' closing itself off. If the path has touched the far wall already + ' then touching one of the side walls is no problem. + If currx = 1 Or currx = MazeWidth Then + If EntryY = 1 And Not touched Then CancelDirection CurrMove, CTOP + If EntryY = MazeHeight And Not touched Then CancelDirection CurrMove, CBOTTOM + If EntryX = currx Then + If curry > EntryY Then + CancelDirection CurrMove, CTOP + Else + CancelDirection CurrMove, CBOTTOM + End If + End If + If currx = 1 And EntryX = MazeWidth Then touched = 1 + If currx = MazeWidth And EntryX = 1 Then touched = 1 + End If + If curry = 1 Or curry = MazeHeight Then + If EntryX = 1 And Not touched Then CancelDirection CurrMove, CLEFT + If EntryX = MazeWidth And Not touched Then CancelDirection CurrMove, CRIGHT + If EntryY = curry Then + If currx > EntryX Then + CancelDirection CurrMove, CLEFT + Else + CancelDirection CurrMove, CRIGHT + End If + End If + If curry = 1 And EntryY = MazeHeight Then touched = TRUE + If curry = MazeHeight And EntryY = 1 Then touched = TRUE + End If + End If + End If + Wend + + If Not MazeError Then CreatePath = TRUE Else CreatePath = FALSE + On Error GoTo 0 + +End Function + +'-------------------------------------------------------------------------- +' DisplayChanges +' +' Displays a list of changes that the player can easily make. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub DisplayChanges + + DisplayGameTitle ' Display game title. + + Color 7 ' Set colors so text prints white. + Center "The following game characteristics can be easily changed from", 5 + Center "within the QuickBASIC Interpreter. To change the values of ", 6 + Center "these characteristics, locate the corresponding CONST or DATA", 7 + Center "statements in the source code and change their values, then ", 8 + Center "restart the program (press Shift+F5). ", 9 + + Color 15 ' Set foreground color to bright white. + Center "Songs played during this game ", 11 + Center "Size of the maze game grid ", 12 + Center "How quickly the monsters move ", 13 + Center "Initial time allowed per maze ", 14 + Center "Color of Player 1 ", 15 + Center "Color of Player 2 ", 16 + Center "Color of the Monsters ", 17 + Center "Maze dimensions at each difficulty level", 18 + Center "Amount of time path preview is shown ", 19 + + Color 7 + Center "The CONST statements and instructions on changing them are ", 21 + Center "located at the beginning of the main program. ", 22 + + Do While InKey$ = "": Loop ' Wait for any key to be pressed. + Cls ' Clear screen. + +End Sub + +'--------------------------------------------------------------------------- +' DisplayGameTitle +' +' Displays title of the game. +' +' PARAMETERS: None +'--------------------------------------------------------------------------- +Sub DisplayGameTitle + + Screen 0 ' Set screen mode 0. + Width SCREENWIDTH, 25 ' Set width to 80, height to 25. + Color 4, 0 ' Set colors for red on black. + Cls ' Clear the screen. + Locate 1, 2 + Print Chr$(201); String$(76, 205); Chr$(187); ' Draw top border. + For i% = 2 To 24 ' Draw left and right borders. + Locate i%, 2 + Print Chr$(186); Tab(79); Chr$(186); + Next i% + Locate 25, 2 + Print Chr$(200); String$(76, 205); Chr$(188); ' Draw bottom border. + + 'Print game title centered at top of screen + Color 0, 4 ' Set colors to black on red. + Center " Microsoft ", 1 ' Center game title on lines + Center " Q M A Z E ", 2 ' 1 and 2. + Center " Press any key to continue ", 25 + Color 7, 0 + +End Sub + +'-------------------------------------------------------------------------- +' DisplayIntro +' +' Explains the object of the game and show how to play. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub DisplayIntro + + DisplayGameTitle ' Display game title + Color 7 ' Set colors so text prints white. + Center "Copyright (C) 1990 Microsoft Corporation. All Rights Reserved.", 4 + Center "You are moving through a maze at breakneck speed, racing the clock or ", 6 + Center "a friend. The object is to finish the maze before time runs out ", 7 + Center "or before your opponent finishes. Monsters can be added to increase ", 8 + Center "difficulty. The amount of time allowed to complete the maze increases", 9 + Center "for every monster in the maze. The player who finishes first wins ", 10 + Center "the points for the maze. ", 11 + Color 4 ' Change foreground color for line to red. + Center String$(74, 196), 13 ' Put horizontal red line on screen. + Color 7 ' Change foreground color back to white. + Center " Game Controls ", 13 ' Display game controls. + Center " General Player 1 Controls Player 2 Controls ", 15 + Center " (Up) (Up) ", 17 + Center " P - Pause " + Chr$(24) + " E ", 18 + Center " Q - Quit (Left) " + Chr$(27) + " " + Chr$(26) + " (Right) (Left) S F (Right) ", 19 + Center " " + Chr$(25) + " D ", 20 + Center " (Down) (Down) ", 21 + + Play STARTOFGAMESOUND 'Play introductory melody. + Do 'Wait for any key to be pressed. + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Q" Then 'Allow player to quit now + Cls + Locate 10, 30: Print "Really quit? (Y/N)"; + Do + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Y" Then + Cls + End + End If + End If + +End Sub + +'---------------------------------------------------------------------------- +' DisplayWinner +' +' Displays a screen between mazes. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayWinner + + Cls ' Clear the screen. + Line (5, 5)-(315, 195), , B ' Draw a border. + Diff = NumOfMazes - MazesFinished ' Determine number of mazes remaining. + Locate 3, 16 + If Diff = 0 Then Print "GAME OVER" Else Print "Maze #"; MazesFinished + + Locate 6, 5 + If Player(1).Done Then ' Display number of seconds player 1 took to complete the maze. + Print "Player 1 finished in"; MazeTime - Player(1).TimeLeft; "seconds" + Else + Print "Player 1 did not finish!" + End If + + Temp = Player(1).TimeLeft - Player(2).TimeLeft + Locate 10, 5 + If Temp = 0 Then + If NumOfPlayers = 2 Then ' Message based on number of players. + Print "Tie maze: nobody wins this round" + Else + Print "Player 1 loses this round" + End If + Else + If Sgn(Temp) = 1 Then Win = 1 Else Win = 2 ' Determine who won. + Print "Player"; Win; "wins maze by"; Abs(Temp); "seconds!" + Player(Win).Score = Player(Win).Score + Abs(Temp) * 100 + End If + Locate 13, 9: Print Using "Player 1 score: ###,###"; Player(1).Score + + If NumOfPlayers = 2 Then ' For two players. + Locate 8, 5 + If Player(2).Done Then + Print "Player 2 finished in"; MazeTime - Player(2).TimeLeft; "seconds" + Else + Print "Player 2 did not finish!" + End If + Locate 15, 9: Print Using "Player 2 score: ###,###"; Player(2).Score + End If + + Do: Loop Until InKey$ = "" ' Clear keyboard buffer. + If Diff > 0 And Not GameOver Then + Locate 20, 8: Print "Number of mazes left:"; Diff + Play ENDOFMAZESOUND ' Play maze completion melody. + Locate 23, 6: Print "" + MazesFinished = MazesFinished + 1 ' Add one to the number of mazes completed. + While InKey$ <> " ": Wend + Else + If NumOfPlayers = 2 Then + Locate 18, 5 + Hold& = Player(1).Score - Player(2).Score + If Hold& = 0 Then + Print "EQUAL POINTS - This is a tie game!" ' Announce a tie. + Else + If Sgn(Hold&) = 1 Then Win = 1 Else Win = 2 + Print "PLAYER"; Win; "WINS GAME BY"; Abs(Hold&); "POINTS!" ' Announce winner. + End If + End If + GameOver = TRUE + Play ENDOFGAMESOUND ' Play end-of-game melody. + End If + +End Sub + +'-------------------------------------------------------------------------- +' DrawMonster +' +' Draws a monster given the color and the x,y coordinate of where it is +' in the maze. +' +' PARAMETERS: X - X coordinate of the monster +' Y - Y coordinate of the monster +' WhatColor - Color of the monster +'-------------------------------------------------------------------------- +Sub DrawMonster (x, y, WhatColor) + + Circle (StartX + x * BLOCKSIZE + BLOCKSIZE / 2, StartY + y * BLOCKSIZE + BLOCKSIZE / 2), (BLOCKSIZE / 2 - 2), WhatColor + +End Sub + +'--------------------------------------------------------------------------- +' DrawPlayer +' +' Draws a player given the color and player. +' +' PARAMETERS: Player - Which player to draw +' WhatColor - Player color +'--------------------------------------------------------------------------- +Sub DrawPlayer (Player, WhatColor) + + If Player = 1 Then + Line (StartX + Player(1).x * BLOCKSIZE + BLOCKSIZE / 4 + 1, StartY + Player(1).y * BLOCKSIZE + BLOCKSIZE / 4 + 1)-(StartX + Player(1).x * BLOCKSIZE + BLOCKSIZE * .75 - 1, StartY + Player(1).y * BLOCKSIZE + BLOCKSIZE * .75 - 1), WhatColor, BF + Else + Line (StartX + Player(2).x * BLOCKSIZE + BLOCKSIZE / 4, StartY + Player(2).y * BLOCKSIZE + BLOCKSIZE / 4)-(StartX + Player(2).x * BLOCKSIZE + BLOCKSIZE * .75, StartY + Player(2).y * BLOCKSIZE + BLOCKSIZE * .75), WhatColor, B + End If + +End Sub + +'---------------------------------------------------------------------------- +' GenerateMaze +' +' Initializes the maze variables and picks a starting point for the maze, +' then calls two routines which complete the maze. +' +' PARAMETERS: None +'--------------------------------------------------------------------------- +Sub GenerateMaze + + ReDim MazeArray(MazeWidth, MazeHeight) As MazeType 'Make sure the MazeArray is big enough. + StackPointer = 1 + For i = 1 To MazeWidth ' Initialize the maze so every wall is up. + For j = 1 To MazeHeight + MazeArray(i, j).Left = 1: MazeArray(i, j).Right = 1 + MazeArray(i, j).top = 1: MazeArray(i, j).Bottom = 1 + Next j + Next i + Cls ' Clear and show the maze grid. + PrintMaze + + Entrydir = Rnd(1) ' Choose the entry point for the maze. + Entryside = Rnd(1) + If Entrydir > .5 Then + EntryX = Int(Rnd(1) * MazeWidth) + 1 + If Entryside > .5 Then + EntryY = MazeHeight + MazeArray(EntryX, EntryY).Bottom = 0 + Else + EntryY = 1 + MazeArray(EntryX, EntryY).top = 0 + End If + Else + EntryY = Int(Rnd(1) * MazeHeight) + 1 + If Entryside > .5 Then + EntryX = MazeWidth + MazeArray(EntryX, EntryY).Right = 0 + Else + EntryX = 1 + MazeArray(EntryX, EntryY).Left = 0 + End If + End If + + ' With more complex mazes that require more moves, the stack array may + ' need to be made larger. Currently, no problems. + ReDim stackVar(1 To PathLength * 10) As MoveType + + If Not CreatePath Then + GenerateMaze ' Call GenerateMaze again + Else + first! = Timer ' Set up a small delay for user to see path. + Do: Loop Until Timer > first! + SHOWDELAY + Cls ' Clear screen from players. + If ScreenMode = 7 Then Color 14 + Locate 2, 11: Print "Generating maze..." + CompleteMaze + Locate 2, 11: Print Space$(20) + End If + +End Sub + +'---------------------------------------------------------------------------- +' GenerateMove +' +' Generates a random move for the valid maze path to make. Decides what +' directions it may move in, then choose one of the directions. Generate +' a random number of spaces to move in the given direction based on the +' turn rate. A variable of type MoveType will have a value of 1 in a +' field if a move in that direction is invalid. +' +' PARAMETERS: move - User-defined type that contains the current +' valid moves for a square +'----------------------------------------------------------------------------- +Sub GenerateMove (move As MoveType) + + ' Determine how many directions are valid, and choose one. + If move.y = 1 Then + move.top = 1 + ElseIf MazeArray(move.x, move.y - 1).top + MazeArray(move.x, move.y - 1).Bottom + MazeArray(move.x, move.y - 1).Left + MazeArray(move.x, move.y - 1).Right <> 4 Then + move.top = 1 + End If + + If move.y = MazeHeight Then + move.Bottom = 1 + ElseIf MazeArray(move.x, move.y + 1).top + MazeArray(move.x, move.y + 1).Bottom + MazeArray(move.x, move.y + 1).Left + MazeArray(move.x, move.y + 1).Right <> 4 Then + move.Bottom = 1 + End If + + If move.x = 1 Then + move.Left = 1 + ElseIf MazeArray(move.x - 1, move.y).top + MazeArray(move.x - 1, move.y).Bottom + MazeArray(move.x - 1, move.y).Left + MazeArray(move.x - 1, move.y).Right <> 4 Then + move.Left = 1 + End If + + If move.x = MazeWidth Then + move.Right = 1 + ElseIf MazeArray(move.x + 1, move.y).top + MazeArray(move.x + 1, move.y).Bottom + MazeArray(move.x + 1, move.y).Left + MazeArray(move.x + 1, move.y).Right <> 4 Then + move.Right = 1 + End If + + + AvailableMoves = 4 - (move.Left + move.Right + move.top + move.Bottom) + + If AvailableMoves = 0 Then + move.direction = 0 + move.Spaces = 1 + Exit Sub + End If + + NewDirection = Int(Rnd(1) * AvailableMoves) + 1 + + ' Determine what direction was randomly chosen. + Counter = 1 + If move.top = 0 Then + If NewDirection = Counter Then + move.direction = CTOP + End If + Counter = Counter + 1 + End If + + If move.Bottom = 0 Then + If NewDirection = Counter Then + move.direction = CBOTTOM + End If + Counter = Counter + 1 + End If + + If move.Left = 0 Then + If NewDirection = Counter Then + move.direction = CLEFT + End If + Counter = Counter + 1 + End If + + If move.Right = 0 Then + If NewDirection = Counter Then + move.direction = CRIGHT + End If + Counter = Counter + 1 + End If + + move.Spaces = Int(Rnd(1) * TurnRate) + 1 ' Decide how far to go in the chosen direction + +End Sub + +'-------------------------------------------------------------------------- +' GetGameOptions +' +' Prompts for and saves various game parameters. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub GetGameOptions + + Screen 0 ' Set screen mode 0. + Width SCREENWIDTH, 25 ' Set width to 80, height to 25., + Color 7, 0 ' Set colors to white on black. + Cls ' Clear the screen. + Locate 7, 20: Print "Default is"; DEFAULTPLAYERS + Color 15 + Do ' Get the number of Players. + Locate 6, 23: Print Space$(50) + Locate 6, 23 + Input "How many players? (1 or 2) ", InputHold$ + Loop Until InputHold$ = "1" Or InputHold$ = "2" Or Len(InputHold$) = 0 + NumOfPlayers = Val(InputHold$) + If NumOfPlayers = 0 Then NumOfPlayers = DEFAULTPLAYERS + + Color 7 + Locate 10, 20: Print "Default is"; DEFAULTLEVEL + Color 15 ' Change foreground color to bright white. + Do ' Get the difficulty level. + Locate 9, 23: Print Space$(50) + Locate 9, 23 + Input "Difficulty level? (1 to 5) ", InputHold$ + Level = Val(Left$(InputHold$, 1)) + Loop Until (Level > 0 And Level <= MAXLEVEL And Len(InputHold$) < 2) Or (Len(InputHold$) = 0) + If Level = 0 Then Level = DEFAULTLEVEL + + Color 7 ' Change foreground color back to white. + Locate 13, 20: Print "Default is"; DEFAULTNUMMAZES + Color 15 + Do ' Get number of mazes to create. + Locate 12, 23: Print Space$(50) + Locate 12, 23 + Input "Play how many mazes? (1 to 10) ", InputHold$ + NumOfMazes = Val(Left$(InputHold$, 2)) + Loop Until (NumOfMazes > 0 And NumOfMazes <= MAXMAZES And Len(InputHold$) < 3) Or (Len(InputHold$) = 0) + If NumOfMazes = 0 Then NumOfMazes = DEFAULTNUMMAZES + + Color 7 ' Change foreground color back to white. + Locate 16, 20: Print "Default is"; DEFAULTMONSTERS + Color 15 + Do ' Get number of monsters; allow for 0 entry. + Locate 15, 23: Print Space$(50) + Locate 15, 23 + Input "How many monsters? (0 to 10) ", InputHold$ + AvailMonsters = Val(Left$(InputHold$, 2)) + If AvailMonsters = 0 And InputHold$ <> "0" Then AvailMonsters = -1 + Loop Until (AvailMonsters > -1 And AvailMonsters <= MAXMONSTERS And Len(InputHold$) < 3) Or (Len(InputHold$) = 0) + If Len(InputHold$) = 0 Then AvailMonsters = DEFAULTMONSTERS + + Color 7 ' Change foreground color back to white. + Locate 19, 20: Print "Default is "; + If DEFAULTSHOWMAZE Then Print "YES" Else Print "NO" + Color 15 + Do ' Get visible or invisible maze choice + Locate 18, 23: Print Space$(40) + Locate 18, 23 + Print "Visible mazes? (Y or N) "; + Input "", InputHold$ + InputHold$ = UCase$(InputHold$) + Loop Until (InputHold$ = "Y") Or (InputHold$ = "N") Or (Len(InputHold$) = 0) + If InputHold$ = "N" Then + ShowMaze = FALSE + ElseIf InputHold$ = "Y" Then + ShowMaze = TRUE + Else + ShowMaze = DEFAULTSHOWMAZE ' Use the default. + End If + +End Sub + +'--------------------------------------------------------------------------- +' GetMonsterDirection +' +' Decides which direction a monster should move given its current position +' and the direction it had been moving. Currently, the direction is chosen +' as follows: Determine how many directions the monster has a choice of +' moving. Based on this, determine a percentage which is the likelihood +' of continuing in the same direction. If the monster isn't to move in the +' same direction, a new direction is chosen (it may be the same direction +' that it was moving before). This routine decides how smart the monsters +' will be. +' +' PARAMETERS: X - X coordinate of the monster +' Y - Y coordinate of the monster +' direction - Current direction of the monster +' movement +'--------------------------------------------------------------------------- +Function GetMonsterDirection (x, y, direction) + + NewDirection = FALSE ' Assume it's not changing direction. + + ' Determine how many directions are available. + AvailableDirections = 4 - NumberOfWalls(x, y) + If (x = ExitX And y = ExitY) Or (x = EntryX And y = EntryY) Then + AvailableDirections = AvailableDirections - 1 + End If + + ' Decides the percentage of whether the monster will continue in the same direction. + ContinueDirection = 1 - (AvailableDirections - 1) * .25 + Select Case direction + Case CTOP + If MazeArray(x, y).top = 0 And y > 1 And Rnd(1) < ContinueDirection Then GetMonsterDirection = direction + Case CBOTTOM + If MazeArray(x, y).Bottom = 0 And y < MazeHeight And Rnd(1) < ContinueDirection Then GetMonsterDirection = direction + Case CLEFT + If MazeArray(x, y).Left = 0 And x > 1 And Rnd(1) < ContinueDirection Then GetMonsterDirection = direction + Case CRIGHT + If MazeArray(x, y).Right = 0 And x < MazeWidth And Rnd(1) < ContinueDirection Then GetMonsterDirection = direction + Case Else + NewDirection = TRUE + End Select + + If Not NewDirection Then Exit Function ' If monster doesn't change direction. + + NewDirection = Int(Rnd(1) * AvailableDirections) + 1 ' Pick a new direction. + Counter = 1 + If MazeArray(x, y).top = 0 And y > 1 Then + If NewDirection = Counter Then GetMonsterDirection = CTOP + Counter = Counter + 1 + End If + If MazeArray(x, y).Bottom = 0 And y < MazeHeight Then + If NewDirection = Counter Then GetMonsterDirection = CBOTTOM + Counter = Counter + 1 + End If + If MazeArray(x, y).Left = 0 And x > 1 Then + If NewDirection = Counter Then GetMonsterDirection = CLEFT + Counter = Counter + 1 + End If + If MazeArray(x, y).Right = 0 And x < MazeWidth Then + If NewDirection = Counter Then GetMonsterDirection = CRIGHT + Counter = Counter + 1 + End If + +End Function + +'--------------------------------------------------------------------------- +' InitVariables +' +' Initializes player keys and game variables. +' +' PARAMETERS: None +'--------------------------------------------------------------------------- +Sub InitVariables + + KEY 15, Chr$(0) + Chr$(25) ' P key (Pause) + KEY 16, Chr$(0) + Chr$(16) ' Q key (Quit) + KEY 21, Chr$(128) + Chr$(72) ' Extended Up key for player 1. + KEY 22, Chr$(128) + Chr$(75) ' Extended Left key for player 1. + KEY 23, Chr$(128) + Chr$(77) ' Extended Right key for player 1. + KEY 24, Chr$(128) + Chr$(80) ' Extended Down key for player 1. + + 'ON KEY (X) indicates what subroutine to jump to when KEY (X) is pressed. + On Key(11) GoSub MovePlayer1Up + On Key(12) GoSub MovePlayer1Left + On Key(13) GoSub MovePlayer1Right + On Key(14) GoSub MovePlayer1Down + On Key(15) GoSub PauseGame ' Pause the game. + On Key(16) GoSub QuitGame ' Quit the game. + On Key(21) GoSub MovePlayer1Up + On Key(22) GoSub MovePlayer1Left + On Key(23) GoSub MovePlayer1Right + On Key(24) GoSub MovePlayer1Down + On Timer(1) GoSub TimerUpdate 'Timer interrupts every second. + + If NumOfPlayers = 2 Then + KEY 17, Chr$(0) + Chr$(UP2) 'Up for player 2. + KEY 18, Chr$(0) + Chr$(DOWN2) 'Down for player 2. + KEY 19, Chr$(0) + Chr$(LEFT2) 'Left for player 2. + KEY 20, Chr$(0) + Chr$(RIGHT2) 'Right for player 2. + On Key(17) GoSub MovePlayer2Up '17 is the UP for player 2. + On Key(18) GoSub MovePlayer2Down '18 is the DOWN key for player 2. + On Key(19) GoSub MovePlayer2Left '19 is the LEFT key for player 2. + On Key(20) GoSub MovePlayer2Right '20 is the RIGHT key for player 2. + End If + + For i = 1 To 2 ' Initialize player variables. + Player(i).Score = 0 + Player(i).TimeLeft = 0 + Player(i).Done = FALSE + Next i + + If ScreenMode = 7 Then ' Set up correct screen colors for mode 7. + MazeColor = MAZECOLOR7 + Player(1).PColor = PLAYER1COLOR7 + Player(2).PColor = PLAYER2COLOR7 + MonsterColor = MONSTERCOLOR7 + GameBkGround = GAMEBKGROUND7 + Else + MazeColor = MAZECOLOR1 ' Set up correct screen colors for mode 1. + Player(1).PColor = PLAYER1COLOR1 + Player(2).PColor = PLAYER2COLOR1 + MonsterColor = MONSTERCOLOR1 + GameBkGround = GAMEBKGROUND1 + End If + GameOver = FALSE + MazesFinished = 1 + MazeTime = DEFAULTTIME + AvailMonsters * 5 - (Level - 1) * 5 ' Number of seconds to finish all mazes. Allow 5 more seconds for each monster. + MonsterUpdateTime = DEFAULTMONSTERTIME + Restore ' Restore and reread DATA statements. + For i = 1 To Level + Read MazeWidth, MazeHeight, PathLength, TurnRate + Next + StartX = (300 / BLOCKSIZE - MazeWidth) / 2 * BLOCKSIZE + 1 + StartY = (180 / BLOCKSIZE - MazeHeight) / 2 * BLOCKSIZE + 1 + +End Sub + +'-------------------------------------------------------------------------- +' Keys +' +' Turns key event-processing on, off, or temporarily stops. +' +' PARAMETERS: onoff - If it's 1 = enable, 2 = disable, 3 = stop. +'-------------------------------------------------------------------------- +Sub Keys (onoff) + + For i = 11 To 24 ' Loop through all defined keys. + Select Case onoff + Case 1 + Key(i) On + Case 2 + Key(i) Off + Case 3 + Key(i) Stop + End Select + Next i + +End Sub + +'---------------------------------------------------------------------------- +' MonsterControl +' +' Controls, checks and updates the monsters. Checks +' to see if any of the players have moved into any of the monsters. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub MonsterControl Static + + If UBound(Monsters) <> AvailMonsters Then ' Initialize monster array. + ReDim Monsters(1 To AvailMonsters) As MonsterType + NumMonsters = 0 + End If + + Keys (3) ' Temporarily stop arrow keys processing. + For i = 1 To NumMonsters ' Check for players hitting monsters. + For j = 1 To NumOfPlayers + If Monsters(i).x = Player(j).x And Monsters(i).y = Player(j).y And Monsters(i).Active Then + Player(j).Dead = TRUE + Play PLAYERDEATHSOUND + DrawPlayer j, GameBkGround + End If + Next j + Next i + Keys (1) ' Enable key event-processing. + + If NumMonsters < AvailMonsters Then ' Add another monster to the maze if there isn't the right number. + NumMonsters = NumMonsters + 1 + If NumMonsters Mod 3 = 1 Then ' Add every third one at the exit of the maze. + Monsters(NumMonsters).x = ExitX + Monsters(NumMonsters).y = ExitY + Else + ' Choose a point along the last 80 percent of the valid path to place the monster. + RandomPlace = Int(Rnd(1) * (StackPointer - StackPointer * .2)) + StackPointer * .2 + Monsters(NumMonsters).x = stackVar(RandomPlace).x + Monsters(NumMonsters).y = stackVar(RandomPlace).y + End If + Monsters(NumMonsters).Active = TRUE + End If + If Timer - LastUpdate! < MonsterUpdateTime Then Exit Sub + LastUpdate! = Timer + + For i = 1 To NumMonsters ' Move the monsters. + If Monsters(i).Active Then + Dir = GetMonsterDirection(Monsters(i).x, Monsters(i).y, Monsters(i).direction) + Monsters(i).direction = Dir + DrawMonster Monsters(i).x, Monsters(i).y, GameBkGround ' Erase current position. + ConvertDirToXY Dir, xmove, ymove + Monsters(i).x = Monsters(i).x + xmove + Monsters(i).y = Monsters(i).y + ymove + DrawMonster Monsters(i).x, Monsters(i).y, MonsterColor + End If + Next i + + Keys (3) ' Temporarily stop arrow keys processing. + For i = 1 To NumMonsters ' Check for monsters hitting players. + For j = 1 To NumOfPlayers + If Monsters(i).x = Player(j).x And Monsters(i).y = Player(j).y And Monsters(i).Active Then + Player(j).Dead = TRUE ' Kill the player + Play PLAYERDEATHSOUND ' Play death melody. + DrawPlayer j, GameBkGround + End If + Next j + Next i + Keys (1) ' Enable key event-processing. + +End Sub + +'--------------------------------------------------------------------------- +' NumberOfWalls +' +' Returns the number of walls in a given block. +' +' PARAMETERS: X - X coordinate of the maze square to be checked +' Y - Y coordinate of the maze square to be checked +'--------------------------------------------------------------------------- +Function NumberOfWalls (x, y) + + NumberOfWalls = MazeArray(x, y).top + MazeArray(x, y).Bottom + MazeArray(x, y).Left + MazeArray(x, y).Right + +End Function + +'-------------------------------------------------------------------------- +' PlayGame +' +' Loops until a given maze is exited or the game is ended. +' The basic flow of the routine is to update all of the various things like +' monsters, scores, and checks to see if somebody was killed. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub PlayGame + + PrintMaze ' Show the maze. + + If ExitY = MazeHeight Then ' Print the exit path markers. + Line (StartX + ExitX * BLOCKSIZE, StartY + ExitY * BLOCKSIZE + BLOCKSIZE - 1)-(StartX + ExitX * BLOCKSIZE, StartY + ExitY * BLOCKSIZE + BLOCKSIZE + 2), 12, BF + Line (StartX + ExitX * BLOCKSIZE + BLOCKSIZE, StartY + ExitY * BLOCKSIZE + BLOCKSIZE - 1)-(StartX + ExitX * BLOCKSIZE + BLOCKSIZE, StartY + ExitY * BLOCKSIZE + BLOCKSIZE + 2), 12, BF + ElseIf ExitY = 1 Then + Line (StartX + ExitX * BLOCKSIZE, StartY + ExitY * BLOCKSIZE - 2)-(StartX + ExitX * BLOCKSIZE, StartY + ExitY * BLOCKSIZE + 1), 12, BF + Line (StartX + ExitX * BLOCKSIZE + BLOCKSIZE, StartY + ExitY * BLOCKSIZE - 2)-(StartX + ExitX * BLOCKSIZE + BLOCKSIZE, StartY + ExitY * BLOCKSIZE + 1), 12, BF + ElseIf ExitX = MazeWidth Then + Line (StartX + ExitX * BLOCKSIZE + BLOCKSIZE - 1, StartY + ExitY * BLOCKSIZE)-(StartX + ExitX * BLOCKSIZE + BLOCKSIZE + 2, StartY + ExitY * BLOCKSIZE), 12, BF + Line (StartX + ExitX * BLOCKSIZE + BLOCKSIZE - 1, StartY + ExitY * BLOCKSIZE + BLOCKSIZE)-(StartX + ExitX * BLOCKSIZE + BLOCKSIZE + 2, StartY + ExitY * BLOCKSIZE + BLOCKSIZE), 12, BF + ElseIf ExitX = 1 Then + Line (StartX + ExitX * BLOCKSIZE - 2, StartY + ExitY * BLOCKSIZE)-(StartX + ExitX * BLOCKSIZE + 1, StartY + ExitY * BLOCKSIZE), 12, BF + Line (StartX + ExitX * BLOCKSIZE - 2, StartY + ExitY * BLOCKSIZE + BLOCKSIZE)-(StartX + ExitX * BLOCKSIZE + 1, StartY + ExitY * BLOCKSIZE + BLOCKSIZE), 12, BF + End If + + For i = 1 To NumOfPlayers ' Initialize needed values. + Player(i).x = EntryX + Player(i).y = EntryY + Player(i).TimeLeft = 0 + Player(i).Done = FALSE + Player(i).Dead = FALSE + DrawPlayer i, Player(i).PColor ' Draw player(s). + Next i + CountDown = MazeTime ' Set time allowed to solve maze. + MazeOver = FALSE + Locate 1, 3: Print "Time left:"; CountDown; ' Display time left. + Locate 1, 31: Print "Maze:"; MazesFinished; ' Display mazes finished. + + If NumOfPlayers = 1 Then ' Different for one or two players. + Line (191, 194)-(194, 197), Player(1).PColor, BF + Locate 25, 15 + Else + Locate 25, 3: Print "Player 2:"; + Line (93, 193)-(98, 198), Player(2).PColor, B + Line (275, 193)-(278, 196), Player(1).PColor, BF + Locate 25, 26 + End If + Print "Player 1:"; + Sound 500, 3 ' 500Hz tone for 3 clock ticks. + Keys (1) ' Enable key event-processing. + Timer On + + ' This is the loop which runs until quit, both players are out, or time's up. + Do + Do: Loop Until InKey$ = "" ' Clear keyboard buffer. + If AvailMonsters > 0 Then MonsterControl + + For i = 1 To NumOfPlayers ' Check to see if any of the players have been killed in the last update. + If Player(i).Dead Then + Player(i).Dead = FALSE + Player(i).x = EntryX + Player(i).y = EntryY + DrawPlayer i, Player(i).PColor + End If + Next i + + If NumOfPlayers = 2 And Player(1).Done And Player(2).Done Then + MazeOver = TRUE + ElseIf NumOfPlayers = 1 And Player(1).Done Then + MazeOver = TRUE + End If + Loop Until MazeOver Or GameOver Or CountDown = 0 + Timer Off + Keys (2) ' Disable key event-processing. + +End Sub + +'-------------------------------------------------------------------------- +' PopMove +' +' Removes the previous path move from the top of the stack and returns it. +' +' PARAMETERS: move - The previous move that will be returned +' from the top of stackVar array +'-------------------------------------------------------------------------- +Sub PopMove (move As MoveType) + + If StackPointer <> 0 Then + move = stackVar(StackPointer) + StackPointer = StackPointer - 1 + Else + MazeError = TRUE + End If + +End Sub + +'--------------------------------------------------------------------------- +' PrintBlock +' +' Prints the walls of a given block in the color specified and uses the +' background color to print walls that have been removed. +' +' PARAMETERS: block - Block to draw +' X - X coordinate of the block to be drawn +' Y - Y coordinate of the block to be drawn +' whatColor - Color of the block to be drawn +'--------------------------------------------------------------------------- +Sub PrintBlock (block As MazeType, x, y, WhatColor) + + ActualX = StartX + x * BLOCKSIZE + ActualY = StartY + y * BLOCKSIZE + If block.top = 1 Then + Line (ActualX, ActualY)-(ActualX + BLOCKSIZE, ActualY), WhatColor + Else + Line (ActualX + 1, ActualY)-(ActualX + BLOCKSIZE - 1, ActualY), GameBkGround + End If + + If block.Bottom = 1 Then + Line (ActualX, ActualY + BLOCKSIZE)-(ActualX + BLOCKSIZE, ActualY + BLOCKSIZE), WhatColor + Else + Line (ActualX + 1, ActualY + BLOCKSIZE)-(ActualX + BLOCKSIZE - 1, ActualY + BLOCKSIZE), GameBkGround + End If + + If block.Left = 1 Then + Line (ActualX, ActualY)-(ActualX, ActualY + BLOCKSIZE), WhatColor + Else + Line (ActualX, ActualY + 1)-(ActualX, ActualY + BLOCKSIZE - 1), GameBkGround + End If + + If block.Right = 1 Then + Line (ActualX + BLOCKSIZE, ActualY)-(ActualX + BLOCKSIZE, ActualY + BLOCKSIZE), WhatColor + Else + Line (ActualX + BLOCKSIZE, ActualY + 1)-(ActualX + BLOCKSIZE, ActualY + BLOCKSIZE - 1), GameBkGround + End If + +End Sub + +'--------------------------------------------------------------------------- +' PrintMaze +' +' Prints out the entire maze or just the outside edge. +' +' PARAMETERS: None +'--------------------------------------------------------------------------- +Sub PrintMaze + + If ShowMaze Then ' Print the whole maze. + For i = 1 To MazeHeight + For j = 1 To MazeWidth + PrintBlock MazeArray(j, i), j, i, MazeColor + Next j + Next i + Else ' Print just the outside edge of the maze. + For i = 1 To MazeWidth + PrintBlock MazeArray(i, 1), i, 1, MazeColor + PrintBlock MazeArray(i, MazeHeight), i, MazeHeight, MazeColor + Next i + For j = 1 To MazeHeight + PrintBlock MazeArray(1, j), 1, j, MazeColor + PrintBlock MazeArray(MazeWidth, j), MazeWidth, j, MazeColor + Next j + End If + +End Sub + +'--------------------------------------------------------------------------- +' ProcessPlayerInput +' +' Processes the player input. +' +' PARAMETERS: i - Player number to be processed +'--------------------------------------------------------------------------- +Sub ProcessPlayerInput (i) + + Keys (3) ' Temporarily stop arrow keys processing. + If PlayerMove(i) <> 0 And Not Player(i).Done And Not Player(i).Dead Then 'Only if player input and not done + + ValMove = FALSE ' Check for valid direction. + Select Case PlayerMove(i) + Case CTOP + If MazeArray(Player(i).x, Player(i).y).top = 0 And Player(i).y > 1 Then ValMove = TRUE + Case CBOTTOM + If MazeArray(Player(i).x, Player(i).y).Bottom = 0 And Player(i).y < MazeHeight Then ValMove = TRUE + Case CLEFT + If MazeArray(Player(i).x, Player(i).y).Left = 0 And Player(i).x > 1 Then ValMove = TRUE + Case CRIGHT + If MazeArray(Player(i).x, Player(i).y).Right = 0 And Player(i).x < MazeWidth Then ValMove = TRUE + End Select + + If ValMove Then + UpdatePosition PlayerMove(i), i + Else + Select Case PlayerMove(i) ' If invalid, check maze exit + Case CTOP + If MazeArray(Player(i).x, Player(i).y).top = 0 And Player(i).y = 1 Then ValMove = TRUE + Case CBOTTOM + If MazeArray(Player(i).x, Player(i).y).Bottom = 0 And Player(i).y = MazeHeight Then ValMove = TRUE + Case CLEFT + If MazeArray(Player(i).x, Player(i).y).Left = 0 And Player(i).x = 1 Then ValMove = TRUE + Case CRIGHT + If MazeArray(Player(i).x, Player(i).y).Right = 0 And Player(i).x = MazeWidth Then ValMove = TRUE + End Select + + If Player(i).x <> ExitX Or Player(i).y <> ExitY Then ValMove = FALSE + + If ValMove Then + Player(i).Done = TRUE + Player(i).TimeLeft = CountDown + UpdatePosition PlayerMove(i), i + Play PLAYEROUTSOUND ' Play the melody for when the player exits the maze. + + End If + End If + PlayerMove(i) = 0 ' Clear player move. + End If + Keys (1) ' Enable key event-processing. + +End Sub + +'------------------------------------------------------------------------- +' UpdatePosition +' +' Updates the player's coordinates and moves the player. Also draws the +' blocks of the maze around the player. This allows the player +' to see one space in any direction when travelling through an invisible +' maze. +' +' PARAMETERS: Dir - Direction of travel +' Plr - Player number whose position is being shown +'------------------------------------------------------------------------- +Sub UpdatePosition (Dir, Plr) + + DrawPlayer Plr, GameBkGround ' Draw player. + ConvertDirToXY Dir, xmove, ymove + Player(Plr).x = Player(Plr).x + xmove + Player(Plr).y = Player(Plr).y + ymove + + If Not ShowMaze Then + If Player(Plr).x >= 1 And Player(Plr).x <= MazeWidth And Player(Plr).y >= 1 And Player(Plr).y <= MazeHeight Then + PrintBlock MazeArray(Player(Plr).x, Player(Plr).y), Player(Plr).x, Player(Plr).y, MazeColor + If Player(Plr).x - 1 > 0 Then PrintBlock MazeArray(Player(Plr).x - 1, Player(Plr).y), (Player(Plr).x - 1), Player(Plr).y, MazeColor + If Player(Plr).x + 1 <= MazeWidth Then PrintBlock MazeArray(Player(Plr).x + 1, Player(Plr).y), (Player(Plr).x + 1), Player(Plr).y, MazeColor + If Player(Plr).y - 1 > 0 Then PrintBlock MazeArray(Player(Plr).x, Player(Plr).y - 1), Player(Plr).x, (Player(Plr).y - 1), MazeColor + If Player(Plr).y + 1 <= MazeHeight Then PrintBlock MazeArray(Player(Plr).x, Player(Plr).y + 1), Player(Plr).x, (Player(Plr).y + 1), MazeColor + End If + End If + DrawPlayer Plr, Player(Plr).PColor ' Draw player. + +End Sub + +'------------------------------------------------------------------------- +' ValidBustDir +' +' Returns the direction of a wall to remove. Ensures that no +' walls on the edge of the maze are broken out. +' +' PARAMETERS: X - X coordinate of the block being checked for +' removal +' Y - Y coordinate of the block being checked for +' removal +'------------------------------------------------------------------------- +Function ValidBustDir (x, y) + + Dim BreakableWalls As MazeType + BreakableWalls = MazeArray(x, y) + If x = 1 Then BreakableWalls.Left = 0 + If x = MazeWidth Then BreakableWalls.Right = 0 + If y = 1 Then BreakableWalls.top = 0 + If y = MazeHeight Then BreakableWalls.Bottom = 0 + + AvailableMoves = BreakableWalls.Left + BreakableWalls.Right + BreakableWalls.top + BreakableWalls.Bottom + NewDirection = Int(Rnd(1) * AvailableMoves) + 1 + Counter = 1 + If BreakableWalls.top = 1 Then + If NewDirection = Counter Then ValidBustDir = CTOP + Counter = Counter + 1 + End If + If BreakableWalls.Bottom = 1 Then + If NewDirection = Counter Then ValidBustDir = CBOTTOM + Counter = Counter + 1 + End If + If BreakableWalls.Left = 1 Then + If NewDirection = Counter Then ValidBustDir = CLEFT + Counter = Counter + 1 + End If + If BreakableWalls.Right = 1 Then + If NewDirection = Counter Then ValidBustDir = CRIGHT + Counter = Counter + 1 + End If + +End Function + diff --git a/samples/qships/img/screenshot.png b/samples/qships/img/screenshot.png new file mode 100644 index 00000000..4a6b7349 Binary files /dev/null and b/samples/qships/img/screenshot.png differ diff --git a/samples/qships/index.md b/samples/qships/index.md new file mode 100644 index 00000000..11f2b4da --- /dev/null +++ b/samples/qships/index.md @@ -0,0 +1,21 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QSHIPS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Turn-based artillery game by Microsoft. +``` + +### File(s) + +* [qships.bas](src/qships.bas) + +🔗 [game](../game.md), [artillery](../artillery.md) diff --git a/samples/qships/src/qships.bas b/samples/qships/src/qships.bas new file mode 100644 index 00000000..95a725c0 --- /dev/null +++ b/samples/qships/src/qships.bas @@ -0,0 +1,1373 @@ +' QSHIPS.BAS +' +' Copyright (C) 1990 Microsoft Corporation. All Rights Reserved. +' +' QShips puts two players in a ship-to-ship cannon duel. Adjust your cannon +' fire to the correct angle and velocity to sink your opponent. An island, +' the shifting wind, and a moving opponent make each shot a new challenge. +' +' To run this game, press Shift+F5. +' +' To exit this program, press Alt, F, X. +' +' To get help on a BASIC keyword, move the cursor to the keyword and press +' F1 or click the right mouse button. +' +' To view suggestions on changing this game, press Page Down. +' +' +' Suggested Changes +' ----------------- +' +' There are many ways that you can modify this BASIC game. The CONST +' statements below these comments can be modified to change the following: +' Size of the island +' Number of trees on the island +' Strength of gravity that affects your shots +' Default number of hits needed to win the game. +' Maximum velocity your cannons can fire. +' Sounds of the cannon firing and the explosions +' +' On the right side of each CONST statement, there is a comment that tells +' you what it does and how big or small you can set the value. +' +' On your own, you can also add exciting sound and visual effects or make +' any other changes that your imagination can dream up. By reading the +' Learn BASIC Now book, you'll learn the techniques that will enable you +' to fully customize this game and to create games of your own. +' +' If the game won't run after you have changed it, you can exit without +' saving your changes by pressing Alt, F, X and choosing NO. +' +' If you do want to save your changes, press Alt, F, A and enter a filename +' for saving your version of the program. Before saving your changes, +' however, make sure the program still works by running the program and +' verifying that your changes produce the desired results. Also, always +' be sure to keep a backup of the original program. +' +DefInt A-Z + +Const ISLLENGTH = 80 ' Length of the island. Range is 40 to 240. If you make ISLLENGTH too large there will not be any water for your ships! +Const NUMTREES = 3 ' Number of trees on the island. Range 0 to 10. If you make this large (or make ISLLENGTH small) there may not be enough room on the island for all the trees. +Const GRAVITY = 9.8 ' Gravity. Range is 1.0 to 50.0. The higher or lower you go, the more difficult to hit your opponent. +Const INITNUMGAMES = 3 ' Default number of hits needed to win the game. Range from 1 to 99. +Const MAXVELOCITY = 150 ' Maximum velocity of cannon. Range 50 to 300 for best results. You may need to increase this if you have also increased GRAVITY above 9.8. +' The following sound constants are used by the PLAY command to +' produce music during the game. To change the sounds you hear, change +' these constants. Refer to the online help for PLAY for the correct format. +' To completely remove sound from the game set the constants equal to null. +' For example: INTROSOUND = "" +Const INTROSOUND = "T160O1L8CDEDCDL4ECC" ' Sound played at the start of the game. +Const CANNONFIRESOUND = "MBo0L32A-L64CL16BL64A+" ' Sound made when a cannon is fired. +Const CANNONHITSOUND = "MBO0L32EFGEFDC" ' Sound made when a cannon ball hits an object. +Const SHIPEXPLOSIONSOUND = "MBO0L16EFGEFDC" ' Sound made when a ship is exploded. + +' The following are general constants and their values should not be changed. +Const TRUE = -1 +Const FALSE = Not TRUE +Const SHOOTSELF = 1 ' Used to indicate that a player shot him/her self. +Const TREEWIDTH = 16 ' Width of the tree picture (do NOT change). +Const SHIPWIDTH = 16 ' Width of the Ship picture (do NOT change). +Const MOVESHIPBY = 16 ' Distance to move the ship per key press. +Const UP = 0 + 72 ' Two bytes representing Up arrow key. Elevate cannon by 1 degree. +Const DOWN = 0 + 80 ' Two bytes representing Down arrow key. Depress cannon by 1. +Const LEFT = 0 + 75 ' Two bytes representing Left arrow key. Move ship left / speed change. +Const RIGHT = 0 + 77 ' Two bytes representing Right arrow key. Move ship right / speed change. +Const ENTERKEY = 13 ' Single byte ASCII code for Carriage Return (Enter key). Confirm selections. +Const BACKGROUNDCOLOR = 0 ' Black. +Const WATERCOLOR = 1 ' Palette 1, color 1 cyan. +Const ISLANDCOLOR = 2 ' Palette 1, color 2 purple. +Const OBJECTCOLOR = 3 ' Palette 1, color 3 white. + +'Declarations of all the FUNCTION and SUB procedures called in this program. +DECLARE FUNCTION MoveShip (PlayerNum, SeaLevel()) +DECLARE FUNCTION SinkShip (x, y) +DECLARE FUNCTION PlotShot (startX, startY, angle#, velocity) +DECLARE FUNCTION GetPlayerCommand (PlayerNum, SeaLevel()) +DECLARE SUB Center (text$, row) +DECLARE SUB ClearArea (startRow, startCol, endRow, endCol) +DECLARE SUB CyclePalette () +DECLARE SUB DisplayChanges () +DECLARE SUB DisplayGameTitle () +DECLARE SUB DisplayIntro () +DECLARE SUB DrawIsland (SeaLevel()) +DECLARE SUB DrawWaves (offset, hmult, tmult, SeaLevel()) +DECLARE SUB DrawWind () +DECLARE SUB GetGameOptions () +DECLARE SUB GetShotParams (PlayerNum, NewAngle#, NewVelocity) +DECLARE SUB InitializeVariables () +DECLARE SUB MakeBattleField (SeaLevel()) +DECLARE SUB PlaceShips (SeaLevel()) +DECLARE SUB PlayGame () +DECLARE SUB PlotAngle (col, angle#, PlayerNum) +DECLARE SUB PlotBattleField (SeaLevel()) +DECLARE SUB PlotVelocity (col, velocity, PlayerNum) +DECLARE SUB CannonHit (x, y, theColor) +DECLARE SUB UpdateScores (Record(), PlayerNum, Results) + +' SHARED (global) variable declarations for use in this program. +Dim Shared ShipX(1 To 2) As Integer ' x coordinate for ships. +Dim Shared ShipY(1 To 2) As Integer ' y coordinate for ships. +Dim Shared TotalShots(1 To 2) As Integer ' Total shots fired for each player. +Dim Shared TotalWins(1 To 2) As Integer ' Total points for each player. +Dim Shared TheAngle#(1 To 2) ' Angle each player used in last shot. +Dim Shared TheVelocity(1 To 2) As Integer ' Velocity each player used in last shot. +Dim Shared Player$(1 To 2) ' Player name of each player. +Dim Shared Pi# ' Pi (3.1415....) used in calculations +Dim Shared TreePic1(1 To 20) As Integer ' Holds the bottom of the palm tree picture. +Dim Shared TreePic2(1 To 36) As Integer ' Holds the top of the palm tree picture. +Dim Shared ShipPic(1 To 36) As Integer ' Holds the ship picture. +Dim Shared Shot&(1 To 2) ' Holds the cannon ball picture. +Dim Shared ScreenHeight As Integer ' Screen height in pixels. +Dim Shared ScreenWidth As Integer ' Screen width in pixels. +Dim Shared NumGames As Integer ' Number of games to play. +Dim Shared Wind As Integer ' Wind speed; used in shot calculations. +Dim Shared ScreenMode As Integer ' BASIC screen ScreenMode number. +Dim Shared MaxCol As Integer ' Screen maximum number of columns. +Dim Shared IStart As Integer ' Island starting x coordinate. +Dim Shared IEnd As Integer ' Island ending x coordinate. +Dim Shared Delay As Integer ' Delay factor for explosions +' Module-level variables (not known in procedures) +Dim KeyFlags As Integer +Dim BadMode As Integer + +' The values below are loaded into arrays, then used in graphics PUT +' statement to display pictures of ships, trees, cannon shots. +' DO NOT CHANGE THE VALUE OF THIS DATA +ShipPicData: +Data 32,16,0,192,0,192,768,192,3840,192,16128,195 +Data -256,195,-253,-16189,-241,-3901,-193,-829,-1,-61,0,195 +Data 0,195,-21846,-21846,-21926,-23126,-21931,21930,23125,21925,0,0 + +TreePic1Data: +Data 16,16,-32760,-32760,-32758,-32760,-32760,-32758,-32760,-32760 +Data -32758,-32760,-32760,-32758,-24024,-30584,8226,-30072,0,0 + +TreePic2Data: +Data 32,16,0,2,0,-32758,0,10272,-32766,2720,-24566,640 +Data 10792,-32766,10912,-24566,2688,10280,2176,10400,512,2688,2562,512 +Data -30198,522,-24024,-32598,10784,-24416,2208,10368,2176,640,0,0 + +ShotData: +Data 196614,3210288& + + +' The module-level code of the QSHIPS program begins here! + +' Use error trap to test for Screen Mode 1 (320x200 graphics, 40-column text) +On Error GoTo ScreenError ' If mode 1 not available, BadMode +BadMode = FALSE ' is set TRUE in error handler. Other- +ScreenMode = 1 ' wise, screen mode 1 is set. +Screen ScreenMode ' Attempt to go into SCREEN 1. + +On Error GoTo 0 ' Turn off error trapping for now. + +If BadMode = TRUE Then ' If mode 1 wasn't found... + Cls + Locate 11, 13 + Print "CGA, EGA Color, or VGA graphics required to run QSHIPS.BAS" +Else ' Make sure NUM LOCK isn't on. + Def Seg = 0 ' Set segment to low memory + KeyFlags = Peek(1047) ' Check address of NUM LOCK status + If KeyFlags And 32 Then ' If it was turned on, + Poke 1047, KeyFlags And 223 ' Turn it off + End If + Def Seg ' Reset segment to DGROUP (default data segment) + + DisplayIntro ' Display game rules. + GetGameOptions ' Get player's names and length of game. + InitializeVariables ' Initialize starting variables. + PlayGame + DisplayChanges ' Reset normal screen mode and end. + + If KeyFlags And 32 Then ' Restore the previous flag settings. + Def Seg = 0 + Poke 1047, KeyFlags Or 32 + Def Seg + End If +End If + +End + + +ScreenError: ' Screen mode error handler starts here. +BadMode = TRUE ' Set the flag indicating there was an error. +Resume Next ' Ignore the error, by executing next statement. + +'-------------------------------------------------------------------------- +' CannonHit +' +' A cannon shot has hit the water, island, or a ship. What has been +' hit is determined; if the shot hit a solid object there is a small +' explosion, then water / debris is thrown into the air. +' +' PARAMETERS: x - x coordinate of the hit +' y - y coordinate of the hit +' theColor - Indicates what has been hit +'-------------------------------------------------------------------------- +Sub CannonHit (x, y, theColor) + + fragments = 11 ' Assume shell hit water - splash. + Select Case Delay ' Base number of cycles in explosion + Case 500: cycles = 8 ' on machine speed + Case 200: cycles = 5 + Case 50: cycles = 3 + End Select + offset = ScreenHeight / 10 + + If theColor <> WATERCOLOR Then ' If shell hit solid object - explode. + Play CANNONHITSOUND + radius = ScreenHeight / 70 ' Set up and create explosion illusion. + increment# = 1.2 + For Counter# = 0 To radius Step increment# + Circle (x, y), Counter#, ISLANDCOLOR + Next Counter# + For Counter# = radius To 0 Step (-1 * increment#) ' Repaint with the + Circle (x, y), Counter#, BACKGROUNDCOLOR ' object now missing. + Next Counter# + End If + + 'Throw water or debris into the air. + Dim xpos(1 To fragments), ypos(1 To fragments) + radius# = .5 + Play CANNONHITSOUND + For j = -3 To 3 Step 3 + Line (x, y)-(x + j, y - offset), theColor ' Create debris + Next j + + ' water / debris flies around for a short time + For kt = 1 To cycles + For i = 1 To fragments + xpos(i) = x + (((10 * Rnd) - 5) / 5) * (offset / 2) + (2 * kt) / cycles + ypos(i) = y - (Rnd + 1) * offset + (3 * kt) / cycles + Next i + For i = 1 To fragments + Circle (xpos(i), ypos(i)), radius#, theColor + Next i + For j = -3 To 3 Step 3 + Line (x, y)-(x + j, y - offset), BACKGROUNDCOLOR + Next j + For i = 1 To fragments + Circle (xpos(i), ypos(i)), radius#, BACKGROUNDCOLOR + Next i + Next kt + +End Sub + +'---------------------------------------------------------------------------- +' Center +' +' Centers the given text string on the indicated row. +' +' PARAMETERS: text$ - The text to center +' row - The screen row to print on +'---------------------------------------------------------------------------- +Sub Center (text$, row) + + Locate row%, 40 - Len(text$) \ 2 + 1 'Calculate column to start at. + Print text$; 'Print the string. + +End Sub + +'---------------------------------------------------------------------------- +' ClearArea +' +' Prints spaces over the a rectangular area of the screen to +' clear any text that may be in that area. +' +' PARAMETERS: startRow - Top row of rectangle to clear +' startCol - Left side +' endRow - Bottom row, must be <= startRow +' endCol - Right side, must be <= endCol +'---------------------------------------------------------------------------- +Sub ClearArea (startRow, startCol, endRow, endCol) + + For row = startRow To endRow + Locate row, startCol ' Set spot for printing to + Print Space$(endCol - startCol + 1) ' begin, then print blank spaces. + Next row + +End Sub + +'-------------------------------------------------------------------------- +' CyclePalette +' +' Changes the screen colors to make the flashing effect when +' a cannon ball explodes. If you wish you can try different +' colors to change the way the flashing effect looks. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub CyclePalette + + ' If you wish to change the colors used by the screen flash, change only + ' the first argument (the foreground) in the COLOR statements below - + ' leave the second argument (background) as "ISLANDCOLOR". + Color 12, ISLANDCOLOR + For g! = 1 To Delay: Next g! 'delay loop + Color 14, ISLANDCOLOR + For g! = 1 To Delay: Next g! 'delay loop + Color 0, 1 'Return the screen colors to normal. + +End Sub + +'---------------------------------------------------------------------------- +' DisplayChanges +' +' Displays game characteristics that you can easily change via +' CONST and DATA statements. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayChanges + + DisplayGameTitle 'Print game title. + + Color 7 + Center "The following game characteristics can be easily changed from", 5 + Center "within the QuickBASIC Interpreter. To change the values of ", 6 + Center "these characteristics, locate the corresponding CONST or DATA", 7 + Center "statements in the source code and change their values, then ", 8 + Center "restart the program (press Shift + F5). ", 9 + Color 15 + Center "Size of the island ", 11 + Center "Number of trees on the island ", 12 + Center "Strength of gravity that affects your shots ", 13 + Center "Maximum velocity your cannons can fire ", 14 + Center "Default number of hits needed to win the game ", 15 + Center "Sounds of the cannon firing and the explosions", 16 + Color 7 + Center "The CONST statements and instructions on changing them are ", 18 + Center "located at the beginning of the main program. ", 19 + + Do While InKey$ = "": Loop 'Wait for any keypress. + Cls + +End Sub + +'---------------------------------------------------------------------------- +' DisplayGameTitle +' +' Displays game title and draws a screen border for use in the +' introduction and suggested changes screens. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayGameTitle + + Screen 0 ' Set the screen to a normal 80x25 text mode, clear it and add blue background. + Width 80, 25 + Color 4, 0 + Cls + + ' Draw outline around screen with extended ASCII characters. + Locate 1, 2 + Print Chr$(201); String$(76, 205); Chr$(187); ' top border + For x% = 2 To 24 ' left and right borders + Locate x%, 2 + Print Chr$(186); Tab(79); Chr$(186); + Next x% + Locate 25, 2 + Print Chr$(200); String$(76, 205); Chr$(188); 'bottom border + + 'Print game title centered at top of screen + Color 0, 4 + Center " Microsoft ", 1 + Center " Q S H I P S ", 2 + Center " Press any key to continue ", 25 + Color 7, 0 + +End Sub + +'---------------------------------------------------------------------------- +' DisplayIntro +' +' Displays game introduction screen which explains game objective and +' game keyboard controls +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayIntro + + DisplayGameTitle ' Display game title. + + Color 7 ' Print game introduction and objectives. + Center "Copyright (C) 1990 Microsoft Corporation. All Rights Reserved.", 4 + Center "Each player's mission is to destroy the opponent's ship by varying the ", 6 + Center "angle and speed of your cannon, taking into account wind speed and terrain.", 7 + Center "The wind speed is shown by a directional arrow on the playing field, its ", 8 + Center "length relative to its strength. With each turn, you may EITHER move your ", 9 + Center "ship to avoid your opponent's cannon fire OR shoot your cannon. ", 10 + + Color 4 'Print game controls. + Center String$(74, 196), 12 + Color 7 + Center " Game Controls ", 12 + Center " General Shooting Cannon Moving Ship ", 13 + Center "S - Shoot cannon " + Chr$(24) + " - Increase cannon angle " + Chr$(27) + " - Move ship left ", 15 + Center "M - Move ship " + Chr$(25) + " - Decrease cannon angle " + Chr$(26) + " - Move ship right", 16 + Center "Q - Quit game " + Chr$(26) + " - Increase cannon velocity ", 17 + Center " for Player 1, decrease ", 18 + Center " cannon velocity for Player 2 ", 19 + Center " " + Chr$(27) + " - Decrease cannon velocity ", 20 + Center " for Player 1, increase ", 21 + Center " cannon velocity for Player 2 ", 22 + Center " Enter - Fire cannon ", 23 + + Play INTROSOUND 'Play melody while waiting to continue. + + Do 'Wait for key press before continuing + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Q" Then 'Allow player to quit now + Cls + Locate 10, 30: Print "Really quit? (Y/N)"; + Do + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Y" Then + Cls + End + End If + End If + +End Sub + +'-------------------------------------------------------------------------- +' DrawIsland +' +' Draws an island between the two ships. The island is made +' by drawing increasingly taller lines (based on the sea level) +' for the left side of the island, and then increasingly shorter +' lines for the right side. Trees are then placed. Note that the +' seaLevel() array was loaded with values at the start of PlayGame. +' +' PARAMETERS: seaLevel() - Water level at each point +'-------------------------------------------------------------------------- +Sub DrawIsland (SeaLevel()) + + ' Calculate a random-sized island (iScale#), and place it between the ships (iStart, iEnd). + iScale# = (Int(((SeaLevel(0) - 60) / 3) * Rnd) + Int((SeaLevel(0) - 60) / 3)) / (ISLLENGTH / 2) + IStart = ((ShipX(2) - (ShipX(1) + SHIPWIDTH)) - ISLLENGTH - 6) * Rnd + ShipX(1) + SHIPWIDTH + 3 + IEnd = IStart + ISLLENGTH + + ' Draw the island by extending lines from the water level (seaLevel()) sloping up on the left side and down on the right. + For Counter = IStart To IEnd + If Counter < (IStart + IEnd) / 2 Then + yoffset = iScale# * (Counter - IStart) + Else + yoffset = iScale# * (IEnd - Counter) + End If + y1 = SeaLevel(Counter) + yoffset + y2 = SeaLevel(Counter) - yoffset + Line (Counter, y1)-(Counter, y2), ISLANDCOLOR + Next Counter + + ' Place the trees. Determine position depending on the island size (iScale#). The pictures that make up the tree image are + ' held in the global arrays treePic1() and treePic2(). These arrays were loaded with treePic DATA in the InitializeVariables + ' SUB procedure. A BASIC graphics PUT statement is used to draw the tree pictures. + For Counter = 1 To NUMTREES + xpos = IStart + 6 + (Counter - 1) * (ISLLENGTH / NUMTREES) + subtot# = 0: trend = 10 + For j = xpos To xpos + trend + If j < (IStart + IEnd) / 2 Then + yoffset = iScale# * (j - IStart) + Else + yoffset = iScale# * (IEnd - j) + End If + subtot# = subtot# + SeaLevel(j) - yoffset + Next j + ypos = subtot# / (trend + 1) - 28 + Put (xpos, ypos), TreePic2(), PSet + Put (xpos + 4, ypos + TREEWIDTH), TreePic1(), PSet + Next Counter + +End Sub + +'-------------------------------------------------------------------------- +' DrawWaves +' +' Uses the BASIC CIRCLE statement to draw arcs (partial circles) +' to make waves in the water. +' +' PARAMETERS: offset - Increasing value move wave left. +' hmult - Increasing value moves wave down. +' tmult - Increasing value moves wave up. +' seaLevel() - Ocean level at each point. +'-------------------------------------------------------------------------- +Sub DrawWaves (offset, hmult, tmult, SeaLevel()) + + radius = ScreenWidth / 80 ' Size of a wave + + ' Move across the screen from right to left drawing waves. + For i = ScreenWidth / offset To ScreenWidth - ScreenWidth / offset Step ScreenWidth / 5 + + ' Calculate vertical position of wave and draw the arcs to create it. + ypos = (hmult * ScreenHeight + tmult * SeaLevel(i)) / (hmult + tmult) + Circle (i, ypos), radius, ISLANDCOLOR, 5 * Pi# / 4, 2 * Pi# + Circle (i + 2 * radius, ypos), radius, ISLANDCOLOR, Pi#, Pi# * 2 + Circle (i + 4 * radius, ypos), radius, ISLANDCOLOR, Pi#, 7 * Pi# / 4 + + Next i + +End Sub + +'-------------------------------------------------------------------------- +' DrawWind +' +' Draws an arrow in the direction of the wind. The length of +' the arrow depends on the strength of the wind. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub DrawWind + + WindTmp = Wind + If WindTmp = 0 Then WindTmp = 1 ' Ensure that Wind won't ever be zero. + + WindLineLength = WindTmp * (ScreenWidth / 80) ' Calculate the length of the arrow. + x1 = ScreenWidth / 2 - WindLineLength / 2 + x2 = x1 + WindLineLength + ' SGN(WindTmp) returns -1 if WindTmp is negative, 1 if it is positive. + ArrowDir = -2 * Sgn(WindTmp) ' Figure out the arrowhead direction. + Line (x1, 16)-(x2, 16), ISLANDCOLOR ' Draw the wind arrow line. + Line (x2, 16)-(x2 + ArrowDir, 14), ISLANDCOLOR + Line (x2, 16)-(x2 + ArrowDir, 18), ISLANDCOLOR + +End Sub + +'-------------------------------------------------------------------------- +' GetGameOptions +' +' Prompts for and saves the Player names for each player and +' the number of points to play to. GetGameOptions does not call +' any other SUB or FUNCTION procedures. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub GetGameOptions + + Screen 0 + Width 80 + Cls + + ' player1$ defaults to "Player 1" + Color 7: Center "Default is 'Player 1'", 9 + Color 15: Locate 8, 30 + Line Input "Name of Player 1: "; Player$(1) + If Player$(1) = "" Then + Player$(1) = "Player 1" + Else + Player$(1) = Left$(Player$(1), 10) + End If + + ' player2$ defaults to "Player 2" + Color 7: Center "Default is 'Player 2'", 12 + Color 15: Locate 11, 30 + Line Input "Name of Player 2: "; Player$(2) + If Player$(2) = "" Then + Player$(2) = "Player 2" + Else + Player$(2) = Left$(Player$(2), 10) + End If + + ' Number of games defaults to INITNUMGAMES + Color 7: Center "Default is" + Str$(INITNUMGAMES), 15 + Do + Color 15: Locate 14, 27: Print Space$(50); + Locate 14, 27 + Input "Play to how many points"; NumHold$ + NumGames = Val(Left$(NumHold$, 2)) + Loop Until NumGames > 0 And Len(NumHold$) < 3 Or Len(NumHold$) = 0 + If NumGames = 0 Then NumGames = INITNUMGAMES + + Color 7 ' Restore color + +End Sub + +'-------------------------------------------------------------------------- +' GetPlayerCommand +' +' Displays a menu on the active players side of the screen and gets the +' player's selection. If the selection is a valid menu option, then +' the appropriate SUB is called to handle the command. If the choice +' is invalid the SUB InvalidKeyHit is called. This process is repeated +' until the player actually shoots, moves, or quits the game. +' +' PARAMETERS: playerNum - The active player +' seaLevel() - Passed on to other SUB procedures +'-------------------------------------------------------------------------- +Function GetPlayerCommand (PlayerNum, SeaLevel()) + + ' As long as the player has not shot or moved he/she can keep selecting. + finished = FALSE + Do: Loop While InKey$ <> "" ' Flush keyboard buffer before turn + + xpos = ShipX(PlayerNum) ' Determine this player's ship location. + ypos = ShipY(PlayerNum) + If PlayerNum = 1 Then ' Determine where to put the menu + MenuCol = 3 ' depending on whose turn it is. + startCol = 30 + endCol = 40 + Else + MenuCol = 25 + startCol = 1 + endCol = 24 + End If + + ' If the player fires the shot "starts" from above his/her ship, so the + ' yShotPosition is calculated to enforce this. + YShotPos = ypos - 3 + + Do While Not finished + ' Print the player's score and label the wind indicator. + Locate 1, 1: Print Player$(1) + Locate 1, (MaxCol - Len(Player$(2))): Print Player$(2) + Locate 1, 19: Print "Wind"; + Locate 2, 1: Print "Hits:"; TotalWins(1); + Locate 2, MaxCol - 6 - Len(Str$(TotalWins(2))): Print "Hits:"; TotalWins(2); + + Call DrawWind ' Draw the wind indicator. + + ' Clear the area where the menu will appear and print the menu with a box. + Call ClearArea(4, MenuCol, 8, MenuCol + 12) + Line (MenuCol * 8 - 2, 28)-(MenuCol * 8 + 87, 60), , B + Locate 5, MenuCol + 2: Print "S = Shoot" + Locate 6, MenuCol + 2: Print "M = Move " + Locate 7, MenuCol + 2: Print "Q = Quit " + + Do ' Get the player's selection. + kbd$ = UCase$(InKey$) + Loop Until kbd$ <> "" + Call ClearArea(4, MenuCol, 8, MenuCol + 12) + + Select Case kbd$ + Case "Q" ' Q = QUIT + Sound 600, .5 ' Make sure the player really wants to quit. + Sound 800, .5 + Locate 5, 11: Print "Really quit? (Y/N)"; + Do + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Y" Then ' If players want to quit, then + Call DisplayChanges ' remind them of changes they can + End ' make to the program. + Else + Call ClearArea(5, 1, 5, 40) + End If + + Case "M" ' M = MOVE + If MoveShip(PlayerNum, SeaLevel()) Then + finished = TRUE ' Player moved - his/her turn is over. + GetPlayerCommand = FALSE + End If + + Case "S", Chr$(ENTERKEY) ' S = SHOOT (or Enter key) + ' Get desired angle & velocity. + Call GetShotParams(PlayerNum, angle#, velocity) + + ' Player 2 is actually shooting from the other direction so we need to turn the angle 180 degrees. + If PlayerNum = 2 Then angle# = 180 - angle# + + ' Clear the text on the upper area of the screen so the cannon shot can go off the top of the screen. + View Print 1 To 7 ' Set text viewport to rows 1-7. + Cls 2 ' Clear the text viewport. + View Print ' Reset text viewport to whole screen. + + ' Plot the shot on the screen. + playerHit = PlotShot(xpos, YShotPos, angle#, velocity) + TotalShots(PlayerNum) = TotalShots(PlayerNum) + 1 + + ' Determine what happened by the value returned from PlotShot FUNCTION.. + If playerHit = PlayerNum Then + GetPlayerCommand = SHOOTSELF ' Player shot himself/herself. + ElseIf playerHit <> 0 Then + GetPlayerCommand = TRUE ' Play shot opponent. + Else + GetPlayerCommand = FALSE ' Player missed. + End If + finished = TRUE ' Player has fired - his/her turn is over. + Case Else ' Some other key was pressed. + Beep + End Select + Loop + +End Function + +'-------------------------------------------------------------------------- +' GetShotParams +' +' Prompts for and records the angle and velocity the player wishes to use +' for shooting his/her cannon. The main loop keeps checking for and +' recording player changes to angle and velocity until the player hits +' Enter to fire the cannon. If the player hits an invalid key then a +' message is displayed about how to get help. Help will be displayed if +' the player enters "h" or "H". +' +' PARAMETERS: playerNum - Which player is firing +' newAngle# - The new angle to use +' newVelocity - The new shot speed to use +'-------------------------------------------------------------------------- +Sub GetShotParams (PlayerNum, NewAngle#, NewVelocity) + + 'Clear the upper left and right corners of the screen + If PlayerNum = 1 Then + locateCol = 1 + locateCol2 = 26 + ArrowAffect = 1 ' Direction wind arrow will point and + Call ClearArea(2, 1, 6, 16) ' direction that velocity meter will extend. + Call ClearArea(1, 26, 6, 40) + Else + locateCol = 30 + locateCol2 = 1 + ArrowAffect = -1 + Call ClearArea(1, 1, 6, 16) + Call ClearArea(2, 26, 6, 40) + End If + + ' Display the shooting instructions in the upper corner on the non-firing players side of the screen. + Locate 2, locateCol2: Print "Change angle " + Locate 3, locateCol2: Print "with  and ." + Locate 4, locateCol2: Print "Change speed " + Locate 5, locateCol2: Print "with " + Chr$(26) + " and " + Chr$(27) + "." + Locate 6, locateCol2: Print "ENTER to fire." + + ' Show the angle and velocity of the players last shot. The angle and velocity defaults to 45 degrees and velocity of 50 meters/ second if the player has not fired yet. + Call PlotAngle(locateCol, TheAngle#(PlayerNum), PlayerNum) + Call PlotVelocity(locateCol, TheVelocity(PlayerNum), PlayerNum) + + ' Get the players input. Either change cannon angle using the Up and + ' Down arrows, change the shot velocity using the Right and Left arrow + ' or fire the cannon with the Enter key. Note that the left + ' and right arrow key affect is reversed for the second player. + Do While Not finished + Do ' Get key pressed. + kbd$ = InKey$ + Loop While kbd$ = "" + + cursorkey = Asc(Right$(kbd$, 1)) + Select Case cursorkey + Case LEFT, RIGHT ' Change the velocity level indicator. + If cursorkey = RIGHT Then + increment = 1 * ArrowAffect + Else + increment = -1 * ArrowAffect + End If + If (increment < 0 And TheVelocity(PlayerNum) > 0) Or (increment > 0 And TheVelocity(PlayerNum) < MAXVELOCITY) Then + TheVelocity(PlayerNum) = TheVelocity(PlayerNum) + increment + Call PlotVelocity(locateCol, TheVelocity(PlayerNum), PlayerNum) + Else + Beep + Do + temp$ = InKey$ + Loop While temp$ <> "" + End If + Case UP, DOWN ' Change angle in trajectory display. + If cursorkey = UP Then + increment = 1 + Else + increment = -1 + End If + If (increment < 0 And TheAngle#(PlayerNum) > 0) Or (increment > 0 And TheAngle#(PlayerNum) < 90) Then + TheAngle#(PlayerNum) = TheAngle#(PlayerNum) + increment + Call PlotAngle(locateCol, TheAngle#(PlayerNum), PlayerNum) + Else + Beep + Do + temp$ = InKey$ + Loop While temp$ <> "" + End If + Case ENTERKEY + finished = TRUE ' Fire cannon when Enter key is pressed. + NewAngle# = TheAngle#(PlayerNum) + NewVelocity = TheVelocity(PlayerNum) + Case Else ' Any other key is invalid. + Beep + End Select + Loop + +End Sub + +'-------------------------------------------------------------------------- +' InitializeVariables +' +' SHARED variables are initialized and graphics pictures loaded from +' DATA statements. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub InitializeVariables + + Pi# = 4 * Atn(1#) ' Calculate PI to 14 decimal places. + + ScreenWidth = 320 ' Width and height for SCREEN 1 (320x200). + ScreenHeight = 200 + MaxCol = 40 + ' Loading picture data from the DATA statements into the respective arrays. + Restore ShipPicData + For Counter = 1 To 36 + Read ShipPic(Counter) ' ship picture + Next Counter + For Counter = 1 To 20 + Read TreePic1(Counter) ' bottom of palm tree + Next Counter + For Counter = 1 To 36 + Read TreePic2(Counter) ' top of palm tree + Next Counter + For Counter = 1 To 2 + Read Shot&(Counter) ' shot + Next Counter + + 'Determine machine performance in a generic manner... + x! = Timer + For g! = 1 To 500 + Next g! + x! = Timer - x! + Select Case x! + Case 0 TO .18 'For 386 type machines. + Delay = 500 + Case Is < .45 'For PC/AT type machines. + Delay = 200 + Case Else 'For XT type machines. + Delay = 50 + End Select + +End Sub + +'-------------------------------------------------------------------------- +' MakeBattleField +' +' Generates the sea at each point on the screen, storing +' the values in the array seaLevel(). The level of +' the ocean is generated from left side of the screen to +' the right. The variable "motion" affects the "trend" of +' sea level, generating up and down "slopes." +' +' PARAMETERS: SeaLevel() - The height of the sea +'-------------------------------------------------------------------------- +Sub MakeBattleField (SeaLevel()) + + increment = 1 + range = 5 + SeaLevel(0) = ScreenHeight - (45 + Int((ScreenHeight / 8) * Rnd + 1)) + ' When the following loop ends, each element of the seaLevel() array has a + ' value to be used in drawing the ocean surface. + For Counter = 1 To ScreenWidth + Motion = Int(range * Rnd + 1) + Select Case Motion + Case 1 TO range / 2 + If Motion < range / 2 - 1 Then + trend = trend + increment + Else + trend = trend - increment + End If + Case range / 2 + 1 TO range / 2 + 2 + trend = 1 * Sgn(Wind) + Case range / 2 + 3 + trend = 0 + Case Else + trend = -1 * Sgn(Wind) + End Select + Select Case trend ' Set values in seaLevel based on trend generated above + Case Is < 0 + SeaLevel(Counter) = SeaLevel(Counter - 1) - 1 ' if trend is negative + Case Is > 0 + SeaLevel(Counter) = SeaLevel(Counter - 1) + 1 ' if trend is positive + Case Else + SeaLevel(Counter) = SeaLevel(Counter - 1) ' if trend is zero + End Select + If SeaLevel(Counter) > SeaLevel(0) + range Then SeaLevel(Counter) = SeaLevel(Counter - 1) - 3 + If SeaLevel(Counter) < SeaLevel(0) - range Then SeaLevel(Counter) = SeaLevel(Counter - 1) + 3 + If Counter > range And Counter < ScreenWidth - range Then + diff = SeaLevel(Counter - 4) - SeaLevel(Counter - 1) + If Abs(diff) > range Then + trend = -increment * Sgn(diff) + End If + End If + Next Counter + ' When this SUB ends the values in SeaLevel array are known in the caller. They + ' are passed to PlotBattleField and used in LINE statements to draw the ocean + ' surface and fill the ocean with color down to the bottom of the screen with + ' WATERCOLOR. DrawWaves uses the SeaLevel values in calculating the positions + ' for drawing waves. + +End Sub + +'-------------------------------------------------------------------------- +' MoveShip +' +' Allows player to move ship using Left and Right arrow keys. As long +' as they do not actually move the ship, they can change their mind +' and go back to the main menu to shoot. +' +' PARAMETERS: playerNum - The player who is moving +' seaLevel() - Used to fix area after move +'-------------------------------------------------------------------------- +Function MoveShip (PlayerNum, SeaLevel()) + + finished = FALSE ' TRUE if player presses Enter. + MoveShip = FALSE ' TRUE if player moves ship. If FALSE + ' player can go back and shoot. + + ' Print instructions for moving. + Locate 5, 2: Print "To move your ship, press either the" + Locate 6, 2: Print Chr$(26) + " or " + Chr$(27) + " arrow keys, then press Enter." + + ' Loop until the player hits enter to indicate they are done moving. + ' If they have not actually moved then they can still do something else. + Do While Not finished + Do ' Get player's selection. + kbd$ = InKey$ + Loop While kbd$ = "" + cursorkey = Asc(Right$(kbd$, 1)) + Select Case cursorkey + Case LEFT ' Move ship to left. + MoveShip = TRUE + moveit = -MOVESHIPBY + Case RIGHT ' Move ship to right. + MoveShip = TRUE + moveit = MOVESHIPBY + Case ENTERKEY ' End move by pressing Enter key. + finished = TRUE + Case Else ' Any other key is invalid. + Beep + moveit = 0 + End Select + + If Not finished Then ' Move ship. + xpos = ShipX(PlayerNum) + moveit + ' Move ship only if it can be moved in that direction. + If (xpos > 3 And xpos < IStart - MOVESHIPBY - 3) Or (xpos > IEnd + 3 And xpos < ScreenWidth - SHIPWIDTH - 3) Then + ypos = SeaLevel(xpos) - 9 + ' blank out current position + Put (ShipX(PlayerNum), ShipY(PlayerNum)), ShipPic(), Xor + If moveit > 0 Then ' clean up the water using seaLevel() + For i = ShipX(PlayerNum) To xpos - 1 + Line (i, SeaLevel(i))-(i, SeaLevel(i) + SHIPWIDTH), WATERCOLOR + Next i + Else + For i = ShipX(PlayerNum) To ShipX(PlayerNum) - moveit + Line (i, SeaLevel(i))-(i, SeaLevel(i) + SHIPWIDTH), WATERCOLOR + Next i + End If + Put (xpos, ypos), ShipPic(), PSet ' Put ship in new position. + ShipX(PlayerNum) = xpos + ShipY(PlayerNum) = ypos + Else + Beep + End If + End If + Loop + + Call ClearArea(5, 1, 6, 40) + +End Function + +'-------------------------------------------------------------------------- +' PlaceShips +' +' Computes new locations and place ships there. +' +' PARAMETERS: seaLevel() - Needed to find shipY() +'-------------------------------------------------------------------------- +Sub PlaceShips (SeaLevel()) + + ' Calculate random position for ships on either side of the screen. + ShipX(1) = Int(((ScreenWidth - ISLLENGTH) / 2 - SHIPWIDTH - 6) * Rnd) + 3 + ShipY(1) = SeaLevel(ShipX(1)) - 12 + ShipX(2) = ScreenWidth - Int(((ScreenWidth - ISLLENGTH) / 2 - SHIPWIDTH - 6) * Rnd) - SHIPWIDTH - 3 + ShipY(2) = SeaLevel(ShipX(2)) - 12 + + For Counter = 1 To 2 ' Place the ship images from shipPic() and fix the water to look good. + Put (ShipX(Counter), ShipY(Counter)), ShipPic(), PSet + For FixTerrain = ShipX(Counter) To ShipX(Counter) + SHIPWIDTH + Line (FixTerrain, ShipY(Counter) + 2 * SHIPWIDTH)-(FixTerrain, ShipY(Counter) + SHIPWIDTH), WATERCOLOR + Next FixTerrain + Next Counter + +End Sub + +'-------------------------------------------------------------------------- +' PlayGame +' +' This is the main driver for QSHIPS. +' This SUB procedure contains three nested loops. The outermost loop +' will ask the players if they wish to play again each time +' someone wins. The second loop will continue to generate a new +' battle field and wind speed each round until someone scores +' enough points to win. The inner most loop gets and executes +' each players commands for that round, ending when one player is +' sunk. +' +' PARAMETERS: None +'-------------------------------------------------------------------------- +Sub PlayGame + + 'Set up arrays to hold the height of the water/terrain at each point. + Dim SeaLevel(0 To ScreenWidth) + Randomize (Timer) + Counter = 0 + + 'The main loop of the game. Keeps going until users select to quit. + Do + Center "Creating game battleground, please wait.", 22 + + ' Initialize score. + For i = 1 To 2 + TotalShots(i) = 0 + TotalWins(i) = 0 + Next i + + firstPlayer = Int(2 * Rnd + 1) ' Randomly determine first player. + + 'This loop gets and executes the players commands until the 'play to' score has been met. + Do Until TotalWins(1) >= NumGames Or TotalWins(2) >= NumGames + + For i = 1 To 2 ' Reset initial cannon angle and speed. + TheAngle#(i) = 45 + TheVelocity(i) = 50 + Next i + + ' Calculate wind for this round. To have the wind speed change after each shot, move the next four lines to down below the statement "DO WHILE directHit = FALSE." + Wind = Int(11 * Rnd + 1) - 6 + If (Int(4 * Rnd + 1) = 1) Then ' Every once in a while, make it 10 times stronger. + Wind = Wind + Sgn(Wind) * 10 + End If + + Call MakeBattleField(SeaLevel()) ' Generate and plot a new battle field. + Do ' Flush keyboard buffer + kbd$ = InKey$ + Loop Until kbd$ = "" + Screen ScreenMode + Color 0, 1 ' Set CGA palette to palette #1. + Cls ' Clear screen for new round. + Call PlotBattleField(SeaLevel()) ' Draw ocean, waves, ships, island, trees. + + Do ' This section will get and execute commands until one player is blown up or the players quit. + Counter = Counter + 1 + + ' Get and execute a player's command, returning an integer that tells if someone has been hit. + directHit = GetPlayerCommand(firstPlayer, SeaLevel()) + + If directHit <> FALSE Then + If directHit = SHOOTSELF Then ' SHOOTSELF is constant value 1. + TotalWins(Abs(firstPlayer - 3)) = TotalWins(Abs(firstPlayer - 3)) + 1 + Else + TotalWins(firstPlayer) = TotalWins(firstPlayer) + 1 + End If + If directHit = TRUE Then Counter = Counter + 1 + End If + + firstPlayer = Abs(firstPlayer - 3) ' Change firstPlayer so turns alternate + ' between players while there hasn't + Loop While directHit = FALSE ' been a direct hit. + ' When this loop is exited one player or the other has been sunk. We now go back to the outer loop to make a new battle field. + + Loop ' Repeat until totalwins are finally met + + Color 1, 1 + Cls ' Display game over info. + Locate 3, 15: Print "GAME OVER!" + diff = TotalWins(1) - TotalWins(2) ' If diff is negative, player2 won + If diff > 0 Then ofst = 1 Else ofst = 2 ' more games, otherwise player1 won more. + + Locate 7, 4 ' If player2 won more, display absolute value of difference: + Print Player$(ofst) + " won by" + Str$(Abs(diff)) + " point(s)." + Locate 11, 2: Print "Player: Hits: Shots Fired:" + Locate 12, 2: Print "------- ----- ------------" + + For j = 1 To 2 + Locate 13 + j, 2: Print Player$(j) + Locate 13 + j, 17: Print TotalWins(j) + Locate 13 + j, 32: Print TotalShots(j) + Next j + + Locate 20, 11: Print "Play again? (Y/N) " 'See if the players wish to play again. + Do + StillPlay$ = UCase$(InKey$) + Loop While StillPlay$ <> "Y" And StillPlay$ <> "N" + + Loop While StillPlay$ = "Y" 'Repeat while players still want to play game. + +End Sub + +'-------------------------------------------------------------------------- +' PlotAngle +' +' Plots the angle (from 0-90 degrees) indicator that is displayed while +' a player is adjusting the angle of his/her shot. +' +' PARAMETERS: col - What column to start at +' newAngle# - The angle to plot +' OldAngle# - The old angle plotted +' playerNum - Which player is adjusting +'-------------------------------------------------------------------------- +Sub PlotAngle (col, NewAngle#, PlayerNum) + + radius = 28.57143 ' Assumes a screen height of 200 and width of 320. + YCenter = 34.28572 + + If PlayerNum = 1 Then ' Set placement of drawing according + XCenter = 78.57143 ' to whose turn it is. + XIncrement = radius + xoffset = -1 + Else + XCenter = 228.5714 + XIncrement = -radius + xoffset = 1 + End If + + ' Erase the previous arc. + Line (XCenter, YCenter)-(XCenter + XIncrement, YCenter - radius * .8333333), BACKGROUNDCOLOR, BF + ' Draw new pie-slice representing trajectory. + If PlayerNum = 1 Then + Circle (XCenter, YCenter), radius, OBJECTCOLOR, -.00001, -Pi# / 2 + Else + Circle (XCenter, YCenter), radius, OBJECTCOLOR, -Pi# / 2, -Pi# + End If + ' Draw line representing the angle of the shot. + Line (XCenter, YCenter)-(XCenter + Cos((NewAngle# * (Pi# / 180))) * XIncrement, YCenter - Sin((NewAngle# * (Pi# / 180))) * (radius * .8333333)), OBJECTCOLOR + ' Fill bottom with magenta if appropriate. + If NewAngle# > 1 Then Paint (XCenter + XIncrement + xoffset, YCenter - 1), ISLANDCOLOR, OBJECTCOLOR + + Locate 3, col ' Print the angle beside the indicator. + Print Using "Angle: ##"; NewAngle# + +End Sub + +'-------------------------------------------------------------------------- +' PlotBattlefield +' +' Plots the sea level stored in the array seaLevel(). A line of color +' WATERCOLOR is drawn from the bottom of the screen straight up to the +' y coordinate stored in seaLevel(). This process is repeated for each +' x coordinate on the screen. PlotBattleField then adds waves, ships, +' and an island to complete the battle field. +' +' PARAMETERS: seaLevel() - The height of the sea +'-------------------------------------------------------------------------- +Sub PlotBattleField (SeaLevel()) + + For Counter = 1 To ScreenWidth ' Draw the sea. + Line (Counter, ScreenHeight)-(Counter, SeaLevel(Counter)), WATERCOLOR + Next Counter + + Call DrawWaves(10, 4, 1, SeaLevel()) ' Call WaveSub to add in the waves. + Call DrawWaves(20, 2, 1, SeaLevel()) + Call DrawWaves(30, 1, 1, SeaLevel()) + Call DrawWaves(40, 3, 1, SeaLevel()) + Call DrawWaves(50, 7, 1, SeaLevel()) + + Call PlaceShips(SeaLevel()) ' Place ships in battlefield. + Call DrawIsland(SeaLevel()) ' Place the island. + +End Sub + +'-------------------------------------------------------------------------- +' PlotShot +' +' Plots the trajectory of a shot on the screen based on indicated angle +' and velocity, adjusting for wind speed and direction. As the cannon +' ball trajectory is plotted we check to see if the shot has hit +' anything. If the shot goes off the top of the screen we keep track +' of it in case it comes down back on the screen. If the shot goes off +' the side of the screen then we assume it missed and quit plotting. +' +' PARAMETERS: startX - The x coordinate shot from +' startY - The y coordinate shot from +' angle# - The angle of the cannon +' velocity - The starting velocity +'-------------------------------------------------------------------------- +Function PlotShot (startX, startY, angle#, velocity) + + Const cSeconds = 3.5 ' Avg # seconds cannon ball in air + + Play CANNONFIRESOUND + + If velocity < 2 Then ' If a shot is too slow then the cannon ball blows the shooter up! + PlotShot = SinkShip(startX, startY) + Else + + ' Calculate the starting variables for plotting the trajectory. + angle# = angle# / 180 * Pi# ' Convert degree angle to radians. + InitialXVelocity# = Cos(angle#) * velocity + InitialYVelocity# = Sin(angle#) * velocity + + PlotShot = 0 ' Assume no ship destroyed + NEEDERASE = FALSE ' TRUE if we need to erase a previous shot + + t1# = Timer + + ' While the shot is on the screen and has not hit anything we plot its + ' trajectory. + Do + + ' Calculate shot's current position. + x = startX + (InitialXVelocity# * t#) + (.5 * (Wind / 5) * t# * t#) + y = startY + (-(InitialYVelocity# * t#) + (.5 * GRAVITY * t# * t#)) * (ScreenHeight / 350) + + ' Erase the old image of the shot if we need to do so. + If NEEDERASE Then ' Shot& is an array holding data + Put (Oldx, Oldy), Shot&(), Xor ' used to draw the projectile. + End If ' XOR causes erasing by + ' redrawing in background color + + ' Check to see if shot has gone off the side of the screen. If + ' so, flag to exit the loop now so we don't try to plot the point + ' or look at a point off of the screen. + If (x >= ScreenWidth - 3) Or (x <= 3) Or (y >= ScreenHeight - 3) Then + Exit Do + End If + + ' Check to see if the shot hit anything: Use the POINT statement + ' to get the color of the points around the shot, then compare the + ' color to ISLANDCOLOR, WATERCOLOR, OBJECTCOLOR to see what was hit. + ' If we get a hit, we have to exit immediately, otherwise we could + ' get several hits at the current location. + For lookX = -1 To 1 + For lookY = -1 To 1 + If Point(x + lookX, y + lookY) <> BACKGROUNDCOLOR Then + If Point(x + lookX, y + lookY) = OBJECTCOLOR Then + PlotShot = SinkShip(x, y) ' hit a ship + Exit Do + ElseIf Point(x + lookX, y + lookY) = ISLANDCOLOR Then + Call CannonHit(x, y, ISLANDCOLOR) ' hit the island + Exit Do + ElseIf Point(x + lookX, y + lookY) = WATERCOLOR Then + Call CannonHit(x, y, WATERCOLOR) ' hit the water + Exit Do + End If + End If + Next + Next + + ' If the shot has not hit anything, plot it. + If y > 0 Then + Put (x, y), Shot&(), PSet + Oldx = x + Oldy = y + NEEDERASE = TRUE + Else + NEEDERASE = FALSE + End If + + ' Wait till time for next position to be drawn (.05 time units) + Do + ' If midnight rollover occurred, adjust starting time + If Timer < t1# Then + t1# = t1# - 86400 + End If + + t2# = (Timer - t1#) * 8 / cSeconds + Loop While t2# - t# < .05 + t# = t2# + Loop + End If + +End Function + +'-------------------------------------------------------------------------- +' PlotVelocity +' +' Plots the shot velocity indicator used when a player is entering the +' parameters for a shot. +' +' PARAMETERS: col - Where to plot +' newVelocity - The velocity to indicate +' playerNum - Which player is firing +'-------------------------------------------------------------------------- +Sub PlotVelocity (col, NewVelocity, PlayerNum) + + margin = 33.33333 ' Assumes a 320x200 screen dimension. + YHeight = 5 + YCenter = 50 + XWidth = 106.66667# + + If PlayerNum = 1 Then ' Put the indicator on the firing players side of the screen. + XCenter = .66666 + XIncrement = XWidth + xoffset = -1 + Else + XCenter = 236.6667 + XIncrement = -XWidth + xoffset = 1 + End If + + ' Plot the current velocity on indicator. ISLANDCOLOR is used to paint the current velocity. + Line (XCenter, YCenter)-(XCenter + XIncrement * (NewVelocity / MAXVELOCITY) + xoffset, YCenter - YHeight), ISLANDCOLOR, BF + Line (XCenter + XIncrement * (NewVelocity / MAXVELOCITY), YCenter)-(XCenter + XIncrement + xoffset, YCenter - YHeight), BACKGROUNDCOLOR, BF + ' Draw box around velocity indicator. + Line (XCenter + xoffset, YCenter + 1)-(XCenter + XIncrement, YCenter - YHeight - 1), OBJECTCOLOR, B + ' Put strip of grey at current velocity. + Line (XCenter + XIncrement * (NewVelocity / MAXVELOCITY) + xoffset, YCenter)-(XCenter + XIncrement * (NewVelocity / MAXVELOCITY) + xoffset, YCenter - YHeight), OBJECTCOLOR + + Locate 5, col ' Print current velocity as numerical value also. + Print Using "Speed:###"; NewVelocity + +End Sub + +'-------------------------------------------------------------------------- +' SinkShip +' +' Causes the ship that has been hit to explode in a large explosion and +' then sink. The explosion is created using a series of circle +' statements. The sinking ship is done using the BASIC graphics PUT +' statement with the XOR option. +' +' PARAMETERS: x - x coordinate of shot +' y - y coordinate of shot +'-------------------------------------------------------------------------- +Function SinkShip (x, y) + + XWidth = 8 + YHeight = 10 + + Call CannonHit(x, y, ISLANDCOLOR) ' Do a normal cannon ball explosion. + + Call CyclePalette ' Flash the screen. + If x < ScreenWidth / 2 Then playerHit = 1 Else playerHit = 2 ' Determine the player hit. + + Play SHIPEXPLOSIONSOUND + + ' Create the base of the explosion using expanding circles and the "stem" of the mushroom cloud using lines. + For blast = 1 To XWidth + Circle (ShipX(playerHit) + SHIPWIDTH / 2, ShipY(playerHit) + YHeight), blast, ISLANDCOLOR, , , -1.57 + Line (ShipX(playerHit) + SHIPWIDTH / 2 - 3.5, ShipY(playerHit) + YHeight - blast)-(ShipX(playerHit) + SHIPWIDTH / 2 + 3.5, ShipY(playerHit) + YHeight - blast), ISLANDCOLOR + Next blast + + Call CyclePalette + + ' Create the top of the mushroom cloud using expanding circles while clearing the bottom of the cloud off. + For Cloud = 1 To SHIPWIDTH + If Cloud < (XWidth) Then Circle (ShipX(playerHit) + SHIPWIDTH / 2, ShipY(playerHit) + YHeight), (XWidth + 1) - Cloud, BACKGROUNDCOLOR, , , -1.57 + Circle (ShipX(playerHit) + SHIPWIDTH / 2, ShipY(playerHit)), Cloud, ISLANDCOLOR, , , -1.57 + Next Cloud + + Call CyclePalette + + For Cloud = SHIPWIDTH To 1 Step -1 ' Slowly erase the top of the cloud. + Circle (ShipX(playerHit) + SHIPWIDTH / 2, ShipY(playerHit)), Cloud, BACKGROUNDCOLOR, , , -1.57 + Next Cloud + SinkShip = playerHit + + xcol = ShipX(playerHit) + origycol = ShipY(playerHit) + ycol = origycol + i = 1 + + ' Sink the ship using the PUT statement to slowly lower the ship image and drawing lines in WATERCOLOR over the image so it seems to submerge. + Do While i <= SHIPWIDTH And ycol + SHIPWIDTH < ScreenHeight + Put (xcol, ycol), ShipPic(), Xor + ycol = ycol + 1 + If ycol + SHIPWIDTH < ScreenHeight Then + Line (xcol, ycol - 1)-(xcol + SHIPWIDTH, ycol - 1), BACKGROUNDCOLOR + Put (xcol, ycol), ShipPic(), PSet + For j = 0 To i + Line (xcol, origycol + j + SHIPWIDTH)-(xcol + SHIPWIDTH, origycol + j + SHIPWIDTH), WATERCOLOR + Next j + End If + i = i + 1 + Loop + +End Function + diff --git a/samples/qspace/img/screenshot.png b/samples/qspace/img/screenshot.png new file mode 100644 index 00000000..8170e50d Binary files /dev/null and b/samples/qspace/img/screenshot.png differ diff --git a/samples/qspace/index.md b/samples/qspace/index.md new file mode 100644 index 00000000..03392db4 --- /dev/null +++ b/samples/qspace/index.md @@ -0,0 +1,21 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QSPACE + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Space station defense game by Microsoft. +``` + +### File(s) + +* [qspace.bas](src/qspace.bas) + +🔗 [game](../game.md), [defense](../defense.md) diff --git a/samples/qspace/src/qspace.bas b/samples/qspace/src/qspace.bas new file mode 100644 index 00000000..fc423259 --- /dev/null +++ b/samples/qspace/src/qspace.bas @@ -0,0 +1,1255 @@ +' QSPACE.BAS +' +' Copyright (C) 1990 Microsoft Corporation. All Rights Reserved. +' +' Your mission in QSpace is to defend your orbiting starbases from enemy +' attack. Protect them by firing your own interceptor missiles to destroy +' the incoming missiles. +' +' To run this game, press Shift+F5. +' +' To exit this program, press Alt, F, X. +' +' To get help on a BASIC keyword, move the cursor to the keyword and press +' F1 or click the right mouse button. +' +' To view suggestions on changing this game, press Page Down. +' +' +' Suggested Changes +' ----------------- +' +' There are many ways that you can modify this BASIC game. The CONST +' statements below these comments and the DATA statements at the end +' of this screen can be modified to change the following: +' +' Enemy missile speed at the start of the game +' Songs played during this game +' Color of the game pieces (EGA or VGA systems only) +' Speed of the targeting crosshair +' Number of missiles falling at the start of the game +' Size of missile explosions +' Duration of the explosions +' GAME OVER messages +' +' On the right side of each CONST statement, there is a comment that tells +' you what it does and how big or small you can set the value. Above the +' DATA statements, there are comments that tell you the format of the +' information stored there. +' +' On your own, you can also add exciting sound and visual effects or make +' any other changes that your imagination can dream up. By reading the +' Learn BASIC Now book, you'll learn the techniques that will enable you +' to fully customize this game and to create games of your own. +' +' If the game won't run after you have changed it, you can exit without +' saving your changes by pressing Alt, F, X and choosing NO. +' +' If you do want to save your changes, press Alt, F, A and enter a filename +' for saving your version of the program. Before saving your changes, +' however, make sure the program still works by running the program and +' verifying that your changes produce the desired results. Also, always +' be sure to keep a backup of the original program. +' +DefInt A-Z + +' These CONST statements define things in the game that you can control. +Const GAMEBKGROUNDS7 = 0 ' Screen background color in screen mode 7. Can't be any of the other game colors. Usually is black (0). +Const INITIALDELAY = .1 ' Initial value of the Incoming missile delay. Increase the number to make the Incoming missiles slower; decrease to make them faster. After odd-numbered waves, the IncomingDelay gets 33% shorter. +Const INITNUMSTARBASES = 3 ' Initial number of starbases. This sets the starting value of the MaxStarbases variable. Range is 1 to 4. +Const INITNUMMISSILES = 3 ' Number of incoming missiles when the game starts. This is just the start - the number of missiles increases as you complete more waves. Range 1 to 6. +Const TARGETSPEED = 10 ' How fast and far the target moves. Range 4 to 30. +Const EXPLOSIONDELAY = .1 ' Rate that explosions grow. Range .05 to .25. +Const EXPLRADIUS = 16 ' How big the explosion gets before it stops and is erased. Range 5 to 75. +Const PLANETS7 = 9 ' Planet color in screen mode 7. +Const BASECOLORS7 = 7 ' Starbase color in screen mode 7. Can't be the same as GAMEBKGROUNDS7. +Const ENEMYCOLORS7 = 3 ' Enemy missile color in screen mode 7. Can't be the same as GAMEBKGROUNDS7. +Const INTERCEPTCOLORS7 = 2 ' Interceptor missile color in screen mode 7. Can't be the same as GAMEBKGROUNDS7. +Const EXPLCOLORS7 = 12 ' Explosion color in screen mode 7. Can't be the same as GAMEBKGROUNDS7. +Const TARGETCOLORS7 = 2 ' Target crosshair color for screen mode 7. Can't be the same as GAMEBKGROUNDS7. +Const FASTESTMISSILE = .005 ' Lowest time delay between enemy missile movements. +Const RATIOINTERCEPTTOINCOMING = 5 ' How fast your interceptor missiles move compared to enemy missiles. At 5, interceptors move at least 5 times faster than enemy missiles. Range 1 to 20. +' The following sound constants are used by the PLAY command to +' produce music during the game. To change the sounds you hear, change +' these constants. Refer to the online help for PLAY for the correct format. +' To completely remove sound from the game set the constants equal to null. +' For example: GAMESTARTSONG = "" +Const GAMESTARTSONG = "MBT150L4O2CD-CL8A-FAECD-L4A-F" ' Played when program starts. No limits. +Const WAVEOVERSONG = "MB O2 T240 L4 N40 N44 N48 N55 N48 L2 N53" ' Played at the end of each wave. No limits. +Const GAMEOVERSONG = "MB O1 T240 L2 g- g- L1 a" ' Played when the game is over. No limits. + +' The following CONST statements should not be changed like the ones above +' because the program relies on them being this value. +Const TRUE = -1 ' Microsoft QuickBASIC uses -1 to mean TRUE. +Const FALSE = 0 ' 0 means FALSE. +Const XSCALE = 320 ' Width of the screen. +Const YSCALE = 200 ' Height of the screen. +Const MAXY = YSCALE - 11 ' Highest vertical position that a missile can be. +Const MINY = 11 ' Lowest position an incoming missile can be can be. +Const MINX = 11 ' Left-most position an incoming missile can be. +Const MAXX = XSCALE - 11 ' Right-most position that an Incoming missile can be. +Const LEFTLAUNCHER = 90 ' Key that controls left FireBase. +Const RIGHTLAUNCHER = 88 ' Key that controls right FireBase. +Const PAUSE = 25 ' Key that pauses the game. +Const QUIT = 16 ' Key that quits the game. +Const FACTOR = 250 ' Used to determine the radius of the starbases. Increase to make the starbases smaller; decrease to make the starbases larger. +Const PI = 3.14 ' Value of the mathematical constant PI. Used in determining the position of the starbases orbiting the planet. +Const PLANETRADIUS = XSCALE * .62 ' The radius of the planet that the starbases orbit. +Const GAMEBKGROUNDS1 = 0 ' Screen background in SCREEN 1. +Const PLANETS1 = 2 ' Planet color in SCREEN 1. +Const BASECOLORS1 = 1 ' Starbase color in SCREEN 1. +Const ENEMYCOLORS1 = 3 ' Enemy missile color in SCREEN 1. +Const INTERCEPTCOLORS1 = 3 ' Interceptor missile color in SCREEN 1. +Const EXPLCOLORS1 = 2 ' Explosion color in SCREEN 1. +Const TARGETCOLORS1 = 9 ' Target crosshair color for SCREEN 1 +Const RESOLUTION = 100 ' Controls how accurately a line is drawn. + +' SUB and FUNCTION declarations +DECLARE SUB Center (Text$, Row) +DECLARE SUB DestroyStarbase (Z) +DECLARE SUB DisplayIntro () +DECLARE SUB DisplayGameTitle () +DECLARE SUB DisplayChanges () +DECLARE SUB EraseMissileTrail (MNum) +DECLARE SUB Explode (Chosen, X, Y, WMissiles) +DECLARE SUB GameOver () +DECLARE SUB HorizontalScroll (M$, Row) +DECLARE SUB InitScreen () +DECLARE SUB InitFirebases () +DECLARE SUB Keys (TurnKeysOn) +DECLARE SUB KeyPause () +DECLARE SUB LaunchMissile (Chosen, XStart, YStart, XFinish, YFinish) +DECLARE SUB NewMissile () +DECLARE SUB NewStarbase () +DECLARE SUB NewInterceptor (X, Y) +DECLARE SUB StopMissile (Chosen, WMissiles) +DECLARE SUB UpdateMissiles (Start, Finish, WMissiles, NumOfTimes, WColor) +DECLARE SUB UpdateExplosions () +DECLARE SUB UpdateTarget () +DECLARE SUB UpdateScore () +DECLARE SUB WaveComplete () + +' Structure definitions. +Type Missile + X As Integer ' Current X (horizontal) position. + Y As Integer ' Current Y (vertical) position. + XStart As Integer ' Horizontal missile start position. + YStart As Integer ' Vertical missile start position. + XOffset As Integer ' # of X pixels to move each time the UpdateMissile subprogram is called. + YOffset As Integer ' # of Y pixels to move each time the UpdateMissile subprogram is called. + Active As Integer ' 0 = not active, 1 = in flight, 2 = frozen (while it explodes) + XFinish As Integer ' X of the missile's target. + YFinish As Integer ' Y of the missile's target. + MaxCount As Integer ' Number of moves in the missile's primary direction until the missile moves in the secondary direction. + Count As Integer ' Number of moves in the missile's primary direction. + YMajor As Integer ' TRUE if the missile moves more vertically then horizontally. FALSE otherwise. +End Type + +Type GenericPos ' General-purpose data type for moving objects. Used many places in QSpace. + X As Integer ' X position. + Y As Integer ' Y position. + Active As Integer ' FALSE (0) = Not active (destroyed, etc.), TRUE (-1) = Active. + OldX As Integer ' Last X position. Used to make it possible to restore a previous position if the new one would be off the screen. + OldY As Integer ' Last Y position. Used to make it possible to restore a previous position if the new one would be off the screen. +End Type + +Type xplode ' Data type for explosions. + X As Integer ' X position. + Y As Integer ' Y position. + Active As Integer ' Explosion status. FALSE (0) = No explosion, Greater than 0 = Radius of explosion. + MissileNum As Integer ' Number of the missile that was destroyed to cause this explosion. Needed to erase missile path after explosion is over. + MType As Integer ' Type of the missile that exploded. 1 = incoming enemy missile, 2 = interceptor missile. +End Type + +Clear , , 5120 ' Set up a large stack for input processing + +' DIM SHARED indicates that the following variable is available to all +' subprograms. Without this statement, a variable used in one subprogram +' cannot be used by another subprogram or the main program. +Dim Shared NumMissiles As Integer ' Maximum number of incoming missiles. Initially set to InitNumMissiles. +Dim Shared MaxStarbases As Integer ' Maximum number of starbases. Initially set to InitNumStarbases. +Dim Shared Incoming(1 To 10) As Missile ' Array used to track of all missiles, both incoming and interceptors. Incoming missiles are numbered from 1 to 6; interceptors from 7 to 10. +Dim Shared Starbase(1 To 4) As GenericPos ' Array used to keep track of the starbases. Game begins with 3 starbases but up to 4 starbases can exist depending on the score. New bases added by the WaveComplete subprogram. +Dim Shared ContinueGame As Integer ' A flag variable to track the status of the game. 1 = Game in progress, -1 = Begin new game, 0 = End game. +Dim Shared Target As GenericPos ' Target crosshair. The .active element is not used. +Dim Shared NumIntercepts As Integer ' Number of interceptors flying. No more than 4 can exist at any one time. +Dim Shared Score As Long ' Score. +Dim Shared Wave As Long ' Number of the current attack wave. +Dim Shared WaveCount As Long ' Number of missiles already launched in the current attack wave. +Dim Shared NextIncoming As Single ' Interval, in seconds from current time, to move the incoming missiles again. +Dim Shared NextExplosion As Single ' Delay until next explosion begins. +Dim Shared Explosion(1 To 10) As xplode ' Array that keeps track of the explosions. Since no more than 10 missiles can be flying at once, no more than 10 simultaneous explosions are possible. +Dim Shared IncomingDelay As Single ' Delay between incoming missile movements. +Dim Shared MissilesFlying As Integer ' Number of incoming missiles currently flying. +Dim Shared BasesLeft As Integer ' Number of starbases left. Used for scoring and in determining when the game is over. +Dim Shared TotalIncoming As Long ' Total number of incoming missiles that have been destroyed. Used for the statistics at the end of the game. +Dim Shared TotalInterceptors As Long ' Total number of interceptors launched. Used for the statistics at the end of the game. +Dim Shared NextNewBase As Long ' Score when a bonus new base will be awarded. +Dim Shared NumExplosions As Integer ' Number of explosions in progress. +Dim Shared PlanetColor As Integer ' Color of the planet. +Dim Shared EnemyColor As Integer ' Color of the enemy missiles. +Dim Shared InterceptColor As Integer ' Color of interceptor missiles. +Dim Shared ExplColor As Integer ' Color of the explosions. +Dim Shared BaseColor As Integer ' Primary color of the starbase. +Dim Shared GameBkGround As Integer ' Color of the game background. +Dim Shared TargetColor As Integer ' Color of the target crosshair. +Dim Shared ScreenMode As Integer ' Number of the screen mode we are running in. +Dim Shared ScreenWidth As Integer ' Width of the screen. Used in various screen output functions. +Dim KeyFlags As Integer ' Internal state of the keyboard flags when game starts. Hold the state so it can be restored when the games ends. +Dim BadMode As Integer ' Store the status of a valid screen mode. + +On Error GoTo ScreenError ' Set up a place to jump to if an error occurs in the program. +BadMode = FALSE +ScreenMode = 7 +Screen ScreenMode ' Attempt to go into SCREEN 7 (EGA screen). +If BadMode = TRUE Then ' If this attempt failed. + ScreenMode = 1 + BadMode = FALSE + Screen ScreenMode ' Attempt to go into SCREEN 1 (CGA screen). +End If +On Error GoTo 0 ' Turn off error handling for now. + +If BadMode Then ' If no graphics adapter. + Cls + Locate 10, 13: Print "CGA, EGA Color, or VGA graphics required to run QSPACE.BAS" +Else + Randomize Timer ' Ensure that a new random number sequence is generated. + DisplayIntro ' Display the name of the game, control keys, etc. + + Def Seg = 0 ' Set the current segment to the low memory area. + KeyFlags = Peek(1047) ' Read the location that stores the keyboard flag. + Poke 1047, &H0 ' Force them off. + Def Seg ' Restore the default segment. + + Do ' For multiple games. + Restore ' BASIC command to allow DATA statements to be reused. Necessary for multiple games. + ScreenWidth = 40 ' Set screen width of the two screens supported - 1 and 7. + IncomingDelay = INITIALDELAY ' Set initial incoming missile IncomingDelay to the value of the InitialDelay constant. + Wave = 1 ' Set wave number to 1 (first wave). + WaveCount = 0 ' Set number of missiles in the first wave to 0. After the first wave, WaveCount is reset by the WaveComplete subprogram. + Score = 0 ' Set score to 0 to begin the game. + InitScreen ' Initialize the screen, including drawing the planet. + NumMissiles = INITNUMMISSILES ' Set maximum number of missiles flying simultaneously in each wave to the value of the InitNumMissiles constant. + MissilesFlying = 0 ' Set the number of missiles currently flying to 0. Like WaveCount, this is cleared after subsequent waves by the WaveComplete subprogram. + NumIntercepts = 0 ' Set the number of interceptors currently flying. + NumExplosions = 0 ' Set the number of explosions currently happening. + ContinueGame = TRUE ' ContinueGame = TRUE means that a game is in progress. + NextIncoming = Timer ' Time when incoming missiles will again fire. Setting NextIncoming equal to the timer insures that the incoming missiles will begin moving immediately. + NextExplosion = Timer ' Time when explosions will be updated again. Setting NextExplosion equal to the timer ensures that the explosions will begin immediately. + TotalIncoming = 0 ' Set total number of destroyed incoming missiles. Missiles are counted as destroyed if hit by interceptor missiles, hit by the explosion of another incoming missile, or stopped by hitting their targets. + TotalInterceptors = 0 ' Set total number of interceptors launched. + BasesLeft = 0 ' Set the number of bases remaining. Necessary because the NewBase subprogram used below adds 1 to the current number of bases remaining. + MaxStarbases = INITNUMSTARBASES ' Set maximum number of starbases equal to the value of the InitNumStarbases constant. + NextNewBase = 15000 ' Set initial point at which a bonus starbase is awarded. After that, new starbases are awarded based on a formula in the WaveComplete subprogram. + + Erase Starbase, Incoming, Explosion ' Set all elements of the entire Starbase, Incoming, and Explosion arrays to 0. + + For i = 1 To MaxStarbases ' Loop to create the number of starbases called for in the MaxStarbases variable. + NewStarbase ' Create a new starbase + Next i + + InitFirebases ' Draw the firebases. + + For i = 1 To NumMissiles ' Start the incoming missiles flying. + NewMissile + Next i + + ' The KEY n and ON KEY statements below enable QSpace to move the + ' target crosshair the moment a key is pressed. After the + ' KEY (X) ON statement, anytime key (X) is pressed, QSpace stops + ' what it was doing and moves the crosshair. After the crosshair + ' moves, QSpace goes back to where it left off. This method allows + ' BASIC to process keys instantly and without explicitly checking + ' the keyboard. + KEY 15, Chr$(0) + Chr$(PAUSE) ' P key (Pause) + KEY 16, Chr$(0) + Chr$(QUIT) ' Q key (Quit) + KEY 17, Chr$(128) + Chr$(72) ' Extended Up key for player 1. + KEY 18, Chr$(128) + Chr$(75) ' Extended Left key for player 1. + KEY 19, Chr$(128) + Chr$(77) ' Extended Right key for player 1. + KEY 20, Chr$(128) + Chr$(80) ' Extended Down key for player 1. + + On Key(11) GoSub MoveCrossHairUp ' Up key. + On Key(12) GoSub MoveCrossHairLeft ' Left key. + On Key(13) GoSub MoveCrossHairRight ' Right key. + On Key(14) GoSub MoveCrossHairDown ' Down key. + On Key(15) GoSub PauseGame ' Pause the game. + On Key(16) GoSub QuitGame ' Quit the game. + On Key(17) GoSub MoveCrossHairUp ' Process Up key. + On Key(18) GoSub MoveCrossHairLeft ' Process Left key. + On Key(19) GoSub MoveCrossHairRight ' the Right key. + On Key(20) GoSub MoveCrossHairDown ' the Down key. + Keys TRUE ' Enable key event processing. + + Do While ContinueGame = TRUE ' ContinueGame is set to TRUE at the start of each game. When the game is over, ContinueGame is set to either FALSE (do not play again) or 1 (play again). + If Timer >= NextIncoming Then ' If enough time has elapsed since the enemy incoming missiles last moved, + NextIncoming = Timer + IncomingDelay ' Calculate when to move the incoming missiles again. + UpdateMissiles 1, NumMissiles, 1, 1, EnemyColor ' Move the incoming missiles one step. The 1 means move incoming missiles, a 2 would mean move interceptors; EnemyColor is the color of the incoming missiles -- usually cyan (3). + End If + + If NumExplosions > 0 Then ' Update explosions if there are any. + If Timer >= NextExplosion Then ' If enough time has elapsed since the explosions were last updated, + NextExplosion = Timer + EXPLOSIONDELAY ' calculate when to update the explosions again. + UpdateExplosions ' Increase the size of any explosions. + End If + End If + + If NumIntercepts > 0 Then ' Update interceptors if any are in the air. + UpdateMissiles 7, 10, 2, RATIOINTERCEPTTOINCOMING, InterceptColor + End If + + K$ = InKey$ ' Get a key press. + If Len(K$) > 0 Then ' LEN(K$) will be 0 if no key was pressed. + Select Case Asc(UCase$(K$)) ' Prepare to compare the ASCII value of the key press (done with the ASC function). UCASE$ forces upper-case. + Case LEFTLAUNCHER ' Key for the left launcher pressed. + NewInterceptor MINX + 1, MAXY - 1 ' Launch interceptor missile. + Case RIGHTLAUNCHER ' Key for the right launcher pressed. + NewInterceptor MAXX - 1, MAXY - 1 ' Launch interceptor missile. + End Select + End If + + Loop ' Do again until the game is over. + + Loop While ContinueGame <> FALSE ' At GameOver, the ContinueGame variable is set to either 1 or FALSE (0) depending on whether the player wants to try again. If 1, then the game restarts. + + DisplayChanges ' Display the suggested changes. + + Def Seg = 0 ' Restore the previous flag settings. + Poke 1047, KeyFlags + Def Seg + +End If + +End ' End of the main program code. + +MoveCrossHairUp: +Target.Y = Target.Y - TARGETSPEED +UpdateTarget +Return + +MoveCrossHairDown: +Target.Y = Target.Y + TARGETSPEED +UpdateTarget +Return + +MoveCrossHairLeft: +Target.X = Target.X - TARGETSPEED +UpdateTarget +Return + +MoveCrossHairRight: +Target.X = Target.X + TARGETSPEED +UpdateTarget +Return + +PauseGame: +Keys FALSE ' Turn all keys off. +Sound 1100, .75 ' Tone at 1100 hertz for 75 clock ticks. +Center " * Paused * ", 12 ' Display message on the screen. +Do: Loop Until InKey$ <> "" ' Wait until player presses any key. +Center Space$(12), 12 +Keys TRUE ' Turn the keys back on. +Return + +QuitGame: +Keys FALSE ' Turn all keys off. +Sound 1700, 1 ' Tone at 1700 hertz for 1 clock tick. +Sound 1100, .75 ' Tone at 1100 hertz for .75 clock tick. +Center " Really quit? (Y/N) ", 12 ' Make sure player really wants to quit. +Do ' Wait until player presses a key. + a$ = UCase$(InKey$) +Loop Until a$ <> "" +If a$ = "Y" Then ContinueGame = FALSE ' If so, set the main loop variable to FALSE to end main program level loop. +Center Space$(20), 12 ' Clear the message line. +Keys TRUE ' Turn keys back on. +Return + +' All of the data for GameOver messages. These can also be changed but the +' format must be the same. For example, the first line has a 5: that says how +' many lines of data will come afterwards, and the next lines are made of two +' parts: what the rank is (such as "Cadet") and the comments to go along with it. +' You can add a new line by following the format the others have and adding +' one to the number at the top. The last line has already been created so you +' can just change the 5 to a 6 for to add that message. + +Data 5: ' The number of messages. +Data "Cadet","Not good. Everything destroyed.": ' Lowest possible rank. +Data "Ensign","You saved a few people.": ' Better rank. +Data "Lieutenant","Your parents will be proud.": ' Better rank. +Data "Commander","Medal of Honor!": ' Better rank. +Data "Admiral","If only we had more like you!": ' Top rank. +Data "Top Gun","You can guard our starbases anytime!!": ' The ultimate. + +ScreenError: ' QSpace uses this error handler to determine the highest available video mode. +BadMode% = TRUE +Resume Next + +'---------------------------------------------------------------------------- +' Center +' +' Centers the given text string on the indicated row. +' +' PARAMETERS: text$ - The text to center +' row - The screen row to print on +'---------------------------------------------------------------------------- +Sub Center (Text$, Row) + + Locate Row, (ScreenWidth - Len(Text$)) \ 2 + 1 + Print Text$; + +End Sub + +'---------------------------------------------------------------------------- +'DestroyStarbase +' +' Declares a given base number as destroyed and determine the +' number of star bases remaining. If that number is zero then +' call the GameOver routine. This subprogram does not do the +' visual explosion of the starbase. +' +' PARAMETERS: BNum - Number of the starbase to destroy. +'---------------------------------------------------------------------------- +Sub DestroyStarbase (BNum) + + Starbase(BNum).Active = FALSE ' Set the passed starbase number to 0. + BasesLeft = 0 ' Assume there are no starbases left. + + For i = 1 To MaxStarbases ' Perform one more than the initial number of starbases. + BasesLeft = BasesLeft - Starbase(i).Active ' If not 0, increase by one. + If Starbase(i).Active = TRUE Then MaxStarbases = i ' Keep counting until you've counted the number of starbases left. + Next i + + If BasesLeft = 0 Then ' If there are no starbases left, + GameOver ' call the GameOver SUB. + End If + +End Sub + +'---------------------------------------------------------------------------- +' DisplayChanges +' +' Displays list of changes that the player can easily make. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayChanges + + Keys FALSE ' Disable key event processing. + DisplayGameTitle ' Display game title. + + Color 7 + Center "The following game characteristics can be easily changed from", 5 + Center "within the QuickBASIC Interpreter. To change the values of ", 6 + Center "these characteristics, locate the corresponding CONST or DATA", 7 + Center "statements in the source code and change their values, then ", 8 + Center "restart the program (press Shift + F5). ", 9 + + Color 15 + Center "Enemy missile speed at the start of the game ", 11 + Center "Songs played during this game ", 12 + Center "Color of the game pieces (EGA or VGA systems only) ", 13 + Center "Speed of the targeting crosshair ", 14 + Center "Number of missiles falling at the start of the game ", 15 + Center "Size of each missile explosion ", 16 + Center "Duration of the explosions ", 17 + Center "GAME OVER messages ", 18 + + Color 7 + Center "The CONST statements and instructions on changing them are ", 20 + Center "located at the beginning of the main program. ", 21 + + Do While InKey$ = "": Loop ' Wait for any keypress. + Cls ' Clear screen. + +End Sub + +'---------------------------------------------------------------------------- +' DisplayGameTitle +' +' Displays title of the game. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayGameTitle + + Screen 0 ' Set Screen mode 0. + Width 80, 25 ' Set width to 80, height to 25. + Color 4, 0 ' Set colors for red on black. + Cls ' Clear the screen. + ScreenWidth = 80 ' Set screen width variable to match current width. + + ' Draw outline around screen with extended ASCII characters. + Locate 1, 2 + Print Chr$(201); String$(76, 205); Chr$(187); ' Draw top border. + For i% = 2 To 24 + Locate i%, 2 + Print Chr$(186); Tab(79); Chr$(186); ' Draw left and right borders. + Next i% + Locate 25, 2 + Print Chr$(200); String$(76, 205); Chr$(188); ' Draw bottom border. + + ' Print game title centered at top of screen. + Color 0, 4 ' Set colors to black on red. + Center " Microsoft ", 1 ' Center game title on lines + Center " Q S P A C E ", 2 ' 1 and 2. + Center " Press any key to continue ", 25 ' Center prompt on line 25. + Color 7, 0 ' Set colors to white on black. + +End Sub + +'---------------------------------------------------------------------------- +' DisplayIntro +' +' Explains the object of the game and show how to play. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub DisplayIntro + + DisplayGameTitle ' Display game title. + + Color 7 + Center "Copyright (C) 1990 Microsoft Corporation. All Rights Reserved.", 4 + Center "Your starbases orbiting the planet Saurus are under attack from enemy", 6 + Center "fire! You can protect them by firing your own interceptor missiles ", 7 + Center "to destroy incoming missiles. ", 8 + Center "The enemy attacks the planet in waves. Each wave has more missiles ", 10 + Center "than the one before it. New waves are also faster or send more ", 11 + Center "missiles at a time. Bonus points and starbases are awarded for high ", 12 + Center "scores and completed waves. ", 13 + + Color 4 + Center String$(74, 196), 15 ' Put horizontal red line on screen. + Color 7 + Center " Game Controls ", 15 ' Display game controls. + Center "General Missile Launchers Target site ", 17 + Center " (Up)", 19 + Center "P - Pause Z - Fire left launcher " + Chr$(24) + " ", 20 + Center "Q - Quit X - Fire right launcher (Left) " + Chr$(27) + " " + Chr$(26) + " (Right)", 21 + Center " " + Chr$(25), 22 + Center " (Down)", 23 + + Play GAMESTARTSONG ' Play intro melody. + + Do ' Wait for keypress to continue + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Q" Then ' Allow player to quit now + Cls + Locate 10, 30: Print "Really quit? (Y/N)"; + Do + kbd$ = UCase$(InKey$) + Loop While kbd$ = "" + If kbd$ = "Y" Then + Cls + End + End If + End If + +End Sub + +'---------------------------------------------------------------------------- +' EraseMissileTrail +' +' Erases the trail of both enemy and interceptor missiles once +' they have exploded. This subprogram erases one of many +' possible missile trails temporarily stored in the Incoming() array. +' +' PARAMETERS: MNum - Missile line number to erase. +'---------------------------------------------------------------------------- +Sub EraseMissileTrail (MNum) + + MaxCount = Incoming(MNum).MaxCount ' Set temporary variable to the number of moves in the primary direction made before a move in the secondary direction. + Count = MaxCount ' Temp variable that keeps track of how many times the trail has been followed since the last move in the secondary direction. + If Incoming(MNum).YMajor Then ' For best speed, use different routines for missiles that move mainly vertically (YMajor = TRUE) and those that move mainly horizontally (YMajor = FALSE). + X = Incoming(MNum).XStart ' Initial X position. + XOff = Incoming(MNum).XOffset ' Temp variable for the X offset. + For Y = Incoming(MNum).YStart To Incoming(MNum).Y Step Sgn(Incoming(MNum).YOffset) ' Loop through all Y positions. + PSet (X, Y), GameBkGround ' Erase the dot. + Count = Count - RESOLUTION ' Decrease COUNT. RESOLUTION controls how accurate this algorithm is (the higher the more accurate). + If Count <= 0 Then ' Don't move in the X direction until Y has moved enough for COUNT to drop to 0 or below. + X = X + XOff ' Move in the X direction. + Count = Count + MaxCount ' Reset counter. + End If + Next + Else ' Missile moves more horizontally than vertically. + Y = Incoming(MNum).YStart ' Initial Y position. + YOff = Incoming(MNum).YOffset ' Temp variable for the Y offset. + For X = Incoming(MNum).XStart To Incoming(MNum).X Step Sgn(Incoming(MNum).XOffset) ' Loop through all X positions. + PSet (X, Y), GameBkGround ' Erase the dot. + Count = Count - RESOLUTION ' Decrease COUNT. + If Count <= 0 Then ' Has trail moved enough in the X direction to move in the X direction? + Y = Y + YOff ' Yes. Move in the Y direction. + Count = Count + MaxCount ' Reset counter. + End If + Next + End If + +End Sub + +'---------------------------------------------------------------------------- +' Explode +' +' Generates the explosion sound and set up an Explosion array +' element to use when drawing the visual explosion. +' +' PARAMETERS: MNum - Missile number that caused the explosion. +' WMissiles - Type of missile being exploded (enemy or interceptor). +'---------------------------------------------------------------------------- +Sub Explode (MNum, X, Y, WMissiles) + If Incoming(MNum).Active <> TRUE Then Exit Sub ' Makes sure that the same missile is not exploded twice. + Play "MB" ' Play (M)usic in the (B)ackground. + Sound 50, 2 ' Tone at 50 hertz for 2 clock ticks (clock tick = .054 seconds). + Sound 40, 8 ' Tone at 40 hertz for 8 clock ticks. + + Do ' DO loop to determine the highest number of currently active explosions. + XNum = XNum + 1 ' Increase the counter. + Loop Until Explosion(XNum).Active = FALSE ' When this loop is done XNum will contain the number of a valid array offset to use for the new explosion. + + Explosion(XNum).Active = 1 ' Set the active status to 1. + Explosion(XNum).X = X ' Set X and Y values to the current incoming + Explosion(XNum).Y = Y ' missile's X and Y values. + Explosion(XNum).MissileNum = MNum ' Set to the missile number that was passed in as an argument. + Explosion(XNum).MType = WMissiles ' Set to the missile type that was passed in as an argument. + Incoming(MNum).Active = 2 ' Set the specific incoming missile's active status to 2. + NumExplosions = NumExplosions + 1 ' Increase the number of global explosions to add this one. + NextExplosion = Timer ' Ensure explosion begins immediately. + +End Sub + +'---------------------------------------------------------------------------- +' GameOver +' +' Displays the full-screen explosion, read the GAME OVER +' messages, and display the score and statistics. +' Also asks the player if he/she wants to play again. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub GameOver + + Dim MessageCount As Long ' Create the variables used for score, etc. + Dim MaxMessages As Long + Dim MaxScore As Long + + Keys FALSE ' Turn off the control keys. + Play GAMEOVERSONG ' Play the game end melody. + Sound 38, 36 ' Tone at 38 hertz for 36 clock ticks. + For i = 1 To XSCALE * .666 Step 2 ' Draw an expanding explosion screen. + Circle (XSCALE / 2, YSCALE / 2), i, ExplColor + Next i + + If ScreenMode = 7 Then + Color 15, ExplColor ' Display the ending score and wave for SCREEN 7. + Else + Color 0 ' Display for SCREEN 1. + End If + Locate 1, 3: Print Using "Score: ###,###,###"; Score + Locate 1, ScreenWidth - 10: Print Using "Wave: ###"; Wave + + Center "Game statistics:", 8 ' Print the player's game statistics. + Center "Number of missiles destroyed:" + Str$(TotalIncoming), 10 + Center "Number of interceptors launched:" + Str$(TotalInterceptors), 11 + + Read MaxMessages ' Read all the message choices from the DATA statements. + + Do ' DO loop to read the Rank$ and Message$ for display. This loop will end when the MaxScore is greater than or equal to the player's Score. + Read Rank$, Message$ ' READ two elements from the next DATA statement. + MaxScore = MaxScore + 10000& + 20000& * MessageCount + MessageCount = MessageCount + 1 ' Increase message count. + Loop While MaxScore < Score And MessageCount < MaxMessages + + Center Message$, 15 ' Display Message$ in the center of line 15. + Center "Rank: " + Rank$, 16 ' Display the matching rank on line 16. + Center "Would you like to try again? (Y/N)", 20 ' Ask if player wants to play again. + + Do: Loop Until InKey$ = "" ' Clears the keyboard input buffer. + + Do ' Wait for a 'y' or 'n' keypress. + a$ = UCase$(InKey$) + Loop While a$ <> "Y" And a$ <> "N" + + If a$ = "Y" Then + ContinueGame = 1 ' Player wants to start playing again. + Else + ContinueGame = FALSE ' Player wants to end the game. + End If + +End Sub + +'---------------------------------------------------------------------------- +' HorizontalScroll +' +' Displays a string moving across the screen at a given line. +' Assumes a 40 column display. +' +' PARAMETERS: M$ - String to be displayed. +' Row - Screen row where string is displayed. +' +'---------------------------------------------------------------------------- +Sub HorizontalScroll (M$, Row) + + M$ = Space$(ScreenWidth + 2) + M$ ' Add ending spaces for display. + For i = 1 To Len(M$) - 1 ' Loop through the message in M$. + Locate Row, 1 ' Position the message on passed Row value. + Print Mid$(M$, Len(M$) - i, ScreenWidth - 1) ' Uses the MID$() function to print a ScreenWidth-1 character piece of the entire message. The piece is determined by the value of X. + UpdateTarget ' Redraw the target crosshair in case the scrolling letters overwrite it. + Delay! = Timer + .05 ' Delay the printing of each letter by .1 second. + Do While Timer < Delay!: Loop + Next i + +End Sub + +'---------------------------------------------------------------------------- +' InitFirebases +' +' Draws two firebases at the lower left and right corners of the +' screen and fills them with color. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub InitFirebases + + ' Draw the left missile launcher. + Line (0, YSCALE - 6)-(10, YSCALE - 11), 14 ' Draw each side of the triangle. + Line (0, YSCALE - 6)-(5, YSCALE - 1), 14 + Line (10, YSCALE - 11)-(5, YSCALE - 1), 14 + Paint (5, YSCALE - 6), 4, 14 ' Fill the triangle with color 4. + + ' Draw the right missile launcher. + Line (XSCALE - 1, YSCALE - 6)-(XSCALE - 11, YSCALE - 11), 14 + Line (XSCALE - 11, YSCALE - 11)-(XSCALE - 6, YSCALE - 1), 14 + Line (XSCALE - 6, YSCALE - 1)-(XSCALE - 1, YSCALE - 6), 14 + Paint (XSCALE - 6, YSCALE - 6), 4, 14 ' Fill the triangle with color 4. + +End Sub + +'---------------------------------------------------------------------------- +' InitScreen +' +' Initializes the game. Clears the screen, draws the game pieces, +' and displays score and wave numbers. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub InitScreen + + Screen 0 ' Clear the screen for each game. + Screen ScreenMode ' Change to the most appropriate screen mode. + Select Case ScreenMode + Case 7 ' Set colors for color screen. + PlanetColor = PLANETS7 + EnemyColor = ENEMYCOLORS7 + InterceptColor = INTERCEPTCOLORS7 + ExplColor = EXPLCOLORS7 + BaseColor = BASECOLORS7 + GameBkGround = GAMEBKGROUNDS7 + TargetColor = TARGETCOLORS7 + Case Else + PlanetColor = PLANETS1 ' Set colors for mono screen. + EnemyColor = ENEMYCOLORS1 + InterceptColor = INTERCEPTCOLORS1 + ExplColor = EXPLCOLORS1 + BaseColor = BASECOLORS1 + GameBkGround = GAMEBKGROUNDS1 + TargetColor = TARGETCOLORS1 + End Select + + Color , GameBkGround ' Change the background color. + + Target.X = XSCALE / 2 ' Setup first X position. + Target.Y = YSCALE / 2 + 5 ' Setup first Y position. + Target.OldX = Target.X ' Setup old target position as the current one. + Target.OldY = Target.Y + UpdateTarget ' Draw the initial target crosshair. + + Do: Loop Until InKey$ = "" ' Clear keyboard input buffer. + + UpdateScore ' Display the initial score and wave number. + ' Draw the planet edge here and fill the planet with PlanetColor. + Circle (XSCALE / 2, YSCALE + 135), PLANETRADIUS, PlanetColor + Paint (XSCALE / 2, YSCALE - 1), PlanetColor + +End Sub + +'---------------------------------------------------------------------------- +' KeyPause +' +' Suspends key event processing. This is different than +' a KEY (X) OFF command because KEY (X) STOP stores key +' events and will fire them when KEY (X) ON is used. +' +' PARAMETERS: None. +'---------------------------------------------------------------------------- +Sub KeyPause + For i = 11 To 20 ' Loop through all defined keys. + Key(i) Stop + Next i +End Sub + +'---------------------------------------------------------------------------- +' Keys +' +' Turns key event processing on or off. +' +' PARAMETERS: TurnKeysOn - If it's TRUE then enable, otherwise +' disable +'---------------------------------------------------------------------------- +Sub Keys (TurnKeysOn) + + For i = 11 To 20 ' Loop through all defined keys. + If TurnKeysOn Then + Key(i) On + Else + Key(i) Off + End If + Next i + +End Sub + +'---------------------------------------------------------------------------- +' LaunchMissile +' +' Launches an interceptor or an enemy missile. +' +' PARAMETERS: Chosen - Missile number to launch. +' XStart - X (horizontal) position of where the missile begins. +' YStart - Y (vertical) position of where the missile begins. +' XFinish - X position of where the missile is aimed. +' YFinish - Y position of where the missile is aimed. +'---------------------------------------------------------------------------- +Sub LaunchMissile (Chosen, XStart, YStart, XFinish, YFinish) + + Incoming(Chosen).Active = TRUE ' Set the active status to TRUE. + Incoming(Chosen).XStart = XStart ' Set the initial X position. + Incoming(Chosen).YStart = YStart ' Set initial Y position. + Incoming(Chosen).XFinish = XFinish ' Set the missile's X + Incoming(Chosen).YFinish = YFinish ' and Y destination location. + Incoming(Chosen).X = XStart ' Set the missile's current X + Incoming(Chosen).Y = YStart ' and Y to the start. + + ' The code below determines which direction, either X or Y, is the + ' missile's primary direction. Every time UpdateMissiles is called, the + ' missile will move in the primary direction. MaxCount determines how many + ' primary moves are made before a secondary move is made but MaXCount is + ' not the actual number of moves since it is multiplied by RESOLUTION to + ' allow fast integer math to be used instead of slower floating-point. + ' Every time UpdateMissiles is called, Count is decreased by RESOLUTION. + ' When Count is less than 0, MaxCount added to Count and the missile moves + ' in the secondary direction. + XDistance = XFinish - XStart + YDistance = YFinish - YStart + Incoming(Chosen).XOffset = Sgn(XDistance) ' Forces X and Y offsets that + Incoming(Chosen).YOffset = Sgn(YDistance) ' are always -1, 0, or 1. + + If Abs(XDistance) >= Abs(YDistance) Then ' Missile moves more horizontally than vertically. + Incoming(Chosen).MaxCount = Int(Abs(XDistance) / (Abs(YDistance) + 1) * RESOLUTION) ' Determines how many horizontal moves to make before moving vertically. RESOLUTION is used to round the value so fast integer math can be used. + Incoming(Chosen).YMajor = FALSE ' Sets flag to tell UpdateMissiles that primary direction is not Y. + Else ' Missile moves more vertically than horizontally. + Incoming(Chosen).MaxCount = Int(Abs(YDistance) / (Abs(XDistance) + 1) * RESOLUTION) ' Determines how many vertical moves to make before moving horizontally. + Incoming(Chosen).YMajor = TRUE ' Sets flag to tell UpdateMissiles that primary direction is Y. + End If + Incoming(Chosen).Count = Incoming(Chosen).MaxCount ' Sets the number of times the missile has moved in the primary direction. +End Sub + +'---------------------------------------------------------------------------- +' NewInterceptor +' +' Determines if there is room for another interceptor, and if so, +' sets up another Incoming element and draw the crosshairs for a +' permanent target point. +' +' PARAMETERS: StartX - The X screen position to beginning of the missile trail. +' StartY - The Y screen position to beginning of the missile trail. +'---------------------------------------------------------------------------- +Sub NewInterceptor (StartX As Integer, StartY As Integer) + + If NumIntercepts < 4 Then ' Allow only 4 interceptor explosions on the screen at once. + NumIntercepts = NumIntercepts + 1 ' Increase total number of intercepts by one. + TotalInterceptors = TotalInterceptors + 1 ' Increase the number of total interceptors. + + Chosen = 7 ' Start at an offset of 7 because the Incoming array handles both enemy and player missiles. + Do Until Incoming(Chosen).Active = FALSE ' DO loop to find the first unused Incoming element. + Chosen = Chosen + 1 ' Increase offset by one. + Loop + + KeyPause ' Disable key event processing. + TargetX = Target.X ' Store the current crosshair x location + TargetY = Target.Y ' and y location, in case the crosshair moves while this subprogram is running. + Keys TRUE ' Enable key event processing. + + ' Draw the stationary crosshairs on the screen so we can see where the missile is heading. + Line (TargetX - 5, TargetY - 5)-(TargetX + 5, TargetY + 5), TargetColor + Line (TargetX + 5, TargetY - 5)-(TargetX - 5, TargetY + 5), TargetColor + + LaunchMissile Chosen, StartX, StartY, TargetX, TargetY + End If + +End Sub + +'---------------------------------------------------------------------------- +' NewMissile +' +' Develops the boundaries and parameters for a new enemy missile +' to be fired. When completed, another enemy missile will be +' setup for drawing on the screen. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub NewMissile + + ' If WaveCount is more than the maximum enemy missile wave or ContinueGame isn't correct. + If WaveCount = 10 + Wave * 2 Or ContinueGame <> TRUE Then Exit Sub + + WaveCount = WaveCount + 1 ' Increase WaveCount by one. + TotalIncoming = TotalIncoming + 1 ' Increase the total incoming count by one. + MissilesFlying = MissilesFlying + 1 ' Increase the count of missiles flying. + + Do ' DO loop to select which starbase is the target. + Targ = Int(Rnd(1) * MaxStarbases) + 1 ' Randomly select until we select one that is currently active. + Loop Until Starbase(Targ).Active = TRUE + + Chosen = 1 ' Select first available missile. + Do While Incoming(Chosen).Active <> FALSE ' DO loop to determine the next available Incoming element. + Chosen = Chosen + 1 ' Increment offset by one. + Loop + + XStart = Int(Rnd(1) * XSCALE - 1) + 1 ' Randomly select where to start. + YStart = 12 + XFinish = Starbase(Targ).X ' Work variables to hold the selected starbase's X and Y position. + YFinish = Starbase(Targ).Y + + LaunchMissile Chosen, XStart, YStart, XFinish, YFinish + +End Sub + +'---------------------------------------------------------------------------- +' NewStarbase +' +' Determines a new starbase position and draws it in orbit around +' the planet. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub NewStarbase + + Chosen = 1 ' Setup initial starbase offset. + Do While Starbase(Chosen).Active = TRUE ' DO until we find one that hasn't been initialized. + Chosen = Chosen + 1 ' Increase the offset by one. + Loop + BasesLeft = BasesLeft + 1 ' Increase the number of active bases by one. + + Do ' DO loop to determine if the randomly chosen starbase is within range. + Angle! = Rnd(1) * 2 * PI ' Randomly select position along planet edge. + Y = Sin(Angle!) * PLANETRADIUS + YSCALE + 155 ' Set X and Y based on that angle. + X = Cos(Angle!) * PLANETRADIUS + XSCALE / 2 + TooClose = FALSE ' Assume that the new starbase is not too close to another one. + + For i = 1 To MaxStarbases ' Loop to make sure there isn't a conflict with an existing starbase. + ' If starbase is close then set TooClose to TRUE. + If Abs(Starbase(i).X - X) < 20 And Starbase(i).Active = TRUE Then TooClose = TRUE + Next i + Loop While Y > YSCALE - 11 Or TooClose = TRUE + + Starbase(Chosen).X = X ' Setup the chosen starbases X and Y coordinates. + Starbase(Chosen).Y = Y + Starbase(Chosen).Active = TRUE ' Set starbase active status to TRUE. + ' Draw the base in orbit around the planet. + Circle (Starbase(Chosen).X, Starbase(Chosen).Y), 7, BaseColor, , , .3 + Paint (Starbase(Chosen).X, Starbase(Chosen).Y), BaseColor + Line (Starbase(Chosen).X - XSCALE / FACTOR, Starbase(Chosen).Y - XSCALE / FACTOR)-(Starbase(Chosen).X + XSCALE / FACTOR, Starbase(Chosen).Y + XSCALE / FACTOR), 4, BF + PSet (Starbase(Chosen).X, Starbase(Chosen).Y - 3), 14 + PSet (Starbase(Chosen).X, Starbase(Chosen).Y + 3), 14 + +End Sub + +'---------------------------------------------------------------------------- +' StopMissile +' +' Stops the MNum missile and adjusts all global values that this +' operation affects. +' +' PARAMETERS: MNum - Missile number to stop +' WMissiles - Which type of missile: 1 = Incoming, 2 = Interceptor +'---------------------------------------------------------------------------- +Sub StopMissile (MNum, WMissiles) + + EraseMissileTrail MNum ' Erase the given missile's trail. + Incoming(MNum).Active = FALSE ' Set incoming active status to FALSE. + + If WMissiles = 1 Then + UpdateScore ' Update the current score. + MissilesFlying = MissilesFlying - 1 ' Reduce the number of missiles currently flying. + ' If all of the enemy missiles for this wave have already flown, call WaveComplete subprogram. + If WaveCount = 10 + 2 * Wave And MissilesFlying = 0 Then WaveComplete + NewMissile ' Start a new enemy missile flying. + Else + NumIntercepts = NumIntercepts - 1 ' Decrease the number of intercepted missiles. + XFinish = Incoming(MNum).XFinish ' Setup work variables for the finish point of the missile. + YFinish = Incoming(MNum).YFinish + ' Overwrite the target X with background. + Line (XFinish - 5, YFinish - 5)-(XFinish + 5, YFinish + 5), GameBkGround + Line (XFinish + 5, YFinish - 5)-(XFinish - 5, YFinish + 5), GameBkGround + End If + +End Sub + +'---------------------------------------------------------------------------- +' UpdateExplosions +' +' Updates all currently active explosions in the Explosions array. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub UpdateExplosions + + For XNum = 1 To 10 ' Loop for the number of possible concurrent explosions. + W = Explosion(XNum).Active ' Set work variable for active status of explosion element. + If W > 0 Then ' If this explosion is active. + X = Explosion(XNum).X ' Set work variables to explosion X and Y coordinates. + Y = Explosion(XNum).Y + + If W > EXPLRADIUS Then ' If explosion status (radius) is greater than the max radius. + For T = 1 To EXPLRADIUS ' Draw expanding circles with the background color to erase everything! + Circle (X, Y), T, GameBkGround + Next T + + ' Stop the missile that caused the explosion. + StopMissile Explosion(XNum).MissileNum, Explosion(XNum).MType + + For i = 1 To MaxStarbases ' Loop through all starbases. If starbase is active and within the exploding missile's range, destroy starbase. + If Starbase(i).Active = TRUE And ((X - Starbase(i).X) ^ 2 + (Y - Starbase(i).Y) ^ 2) ^ .5 - EXPLRADIUS < -2 Then DestroyStarbase i + Next i + + UpdateTarget ' Redraw the target crosshair. + Explosion(XNum).Active = FALSE ' Set this explosion's active status to FALSE. + Else + Explosion(XNum).Active = W + 1 ' Increase the status (radius) of current explosion. + Circle (X, Y), W, ExplColor ' Draw another circle to increase the explosion visually. + UpdateTarget ' Redraw the target crosshair. + End If + End If + Next XNum + +End Sub + +'---------------------------------------------------------------------------- +' UpdateMissiles +' +' Updates one of the two types of missiles by drawing the missile +' one pixel more in its direction of travel. +' +' PARAMETERS: Start - Where in the Incoming array to begin looking +' Finish - Where to stop looking +' WMissiles - Missile type to update (enemy or defense) +' NumOfTimes - Number of times to update the missiles +' ColorToUse - Color to use for the updated line +' +' Note: Start and Finish are not technically necessary since they can be +' resolved from WMissiles. Passing Start and Finish is faster than +' determining them each time UpdateMissiles is called, however. +'---------------------------------------------------------------------------- +Sub UpdateMissiles (Start, Finish, WMissiles, NumOfTimes, ColorToUse) + + For Chosen = Start To Finish ' Loop through the possible missiles. + If Incoming(Chosen).Active = TRUE Then ' If this incoming missile is active... + X = Incoming(Chosen).X ' Use temporary local + Y = Incoming(Chosen).Y ' variables for best speed. + YOffset = Incoming(Chosen).YOffset + XOffset = Incoming(Chosen).XOffset + Count = Incoming(Chosen).Count + MaxCount = Incoming(Chosen).MaxCount + XFinish = Incoming(Chosen).XFinish + YFinish = Incoming(Chosen).YFinish + + ' For maximum speed, use different routines for missiles that + ' move mainly horizontally than for ones that move mainly + ' vertically. + If Incoming(Chosen).YMajor Then ' If missile is mainly vertical + For i = 1 To NumOfTimes ' Do NumOfTimes + C = Point(X, Y) ' Read the color of the point. + PSet (X, Y), ColorToUse ' Add a new point to the trail. + Count = Count - RESOLUTION ' Decrease the Count. + Y = Y + YOffset ' Move vertically. + + If Count <= 0 Then ' Time for the horizontal move? + X = X + XOffset ' Yes. Move horizontally. + Count = Count + MaxCount ' Prepare Count for the next horizontal movement. + End If + + ' Explode the missile if it hits another explosion, a base, + ' or reaches its target Y. + If (C = ExplColor) Or (C = BaseColor) Or Y = YFinish Then Explode Chosen, X, Y, WMissiles ' Explode the chosen missile given the current missile type + Next i + Else ' Mainly horizontal + For i = 1 To NumOfTimes ' Do NumOfTimes + C = Point(X, Y) ' Read the color of the point. + PSet (X, Y), ColorToUse ' Add a new point to the trail. + Count = Count - RESOLUTION ' Decrease the Count. + X = X + XOffset ' Move horizontally. + + If Count <= 0 Then ' Time for the vertical move? + Y = Y + YOffset ' Yes. Move vertically. + Count = Count + MaxCount ' Prepare Count for the next vertical movement. + End If + + ' Explode the missile if it hits another explosion, a base, + ' or reaches its target X. + If (C = ExplColor) Or (C = BaseColor) Or X = XFinish Then Explode Chosen, X, Y, WMissiles ' Explode the chosen missile given the current missile type + Next i + End If + + ' Copy the temporary local variables back to the SHARED variables. + Incoming(Chosen).Count = Count + Incoming(Chosen).X = X + Incoming(Chosen).Y = Y + + End If + Next Chosen + +End Sub + +'---------------------------------------------------------------------------- +' UpdateScore +' +' Calculates new score, then performs a formatted print of the +' Score and Wave values. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub UpdateScore + + ' Calculate the new score. + Score = Score + 10 * MissilesFlying * BasesLeft * Wave + + ' Locate and do a formatted print of the current score and wave numbers. + Locate 1, 3: Print Using "Score: ###,###,###"; Score + Locate 1, ScreenWidth - 10: Print Using "Wave: ###"; Wave + +End Sub + +'---------------------------------------------------------------------------- +' UpdateTarget +' +' Checks to see if the coordinates for the target are within the +' boundaries and adjusts, if necessary. Erases the old target +' crosshair and draws the new target crosshair in its new +' position. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub UpdateTarget + + ' If target goes off the screen horizontally, restore old horizontal position. + If Target.X > XSCALE - 5 Or Target.X < 5 Then Target.X = Target.OldX + + ' Target cannot move above the SCORE line or below the top of the planet. + If Target.Y > YSCALE - 53 Or Target.Y < 15 Then Target.Y = Target.OldY + + ' If the target is in a different position than when it was last updated. + If Target.X <> Target.OldX Or Target.Y <> Target.OldY Then ' Erase the old target. + Line (Target.OldX, Target.OldY + 5)-(Target.OldX, Target.OldY - 5), 0 + Line (Target.OldX - 5, Target.OldY)-(Target.OldX + 5, Target.OldY), 0 + Target.OldX = Target.X ' Make the old X and Y values equal to the current ones. + Target.OldY = Target.Y + End If + + ' Draw new target crosshair in the new X and Y position. + Line (Target.X, Target.Y + 5)-(Target.X, Target.Y - 5), 14 + Line (Target.X - 5, Target.Y)-(Target.X + 5, Target.Y), 14 + +End Sub + +'---------------------------------------------------------------------------- +' WaveComplete +' +' Handles the screen output when a wave has been completed. Also +' sets up information for the next wave. +' +' PARAMETERS: None +'---------------------------------------------------------------------------- +Sub WaveComplete + + Key(15) Off ' Disable the Pause key. + Key(16) Off ' Disable the Quit key. + + WaveCount = 0 ' Reset the WaveCount variable that holds home many missiles have been launched in the current wave. + WaveInterceptCount = 0 ' Reset the counter for the number of interceptors launched in the wave. + Score = Score + Wave * 500 ' Calculate bonus points. + Wave = Wave + 1 ' Increment to the next wave. + Play WAVEOVERSONG ' Play the wave-end melody. + + ' Move the Wave Over, etc. message across the screen. + M$ = Str$(500 * (Wave - 1)) + " point bonus!" + Space$(20) + "Wave" + Str$(Wave - 1) + " Complete!" + HorizontalScroll M$, 10 + + For XNum = 1 To 10 ' Loop through the 10 possible explosions. + If Explosion(XNum).Active > 0 Then ' If exploding now, explosion(mnum%).active will be greater than 0 (the radius of the explosion). + X! = Explosion(XNum).X ' Get the X coordinate of the explosion. + Y! = Explosion(XNum).Y ' Get the Y coordinate of the explosion. + + For T = 1 To EXPLRADIUS ' Draw expanding circles with the background color to erase everything. + Circle (X!, Y!), T, GameBkGround + Next T + + StopMissile Explosion(XNum).MissileNum, Explosion(XNum).MType + + For i = 1 To MaxStarbases ' Loop through all starbases. If starbase is active and within the exploding missile's range, destroy starbase. + If Starbase(i).Active = TRUE And ((X! - Starbase(i).X) ^ 2 + (Y! - Starbase(i).Y) ^ 2) ^ .5 - EXPLRADIUS < -2 Then DestroyStarbase i + Next i + + UpdateTarget ' Redraw the target crosshair. + Explosion(XNum).Active = FALSE ' Reset the active flag so explosion can be re-used. + + End If + Next XNum + + For i = 1 To 10 ' Loop through all missiles (both interceptor and enemy). + If Incoming(i).Active <> 0 Then ' If it's flying or frozen, + EraseMissileTrail i ' erase it. + If i > 6 Then ' If it is an interceptor missile: + XFinish = Incoming(i).XFinish ' Store X coordinate of the missile's final target. + YFinish = Incoming(i).YFinish ' Get Y coordinate. + ' Erase the target at this line. + Line (XFinish - 5, YFinish - 5)-(XFinish + 5, YFinish + 5), GamBkGround ' Erase the target X. + Line (XFinish + 5, YFinish - 5)-(XFinish - 5, YFinish + 5), GameBkGround + End If + + End If + Incoming(i).Active = FALSE ' Reset the active flag so missile can be re-used. + Next i + + ' If score is high enough score, add another starbase if there's room. + If Score > NextNewBase And BasesLeft < 4 Then + M$ = "Bonus Starbase!" + HorizontalScroll M$, 10 ' Scroll the bonus message across the screen. + + NextNewBase = NextNewBase + 10000& * Wave ' Determine when next new starbase will possibly be awarded. + NewStarbase ' Setup another starbase. + For i = 1 To 4 ' Loop to determine need to update the number of starbases. + If Starbase(i).Active = TRUE Then MaxStarbases = i + Next i + End If + + ' Determine how to make the next wave more difficult. + If Wave / 2 = Wave \ 2 And NumMissiles < 6 Then + NumMissiles = NumMissiles + 1 ' If an even number wave, increase the # of missiles unless the maximum (6) has already been reached. + Else + IncomingDelay = IncomingDelay * .66667 ' Otherwise, make the incoming missiles 33% faster unless already at maximum speed. + If IncomingDelay < FASTESTMISSILE Then IncomingDelay = FASTESTMISSILE + End If + + UpdateScore ' Show new score and wave. + + For i = 1 To NumMissiles - 1 ' Create the new missiles (one more will be added by the StopMissile subprogram when WaveComplete is finished). + NewMissile + Next i + + NumIntercepts = 0 ' Reset the number of interceptors. + NumExplosions = 0 ' Reset the number of explosions. + Line (1, MINY)-(XSCALE, YSCALE - 51), 0, BF ' Erase this area and cover with black. + + Do: Loop Until InKey$ = "" ' Clear keyboard input buffer. + Keys TRUE ' Enable key event processing. + +End Sub + diff --git a/samples/qsynth/img/screenshot.png b/samples/qsynth/img/screenshot.png new file mode 100644 index 00000000..972c7548 Binary files /dev/null and b/samples/qsynth/img/screenshot.png differ diff --git a/samples/qsynth/index.md b/samples/qsynth/index.md new file mode 100644 index 00000000..13cf528a --- /dev/null +++ b/samples/qsynth/index.md @@ -0,0 +1,23 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QSYNTH + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Audio synthesizer by Microsoft. +``` + +### File(s) + +* [qsynth.bas](src/qsynth.bas) +* [qsynth.dat](src/qsynth.dat) +* [qsynth.zip](src/qsynth.zip) + +🔗 [sound](../sound.md), [music](../music.md) diff --git a/samples/qsynth/src/qsynth.bas b/samples/qsynth/src/qsynth.bas new file mode 100644 index 00000000..28f7fe7e --- /dev/null +++ b/samples/qsynth/src/qsynth.bas @@ -0,0 +1,1989 @@ +' QSYNTH.BAS +' +' Copyright (C) 1990 Microsoft Corporation. All Rights Reserved. +' +' This program records and plays back songs. To enter a song, use the +' piano keyboard displayed on the screen. You can save, change, and +' delete the songs and change the speed of the song play back. +' +' To run this game, press SHIFT+F5. +' +' To exit this program, press ALT, F, X. +' +' To get help on a BASIC keyword, move the cursor to the keyword and press +' F1 or click the right mouse button. +' +' To view suggestions on changing this game, press Page Down. +' +' +' Suggested Changes +' ----------------- +' +' There are many ways that you can modify this BASIC game. The CONST +' statements below these comments and the DATA statements at the end +' of this screen can be modified to change the following: +' Pitch of song playback +' Background color +' Text color +' Pressed piano key color +' System songs +' +' On the right side of each CONST statement, there is a comment that tells +' you what it does and how big or small you can set the value. Above the +' DATA statements, there are comments that tell you the format of the +' information stored there. +' +' On your own, you can also add exciting sound and visual effects or make any +' other changes that your imagination can dream up. By reading the +' Learn BASIC Now book, you'll learn the techniques that will enable you +' to fully customize this game and to create games of your own. +' +' +' If the game won't run after you have changed it, you can exit without +' saving your changes by pressing Alt, F, X and choosing NO. +' +' If you do want to save your changes, press Alt, F, A and enter a filename +' for saving your version of the program. Before you save your changes, +' however, you should make sure they work by running the program and +' verifying that your changes produce the desired results. Also, always +' be sure to keep a backup of the original program. +' +DefInt A-Z + +' These constants can be modified to change certain aspects of the game. +Const PRESSEDKEYCOLOR = 15 ' Pressed keyboard key color. Range 1-6, 8-15. +Const BACKGROUNDCOLOR = 3 ' Background color. Range 0-7 +Const TEXTCOLOR = 0 ' Menu text color. Range 0-15, but not same as BACKGROUNDCOLOR. +Const TITLECOLOR = 15 ' Mode and title color. Range 0-15, but not same as BACKGROUNDCOLOR. +Const PITCH = 4 ' Pitch of songs (higher number means lower pitch)- MUST BE BETWEEN 0 AND 4!!! +Const XTNOTELENGTH = 4 ' Length of the note sound on all PC/XT type machines. Range 1 to 24. +Const INTROSONG = "T100O2L16CCDFDEL4DL16FEDO1BO2L4C" ' Song played at game introduction + + +' The following are general constants and their values should not be changed. + +' Musical note constants. +Const C = 1 +Const DF = 2 +Const D = 3 +Const EF = 4 +Const E = 5 +Const F = 6 +Const GF = 7 +Const G = 8 +Const AF = 9 +Const A = 10 +Const BF = 11 +Const B = 12 +' Menu constants +Const MAIN = 0 +Const PRACTICE = 1 +Const RECORD = 2 +Const PLAYBACK = 3 +Const PLAYING = 6 +Const SAVING = 7 +Const EDITOR = 8 +Const EDITMENU = 9 +Const GETNAME = 10 +' Other constants +Const MAXSONG = 50 ' # of recordable selections +Const MAXNOTE = 2000 ' # notes available per song +Const FALSE = 0 ' Constant for FALSE value +Const TRUE = Not FALSE ' Constant for TRUE value +Const UP = FALSE ' Up as in key released +Const DOWN = TRUE ' Down as in key pressed +Const CANCEL = 255 +Const NOTETICK = .6 ' Length of time rests and notes are +Const RESTTICK = .7 ' played per duration increment +Const CR = 13 ' Carriage Return (Enter) +Const ESC = 27 ' Esc key +Const TABCHAR = 9 ' Tab key + +' Structure definitions +Type KeyMap + Note As Integer ' An array of this type is used to map + Oct As Integer ' keyboard keys to Note/Oct values. +End Type + +Type SongElement ' An array of this type is used to + Note As Integer ' hold all the information in a song + Oct As Integer ' (Note, Octave, and Duration of each + Dur As Integer ' note in the song) +End Type + +Type SongIndexCard ' Elements of this type make up the + naym As String * 25 ' SongIndex section of the song file, + desc As String * 40 ' describing the name/description of + Size As Integer ' a song, the length in notes, and the + Offset As Long ' position of the song in the file. +End Type + +Type FileHeader ' This structure is the file header + Count As Integer ' for the song file, indicating the + NextNote As Long ' number of songs saved, and position +End Type ' of the next unused byte in the file. + +'Declaration of all the FUNCTION and SUB procedures called in this program. +DECLARE FUNCTION ConfirmDelete% () +DECLARE FUNCTION GetNote$ (Note%) +DECLARE FUNCTION SaveChanges% () +DECLARE FUNCTION SimpleEdit% (row%, col%, text$, MaxLen%) +DECLARE SUB Center (text$, row%) +DECLARE SUB ChangeTempo (Inc%) +DECLARE SUB ClearMenuScreen (Title$) +DECLARE SUB CreateSongFile () +DECLARE SUB DeleteSong (SongNo%) +DECLARE SUB DisplayChanges () +DECLARE SUB DisplayGameTitle () +DECLARE SUB DisplayIntro () +DECLARE SUB DisplayMenuText (Menu%) +DECLARE SUB DrawBox (r1%, c1%, r2%, c2%, Title$) +DECLARE SUB DrawKeyboard () +DECLARE SUB DrawNote (Note%, Octave%, Action%) +DECLARE SUB EditSong (SongNo%) +DECLARE SUB ErrorMessage (msg$) +DECLARE SUB GetNameAndSave () +DECLARE SUB InitFreq () +DECLARE SUB LoadDefaultSong (num%) +DECLARE SUB LoadSong (SongNo%) +DECLARE SUB MainMenu () +DECLARE SUB PlayNote (Note%, Octave%, Duration#) +DECLARE SUB PlaySong () +DECLARE SUB RecordMenu (NoSave%) +DECLARE SUB RecordMode (NoSave%) +DECLARE SUB SaveSong () +DECLARE SUB TimeDelay (Dur#) + +' SHARED (global) variable declarations for use in this program +Dim Shared Freq(1 To 12) As Integer ' Base array of frequencies +Dim Shared Kyb(1 To 127) As KeyMap ' Keyboard key to piano key array +Dim Shared Song(1 To MAXNOTE) As SongElement ' Array to hold the actual song +Dim Shared Counter As Integer ' Number of notes in Song() +Dim Shared SongName As String * 25 ' Name of Song() +Dim Shared SongDesc As String * 40 ' Description of Song() +Dim Shared TEMPO As Integer ' Tempo of song playback (control) +Dim Shared TFACTOR As Single ' Tempo factor (for actual speed) +Dim Shared FileError As Integer ' Keeps file error status. +Dim Shared SongRecorded As Integer ' Flag used to decide whether or +' not a song was actually recorded +Dim KeyFlags As Integer ' Used to turn NUM LOCK off +Dim BadMode As Integer ' Used to validate screen mode + +' Use error trap to test for graphics capability. +On Error GoTo ScreenError ' Set up an error trap. +BadMode = FALSE ' ScreenError will change to TRUE if... +Screen 1 ' this statement fails, which means... + +If BadMode = TRUE Then ' no graphic was found. + Cls + Locate 11, 13 + Print "CGA, EGA Color, or VGA graphics required to run QSYNTH.BAS" + +Else + + Def Seg = 0 + KeyFlags = Peek(1047) ' Keep current keyboard flags. + If KeyFlags And 32 Then + Poke 1047, KeyFlags And 223 ' Force the NUM LOCK state to OFF. + End If + Def Seg + + On Error GoTo ErrorTrap ' Set the main error trap. + DisplayIntro ' Display the intro screen. + FileError = 0 + + StartAgain: ' If an error occurs, we start again here. + DrawKeyboard ' Draw the keyboard on the screen. + InitFreq ' Map keyboard to piano, and set frequencies. + MainMenu ' Go to the main menu. + DisplayChanges ' Display the final screen. + + If KeyFlags And 32 Then ' Restore the keyboard + Def Seg = 0 ' to the state in which + Poke 1047, KeyFlags Or 32 ' we found it originally. + Def Seg + End If + +End If + +End ' The end of module-level control flow. + + +' Error handling routine +ErrorTrap: +errnum = Err +Select Case errnum + Case 52 TO 76 + If FileError = 0 Then + ErrorMessage "Cannot access QSYNTH.DAT file." + FileError = 1 + End If + Resume Next + Case Else + ErrorMessage "Sorry, an unexpected error has occurred." + Resume StartAgain +End Select + +' Error handler for screen test +ScreenError: +BadMode = TRUE +Resume Next + + +' Data statements for the default hard-coded songs +' The format for the DATA statements for a song is: +' +' DATA "Song's Name", "Song's Description", Length of song (in "notes") +' DATA note,octave,duration ' <- first "note" +' DATA note,octave,duration ' <- second "note" +' DATA note,octave,duration ' <- third "note", etc. +SONG1: +Data "Yankee","Yankee Doodle Dandy",107 +Data 1,0,18,0,0,3,1,0,18,0,0,3,3,0,18,0,0,3,5,0,18,0,0,3,1,0,18,0,0,3 +Data 5,0,18,0,0,3,3,0,18,0,0,3,8,-1,18,0,0,3,1,0,18,0,0,3,1,0,18,0,0,3 +Data 3,0,18,0,0,3,5,0,18,0,0,3,1,0,38,0,0,6,12,-1,38,0,0,6,1,0,18,0,0,3 +Data 1,0,18,0,0,3,3,0,18,0,0,3,5,0,18,0,0,3,6,0,18,0,0,3,5,0,18,0,0,3 +Data 3,0,18,0,0,3,1,0,18,0,0,3,12,-1,18,0,0,3,8,-1,18,0,0,3,10,-1,18 +Data 0,0,3,12,-1,18,0,0,3,1,0,38,0,0,6,1,0,38,0,0,6,10,-1,38,0,0,3 +Data 12,-1,15,10,-1,18,0,0,3,8,-1,18,0,0,3,10,-1,18,0,0,3,12,-1,18 +Data 0,0,3,1,0,38,0,0,6,8,-1,38,0,0,3,10,-1,15,8,-1,18,0,0,3,6,-1,18 +Data 0,0,3,5,-1,38,0,0,6,8,-1,38,0,0,6,10,-1,38,0,0,3,12,-1,15,10,-1,18 +Data 0,0,3,8,-1,18,0,0,3,10,-1,18,0,0,3,12,-1,18,0,0,3,1,0,18,0,0,3 +Data 10,-1,18,0,0,3,8,-1,18,0,0,3,1,0,18,0,0,3,12,-1,18,0,0,3,3,0,18 +Data 0,0,3,1,0,38,0,0,6,1,0,38,0,0,6 + +SONG2: +Data "Hat","Mexican Hat Dance",36 +Data 1,0,16,6,0,10,0,0,5,1,0,16,6,0,10,0,0,5,1,0,16,6,0,10,0,0,12 +Data 1,0,16,6,0,16,8,0,16,6,0,16,5,0,10,0,0,5,6,0,16,8,0,10,0,0,15 +Data 1,0,16,5,0,10,0,0,5,1,0,16,5,0,10,0,0,5,1,0,16,5,0,10,0,0,12 +Data 1,0,16,5,0,16,6,0,16,5,0,16,3,0,10,0,0,5,5,0,16,6,0,10,0,0,15 + +'------------------------------------------------------------------------- +' Center +' +' Centers the text string it receives on the indicated row. +' +' PARAMETERS: text$ - the text to print +' row - the row on which to print text$ +'------------------------------------------------------------------------- +Sub Center (text$, row) + + Locate row%, 40 - Len(text$) \ 2 + 1 ' Calculate column to start at. + Print text$; + +End Sub + +'------------------------------------------------------------------------- +' ChangeTempo +' +' Changes the current tempo (speed) for song playback. When the +' user presses a direction key, this SUB is called with the direction of +' change as an argument and adjusts the tempo accordingly, and also updates +' the tempo control on the screen. +' +' PARAMETERS: Inc - The amount by which to change the TEMPO +' +'------------------------------------------------------------------------- +Sub ChangeTempo (Inc) Static + + Color 0, 7 ' Erase the TEMPO control lever. + Locate 23, 17 + TEMPO + Print Chr$(205) + + If Inc = UP And TEMPO < 45 Then ' Calculate new TEMPO value. + TEMPO = TEMPO + 1 + ElseIf Inc = DOWN And TEMPO > 1 Then + TEMPO = TEMPO - 1 + End If + + TFACTOR = 1 + (23 - TEMPO) * .03 ' Calculate new TFACTOR value. + Locate 23, 17 + TEMPO ' Redisplay the TEMPO control. + Print Chr$(219) + +End Sub + +'------------------------------------------------------------------------- +' ClearMenuScreen +' +' Clears the section of the screen below the keyboard, and centers +' the title given in Title$ at the top. +' +' PARAMETERS: Title$ - The text to display at the top of the +' screen or "RETAIN" to keep current title +'------------------------------------------------------------------------- +Sub ClearMenuScreen (Title$) Static + + Color TEXTCOLOR, BACKGROUNDCOLOR + If Title$ <> "RETAIN" Then ' "RETAIN" means leave the current + Color TITLECOLOR ' title on the top of the screen. + Locate 3, 20 + + ' Print a 40-character string of spaces with Title$ in the center. + Print Left$(Space$(20 - Len(Title$) \ 2) + Title$ + Space$(20), 40) + Color TEXTCOLOR + End If + + View Print 13 To 25 ' Clear these specific lines. + Cls + View Print + +End Sub + +'------------------------------------------------------------------------- +' ConfirmDelete +' +' Makes sure that the user really wants to delete the song. +' Returns TRUE if so, or FALSE if not. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Function ConfirmDelete Static + + Color BACKGROUNDCOLOR, BACKGROUNDCOLOR ' Draw the dialog box. + DrawBox 13, 38, 24, 78, "" + Color 0, 7 + DrawBox 15, 41, 20, 75, "Delete Song" + Locate 17, 43 + Print "Are you sure you want to delete" + Locate , 43, 1 + Print "the current song? (Y/N) "; + + Do ' Wait for input. + i$ = UCase$(InKey$) + Loop Until i$ <> "" + + Locate , , 0 ' Turn off cursor. + If i$ = "Y" Then ' Return appropriate value. + ConfirmDelete = TRUE + Else + ConfirmDelete = FALSE + End If + +End Function + +'------------------------------------------------------------------------- +' CreateSongFile +' +' Creates the song file QSYNTH.DAT in the proper format. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub CreateSongFile Static + + Dim Hdr As FileHeader + Dim S As SongIndexCard + + Hdr.Count = 0 + Hdr.NextNote = 1 ' Initialize header structure. + Seek #1, 1 + Put #1, , Hdr ' Put the header in the file. + + For i = 1 To MAXSONG ' Fill in the blank index records. + Put #1, , S + Next i + +End Sub + +'------------------------------------------------------------------------- +' DeleteSong +' +' Deletes a song from the song list, and deletes the song index card +' and song data from the file. To understand how this procedure works, see the +' SaveSong SUB for a description of the file structure for QSYNTH.DAT. +' +' PARAMETERS: SongNo - The song number to delete +'------------------------------------------------------------------------- +Sub DeleteSong (SongNo) Static + + Dim HeaderInfo As FileHeader + Dim S As SongIndexCard + Dim n As SongElement + FileError = 0 + + Open "QSYNTH.DAT" For Binary As 1 + Get #1, , HeaderInfo + + Seek #1, Len(HeaderInfo) + (Len(S) * (SongNo - 1)) + 1 + Get #1, , S ' Get info on song to delete. + BackPtr = S.Offset ' BackPtr is the location where the + ' collapse starts copying TO (see below). + + If SongNo = HeaderInfo.Count Then + ' SongNo was the last song in the list, so we're basically done. All + ' there is to do is reduce the number of songs by one, and update the + ' NextNote pointer in the file header to point to the first note of + ' the deleted song. Remember that NextNote always points to the next + ' available note location in the file. Note that this leaves all the + ' data of the deleted song at the end of the file, which will be over- + ' written the next time a song is saved. + HeaderInfo.Count = HeaderInfo.Count - 1 ' Reduce # of songs by one + HeaderInfo.NextNote = S.Offset ' Point NextNote at first note + ' of deleted song. + Seek #1, 1 ' Header belongs at beginning + Put #1, , HeaderInfo ' Write new header. + Close 1 + Exit Sub + Else + ' The song we're deleting is not the last one in the file, so + ' to delete it, we must "collapse" both the song index part and + ' the song data part of the file. "Collapse" here means to copy + ' all the information appearing in the file after the song we are + ' deleting up in the file, thus writing over the deleted song. Then, + ' the song count and NextNote values in the file header are updated. + Get #1, , S ' Get info on the next song in the file. + ForePtr = S.Offset ' ForePtr is where we are copying from. + End If + + ' First, we need to collapse song index part of the file. This is done by + ' moving each song index record after the deleted one up one notch, so that + ' the deleted song's index record get replaced by the one following it, and + ' so on. Also, for each record, the Offset field needs to be adjusted by + ' the size of the deleted song, which at this point can be calculated by + ' ForePtr - BackPtr, since ForePtr points to the song data immediately after + ' the deleted song, and BackPtr points to the deleted song's data. This + ' adjustment is necessary because the song data will be collapsed as well. + For i = SongNo + 1 To HeaderInfo.Count + Seek #1, Len(HeaderInfo) + (Len(S) * (i - 1)) + 1 + Get #1, , S ' Get the old song index record. + S.Offset = S.Offset - (ForePtr - BackPtr) ' Make the adjustment + Seek #1, Len(HeaderInfo) + (Len(S) * (i - 2)) + 1 + Put #1, , S ' and put it in it's new place. + Next i + + ' Next, we need to collapse the song data part of the file. This is done in + ' the same way that the song index part was, with the exception that it is + ' moved up in the file one note at a time. ALL notes of ALL songs after the + ' deleted song are copied with the following loop. + For i = ForePtr To HeaderInfo.NextNote - Len(n) Step Len(n) + Seek #1, Len(HeaderInfo) + (Len(S) * MAXSONG) + i + Get #1, , n ' Get a note. + Seek #1, Len(HeaderInfo) + (Len(S) * MAXSONG) + BackPtr + Put #1, , n ' Put it at it's new location. + BackPtr = BackPtr + Len(n) ' Update BackPtr. + Next i + + ' The last step is to update the file header record. This is the same as + ' if we deleted the last song; reduce the song count by one, and point NextNote + ' at the next AVAILABLE note location in the song data section. Note that + ' after the above loop completes, i points to one past the last note of the + ' last song (which is exactly what we want for NextNote). + HeaderInfo.Count = HeaderInfo.Count - 1 + HeaderInfo.NextNote = i + Seek #1, 1 + Put #1, , HeaderInfo ' write the new file header + Close 1 ' - song is history! + +End Sub + +'------------------------------------------------------------------------- +' DisplayChanges +' +' Displays game characteristics that you can easily change via CONST and DATA. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub DisplayChanges + + DisplayGameTitle ' Print game title + + Color 7 ' Print suggested changes in white. + Center "The following game characteristics can be easily changed from", 5 + Center "within QuickBASIC Interpreter. To change the values of these", 6 + Center "characteristics, locate the corresponding CONST or DATA ", 7 + Center "statements in the source code and change their values, then ", 8 + Center "restart the program (press Shift + F5). ", 9 + Color 15 + Center "Pitch of song playback ", 11 + Center "Background color ", 12 + Center "Text color ", 13 + Center "Pressed piano key color", 14 + Center "System songs ", 15 + Color 7 + Center "The CONST statements and instructions on changing them are ", 17 + Center "located at the beginning of the main program. ", 18 + + Do While InKey$ = "": Loop ' Wait for any keypress. + Cls + +End Sub + +'------------------------------------------------------------------------- +' DisplayGameTitle +' +' Displays game title for use in the introduction and suggested changes. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub DisplayGameTitle + + ' Set the screen to a normal text, clear it and add blue background. + Screen 0 + Width 80, 25 + Color 4, 0 + Cls + + Locate 1, 2 ' Draw outline around screen with extended ASCII characters. + Print Chr$(201); String$(76, 205); Chr$(187); ' top border + For x% = 2 To 24 ' left and right borders + Locate x%, 2 + Print Chr$(186); Tab(79); Chr$(186); + Next x% + Locate 25, 2 + Print Chr$(200); String$(76, 205); Chr$(188); ' bottom border + + ' Print game title centered at top of screen + Color 0, 4 ' Print title in black on red. + Center " Microsoft ", 1 ' Center game title on lines 1 & 2. + Center " Q S Y N T H E S I Z E R ", 2 + Center " Press any key to continue ", 25 + Color 7, 0 + +End Sub + +'------------------------------------------------------------------------- +' DisplayIntro +' +' Displays game introduction screen. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub DisplayIntro + + DisplayGameTitle ' Display game title. + + Color 7 + Center "Copyright (C) 1990 Microsoft Corporation. All Rights Reserved.", 4 + Center "Microsoft QSynthesizer allows you to record and play back songs", 7 + Center "entered by pressing keys on the keyboard. You can save up to ", 8 + Center LTrim$(Str$(MAXSONG)) + " songs on disk and play them back as often as you like. You", 9 + Center "can also use the song editor to fine-tune your songs. ", 10 + Center "Just follow the directions in the menus to play, record, save,", 12 + Center "edit, and delete your songs. ", 13 + + Play INTROSONG ' Play melody while waiting to continue. + + Do While InKey$ = "": Loop ' Wait for any keypress. + +End Sub + +'------------------------------------------------------------------------- +' DisplayMenuText +' +' Displays almost all the text, boxes, and other info on the screen. It +' uses the parameter (Menu) to determine which screen has been requested. +' +' PARAMETERS: Menu - The "Menu" number to be displayed +'------------------------------------------------------------------------- +Sub DisplayMenuText (Menu) Static + + Select Case Menu + Case MAIN ' Main menu screen. + ClearMenuScreen "" + Color 0, 7 + DrawBox 14, 7, 24, 35, "Song List" + Color TEXTCOLOR, BACKGROUNDCOLOR + Locate 14, 46 + Print "P - Play current song" + Locate , 46 + Print "R - Record a new song" + Locate , 46 + Print "E - Edit song from list" + Locate , 46 + Print "D - Delete song from list" + Locate , 46 + Print "S - Practice QSynthesizer" + Locate , 46 + Print "Q - Quit QSynthesizer" + Locate 21, 40 + Print "Use the arrow keys to select a song." + Locate , 41 + Print "Press the corresponding letter to" + Locate , 44 + Print "make a selection from above." + + Case PRACTICE, RECORD ' These two are almost the same (PRACTICE and RECORD modes). + If Menu = PRACTICE Then + ClearMenuScreen "Practice Mode" + Center "When finished practicing, press the Esc key.", 20 + Else + ClearMenuScreen "Record Mode" + Center "When finished recording, press the Esc key.", 20 + End If + Center "To play a note, press the key on the keyboard", 16 + Center "corresponding to the desired note shown on", 17 + Center "the piano above. ", 18 + + Case PLAYBACK ' Song playback screen - with the TEMPO control. + ClearMenuScreen "Playback Mode: " + RTrim$(SongName) + Color TITLECOLOR + Locate 14, 40 - (Len(RTrim$(SongDesc)) \ 2) + Print RTrim$(SongDesc) + Color TEXTCOLOR + Center "Use arrow keys to adjust tempo.", 17 + Center "Press Enter to start song playback.", 18 + Center "Press Esc to exit playback mode.", 19 + Color 0, 7 + DrawBox 21, 15, 24, 65, "Tempo Control" + Locate 22, 17 + Print "Slow" + Locate 22, 60 + Print "Fast" + Locate , 17 + Print Chr$(198); String$(22, 205); Chr$(219); String$(22, 205); Chr$(181) + TEMPO = 23 + TFACTOR = 1 + Color TEXTCOLOR, BACKGROUNDCOLOR + + Case EDITOR ' Song editor screen. + ClearMenuScreen "Edit Mode: " + RTrim$(SongName) + Locate 14, 58 - Len(RTrim$(SongDesc)) \ 2 + Color TITLECOLOR + Print RTrim$(SongDesc) + Color TEXTCOLOR + Locate 16, 46 + Print "C - Change current note" + Locate , 46 + Print "I - Insert new note" + Locate , 46 + Print "D - Delete current note" + Locate , 46 + Print "P - Play song" + Locate 22, 41 + Print "Press the corresponding letter to" + Locate , 39 + Print "make a selection from the list above." + Locate , 43 + Print "Press Esc to exit the editor."; + Color 0, 7 + DrawBox 14, 5, 24, 35, "Note List" + Color 15 + Locate 15, 6 + Print "Note Octave Duration" + Color 0 + Locate 22, 5 + Print Chr$(195); String$(29, 196); Chr$(180) + + Case GETNAME ' This is the dialog box to get the song name. + ClearMenuScreen "RETAIN" + Color 0, 7 + DrawBox 14, 10, 24, 70, "Save Recorded Song" + DrawBox 15, 26, 17, 53, "" + DrawBox 18, 26, 20, 68, "" + Locate 16, 12 + Print "Song's Name:" + Locate 19, 12 + Print "Description:" + Locate 22, 15 + Print "Press Tab to change edit fields, and Enter to save." + Locate 23, 12 + Print "Press Esc to return to main menu without saving the song." + + End Select + +End Sub + +'------------------------------------------------------------------------- +' DrawBox +' +' Draws a box using single line characters at the given coordinates. +' +' PARAMETERS: r1,c1 - The row and column location of the upper left corner +' r2,c2 - The row and column location of the lower right corner +' Title$ - The text to place at the top of the box, if any +'------------------------------------------------------------------------- +Sub DrawBox (r1, c1, r2, c2, Title$) Static + + InBoxWidth = c2 - c1 - 1 ' Calculate box width. + + Locate r1, c1 ' Draw the top line. + Print Chr$(218); String$(InBoxWidth, 196); Chr$(191) + + For t = r1 + 1 To r2 - 1 ' Draw sides of the box. + Locate t, c1 + Print Chr$(179); Space$(InBoxWidth); Chr$(179); + Next t + + Locate r2, c1 ' Draw the bottom line. + Print Chr$(192); String$(InBoxWidth, 196); Chr$(217); + + If Title$ <> "" Then ' Put the title on top. + Locate r1, c1 + (InBoxWidth \ 2) - (Len(Title$) \ 2) + Print " "; Title$; " "; + End If + +End Sub + +'------------------------------------------------------------------------- +' DrawKeyboard +' +' Draws the piano keyboard on the screen. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub DrawKeyboard Static + + Color TITLECOLOR, BACKGROUNDCOLOR + Width 80, 25 + Cls + + ' - Print top lines of keyboard. + Locate 2, 29 + Print "Microsoft QSynthesizer" + Color 7, 0 + Locate 5, 4 + Print Space$(75) + Locate , 4 + Print Space$(75) + + ' Print middle section (black/white keys). + Color 0, 7 + temp$ = Chr$(179) + " " + Chr$(219) + " " + Chr$(219) + " " + Chr$(179) + " " + temp$ = temp$ + Chr$(219) + " " + Chr$(219) + " " + Chr$(219) + " " + temp2$ = Chr$(179) + " " + Chr$(222) + For i = 1 To 3 + Locate , 4 + Print Chr$(219); Chr$(221); Mid$(temp$, 2); temp$; + Print temp$; temp$; temp$; temp2$; Chr$(219) + Next i + + ' Print middle section (white keys only). + For i = 1 To 2 + Locate , 4 + Print Chr$(219); Chr$(221); + For t = 1 To 35 + Print " "; Chr$(179); + Next t + Print " "; Chr$(222); Chr$(219) + Next i + Color 7, 0 + Locate , 4 + Print Space$(75) + +End Sub + +'------------------------------------------------------------------------- +' DrawNote +' +' Highlights or un-highlights the given note on the piano keyboard. +' +' PARAMETERS: Note - The note number to draw +' Octave - The octave number (-3 to 3) of the note +' Action - What to do (DOWN = un-highlight, UP = highlight) +'------------------------------------------------------------------------- +Sub DrawNote (Note, Octave, Action) Static + + If Note = 0 Then Exit Sub ' Note = 0 means do not draw a note + + Select Case Note + Case A, B, C, D, E, F, G ' Find offset from middle C for a + Select Case Note ' white key. + Case A + Offset = 10 + Case B + Offset = 12 + Case C + Offset = 0 + Case D + Offset = 2 + Case E + Offset = 4 + Case F + Offset = 6 + Case G + Offset = 8 + End Select + col = (34 + Offset) + (Octave * 14) ' Calculate column value. + bottom = 11 ' Bottom of key (row) + keyColor = 7 ' Color to draw UP key + + Case Else ' Find offset from middle C for a + Select Case Note ' black key. + Case DF + Offset = 1 + Case EF + Offset = 3 + Case GF + Offset = 7 + Case AF + Offset = 9 + Case BF + Offset = 11 + End Select + col = (34 + Offset) + (Octave * 14) ' Calculate column value. + bottom = 9 ' Bottom of key (row) + keyColor = 0 ' Color to draw UP key + End Select + + If Action = DOWN Then + Color PRESSEDKEYCOLOR ' Set pressed key color. + Else + Color keyColor + End If + + If col > 5 And col < 77 Then ' Using the calculated row + For row = 7 To bottom ' and the bottom found, draw + Locate row, col ' a vertical line of blocks + Print Chr$(219) ' to fill in key pressed. + Next row + End If + +End Sub + +'------------------------------------------------------------------------- +' EditSong +' +' This is the song editor. Each of the functions available in the song editor +' are subroutines contained in this subprogram. +' +' PARAMETERS: SongNo - The number of the song being edited, indexed +' from the beginning of the QSYNTH.DAT file +'------------------------------------------------------------------------- +Sub EditSong (SongNo) Static + + Dim EditNote As SongElement, DrawnNote As SongElement + + ' - Initialize screen and variables. + DisplayMenuText EDITOR + Cursor = 1 + WindowTop = 1 + DrawnNote.Note = 0 + Finished = FALSE + GoSub DisplayNoteTable + + 'Poll the keyboard, performing requested functions, until the Esc key is pressed. + While Not Finished + Do + x$ = InKey$ ' - Wait for a keypress. + Loop Until x$ <> "" + + If Len(x$) > 1 Then ' - Key was a function key + Color 0, 7 + GoSub DrawNoteCursor ' "undraw" note cursor + If Right$(x$, 1) = "H" And Cursor > 1 Then ' UP arrow + Cursor = Cursor - 1 + ElseIf Right$(x$, 1) = "P" And Cursor < Counter Then ' DOWN arrow + Cursor = Cursor + 1 + End If + Color 7, 0 + GoSub DrawNoteCursor ' Redraw note cursor. + GoSub PrintEditorStatus ' Update the current note value. + + Else ' Key was a standard key + Select Case UCase$(x$) + Case "C" ' - Change note. + EditNote = Song(Cursor) + EditTitle$ = "Change a Note" + GoSub GetNewNote ' Do the note edit. + If Not (Cancelled) Then + Song(Cursor) = EditNote + End If + GoSub DisplayNoteTable ' Update the note list to display change. + + Case "D" ' - Delete note. + GoSub DeleteCurrentNote + + Case "I" ' - Insert note + EditNote.Note = C + EditNote.Oct = 0 + EditNote.Dur = 4 + EditTitle$ = "Insert a Note" + GoSub GetNewNote ' Do the note edit. + If Not (Cancelled) Then + GoSub InsertEditNote + End If + GoSub DisplayNoteTable ' Update the note list. + + Case "P" ' - Play song. + DrawNote DrawnNote.Note, DrawnNote.Oct, UP + PlaySong ' Play the song. + DisplayMenuText EDITOR ' Redraw the editor screen. + GoSub DisplayNoteTable ' Update the note table. + + Case Chr$(27) ' - Esc key was pressed! + Finished = TRUE ' time to leave + + End Select + End If + Wend + + ' - See if the user wants to save his/her changes. + If SaveChanges Then + DeleteSong SongNo + SaveSong + End If + DrawNote DrawnNote.Note, DrawnNote.Oct, UP + Exit Sub + + ' - This subroutine displays the notes in text format in the Note List box. + DisplayNoteTable: + GoSub PrintEditorStatus + For i = 16 To 21 + Locate i, 6 + Color 0, 7 + CurNote = i + WindowTop - 16 + If CurNote <= Counter Then + GoSub PrintCurNote + Else + Print Space$(29) + End If + Next i + Color 7, 0 + + ' - This subroutine draws the current note again but in a different color to indicate a "cursor." + DrawNoteCursor: + If Cursor < WindowTop Then + WindowTop = Cursor + GoTo DisplayNoteTable + ElseIf Cursor > WindowTop + 5 Then + WindowTop = Cursor - 5 + GoTo DisplayNoteTable + End If + CurNote = Cursor + Locate Cursor - WindowTop + 16, 6 + GoSub PrintCurNote + DrawNote DrawnNote.Note, DrawnNote.Oct, UP + DrawNote Song(CurNote).Note, Song(CurNote).Oct, DOWN + DrawnNote = Song(CurNote) + Return + + ' - This subroutine actually does the conversion of the note into text information and prints it out. + PrintCurNote: + If Song(CurNote).Note = 0 Then + Print Using " \ \ ###### "; ""; Song(CurNote).Dur + Else + Print Using " \ \ ## ###### "; GetNote$(Song(CurNote).Note); Song(CurNote).Oct; Song(CurNote).Dur + End If + Return + + ' - This subroutine displays the number of notes in the song and the number of the current note. + PrintEditorStatus: + Color 7, 0 + Locate 23, 6 + Print Using " Notes: #### Current: #### "; Counter; Cursor + Return + + ' - This subroutine deletes the current note. + DeleteCurrentNote: + If Counter = 1 Then + ErrorMessage "You cannot delete the last note." + DisplayMenuText EDITOR + Else + Counter = Counter - 1 + For i = Cursor To Counter + Song(i) = Song(i + 1) ' Delete note up on notch. + Next i + If Cursor > Counter Then Cursor = Counter + End If + GoTo DisplayNoteTable + + ' - This subroutine controls the input of a new note. It draws + ' - the box, processes the keys pressed and changes the note + ' - values accordingly, until Esc or Enter is pressed. Before + ' - this routine is called, the starting values of the new note + ' - are placed in EditNote; when the edit has been completed, the + ' - new note's value is placed back into EditNote. + GetNewNote: + Color 0, 7 ' Draw the edit box. + DrawBox 16, 39, 24, 76, EditTitle$ + Locate 18, 42 + Print "Use arrow keys to change values" + Locate , 42 + Print "Enter when done, Esc to cancel" + Locate 21, 42 + Color 7, 0 + Print "Note"; + Color 0, 7 + Print " Octave Duration" + EditField = 1 + EditDone = FALSE + Cancelled = FALSE + + While Not EditDone + Note$ = GetNote$(EditNote.Note) ' Display the note. + Locate 22, 42 + If EditNote.Note > 0 Then + Print Using "\ \ ## ######"; Note$; EditNote.Oct; EditNote.Dur + Else + Print Using "\ \ ######"; " "; EditNote.Dur + End If + + Do + k$ = InKey$ + Loop While k$ = "" + + If Len(k$) > 1 Then + Select Case Right$(k$, 1) + Case "H", "P" ' Up arrow or Down arrow key pressed + If Right$(k$, 1) = "H" Then ' set increment appropriately. + Increment = 1 + Else + Increment = -1 + End If + + Select Case EditField ' Change value according to edit mode. + Case 1 + EditNote.Note = EditNote.Note + Increment + If EditNote.Note > B Then + EditNote.Note = 0 + EditNote.Oct = EditNote.Oct + 1 + ElseIf EditNote.Note < 0 Then + EditNote.Note = B + EditNote.Oct = EditNote.Oct - 1 + End If + Case 2 + EditNote.Oct = EditNote.Oct + Increment + Case 3 + EditNote.Dur = EditNote.Dur + Increment + If EditNote.Dur < 1 Then EditNote.Dur = 0 + End Select + + If EditNote.Oct = 3 Then ' Keep octave value in range. + If EditNote.Note > C Then + EditNote.Oct = 2 + End If + ElseIf EditNote.Oct > 3 Then + EditNote.Oct = 3 + ElseIf EditNote.Oct < -2 Then + EditNote.Oct = -2 + End If + + Case "K", "M" ' Left arrow or Right arrow key pressed. + If Right$(k$, 1) = "K" Then ' Set increment appropriately. + Increment = -1 + Else + Increment = 1 + End If + + EditField = EditField + Increment ' Change edit mode according + If EditField > 3 Then EditField = 1 ' to increment's value. + If EditField < 1 Then EditField = 3 + + Locate 21, 42 ' Redraw the field titles to + Color 0, 7 ' show which one has focus. + Print "Note Octave Duration" + Color 7, 0 + Select Case EditField + Case 1 + Locate 21, 42 + Print "Note" + Case 2 + Locate 21, 53 + Print "Octave" + Case 3 + Locate 21, 65 + Print "Duration" + End Select + Color 0, 7 + + End Select + + ElseIf k$ = Chr$(13) Then ' Enter key = exit + EditDone = TRUE + ElseIf k$ = Chr$(27) Then ' Esc key = exit/cancel + Cancelled = TRUE + EditDone = TRUE + End If + Wend + DisplayMenuText EDITOR ' Redisplay editor screen. + Return + + ' - This subroutine inserts EditNote into the song just before the current note. + InsertEditNote: + Counter = Counter + 1 + For i = Counter To Cursor + 1 Step -1 ' Move all notes from current + Song(i) = Song(i - 1) ' note down one notch, and put + Next i ' the new note at the current + Song(Cursor) = EditNote ' location. + Cursor = Cursor + 1 + Return + +End Sub + +'------------------------------------------------------------------------- +' ErrorMessage +' +' Prints an error message in a box and waits for a keypress. +' +' PARAMETERS: msg$ - The message to display in the box. +'------------------------------------------------------------------------- +Sub ErrorMessage (msg$) Static + + Color 15, 4 ' Draw the box. + DrawBox 15, 15, 19, 65, "" + Locate 16, 40 - Len(msg$) \ 2 + Print msg$ ' Print the message + Locate 18, 27 + Print "Press any key to continue" + + Sound 250, 1 ' Make some sound. + Sound 32767, 2 + Sound 200, 1 + + Do While InKey$ = "": Loop ' Wait for a keypress. + +End Sub + +'------------------------------------------------------------------------- +' GetNameAndSave +' +' Gets a name and description for a newly recorded song. If the +' user presses the Esc key, the song is not saved. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub GetNameAndSave Static + + DisplayMenuText GETNAME ' Display the screen info. + + Finished = FALSE + EditField = 1 + naym$ = "" + desc$ = "" + + While Finished = FALSE ' Depending on the value of + Select Case EditField ' EditField, call SimpleEdit + Case 1 ' with either naym$ or desc$ + RetVal = SimpleEdit(16, 27, naym$, 25) ' as a parameter. Then, take + If RetVal = TABCHAR Then EditField = 2 ' a look at the return value: + Case 2 ' If it was a Tab key, then + RetVal = SimpleEdit(19, 27, desc$, 40) ' switch to the other edit + If RetVal = TABCHAR Then EditField = 1 ' field otherwise, we're done. + End Select + + If RetVal = ESC Or RetVal = CR Then + If naym$ = "" And RetVal = CR Then ' Make sure user enters a name. + ErrorMessage "You must supply a song name." + DisplayMenuText GETNAME ' Redisplay dialog box. + Locate 16, 27 + Print naym$ + Locate 19, 27 + Print desc$ + Else + Finished = TRUE + End If + End If + Wend + + If RetVal = CR Then ' Only save the song if the + SongName = naym$ ' user pressed Enter to + SongDesc = desc$ ' terminate the save dialog. + SaveSong + End If + +End Sub + +'------------------------------------------------------------------------- +' GetNote$ +' +' Given a note number, return the text representation of that note. +' +' PARAMETERS: Note - Value of note to be converted +'------------------------------------------------------------------------- +Function GetNote$ (Note) Static + + Select Case Note + Case C + GetNote$ = "C" + Case D + GetNote$ = "D" + Case E + GetNote$ = "E" + Case F + GetNote$ = "F" + Case G + GetNote$ = "G" + Case A + GetNote$ = "A" + Case B + GetNote$ = "B" + Case DF + GetNote$ = "D flat" + Case EF + GetNote$ = "E flat" + Case GF + GetNote$ = "G flat" + Case AF + GetNote$ = "A flat" + Case BF + GetNote$ = "B flat" + End Select + +End Function + +'------------------------------------------------------------------------- +' InitFreq +' +' Initializes the note frequency table and the keyboard map array. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub InitFreq Static + + ' - Initialize frequency table + Freq(1) = 4186 + Freq(2) = 4435 + Freq(3) = 4699 + Freq(4) = 4978 + Freq(5) = 5274 + Freq(6) = 5588 + Freq(7) = 5920 + Freq(8) = 6272 + Freq(9) = 6645 + Freq(10) = 7040 + Freq(11) = 7459 + Freq(12) = 7902 + + ' Initialize keyboard map + For i = 1 To 127 + Kyb(i).Note = 0 ' Set all keys to 0 first + Kyb(i).Oct = 0 ' (that means no note is + Next i ' played if that key is pressed). + + CurNote = C ' Initialize counter variables. + CurOct = -1 + + ' + ' The code below correlates note/octave values with the values + ' returned by the INP(&H60) function, which is the function that reads + ' the keyboard port to see what key is pressed. The numbers returned by + ' the keys pressed are sequential as follows: + ' + ' KEY PRESSED VALUE RETURNED + ' + ' 1 thru 0 -> 2 thru 11 + ' Q thru P -> 16 thru 25 + ' A thru ; -> 30 thru 39 + ' Z thru , -> 44 thru 51 + ' + + 'Mapping for Q through P + Kyb(16).Note = A + Kyb(16).Oct = -2 + Kyb(17).Note = B + Kyb(17).Oct = -2 + Kyb(18).Note = C + Kyb(18).Oct = -1 + Kyb(19).Note = D + Kyb(19).Oct = -1 + Kyb(20).Note = E + Kyb(20).Oct = -1 + Kyb(21).Note = F + Kyb(21).Oct = -1 + Kyb(22).Note = G + Kyb(22).Oct = -1 + Kyb(23).Note = A + Kyb(23).Oct = -1 + Kyb(24).Note = B + Kyb(24).Oct = -1 + Kyb(25).Note = C + Kyb(25).Oct = 0 + Kyb(26).Note = D + Kyb(26).Oct = 0 + Kyb(27).Note = E + Kyb(27).Oct = 0 + + 'Mapping for 1 through 0 + Kyb(3).Note = BF + Kyb(3).Oct = -2 + Kyb(5).Note = DF + Kyb(5).Oct = -1 + Kyb(6).Note = EF + Kyb(6).Oct = -1 + Kyb(8).Note = GF + Kyb(8).Oct = -1 + Kyb(9).Note = AF + Kyb(9).Oct = -1 + Kyb(10).Note = BF + Kyb(10).Oct = -1 + Kyb(12).Note = DF + Kyb(12).Oct = 0 + Kyb(13).Note = EF + Kyb(13).Oct = 0 + + 'Mapping for Z through . + Kyb(44).Note = F + Kyb(44).Oct = 0 + Kyb(45).Note = G + Kyb(45).Oct = 0 + Kyb(46).Note = A + Kyb(46).Oct = 0 + Kyb(47).Note = B + Kyb(47).Oct = 0 + Kyb(48).Note = C + Kyb(48).Oct = 1 + Kyb(49).Note = D + Kyb(49).Oct = 1 + Kyb(50).Note = E + Kyb(50).Oct = 1 + Kyb(51).Note = F + Kyb(51).Oct = 1 + Kyb(52).Note = G + Kyb(52).Oct = 1 + Kyb(53).Note = A + Kyb(53).Oct = 1 + + 'Mapping for A through ; + Kyb(31).Note = GF + Kyb(31).Oct = 0 + Kyb(32).Note = AF + Kyb(32).Oct = 0 + Kyb(33).Note = BF + Kyb(33).Oct = 0 + Kyb(35).Note = DF + Kyb(35).Oct = 1 + Kyb(36).Note = EF + Kyb(36).Oct = 1 + Kyb(38).Note = GF + Kyb(38).Oct = 1 + Kyb(39).Note = AF + Kyb(39).Oct = 1 + Kyb(40).Note = BF + Kyb(40).Oct = 1 + +End Sub + +'------------------------------------------------------------------------- +' LoadDefaultSong +' +' Reads the data for either SONG1 or SONG2 into the Song() array. +' +' PARAMETERS: num - Indicates which internal song to load +'------------------------------------------------------------------------- +Sub LoadDefaultSong (num) Static + + If num = 1 Then ' Restore appropriate line number. + Restore SONG1 + Else + Restore SONG2 + End If + + Read SongName, SongDesc, Counter ' Read global song info. + For i = 1 To Counter ' Read in the notes. + Read n, o, Dur + Song(i).Note = n + Song(i).Oct = o + Song(i).Dur = Dur + Next i + +End Sub + +'------------------------------------------------------------------------- +' LoadSong +' +' Given an index into the QSYNTH.DAT file, this SUB loads the song data from +' the file into the global Song() array. +' +' PARAMETERS: SongNo - Index of song to load +'------------------------------------------------------------------------- +Sub LoadSong (SongNo) Static + + Dim HeaderInfo As FileHeader + Dim S As SongIndexCard + FileError = 0 + + Open "QSYNTH.DAT" For Binary As 1 + + ' seek to the beginning of the song index record and read it + Seek #1, Len(HeaderInfo) + (Len(S) * (SongNo - 1)) + 1 + Get #1, , S + SongName = S.naym ' Set the global song info. + SongDesc = S.desc + Counter = S.Size + + ' seek to the beginning of the actual song information according to the + ' information in the song index record + Seek #1, Len(HeaderInfo) + (Len(S) * MAXSONG) + S.Offset + + For i = 1 To Counter ' Read the notes in from disk. + Get #1, , Song(i) + Next i + Close 1 + +End Sub + +'------------------------------------------------------------------------- +' MainMenu +' +' Handles the main menu. It waits for a keypress and acts upon it. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub MainMenu Static + + Dim S As SongIndexCard + Dim HeaderInfo As FileHeader ' Dimension variables. + ReDim i$(1 To 10) + + Cursor = 1 + WindowTop = 1 + SongLoaded = 0 + GoSub LoadSongList + + Finished = FALSE + While Not Finished + DisplayMenuText MAIN + GoSub DisplaySongList + x$ = "" + ' Wait for a relevant keypress + While InStr("PSERDQ" + Chr$(13), x$) = 0 Or x$ = "" + x$ = UCase$(InKey$) + If Len(x$) > 1 Then + If Right$(x$, 1) = "H" And Cursor > 1 Then + Cursor = Cursor - 1 + ElseIf Right$(x$, 1) = "P" And Cursor < UBound(i$) Then + Cursor = Cursor + 1 + End If + GoSub DisplaySongList + End If + Wend + + Select Case x$ + Case "S" + RecordMenu (TRUE) ' Practice mode. + + Case "P", Chr$(13) ' Load and play the appropriate song. + If Cursor > 2 Then + LoadSong Cursor - 2 + Else + LoadDefaultSong Cursor + End If + PlaySong + + Case "E" ' Song editor + If Cursor > 2 Then + LoadSong Cursor - 2 + EditSong Cursor - 2 + Else + ErrorMessage "You cannot edit a system song." + End If + + Case "R" ' Record mode + SongRecorded = FALSE + RecordMenu (FALSE) + If SongRecorded Then + GetNameAndSave ' Only ask to save if something was recorded. + End If + GoSub LoadSongList + + Case "D" ' Delete song + If Cursor > 2 Then + If ConfirmDelete Then + DeleteSong Cursor - 2 + If Cursor = UBound(i$) Then Cursor = Cursor - 1 + GoSub LoadSongList + End If + Else + ErrorMessage "You cannot delete a system song." + End If + + Case "Q" ' Quit QSynth. + Finished = TRUE + End Select + Wend + Exit Sub + + ' This subroutine loads the names of all the songs in the QSYNTH.DAT file. + LoadSongList: + Open "QSYNTH.DAT" For Binary As 1 + If LOF(1) = 0 Then + CreateSongFile ' Create disk file if not there. + End If + HeaderInfo.Count = 0 + Get #1, , HeaderInfo + ReDim i$(1 To 2 + HeaderInfo.Count) ' Size array appropriately. + Restore SONG1 ' First two songs are provided as DATA statements. + Read i$(1) + Restore SONG2 + Read i$(2) + + For i = 3 To UBound(i$) ' Read the rest from disk. + Get #1, , S + i$(i) = S.naym + Next i + Close 1 + Return + + ' This subroutine displays the song list in the Song List box. + DisplaySongList: + Color 0, 7 + For i = 15 To 23 + Locate i, 8 + If i - 15 + WindowTop <= UBound(i$) Then + Print " "; Left$(i$(i - 15 + WindowTop) + Space$(27), 25); " " + Else + Print Space$(27) + End If + Next i + + ' This subroutine displays the "cursor" by re-displaying the current song's name in a different color. + DisplaySongCursor: + If Cursor < WindowTop Then + WindowTop = Cursor + GoTo DisplaySongList + ElseIf Cursor > WindowTop + 8 Then + WindowTop = Cursor - 8 + GoTo DisplaySongList + End If + Color 7, 0 + Locate 15 + Cursor - WindowTop, 8 + Print " "; Left$(i$(Cursor) + Space$(27), 25); " " + Color TEXTCOLOR, BACKGROUNDCOLOR + Return + +End Sub + +'------------------------------------------------------------------------- +' PlayNote +' +' Calculates the correct frequency of the note given in the octave +' given for the duration given. +' +' PARAMETERS: Note - The note to play +' Octave - The octave to play the note in +' Duration# - The duration (time) to play the note +'------------------------------------------------------------------------- +Sub PlayNote (Note, Octave, Duration#) Static + + If Note <> 0 Then + ' Perform equation to find frequency value from the Freq() array + ThisFreq& = Freq(Note) / (2 ^ (PITCH - Octave)) + + If ThisFreq& > 32767 Then ThisFreq& = 32767 + Sound ThisFreq&, Duration# + Else + TimeDelay Duration# + End If + +End Sub + +'------------------------------------------------------------------------- +' PlaySong +' +' Performs song playback by running through the Song() array playing +' each note, and highlighting each note on the keyboard. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub PlaySong Static + + DisplayMenuText PLAYBACK + + Do ' Wait for the Enter key, + i$ = InKey$ ' Adjust the tempo. + Select Case i$ + Case Chr$(27) + Exit Sub + Case Chr$(0) + "H", Chr$(0) + "M" + ChangeTempo UP + Case Chr$(0) + "P", Chr$(0) + "K" + ChangeTempo DOWN + Case Chr$(13) + Exit Do + End Select + Loop + + Finished = FALSE + For i = 1 To Counter + DrawNote Song(i).Note, Song(i).Oct, DOWN + For j = 1 To Song(i).Dur + If Song(i).Note > 0 Then + PlayNote Song(i).Note, Song(i).Oct, NOTETICK * TFACTOR + Else + PlayNote 0, 0, RESTTICK * TFACTOR + End If + + i$ = InKey$ ' Adjust the TEMPO if need be. + Select Case UCase$(i$) + Case Chr$(27) + Finished = TRUE + Exit For + Case Chr$(0) + "H", Chr$(0) + "M" + ChangeTempo UP + Case Chr$(0) + "P", Chr$(0) + "K" + ChangeTempo DOWN + End Select + + Next j + DrawNote Song(i).Note, Song(i).Oct, UP ' "Undraw" the pressed key. + If Finished Then Exit For + Next i + +End Sub + +'------------------------------------------------------------------------- +' RecordMenu +' +' Sets up the screen for record/practice mode. +' +' PARAMETERS: NoSave - Indicates whether the user is doing PRACTICE or RECORD +'------------------------------------------------------------------------- +Sub RecordMenu (NoSave) Static + + If NoSave = TRUE Then + DisplayMenuText PRACTICE ' Draw the PRACTICE screen. + Else + DisplayMenuText RECORD ' Draw the RECORD screen. + End If + + Color 7, 0 ' Show the keyboard helper keys. + Locate 6, 17: Print "2 4 5 7 8 9 - = S D F H J L ; '" + Locate 12, 16: Print "Q W E R T Y U I O P [ ] Z X C V B N M , . /" + + RecordMode NoSave + + Color , 0 ' Print spaces over both rows. + Locate 6, 4: Print Space$(75) + Locate 12, 4: Print Space$(75) + Color , BACKGROUNDCOLOR + +End Sub + +'------------------------------------------------------------------------- +' RecordMode +' +' Handles the keypresses from the user and plays +' and records notes in the global Song() array. For keyboard input, +' it uses the INP function to read from the keyboard port (ADDR = 0x60). +' This is done to determine what key was pressed and how long it was pressed. +' +' PARAMETERS: NoSave - Indicates whether the user is doing PRACTICE or RECORD +'------------------------------------------------------------------------- +Sub RecordMode (NoSave) Static + + Hld$ = "" + Counter = 1 + Song(Counter).Note = 0 + Song(Counter).Dur = 0 + KeyState = UP + oi$ = "": n$ = "" + For i = 1 To 12 + n$ = n$ + Chr$(i) + Next i + n$ = Mid$(n$, 10) + n$ + n$ + n$ ' Used for the XT version. + o$ = "00011111111111122222222222233333333333" + + If Inp(&H60) = 0 Then ' If 0, we must use INKEY$ + XTKeyboard = TRUE ' instead of INP(&H60) + Else ' because of certain keyboard + XTKeyboard = FALSE ' controllers that do not + End If ' keep the last keypress in the &h60 port. + Do + i$ = InKey$ + Loop While i$ = "" ' Wait for first keypress. + If i$ = Chr$(27) Then Exit Sub ' Esc means no song recorded. + + x = 0 + While i$ <> Chr$(27) + If XTKeyboard Then ' Do this block if XT keyboard + If i$ = oi$ Then + If Song(Counter).Note = 0 Then + PlayNote Song(Counter).Note, Song(Counter).Oct, RESTTICK + Song(Counter).Dur = Song(Counter).Dur + 1 + Else ' a real note + PlayNote Song(Counter).Note, Song(Counter).Oct, XTNOTELENGTH * NOTETICK + Song(Counter).Dur = Song(Counter).Dur + XTNOTELENGTH + End If + ElseIf i$ <> "" Then + keyloc = InStr("Q2WE4R5TY7U8I9OP-[=]ZSXDCFVBHNJM,L.;/'", UCase$(i$)) + If keyloc = 0 Then + DrawNote Song(Counter).Note, Song(Counter).Oct, UP + Counter = Counter + 1 + If Counter > MAXNOTE Then + ErrorMessage "Maximum song length reached." + GoTo GetOut + End If + Song(Counter).Note = 0 + Song(Counter).Oct = 0 ' Rests are counted. + Song(Counter).Dur = 0 + DrawNote Song(Counter).Note, Song(Counter).Oct, DOWN + Else + DrawNote Song(Counter).Note, Song(Counter).Oct, UP + Counter = Counter + 1 + NewNote = Asc(Mid$(n$, keyloc, 1)) + NewOct = Val(Mid$(o$, keyloc, 1)) - 2 + + If Counter > MAXNOTE Then + ErrorMessage "Maximum song length reached." + GoTo GetOut + End If + Song(Counter).Note = NewNote + Song(Counter).Oct = NewOct + Song(Counter).Dur = XTNOTELENGTH + DrawNote Song(Counter).Note, Song(Counter).Oct, DOWN + PlayNote Song(Counter).Note, Song(Counter).Oct, XTNOTELENGTH * NOTETICK + TimeDelay XTNOTELENGTH * NOTETICK + End If + ElseIf i$ = "" Then + DrawNote Song(Counter).Note, Song(Counter).Oct, UP + Counter = Counter + 1 + If Counter > MAXNOTE Then + ErrorMessage "Maximum song length reached." + GoTo GetOut + End If + Song(Counter).Note = 0 + Song(Counter).Oct = 0 + Song(Counter).Dur = 0 + DrawNote Song(Counter).Note, Song(Counter).Oct, DOWN + End If + + Else ' Do this block if not XT keyboard. + ox = x + Hld$ = Hld$ + i$ + If (Len(Hld$) < 2) And (Song(Counter).Dur > 8) And (Song(Counter).Note <> 0) Then + x = 1 + Else + x = Inp(&H60) + End If + + If ox = x Then ' no change in keypress + Song(Counter).Dur = Song(Counter).Dur + 1 + If Song(Counter).Note = 0 Then ' a rest + PlayNote Song(Counter).Note, Song(Counter).Oct, RESTTICK + Else ' a real note + PlayNote Song(Counter).Note, Song(Counter).Oct, NOTETICK + End If + If Len(Hld$) > 1 Then Hld$ = "" + + ElseIf x < 128 Then ' it's a KEYDOWN event + If KeyState = DOWN Then + DrawNote Song(Counter).Note, Song(Counter).Oct, UP + End If + Counter = Counter + 1 + If Counter > MAXNOTE Then + ErrorMessage "Maximum song length reached." + GoTo GetOut + End If + Song(Counter).Note = Kyb(x).Note + Song(Counter).Oct = Kyb(x).Oct + Song(Counter).Dur = 0 + DrawNote Song(Counter).Note, Song(Counter).Oct, DOWN + Hld$ = "" + KeyState = DOWN + + ElseIf (x - 128) <> ox Then ' an old key came up + x = ox + Song(Counter).Dur = Song(Counter).Dur + 1 + If Song(Counter).Note = 0 Then ' a rest + PlayNote Song(Counter).Note, Song(Counter).Oct, RESTTICK + Else ' a real note + PlayNote Song(Counter).Note, Song(Counter).Oct, NOTETICK + End If + If Len(Hld$) > 1 Then Hld$ = "" + + ElseIf KeyState = DOWN Then ' it's a KEYUP event + KeyState = UP + DrawNote Song(Counter).Note, Song(Counter).Oct, UP + Counter = Counter + 1 + If Counter > MAXNOTE Then + ErrorMessage "Maximum song length reached." + GoTo GetOut + End If + Song(Counter).Note = 0 + Song(Counter).Dur = 0 + Hld$ = "" + End If + End If + oi$ = i$ + i$ = InKey$ + Wend + + GetOut: + DrawNote Song(Counter).Note, Song(Counter).Oct, UP ' Make sure that the last key pressed is released. + + If Counter = 1 Or NoSave = TRUE Then Exit Sub ' No notes recorded or Practice mode. + + While Song(Counter).Note = 0 And Counter > 0 ' Get rid of any rests at the end of the song. + Counter = Counter - 1 + Wend + + SongRecorded = TRUE ' Let MainMenu know we have recorded a new song. + +End Sub + +'------------------------------------------------------------------------- +' SaveChanges +' +' Asks the user if the changes just made to the current song with the song +' editor should be saved or not. It returns TRUE if so, or FALSE if not. +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Function SaveChanges Static + + Color BACKGROUNDCOLOR, BACKGROUNDCOLOR + DrawBox 13, 38, 24, 78, "" + Color 0, 7 + DrawBox 15, 41, 20, 75, "Save Changes" + Locate 17, 43 + Print "Do you want to save the changes" + Locate , 43, 1 + Print "made to this song? (Y/N) "; + + Do ' Wait for keypress. + i$ = UCase$(InKey$) + Loop Until i$ = "Y" Or i$ = "N" + + Locate , , 0 ' Return appropriate value. + If i$ = "Y" Then + SaveChanges = TRUE + Else + SaveChanges = FALSE + End If + +End Function + +'------------------------------------------------------------------------- +' SaveSong +' +' Saves the current song in the QSYNTH.DAT file, thus adding +' the song to the Song List. The QSYNTH.DAT file has the following format: +' +' o A file header having a fixed length (LEN(HeaderInfo), where HeaderInfo +' is a variable of type FileHeader) +' +' o A "Song Index Card" area having a fixed length (LEN(S) * MAXSONG, where +' S is a variable of type SongIndexCard, and MAXSONG is the constant +' which defines the maximum number of songs which can be saved in the file) +' +' o A "Song Data" area which is of variable length, since the songs can be of +' variable length. Thus, the last MEANINGFUL byte in the file is the last +' byte of song data of the last song in the file. It is important to +' understand that this last note of the last song may not be the last +' physical byte of the file. If a song is deleted from the file, the other +' songs in the file are "moved up", to fill in the "hole" left by the song +' that was deleted. However, the file does not decrease in size. Once the +' remaining songs are moved up in the file, there exists "old" data starting +' 1 byte after the last note of the last song, and extending to the end of +' the physical file. +' +' The end of the meaningful data in the file can always be found using the +' NextNote field of the FileHeader structure. This value ALWAYS points to +' the next AVAILABLE note position in the song data area of the file. Thus, +' the last byte of the last song in the file is at location NextNote-1. +' +' IMPORTANT NOTE: NextNote is relative to the beginning of the song data +' area, NOT the physical beginning of the file! So, the +' physical location of the next available note can be found +' by: LEN(Header) + LEN(S)*MAXSONG + Header.NextNote +' +' Understanding this file structure is crucial to understanding how the +' SaveSong and DeleteSong procedures work. Here in SaveSong, the Song Index +' Card is written to the FileHeader.Count+1 record of the SongIndexCard part +' of the file, and the actual song data is written to the file starting at +' the NextNote byte of the file. (See the DeleteNote procedure for details +' on how songs are deleted from the file). +' +' PARAMETERS: None +'------------------------------------------------------------------------- +Sub SaveSong Static + + Dim S As SongIndexCard + Dim HeaderInfo As FileHeader + FileError = 0 + + Open "QSYNTH.DAT" For Binary As 1 ' Open the file. + Get #1, , HeaderInfo ' Get header info. + + ' Seek to the next available song index record. The Count field of the + ' header record is 1-based, so LEN(S)*HeaderInfo.Count + 1 is the first + ' byte of song index record #(Count+1) + Seek #1, Len(HeaderInfo) + (Len(S) * HeaderInfo.Count) + 1 + + S.naym = SongName ' Insert data for current song. + S.desc = SongDesc + S.Size = Counter + S.Offset = HeaderInfo.NextNote ' PUT it into the file at the + Put #1, , S ' file position found by the SEEK statement. + + ' Seek to the next available note position in the song data section. This + ' is found using the NextNote field of the file header structure. Remember + ' the NextNote pointer is relative to the start of the song data area, + ' and not the physical beginning of the file, so we have to add the size of + ' the file header and the song index card sections as well. + Seek #1, Len(HeaderInfo) + (Len(S) * MAXSONG) + HeaderInfo.NextNote + + For i = 1 To Counter ' Write each note of the song + Put #1, , Song(i) ' to the file. + Next i + + ' Update the header information (increment the song count, and point + ' NextNote at the next available note in the file by adding the size of the + ' newly saved song to the current value of NextNote. + HeaderInfo.Count = HeaderInfo.Count + 1 + HeaderInfo.NextNote = HeaderInfo.NextNote + (Counter * Len(Song(1))) + Seek #1, 1 ' Seek to the start. + Put #1, , HeaderInfo ' Write the new header. + Close 1 ' The song is saved! + +End Sub + +'------------------------------------------------------------------------- +' SimpleEdit +' +' This function is a very simple one-line edit routine. It allows entry of +' text up to a given maximum length, and the editing capabilities are +' limited to backspace (to delete the last character typed). It returns a +' code indicating which terminator key was pressed: Esc, Enter or Tab. +' +' PARAMETERS: row,col - Row and column position of first character +' in text +' Text$ - String variable to place edited text (can +' contain the initial value of the text) +' MaxLen - Maximum length allowed for the entered text +'------------------------------------------------------------------------- +Function SimpleEdit (row, col, text$, MaxLen) Static + + Locate row, col, 1 ' Turn on the cursor. + Print text$; + + Finished = FALSE + While Not Finished + i$ = InKey$ + Select Case i$ + Case Chr$(13) + Finished = TRUE ' Enter key pressed. + SimpleEdit = CR + + Case Chr$(27) + Finished = TRUE ' Esc key pressed. + SimpleEdit = ESC + + Case Chr$(9) + Finished = TRUE ' Tab key pressed. + SimpleEdit = TABCHAR + + Case Chr$(8) ' Backspace key pressed. + If Len(text$) > 0 Then + text$ = Left$(text$, Len(text$) - 1) + Locate row, col + Print text$; " "; + Locate row, col + Len(text$) + End If + + Case Chr$(32) TO Chr$(126) + If Len(text$) < MaxLen Then ' Normal key - add it to text$. + text$ = text$ + i$ + Print i$; + End If + End Select + Wend + + Locate , , 0 ' Turn cursor off. + +End Function + +'------------------------------------------------------------------------- +' TimeDelay +' +' Waits for a length of time equal to a SOUND 0, Cur# statement. +' +' PARAMETERS: Dur# - Duration of delay +'------------------------------------------------------------------------- +Sub TimeDelay (Dur#) Static + + x# = Timer ' Wait until Dur# seconds pass. + While (Timer - x#) < (Dur# / 18.2): Wend + +End Sub + diff --git a/samples/qsynth/src/qsynth.dat b/samples/qsynth/src/qsynth.dat new file mode 100644 index 00000000..554fea2d Binary files /dev/null and b/samples/qsynth/src/qsynth.dat differ diff --git a/samples/qsynth/src/qsynth.zip b/samples/qsynth/src/qsynth.zip new file mode 100644 index 00000000..92feb0d4 Binary files /dev/null and b/samples/qsynth/src/qsynth.zip differ diff --git a/samples/qtrek/img/screenshot.png b/samples/qtrek/img/screenshot.png new file mode 100644 index 00000000..0b1686c3 Binary files /dev/null and b/samples/qtrek/img/screenshot.png differ diff --git a/samples/qtrek/index.md b/samples/qtrek/index.md new file mode 100644 index 00000000..af12e957 --- /dev/null +++ b/samples/qtrek/index.md @@ -0,0 +1,24 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: QTREK + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Philipp Strathausen](../philipp-strathausen.md) + +### Description + +```text +Star Trek-like game by Philipp Strathausen. +``` + +### File(s) + +* [qtrek.bas](src/qtrek.bas) + +🔗 [game](../game.md), [space shooter](../space-shooter.md) + + +Reference: [github.com](https://github.com/strathausen/qtrek.bas) diff --git a/samples/qtrek/src/qtrek.bas b/samples/qtrek/src/qtrek.bas new file mode 100644 index 00000000..679925a5 --- /dev/null +++ b/samples/qtrek/src/qtrek.bas @@ -0,0 +1,3135 @@ +'----------------------------------------------------------------------------------------------------- +'qtrek +'star trek themed game for QB64 +'https://github.com/strathausen/qtrek.bas +'----------------------------------------------------------------------------------------------------- + +'----------------------------------------------------------------------------------------------------- +' These are some metacommands and compiler options for QB64 to write modern & type-strict code +'----------------------------------------------------------------------------------------------------- +' This will disable prefixing all modern QB64 calls using a underscore prefix. +$NoPrefix +' Whatever indentifiers are not defined, should default to signed longs (ex. constants and functions). +DefInt A-Z +' All variables must be defined. +Option Explicit +' All arrays must be defined. +Option ExplicitArray +' Array lower bounds should always start from 1 unless explicitly specified. +' This allows a(4) as integer to have 4 members with index 1-4. +Option Base 1 +' All arrays should be static by default. Allocate dynamic array using ReDim +'$Static +' This allows the executable window & it's contents to be resized. +$Resize:Smooth +'FullScreen SquarePixels , Smooth +Title "QTrek" +'----------------------------------------------------------------------------------------------------- + +Dim Shared x%, y%, xp%, yp%, lx%, ly%, kstn% +Dim Shared ex%, ey%, enm%, ez%, ek%, eex% +Dim Shared snd%, snp%, cb%, cf% +Dim Shared trf%, punkte%, gshl% +Dim ys(0 To 49) As Integer, zs(0 To 49) As Integer, xs(0 To 49) As Single +Dim As Integer prm, lvl, str, qty, fv, pv, lv, lx2, fa +Dim As Integer pb(0 To 2), xp(0 To 2), yp(0 To 2) +Dim As Integer fb(0 To 5), xf(0 To 5), yf(0 To 5) + +On Error GoTo errorhandler +Screen 13 +'Umgebungsvariablen +prm% = Point(0, 0) +snp% = Point(1, 0) +lvl% = Point(2, 0) +Cls +Randomize Timer +Close +Palette 6, 60 +Palette 5, 50 +Palette 4, 40 +Palette 3, 30 +Palette 2, 20 + +'IF prm% = 0 THEN COLOR 12: PRINT : PRINT : PRINT : PRINT " Sie mssen das Spiel mit der Datei": PRINT " "; CHR$(34); "UNAD2.BAT"; CHR$(34); " starten!": SLEEP: SYSTEM + +'Vorberechnungen fr Sterne +For str% = 0 To 49 + qty% * 10 + xs(str%) = Rnd * 320 + zs%(str%) = Rnd * 14 + 2 + ys%(str%) = Rnd * 180 +Next + +'Variablen +x% = 20 +y% = 100 +ex% = 300 +ey% = 102 +gshl% = 10 +enm% = 15 + +Do + + For str% = 0 To 49 + PSet (xs(str%), ys%(str%)), 0 + xs(str%) = xs(str%) - zs%(str%) / 8 - 1 + If xs(str%) < 0 Then xs(str%) = 320 + PSet (xs(str%), ys%(str%)), zs%(str%) + 15 + Next + + gdisplay + + If KeyDown(18432) Then Line (x%, y%)-(x% + 20, y% + 9), 0, BF: y% = y% - 1 + If KeyDown(20480) Then Line (x%, y%)-(x% + 20, y% + 9), 0, BF: y% = y% + 1 + If KeyDown(19200) Then Line (x%, y%)-(x% + 20, y% + 9), 0, BF: x% = x% - 1 + If KeyDown(19712) Then Line (x%, y%)-(x% + 20, y% + 9), 0, BF: x% = x% + 1 + If KeyDown(110) Or KeyDown(78) Then fv% = 1 + If KeyDown(103) Or KeyDown(71) Then pv% = 1 + If KeyDown(104) Or KeyDown(72) Then If lv% = 0 Then lv% = 1 + If KeyDown(115) Or KeyDown(83) Then If snp% = 0 Then snp% = 1 Else snp% = 0 + + bounce + + crash + If enm% = 0 Then eex% = eex% + 1 + Line (ex%, ey%)-Step(21, 7), 0, BF 'berzeichnen + If eex% > 1 Then Line (ex%, ey% - 3)-(ex% + 25, ey% + 15), 0, BF + 'Fortbewegung + ex% = ex% - 3 + 'Durchlauf + If ex% < -25 Then ex% = 340: enm% = 15: eex% = 0: snd% = 0: ey% = Int(Rnd * 100) + 50: punkte% = punkte% - 100 + 'Sicherung + If ey% > 170 Then ey% = 170: ez% = 0 + If ey% < 0 Then ey% = 0: ez% = 0 + + If eex% = 1 Then trf% = trf% + 1: punkte% = punkte% + 400 + Select Case Int(eex% / 2) + Case 0: enemy + Case 1: xxf1: snd% = 1 + Case 2: xxf2 + Case 3: xxf3 + Case 4: xxf4 + Case 5: xxf5 + Case 6: xxf6 + Case 7: xxf7 + Case 8: xxf8 + Case 9: xxf9 + Case 10: xxf10 + Case 11: xxf11 + Case 12: xxf12 + Case 13: Line (ex%, ey% - 3)-(ex% + 25, ey% + 15), 0, BF: ex% = -21: enm% = 15: eex% = 0 + End Select + ship + srnd + + ' Laser + If lv% = 1 Then lx% = x% + 20: ly% = y% + 7: If ly% >= ey% And ly% <= ey% + 7 And ex% > x% And eex% = 0 Then lx2% = ex% + 7: snd% = 17: enm% = enm% - 4: punkte% = punkte% + 10 Else lx2% = 320: snd% = 17: punkte% = punkte% - 5 + If lv% >= 1 Then + lv% = lv% + 1 + Line (lx%, ly%)-(lx2%, ly%), 46 + If lv% = 3 Then lv% = 0: Line (lx%, ly%)-(lx2%, ly%), 0 + End If + + ' Engine - Plasma + For fa% = 0 To 2 + If pv% = 1 And pb%(fa%) = 0 Then pb%(fa%) = 1: pv% = 0: snd% = 21 + If pb%(fa%) = 1 Then xp%(fa%) = x% + 14: yp%(fa%) = y% + 7: pb%(fa%) = 2 + If pb%(fa%) = 2 Then + xp%(fa%) = xp%(fa%) + 9 + Line (xp%(fa%), yp%(fa%))-(xp%(fa%) + 9, yp%(fa%)), 6 + Line (xp%(fa%), yp%(fa%))-(xp%(fa%) - 8, yp%(fa%)), 0 + If xp%(fa%) > 340 Then pb%(fa%) = 0: punkte% = punkte% - 7 + If xp%(fa%) > ex% And xp%(fa%) < ex% + 17 And yp%(fa%) >= ey% And yp%(fa%) <= ey% + 7 And eex% = 0 Then pb%(fa%) = 0: Line (xp%(fa%) + 9, yp%(fa%))-(xp%(fa%) - 8, yp%(fa%)), 0: enm% = enm% - 4: punkte% = punkte% + 14 + End If + Next + + ' Photon Torpedos + For fa% = 0 To 5 + If fv% = 1 And fb%(fa%) = 0 Then fb%(fa%) = 1: fv% = 0: snd% = 10 + If fb%(fa%) = 1 Then xf%(fa%) = x% + 16: yf%(fa%) = y% + 7: fb%(fa%) = 2 + If fb%(fa%) = 2 Then + xf%(fa%) = xf%(fa%) + 3 + photon xf%(fa%), yf%(fa%) + If xf%(fa%) > 320 Then fb%(fa%) = 0: punkte% = punkte% - 8 + If xf%(fa%) > ex% And xf%(fa%) < ex% + 21 And yf%(fa%) >= ey% And yf%(fa%) <= ey% + 7 And eex% = 0 And eex% = 0 Then fb%(fa%) = 0: Line (xf%(fa%), yf%(fa%) - 1)-(xf%(fa%) + 10, yf%(fa%) + 1), 0, BF: enm% = enm% - 5: punkte% = punkte% + 16 + End If + Next + + Limit 60 +Loop Until KeyDown(27) + +System 0 + +'Handle errors by not handling errors +errorhandler: +Resume Next + +Sub a + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% +End Sub + +Sub ae + PSet Step(2, -4), cf% + PSet Step(3, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% +End Sub + +Sub gdisplay + cf% = 43 + Draw "bm5,198" + kra + + box1 + empty 1 + : p: u: n: k: t: e: dpt + cf% = 43 + 48 + prnumber punkte%, 4 + + box1 + empty 1 + cf% = 43 + : t: r: e: f: f: e: r: dpt + If trf% > 99 Then trf% = 99 + cf% = 43 + 48 + prnumber trf%, 2 + + box1 + empty 1 + cf% = 43 + : s: c: h: i: l: d: e: dpt + Line Step(3, -4)-Step(gshl% * 2, 4), 41, BF + If gshl% = 10 Then Line Step(1, -4)-Step(0, 4), 41 Else Line Step(1, -4)-Step(20 - gshl% * 2, 4), 113, BF + Draw "bm+2,0" + + box 30 + empty 1 + : f: e: i: n: d + If enm% < 0 Then enm% = 0 + Line Step(3, -4)-Step(enm% * 2, 4), 41, BF + If enm% = 15 Then Line Step(1, -4)-Step(0, 4), 41 Else Line Step(1, -4)-Step(30 - enm% * 2, 4), 113, BF + Draw "bm+2,0" + box1 + krz + +End Sub + +Sub b + PSet Step(2, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-1, 1), cf% + PSet Step(2, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub box (kbox As Integer) + Line Step(3, -6)-Step(kbox%, 8), 104, B + Paint Step(-1, -1), 32, 104 + Draw "bm+2,-1" +End Sub + +Sub box1 + Line Step(3, -6)-Step(4, 8), 104, B + Paint Step(-1, -1), 32, 104 + Draw "bm+1,-1" +End Sub + +Sub c + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(1, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% +End Sub + +Sub crash + If x% >= ex% - 20 And x% <= ex% + 15 And y% >= ey% - 8 And y% <= ey% + 7 And enm% > 0 Then enm% = 0: trf% = trf% - 1: punkte% = punkte% - 400: gshl% = gshl% - 1 +End Sub + +Sub d + PSet Step(2, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-1, 1), cf% + PSet Step(2, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub dpt + PSet Step(2, -3), cf% + + PSet Step(0, 2), cf% + + Draw "bm+0,1" +End Sub + +Sub e + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + + PSet Step(0, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + + PSet Step(0, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% +End Sub + +Sub f + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + + PSet Step(0, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + + PSet Step(0, 1), cf% + Draw "bm+2, 0" +End Sub + +Sub enemy + 'Jump line + ez% = ez% + 1 + If ez% = 10 Then ek% = CInt(Rnd * 2 - 1): ez% = 0 + If ez% = 20 Then ek% = 0 + ey% = ey% + ek% + PSet (ex% + 8, ey%), 178 + PSet (ex% + 9, ey%), 130 + PSet (ex% + 10, ey%), 24 + PSet (ex% + 11, ey%), 25 + PSet (ex% + 12, ey%), 24 + PSet (ex% + 13, ey%), 24 + PSet (ex% + 14, ey%), 24 + PSet (ex% + 15, ey%), 24 + PSet (ex% + 16, ey%), 23 + PSet (ex% + 17, ey%), 21 + PSet (ex% + 18, ey%), 19 + PSet (ex% + 5, ey% + 1), 178 + PSet (ex% + 6, ey% + 1), 106 + PSet (ex% + 7, ey% + 1), 106 + PSet (ex% + 8, ey% + 1), 106 + PSet (ex% + 9, ey% + 1), 130 + PSet (ex% + 10, ey% + 1), 154 + PSet (ex% + 11, ey% + 1), 25 + PSet (ex% + 12, ey% + 1), 25 + PSet (ex% + 13, ey% + 1), 25 + PSet (ex% + 14, ey% + 1), 25 + PSet (ex% + 15, ey% + 1), 25 + PSet (ex% + 16, ey% + 1), 25 + PSet (ex% + 17, ey% + 1), 24 + PSet (ex% + 18, ey% + 1), 23 + PSet (ex% + 19, ey% + 1), 22 + PSet (ex% + 20, ey% + 1), 19 + PSet (ex% + 2, ey% + 2), 178 + PSet (ex% + 3, ey% + 2), 106 + PSet (ex% + 4, ey% + 2), 106 + PSet (ex% + 5, ey% + 2), 106 + PSet (ex% + 6, ey% + 2), 130 + PSet (ex% + 7, ey% + 2), 154 + PSet (ex% + 8, ey% + 2), 24 + PSet (ex% + 9, ey% + 2), 24 + PSet (ex% + 10, ey% + 2), 24 + PSet (ex% + 11, ey% + 2), 24 + PSet (ex% + 12, ey% + 2), 21 + PSet (ex% + 13, ey% + 2), 22 + PSet (ex% + 14, ey% + 2), 23 + PSet (ex% + 15, ey% + 2), 25 + PSet (ex% + 16, ey% + 2), 25 + PSet (ex% + 17, ey% + 2), 25 + PSet (ex% + 18, ey% + 2), 25 + PSet (ex% + 19, ey% + 2), 24 + PSet (ex% + 20, ey% + 2), 23 + PSet (ex% + 21, ey% + 2), 20 + PSet (ex%, ey% + 3), 21 + PSet (ex% + 1, ey% + 3), 22 + PSet (ex% + 2, ey% + 3), 23 + PSet (ex% + 3, ey% + 3), 23 + PSet (ex% + 4, ey% + 3), 24 + PSet (ex% + 5, ey% + 3), 24 + PSet (ex% + 6, ey% + 3), 24 + PSet (ex% + 7, ey% + 3), 24 + PSet (ex% + 8, ey% + 3), 24 + PSet (ex% + 9, ey% + 3), 22 + PSet (ex% + 10, ey% + 3), 20 + PSet (ex% + 11, ey% + 3), 19 + PSet (ex% + 15, ey% + 3), 22 + PSet (ex% + 16, ey% + 3), 25 + PSet (ex% + 17, ey% + 3), 25 + PSet (ex% + 18, ey% + 3), 25 + PSet (ex% + 19, ey% + 3), 23 + PSet (ex% + 20, ey% + 3), 20 + PSet (ex% + 3, ey% + 4), 20 + PSet (ex% + 4, ey% + 4), 22 + PSet (ex% + 5, ey% + 4), 22 + PSet (ex% + 6, ey% + 4), 20 + PSet (ex% + 7, ey% + 4), 19 + PSet (ex% + 14, ey% + 4), 23 + PSet (ex% + 15, ey% + 4), 26 + PSet (ex% + 16, ey% + 4), 25 + PSet (ex% + 17, ey% + 4), 24 + PSet (ex% + 18, ey% + 4), 21 + PSet (ex% + 19, ey% + 4), 19 + PSet (ex% + 20, ey% + 4), 17 + PSet (ex% + 9, ey% + 5), 18 + PSet (ex% + 10, ey% + 5), 21 + PSet (ex% + 11, ey% + 5), 23 + PSet (ex% + 12, ey% + 5), 24 + PSet (ex% + 13, ey% + 5), 26 + PSet (ex% + 14, ey% + 5), 27 + PSet (ex% + 15, ey% + 5), 25 + PSet (ex% + 16, ey% + 5), 22 + PSet (ex% + 17, ey% + 5), 20 + PSet (ex% + 18, ey% + 5), 18 + PSet (ex% + 8, ey% + 6), 42 + PSet (ex% + 9, ey% + 6), 41 + PSet (ex% + 10, ey% + 6), 42 + PSet (ex% + 11, ey% + 6), 43 + PSet (ex% + 12, ey% + 6), 44 + PSet (ex% + 13, ey% + 6), 26 + PSet (ex% + 14, ey% + 6), 24 + PSet (ex% + 15, ey% + 6), 20 + PSet (ex% + 16, ey% + 6), 18 + PSet (ex% + 10, ey% + 7), 19 + PSet (ex% + 11, ey% + 7), 21 + PSet (ex% + 12, ey% + 7), 23 + PSet (ex% + 13, ey% + 7), 21 +End Sub + +Sub g + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + + PSet Step(0, 1), cf% + PSet Step(2, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% +End Sub + +Sub h + PSet Step(2, -4), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% +End Sub + +Sub i + PSet Step(2, -4), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-1, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(-1, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% +End Sub + +Sub k + PSet Step(2, -4), cf% + PSet Step(2, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(2, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% +End Sub + +Sub klma1 + PSet Step(3, -4), cf% + + PSet Step(-1, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(1, 1), cf% +End Sub + +Sub klma2 + PSet Step(4, -4), cf% + + PSet Step(-1, 1), cf% + + PSet Step(-1, 1), cf% + + PSet Step(1, 1), cf% + + PSet Step(1, 1), cf% +End Sub + +Sub klmz1 + PSet Step(2, -4), cf% + + PSet Step(1, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(-1, 1), cf% + Draw "bm+1,0" +End Sub + +Sub klmz2 + PSet Step(2, -4), cf% + + PSet Step(1, 1), cf% + + PSet Step(1, 1), cf% + + PSet Step(-1, 1), cf% + + PSet Step(-1, 1), cf% + Draw "bm+2,0" +End Sub + +Sub kra + Circle Step(6, -3), 5, 104, Pi / 2.1, 3.1 * Pi / 2 + Line Step(0, 4)-Step(0, -8), 104 + Paint Step(-4, 3), 32, 104 + Draw "bm+4, 3" +End Sub + +Sub krz + Circle Step(3, -2), 5, 104, 2.9 * Pi / 2, Pi / 2 + Line Step(0, 4)-Step(0, -8), 104 + Paint Step(4, 3), 32, 104 + Draw "bm+1, 3" +End Sub + +Sub l + PSet Step(2, -4), cf% + + PSet Step(0, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(0, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% +End Sub + +Sub empty (lr As Integer) + Draw "bm +" + Str$(lr%) + ",0" +End Sub + +Sub empty2 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% +End Sub + +Sub m + PSet Step(3, -4), cf% + PSet Step(2, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(2, 0), cf% + PSet Step(2, 0), cf% + + PSet Step(-4, 1), cf% + PSet Step(4, 0), cf% + + PSet Step(-4, 1), cf% + PSet Step(4, 0), cf% +End Sub + +Sub minus + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% +End Sub + +Sub n + PSet Step(2, -4), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(2, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(2, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% +End Sub + +Sub o + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub oe + PSet Step(2, -4), cf% + PSet Step(3, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub p + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + + PSet Step(0, 1), cf% + Draw "bm+3, 0" +End Sub + +Sub photon (xf As Integer, yf As Integer) + PSet (xf% + 3, yf% - 1), 0 + PSet (xf% + 4, yf% - 1), 0 + PSet (xf% + 5, yf% - 1), 0 + PSet (xf% + 6, yf% - 1), 185 + Int(Rnd * 3) + PSet (xf% + 7, yf% - 1), 113 + Int(Rnd * 3) + PSet (xf% + 8, yf% - 1), 41 + Int(Rnd * 3) + PSet (xf% + 9, yf% - 1), 113 + Int(Rnd * 3) + PSet (xf% + 1, yf%), 0 + PSet (xf% + 2, yf%), 0 + PSet (xf% + 3, yf%), 0 + PSet (xf% + 4, yf%), 185 + Int(Rnd * 3) + PSet (xf% + 5, yf%), 113 + Int(Rnd * 3) + PSet (xf% + 6, yf%), 113 + Int(Rnd * 3) + PSet (xf% + 7, yf%), 41 + Int(Rnd * 3) + PSet (xf% + 8, yf%), 41 + Int(Rnd * 3) + PSet (xf% + 9, yf%), 41 + Int(Rnd * 3) + PSet (xf% + 10, yf%), 113 + Int(Rnd * 3) + PSet (xf% + 3, yf% + 1), 0 + PSet (xf% + 4, yf% + 1), 0 + PSet (xf% + 5, yf% + 1), 0 + PSet (xf% + 6, yf% + 1), 185 + Int(Rnd * 3) + PSet (xf% + 7, yf% + 1), 113 + Int(Rnd * 3) + PSet (xf% + 8, yf% + 1), 41 + Int(Rnd * 3) + PSet (xf% + 9, yf% + 1), 113 + Int(Rnd * 3) +End Sub + +Sub punkt + PSet Step(2, 0), cf% +End Sub + +Sub q + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(2, 0), cf% + + PSet Step(-1, 1), cf% + PSet Step(2, 0), cf% +End Sub + +Sub r + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(2, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% +End Sub + +Sub s + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-3, 1), cf% + + PSet Step(1, 1), cf% + PSet Step(1, 0), cf% + + PSet Step(1, 1), cf% + + PSet Step(-3, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub ship + PSet (x% + 3, y%), 20 + PSet (x% + 4, y%), 22 + PSet (x% + 5, y%), 23 + PSet (x% + 6, y%), 23 + PSet (x% + 7, y%), 21 + PSet (x% + 8, y%), 177 + PSet (x% + 2, y% + 1), 21 + PSet (x% + 3, y% + 1), 23 + PSet (x% + 4, y% + 1), 23 + PSet (x% + 5, y% + 1), 21 + PSet (x% + 6, y% + 1), 21 + PSet (x% + 7, y% + 1), 201 + PSet (x% + 8, y% + 1), 105 + PSet (x% + 9, y% + 1), 105 + PSet (x% + 10, y% + 1), 177 + PSet (x% + 11, y% + 1), 177 + PSet (x% + 1, y% + 2), 21 + PSet (x% + 2, y% + 2), 23 + PSet (x% + 3, y% + 2), 23 + PSet (x% + 4, y% + 2), 22 + PSet (x% + 5, y% + 2), 21 + PSet (x% + 6, y% + 2), 200 + PSet (x% + 7, y% + 2), 105 + PSet (x% + 8, y% + 2), 104 + PSet (x% + 9, y% + 2), 104 + PSet (x% + 10, y% + 2), 104 + PSet (x% + 11, y% + 2), 104 + PSet (x% + 12, y% + 2), 105 + PSet (x% + 13, y% + 2), 177 + PSet (x% + 14, y% + 2), 177 + PSet (x%, y% + 3), 20 + PSet (x% + 1, y% + 3), 23 + PSet (x% + 2, y% + 3), 23 + PSet (x% + 3, y% + 3), 22 + PSet (x% + 4, y% + 3), 21 + PSet (x% + 5, y% + 3), 21 + PSet (x% + 6, y% + 3), 21 + PSet (x% + 7, y% + 3), 200 + PSet (x% + 8, y% + 3), 105 + PSet (x% + 9, y% + 3), 105 + PSet (x% + 10, y% + 3), 200 + PSet (x% + 11, y% + 3), 223 + PSet (x% + 12, y% + 3), 21 + PSet (x% + 13, y% + 3), 21 + PSet (x% + 14, y% + 3), 20 + PSet (x% + 15, y% + 3), 19 + PSet (x% + 16, y% + 3), 18 + PSet (x%, y% + 4), 21 + PSet (x% + 1, y% + 4), 22 + PSet (x% + 2, y% + 4), 21 + PSet (x% + 3, y% + 4), 20 + PSet (x% + 4, y% + 4), 20 + PSet (x% + 5, y% + 4), 20 + PSet (x% + 6, y% + 4), 21 + PSet (x% + 7, y% + 4), 21 + PSet (x% + 8, y% + 4), 21 + PSet (x% + 9, y% + 4), 21 + PSet (x% + 10, y% + 4), 21 + PSet (x% + 11, y% + 4), 21 + PSet (x% + 12, y% + 4), 20 + PSet (x% + 13, y% + 4), 19 + PSet (x% + 14, y% + 4), 19 + PSet (x% + 15, y% + 4), 18 + PSet (x% + 16, y% + 4), 17 + PSet (x% + 1, y% + 5), 18 + PSet (x% + 2, y% + 5), 19 + PSet (x% + 3, y% + 5), 19 + PSet (x% + 4, y% + 5), 19 + PSet (x% + 5, y% + 5), 19 + PSet (x% + 6, y% + 5), 19 + PSet (x% + 7, y% + 5), 20 + PSet (x% + 8, y% + 5), 21 + PSet (x% + 9, y% + 5), 21 + PSet (x% + 10, y% + 5), 20 + PSet (x% + 11, y% + 5), 19 + PSet (x% + 12, y% + 5), 18 + PSet (x% + 13, y% + 5), 17 + PSet (x% + 2, y% + 6), 17 + PSet (x% + 3, y% + 6), 18 + PSet (x% + 4, y% + 6), 18 + PSet (x% + 5, y% + 6), 18 + PSet (x% + 6, y% + 6), 18 + PSet (x% + 7, y% + 6), 18 + PSet (x% + 8, y% + 6), 21 + PSet (x% + 9, y% + 6), 22 + PSet (x% + 10, y% + 6), 23 + PSet (x% + 11, y% + 6), 23 + PSet (x% + 12, y% + 6), 23 + PSet (x% + 13, y% + 6), 23 + PSet (x% + 14, y% + 6), 22 + PSet (x% + 15, y% + 6), 23 + PSet (x% + 16, y% + 6), 117 + PSet (x% + 17, y% + 6), 189 + PSet (x% + 6, y% + 7), 23 + PSet (x% + 8, y% + 7), 24 + PSet (x% + 10, y% + 7), 24 + PSet (x% + 12, y% + 7), 25 + PSet (x% + 13, y% + 7), 24 + PSet (x% + 14, y% + 7), 24 + PSet (x% + 15, y% + 7), 144 + PSet (x% + 16, y% + 7), 44 + Int(Rnd * -4) + PSet (x% + 17, y% + 7), 43 + Int(Rnd * -4) + PSet (x% + 18, y% + 7), 117 + PSet (x% + 19, y% + 7), 189 + PSet (x% + 7, y% + 8), 19 + PSet (x% + 8, y% + 8), 20 + PSet (x% + 9, y% + 8), 20 + PSet (x% + 10, y% + 8), 21 + PSet (x% + 11, y% + 8), 21 + PSet (x% + 12, y% + 8), 21 + PSet (x% + 13, y% + 8), 21 + PSet (x% + 14, y% + 8), 21 + PSet (x% + 15, y% + 8), 22 + PSet (x% + 16, y% + 8), 117 + PSet (x% + 17, y% + 8), 189 + + kstn% = kstn% + 1 + Select Case kstn% + Case 1 + PSet (x% + 4, y% + 7), 6 + PSet (x% + 5, y% + 7), 5 + PSet (x% + 7, y% + 7), 4 + PSet (x% + 9, y% + 7), 3 + PSet (x% + 11, y% + 7), 2 + Case 2 + PSet (x% + 4, y% + 7), 5 + PSet (x% + 5, y% + 7), 4 + PSet (x% + 7, y% + 7), 3 + PSet (x% + 9, y% + 7), 2 + PSet (x% + 11, y% + 7), 6 + Case 3 + PSet (x% + 4, y% + 7), 4 + PSet (x% + 5, y% + 7), 3 + PSet (x% + 7, y% + 7), 2 + PSet (x% + 9, y% + 7), 6 + PSet (x% + 11, y% + 7), 5 + Case 4 + PSet (x% + 4, y% + 7), 3 + PSet (x% + 5, y% + 7), 2 + PSet (x% + 7, y% + 7), 6 + PSet (x% + 9, y% + 7), 5 + PSet (x% + 11, y% + 7), 4 + Case 5 + PSet (x% + 4, y% + 7), 2 + PSet (x% + 5, y% + 7), 6 + PSet (x% + 7, y% + 7), 5 + PSet (x% + 9, y% + 7), 4 + PSet (x% + 11, y% + 7), 3 + kstn% = 0 + End Select +End Sub + +Sub bounce + If x% > 300 Then x% = 300 + If x% < 0 Then x% = 0 + If y% > 180 Then y% = 180 + If y% < 0 Then y% = 0 +End Sub + +Sub srnd + If snp% = 0 Then snd% = 0 Else Play "l64" + Select Case snd% + + Case 0 + Play "p64" + + Case 1 'Explosion + Play "n15" + snd% = 2 + Case 2 + Play "n25" + snd% = 3 + Case 3 + Play "n10" + snd% = 4 + Case 4 + Play "n20" + snd% = 5 + Case 5 + Play "n16" + snd% = 6 + Case 6 + Play "n12" + snd% = 7 + Case 7 + Play "n29" + snd% = 8 + Case 8 + Play "n17" + snd% = 9 + Case 9 + Play "n20" + snd% = 0 + + Case 10 'Torpedos + Play "n20" + snd% = 11 + Case 11 + Play "n22" + snd% = 12 + Case 12 + Play "n24" + snd% = 13 + Case 13 + Play "n26" + snd% = 14 + Case 14 + Play "n28" + snd% = 15 + Case 15 + Play "n30" + snd% = 0 + + Case 17 'Phaser + Play "n32" + snd% = 18 + Case 18 + Play "n31" + snd% = 19 + Case 19 + Play "n32" + snd% = 0 + + Case 21 'Plasma + Play "n28" + snd% = 22 + Case 22 + Play "n27" + snd% = 23 + Case 23 + Play "n26" + snd% = 24 + Case 24 + Play "n24" + snd% = 25 + Case 25 + Play "n22" + snd% = 26 + Case 26 + Play "n20" + snd% = 0 + + End Select +End Sub + +Sub stars + PSet (226, 9), 23 + PSet (245, 10), 25 + PSet (4, 152), 29 + PSet (207, 52), 21 + PSet (149, 59), 26 + PSet (92, 60), 28 + PSet (303, 72), 24 + PSet (225, 106), 25 + PSet (276, 158), 22 + PSet (307, 174), 17 + PSet (265, 164), 25 + PSet (315, 182), 20 + PSet (222, 36), 20 + PSet (170, 21), 31 + PSet (216, 3), 25 + PSet (32, 20), 28 + PSet (91, 9), 21 + PSet (122, 60), 31 + PSet (313, 80), 21 + PSet (51, 32), 26 + PSet (131, 82), 27 + PSet (104, 126), 20 + PSet (59, 116), 18 + PSet (146, 181), 20 + PSet (251, 75), 21 + PSet (294, 126), 26 + PSet (137, 19), 25 + PSet (222, 182), 29 + PSet (7, 108), 30 + PSet (137, 135), 24 + PSet (164, 92), 22 + PSet (129, 53), 17 + PSet (78, 145), 17 + PSet (124, 72), 24 + PSet (49, 94), 20 + PSet (201, 108), 19 + PSet (300, 130), 24 + PSet (124, 21), 28 + PSet (147, 150), 25 + PSet (266, 3), 20 + PSet (23, 21), 21 + PSet (41, 0), 25 + PSet (210, 108), 29 + PSet (26, 38), 27 + PSet (145, 71), 19 + PSet (225, 185), 24 + PSet (28, 151), 23 + PSet (147, 98), 20 + PSet (105, 19), 25 + PSet (54, 185), 18 + PSet (142, 54), 30 + PSet (240, 54), 27 + PSet (82, 17), 17 + PSet (103, 158), 21 + PSet (75, 96), 20 + PSet (108, 8), 24 + PSet (65, 172), 25 + PSet (241, 185), 21 + PSet (173, 16), 26 + PSet (131, 122), 18 + PSet (295, 124), 22 + PSet (47, 95), 20 + PSet (317, 26), 17 + PSet (110, 109), 30 + PSet (172, 81), 29 + PSet (264, 134), 27 + PSet (318, 67), 24 + PSet (132, 139), 19 + PSet (135, 108), 29 + PSet (173, 85), 24 + PSet (72, 123), 24 + PSet (217, 177), 22 + PSet (96, 58), 19 + PSet (169, 44), 25 + PSet (116, 175), 24 + PSet (61, 136), 28 + PSet (196, 156), 19 + PSet (258, 40), 31 + PSet (21, 12), 28 + PSet (121, 92), 18 + PSet (36, 34), 17 + PSet (228, 106), 25 + PSet (69, 93), 28 + PSet (240, 79), 30 + PSet (238, 17), 26 + PSet (228, 3), 23 + PSet (128, 55), 31 + PSet (256, 139), 23 + PSet (235, 55), 22 + PSet (138, 188), 18 + PSet (206, 69), 18 + PSet (59, 15), 23 + PSet (306, 108), 24 + PSet (311, 43), 22 + PSet (126, 56), 24 + PSet (44, 103), 31 + PSet (178, 181), 26 + PSet (141, 138), 17 + PSet (241, 140), 24 + PSet (49, 44), 21 + PSet (251, 10), 24 + PSet (242, 160), 21 + PSet (311, 160), 27 + PSet (289, 175), 23 + PSet (39, 120), 28 + PSet (222, 80), 17 + PSet (53, 32), 24 + PSet (129, 21), 21 + PSet (205, 169), 24 + PSet (60, 179), 22 + PSet (103, 154), 20 + PSet (143, 47), 30 + PSet (195, 74), 22 + PSet (275, 117), 30 + PSet (165, 66), 30 + PSet (82, 51), 19 + PSet (111, 0), 28 + PSet (269, 55), 27 + PSet (129, 162), 28 + PSet (140, 15), 23 + PSet (108, 142), 21 + PSet (255, 30), 25 + PSet (305, 48), 31 + PSet (36, 96), 26 + PSet (191, 180), 25 + PSet (78, 172), 18 + PSet (140, 151), 20 + PSet (121, 79), 24 + PSet (86, 116), 20 + PSet (25, 179), 18 + PSet (208, 180), 20 + PSet (303, 169), 23 + PSet (157, 153), 29 + PSet (122, 39), 21 + PSet (132, 30), 26 + PSet (31, 41), 27 + PSet (161, 36), 31 + PSet (150, 0), 23 + PSet (92, 150), 30 + PSet (263, 35), 18 + PSet (3, 30), 22 + PSet (60, 125), 30 + PSet (186, 145), 19 + PSet (82, 5), 29 + PSet (250, 158), 21 + PSet (144, 111), 29 + PSet (180, 40), 20 + PSet (116, 114), 22 + PSet (169, 85), 25 + PSet (16, 109), 20 + PSet (308, 186), 31 + PSet (268, 81), 29 + PSet (316, 51), 19 + PSet (222, 3), 22 + PSet (221, 22), 18 + PSet (92, 79), 25 + PSet (99, 59), 29 + PSet (99, 75), 23 + PSet (269, 81), 27 + PSet (210, 81), 31 + PSet (206, 103), 20 + PSet (186, 149), 23 + PSet (289, 56), 27 + PSet (284, 56), 22 + PSet (4, 58), 31 + PSet (243, 116), 26 + PSet (85, 101), 28 + PSet (274, 18), 25 + PSet (132, 14), 23 + PSet (223, 99), 23 + PSet (302, 16), 25 + PSet (170, 123), 18 + PSet (59, 56), 17 + PSet (48, 84), 25 + PSet (178, 156), 17 + PSet (129, 11), 21 + PSet (192, 103), 25 + PSet (105, 181), 28 + PSet (184, 86), 27 + PSet (52, 11), 20 + PSet (242, 100), 22 + PSet (218, 158), 17 + PSet (254, 96), 20 + PSet (192, 181), 31 + PSet (209, 2), 26 + PSet (308, 1), 31 + PSet (23, 58), 25 + PSet (258, 8), 17 + PSet (180, 62), 23 + PSet (163, 146), 23 + PSet (103, 14), 23 + PSet (183, 152), 25 + PSet (208, 161), 23 + PSet (255, 144), 27 + PSet (233, 38), 28 + PSet (22, 49), 31 + PSet (262, 43), 19 + PSet (75, 185), 20 + PSet (81, 142), 26 + PSet (247, 151), 21 + PSet (263, 143), 30 +End Sub + +Sub sz + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(2, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(2, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub t + PSet Step(2, -4), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-2, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(0, 1), cf% + + PSet Step(0, 1), cf% + Draw "bm+2, 0" +End Sub + +Sub u + PSet Step(2, -4), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub ue + PSet Step(2, -4), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 2), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-2, 1), cf% + PSet Step(1, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub v + PSet Step(2, -4), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(3, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(2, 0), cf% + + PSet Step(-1, 1), cf% + Draw "bm+2, 0" +End Sub + +Sub w + PSet Step(2, -4), cf% + PSet Step(4, 0), cf% + + PSet Step(-4, 1), cf% + PSet Step(2, 0), cf% + PSet Step(2, 0), cf% + + PSet Step(-4, 1), cf% + PSet Step(2, 0), cf% + PSet Step(2, 0), cf% + + PSet Step(-4, 1), cf% + PSet Step(2, 0), cf% + PSet Step(2, 0), cf% + + PSet Step(-3, 1), cf% + PSet Step(2, 0), cf% + Draw "bm+1, 0" +End Sub + +Sub xxf1 + PSet (ex% + 8, ey% + 0), 178 + PSet (ex% + 9, ey% + 0), 130 + PSet (ex% + 10, ey% + 0), 23 + PSet (ex% + 11, ey% + 0), 24 + PSet (ex% + 12, ey% + 0), 24 + PSet (ex% + 13, ey% + 0), 24 + PSet (ex% + 14, ey% + 0), 24 + PSet (ex% + 15, ey% + 0), 25 + PSet (ex% + 16, ey% + 0), 25 + PSet (ex% + 17, ey% + 0), 24 + PSet (ex% + 18, ey% + 0), 21 + PSet (ex% + 19, ey% + 0), 19 + PSet (ex% + 5, ey% + 1), 178 + PSet (ex% + 6, ey% + 1), 106 + PSet (ex% + 7, ey% + 1), 106 + PSet (ex% + 8, ey% + 1), 106 + PSet (ex% + 9, ey% + 1), 130 + PSet (ex% + 10, ey% + 1), 154 + PSet (ex% + 11, ey% + 1), 26 + PSet (ex% + 12, ey% + 1), 26 + PSet (ex% + 13, ey% + 1), 42 + PSet (ex% + 14, ey% + 1), 43 + PSet (ex% + 15, ey% + 1), 44 + PSet (ex% + 16, ey% + 1), 43 + PSet (ex% + 17, ey% + 1), 44 + PSet (ex% + 18, ey% + 1), 42 + PSet (ex% + 19, ey% + 1), 19 + PSet (ex% + 20, ey% + 1), 19 + PSet (ex% + 2, ey% + 2), 178 + PSet (ex% + 3, ey% + 2), 106 + PSet (ex% + 4, ey% + 2), 106 + PSet (ex% + 5, ey% + 2), 106 + PSet (ex% + 6, ey% + 2), 130 + PSet (ex% + 7, ey% + 2), 154 + PSet (ex% + 8, ey% + 2), 25 + PSet (ex% + 9, ey% + 2), 25 + PSet (ex% + 10, ey% + 2), 25 + PSet (ex% + 11, ey% + 2), 23 + PSet (ex% + 12, ey% + 2), 21 + PSet (ex% + 13, ey% + 2), 21 + PSet (ex% + 14, ey% + 2), 22 + PSet (ex% + 15, ey% + 2), 43 + PSet (ex% + 16, ey% + 2), 44 + PSet (ex% + 17, ey% + 2), 44 + PSet (ex% + 18, ey% + 2), 43 + PSet (ex% + 19, ey% + 2), 42 + PSet (ex% + 20, ey% + 2), 23 + PSet (ex% + 21, ey% + 2), 21 + PSet (ex% + 0, ey% + 3), 21 + PSet (ex% + 1, ey% + 3), 22 + PSet (ex% + 2, ey% + 3), 23 + PSet (ex% + 3, ey% + 3), 23 + PSet (ex% + 4, ey% + 3), 24 + PSet (ex% + 5, ey% + 3), 24 + PSet (ex% + 6, ey% + 3), 24 + PSet (ex% + 7, ey% + 3), 24 + PSet (ex% + 8, ey% + 3), 24 + PSet (ex% + 9, ey% + 3), 21 + PSet (ex% + 10, ey% + 3), 21 + PSet (ex% + 11, ey% + 3), 20 + PSet (ex% + 12, ey% + 3), 20 + PSet (ex% + 14, ey% + 3), 24 + PSet (ex% + 15, ey% + 3), 25 + PSet (ex% + 16, ey% + 3), 25 + PSet (ex% + 17, ey% + 3), 43 + PSet (ex% + 18, ey% + 3), 24 + PSet (ex% + 19, ey% + 3), 20 + PSet (ex% + 20, ey% + 3), 19 + PSet (ex% + 21, ey% + 3), 19 + PSet (ex% + 3, ey% + 4), 20 + PSet (ex% + 4, ey% + 4), 22 + PSet (ex% + 5, ey% + 4), 22 + PSet (ex% + 6, ey% + 4), 20 + PSet (ex% + 7, ey% + 4), 19 + PSet (ex% + 13, ey% + 4), 24 + PSet (ex% + 14, ey% + 4), 25 + PSet (ex% + 15, ey% + 4), 25 + PSet (ex% + 16, ey% + 4), 25 + PSet (ex% + 17, ey% + 4), 21 + PSet (ex% + 18, ey% + 4), 20 + PSet (ex% + 19, ey% + 4), 20 + PSet (ex% + 20, ey% + 4), 19 + PSet (ex% + 9, ey% + 5), 22 + PSet (ex% + 10, ey% + 5), 24 + PSet (ex% + 11, ey% + 5), 25 + PSet (ex% + 12, ey% + 5), 25 + PSet (ex% + 13, ey% + 5), 25 + PSet (ex% + 14, ey% + 5), 25 + PSet (ex% + 15, ey% + 5), 24 + PSet (ex% + 16, ey% + 5), 20 + PSet (ex% + 17, ey% + 5), 20 + PSet (ex% + 18, ey% + 5), 19 + PSet (ex% + 8, ey% + 6), 42 + PSet (ex% + 9, ey% + 6), 41 + PSet (ex% + 10, ey% + 6), 42 + PSet (ex% + 11, ey% + 6), 43 + PSet (ex% + 12, ey% + 6), 44 + PSet (ex% + 13, ey% + 6), 25 + PSet (ex% + 14, ey% + 6), 20 + PSet (ex% + 15, ey% + 6), 19 + PSet (ex% + 16, ey% + 6), 19 + PSet (ex% + 9, ey% + 7), 20 + PSet (ex% + 10, ey% + 7), 21 + PSet (ex% + 11, ey% + 7), 22 + PSet (ex% + 12, ey% + 7), 22 + PSet (ex% + 13, ey% + 7), 20 + PSet (ex% + 14, ey% + 7), 19 +End Sub + +Sub xxf10 + PSet (ex% + 15, ey% + -1), 40 + PSet (ex% + 16, ey% + -1), 41 + PSet (ex% + 13, ey% + 0), 41 + PSet (ex% + 14, ey% + 0), 40 + PSet (ex% + 15, ey% + 0), 42 + PSet (ex% + 16, ey% + 0), 40 + PSet (ex% + 17, ey% + 0), 40 + PSet (ex% + 8, ey% + 1), 40 + PSet (ex% + 14, ey% + 1), 40 + PSet (ex% + 16, ey% + 3), 40 + PSet (ex% + 19, ey% + 3), 41 + PSet (ex% + 21, ey% + 3), 40 + PSet (ex% + 8, ey% + 4), 40 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 40 + PSet (ex% + 20, ey% + 4), 41 + PSet (ex% + 11, ey% + 5), 41 + PSet (ex% + 9, ey% + 6), 41 + PSet (ex% + 15, ey% + 6), 42 + PSet (ex% + 19, ey% + 6), 42 + PSet (ex% + 12, ey% + 7), 41 + PSet (ex% + 14, ey% + 7), 41 + PSet (ex% + 15, ey% + 7), 42 + PSet (ex% + 16, ey% + 7), 41 + PSet (ex% + 17, ey% + 7), 42 + PSet (ex% + 11, ey% + 8), 41 + PSet (ex% + 13, ey% + 8), 42 + PSet (ex% + 14, ey% + 8), 41 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 11, ey% + 9), 40 + PSet (ex% + 12, ey% + 9), 41 + PSet (ex% + 13, ey% + 9), 41 + PSet (ex% + 14, ey% + 9), 40 + PSet (ex% + 12, ey% + 10), 40 +End Sub + +Sub xxf11 + PSet (ex% + 13, ey% + 0), 41 + PSet (ex% + 16, ey% + 0), 40 + PSet (ex% + 14, ey% + 1), 40 + PSet (ex% + 21, ey% + 3), 43 + PSet (ex% + 14, ey% + 4), 40 + PSet (ex% + 15, ey% + 6), 42 + PSet (ex% + 12, ey% + 7), 41 + PSet (ex% + 13, ey% + 8), 41 + PSet (ex% + 14, ey% + 8), 43 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 11, ey% + 9), 42 + PSet (ex% + 13, ey% + 9), 43 + PSet (ex% + 12, ey% + 10), 40 +End Sub + +Sub xxf12 + PSet (ex% + 14, ey% + 8), 40 + PSet (ex% + 11, ey% + 9), 41 + PSet (ex% + 13, ey% + 9), 42 + PSet (ex% + 14, ey% + 10), 40 +End Sub + +Sub xxf2 + PSet (ex% + 16, ey% + -1), 41 + PSet (ex% + 8, ey% + 0), 178 + PSet (ex% + 9, ey% + 0), 130 + PSet (ex% + 10, ey% + 0), 23 + PSet (ex% + 11, ey% + 0), 24 + PSet (ex% + 12, ey% + 0), 42 + PSet (ex% + 13, ey% + 0), 24 + PSet (ex% + 14, ey% + 0), 24 + PSet (ex% + 15, ey% + 0), 42 + PSet (ex% + 16, ey% + 0), 42 + PSet (ex% + 17, ey% + 0), 41 + PSet (ex% + 18, ey% + 0), 21 + PSet (ex% + 19, ey% + 0), 19 + PSet (ex% + 5, ey% + 1), 178 + PSet (ex% + 6, ey% + 1), 106 + PSet (ex% + 7, ey% + 1), 106 + PSet (ex% + 8, ey% + 1), 106 + PSet (ex% + 9, ey% + 1), 130 + PSet (ex% + 10, ey% + 1), 154 + PSet (ex% + 11, ey% + 1), 42 + PSet (ex% + 12, ey% + 1), 43 + PSet (ex% + 13, ey% + 1), 43 + PSet (ex% + 14, ey% + 1), 42 + PSet (ex% + 15, ey% + 1), 43 + PSet (ex% + 16, ey% + 1), 43 + PSet (ex% + 17, ey% + 1), 44 + PSet (ex% + 18, ey% + 1), 42 + PSet (ex% + 19, ey% + 1), 19 + PSet (ex% + 20, ey% + 1), 19 + PSet (ex% + 2, ey% + 2), 178 + PSet (ex% + 3, ey% + 2), 106 + PSet (ex% + 4, ey% + 2), 106 + PSet (ex% + 5, ey% + 2), 106 + PSet (ex% + 6, ey% + 2), 130 + PSet (ex% + 7, ey% + 2), 154 + PSet (ex% + 8, ey% + 2), 25 + PSet (ex% + 9, ey% + 2), 25 + PSet (ex% + 10, ey% + 2), 25 + PSet (ex% + 11, ey% + 2), 23 + PSet (ex% + 12, ey% + 2), 42 + PSet (ex% + 13, ey% + 2), 21 + PSet (ex% + 14, ey% + 2), 44 + PSet (ex% + 15, ey% + 2), 43 + PSet (ex% + 16, ey% + 2), 44 + PSet (ex% + 17, ey% + 2), 44 + PSet (ex% + 18, ey% + 2), 43 + PSet (ex% + 19, ey% + 2), 42 + PSet (ex% + 20, ey% + 2), 23 + PSet (ex% + 21, ey% + 2), 21 + PSet (ex% + 0, ey% + 3), 21 + PSet (ex% + 1, ey% + 3), 22 + PSet (ex% + 2, ey% + 3), 23 + PSet (ex% + 3, ey% + 3), 23 + PSet (ex% + 4, ey% + 3), 24 + PSet (ex% + 5, ey% + 3), 24 + PSet (ex% + 6, ey% + 3), 24 + PSet (ex% + 7, ey% + 3), 24 + PSet (ex% + 8, ey% + 3), 24 + PSet (ex% + 9, ey% + 3), 21 + PSet (ex% + 10, ey% + 3), 21 + PSet (ex% + 11, ey% + 3), 20 + PSet (ex% + 12, ey% + 3), 20 + PSet (ex% + 14, ey% + 3), 24 + PSet (ex% + 15, ey% + 3), 25 + PSet (ex% + 16, ey% + 3), 44 + PSet (ex% + 17, ey% + 3), 43 + PSet (ex% + 18, ey% + 3), 42 + PSet (ex% + 19, ey% + 3), 20 + PSet (ex% + 20, ey% + 3), 19 + PSet (ex% + 21, ey% + 3), 19 + PSet (ex% + 3, ey% + 4), 20 + PSet (ex% + 4, ey% + 4), 22 + PSet (ex% + 5, ey% + 4), 22 + PSet (ex% + 6, ey% + 4), 20 + PSet (ex% + 7, ey% + 4), 19 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 43 + PSet (ex% + 15, ey% + 4), 44 + PSet (ex% + 16, ey% + 4), 43 + PSet (ex% + 17, ey% + 4), 42 + PSet (ex% + 18, ey% + 4), 20 + PSet (ex% + 19, ey% + 4), 20 + PSet (ex% + 20, ey% + 4), 19 + PSet (ex% + 9, ey% + 5), 19 + PSet (ex% + 10, ey% + 5), 21 + PSet (ex% + 11, ey% + 5), 22 + PSet (ex% + 12, ey% + 5), 24 + PSet (ex% + 13, ey% + 5), 25 + PSet (ex% + 14, ey% + 5), 25 + PSet (ex% + 15, ey% + 5), 43 + PSet (ex% + 16, ey% + 5), 20 + PSet (ex% + 17, ey% + 5), 20 + PSet (ex% + 18, ey% + 5), 19 + PSet (ex% + 8, ey% + 6), 19 + PSet (ex% + 9, ey% + 6), 19 + PSet (ex% + 10, ey% + 6), 42 + PSet (ex% + 11, ey% + 6), 44 + PSet (ex% + 12, ey% + 6), 43 + PSet (ex% + 13, ey% + 6), 24 + PSet (ex% + 14, ey% + 6), 20 + PSet (ex% + 15, ey% + 6), 19 + PSet (ex% + 16, ey% + 6), 19 + PSet (ex% + 8, ey% + 7), 41 + PSet (ex% + 9, ey% + 7), 42 + PSet (ex% + 10, ey% + 7), 44 + PSet (ex% + 11, ey% + 7), 26 + PSet (ex% + 12, ey% + 7), 23 + PSet (ex% + 13, ey% + 7), 21 + PSet (ex% + 14, ey% + 7), 19 + PSet (ex% + 8, ey% + 8), 19 + PSet (ex% + 9, ey% + 8), 22 + PSet (ex% + 10, ey% + 8), 24 + PSet (ex% + 11, ey% + 8), 22 +End Sub + +Sub xxf3 + PSet (ex% + 18, ey% + -3), 41 + PSet (ex% + 11, ey% + -2), 41 + PSet (ex% + 13, ey% + -2), 41 + PSet (ex% + 16, ey% + -2), 42 + PSet (ex% + 17, ey% + -2), 44 + PSet (ex% + 18, ey% + -2), 43 + PSet (ex% + 19, ey% + -2), 42 + PSet (ex% + 10, ey% + -1), 41 + PSet (ex% + 11, ey% + -1), 42 + PSet (ex% + 12, ey% + -1), 43 + PSet (ex% + 15, ey% + -1), 42 + PSet (ex% + 16, ey% + -1), 44 + PSet (ex% + 17, ey% + -1), 43 + PSet (ex% + 18, ey% + -1), 44 + PSet (ex% + 21, ey% + -1), 41 + PSet (ex% + 8, ey% + 0), 178 + PSet (ex% + 9, ey% + 0), 41 + PSet (ex% + 10, ey% + 0), 42 + PSet (ex% + 11, ey% + 0), 43 + PSet (ex% + 12, ey% + 0), 43 + PSet (ex% + 13, ey% + 0), 42 + PSet (ex% + 14, ey% + 0), 24 + PSet (ex% + 15, ey% + 0), 42 + PSet (ex% + 16, ey% + 0), 44 + PSet (ex% + 17, ey% + 0), 43 + PSet (ex% + 18, ey% + 0), 43 + PSet (ex% + 19, ey% + 0), 42 + PSet (ex% + 20, ey% + 0), 42 + PSet (ex% + 21, ey% + 0), 44 + PSet (ex% + 22, ey% + 0), 43 + PSet (ex% + 23, ey% + 0), 42 + PSet (ex% + 5, ey% + 1), 42 + PSet (ex% + 6, ey% + 1), 43 + PSet (ex% + 7, ey% + 1), 106 + PSet (ex% + 8, ey% + 1), 106 + PSet (ex% + 9, ey% + 1), 130 + PSet (ex% + 10, ey% + 1), 43 + PSet (ex% + 11, ey% + 1), 42 + PSet (ex% + 12, ey% + 1), 44 + PSet (ex% + 13, ey% + 1), 43 + PSet (ex% + 14, ey% + 1), 44 + PSet (ex% + 15, ey% + 1), 43 + PSet (ex% + 16, ey% + 1), 43 + PSet (ex% + 17, ey% + 1), 44 + PSet (ex% + 18, ey% + 1), 42 + PSet (ex% + 19, ey% + 1), 44 + PSet (ex% + 20, ey% + 1), 44 + PSet (ex% + 21, ey% + 1), 43 + PSet (ex% + 22, ey% + 1), 42 + PSet (ex% + 2, ey% + 2), 178 + PSet (ex% + 3, ey% + 2), 106 + PSet (ex% + 4, ey% + 2), 42 + PSet (ex% + 5, ey% + 2), 43 + PSet (ex% + 6, ey% + 2), 44 + PSet (ex% + 7, ey% + 2), 43 + PSet (ex% + 8, ey% + 2), 25 + PSet (ex% + 9, ey% + 2), 25 + PSet (ex% + 10, ey% + 2), 43 + PSet (ex% + 11, ey% + 2), 44 + PSet (ex% + 12, ey% + 2), 43 + PSet (ex% + 13, ey% + 2), 21 + PSet (ex% + 14, ey% + 2), 44 + PSet (ex% + 15, ey% + 2), 43 + PSet (ex% + 16, ey% + 2), 44 + PSet (ex% + 17, ey% + 2), 44 + PSet (ex% + 18, ey% + 2), 43 + PSet (ex% + 19, ey% + 2), 43 + PSet (ex% + 20, ey% + 2), 43 + PSet (ex% + 21, ey% + 2), 44 + PSet (ex% + 0, ey% + 3), 21 + PSet (ex% + 1, ey% + 3), 22 + PSet (ex% + 2, ey% + 3), 23 + PSet (ex% + 3, ey% + 3), 23 + PSet (ex% + 4, ey% + 3), 24 + PSet (ex% + 5, ey% + 3), 43 + PSet (ex% + 6, ey% + 3), 43 + PSet (ex% + 7, ey% + 3), 24 + PSet (ex% + 8, ey% + 3), 24 + PSet (ex% + 9, ey% + 3), 41 + PSet (ex% + 10, ey% + 3), 42 + PSet (ex% + 11, ey% + 3), 42 + PSet (ex% + 12, ey% + 3), 44 + PSet (ex% + 14, ey% + 3), 24 + PSet (ex% + 15, ey% + 3), 25 + PSet (ex% + 16, ey% + 3), 44 + PSet (ex% + 17, ey% + 3), 43 + PSet (ex% + 18, ey% + 3), 44 + PSet (ex% + 19, ey% + 3), 42 + PSet (ex% + 20, ey% + 3), 44 + PSet (ex% + 21, ey% + 3), 43 + PSet (ex% + 22, ey% + 3), 41 + PSet (ex% + 3, ey% + 4), 20 + PSet (ex% + 4, ey% + 4), 22 + PSet (ex% + 5, ey% + 4), 22 + PSet (ex% + 6, ey% + 4), 20 + PSet (ex% + 7, ey% + 4), 19 + PSet (ex% + 10, ey% + 4), 41 + PSet (ex% + 12, ey% + 4), 43 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 43 + PSet (ex% + 15, ey% + 4), 44 + PSet (ex% + 16, ey% + 4), 43 + PSet (ex% + 17, ey% + 4), 42 + PSet (ex% + 18, ey% + 4), 43 + PSet (ex% + 19, ey% + 4), 44 + PSet (ex% + 20, ey% + 4), 43 + PSet (ex% + 12, ey% + 5), 43 + PSet (ex% + 13, ey% + 5), 44 + PSet (ex% + 14, ey% + 5), 44 + PSet (ex% + 15, ey% + 5), 43 + PSet (ex% + 16, ey% + 5), 44 + PSet (ex% + 17, ey% + 5), 42 + PSet (ex% + 18, ey% + 5), 42 + PSet (ex% + 19, ey% + 5), 41 + PSet (ex% + 21, ey% + 5), 42 + PSet (ex% + 11, ey% + 6), 42 + PSet (ex% + 12, ey% + 6), 41 + PSet (ex% + 13, ey% + 6), 43 + PSet (ex% + 14, ey% + 6), 44 + PSet (ex% + 15, ey% + 6), 44 + PSet (ex% + 16, ey% + 6), 42 + PSet (ex% + 18, ey% + 6), 41 + PSet (ex% + 10, ey% + 7), 19 + PSet (ex% + 11, ey% + 7), 23 + PSet (ex% + 12, ey% + 7), 43 + PSet (ex% + 13, ey% + 7), 42 + PSet (ex% + 14, ey% + 7), 24 + PSet (ex% + 15, ey% + 7), 42 + PSet (ex% + 16, ey% + 7), 43 + PSet (ex% + 17, ey% + 7), 42 + PSet (ex% + 9, ey% + 8), 19 + PSet (ex% + 10, ey% + 8), 24 + PSet (ex% + 11, ey% + 8), 44 + PSet (ex% + 12, ey% + 8), 42 + PSet (ex% + 13, ey% + 8), 25 + PSet (ex% + 14, ey% + 8), 23 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 10, ey% + 9), 43 + PSet (ex% + 11, ey% + 9), 42 + PSet (ex% + 12, ey% + 9), 22 + PSet (ex% + 13, ey% + 9), 21 +End Sub + +Sub xxf4 + PSet (ex% + 18, ey% + -3), 42 + PSet (ex% + 20, ey% + -3), 40 + PSet (ex% + 11, ey% + -2), 41 + PSet (ex% + 13, ey% + -2), 41 + PSet (ex% + 16, ey% + -2), 42 + PSet (ex% + 17, ey% + -2), 44 + PSet (ex% + 18, ey% + -2), 43 + PSet (ex% + 19, ey% + -2), 44 + PSet (ex% + 20, ey% + -2), 42 + PSet (ex% + 10, ey% + -1), 41 + PSet (ex% + 11, ey% + -1), 42 + PSet (ex% + 12, ey% + -1), 43 + PSet (ex% + 14, ey% + -1), 44 + PSet (ex% + 15, ey% + -1), 44 + PSet (ex% + 16, ey% + -1), 44 + PSet (ex% + 17, ey% + -1), 43 + PSet (ex% + 18, ey% + -1), 44 + PSet (ex% + 19, ey% + -1), 44 + PSet (ex% + 21, ey% + -1), 43 + PSet (ex% + 22, ey% + -1), 43 + PSet (ex% + 6, ey% + 0), 40 + PSet (ex% + 7, ey% + 0), 42 + PSet (ex% + 8, ey% + 0), 178 + PSet (ex% + 9, ey% + 0), 41 + PSet (ex% + 10, ey% + 0), 42 + PSet (ex% + 11, ey% + 0), 43 + PSet (ex% + 12, ey% + 0), 43 + PSet (ex% + 13, ey% + 0), 42 + PSet (ex% + 14, ey% + 0), 24 + PSet (ex% + 15, ey% + 0), 42 + PSet (ex% + 16, ey% + 0), 44 + PSet (ex% + 17, ey% + 0), 43 + PSet (ex% + 18, ey% + 0), 43 + PSet (ex% + 19, ey% + 0), 42 + PSet (ex% + 20, ey% + 0), 42 + PSet (ex% + 21, ey% + 0), 44 + PSet (ex% + 22, ey% + 0), 43 + PSet (ex% + 23, ey% + 0), 42 + PSet (ex% + 4, ey% + 1), 41 + PSet (ex% + 5, ey% + 1), 43 + PSet (ex% + 6, ey% + 1), 43 + PSet (ex% + 7, ey% + 1), 44 + PSet (ex% + 8, ey% + 1), 43 + PSet (ex% + 9, ey% + 1), 130 + PSet (ex% + 10, ey% + 1), 43 + PSet (ex% + 11, ey% + 1), 42 + PSet (ex% + 12, ey% + 1), 44 + PSet (ex% + 13, ey% + 1), 43 + PSet (ex% + 14, ey% + 1), 44 + PSet (ex% + 15, ey% + 1), 42 + PSet (ex% + 16, ey% + 1), 43 + PSet (ex% + 17, ey% + 1), 42 + PSet (ex% + 18, ey% + 1), 43 + PSet (ex% + 19, ey% + 1), 44 + PSet (ex% + 20, ey% + 1), 44 + PSet (ex% + 21, ey% + 1), 43 + PSet (ex% + 22, ey% + 1), 43 + PSet (ex% + 23, ey% + 1), 44 + PSet (ex% + 2, ey% + 2), 178 + PSet (ex% + 3, ey% + 2), 43 + PSet (ex% + 4, ey% + 2), 42 + PSet (ex% + 5, ey% + 2), 43 + PSet (ex% + 6, ey% + 2), 44 + PSet (ex% + 7, ey% + 2), 43 + PSet (ex% + 8, ey% + 2), 25 + PSet (ex% + 9, ey% + 2), 25 + PSet (ex% + 10, ey% + 2), 43 + PSet (ex% + 11, ey% + 2), 44 + PSet (ex% + 12, ey% + 2), 43 + PSet (ex% + 13, ey% + 2), 21 + PSet (ex% + 14, ey% + 2), 42 + PSet (ex% + 15, ey% + 2), 43 + PSet (ex% + 16, ey% + 2), 41 + PSet (ex% + 17, ey% + 2), 42 + PSet (ex% + 18, ey% + 2), 42 + PSet (ex% + 19, ey% + 2), 43 + PSet (ex% + 20, ey% + 2), 43 + PSet (ex% + 21, ey% + 2), 44 + PSet (ex% + 0, ey% + 3), 21 + PSet (ex% + 1, ey% + 3), 22 + PSet (ex% + 2, ey% + 3), 41 + PSet (ex% + 3, ey% + 3), 42 + PSet (ex% + 4, ey% + 3), 41 + PSet (ex% + 5, ey% + 3), 43 + PSet (ex% + 6, ey% + 3), 43 + PSet (ex% + 7, ey% + 3), 43 + PSet (ex% + 8, ey% + 3), 44 + PSet (ex% + 9, ey% + 3), 43 + PSet (ex% + 10, ey% + 3), 44 + PSet (ex% + 11, ey% + 3), 42 + PSet (ex% + 12, ey% + 3), 44 + PSet (ex% + 14, ey% + 3), 24 + PSet (ex% + 15, ey% + 3), 25 + PSet (ex% + 16, ey% + 3), 43 + PSet (ex% + 17, ey% + 3), 41 + PSet (ex% + 18, ey% + 3), 44 + PSet (ex% + 19, ey% + 3), 42 + PSet (ex% + 20, ey% + 3), 44 + PSet (ex% + 21, ey% + 3), 43 + PSet (ex% + 22, ey% + 3), 42 + PSet (ex% + 3, ey% + 4), 20 + PSet (ex% + 4, ey% + 4), 22 + PSet (ex% + 5, ey% + 4), 42 + PSet (ex% + 6, ey% + 4), 42 + PSet (ex% + 7, ey% + 4), 19 + PSet (ex% + 8, ey% + 4), 42 + PSet (ex% + 9, ey% + 4), 43 + PSet (ex% + 10, ey% + 4), 41 + PSet (ex% + 12, ey% + 4), 43 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 43 + PSet (ex% + 15, ey% + 4), 44 + PSet (ex% + 16, ey% + 4), 43 + PSet (ex% + 17, ey% + 4), 43 + PSet (ex% + 18, ey% + 4), 43 + PSet (ex% + 19, ey% + 4), 44 + PSet (ex% + 20, ey% + 4), 43 + PSet (ex% + 10, ey% + 5), 44 + PSet (ex% + 12, ey% + 5), 43 + PSet (ex% + 13, ey% + 5), 44 + PSet (ex% + 14, ey% + 5), 44 + PSet (ex% + 15, ey% + 5), 43 + PSet (ex% + 16, ey% + 5), 44 + PSet (ex% + 17, ey% + 5), 44 + PSet (ex% + 18, ey% + 5), 43 + PSet (ex% + 19, ey% + 5), 42 + PSet (ex% + 21, ey% + 5), 42 + PSet (ex% + 22, ey% + 5), 42 + PSet (ex% + 11, ey% + 6), 42 + PSet (ex% + 12, ey% + 6), 41 + PSet (ex% + 13, ey% + 6), 43 + PSet (ex% + 14, ey% + 6), 44 + PSet (ex% + 15, ey% + 6), 44 + PSet (ex% + 16, ey% + 6), 42 + PSet (ex% + 18, ey% + 6), 43 + PSet (ex% + 19, ey% + 6), 43 + PSet (ex% + 10, ey% + 7), 43 + PSet (ex% + 11, ey% + 7), 44 + PSet (ex% + 12, ey% + 7), 43 + PSet (ex% + 13, ey% + 7), 42 + PSet (ex% + 14, ey% + 7), 24 + PSet (ex% + 15, ey% + 7), 42 + PSet (ex% + 16, ey% + 7), 43 + PSet (ex% + 17, ey% + 7), 42 + PSet (ex% + 18, ey% + 7), 43 + PSet (ex% + 20, ey% + 7), 42 + PSet (ex% + 21, ey% + 7), 41 + PSet (ex% + 9, ey% + 8), 43 + PSet (ex% + 10, ey% + 8), 23 + PSet (ex% + 11, ey% + 8), 42 + PSet (ex% + 12, ey% + 8), 44 + PSet (ex% + 13, ey% + 8), 43 + PSet (ex% + 14, ey% + 8), 43 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 18, ey% + 8), 41 + PSet (ex% + 10, ey% + 9), 43 + PSet (ex% + 11, ey% + 9), 43 + PSet (ex% + 12, ey% + 9), 22 + PSet (ex% + 13, ey% + 9), 43 + PSet (ex% + 14, ey% + 9), 42 +End Sub + +Sub xxf5 + PSet (ex% + 13, ey% + -3), 42 + PSet (ex% + 14, ey% + -3), 41 + PSet (ex% + 15, ey% + -3), 41 + PSet (ex% + 18, ey% + -3), 41 + PSet (ex% + 20, ey% + -3), 40 + PSet (ex% + 23, ey% + -3), 41 + PSet (ex% + 11, ey% + -2), 41 + PSet (ex% + 13, ey% + -2), 41 + PSet (ex% + 14, ey% + -2), 42 + PSet (ex% + 16, ey% + -2), 42 + PSet (ex% + 17, ey% + -2), 42 + PSet (ex% + 18, ey% + -2), 43 + PSet (ex% + 19, ey% + -2), 41 + PSet (ex% + 20, ey% + -2), 42 + PSet (ex% + 21, ey% + -2), 42 + PSet (ex% + 22, ey% + -2), 41 + PSet (ex% + 4, ey% + -1), 40 + PSet (ex% + 9, ey% + -1), 41 + PSet (ex% + 10, ey% + -1), 42 + PSet (ex% + 11, ey% + -1), 42 + PSet (ex% + 12, ey% + -1), 41 + PSet (ex% + 14, ey% + -1), 44 + PSet (ex% + 15, ey% + -1), 44 + PSet (ex% + 16, ey% + -1), 44 + PSet (ex% + 17, ey% + -1), 43 + PSet (ex% + 18, ey% + -1), 44 + PSet (ex% + 19, ey% + -1), 44 + PSet (ex% + 21, ey% + -1), 43 + PSet (ex% + 22, ey% + -1), 43 + PSet (ex% + 24, ey% + -1), 41 + PSet (ex% + 6, ey% + 0), 40 + PSet (ex% + 7, ey% + 0), 42 + PSet (ex% + 8, ey% + 0), 44 + PSet (ex% + 9, ey% + 0), 41 + PSet (ex% + 10, ey% + 0), 42 + PSet (ex% + 11, ey% + 0), 43 + PSet (ex% + 12, ey% + 0), 43 + PSet (ex% + 13, ey% + 0), 42 + PSet (ex% + 14, ey% + 0), 44 + PSet (ex% + 15, ey% + 0), 42 + PSet (ex% + 16, ey% + 0), 44 + PSet (ex% + 17, ey% + 0), 43 + PSet (ex% + 18, ey% + 0), 43 + PSet (ex% + 19, ey% + 0), 42 + PSet (ex% + 20, ey% + 0), 42 + PSet (ex% + 21, ey% + 0), 44 + PSet (ex% + 22, ey% + 0), 42 + PSet (ex% + 23, ey% + 0), 42 + PSet (ex% + 3, ey% + 1), 40 + PSet (ex% + 4, ey% + 1), 41 + PSet (ex% + 5, ey% + 1), 43 + PSet (ex% + 6, ey% + 1), 43 + PSet (ex% + 7, ey% + 1), 44 + PSet (ex% + 8, ey% + 1), 43 + PSet (ex% + 9, ey% + 1), 44 + PSet (ex% + 10, ey% + 1), 43 + PSet (ex% + 11, ey% + 1), 42 + PSet (ex% + 12, ey% + 1), 44 + PSet (ex% + 13, ey% + 1), 44 + PSet (ex% + 14, ey% + 1), 44 + PSet (ex% + 15, ey% + 1), 42 + PSet (ex% + 16, ey% + 1), 43 + PSet (ex% + 17, ey% + 1), 42 + PSet (ex% + 18, ey% + 1), 43 + PSet (ex% + 19, ey% + 1), 44 + PSet (ex% + 20, ey% + 1), 44 + PSet (ex% + 21, ey% + 1), 43 + PSet (ex% + 22, ey% + 1), 43 + PSet (ex% + 23, ey% + 1), 43 + PSet (ex% + 24, ey% + 1), 42 + PSet (ex% + 25, ey% + 1), 41 + PSet (ex% + 1, ey% + 2), 41 + PSet (ex% + 2, ey% + 2), 42 + PSet (ex% + 3, ey% + 2), 43 + PSet (ex% + 4, ey% + 2), 42 + PSet (ex% + 5, ey% + 2), 43 + PSet (ex% + 6, ey% + 2), 44 + PSet (ex% + 7, ey% + 2), 43 + PSet (ex% + 8, ey% + 2), 44 + PSet (ex% + 9, ey% + 2), 44 + PSet (ex% + 10, ey% + 2), 44 + PSet (ex% + 11, ey% + 2), 44 + PSet (ex% + 12, ey% + 2), 43 + PSet (ex% + 13, ey% + 2), 44 + PSet (ex% + 14, ey% + 2), 42 + PSet (ex% + 15, ey% + 2), 42 + PSet (ex% + 16, ey% + 2), 41 + PSet (ex% + 17, ey% + 2), 42 + PSet (ex% + 18, ey% + 2), 41 + PSet (ex% + 19, ey% + 2), 43 + PSet (ex% + 20, ey% + 2), 43 + PSet (ex% + 21, ey% + 2), 44 + PSet (ex% + 24, ey% + 2), 40 + PSet (ex% + 0, ey% + 3), 41 + PSet (ex% + 1, ey% + 3), 43 + PSet (ex% + 2, ey% + 3), 43 + PSet (ex% + 3, ey% + 3), 42 + PSet (ex% + 4, ey% + 3), 41 + PSet (ex% + 5, ey% + 3), 43 + PSet (ex% + 6, ey% + 3), 43 + PSet (ex% + 7, ey% + 3), 43 + PSet (ex% + 8, ey% + 3), 44 + PSet (ex% + 9, ey% + 3), 43 + PSet (ex% + 10, ey% + 3), 44 + PSet (ex% + 11, ey% + 3), 42 + PSet (ex% + 12, ey% + 3), 44 + PSet (ex% + 13, ey% + 3), 44 + PSet (ex% + 14, ey% + 3), 44 + PSet (ex% + 15, ey% + 3), 43 + PSet (ex% + 16, ey% + 3), 42 + PSet (ex% + 17, ey% + 3), 41 + PSet (ex% + 18, ey% + 3), 44 + PSet (ex% + 19, ey% + 3), 42 + PSet (ex% + 20, ey% + 3), 44 + PSet (ex% + 21, ey% + 3), 43 + PSet (ex% + 22, ey% + 3), 42 + PSet (ex% + 2, ey% + 4), 41 + PSet (ex% + 3, ey% + 4), 43 + PSet (ex% + 4, ey% + 4), 43 + PSet (ex% + 5, ey% + 4), 42 + PSet (ex% + 6, ey% + 4), 42 + PSet (ex% + 7, ey% + 4), 44 + PSet (ex% + 8, ey% + 4), 42 + PSet (ex% + 9, ey% + 4), 43 + PSet (ex% + 10, ey% + 4), 41 + PSet (ex% + 12, ey% + 4), 43 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 43 + PSet (ex% + 15, ey% + 4), 44 + PSet (ex% + 16, ey% + 4), 43 + PSet (ex% + 17, ey% + 4), 43 + PSet (ex% + 18, ey% + 4), 43 + PSet (ex% + 19, ey% + 4), 44 + PSet (ex% + 20, ey% + 4), 43 + PSet (ex% + 23, ey% + 4), 41 + PSet (ex% + 3, ey% + 5), 42 + PSet (ex% + 4, ey% + 5), 43 + PSet (ex% + 6, ey% + 5), 41 + PSet (ex% + 8, ey% + 5), 42 + PSet (ex% + 9, ey% + 5), 43 + PSet (ex% + 10, ey% + 5), 43 + PSet (ex% + 11, ey% + 5), 44 + PSet (ex% + 12, ey% + 5), 43 + PSet (ex% + 13, ey% + 5), 44 + PSet (ex% + 14, ey% + 5), 43 + PSet (ex% + 15, ey% + 5), 43 + PSet (ex% + 16, ey% + 5), 44 + PSet (ex% + 17, ey% + 5), 44 + PSet (ex% + 18, ey% + 5), 43 + PSet (ex% + 19, ey% + 5), 42 + PSet (ex% + 21, ey% + 5), 42 + PSet (ex% + 22, ey% + 5), 42 + PSet (ex% + 9, ey% + 6), 41 + PSet (ex% + 11, ey% + 6), 42 + PSet (ex% + 12, ey% + 6), 41 + PSet (ex% + 13, ey% + 6), 43 + PSet (ex% + 14, ey% + 6), 44 + PSet (ex% + 15, ey% + 6), 44 + PSet (ex% + 16, ey% + 6), 42 + PSet (ex% + 18, ey% + 6), 43 + PSet (ex% + 19, ey% + 6), 43 + PSet (ex% + 23, ey% + 6), 41 + PSet (ex% + 10, ey% + 7), 41 + PSet (ex% + 11, ey% + 7), 43 + PSet (ex% + 12, ey% + 7), 42 + PSet (ex% + 13, ey% + 7), 42 + PSet (ex% + 14, ey% + 7), 44 + PSet (ex% + 15, ey% + 7), 42 + PSet (ex% + 16, ey% + 7), 43 + PSet (ex% + 17, ey% + 7), 42 + PSet (ex% + 18, ey% + 7), 43 + PSet (ex% + 20, ey% + 7), 42 + PSet (ex% + 21, ey% + 7), 41 + PSet (ex% + 9, ey% + 8), 41 + PSet (ex% + 10, ey% + 8), 23 + PSet (ex% + 11, ey% + 8), 42 + PSet (ex% + 12, ey% + 8), 43 + PSet (ex% + 13, ey% + 8), 43 + PSet (ex% + 14, ey% + 8), 43 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 16, ey% + 8), 40 + PSet (ex% + 18, ey% + 8), 41 + PSet (ex% + 22, ey% + 8), 40 + PSet (ex% + 10, ey% + 9), 40 + PSet (ex% + 11, ey% + 9), 42 + PSet (ex% + 12, ey% + 9), 22 + PSet (ex% + 13, ey% + 9), 43 + PSet (ex% + 14, ey% + 9), 42 + PSet (ex% + 15, ey% + 9), 41 + PSet (ex% + 13, ey% + 10), 40 +End Sub + +Sub xxf6 + PSet (ex% + 13, ey% + -3), 42 + PSet (ex% + 14, ey% + -3), 41 + PSet (ex% + 15, ey% + -3), 41 + PSet (ex% + 18, ey% + -3), 41 + PSet (ex% + 21, ey% + -3), 40 + PSet (ex% + 11, ey% + -2), 41 + PSet (ex% + 13, ey% + -2), 41 + PSet (ex% + 14, ey% + -2), 42 + PSet (ex% + 16, ey% + -2), 42 + PSet (ex% + 17, ey% + -2), 41 + PSet (ex% + 18, ey% + -2), 42 + PSet (ex% + 19, ey% + -2), 40 + PSet (ex% + 21, ey% + -2), 42 + PSet (ex% + 22, ey% + -2), 41 + PSet (ex% + 24, ey% + -2), 41 + PSet (ex% + 4, ey% + -1), 43 + PSet (ex% + 9, ey% + -1), 41 + PSet (ex% + 10, ey% + -1), 42 + PSet (ex% + 11, ey% + -1), 42 + PSet (ex% + 12, ey% + -1), 41 + PSet (ex% + 14, ey% + -1), 40 + PSet (ex% + 15, ey% + -1), 43 + PSet (ex% + 16, ey% + -1), 43 + PSet (ex% + 17, ey% + -1), 43 + PSet (ex% + 18, ey% + -1), 43 + PSet (ex% + 19, ey% + -1), 41 + PSet (ex% + 21, ey% + -1), 43 + PSet (ex% + 22, ey% + -1), 43 + PSet (ex% + 5, ey% + 0), 41 + PSet (ex% + 6, ey% + 0), 40 + PSet (ex% + 7, ey% + 0), 42 + PSet (ex% + 8, ey% + 0), 44 + PSet (ex% + 9, ey% + 0), 41 + PSet (ex% + 10, ey% + 0), 42 + PSet (ex% + 11, ey% + 0), 43 + PSet (ex% + 12, ey% + 0), 43 + PSet (ex% + 13, ey% + 0), 42 + PSet (ex% + 14, ey% + 0), 43 + PSet (ex% + 15, ey% + 0), 42 + PSet (ex% + 16, ey% + 0), 44 + PSet (ex% + 17, ey% + 0), 42 + PSet (ex% + 18, ey% + 0), 40 + PSet (ex% + 19, ey% + 0), 42 + PSet (ex% + 20, ey% + 0), 42 + PSet (ex% + 21, ey% + 0), 44 + PSet (ex% + 22, ey% + 0), 41 + PSet (ex% + 23, ey% + 0), 42 + PSet (ex% + 3, ey% + 1), 41 + PSet (ex% + 4, ey% + 1), 43 + PSet (ex% + 5, ey% + 1), 42 + PSet (ex% + 6, ey% + 1), 43 + PSet (ex% + 7, ey% + 1), 44 + PSet (ex% + 8, ey% + 1), 43 + PSet (ex% + 9, ey% + 1), 43 + PSet (ex% + 10, ey% + 1), 43 + PSet (ex% + 11, ey% + 1), 42 + PSet (ex% + 12, ey% + 1), 40 + PSet (ex% + 13, ey% + 1), 43 + PSet (ex% + 14, ey% + 1), 44 + PSet (ex% + 15, ey% + 1), 43 + PSet (ex% + 16, ey% + 1), 41 + PSet (ex% + 17, ey% + 1), 42 + PSet (ex% + 19, ey% + 1), 41 + PSet (ex% + 20, ey% + 1), 43 + PSet (ex% + 21, ey% + 1), 42 + PSet (ex% + 22, ey% + 1), 40 + PSet (ex% + 24, ey% + 1), 40 + PSet (ex% + 1, ey% + 2), 41 + PSet (ex% + 2, ey% + 2), 42 + PSet (ex% + 3, ey% + 2), 42 + PSet (ex% + 4, ey% + 2), 41 + PSet (ex% + 6, ey% + 2), 41 + PSet (ex% + 7, ey% + 2), 43 + PSet (ex% + 8, ey% + 2), 44 + PSet (ex% + 9, ey% + 2), 42 + PSet (ex% + 10, ey% + 2), 41 + PSet (ex% + 11, ey% + 2), 41 + PSet (ex% + 13, ey% + 2), 40 + PSet (ex% + 14, ey% + 2), 42 + PSet (ex% + 15, ey% + 2), 41 + PSet (ex% + 16, ey% + 2), 41 + PSet (ex% + 19, ey% + 2), 40 + PSet (ex% + 20, ey% + 2), 42 + PSet (ex% + 21, ey% + 2), 44 + PSet (ex% + 0, ey% + 3), 41 + PSet (ex% + 1, ey% + 3), 43 + PSet (ex% + 2, ey% + 3), 43 + PSet (ex% + 3, ey% + 3), 41 + PSet (ex% + 6, ey% + 3), 40 + PSet (ex% + 7, ey% + 3), 42 + PSet (ex% + 8, ey% + 3), 44 + PSet (ex% + 9, ey% + 3), 43 + PSet (ex% + 10, ey% + 3), 44 + PSet (ex% + 11, ey% + 3), 42 + PSet (ex% + 12, ey% + 3), 41 + PSet (ex% + 13, ey% + 3), 41 + PSet (ex% + 14, ey% + 3), 44 + PSet (ex% + 15, ey% + 3), 43 + PSet (ex% + 16, ey% + 3), 42 + PSet (ex% + 17, ey% + 3), 41 + PSet (ex% + 18, ey% + 3), 42 + PSet (ex% + 19, ey% + 3), 41 + PSet (ex% + 20, ey% + 3), 44 + PSet (ex% + 21, ey% + 3), 40 + PSet (ex% + 22, ey% + 3), 42 + PSet (ex% + 2, ey% + 4), 41 + PSet (ex% + 3, ey% + 4), 42 + PSet (ex% + 4, ey% + 4), 41 + PSet (ex% + 5, ey% + 4), 42 + PSet (ex% + 6, ey% + 4), 41 + PSet (ex% + 7, ey% + 4), 44 + PSet (ex% + 8, ey% + 4), 42 + PSet (ex% + 9, ey% + 4), 43 + PSet (ex% + 10, ey% + 4), 41 + PSet (ex% + 12, ey% + 4), 42 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 43 + PSet (ex% + 15, ey% + 4), 44 + PSet (ex% + 16, ey% + 4), 42 + PSet (ex% + 17, ey% + 4), 42 + PSet (ex% + 18, ey% + 4), 42 + PSet (ex% + 19, ey% + 4), 44 + PSet (ex% + 20, ey% + 4), 41 + PSet (ex% + 24, ey% + 4), 42 + PSet (ex% + 25, ey% + 4), 41 + PSet (ex% + 3, ey% + 5), 42 + PSet (ex% + 4, ey% + 5), 43 + PSet (ex% + 6, ey% + 5), 41 + PSet (ex% + 8, ey% + 5), 42 + PSet (ex% + 9, ey% + 5), 43 + PSet (ex% + 10, ey% + 5), 43 + PSet (ex% + 11, ey% + 5), 44 + PSet (ex% + 12, ey% + 5), 43 + PSet (ex% + 13, ey% + 5), 44 + PSet (ex% + 14, ey% + 5), 43 + PSet (ex% + 15, ey% + 5), 43 + PSet (ex% + 16, ey% + 5), 44 + PSet (ex% + 17, ey% + 5), 41 + PSet (ex% + 18, ey% + 5), 43 + PSet (ex% + 19, ey% + 5), 41 + PSet (ex% + 9, ey% + 6), 41 + PSet (ex% + 11, ey% + 6), 42 + PSet (ex% + 12, ey% + 6), 41 + PSet (ex% + 13, ey% + 6), 43 + PSet (ex% + 14, ey% + 6), 44 + PSet (ex% + 15, ey% + 6), 44 + PSet (ex% + 16, ey% + 6), 42 + PSet (ex% + 18, ey% + 6), 41 + PSet (ex% + 19, ey% + 6), 42 + PSet (ex% + 23, ey% + 6), 41 + PSet (ex% + 24, ey% + 6), 42 + PSet (ex% + 10, ey% + 7), 41 + PSet (ex% + 11, ey% + 7), 43 + PSet (ex% + 12, ey% + 7), 42 + PSet (ex% + 13, ey% + 7), 42 + PSet (ex% + 14, ey% + 7), 44 + PSet (ex% + 15, ey% + 7), 42 + PSet (ex% + 16, ey% + 7), 43 + PSet (ex% + 17, ey% + 7), 42 + PSet (ex% + 18, ey% + 7), 43 + PSet (ex% + 9, ey% + 8), 41 + PSet (ex% + 10, ey% + 8), 44 + PSet (ex% + 11, ey% + 8), 43 + PSet (ex% + 12, ey% + 8), 44 + PSet (ex% + 13, ey% + 8), 43 + PSet (ex% + 14, ey% + 8), 43 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 16, ey% + 8), 40 + PSet (ex% + 18, ey% + 8), 41 + PSet (ex% + 22, ey% + 8), 40 + PSet (ex% + 23, ey% + 8), 40 + PSet (ex% + 10, ey% + 9), 40 + PSet (ex% + 11, ey% + 9), 42 + PSet (ex% + 12, ey% + 9), 43 + PSet (ex% + 13, ey% + 9), 43 + PSet (ex% + 14, ey% + 9), 42 + PSet (ex% + 15, ey% + 9), 41 + PSet (ex% + 11, ey% + 10), 40 + PSet (ex% + 12, ey% + 10), 42 + PSet (ex% + 13, ey% + 10), 40 +End Sub + +Sub xxf7 + PSet (ex% + 14, ey% + -3), 39 + PSet (ex% + 15, ey% + -3), 41 + PSet (ex% + 18, ey% + -3), 41 + PSet (ex% + 11, ey% + -2), 41 + PSet (ex% + 13, ey% + -2), 41 + PSet (ex% + 14, ey% + -2), 42 + PSet (ex% + 16, ey% + -2), 42 + PSet (ex% + 17, ey% + -2), 41 + PSet (ex% + 18, ey% + -2), 42 + PSet (ex% + 19, ey% + -2), 40 + PSet (ex% + 21, ey% + -2), 40 + PSet (ex% + 25, ey% + -2), 41 + PSet (ex% + 4, ey% + -1), 43 + PSet (ex% + 9, ey% + -1), 41 + PSet (ex% + 10, ey% + -1), 42 + PSet (ex% + 11, ey% + -1), 42 + PSet (ex% + 12, ey% + -1), 41 + PSet (ex% + 14, ey% + -1), 40 + PSet (ex% + 15, ey% + -1), 43 + PSet (ex% + 16, ey% + -1), 43 + PSet (ex% + 17, ey% + -1), 43 + PSet (ex% + 18, ey% + -1), 42 + PSet (ex% + 19, ey% + -1), 41 + PSet (ex% + 21, ey% + -1), 41 + PSet (ex% + 22, ey% + -1), 40 + PSet (ex% + 5, ey% + 0), 41 + PSet (ex% + 6, ey% + 0), 40 + PSet (ex% + 7, ey% + 0), 42 + PSet (ex% + 8, ey% + 0), 42 + PSet (ex% + 9, ey% + 0), 41 + PSet (ex% + 10, ey% + 0), 42 + PSet (ex% + 11, ey% + 0), 43 + PSet (ex% + 12, ey% + 0), 42 + PSet (ex% + 13, ey% + 0), 41 + PSet (ex% + 14, ey% + 0), 43 + PSet (ex% + 15, ey% + 0), 42 + PSet (ex% + 16, ey% + 0), 44 + PSet (ex% + 17, ey% + 0), 42 + PSet (ex% + 19, ey% + 0), 40 + PSet (ex% + 20, ey% + 0), 42 + PSet (ex% + 22, ey% + 0), 43 + PSet (ex% + 23, ey% + 0), 42 + PSet (ex% + 3, ey% + 1), 41 + PSet (ex% + 4, ey% + 1), 43 + PSet (ex% + 5, ey% + 1), 42 + PSet (ex% + 6, ey% + 1), 43 + PSet (ex% + 7, ey% + 1), 42 + PSet (ex% + 8, ey% + 1), 43 + PSet (ex% + 9, ey% + 1), 42 + PSet (ex% + 10, ey% + 1), 41 + PSet (ex% + 11, ey% + 1), 40 + PSet (ex% + 14, ey% + 1), 40 + PSet (ex% + 15, ey% + 1), 43 + PSet (ex% + 16, ey% + 1), 41 + PSet (ex% + 20, ey% + 1), 42 + PSet (ex% + 21, ey% + 1), 41 + PSet (ex% + 22, ey% + 1), 40 + PSet (ex% + 1, ey% + 2), 41 + PSet (ex% + 2, ey% + 2), 42 + PSet (ex% + 3, ey% + 2), 42 + PSet (ex% + 6, ey% + 2), 41 + PSet (ex% + 7, ey% + 2), 42 + PSet (ex% + 8, ey% + 2), 41 + PSet (ex% + 14, ey% + 2), 42 + PSet (ex% + 15, ey% + 2), 41 + PSet (ex% + 20, ey% + 2), 42 + PSet (ex% + 21, ey% + 2), 44 + PSet (ex% + 0, ey% + 3), 41 + PSet (ex% + 1, ey% + 3), 43 + PSet (ex% + 2, ey% + 3), 43 + PSet (ex% + 8, ey% + 3), 42 + PSet (ex% + 9, ey% + 3), 41 + PSet (ex% + 13, ey% + 3), 41 + PSet (ex% + 14, ey% + 3), 42 + PSet (ex% + 15, ey% + 3), 43 + PSet (ex% + 16, ey% + 3), 42 + PSet (ex% + 17, ey% + 3), 41 + PSet (ex% + 19, ey% + 3), 41 + PSet (ex% + 20, ey% + 3), 44 + PSet (ex% + 21, ey% + 3), 40 + PSet (ex% + 22, ey% + 3), 42 + PSet (ex% + 2, ey% + 4), 41 + PSet (ex% + 3, ey% + 4), 42 + PSet (ex% + 5, ey% + 4), 42 + PSet (ex% + 6, ey% + 4), 41 + PSet (ex% + 7, ey% + 4), 42 + PSet (ex% + 8, ey% + 4), 42 + PSet (ex% + 9, ey% + 4), 42 + PSet (ex% + 10, ey% + 4), 41 + PSet (ex% + 12, ey% + 4), 42 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 43 + PSet (ex% + 15, ey% + 4), 41 + PSet (ex% + 16, ey% + 4), 42 + PSet (ex% + 17, ey% + 4), 42 + PSet (ex% + 18, ey% + 4), 42 + PSet (ex% + 19, ey% + 4), 44 + PSet (ex% + 20, ey% + 4), 41 + PSet (ex% + 3, ey% + 5), 42 + PSet (ex% + 4, ey% + 5), 43 + PSet (ex% + 6, ey% + 5), 41 + PSet (ex% + 8, ey% + 5), 42 + PSet (ex% + 9, ey% + 5), 43 + PSet (ex% + 10, ey% + 5), 42 + PSet (ex% + 11, ey% + 5), 41 + PSet (ex% + 12, ey% + 5), 42 + PSet (ex% + 13, ey% + 5), 43 + PSet (ex% + 14, ey% + 5), 43 + PSet (ex% + 16, ey% + 5), 40 + PSet (ex% + 18, ey% + 5), 43 + PSet (ex% + 19, ey% + 5), 41 + PSet (ex% + 9, ey% + 6), 41 + PSet (ex% + 11, ey% + 6), 42 + PSet (ex% + 12, ey% + 6), 41 + PSet (ex% + 13, ey% + 6), 43 + PSet (ex% + 14, ey% + 6), 42 + PSet (ex% + 15, ey% + 6), 42 + PSet (ex% + 16, ey% + 6), 42 + PSet (ex% + 18, ey% + 6), 41 + PSet (ex% + 19, ey% + 6), 42 + PSet (ex% + 10, ey% + 7), 41 + PSet (ex% + 11, ey% + 7), 43 + PSet (ex% + 12, ey% + 7), 42 + PSet (ex% + 13, ey% + 7), 42 + PSet (ex% + 14, ey% + 7), 44 + PSet (ex% + 15, ey% + 7), 42 + PSet (ex% + 16, ey% + 7), 43 + PSet (ex% + 17, ey% + 7), 42 + PSet (ex% + 18, ey% + 7), 43 + PSet (ex% + 24, ey% + 7), 40 + PSet (ex% + 9, ey% + 8), 41 + PSet (ex% + 10, ey% + 8), 44 + PSet (ex% + 11, ey% + 8), 43 + PSet (ex% + 12, ey% + 8), 44 + PSet (ex% + 13, ey% + 8), 43 + PSet (ex% + 14, ey% + 8), 43 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 16, ey% + 8), 40 + PSet (ex% + 18, ey% + 8), 41 + PSet (ex% + 10, ey% + 9), 40 + PSet (ex% + 11, ey% + 9), 42 + PSet (ex% + 12, ey% + 9), 43 + PSet (ex% + 13, ey% + 9), 43 + PSet (ex% + 14, ey% + 9), 42 + PSet (ex% + 15, ey% + 9), 41 + PSet (ex% + 11, ey% + 10), 40 + PSet (ex% + 12, ey% + 10), 42 + PSet (ex% + 13, ey% + 10), 40 +End Sub + +Sub xxf8 + PSet (ex% + 15, ey% + -3), 41 + PSet (ex% + 18, ey% + -3), 41 + PSet (ex% + 13, ey% + -2), 41 + PSet (ex% + 17, ey% + -2), 41 + PSet (ex% + 18, ey% + -2), 42 + PSet (ex% + 19, ey% + -2), 40 + PSet (ex% + 21, ey% + -2), 40 + PSet (ex% + 4, ey% + -1), 42 + PSet (ex% + 9, ey% + -1), 41 + PSet (ex% + 10, ey% + -1), 42 + PSet (ex% + 11, ey% + -1), 42 + PSet (ex% + 12, ey% + -1), 41 + PSet (ex% + 15, ey% + -1), 40 + PSet (ex% + 16, ey% + -1), 42 + PSet (ex% + 17, ey% + -1), 42 + PSet (ex% + 18, ey% + -1), 42 + PSet (ex% + 22, ey% + -1), 40 + PSet (ex% + 7, ey% + 0), 40 + PSet (ex% + 8, ey% + 0), 42 + PSet (ex% + 9, ey% + 0), 41 + PSet (ex% + 10, ey% + 0), 41 + PSet (ex% + 12, ey% + 0), 41 + PSet (ex% + 13, ey% + 0), 41 + PSet (ex% + 14, ey% + 0), 43 + PSet (ex% + 15, ey% + 0), 41 + PSet (ex% + 16, ey% + 0), 44 + PSet (ex% + 17, ey% + 0), 42 + PSet (ex% + 20, ey% + 0), 42 + PSet (ex% + 22, ey% + 0), 42 + PSet (ex% + 23, ey% + 0), 40 + PSet (ex% + 4, ey% + 1), 41 + PSet (ex% + 6, ey% + 1), 40 + PSet (ex% + 7, ey% + 1), 41 + PSet (ex% + 8, ey% + 1), 41 + PSet (ex% + 9, ey% + 1), 42 + PSet (ex% + 14, ey% + 1), 40 + PSet (ex% + 15, ey% + 1), 43 + PSet (ex% + 16, ey% + 1), 41 + PSet (ex% + 21, ey% + 1), 41 + PSet (ex% + 1, ey% + 2), 40 + PSet (ex% + 7, ey% + 2), 41 + PSet (ex% + 14, ey% + 2), 42 + PSet (ex% + 15, ey% + 2), 41 + PSet (ex% + 20, ey% + 2), 42 + PSet (ex% + 21, ey% + 2), 44 + PSet (ex% + 0, ey% + 3), 41 + PSet (ex% + 1, ey% + 3), 42 + PSet (ex% + 8, ey% + 3), 42 + PSet (ex% + 9, ey% + 3), 41 + PSet (ex% + 13, ey% + 3), 41 + PSet (ex% + 14, ey% + 3), 41 + PSet (ex% + 15, ey% + 3), 41 + PSet (ex% + 16, ey% + 3), 42 + PSet (ex% + 17, ey% + 3), 41 + PSet (ex% + 19, ey% + 3), 41 + PSet (ex% + 20, ey% + 3), 44 + PSet (ex% + 21, ey% + 3), 40 + PSet (ex% + 22, ey% + 3), 42 + PSet (ex% + 3, ey% + 4), 42 + PSet (ex% + 7, ey% + 4), 42 + PSet (ex% + 8, ey% + 4), 42 + PSet (ex% + 9, ey% + 4), 42 + PSet (ex% + 10, ey% + 4), 41 + PSet (ex% + 12, ey% + 4), 42 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 42 + PSet (ex% + 17, ey% + 4), 42 + PSet (ex% + 18, ey% + 4), 42 + PSet (ex% + 19, ey% + 4), 42 + PSet (ex% + 20, ey% + 4), 41 + PSet (ex% + 4, ey% + 5), 43 + PSet (ex% + 6, ey% + 5), 41 + PSet (ex% + 8, ey% + 5), 42 + PSet (ex% + 9, ey% + 5), 43 + PSet (ex% + 10, ey% + 5), 42 + PSet (ex% + 11, ey% + 5), 41 + PSet (ex% + 12, ey% + 5), 42 + PSet (ex% + 13, ey% + 5), 40 + PSet (ex% + 18, ey% + 5), 43 + PSet (ex% + 19, ey% + 5), 41 + PSet (ex% + 9, ey% + 6), 41 + PSet (ex% + 15, ey% + 6), 42 + PSet (ex% + 18, ey% + 6), 41 + PSet (ex% + 19, ey% + 6), 42 + PSet (ex% + 12, ey% + 7), 41 + PSet (ex% + 13, ey% + 7), 41 + PSet (ex% + 14, ey% + 7), 41 + PSet (ex% + 15, ey% + 7), 42 + PSet (ex% + 16, ey% + 7), 43 + PSet (ex% + 17, ey% + 7), 42 + PSet (ex% + 11, ey% + 8), 41 + PSet (ex% + 12, ey% + 8), 43 + PSet (ex% + 13, ey% + 8), 43 + PSet (ex% + 14, ey% + 8), 43 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 16, ey% + 8), 40 + PSet (ex% + 10, ey% + 9), 40 + PSet (ex% + 11, ey% + 9), 42 + PSet (ex% + 12, ey% + 9), 43 + PSet (ex% + 13, ey% + 9), 44 + PSet (ex% + 14, ey% + 9), 42 + PSet (ex% + 15, ey% + 9), 41 + PSet (ex% + 11, ey% + 10), 40 + PSet (ex% + 12, ey% + 10), 42 + PSet (ex% + 13, ey% + 10), 40 +End Sub + +Sub xxf9 + PSet (ex% + 16, ey% + -3), 40 + PSet (ex% + 13, ey% + -2), 41 + PSet (ex% + 18, ey% + -2), 42 + PSet (ex% + 9, ey% + -1), 41 + PSet (ex% + 10, ey% + -1), 42 + PSet (ex% + 11, ey% + -1), 42 + PSet (ex% + 12, ey% + -1), 41 + PSet (ex% + 15, ey% + -1), 40 + PSet (ex% + 16, ey% + -1), 42 + PSet (ex% + 17, ey% + -1), 42 + PSet (ex% + 18, ey% + -1), 42 + PSet (ex% + 8, ey% + 0), 42 + PSet (ex% + 12, ey% + 0), 41 + PSet (ex% + 13, ey% + 0), 41 + PSet (ex% + 14, ey% + 0), 43 + PSet (ex% + 15, ey% + 0), 41 + PSet (ex% + 16, ey% + 0), 44 + PSet (ex% + 17, ey% + 0), 42 + PSet (ex% + 22, ey% + 0), 42 + PSet (ex% + 8, ey% + 1), 40 + PSet (ex% + 9, ey% + 1), 42 + PSet (ex% + 14, ey% + 1), 40 + PSet (ex% + 15, ey% + 1), 43 + PSet (ex% + 16, ey% + 1), 41 + PSet (ex% + 14, ey% + 2), 42 + PSet (ex% + 15, ey% + 2), 41 + PSet (ex% + 20, ey% + 2), 40 + PSet (ex% + 21, ey% + 2), 41 + PSet (ex% + 13, ey% + 3), 41 + PSet (ex% + 14, ey% + 3), 41 + PSet (ex% + 15, ey% + 3), 42 + PSet (ex% + 16, ey% + 3), 40 + PSet (ex% + 19, ey% + 3), 41 + PSet (ex% + 20, ey% + 3), 42 + PSet (ex% + 21, ey% + 3), 40 + PSet (ex% + 22, ey% + 3), 42 + PSet (ex% + 7, ey% + 4), 41 + PSet (ex% + 8, ey% + 4), 40 + PSet (ex% + 12, ey% + 4), 42 + PSet (ex% + 13, ey% + 4), 42 + PSet (ex% + 14, ey% + 4), 40 + PSet (ex% + 17, ey% + 4), 42 + PSet (ex% + 18, ey% + 4), 42 + PSet (ex% + 19, ey% + 4), 42 + PSet (ex% + 20, ey% + 4), 41 + PSet (ex% + 8, ey% + 5), 41 + PSet (ex% + 9, ey% + 5), 42 + PSet (ex% + 10, ey% + 5), 42 + PSet (ex% + 11, ey% + 5), 41 + PSet (ex% + 12, ey% + 5), 41 + PSet (ex% + 18, ey% + 5), 41 + PSet (ex% + 19, ey% + 5), 41 + PSet (ex% + 9, ey% + 6), 41 + PSet (ex% + 15, ey% + 6), 42 + PSet (ex% + 18, ey% + 6), 41 + PSet (ex% + 19, ey% + 6), 42 + PSet (ex% + 12, ey% + 7), 41 + PSet (ex% + 14, ey% + 7), 41 + PSet (ex% + 15, ey% + 7), 42 + PSet (ex% + 16, ey% + 7), 43 + PSet (ex% + 17, ey% + 7), 42 + PSet (ex% + 11, ey% + 8), 41 + PSet (ex% + 12, ey% + 8), 42 + PSet (ex% + 13, ey% + 8), 42 + PSet (ex% + 14, ey% + 8), 43 + PSet (ex% + 15, ey% + 8), 41 + PSet (ex% + 11, ey% + 9), 40 + PSet (ex% + 12, ey% + 9), 43 + PSet (ex% + 13, ey% + 9), 41 + PSet (ex% + 14, ey% + 9), 42 + PSet (ex% + 12, ey% + 10), 40 +End Sub + +Sub z + PSet Step(3, -4), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-1, 1), cf% + + PSet Step(-1, 1), cf% + + PSet Step(-1, 1), cf% + + PSet Step(-1, 1), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% +End Sub + +Sub z0 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% +End Sub + +Sub z1 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% +End Sub + +Sub z2 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% +End Sub + +Sub z3 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% +End Sub + +Sub z4 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% +End Sub + +Sub z5 + PSet Step(1, -4), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% +End Sub + +Sub z6 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% +End Sub + +Sub z7 + PSet Step(1, -4), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% +End Sub + +Sub z8 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% +End Sub + +Sub z9 + PSet Step(1, -4), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cb% + PSet Step(1, 0), cf% + + PSet Step(-4, 1), cb% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cf% + PSet Step(1, 0), cb% +End Sub + +'Print number on the screen +Sub prnumber (num As Integer, stl As Integer) + Dim As Integer tsd, hnd, znr, enr + + tsd% = Int(Abs(num%) / 1000) + hnd% = Int((Abs(num%) - tsd% * 1000) / 100) + znr% = Int((Abs(num%) - tsd% * 1000 - hnd% * 100) / 10) + enr% = Abs(num%) - tsd% * 1000 - hnd% * 100 - znr% * 10 + + If tsd% = 0 And hnd% = 0 And znr% = 0 Then znr% = -1 + If tsd% = 0 And hnd% = 0 Then hnd% = -1 + If tsd% = 0 Then tsd% = -1 + + If tsd% <= 0 And hnd% <= 0 And znr% <= 0 And num% < 0 Then znr% = -2 + If tsd% <= 0 And hnd% <= 0 And znr% >= 0 And num% < 0 Then hnd% = -2 + If tsd% <= 0 And hnd% >= 0 And znr% >= 0 And num% < 0 Then tsd% = -2 + If tsd% >= 0 And hnd% >= 0 And znr% >= 0 And num% < 0 Then minus Else empty2 + + If stl% = 4 Then + Select Case tsd% + Case -2: minus + Case -1: empty2 + Case 0: z0 + Case 1: z1 + Case 2: z2 + Case 3: z3 + Case 4: z4 + Case 5: z5 + Case 6: z6 + Case 7: z7 + Case 8: z8 + Case 9: z9 + End Select + End If + + If stl% >= 3 Then + Select Case hnd% + Case -2: minus + Case -1: empty2 + Case 0: z0 + Case 1: z1 + Case 2: z2 + Case 3: z3 + Case 4: z4 + Case 5: z5 + Case 6: z6 + Case 7: z7 + Case 8: z8 + Case 9: z9 + End Select + End If + + If stl% >= 2 Then + Select Case znr% + Case -2: minus + Case -1: empty2 + Case 0: z0 + Case 1: z1 + Case 2: z2 + Case 3: z3 + Case 4: z4 + Case 5: z5 + Case 6: z6 + Case 7: z7 + Case 8: z8 + Case 9: z9 + End Select + End If + + Select Case enr% + Case 0: z0 + Case 1: z1 + Case 2: z2 + Case 3: z3 + Case 4: z4 + Case 5: z5 + Case 6: z6 + Case 7: z7 + Case 8: z8 + Case 9: z9 + End Select + +End Sub + diff --git a/samples/rattler/img/screenshot.png b/samples/rattler/img/screenshot.png new file mode 100644 index 00000000..440128ff Binary files /dev/null and b/samples/rattler/img/screenshot.png differ diff --git a/samples/rattler/index.md b/samples/rattler/index.md new file mode 100644 index 00000000..921e59fb --- /dev/null +++ b/samples/rattler/index.md @@ -0,0 +1,22 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: RATTLER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Bob Seguin](../bob-seguin.md) + +### Description + +```text +Snake clone by Bob Seguin. +``` + +### File(s) + +* [rattler.bas](src/rattler.bas) +* [rattler.zip](src/rattler.zip) + +🔗 [game](../game.md), [snake](../snake.md) diff --git a/samples/rattler/src/rattler.bas b/samples/rattler/src/rattler.bas new file mode 100644 index 00000000..2923b8d4 --- /dev/null +++ b/samples/rattler/src/rattler.bas @@ -0,0 +1,1550 @@ +'***************************************************************************** +' +'--------------------------- R A T T L E R . B A S --------------------------- +' +'---------------- Copyright (C) 2003 by Bob Seguin (Freeware) ---------------- +' +'------------------------ Email: BOBSEG@sympatico.ca ------------------------- +' +'--------------------- RATTLER is a graphical version of --------------------- +'--------------------- the classic QBasic game, NIBBLES ---------------------- +' +'***************************************************************************** + +$Resize:Smooth + +DefInt A-Z + +Dim Shared SnakePIT(1 To 32, 1 To 24) +Dim Shared WipeBOX(29, 21) + +ReDim Shared SpriteBOX(8000) +ReDim Shared NumBOX(400) +ReDim Shared TTBox(480) +ReDim Shared BigBOX(32000) + +'The following constants are used to determine sprite array indexes +Const Head = 0 +Const Neck = 500 +Const Shoulders = 1000 +Const Body = 1500 +Const Tail = 2000 +Const TailEND = 2500 +Const Rattle = 3000 + +Const Mouse = 6000 +Const Frog = 6500 +Const Stone = 7000 +Const Blank = 7500 + +Const TURN = 3000 + +Const Left = 0 +Const Up = 125 +Const Right = 250 +Const Down = 375 + +Const DL = 0 +Const DR = 125 +Const UR = 250 +Const UL = 375 +Const RD = 375 +Const LD = 250 +Const LU = 125 +Const RU = 0 + +Type DiamondBACK + Row As Integer + Col As Integer + BodyPART As Integer + TURN As Integer + WhichWAY As Integer + RattleDIR As Integer +End Type +Dim Shared Rattler(72) As DiamondBACK + +Type ScoreTYPE + PlayerNAME As String * 20 + PlayDATE As String * 10 + PlayerSCORE As Long +End Type +Dim Shared ScoreDATA(10) As ScoreTYPE + +Dim Shared SnakeLENGTH +Dim Shared SetSPEED +Dim Shared Speed +Dim Shared SpeedLEVEL +Dim Shared Level +Dim Shared Lives +Dim Shared Score +Dim Shared CrittersLEFT + +Open "rattler.top" For Append As #1 +Close #1 + +Open "rattler.top" For Input As #1 +Do While Not EOF(1) + Input #1, ScoreDATA(n).PlayerNAME + Input #1, ScoreDATA(n).PlayDATE + Input #1, ScoreDATA(n).PlayerSCORE + n = n + 1 +Loop +Close #1 + +Randomize Timer + +Screen 12 +_FullScreen _SquarePixels , _Smooth + +GoSub DrawSPRITES +DrawSCREEN + +Intro + +Do + PlayGAME +Loop + +End + +'------------------------- SUBROUTINE SECTION BEGINS ------------------------- + +DrawSPRITES: +'Creates images from compressed data + +'Set all attributes to black (REM out to view the process) +For n = 1 To 15 + Out &H3C8, n + Out &H3C9, 0 + Out &H3C9, 0 + Out &H3C9, 0 +Next n + +Out &H3C8, 9 +Out &H3C9, 52 +Out &H3C9, 42 +Out &H3C9, 32 +Locate 12, 32: Color 9 +Print "ONE MOMENT PLEASE..." + +MaxWIDTH = 19 +MaxDEPTH = 279 +x = 0: y = 0 + +Do + Read Count, Colr + For Reps = 1 To Count + PSet (x, y), Colr + x = x + 1 + If x > MaxWIDTH Then + x = 0 + y = y + 1 + End If + Next Reps +Loop Until y > MaxDEPTH + +'Create directional sets +Index = 0 +For y = 0 To 260 Step 20 + Get (0, y)-(19, y + 19), SpriteBOX(Index) + GoSub Poses + Index = Index + 500 +Next y +Cls +Palette 9, 0 +'Create stone block and erasing sprite(s) +Line (0, 0)-(19, 19), 6, BF +For Reps = 1 To 240 + x = Fix(Rnd * 20) + 1 + y = Fix(Rnd * 20) + 1 + PSet (x, y), 7 + PSet (x + 1, y + 1), 15 +Next Reps +Line (0, 0)-(19, 19), 6, B +Line (1, 1)-(18, 18), 13, B +Line (1, 1)-(1, 18), 15 +Line (1, 1)-(18, 1), 15 +Get (0, 0)-(19, 19), SpriteBOX(Stone) 'stone tile +Line (0, 0)-(19, 19), 8, BF +Get (0, 0)-(19, 19), SpriteBOX(Blank + Left) 'erasing tile +Get (0, 0)-(19, 19), SpriteBOX(Blank + Up) 'erasing tile +Get (0, 0)-(19, 19), SpriteBOX(Blank + Right) 'erasing tile +Get (0, 0)-(19, 19), SpriteBOX(Blank + Down) 'erasing tile +Cls +Color 9 +Locate 9, 31 +Print "RATTLER TOP-TEN LIST" +Get (240, 130)-(398, 140), TTBox() +Locate 9, 31 +Print Space$(20) + +'GET numbers +For n = 0 To 9 + Locate 10, 10 + If n = 0 Then Print "O" Else Print LTrim$(Str$(n)) + For x = 72 To 80 + For y = 144 To 160 + If Point(x, y) = 0 Then PSet (x, y), 15 Else PSet (x, y), 4 + Next y + Next x + Get (72, 144)-(79, 156), NumBOX(NumDEX) + NumDEX = NumDEX + 40 +Next n +Line (72, 144)-(80, 160), 0, BF +Return + +Poses: +'Draws/GETs the other 3 directional poses from each sprite +For i = Index To Index + 250 Step 125 + Put (100, 100), SpriteBOX(i), PSet + For Px = 100 To 119 + For Py = 100 To 119 + PSet (219 - Py, Px - 20), Point(Px, Py) + Next Py + Next Px + Get (100, 80)-(119, 99), SpriteBOX(i + 125) +Next i +Return + +SpriteVALUES: +Data 47,8,2,12,2,0,16,8,3,5,1,12,1,13,1,12,1,13,1,12,8,8,1,0 +Data 1,12,1,15,1,8,1,15,3,5,1,14,3,1,1,14,1,13,5,8,2,5,1,12 +Data 1,5,4,12,3,3,1,5,1,12,1,3,1,12,1,14,1,13,2,8,1,3,14,5 +Data 1,3,1,5,1,1,1,13,1,3,1,5,1,12,1,5,1,12,1,5,1,12,1,5 +Data 1,12,1,5,1,12,3,5,1,12,1,5,1,12,2,3,1,1,22,5,1,12,1,5 +Data 1,12,1,3,1,12,1,3,1,12,1,3,1,12,1,3,1,12,1,15,1,12,1,3 +Data 1,12,1,3,1,12,1,3,2,5,1,12,1,5,1,12,1,3,1,12,1,3,1,12 +Data 1,3,1,12,1,3,1,12,1,15,1,12,1,3,1,12,1,3,1,12,1,3,17,5 +Data 1,3,2,5,1,3,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5 +Data 1,12,3,5,1,12,1,5,1,12,2,3,1,1,1,8,1,3,14,5,1,3,1,14 +Data 1,1,1,13,2,8,2,5,1,12,1,5,4,12,2,3,1,1,1,5,1,12,1,1 +Data 1,12,1,14,1,13,4,8,1,0,1,12,1,15,1,8,1,15,3,5,2,14,2,1 +Data 1,14,1,13,10,8,2,5,1,14,1,12,1,13,1,12,1,13,1,12,12,8,2,12 +Data 2,0,169,8,1,13,1,12,1,13,1,1,1,13,1,12,1,13,1,1,1,13,1,12 +Data 1,13,1,12,1,13,1,1,1,13,1,12,1,13,1,1,1,13,1,12,1,1,1,14 +Data 1,1,1,14,1,12,1,14,1,12,1,14,1,1,1,14,1,1,1,14,1,1,1,14 +Data 1,12,1,14,1,12,1,14,1,1,1,14,2,3,1,5,1,12,1,5,1,12,1,5 +Data 1,12,1,5,3,3,1,5,1,12,1,5,1,12,1,5,1,12,1,5,3,3,1,12 +Data 1,5,1,12,1,5,1,12,1,5,1,12,1,5,2,3,1,12,1,5,1,12,1,5 +Data 1,12,1,5,1,12,1,5,1,3,1,5,1,12,1,5,1,12,1,5,1,12,1,5 +Data 1,12,1,5,1,3,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5 +Data 2,3,1,5,1,12,1,5,1,12,1,5,1,12,1,5,3,3,1,5,1,12,1,5 +Data 1,12,1,5,1,12,1,5,1,3,1,1,1,14,1,1,1,14,1,12,1,14,1,12 +Data 1,14,1,1,1,14,1,1,1,14,1,1,1,14,1,12,1,14,1,12,1,14,1,1 +Data 1,14,1,13,1,12,1,13,1,1,1,13,1,12,1,13,1,1,1,13,1,12,1,13 +Data 1,12,1,13,1,1,1,13,1,12,1,13,1,1,1,13,1,12,220,8,1,12,1,13 +Data 1,12,1,13,1,12,1,13,1,12,1,13,1,12,1,13,1,12,1,13,1,12,1,13 +Data 1,12,1,13,1,12,1,13,1,12,1,13,1,14,1,12,1,14,1,1,1,14,1,12 +Data 1,14,1,1,1,14,1,12,1,14,1,12,1,14,1,1,1,14,1,12,1,14,1,1 +Data 1,14,2,12,1,14,1,3,1,14,1,12,1,14,1,12,1,14,1,3,1,14,1,12 +Data 1,14,1,3,1,14,1,12,1,14,1,12,1,14,1,3,1,14,1,5,1,3,1,5 +Data 1,12,1,5,1,12,1,5,1,12,1,5,1,3,1,5,1,3,1,5,1,12,1,5 +Data 1,12,1,5,1,12,1,5,1,3,1,15,1,5,1,12,1,5,1,12,1,5,1,12 +Data 1,5,1,12,1,5,1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12 +Data 1,5,1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,15 +Data 1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,2,5,1,3,1,5,1,12 +Data 1,5,1,12,1,5,1,12,1,5,1,3,1,5,1,3,1,5,1,12,1,5,1,12 +Data 1,5,1,12,1,5,1,3,1,12,1,14,1,3,1,14,1,12,1,14,1,12,1,14 +Data 1,3,1,14,1,12,1,14,1,3,1,14,1,12,1,14,1,12,1,14,1,3,2,14 +Data 1,12,1,14,1,1,1,14,1,12,1,14,1,1,1,14,1,12,1,14,1,12,1,14 +Data 1,1,1,14,1,12,1,14,1,1,1,14,2,12,1,13,1,12,1,13,1,12,1,13 +Data 1,12,1,13,1,12,1,13,1,12,1,13,1,12,1,13,1,12,1,13,1,12,1,13 +Data 1,12,1,13,180,8,1,13,1,12,1,13,1,12,1,13,1,1,1,13,1,12,1,13 +Data 1,12,1,13,1,12,1,13,1,12,1,13,1,1,1,13,1,12,1,13,2,12,1,14 +Data 1,12,1,14,1,1,1,5,1,1,1,14,1,12,1,14,1,12,1,14,1,12,1,14 +Data 1,1,1,5,1,1,1,14,1,12,2,14,1,12,1,14,1,1,1,14,1,12,1,14 +Data 1,1,1,14,1,12,1,14,1,12,1,14,1,1,1,14,1,12,1,14,1,1,1,14 +Data 2,12,1,5,1,3,1,5,1,12,1,5,1,12,1,5,1,3,1,5,1,12,1,5 +Data 1,3,1,5,1,12,1,5,1,12,1,5,1,3,2,5,1,3,1,5,1,12,1,5 +Data 1,12,1,5,1,12,1,5,1,3,1,5,1,3,1,5,1,12,1,5,1,12,1,5 +Data 1,12,1,5,1,3,1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12 +Data 1,5,1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,15 +Data 1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,15,1,5,1,12 +Data 1,5,1,12,1,5,1,12,1,5,1,12,2,5,1,3,1,5,1,12,1,5,1,12 +Data 1,5,1,12,1,5,1,3,1,5,1,3,1,5,1,12,1,5,1,12,1,5,1,12 +Data 1,5,1,3,1,12,1,5,1,3,1,5,1,12,1,5,1,12,1,5,1,3,1,5 +Data 1,12,1,5,1,3,1,5,1,12,1,5,1,12,1,5,1,3,1,5,1,14,1,12 +Data 1,14,1,1,1,14,1,12,1,14,1,1,1,14,1,12,1,14,1,12,1,14,1,1 +Data 1,14,1,12,1,14,1,1,1,14,2,12,1,14,1,12,1,14,1,1,1,14,1,1 +Data 1,14,1,12,1,14,1,12,1,14,1,12,1,14,1,1,1,14,1,1,1,14,1,12 +Data 1,14,1,13,1,12,1,13,1,12,1,13,1,1,1,13,1,12,1,13,1,12,1,13 +Data 1,12,1,13,1,12,1,13,1,1,1,13,1,12,1,13,1,12,220,8,1,12,1,13 +Data 1,1,1,13,1,12,1,13,1,12,1,13,1,1,1,13,1,12,1,13,1,1,1,13 +Data 1,12,1,13,1,12,1,13,1,1,1,13,1,14,1,1,1,14,1,12,1,14,1,12 +Data 1,14,1,12,1,14,1,1,1,14,1,1,1,14,1,12,1,14,1,12,1,14,1,12 +Data 1,14,1,1,1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5 +Data 1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,15,1,5 +Data 1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,15,1,5,1,12,1,5 +Data 1,12,1,5,1,12,1,5,1,12,1,5,1,14,1,1,1,14,1,12,1,14,1,12 +Data 1,14,1,12,1,14,1,3,1,14,1,3,1,14,1,12,1,14,1,12,1,14,1,12 +Data 1,14,1,1,1,12,1,13,1,1,1,13,1,12,1,13,1,12,1,13,1,1,1,13 +Data 1,12,1,13,1,1,1,13,1,12,1,13,1,12,1,13,1,1,1,13,300,8,1,12 +Data 1,13,1,12,1,13,1,3,1,13,1,3,1,13,1,3,1,13,1,12,1,13,1,12 +Data 1,13,1,3,1,13,1,3,1,13,1,3,1,13,1,5,1,12,1,5,1,12,1,5 +Data 1,3,1,5,1,12,2,3,1,5,1,12,1,5,1,12,1,5,1,3,1,5,1,12 +Data 2,3,1,5,1,12,1,5,1,12,1,5,1,3,1,5,1,12,2,3,1,5,1,12 +Data 1,5,1,12,1,5,1,3,1,5,1,12,2,3,1,12,1,13,1,12,1,13,1,3 +Data 1,13,1,3,1,13,1,3,1,13,1,12,1,13,1,12,1,13,1,3,1,13,1,3 +Data 1,13,1,3,1,13,286,8,2,13,1,8,2,13,1,8,2,13,1,8,2,13,8,8 +Data 1,5,2,1,1,14,2,1,1,14,2,1,1,14,2,1,1,14,1,13,1,8,1,13 +Data 1,3,1,13,1,3,1,13,1,1,2,3,1,14,2,3,1,14,2,3,1,14,2,3 +Data 1,14,1,3,1,13,1,3,1,5,1,12,5,3,1,5,2,3,1,5,2,3,1,5 +Data 2,3,1,5,3,3,1,5,1,12,5,3,1,5,2,3,1,5,2,3,1,5,2,3 +Data 1,5,2,3,1,13,1,3,1,13,1,3,1,13,1,1,2,3,1,14,2,3,1,14 +Data 2,3,1,14,2,3,1,14,1,3,1,13,5,8,1,5,2,1,1,12,2,1,1,12 +Data 2,1,1,12,2,1,1,14,1,13,7,8,2,13,1,8,2,13,1,8,2,13,1,8 +Data 2,13,129,8,1,12,1,5,1,3,2,5,1,3,1,5,1,12,12,8,1,13,1,1 +Data 1,5,2,12,1,5,1,1,1,13,12,8,1,12,1,5,1,12,2,5,1,12,1,5 +Data 1,12,12,8,1,13,1,12,1,5,2,12,1,5,1,12,1,13,12,8,1,12,1,5 +Data 1,12,2,5,1,12,1,5,1,12,11,8,1,13,1,5,1,3,1,5,2,12,1,5 +Data 1,1,1,13,6,8,1,13,1,12,1,13,1,12,1,13,1,1,1,5,1,15,1,12 +Data 2,5,1,3,1,5,1,12,6,8,1,1,1,5,1,1,1,5,1,12,1,5,1,12 +Data 1,5,1,15,1,5,1,3,1,5,1,1,1,13,6,8,2,3,1,5,1,12,1,5 +Data 1,12,1,5,1,12,1,5,1,3,2,5,1,13,7,8,1,12,1,15,1,12,1,5 +Data 1,12,1,5,1,12,1,5,1,12,2,5,1,1,1,12,7,8,1,5,1,15,1,12 +Data 1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,1,1,13,8,8,2,3,1,5 +Data 1,12,1,5,1,12,1,5,1,12,1,5,1,3,1,12,9,8,1,1,1,5,1,1 +Data 1,5,1,12,1,5,1,12,1,5,1,1,1,13,10,8,1,13,1,12,1,13,1,12 +Data 1,13,1,12,1,13,1,12,137,8,1,13,1,12,1,14,1,3,2,5,1,3,1,14 +Data 1,12,1,13,10,8,1,12,1,14,1,3,1,5,2,12,1,5,1,3,1,14,1,12 +Data 10,8,1,13,1,1,1,5,1,12,2,5,1,12,1,5,1,1,1,13,10,8,1,12 +Data 1,3,1,12,1,5,2,12,1,5,1,12,1,5,1,12,9,8,1,13,1,14,1,3 +Data 2,12,2,5,1,12,1,5,1,14,1,13,5,8,1,12,1,13,1,12,1,13,1,12 +Data 1,5,1,3,1,5,1,12,1,5,1,12,2,5,1,1,1,12,5,8,1,14,1,12 +Data 1,14,1,1,1,3,1,12,1,5,1,15,1,5,1,12,1,5,1,12,1,3,1,14 +Data 1,13,5,8,1,12,1,14,1,1,1,5,1,12,2,3,1,5,1,15,2,5,1,3 +Data 1,14,1,13,6,8,1,5,1,3,1,5,1,12,1,5,1,12,1,5,1,12,1,5 +Data 2,3,1,14,2,12,6,8,1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,5 +Data 1,3,1,12,1,14,1,12,1,13,7,8,1,15,1,5,1,12,1,5,1,12,1,5 +Data 1,12,1,5,1,3,1,14,1,12,1,13,1,12,7,8,1,5,1,3,1,5,1,12 +Data 1,5,1,12,1,5,1,12,2,1,1,13,1,12,8,8,1,12,1,14,1,1,1,14 +Data 1,12,1,14,1,12,1,14,1,1,1,13,1,12,9,8,1,14,1,12,1,14,1,1 +Data 1,14,1,12,1,14,1,13,1,12,11,8,1,12,1,13,1,12,1,13,1,12,1,13 +Data 1,12,117,8,1,13,1,12,1,5,1,3,1,5,2,12,1,5,1,3,1,14,1,12 +Data 1,13,8,8,1,12,1,14,1,3,1,5,1,12,2,5,1,12,1,5,1,3,1,14 +Data 1,12,8,8,1,13,2,3,1,12,1,5,2,12,1,5,1,12,1,5,1,3,1,13 +Data 7,8,1,13,1,14,1,3,1,12,1,5,1,12,2,5,1,12,1,5,1,12,1,5 +Data 1,3,4,8,1,12,1,13,1,12,1,14,1,12,2,3,1,12,1,5,2,12,1,5 +Data 1,12,1,14,1,3,1,13,4,8,1,14,1,12,3,3,1,12,1,3,1,5,1,12 +Data 2,5,1,12,1,5,1,3,1,14,1,12,4,8,1,12,1,5,1,3,1,14,1,12 +Data 4,3,2,12,1,5,1,3,1,5,1,12,1,13,4,8,1,14,1,3,1,5,1,12 +Data 1,5,1,12,1,5,1,12,4,3,1,5,1,12,1,14,1,12,4,8,2,3,1,12 +Data 1,5,1,12,1,5,1,12,1,5,1,12,1,3,3,12,1,14,1,12,5,8,1,5 +Data 1,3,1,5,1,12,1,5,2,12,2,5,1,3,1,12,2,14,1,12,1,13,5,8 +Data 1,5,1,3,1,5,1,12,1,5,1,12,1,5,1,12,1,14,1,3,1,14,2,12 +Data 1,14,6,8,1,3,1,5,1,3,1,5,1,12,1,5,1,12,1,14,1,12,1,3 +Data 1,12,2,14,1,12,6,8,1,5,1,12,1,5,1,3,1,14,1,12,1,14,1,12 +Data 1,14,1,3,1,14,1,12,1,13,7,8,1,12,1,14,1,12,1,5,3,3,1,5 +Data 1,3,1,5,1,12,1,13,8,8,1,14,1,12,1,14,1,12,1,14,1,12,1,14 +Data 1,12,1,13,1,12,1,0,9,8,1,12,1,13,1,12,1,13,1,12,1,13,1,12 +Data 1,13,1,0,98,8,1,13,1,3,2,5,1,3,1,13,14,8,1,3,1,14,2,12 +Data 1,5,1,3,14,8,1,13,1,12,2,5,1,12,1,13,14,8,1,12,1,14,2,12 +Data 1,14,1,12,14,8,1,13,1,12,2,5,1,12,1,13,14,8,1,3,1,14,2,12 +Data 1,14,1,3,13,8,1,13,1,14,1,12,2,5,1,12,1,5,7,8,1,12,1,13 +Data 1,3,1,13,1,12,1,3,1,12,1,15,1,12,1,5,1,12,1,3,1,13,7,8 +Data 1,14,1,3,1,14,1,12,1,14,1,12,1,3,1,12,1,15,1,12,1,3,1,5 +Data 8,8,1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12,1,5,1,12 +Data 1,13,8,8,1,15,1,5,1,12,1,5,1,12,1,5,1,12,1,3,1,12,1,14 +Data 1,13,9,8,1,14,1,3,1,14,1,12,1,14,1,12,1,14,1,12,1,13,1,3 +Data 10,8,1,12,1,13,1,3,1,13,1,12,1,3,1,12,1,13,160,8,1,1,2,3 +Data 1,1,16,8,1,1,2,3,1,1,16,8,1,13,2,12,1,13,16,8,1,3,2,5 +Data 1,3,16,8,1,13,2,3,1,13,16,8,1,3,2,5,1,3,15,8,1,13,1,5 +Data 1,15,1,12,1,13,14,8,1,13,1,5,1,12,2,5,1,0,8,8,1,12,1,13 +Data 1,12,1,13,1,3,1,13,3,3,2,12,9,8,1,3,1,12,1,3,1,12,1,3 +Data 1,15,1,5,1,12,2,3,1,0,9,8,1,5,1,12,1,5,1,12,1,5,1,15 +Data 1,5,1,12,1,3,11,8,1,12,1,13,1,12,1,13,1,3,1,13,1,3,1,0 +Data 257,8,2,6,3,8,2,6,1,7,7,8,1,13,1,8,1,13,1,8,3,6,1,7 +Data 3,8,2,7,1,13,7,8,1,6,2,8,2,6,2,7,1,8,1,0,3,6,1,7 +Data 8,8,2,7,1,15,2,7,1,8,1,0,5,6,1,7,6,8,2,7,1,8,1,15 +Data 2,6,1,7,7,6,1,7,4,8,1,6,4,7,2,6,1,7,7,6,1,7,2,6 +Data 2,8,1,6,4,7,2,6,1,7,7,6,1,7,1,6,1,8,1,6,2,8,2,7 +Data 1,8,1,15,2,6,1,7,7,6,1,7,3,8,1,6,2,8,2,7,1,15,2,7 +Data 1,8,1,0,5,6,1,7,4,8,1,6,1,8,1,6,2,8,2,6,2,7,1,8 +Data 1,0,3,6,1,7,4,8,1,6,1,8,1,13,1,8,1,13,1,8,3,6,1,7 +Data 3,8,2,7,1,13,3,8,1,13,7,8,2,6,3,8,2,6,1,7,5,8,1,13 +Data 138,8,1,10,8,8,1,10,7,8,1,2,1,8,1,10,8,8,1,10,2,2,5,8 +Data 2,11,1,2,1,8,1,2,10,8,1,2,2,8,1,10,2,2,1,8,1,2,9,8 +Data 1,10,1,2,1,8,1,2,1,8,4,2,10,8,1,10,1,15,2,2,1,11,2,2 +Data 2,11,2,2,8,8,1,10,1,8,1,15,1,2,2,11,2,2,2,11,3,2,6,8 +Data 1,10,6,2,1,11,3,2,1,11,2,2,6,8,1,10,6,2,1,11,3,2,1,11 +Data 2,2,7,8,1,10,1,8,1,15,1,2,2,11,2,2,2,11,3,2,8,8,1,10 +Data 1,15,2,2,1,11,2,2,2,11,2,2,10,8,1,10,1,2,1,8,1,2,1,8 +Data 4,2,14,8,1,2,2,8,1,10,2,2,1,8,1,2,9,8,1,10,2,2,5,8,2 +Data 11,1,2,1,8,1,2,8,8,1,10,7,8,1,2,1,8,1,10,20,8,1,10,42,8 + +PaletteVALUES: +Data 18,18,18,50,44,36,0,42,0,56,50,42 +Data 63,0,0,51,43,30,48,48,52,42,42,42 +Data 0,14,0,54,24,63,21,63,21,0,30,0 +Data 34,22,21,32,32,32,45,37,24,63,63,63 + +Sub DrawSCREEN + + For Col = 1 To 32 + PutSPRITE Col, 1, Stone + PutSPRITE Col, 24, Stone + Next Col + For Row = 1 To 24 + PutSPRITE 1, Row, Stone + PutSPRITE 32, Row, Stone + Next Row + + Color 4 + Locate 3, 5: Print "LIVES:" + Locate 3, 34: Print "R A T T L E R" + Locate 3, 65: Print "SCORE:" + For x = 254 To 376 + For y = 32 To 45 + PSet (x + 4, y - 30), 15 + Next y + Next x + For x = 254 To 376 + For y = 32 To 45 + If Point(x, y) = 4 Then + PSet (x + 6, y - 29), 0 + PSet (x + 5, y - 30), 5 + End If + PSet (x, y), 0 + Next y + Next x + Line (258, 1)-(378, 1), 0 + Line (258, 1)-(258, 15), 0 + For x = 26 To 99 + For y = 32 To 45 + PSet (x + 4, y - 30), 15 + Next y + Next x + For x = 26 To 99 + For y = 32 To 45 + If Point(x, y) = 4 Then PSet (x + 6, y - 30), 0 + PSet (x, y), 0 + Next y + Next x + Line (28, 1)-(103, 1), 0 + Line (28, 1)-(28, 15), 0 + For x = 504 To 607 + For y = 32 To 45 + If Point(x, y) = 4 Then + PSet (x + 4, y - 30), 0 + Else + PSet (x + 4, y - 30), 15 + End If + PSet (x, y), 0 + Next y + Next x + Line (508, 1)-(611, 1), 0 + Line (508, 1)-(508, 15), 0 + Locate 28, 5: Print "LEVEL:" + For x = 28 To 98 + For y = 432 To 445 + If Point(x, y) = 4 Then + PSet (x, y + 32), 0 + Else + PSet (x, y + 32), 15 + End If + PSet (x, y), 0 + Next y + Next x + Line (28, 463)-(98, 463), 0 + Line (28, 463)-(28, 476), 0 + Locate 28, 70: Print "SPEED:" + For x = 548 To 612 + For y = 432 To 445 + If Point(x, y) = 4 Then + PSet (x, y + 32), 0 + Else + PSet (x, y + 32), 15 + End If + PSet (x, y), 0 + Next y + Next x + Line (548, 463)-(612, 463), 0 + Line (548, 463)-(548, 476), 0 + + Line (267, 463)-(371, 476), 15, BF + Line (267, 463)-(371, 463), 0 + Line (267, 463)-(267, 476), 0 + Line (20, 20)-(619, 459), 8, BF + +End Sub + +Function EndGAME + + If Lives = 0 Then + RemainingLIVES& = 1 + Else + RemainingLIVES& = Lives + End If + FinalSCORE& = Score * RemainingLIVES& * 10& + + Get (166, 152)-(472, 327), BigBOX() + Line (166, 152)-(472, 327), 0, BF + Line (168, 154)-(470, 325), 8, B + Line (170, 156)-(468, 323), 7, B + Line (172, 158)-(466, 321), 6, B + + If FinalSCORE& > ScoreDATA(9).PlayerSCORE Then + Color 4 + Locate 12, 31 + Print "- G A M E O V E R -" + Color 3 + If Lives = 0 Then + Locate 13, 30 + Print "(Sorry, no more lives)" + Else + Locate 13, 33 + Print "Congratulations!" + End If + + Hundred$ = LTrim$(Str$(FinalSCORE& Mod 1000)) + If FinalSCORE& >= 1000 Then + If Val(Hundred$) = 0 Then Hundred$ = "000" + If Val(Hundred$) < 100 Then Hundred$ = "0" + Hundred$ + Thousand$ = LTrim$(Str$(FinalSCORE& \ 1000)) + FinalSCORE$ = Thousand$ + "," + Hundred$ + Else + FinalSCORE$ = Hundred$ + End If + Color 6: Locate 15, 28: Print "Your final score is "; + Color 15: Print FinalSCORE$ + Color 9 + Locate 16, 26: Print "Enter your name to record score" + Locate 17, 26: Print "(Just press ENTER to decline):" + Color 15 + Locate 19, 26: Input ; Name$ + If Len(Name$) Then + ScoreDATA(10).PlayerNAME = Left$(Name$, 20) + ScoreDATA(10).PlayDATE = Date$ + ScoreDATA(10).PlayerSCORE = FinalSCORE& + For a = 0 To 10 + For B = a To 10 + If ScoreDATA(B).PlayerSCORE > ScoreDATA(a).PlayerSCORE Then + Swap ScoreDATA(B), ScoreDATA(a) + End If + Next B + Next a + + TopTEN + + Open "rattler.top" For Output As #1 + For Reps = 0 To 9 + Write #1, ScoreDATA(Reps).PlayerNAME + Write #1, ScoreDATA(Reps).PlayDATE + Write #1, ScoreDATA(Reps).PlayerSCORE + Next Reps + Close #1 + End If + End If + + Line (176, 160)-(462, 317), 0, BF + Color 4: Locate 14, 31: Print "- G A M E O V E R -" + Color 9 + Locate 16, 26: Print "Start new game......" + Locate 17, 26: Print "QUIT................" + Color 6 + Locate 16, 47: Print "Press [1]" + Locate 17, 47: Print "Press [2]" + + Do + k$ = InKey$ + Loop Until k$ = "1" Or k$ = "2" Or k$ = Chr$(27) + If k$ = "1" Then EndGAME = 1: Exit Function + Palette: Color 7: Cls + System + +End Function + +Sub InitGAME + + SetSPEED = 9 + SpeedLEVEL = 3 + Level = 1 + Lives = 5 + Score = 0 + CrittersLEFT = 10 + +End Sub + +Sub InitLEVEL + + Erase SnakePIT + SnakeLENGTH = 11 + StartCOL = 22 + + For n = 1 To SnakeLENGTH + StartCOL = StartCOL - 1 + Rattler(n).Col = StartCOL + Rattler(n).Row = 22 + Rattler(n).TURN = 0 + Rattler(n).WhichWAY = Right + Select Case n + Case 1: Rattler(n).BodyPART = Head + Case 2: Rattler(n).BodyPART = Neck + Case 3: Rattler(n).BodyPART = Shoulders + Case 4: Rattler(n).BodyPART = Body + Case 5: Rattler(n).BodyPART = Body + Case 6: Rattler(n).BodyPART = Shoulders + Case 7: Rattler(n).BodyPART = Neck + Case 8: Rattler(n).BodyPART = Tail + Case 9: Rattler(n).BodyPART = TailEND + Case 10: Rattler(n).BodyPART = Rattle + Case 11: Rattler(n).BodyPART = Blank + End Select + Next n + + PrintNUMS 1, Lives + PrintNUMS 2, Score + PrintNUMS 3, Level + PrintNUMS 5, SpeedLEVEL + + For n = 1 To SnakeLENGTH + RCol = Rattler(n).Col + RRow = Rattler(n).Row + RIndex = Rattler(n).BodyPART + Rattler(n).TURN + Rattler(n).WhichWAY + PutSPRITE RCol, RRow, RIndex + Next n + SnakePIT(Rattler(SnakeLENGTH).Col, Rattler(SnakeLENGTH).Row) = 0 + + For Col = 1 To 32 + SnakePIT(Col, 1) = -1 + SnakePIT(Col, 24) = -1 + Next Col + For Row = 2 To 23 + SnakePIT(1, Row) = -1 + SnakePIT(32, Row) = -1 + Next Row + + Line (271, 466)-(368, 474), 15, BF + For x = 271 To 361 Step 10 + Count = Count + 1 + If Count Mod 2 Then Colr = 11 Else Colr = 7 + Line (x, 466)-(x + 7, 474), Colr, BF + Next x + +End Sub + +Sub Instructions + + Get (100, 100)-(539, 379), BigBOX() + Line (100, 100)-(539, 379), 0, BF + Line (106, 106)-(533, 373), 13, B + Line (108, 108)-(531, 371), 7, B + Line (110, 110)-(529, 369), 6, B + + Color 9: Locate 10, 27: Print "- I N S T R U C T I O N S -" + Color 6 + Locate 12, 18: Print "RATTLER is a variation on the classic Microsoft" + Locate 13, 18: Print "QBasic game NIBBLES." + Color 15 + Locate 12, 18: Print "RATTLER": Locate 13, 30: Print "NIBBLES" + Color 6 + Locate 15, 18: Print "Steer the Diamondback Rattler using the Arrow" + Locate 16, 18: Print "keys, eating mice and frogs and scoring points" + Color 15: Locate 15, 58: Print "Arrow": Color 6 + Locate 17, 18: Print "for each kill. These wary creatures cannot be" + Locate 18, 18: Print "caught from the front or sides, however. They" + Locate 19, 18: Print "must be snuck up on from behind, otherwise" + Locate 20, 18: Print "they will simply jump to a new location." + + Color 13: Locate 22, 28: Print "PRESS ANY KEY TO CONTINUE..." + + a$ = Input$(1) + Line (120, 160)-(519, 332), 0, BF + Color 6 + Locate 12, 18: Print "With each creature eaten, the rattler grows" + Locate 13, 18: Print "in length, making steering much more difficult" + Locate 14, 18: Print "and increasing the chance of self-collision." + Locate 16, 18: Print "There are ten levels, each one more hazardous" + Locate 17, 18: Print "than the last. If the snake hits a stone wall" + Locate 18, 18: Print "or bumps into himself, he dies. He has a total" + Locate 19, 18: Print "of five lives. Once they are used up, the game" + Locate 20, 18: Print "is over." + Color 15 + Locate 16, 28: Print "ten": Locate 19, 21: Print "five" + + a$ = Input$(1) + Line (120, 160)-(519, 332), 0, BF + Color 6 + Locate 12, 18: Print "Often, a mouse or frog will have its back to" + Locate 13, 18: Print "a wall, making it impossible to kill. In those" + Locate 14, 18: Print "situations, you must attack from the front or" + Locate 15, 18: Print "sides, forcing it to move to a location where" + Locate 16, 18: Print "its back is exposed." + Locate 18, 18: Print "There are five speeds to choose from. It may" + Locate 19, 18: Print "be wise to choose a slower speed for the high-" + Locate 20, 18: Print "er levels. The default speed is 3." + Color 15: Locate 18, 28: Print "five": Locate 20, 50: Print "3" + a$ = Input$(1) + Line (120, 160)-(519, 332), 0, BF + Color 9 + Locate 12, 18: Print "SCORING:" + Color 6 + Locate 12, 18: Print "SCORING: Each kill scores 10 points multiplied" + Locate 13, 18: Print "by the level of difficulty and the speed. For" + Locate 14, 18: Print "example, at level 5, speed 3, a kill is worth" + Locate 15, 18: Print "150 points; level 10, speed 2: 200 points." + Locate 17, 18: Print "If you manage to complete all 10 levels, your" + Locate 18, 18: Print "final score is then multiplied by the number" + Locate 19, 18: Print "of remaining lives. In other words, the score" + Locate 20, 18: Print "accurately reflects your level of achievement." + Color 15 + Locate 12, 18: Print "SCORING" + Locate 12, 44: Print "10": Locate 14, 36: Print "5" + Locate 14, 45: Print "3": Locate 15, 18: Print "150" + Locate 15, 36: Print "10": Locate 15, 46: Print "2" + Locate 15, 49: Print "200" + a$ = Input$(1) + Line (120, 160)-(519, 368), 0, BF + Color 6 + Locate 12, 18: Print "Indicators of remaining lives and the current" + Locate 13, 18: Print "score are located at the top of the screen on" + Color 15: Locate 12, 42: Print "lives" + Locate 13, 18: Print "score": Color 6 + Locate 14, 18: Print "the extreme left and right, respectively." + Locate 16, 18: Print "The current level of play can be found on the" + Locate 17, 18: Print "bottom-left of the screen. Bottom-center you" + Locate 18, 18: Print "will find a graph indicating the number of" + Locate 19, 18: Print "prey remaining on the current level. The cur-" + Locate 20, 18: Print "rent speed can be read bottom-right." + Color 15 + Locate 16, 30: Print "level" + Locate 18, 51: Print "number of": Locate 19, 18: Print "prey" + Locate 20, 23: Print "speed" + Color 13: Locate 22, 25: Print "PRESS ANY KEY TO RETURN TO GAME..." + a$ = Input$(1) + + Put (100, 100), BigBOX(), PSet + +End Sub + +Sub Intro + + PutSPRITE 7, 16, Rattle + Up + PutSPRITE 7, 15, TailEND + Up + PutSPRITE 7, 14, Tail + Up + PutSPRITE 7, 13, Neck + Up + PutSPRITE 7, 12, Shoulders + Up + PutSPRITE 7, 11, Body + Up + PutSPRITE 7, 10, Body + TURN + UR + PutSPRITE 8, 10, Body + Right + PutSPRITE 9, 10, Body + TURN + RD + PutSPRITE 9, 11, Body + TURN + DL + PutSPRITE 8, 11, Body + TURN + LD + PutSPRITE 8, 12, Body + TURN + DR + PutSPRITE 9, 12, Body + TURN + RD + PutSPRITE 9, 13, Body + Down + PutSPRITE 9, 14, Body + TURN + DR + PutSPRITE 10, 14, Body + TURN + RU + PutSPRITE 10, 13, Body + Up + PutSPRITE 10, 12, Body + Up + PutSPRITE 10, 11, Body + Up + PutSPRITE 10, 10, Body + TURN + UR + PutSPRITE 11, 10, Body + Right + PutSPRITE 12, 10, Body + TURN + RD + PutSPRITE 12, 11, Body + Down + PutSPRITE 12, 12, Body + Down + PutSPRITE 12, 13, Body + Down + PutSPRITE 12, 14, Body + TURN + DR + PutSPRITE 13, 14, Body + Right + PutSPRITE 11, 12, Body + Right + PutSPRITE 13, 10, Body + Right + PutSPRITE 14, 10, Body + Right + PutSPRITE 15, 10, Body + Right + PutSPRITE 16, 10, Body + Right + PutSPRITE 17, 10, Body + Right + PutSPRITE 14, 11, Body + Down + PutSPRITE 14, 12, Body + Down + PutSPRITE 14, 13, Body + Down + PutSPRITE 14, 14, Body + TURN + DR + PutSPRITE 15, 14, Body + Right + PutSPRITE 16, 11, Body + Down + PutSPRITE 16, 12, Body + Down + PutSPRITE 16, 13, Body + Down + PutSPRITE 16, 14, Body + TURN + DR + PutSPRITE 17, 14, Body + Right + PutSPRITE 18, 10, Body + Down + PutSPRITE 18, 11, Body + Down + PutSPRITE 18, 12, Body + Down + PutSPRITE 18, 13, Body + Down + PutSPRITE 18, 14, Body + TURN + DR + PutSPRITE 19, 14, Body + Right + PutSPRITE 20, 10, Body + TURN + UR + PutSPRITE 21, 12, Body + Right + PutSPRITE 21, 10, Body + Right + PutSPRITE 20, 11, Body + Down + PutSPRITE 20, 12, Body + Down + PutSPRITE 20, 13, Body + Down + PutSPRITE 20, 14, Body + TURN + DR + PutSPRITE 21, 14, Body + Right + PutSPRITE 22, 16, Rattle + Up + PutSPRITE 22, 15, TailEND + Up + PutSPRITE 22, 14, Tail + Up + PutSPRITE 22, 13, Neck + Up + PutSPRITE 22, 12, Shoulders + Up + PutSPRITE 22, 11, Body + Up + PutSPRITE 22, 10, Body + TURN + UR + PutSPRITE 23, 10, Body + Right + PutSPRITE 24, 10, Body + TURN + RD + PutSPRITE 24, 11, Body + TURN + DL + PutSPRITE 23, 11, Body + TURN + LD + PutSPRITE 23, 12, Body + TURN + DR + PutSPRITE 24, 12, Body + TURN + RD + PutSPRITE 24, 13, Body + Down + PutSPRITE 24, 14, Body + TURN + DR + PutSPRITE 25, 14, Body + Right + PutSPRITE 26, 14, Shoulders + TURN + RU + PutSPRITE 26, 13, Neck + Up + PutSPRITE 26, 12, Head + Up + Color 13 + Locate 22, 20 + Print "Copyright (C) 2003 by Bob Seguin (Freeware)" + For x = 152 To 496 + For y = 336 To 352 + If Point(x, y) = 0 Then PSet (x, y), 8 + Next y + Next x + Line (80, 106)-(560, 386), 13, B + Line (76, 102)-(564, 390), 7, B + SetPALETTE + + + Play "MFMST200L32O0AP16AP16AP16DP16AP16AP16AP16>C 1 Then RowINC = -1: ColINC = 0: Direction = Up + Case Chr$(0) + "P" + If RowINC <> -1 Then RowINC = 1: ColINC = 0: Direction = Down + Case Chr$(0) + "K" + If ColINC <> 1 Then ColINC = -1: RowINC = 0: Direction = Left + Case Chr$(0) + "M" + If ColINC <> -1 Then ColINC = 1: RowINC = 0: Direction = Right + Case " " + Item = 2 + PauseMENU Item + If Item = -1 Then GoSub ReSTART: + End Select + + Row = Row + RowINC + Col = Col + ColINC + + 'Lengthen snake if prey has been eaten + If Increase Then + SnakeLENGTH = SnakeLENGTH + 1 + For n = SnakeLENGTH To SnakeLENGTH - 7 Step -1 + Rattler(n).BodyPART = Rattler(n - 1).BodyPART + Next n + Increase = Increase - 1 + 'If snake length has been increased significantly, adjust speed + If Increase = 0 Then + Select Case SnakeLENGTH + Case 36 To 46: Speed = SetSPEED - 1 + Case Is > 46: Speed = SetSPEED - 2 + End Select + End If + End If + + For n = SnakeLENGTH To 2 Step -1 + Swap Rattler(n).Row, Rattler(n - 1).Row + Swap Rattler(n).Col, Rattler(n - 1).Col + Swap Rattler(n).TURN, Rattler(n - 1).TURN + Swap Rattler(n).WhichWAY, Rattler(n - 1).WhichWAY + Swap Rattler(n).RattleDIR, Rattler(n - 1).RattleDIR + Next n + + If Direction <> OldDIRECTION Then + Rattler(2).TURN = TURN + Select Case OldDIRECTION + Case Up + Select Case Direction + Case Left: Rattler(2).WhichWAY = UL + Case Right: Rattler(2).WhichWAY = UR + End Select + Rattler(2).RattleDIR = Up + Case Down + Select Case Direction + Case Left: Rattler(2).WhichWAY = DL + Case Right: Rattler(2).WhichWAY = DR + End Select + Rattler(2).RattleDIR = Down + Case Left + Select Case Direction + Case Up: Rattler(2).WhichWAY = LU + Case Down: Rattler(2).WhichWAY = LD + End Select + Rattler(2).RattleDIR = Left + Case Right + Select Case Direction + Case Up: Rattler(2).WhichWAY = RU + Case Down: Rattler(2).WhichWAY = RD + End Select + Rattler(2).RattleDIR = Right + End Select + End If + + Rattler(1).Row = Row + Rattler(1).Col = Col + Rattler(1).TURN = 0 + Rattler(1).WhichWAY = Direction + Rattler(SnakeLENGTH).TURN = 0 + Rattler(SnakeLENGTH - 1).TURN = 0 + + If Rattler(SnakeLENGTH - 2).TURN = 0 Then + Rattler(SnakeLENGTH - 1).WhichWAY = Rattler(SnakeLENGTH - 2).WhichWAY + Else + Rattler(SnakeLENGTH - 1).WhichWAY = Rattler(SnakeLENGTH - 2).RattleDIR + End If + + OldDIRECTION = Direction + + 'TEST Map values + Select Case SnakePIT(Col, Row) + Case Is >= 1000 + If SnakePIT(Col, Row) Mod 1000 = Rattler(1).WhichWAY Then + If SnakePIT(Col, Row) \ 1000 = 1 Then Play "MBMST220L64O0BP16BO1P64B" + If SnakePIT(Col, Row) \ 1000 = 2 Then Play "MBT160L32O6A-B-B" + SnakePIT(Col, Row) = 0 + PreySCORE = PreySCORE + 1 + Score = Score + (Level * SpeedLEVEL) + PrintNUMS 2, Score + Increase = Increase + 5 + CrittersLEFT = CrittersLEFT - 1 + PrintNUMS 4, CrittersLEFT + If PreySCORE = 10 Then + PutSPRITE Col, Row, Blank + Wipe + PreySCORE = 0 + CrittersLEFT = 10 + Level = Level + 1 + If Level = 11 Then Choice = EndGAME + If Choice Then GoSub ReSTART + PrintNUMS 3, Level + Exit Sub + End If + SetPREY = 1 + Else + SetPREY = 2 + End If + Case Is < 0 + Play "MBMST100O0L32GFEDC" + Lives = Lives - 1 + PrintNUMS 1, Lives + PreySCORE = 0 + Get (188, 184)-(450, 295), BigBOX() + Line (188, 184)-(450, 295), 0, BF + Line (190, 186)-(448, 293), 8, B + Line (192, 188)-(446, 291), 7, B + Line (194, 190)-(444, 289), 6, B + Line (196, 192)-(442, 287), 6, B + If SnakePIT(Col, Row) = -1 Then + Color 4: Locate 15, 35: Print "G L O R N K !" + Color 9: Locate 16, 35: Print "HIT THE WALL!" + Else + Color 4: Locate 15, 37: Print "O U C H !" + Color 9: Locate 16, 35: Print "BIT YOURSELF!" + End If + StartTIME! = Timer: Do: Loop While Timer < StartTIME! + 1 + Put (188, 184), BigBOX(), PSet + If Lives = 0 Then Choice = EndGAME + If Choice Then GoSub ReSTART + CrittersLEFT = 10 + Wipe + Exit Sub + End Select + + Wait &H3DA, 8 + For n = SnakeLENGTH To 1 Step -1 + RCol = Rattler(n).Col + RRow = Rattler(n).Row + RIndex = Rattler(n).BodyPART + Rattler(n).TURN + Rattler(n).WhichWAY + PutSPRITE RCol, RRow, RIndex + If Rattler(n).BodyPART = Body Then + For nn = n To 1 Step -1 + If Rattler(n).BodyPART = Shoulders Then + n = nn + Exit For + End If + Next nn + End If + Next n + + If SetPREY Then + If SetPREY = 2 Then + If WhichPREY = 1 Then WhichPREY = 0 Else WhichPREY = 1 + End If + GoSub PutPREY + SetPREY = 0 + End If + + SnakePIT(Rattler(SnakeLENGTH).Col, Rattler(SnakeLENGTH).Row) = 0 + + For Reps = 1 To Speed + Wait &H3DA, 8 + Wait &H3DA, 8, 8 + Next Reps + + Loop + + Exit Sub + + '------------------------ SUBROUTINE SECTION BEGINS -------------------------- + + Rattle2: + If Reps Mod 3 = 0 Then + Line (420, 429)-(425, 430), 4, B + Line (426, 428)-(430, 428), 4 + Line (426, 431)-(430, 431), 4 + End If + Hula = Hula + 1 + Play "MFT220L64O0C" + Wait &H3DA, 8 + Wait &H3DA, 8, 8 + Select Case Hula Mod 2 + Case 0: Put (220, 418), SpriteBOX(Rattle + Right), PSet + Case 1: Put (220, 422), SpriteBOX(Rattle + Right), PSet + End Select + Sound 30000, 1 + Wait &H3DA, 8 + Wait &H3DA, 8, 8 + Put (220, 420), SpriteBOX(Rattle + Right), PSet + If Reps Mod 3 = 0 Then + Line (420, 428)-(430, 431), 8, BF + End If + If Level = 8 Then PutSPRITE 12, 21, Stone + Return + + PutPREY: + Do + PreyCOL = Int(Rnd * 30) + 2 + PreyROW = Int(Rnd * 22) + 2 + Loop While SnakePIT(PreyCOL, PreyROW) <> 0 + WhichDIR = Int(Rnd * 4) + Select Case WhichDIR + Case 0: Way = Left + Case 1: Way = Up + Case 2: Way = Right + Case 3: Way = Down + End Select + If WhichPREY = 1 Then + PutSPRITE PreyCOL, PreyROW, Frog + Way + SnakePIT(PreyCOL, PreyROW) = 1000 + Way + WhichPREY = 0 + Else + PutSPRITE PreyCOL, PreyROW, Mouse + Way + SnakePIT(PreyCOL, PreyROW) = 2000 + Way + WhichPREY = 1 + End If + Return + + ReSTART: + Play "MBMST200L32O0AP16AP16AP16DP16AP16AP16AP16>C 0 Then + Locate PrintROW, 18 + Print ScoreDATA(c).PlayerNAME + Locate PrintROW, 40 + Print ScoreDATA(c).PlayDATE + Locate PrintROW, 56 + Print Using "###,###"; ScoreDATA(c).PlayerSCORE + End If + PrintROW = PrintROW + 1 + Next c + Line (87, 121)-(551, 357), 13, B + Line (89, 123)-(549, 355), 13, B + PSet (89, 123), 15 + Line (91, 125)-(547, 353), 13, B + PSet (91, 125), 15 + Line (100, 157)-(538, 334), 13, B + For LR = 174 To 334 Step 16 + Line (100, LR)-(538, LR), 13 + Next LR + Line (124, 158)-(124, 334), 13 + Line (300, 158)-(300, 334), 13 + Line (402, 158)-(402, 334), 13 + + a$ = Input$(1) + Put (84, 119), BigBOX(), PSet + +End Sub + +Sub Wipe + + For n = 1 To 660 + Do + x = Int(Rnd * 30) + y = Int(Rnd * 22) + xx = x + 1: yy = y + 1 + Loop Until WipeBOX(x, y) = 0 + Line (xx * 20, yy * 20)-(xx * 20 + 19, yy * 20 + 19), 9, BF + Line (xx * 20, yy * 20)-(xx * 20 + 19, yy * 20 + 19), 4, BF + Line (xx * 20, yy * 20)-(xx * 20 + 19, yy * 20 + 19), 10, BF + Line (xx * 20, yy * 20)-(xx * 20 + 19, yy * 20 + 19), 15, BF + Line (xx * 20, yy * 20)-(xx * 20 + 19, yy * 20 + 19), 10, BF + Line (xx * 20, yy * 20)-(xx * 20 + 19, yy * 20 + 19), 8, BF + WipeBOX(x, y) = 1 + Next n + + Erase WipeBOX + +End Sub diff --git a/samples/rattler/src/rattler.zip b/samples/rattler/src/rattler.zip new file mode 100644 index 00000000..3eef1115 Binary files /dev/null and b/samples/rattler/src/rattler.zip differ diff --git a/samples/ray-tracer-demo/img/screenshot.png b/samples/ray-tracer-demo/img/screenshot.png deleted file mode 100644 index 6a2bc979..00000000 Binary files a/samples/ray-tracer-demo/img/screenshot.png and /dev/null differ diff --git a/samples/ray-tracer-demo/index.md b/samples/ray-tracer-demo/index.md deleted file mode 100644 index a8a33929..00000000 --- a/samples/ray-tracer-demo/index.md +++ /dev/null @@ -1,214 +0,0 @@ -[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) - -## SAMPLE: RAY TRACER DEMO - -![screenshot.png](img/screenshot.png) - -### Author - -[🐝 Antoni Gual](../antoni-gual.md) - -### Description - -```text -'Pure QB Realtime Raytracer Demo -'Translated to/optimized for QB by Antoni Gual agual@eic.ictnet.es -'The original was written in C by Texel, a Spanish demo coder. -'It will not work in the IDE due to integer overflow errors. -'Compile with QB 4.0 or QB4.5 + ffix. It does 12.5 fps in my P4 1,4. -'The C version (DOS protected mode, DJGPP) does 50 fps :( -``` - -### Code - -#### raytra1b.bas - -```vb - -'Pure QB Realtime Raytracer Demo -'Translated to/optimized for QB by Antoni Gual agual@eic.ictnet.es -'The original was written in C by Texel, a Spanish demo coder. -'It will not work in the IDE due to integer overflow errors. -'Compile with QB 4.0 or QB4.5 + ffix. It does 12.5 fps in my P4 1,4. -'The C version (DOS protected mode, DJGPP) does 50 fps :( - -$NoPrefix -$Resize:Smooth - -Const objnum = 4 - -Dim n As Integer, K As Integer, OBJMIN As Integer, OBJMIN2 As Integer -Dim OBJ(objnum) As Integer, l As Integer, posi As Integer, POS2 As Integer -Dim s As Integer, t(8200) As Integer, XX As Integer, YY As Integer, XQ As Integer -Dim YQ As Integer, mmmm As Integer, xx1 As Integer, yy1 As Integer -Dim t2(8200) As Integer, ipos As Integer - -Dim A(objnum) As Single, B(objnum) As Single, C(objnum) As Single -Dim R(objnum) As Single - -Screen 13 -FullScreen SquarePixels , Smooth - -Def Seg = &HA000 -'Cambiar la paleta a tonos de azul -Out &H3C8, 0 ' -For n = 0 To 127 - Out &H3C9, 0 - Out &H3C9, Int(n / 4) - Out &H3C9, Int(n / 2) -Next -For n = 0 To 127 - Out &H3C9, Int(n / 2) - Out &H3C9, Int(31 + n / 4) - Out &H3C9, 63 -Next -D = 230 -l = 0 - -'four objects -OBJ(0) = 0: A(0) = -50 + l: B(0) = 0: C(0) = -100: R(0) = -55 * 55 -OBJ(1) = 0: A(1) = 50 - l: B(1) = -25: C(1) = -120: R(1) = -55 * 55 -OBJ(2) = 0: A(2) = 0: B(2) = 500: C(2) = -220: R(2) = -500! * 500 -OBJ(3) = 1: A(3) = 60: B(3) = -35: C(3) = -30 - -tt! = Timer -For l = 0 To 199 - - A(0) = -50 + l - A(1) = 50 - l - posi = 400 - mmmm = -1 - 'calculamos uno de cada 4 pixels a buffer t() - For Y = -40 To 39 Step 2 - For X = -80 To 79 Step 2 - X0 = X - Y0 = Y - GoSub raytrace - t(posi) = COL - posi = posi + 1 - Next - Next - posi = 482 - POS2 = 0 - 'calculamos pixels restantes, interpolando si podemos - For YQ = 6 To 43 - For XQ = 2 To 77 - 'interpolar - If t2(posi) = t2(posi + 1) And t2(posi) = t2(posi + 80) And t2(posi) = t2(posi + 81) Then - ipos = (YQ * 1280 + (XQ * 4)) - For YY = 0 To 3 - For XX = 0 To 3 - Poke ipos, (YY * (t(posi + 80) * (4 - XX) + t(posi + 81) * XX) + (t(posi) * (4 - XX) + t(posi + 1) * XX) * (4 - YY)) \ 16 - ipos = ipos + 1 - Next - ipos = ipos + 316 - Next - 'no interpolar - Else - mmmm = 0 - For yy1 = 0 To 3 - For xx1 = 0 To 3 - If xx1 Or yy1 Then - X0 = (-160 + XQ * 4 + xx1) / 2 - Y0 = (-100 + YQ * 4 + yy1) / 2 - GoSub raytrace - Poke (YQ * 4 + yy1) * 320 + XQ * 4 + xx1, COL - Else - Poke YQ * 1280 + XQ * 4, t(posi) - End If - Next - Next - End If - posi = posi + 1 - Next - posi = posi + 4 - Next - If Len(InKey$) Then Exit For - Limit 60 -Next -Color 255: Print l / (Timer - tt!) -KK$ = Input$(1) -End - -raytrace: -Z0 = 0 -MD = 1 / Sqr(X0 * X0 + Y0 * Y0 + D * D) -X1 = X0 * MD -Y1 = Y0 * MD -Z1 = -(D + Z0) * MD -K = 0 -COL = 0 -OBJMIN = objnum -If mmmm Then t2(posi) = objnum -Do - TMIN = 327680 - For n = 0 To 2 - If OBJ(n) = 0 And (OBJ(n) <> OBJMIN) Then - A0 = A(n) - X0 - B0 = B(n) - Y0 - C0 = C(n) - Z0 - TB = A0 * X1 + B0 * Y1 + C0 * Z1 - RZ = TB * TB - A0 * A0 - B0 * B0 - C0 * C0 - If RZ >= R(n) Then - TN = TB - Sqr(RZ - R(n)) - If TN < TMIN And TN > 0 Then TMIN = TN: OBJMIN2 = n - End If - End If - Next - OBJMIN = OBJMIN2 - If TMIN < 327680 And (OBJ(OBJMIN) = 0) Then - If mmmm Then t2(posi) = t2(posi) * K * objnum * 3 + OBJMIN - X0 = X0 + X1 * TMIN - Y0 = Y0 + Y1 * TMIN - Z0 = Z0 + Z1 * TMIN - NX = X0 - A(OBJMIN) - NY = Y0 - B(OBJMIN) - NZ = Z0 - C(OBJMIN) - CA = 2 * (NX * X1 + NY * Y1 + NZ * Z1) / (NX * NX + NY * NY + NZ * NZ + 1) - X1 = X1 - NX * CA - Y1 = Y1 - NY * CA - Z1 = Z1 - NZ * CA - A2 = A(3) - X0 - B2 = B(3) - Y0 - C2 = C(3) - Z0 - MV = 1 / Sqr(A2 * A2 + B2 * B2 + C2 * C2) - A2 = A2 * MV - B2 = B2 * MV - C2 = C2 * MV - s = 0 - For n = 0 To 2 - If OBJ(n) = 0 And Not s Then - A0 = X0 - A(n) - B0 = Y0 - B(n) - C0 = Z0 - C(n) - TB = A2 * A0 + B2 * B0 + C2 * C0 - RZ = TB * TB - A0 * A0 - B0 * B0 - C0 * C0 - If RZ >= R(n) And TB < 0 Then s = -1: If mmmm Then t2(posi) = t2(posi) * 32 - End If - Next - If Not s Then - If mmmm Then t2(posi) = t2(posi) + 1 - col2 = X1 * A2 + Y1 * B2 + Z1 * C2 - If col2 < 0 Then col2 = 0 - cc = col2 * col2 - col2 = cc * cc - MV = Sqr(NX * NX + NY * NY + NZ * NZ) - 'IF COL2 < 0 THEN COL2 = 0 - col2 = col2 + (NX * A2 + NY * B2 + NZ * C2) / MV - If col2 < 0 Then col2 = 0 - COL = COL + col2 / ((K + 1) * (K + 1) * 2) - If COL > 1 Then COL = 1 - End If - K = K + 1 - End If -Loop While TMIN < 327680 And K <= 2 -If K = 0 Then COL = 50 Else COL = COL * 255 -Return - -``` - -### File(s) - -* [raytra1b.bas](src/raytra1b.bas) - -🔗 [ray tracer](../ray-tracer.md) diff --git a/samples/ray-tracer-demo/src/raytra1b.bas b/samples/ray-tracer-demo/src/raytra1b.bas deleted file mode 100644 index 349c4dca..00000000 --- a/samples/ray-tracer-demo/src/raytra1b.bas +++ /dev/null @@ -1,180 +0,0 @@ -'Pure QB Realtime Raytracer Demo -'Translated to/optimized for QB by Antoni Gual agual@eic.ictnet.es -'The original was written in C by Texel, a Spanish demo coder. -'It will not work in the IDE due to integer overflow errors. -'Compile with QB 4.0 or QB4.5 + ffix. It does 12.5 fps in my P4 1,4. -'The C version (DOS protected mode, DJGPP) does 50 fps :( - -$NoPrefix -$Resize:Smooth - -Const objnum = 4 - -Dim n As Integer, K As Integer, OBJMIN As Integer, OBJMIN2 As Integer -Dim OBJ(objnum) As Integer, l As Integer, posi As Integer, POS2 As Integer -Dim s As Integer, t(8200) As Integer, XX As Integer, YY As Integer, XQ As Integer -Dim YQ As Integer, mmmm As Integer, xx1 As Integer, yy1 As Integer -Dim t2(8200) As Integer, ipos As Integer - -Dim A(objnum) As Single, B(objnum) As Single, C(objnum) As Single -Dim R(objnum) As Single - -Screen 13 -FullScreen SquarePixels , Smooth - -Def Seg = &HA000 -'Cambiar la paleta a tonos de azul -Out &H3C8, 0 ' -For n = 0 To 127 - Out &H3C9, 0 - Out &H3C9, Int(n / 4) - Out &H3C9, Int(n / 2) -Next -For n = 0 To 127 - Out &H3C9, Int(n / 2) - Out &H3C9, Int(31 + n / 4) - Out &H3C9, 63 -Next -D = 230 -l = 0 - -'four objects -OBJ(0) = 0: A(0) = -50 + l: B(0) = 0: C(0) = -100: R(0) = -55 * 55 -OBJ(1) = 0: A(1) = 50 - l: B(1) = -25: C(1) = -120: R(1) = -55 * 55 -OBJ(2) = 0: A(2) = 0: B(2) = 500: C(2) = -220: R(2) = -500! * 500 -OBJ(3) = 1: A(3) = 60: B(3) = -35: C(3) = -30 - -tt! = Timer -For l = 0 To 199 - - A(0) = -50 + l - A(1) = 50 - l - posi = 400 - mmmm = -1 - 'calculamos uno de cada 4 pixels a buffer t() - For Y = -40 To 39 Step 2 - For X = -80 To 79 Step 2 - X0 = X - Y0 = Y - GoSub raytrace - t(posi) = COL - posi = posi + 1 - Next - Next - posi = 482 - POS2 = 0 - 'calculamos pixels restantes, interpolando si podemos - For YQ = 6 To 43 - For XQ = 2 To 77 - 'interpolar - If t2(posi) = t2(posi + 1) And t2(posi) = t2(posi + 80) And t2(posi) = t2(posi + 81) Then - ipos = (YQ * 1280 + (XQ * 4)) - For YY = 0 To 3 - For XX = 0 To 3 - Poke ipos, (YY * (t(posi + 80) * (4 - XX) + t(posi + 81) * XX) + (t(posi) * (4 - XX) + t(posi + 1) * XX) * (4 - YY)) \ 16 - ipos = ipos + 1 - Next - ipos = ipos + 316 - Next - 'no interpolar - Else - mmmm = 0 - For yy1 = 0 To 3 - For xx1 = 0 To 3 - If xx1 Or yy1 Then - X0 = (-160 + XQ * 4 + xx1) / 2 - Y0 = (-100 + YQ * 4 + yy1) / 2 - GoSub raytrace - Poke (YQ * 4 + yy1) * 320 + XQ * 4 + xx1, COL - Else - Poke YQ * 1280 + XQ * 4, t(posi) - End If - Next - Next - End If - posi = posi + 1 - Next - posi = posi + 4 - Next - If Len(InKey$) Then Exit For - Limit 60 -Next -Color 255: Print l / (Timer - tt!) -KK$ = Input$(1) -End - -raytrace: -Z0 = 0 -MD = 1 / Sqr(X0 * X0 + Y0 * Y0 + D * D) -X1 = X0 * MD -Y1 = Y0 * MD -Z1 = -(D + Z0) * MD -K = 0 -COL = 0 -OBJMIN = objnum -If mmmm Then t2(posi) = objnum -Do - TMIN = 327680 - For n = 0 To 2 - If OBJ(n) = 0 And (OBJ(n) <> OBJMIN) Then - A0 = A(n) - X0 - B0 = B(n) - Y0 - C0 = C(n) - Z0 - TB = A0 * X1 + B0 * Y1 + C0 * Z1 - RZ = TB * TB - A0 * A0 - B0 * B0 - C0 * C0 - If RZ >= R(n) Then - TN = TB - Sqr(RZ - R(n)) - If TN < TMIN And TN > 0 Then TMIN = TN: OBJMIN2 = n - End If - End If - Next - OBJMIN = OBJMIN2 - If TMIN < 327680 And (OBJ(OBJMIN) = 0) Then - If mmmm Then t2(posi) = t2(posi) * K * objnum * 3 + OBJMIN - X0 = X0 + X1 * TMIN - Y0 = Y0 + Y1 * TMIN - Z0 = Z0 + Z1 * TMIN - NX = X0 - A(OBJMIN) - NY = Y0 - B(OBJMIN) - NZ = Z0 - C(OBJMIN) - CA = 2 * (NX * X1 + NY * Y1 + NZ * Z1) / (NX * NX + NY * NY + NZ * NZ + 1) - X1 = X1 - NX * CA - Y1 = Y1 - NY * CA - Z1 = Z1 - NZ * CA - A2 = A(3) - X0 - B2 = B(3) - Y0 - C2 = C(3) - Z0 - MV = 1 / Sqr(A2 * A2 + B2 * B2 + C2 * C2) - A2 = A2 * MV - B2 = B2 * MV - C2 = C2 * MV - s = 0 - For n = 0 To 2 - If OBJ(n) = 0 And Not s Then - A0 = X0 - A(n) - B0 = Y0 - B(n) - C0 = Z0 - C(n) - TB = A2 * A0 + B2 * B0 + C2 * C0 - RZ = TB * TB - A0 * A0 - B0 * B0 - C0 * C0 - If RZ >= R(n) And TB < 0 Then s = -1: If mmmm Then t2(posi) = t2(posi) * 32 - End If - Next - If Not s Then - If mmmm Then t2(posi) = t2(posi) + 1 - col2 = X1 * A2 + Y1 * B2 + Z1 * C2 - If col2 < 0 Then col2 = 0 - cc = col2 * col2 - col2 = cc * cc - MV = Sqr(NX * NX + NY * NY + NZ * NZ) - 'IF COL2 < 0 THEN COL2 = 0 - col2 = col2 + (NX * A2 + NY * B2 + NZ * C2) / MV - If col2 < 0 Then col2 = 0 - COL = COL + col2 / ((K + 1) * (K + 1) * 2) - If COL > 1 Then COL = 1 - End If - K = K + 1 - End If -Loop While TMIN < 327680 And K <= 2 -If K = 0 Then COL = 50 Else COL = COL * 255 -Return - diff --git a/samples/ray-tracing.md b/samples/ray-tracing.md index 17a93ac6..9e21e42f 100644 --- a/samples/ray-tracing.md +++ b/samples/ray-tracing.md @@ -2,7 +2,7 @@ ## SAMPLES: RAY TRACING -**[Chaotic Scattering - Gaspard-Rice system](chaotic-scattering/index.md)** +**[Chaotic Scattering](chaotic-scattering/index.md)** [🐝 vince](vince.md) 🔗 [ray tracing](ray-tracing.md), [reflections](reflections.md) diff --git a/samples/raycaster.md b/samples/raycaster.md new file mode 100644 index 00000000..2147f285 --- /dev/null +++ b/samples/raycaster.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: RAYCASTER + +**[RayCaster](raycaster/index.md)** + +[🐝 Antoni Gual](antoni-gual.md) 🔗 [3d](3d.md), [raycaster](raycaster.md) + +'Antoni Gual raycaster 'Modified from Entropy's an 36-lines entry for the Biskbart's '40-lines QB... diff --git a/samples/raycaster/img/screenshot.png b/samples/raycaster/img/screenshot.png new file mode 100644 index 00000000..1711bc01 Binary files /dev/null and b/samples/raycaster/img/screenshot.png differ diff --git a/samples/raycaster/index.md b/samples/raycaster/index.md new file mode 100644 index 00000000..ff12d5b5 --- /dev/null +++ b/samples/raycaster/index.md @@ -0,0 +1,37 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: RAYCASTER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Antoni Gual](../antoni-gual.md) + +### Description + +```text +'Antoni Gual raycaster +'Modified from Entropy's an 36-lines entry for the Biskbart's +'40-lines QB Raycaster Compo of fall-2001 +' +'Added multikey handler +'Step emulation +'Added different textures, including clouds +'Separe +'with some of my ideas + +'to do: +' add screen buffer +' optimize rendering loop +' interpolate rays +' shadowing +' subpixel precision +' make it a game??? +``` + +### File(s) + +* [rc-ent6.bas](src/rc-ent6.bas) + +🔗 [3d](../3d.md), [raycaster](../raycaster.md) diff --git a/samples/raycaster/src/rc-ent6.bas b/samples/raycaster/src/rc-ent6.bas new file mode 100644 index 00000000..5a482abf --- /dev/null +++ b/samples/raycaster/src/rc-ent6.bas @@ -0,0 +1,309 @@ +'Antoni Gual raycaster +'Modified from Entropy's an 36-lines entry for the Biskbart's +'40-lines QB Raycaster Compo of fall-2001 +' +'Added multikey handler +'Step emulation +'Added different textures, including clouds +'Separe +'with some of my ideas + +'to do: +' add screen buffer +' optimize rendering loop +' interpolate rays +' shadowing +' subpixel precision +' make it a game??? + +$NoPrefix +DefLng A-Z +Option Explicit +Option ExplicitArray + +$Resize:Smooth +Screen 13 +FullScreen SquarePixels , Smooth + +Dim map(9, 9) As Integer 'the map +Dim tex(31, 31, 4) As Integer 'texture array +Dim foff(15) As Integer 'walk simulation vertical offset +Dim kbd(128) As Integer 'keyboard reader array +Dim frames As Long +Dim persplut(200) As Single 'vertical offsets for roof and floor +Dim d1(319) As Integer 'temporal arrays raycaster->renderer +Dim d2(319) As Integer +Dim tx(319) As Integer +Dim tm(319) As Integer +Dim dx(319) As Single +Dim dy(319) As Single + +Dim As Long i, j, i1, j1, d1, d, d2 + +'read map,do fixed part of persp lut (sky is always in the infinite) +For i = 0 To 99 + Read map(i \ 10, i Mod 10) + persplut(i) = 25590 / (i - 100) +Next + +'make texture maps (should be read from file) +For i = 0 To 31 + For j = 0 To 31 + tex(i, j, 0) = (i Xor j) 'xor walls + i1 = i - 16 + j1 = j - 16 + tex(i, j, 1) = Sqr((i1 * i1) + (j1 * j1)) 'concentric ground tiles + tex(i, j, 2) = 16 - Sqr((i1 * i1) + (j1 * j1)) + Next +Next + +'cloudy texture 1 +d1 = 64 +d = 32 +tex(0, 0, 3) = 32 +While d > 1 + d2 = d \ 2 + For i = 0 To 31 Step d + For j = 0 To 31 Step d + tex((i + d2) And 31, j, 3) = (tex(i, j, 3) + tex((i + d) And 31, j, 3) + (Rnd - .5) * d1) / 2 + tex(i, (j + d2) And 31, 3) = (tex(i, j, 3) + tex(i, (j + d) And 31, 3) + (Rnd - .5) * d1) / 2 + tex((i + d2) And 31, (j + d2) And 31, 3) = (tex(i, j, 3) + tex((i + d) And 31, (j + d) And 31, 3) + (Rnd - .5) * d1) / 2 + Next + Next + d1 = d1 / 2 + d = d2 +Wend + +'cloudy texture for sky +d1 = 64 +d = 32 +tex(0, 0, 4) = 32 +While d > 1 + d2 = d \ 2 + For i = 0 To 31 Step d + For j = 0 To 31 Step d + tex((i + d2) And 31, j, 4) = (tex(i, j, 4) + tex((i + d) And 31, j, 4) + (Rnd - .5) * d1) / 2 + tex(i, (j + d2) And 31, 4) = (tex(i, j, 4) + tex(i, (j + d) And 31, 4) + (Rnd - .5) * d1) / 2 + tex((i + d2) And 31, (j + d2) And 31, 4) = (tex(i, j, 4) + tex((i + d) And 31, (j + d) And 31, 4) + (Rnd - .5) * d1) / 2 + Next + Next + d1 = d1 / 2 + d = d2 +Wend + +Dim pioct As Single + +'fill step-simulation vertical offset +pioct! = Pi / 8! +For i = 0 To 15 + foff(i) = Abs(Cos(i * pioct!) * 64) +Next + + +'set palette +Out &H3C8, 0 +'grey:walls +For i = 0 To 63 + Out &H3C9, i: Out &H3C9, i: Out &H3C9, i +Next +'green:ground +For i = 0 To 63 + Out &H3C9, 0: Out &H3C9, 63 - i: Out &H3C9, 0 +Next +'blue:sky +For i = 0 To 63 + Out &H3C9, 63 - i / 2: Out &H3C9, 63 - i / 2: Out &H3C9, 63 +Next + +'launch raytracer +'erase key buffer and set num lock off +Def Seg = &H40: Poke &H1C, Peek(&H1A): Poke &H17, Peek(&H17) And Not 32 + +Dim tim As Single +tim! = Timer + +Dim As Long ini, k, turn, mov, f, foff, y, x, sdx, sdy, xm, ym, md1, md2, tx, d21, p, mmap, tt +Dim As Single rtf, rtl, inf, incu, xpos, ypos, angle, xpos2, ypos2, calc, dxc, dxs, dyc, dys +Dim As Single xpos32, xp1, ypos32, yp1, dx, dy, nextxt, dxt, nextyt, dyt, ti, pl + +frames = 0 + + +'SUB raytrace +rtf = 2048 +rtl = .0001 +inf = 3000000 +incu = .05 +xpos = 1.5 +ypos = 1.5 +angle = 0 +ini = 1 +'frames loop +Do + + Wait &H3DA, 8 + Wait &H3DA, 8, 8 + + frames = frames + 1 + + 'keyboard input + k = Inp(&H60): + If k Then + kbd(k And 127) = -((k And 128) = 0) + Def Seg = &H40: Poke &H1C, Peek(&H1A) + If kbd(1) Then GoTo EXITDO1 + turn = kbd(&H4D) - kbd(&H4B): kbd(&H4D) = 0: kbd(&H4B) = 0 + mov = kbd(80) - kbd(72) + ini + End If + 'a movement has happened, update and collision detect + If turn Or mov Then + angle = angle + turn * .1 + xpos2 = mov * Cos(angle) * incu + ypos2 = mov * Sin(angle) * incu + + 'calculate walk offsets,and floor part of perspective + f = f + mov + foff = foff(f And 15) + calc = 25600 - 32 * foff + For y = 100 To 199: persplut(y) = calc / (y - 99): Next + + If ini Then ini = 0 + dxc = Cos(angle) * incu + dxs = Sin(angle) * incu / 160 + dyc = Cos(angle) * incu / 160 + dys = Sin(angle) * incu + 'colision detector + + If map(Int(ypos - incu), Int(xpos - xpos2 - xpos2 - incu)) = 0 Then + If map(Int(ypos - incu), Int(xpos - xpos2 - xpos2 + incu)) = 0 Then + If map(Int(ypos + incu), Int(xpos - xpos2 - xpos2 - incu)) = 0 Then + If map(Int(ypos + incu), Int(xpos - xpos2 - xpos2 + incu)) = 0 Then + xpos = xpos - xpos2 + xpos32 = xpos * 32 + xp1! = (xpos - Int(xpos)) * rtf + End If + End If + End If + End If + If map(Int(ypos - ypos2 - ypos2 - incu), Int(xpos - incu)) = 0 Then + If map(Int(ypos - ypos2 - ypos2 + incu), Int(xpos - incu)) = 0 Then + If map(Int(ypos - ypos2 - ypos2 - incu), Int(xpos + incu)) = 0 Then + If map(Int(ypos - ypos2 - ypos2 + incu), Int(xpos + incu)) = 0 Then + ypos = ypos - ypos2 + ypos32 = ypos * 32 + yp1! = (ypos - Int(ypos)) * rtf + End If + End If + End If + End If + + + 'raycast loop + For x = 0 To 319 + 'INIT RAYCASTER + dx = dxc - (x - 160) * dxs + dy = (x - 160) * dyc + dys + dx(x) = dx + dy(x) = dy + Select Case dx + Case Is < -rtl + nextxt = -xp1! / dx + dxt = -rtf / dx + Case Is > rtl + nextxt = (rtf - xp1!) / dx + dxt = rtf / dx + Case Else + nextxt = inf + End Select + Select Case dy + Case Is < -rtl + nextyt = -yp1! / dy + dyt = -rtf / dy + Case Is > rtl + nextyt = (rtf - yp1!) / dy + dyt = rtf / dy + Case Else + nextyt = inf + End Select + sdx = Sgn(dx): sdy = Sgn(dy) + xm = Int(xpos): ym = Int(ypos) + + 'cast a ray and increase distance until a wall is hit + Do + If nextxt < nextyt Then + + xm = xm + sdx + If map(ym, xm) Then ti = rtf / nextxt: GoTo exitdo2 + nextxt = nextxt + dxt + Else + 'ny% = ny% + 1 + ym = ym + sdy + If map(ym, xm) Then ti = rtf / nextyt: GoTo exitdo2 + nextyt = nextyt + dyt + End If + Loop + exitdo2: + 'Enter texture index, top, bottom into table for this direction + + tm(x) = map(ym, xm) Mod 5 + d1 = 99 - Int((800 + foff) * ti) + If d1 > md1 Then md1 = d1 + d1(x) = d1 + d2 = 102 + Int((800 - foff) * ti) + d2(x) = d2 + If d2 < md2 Then md2 = d2 + tx(x) = ((xpos + ypos + (dx + dy) / ti) * 32) And 31 + + Next + End If + + 'rendering loop (too many products and divisions) + + Def Seg = &HA000 + For x = 0 To 319 + d1 = d1(x) + d2 = d2(x) + tx = tx(x) + d21 = d2 - d1 + dx = dx(x) + dy = dy(x) + p = x + mmap = tm(x) + For y = 0 To 199 + pl = persplut(y) + Select Case y + 'sky + Case Is < d1 + tt = 128 + tex(dx * pl And 31, dy * pl And 31, 4) + 'wall + Case Is < d2 + tt = 10 + tex(32 * (y - d1) \ d21, tx, mmap) + 'ground + Case Else + tt = 56 + tex((xpos32 + dx * pl) And 31, (ypos32 + dy * pl) And 31, 4) + End Select + Poke p&, tt + p& = p& + 320 + Next + Next +Loop +EXITDO1: + +Dim a As String +Color 12 +Locate 1, 1: Print frames / (Timer - tim!); " fps" +a = Input$(1) +End + +'map data +Data 7,8,7,8,7,8,7,8,7,8 +Data 7,0,0,0,0,0,0,0,0,8 +Data 8,0,9,1,0,2,10,2,0,7 +Data 7,0,1,9,0,0,0,10,0,8 +Data 8,0,0,0,0,0,0,0,0,7 +Data 7,0,3,11,3,11,0,0,0,8 +Data 8,0,11,0,0,3,0,0,0,7 +Data 7,0,3,0,0,11,0,0,0,8 +Data 8,0,0,0,0,0,0,0,0,7 +Data 8,7,8,7,8,7,8,7,8,8 + diff --git a/samples/reflections.md b/samples/reflections.md index e206c24f..d6bf196d 100644 --- a/samples/reflections.md +++ b/samples/reflections.md @@ -2,7 +2,7 @@ ## SAMPLES: REFLECTIONS -**[Chaotic Scattering - Gaspard-Rice system](chaotic-scattering/index.md)** +**[Chaotic Scattering](chaotic-scattering/index.md)** [🐝 vince](vince.md) 🔗 [ray tracing](ray-tracing.md), [reflections](reflections.md) diff --git a/samples/relsoft.md b/samples/relsoft.md index 97887150..15ea697b 100644 --- a/samples/relsoft.md +++ b/samples/relsoft.md @@ -2,7 +2,7 @@ ## SAMPLES BY RELSOFT -**[Julia Rings](3d-cube/index.md)** +**[3D Cube](3d-cube/index.md)** [🐝 Relsoft](relsoft.md) 🔗 [3d](3d.md), [cube](cube.md) @@ -14,7 +14,7 @@ Automated Julia set explorer. -**[Non-Palette Rotated Plasma](plasma-non-pal/index.md)** +**[Plasma Non-Pal](plasma-non-pal/index.md)** [🐝 Relsoft](relsoft.md) 🔗 [screensaver](screensaver.md), [plasma](plasma.md) diff --git a/samples/retroqb45.md b/samples/retroqb45.md new file mode 100644 index 00000000..dec22c2d --- /dev/null +++ b/samples/retroqb45.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES BY RETROQB45 + +**[QDigger](qdigger/index.md)** + +[🐝 RETROQB45](retroqb45.md) 🔗 [game](game.md), [digger](digger.md) + +A DIGGER game clone by RETROQB45. diff --git a/samples/reversi/img/screenshot.png b/samples/reversi/img/screenshot.png new file mode 100644 index 00000000..12008cc1 Binary files /dev/null and b/samples/reversi/img/screenshot.png differ diff --git a/samples/reversi/index.md b/samples/reversi/index.md new file mode 100644 index 00000000..85f40df0 --- /dev/null +++ b/samples/reversi/index.md @@ -0,0 +1,21 @@ +[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) + +## SAMPLE: REVERSI + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Reversi game by Microsoft. +``` + +### File(s) + +* [reversi.bas](src/reversi.bas) + +🔗 [game](../game.md) diff --git a/samples/reversi/src/reversi.bas b/samples/reversi/src/reversi.bas new file mode 100644 index 00000000..0ec77f53 --- /dev/null +++ b/samples/reversi/src/reversi.bas @@ -0,0 +1,601 @@ +'----------------------------------------------------------------------------------------------------- +' These are some metacommands and compiler options for QB64 to write modern & type-strict code +'----------------------------------------------------------------------------------------------------- +' This will disable prefixing all modern QB64 calls using a underscore prefix. +$NoPrefix +' Whatever indentifiers are not defined, should default to signed longs (ex. constants and functions). +DefInt A-Z +' All variables must be defined. +Option Explicit +' All arrays must be defined. +Option ExplicitArray +' Array lower bounds should always start from 1 unless explicitly specified. +' This allows a(4) as integer to have 4 members with index 1-4. +Option Base 1 +' This game erases arrays and does not redim them. So we use static arrays instead. +'$Static +' This allows the executable window & it's contents to be resized. +$Resize:Smooth +Title "Reversi" +'----------------------------------------------------------------------------------------------------- + +Const FALSE = 0 +Const TRUE = Not FALSE +Const QUIT = 113 +Const UP = 72 +Const DOWN = 80 +Const LEFT = 75 +Const RIGHT = 77 +Const BBLOCK = 1 +Const EBLOCK = 8 +Const ENTER = 13 +Const ULEFT = 71 +Const URIGHT = 73 +Const DLEFT = 79 +Const DRIGHT = 81 +Const PASS = 112 +Const DIFF = 100 +Const START = 115 +Const HELP = 104 +Const FMOVE = 99 +Const SPACE = 32 + +Type GameGrid + player As Integer + nTake As Integer + cx As Integer + cy As Integer +End Type + +Type GameStatus + curRow As Integer + curCol As Integer + stat As Integer + rScore As Integer + bScore As Integer + mDisplay As Integer + dLevel As String * 6 + GColor As Integer +End Type + +Dim Shared GS As GameStatus, smode As Integer +Dim Shared GG(8, 8) As GameGrid, GBoard As Integer +Dim Shared COMP As Integer, HUMAN As Integer, BG As Integer +Dim Shared GP(8, 8, 8) As Integer, GW(8, 8) As Integer +Dim vmode As Integer +Dim k As String + +On Error GoTo BadMode + +Do + Read smode + vmode = TRUE + Screen smode +Loop Until vmode = TRUE + +If smode = 0 Then + Cls + Locate 10, 15: Print "No graphics screen mode available; cannot run Reversi" +Else + AllowFullScreen SquarePixels , Smooth + GS.stat = START + GS.dLevel = "Novice" + While GS.stat <> QUIT + If GS.stat = START Then + InitGame + DrawGameBoard + End If + If GS.stat <> COMP Then + If ValidMove(COMP) Then + UserMove + ElseIf ValidMove(HUMAN) Then + Do + DisplayMsg "You have no valid moves. Select pass." + Do + k = InKey$ + Loop Until k <> "" + Loop Until Asc(Right$(k, 1)) = PASS + Line (0, 420)-(640, 447), 3, BF + GS.mDisplay = FALSE + GS.stat = COMP + ComputerMove + Else + GameOver + End If + Else + If ValidMove(HUMAN) Then + ComputerMove + ElseIf ValidMove(COMP) Then + DisplayMsg "Computer has no valid moves. Your Turn." + GS.stat = HUMAN + UserMove + Else + GameOver + End If + End If + Wend + DisplayMsg "Game Over" +End If + +Data 9,10,2,3,0 + +BadMode: +vmode = FALSE +Resume Next + +System 0 + +Function CheckPath (i As Integer, IBound As Integer, IStep As Integer, j As Integer, JBound As Integer, JStep As Integer, Opponent As Integer) + Dim As Integer done, count + + done = FALSE + While (i <> IBound Or j <> JBound) And Not done + If GG(i, j).player = GBoard Then + count = 0 + done = TRUE + ElseIf GG(i, j).player = Opponent Then + count = count + 1 + i = i + IStep + j = j + JStep + If (i < 1 Or i > 8) Or (j < 1 Or j > 8) Then + count = 0 + done = TRUE + End If + Else + done = TRUE + End If + Wend + CheckPath = count +End Function + +Sub ComputerMove + Dim As Integer BestMove, row, col, value, BestRow, BestCol + + BestMove = -99 + For row = 1 To 8 + For col = 1 To 8 + If GG(row, col).nTake > 0 Then + If GS.dLevel = "Novice" Then + value = GG(row, col).nTake + GW(row, col) + Else + value = GG(row, col).nTake + GW(row, col) + Select Case row + Case 1 + If col < 5 Then value = value + Abs(10 * GG(1, 1).player = COMP) + If col > 4 Then value = value + Abs(10 * GG(1, 8).player = COMP) + Case 2 + If GG(1, col).player <> COMP Then value = value + 5 * (GG(1, col).player = HUMAN) + If col > 1 And GG(1, col - 1).player <> COMP Then value = value + 5 * (GG(1, col - 1).player = HUMAN) + If col < 8 And GG(1, col + 1).player <> COMP Then value = value + 5 * (GG(1, col + 1).player = HUMAN) + Case 7 + If GG(8, col).player <> COMP Then value = value + 5 * (GG(8, col).player = HUMAN) + If col > 1 And GG(8, col - 1).player <> COMP Then value = value + 5 * (GG(8, col - 1).player = HUMAN) + If col < 8 And GG(8, col + 1).player <> COMP Then value = value + 5 * (GG(8, col + 1).player = HUMAN) + Case 8 + If col < 5 Then value = value + Abs(10 * GG(8, 1).player = COMP) + If col > 4 Then value = value + Abs(10 * GG(8, 8).player = COMP) + End Select + Select Case col + Case 1 + If row < 5 Then value = value + Abs(10 * GG(1, 1).player = COMP) + If row > 4 Then value = value + Abs(10 * GG(8, 1).player = COMP) + Case 2 + If GG(row, 1).player <> COMP Then value = value + 5 * (GG(row, 1).player = HUMAN) + If row > 1 And GG(row - 1, 1).player <> COMP Then value = value + 5 * (GG(row - 1, 1).player = HUMAN) + If row < 8 And GG(row + 1, 1).player <> COMP Then value = value + 5 * (GG(row + 1, 1).player = HUMAN) + Case 7 + If GG(row, 8).player <> COMP Then value = value + 5 * (GG(row, 8).player = HUMAN) + If row > 1 And GG(row - 1, 8).player <> COMP Then value = value + 5 * (GG(row - 1, 8).player = HUMAN) + If row < 8 And GG(row + 1, 8).player <> COMP Then value = value + 5 * (GG(row + 1, 8).player = HUMAN) + Case 8 + If row < 5 Then value = value + Abs(10 * GG(1, 8).player = COMP) + If row > 4 Then value = value + Abs(10 * GG(8, 8).player = COMP) + End Select + End If + If value > BestMove Then + BestMove = value + BestRow = row + BestCol = col + End If + End If + Next col + Next row + + TakeBlocks BestRow, BestCol, COMP + GS.stat = HUMAN +End Sub + +Sub DisplayHelp + Dim As Integer i + Dim a(1 To 18) As String, k As String + + a$(1) = "The object of Reversi is to finish the game with more of your red" + a$(2) = "circles on the board than the computer has of blue (Monochrome" + a$(3) = "monitors will show red as white and blue as black)." + a$(4) = "" + a$(5) = "1) You and the computer play by the same rules." + a$(6) = "2) To make a legal move, at least one of the computer's circles" + a$(7) = " must lie in a horizontal, vertical, or diagonal line between" + a$(8) = " one of your existing circles and the square where you want to" + a$(9) = " move. Use the arrow keys to position the cursor on the square" + a$(10) = " and hit Enter or the Space Bar." + a$(11) = "3) You can choose Pass from the game controls menu on your first" + a$(12) = " move to force the computer to play first." + a$(13) = "4) After your first move, you cannot pass if you can make a legal" + a$(14) = " move." + a$(15) = "5) If you cannot make a legal move, you must choose Pass" + a$(16) = "6) When neither you nor the computer can make a legal move, the" + a$(17) = " game is over." + a$(18) = "7) The one with the most circles wins." + + Line (0, 0)-(640, 480), BG, BF + Line (39, 15)-(590, 450), 0, B + If GBoard = 85 Then + Paint (200, 200), Chr$(85), 0 + Else + Paint (200, 200), GBoard, 0 + End If + Line (590, 25)-(600, 460), 0, BF + Line (50, 450)-(600, 460), 0, BF + + Locate 2, 35: Print "REVERSI HELP" + For i = 1 To 18 + Locate 3 + i, 7 + Print a$(i) + Next i + Locate 23, 25: Print "- Press any key to continue -" + Sleep: k = InKey$ + DrawGameBoard + DrawCursor GS.curRow, GS.curCol +End Sub + +Sub DisplayMsg (a As String) + Dim As Integer sLen, LX + + sLen = Len(a$) + LX = (640 - 8 * (sLen + 8)) / 2 + Line (LX - 1, 420)-(640 - LX, 447), 0, B + If GBoard = 85 Then + Paint (LX + 10, 430), Chr$(85), 0 + Else + Paint (LX + 10, 430), GBoard, 0 + End If + Locate 23, (80 - sLen) / 2 + Print a; + GS.mDisplay = TRUE +End Sub + +Sub DrawCursor (row As Integer, col As Integer) + Dim As Integer lc + + If GG(row, col).nTake > 0 Then + Circle (GG(row, col).cx, GG(row, col).cy), 15, HUMAN + Circle (GG(row, col).cx, GG(row, col).cy), 14, HUMAN + Else + lc = 0 + If GG(row, col).player = 0 Then lc = 7 + Line (GG(row, col).cx, GG(row, col).cy - 15)-(GG(row, col).cx, GG(row, col).cy + 15), lc + Line (GG(row, col).cx - 1, GG(row, col).cy - 15)-(GG(row, col).cx - 1, GG(row, col).cy + 15), lc + Line (GG(row, col).cx + 15, GG(row, col).cy)-(GG(row, col).cx - 15, GG(row, col).cy), lc + End If +End Sub + +Sub DrawGameBoard + Dim As Integer i, row, col + + Line (0, 0)-(640, 480), BG, BF + Line (239, 15)-(400, 40), 0, B + Line (39, 260)-(231, 390), 0, B + Line (39, 70)-(231, 220), 0, B + Line (269, 70)-(591, 390), 0, B + + If GBoard = 85 Then 'If b&w + Paint (300, 25), Chr$(85), 0 + Paint (150, 350), Chr$(85), 0 + Paint (150, 124), Chr$(85), 0 + Paint (450, 225), Chr$(85), 0 + Else + Paint (300, 25), GBoard, 0 + Paint (150, 350), GBoard, 0 + Paint (150, 124), GBoard, 0 + Paint (450, 225), GBoard, 0 + End If + Line (400, 25)-(410, 50), 0, BF + Line (250, 40)-(410, 50), 0, BF + Line (231, 80)-(240, 230), 0, BF + Line (50, 220)-(240, 230), 0, BF + Line (590, 80)-(600, 400), 0, BF + Line (280, 390)-(600, 400), 0, BF + Line (231, 270)-(240, 400), 0, BF + Line (50, 390)-(240, 400), 0, BF + + For i = 0 To 8 + Line (270, 70 + i * 40)-(590, 70 + i * 40), 0 + Line (270 + i * 40, 70)-(270 + i * 40, 390), 0 + Line (269 + i * 40, 70)-(269 + i * 40, 390), 0 + Next i + + Locate 2, 35: Print "R E V E R S I" + + Locate 5, 11: Print "Game Controls" + Locate 7, 7: Print "S = Start New Game" + Locate 8, 7: Print "P = Pass Turn" + Locate 9, 7: Print "D = Set Difficulty" + Locate 10, 7: Print "H = Display Help" + Locate 11, 7: Print "Q = Quit" + Locate 15, 12: Print "Game Status" + Locate 17, 7: Print "Your Score: "; GS.rScore; "" + Locate 18, 7: Print "Computer Score: "; GS.bScore + Locate 20, 7: Print "Difficulty: "; GS.dLevel + + For row = 1 To 8 + For col = 1 To 8 + If GG(row, col).player <> GBoard Then + DrawGamePiece row, col, GG(row, col).player + End If + Next col + Next row +End Sub + +Sub DrawGamePiece (row As Integer, col As Integer, GpColor As Integer) + If GBoard = 85 Then + Line (232 + col * 40, 33 + row * 40)-(267 + col * 40, 67 + row * 40), 7, BF + If GpColor <> GBoard Then + Circle (GG(row, col).cx, GG(row, col).cy), 15, 0 + Paint (GG(row, col).cx, GG(row, col).cy), GpColor, 0 + End If + Paint (235 + col * 40, 35 + row * 40), Chr$(85), 0 + Else + Circle (GG(row, col).cx, GG(row, col).cy), 15, GpColor + Circle (GG(row, col).cx, GG(row, col).cy), 14, GpColor + Paint (GG(row, col).cx, GG(row, col).cy), GpColor, GpColor + End If +End Sub + +Sub GameOver + Dim As Integer ScoreDiff + + ScoreDiff = GS.rScore - GS.bScore + If ScoreDiff = 0 Then + DisplayMsg "Tie Game" + ElseIf ScoreDiff < 0 Then + DisplayMsg "You lost by" + Print Abs(ScoreDiff) + Else + DisplayMsg "You won by" + Print ScoreDiff + End If + Do + GS.stat = Asc(Right$(InKey$, 1)) + Loop Until GS.stat = QUIT Or GS.stat = START + Line (0, 420)-(640, 447), BG, BF +End Sub + +Sub InitGame + Dim As Integer row, col, i, j + + Select Case smode + Case 9: + HUMAN = 4 + COMP = 1 + BG = 3 + GBoard = 8 + Case Else: + HUMAN = 7 + COMP = 0 + BG = 7 + If smode = 10 Then + GBoard = 1 + Else + GBoard = 85 + End If + End Select + + Window Screen(640, 480)-(0, 0) + GS.curCol = 5 + GS.curRow = 3 + GS.stat = FMOVE + GS.bScore = 2 + GS.rScore = 2 + GS.mDisplay = FALSE + + For row = 1 To 8 + For col = 1 To 8 + GG(row, col).player = GBoard + GG(row, col).nTake = 0 + GG(row, col).cx = 270 + (col - .5) * 40 + GG(row, col).cy = 70 + (row - .5) * 40 + GW(row, col) = 2 + Next col + Next row + GW(1, 1) = 99 + GW(1, 8) = 99 + GW(8, 1) = 99 + GW(8, 8) = 99 + For i = 3 To 6 + For j = 1 To 8 Step 7 + GW(i, j) = 5 + GW(j, i) = 5 + Next j + Next i + GG(4, 4).player = HUMAN + GG(5, 4).player = COMP + GG(4, 5).player = COMP + GG(5, 5).player = HUMAN +End Sub + +Sub TakeBlocks (row As Integer, col As Integer, player As Integer) + Dim As Integer i + + GG(row, col).player = player + DrawGamePiece row, col, player + + For i = 1 To GP(row, col, 1) + GG(row, col - i).player = player + DrawGamePiece row, col - i, player + Next i + For i = 1 To GP(row, col, 2) + GG(row, col + i).player = player + DrawGamePiece row, col + i, player + Next i + For i = 1 To GP(row, col, 3) + GG(row - i, col).player = player + DrawGamePiece row - i, col, player + Next i + For i = 1 To GP(row, col, 4) + GG(row + i, col).player = player + DrawGamePiece row + i, col, player + Next i + For i = 1 To GP(row, col, 5) + GG(row - i, col - i).player = player + DrawGamePiece row - i, col - i, player + Next i + For i = 1 To GP(row, col, 6) + GG(row + i, col + i).player = player + DrawGamePiece row + i, col + i, player + Next i + For i = 1 To GP(row, col, 7) + GG(row - i, col + i).player = player + DrawGamePiece row - i, col + i, player + Next i + For i = 1 To GP(row, col, 8) + GG(row + i, col - i).player = player + DrawGamePiece row + i, col - i, player + Next i + + If player = HUMAN Then + GS.rScore = GS.rScore + GG(row, col).nTake + 1 + GS.bScore = GS.bScore - GG(row, col).nTake + Else + GS.bScore = GS.bScore + GG(row, col).nTake + 1 + GS.rScore = GS.rScore - GG(row, col).nTake + End If + + Locate 17, 7: Print "Your Score: "; GS.rScore + Locate 18, 7: Print "Computer Score: "; GS.bScore +End Sub + +Sub UserMove + Dim k As String + Dim As Integer move + + DrawCursor GS.curRow, GS.curCol + Do + Do + k = InKey$ + Loop Until k <> "" + move = Asc(Right$(k, 1)) + If GS.mDisplay Then + Line (0, 420)-(640, 447), BG, BF + GS.mDisplay = FALSE + End If + Select Case move + Case 71 TO 81: + DrawGamePiece GS.curRow, GS.curCol, GG(GS.curRow, GS.curCol).player + If move < 74 Then + If GS.curRow = BBLOCK Then + GS.curRow = EBLOCK + Else + GS.curRow = GS.curRow - 1 + End If + ElseIf move > 78 Then + If GS.curRow = EBLOCK Then + GS.curRow = BBLOCK + Else + GS.curRow = GS.curRow + 1 + End If + End If + If move = 71 Or move = 75 Or move = 79 Then + If GS.curCol = BBLOCK Then + GS.curCol = EBLOCK + Else + GS.curCol = GS.curCol - 1 + End If + ElseIf move = 73 Or move = 77 Or move = 81 Then + If GS.curCol = EBLOCK Then + GS.curCol = BBLOCK + Else + GS.curCol = GS.curCol + 1 + End If + End If + DrawCursor GS.curRow, GS.curCol + Case START: + GS.stat = START + Case PASS: + If GS.stat = FMOVE Then + DisplayMsg "You passed. Computer will make first move." + GS.stat = COMP + Else + DisplayMsg "You can only pass on your first turn." + End If + Case HELP: + DisplayHelp + Case DIFF: + If GS.dLevel = "Novice" Then + GS.dLevel = "Expert" + Else + GS.dLevel = "Novice" + End If + Locate 20, 7 + Print "Difficulty: "; GS.dLevel; + Case ENTER, SPACE: + If GG(GS.curRow, GS.curCol).nTake > 0 Then + TakeBlocks GS.curRow, GS.curCol, HUMAN + GS.stat = COMP + Else + DisplayMsg "Invalid move. Move to a space where the cursor is a circle." + End If + Case QUIT: + GS.stat = QUIT + End Select + Loop Until GS.stat <> HUMAN And GS.stat <> FMOVE +End Sub + +Function ValidMove (Opponent As Integer) + Dim As Integer row, col + + ValidMove = FALSE + Erase GP + For row = 1 To 8 + For col = 1 To 8 + GG(row, col).nTake = 0 + + If GG(row, col).player = GBoard Then + If col > 2 Then + GP(row, col, 1) = CheckPath(row, row, 0, col - 1, 0, -1, Opponent) + GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 1) + End If + If col < 7 Then + GP(row, col, 2) = CheckPath(row, row, 0, col + 1, 9, 1, Opponent) + GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 2) + End If + If row > 2 Then + GP(row, col, 3) = CheckPath(row - 1, 0, -1, col, col, 0, Opponent) + GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 3) + End If + If row < 7 Then + GP(row, col, 4) = CheckPath(row + 1, 9, 1, col, col, 0, Opponent) + GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 4) + End If + If col > 2 And row > 2 Then + GP(row, col, 5) = CheckPath(row - 1, 0, -1, col - 1, 0, -1, Opponent) + GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 5) + End If + If col < 7 And row < 7 Then + GP(row, col, 6) = CheckPath(row + 1, 9, 1, col + 1, 9, 1, Opponent) + GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 6) + End If + If col < 7 And row > 2 Then + GP(row, col, 7) = CheckPath(row - 1, 0, -1, col + 1, 9, 1, Opponent) + GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 7) + End If + If col > 2 And row < 7 Then + GP(row, col, 8) = CheckPath(row + 1, 9, 1, col - 1, 0, -1, Opponent) + GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 8) + End If + If GG(row, col).nTake > 0 Then ValidMove = TRUE + End If + Next col + Next row +End Function + diff --git a/samples/rho-sigma.md b/samples/rho-sigma.md index 55e9efdc..07d0220d 100644 --- a/samples/rho-sigma.md +++ b/samples/rho-sigma.md @@ -8,61 +8,25 @@ '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Binary Clock](binary-clock/index.md)** +**[Kaleidoscope](kaleidoscope/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](fractal/index.md)** +**[Kaleidoscope Mill](kaleidoscope-mill/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](kaleidoscope/index.md)** +**[Splines](splines/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](kaleidoscope-mill/index.md)** - -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) - -'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... - -**[Bezier](lightning-one/index.md)** - -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) - -'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... - -**[Bezier](lightning-two/index.md)** - -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) - -'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... - -**[Bezier](multi-mill/index.md)** - -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) - -'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... - -**[Bezier](mystify/index.md)** - -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) - -'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... - -**[Bezier](splines/index.md)** - -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) - -'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... - -**[Bezier](worms/index.md)** +**[Worms](worms/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) diff --git a/samples/rhosigma.md b/samples/rhosigma.md new file mode 100644 index 00000000..ba156231 --- /dev/null +++ b/samples/rhosigma.md @@ -0,0 +1,39 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES BY RHOSIGMA + +**[Binary Clock](binary-clock/index.md)** + +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + +**[Fractal](fractal/index.md)** + +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + +**[Lightning One](lightning-one/index.md)** + +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + +**[Lightning Two](lightning-two/index.md)** + +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + +**[Multi-Mill](multi-mill/index.md)** + +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + +**[Mystify](mystify/index.md)** + +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... diff --git a/samples/richard-frost.md b/samples/richard-frost.md index 623fc537..febf9a81 100644 --- a/samples/richard-frost.md +++ b/samples/richard-frost.md @@ -7,3 +7,9 @@ [🐝 Richard Frost](richard-frost.md) 🔗 [image processing](image-processing.md) [This] is an image converter that takes a picture a small block at a time and finds the "best fit... + +**[Moon Lander](moon-lander/index.md)** + +[🐝 Richard Frost](richard-frost.md) 🔗 [game](game.md), [lander](lander.md) + +Lunar Lander based on a 1974 program running on a DEC PDP/11 with GT40 vector display terminal at... diff --git a/samples/rotations.md b/samples/rotations.md index 5f549a01..0f0b5cdc 100644 --- a/samples/rotations.md +++ b/samples/rotations.md @@ -2,7 +2,7 @@ ## SAMPLES: ROTATIONS -**[Rotating Lorenz Attractor](lorenz-attractor/index.md)** +**[Lorenz Attractor](lorenz-attractor/index.md)** [🐝 Vince](vince.md) 🔗 [lorenz](lorenz.md), [rotations](rotations.md) diff --git a/samples/rpg.md b/samples/rpg.md index ce8d018e..9c114d41 100644 --- a/samples/rpg.md +++ b/samples/rpg.md @@ -2,7 +2,7 @@ ## SAMPLES: RPG -**[Dragon Warrior 64](dragon-warrior/index.md)** +**[Dragon Warrior](dragon-warrior/index.md)** [🐝 Cobalt](cobalt.md) 🔗 [game](game.md), [rpg](rpg.md) diff --git a/samples/screenblanker.md b/samples/screenblanker.md index 943b05d4..cf65e186 100644 --- a/samples/screenblanker.md +++ b/samples/screenblanker.md @@ -10,59 +10,59 @@ **[Binary Clock](binary-clock/index.md)** -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](fractal/index.md)** +**[Fractal](fractal/index.md)** -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](kaleidoscope/index.md)** +**[Kaleidoscope](kaleidoscope/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](kaleidoscope-mill/index.md)** +**[Kaleidoscope Mill](kaleidoscope-mill/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](lightning-one/index.md)** +**[Lightning One](lightning-one/index.md)** -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](lightning-two/index.md)** +**[Lightning Two](lightning-two/index.md)** -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](multi-mill/index.md)** +**[Multi-Mill](multi-mill/index.md)** -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](mystify/index.md)** +**[Mystify](mystify/index.md)** -[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](splines/index.md)** +**[Splines](splines/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... -**[Bezier](worms/index.md)** +**[Worms](worms/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) diff --git a/samples/screensaver.md b/samples/screensaver.md index 6073c62f..a9fe43af 100644 --- a/samples/screensaver.md +++ b/samples/screensaver.md @@ -14,7 +14,7 @@ Created by QB64 community member bplus. Created by QB community member darokin. -**[GUJERO2](gujero2/index.md)** +**[Gujero2](gujero2/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [tunnel](tunnel.md) @@ -26,19 +26,19 @@ Created by QB community member darokin. 'Lissajous by Antoni Gual 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-----------------... -**[Mandala 9 Line](manadla/index.md)** +**[Manadla](manadla/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [9 lines](9-lines.md) 'Mandala by Antoni gual 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '-------------------... -**[Mandala 9 Line](pattern/index.md)** +**[Pattern](pattern/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [9 lines](9-lines.md) 'patterns 'for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 '---------------------------------... -**[Non-Palette Rotated Plasma](plasma-non-pal/index.md)** +**[Plasma Non-Pal](plasma-non-pal/index.md)** [🐝 Relsoft](relsoft.md) 🔗 [screensaver](screensaver.md), [plasma](plasma.md) diff --git a/samples/snake.md b/samples/snake.md index 44d76b64..6edaf477 100644 --- a/samples/snake.md +++ b/samples/snake.md @@ -2,6 +2,18 @@ ## SAMPLES: SNAKE +**[Nibbles](nibbles/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [snake](snake.md) + +Snake clone by Microsoft. + +**[Rattler](rattler/index.md)** + +[🐝 Bob Seguin](bob-seguin.md) 🔗 [game](game.md), [snake](snake.md) + +Snake clone by Bob Seguin. + **[Snake Basic](snake-basic/index.md)** [🐝 pcluddite](pcluddite.md) 🔗 [game](game.md), [snake](snake.md) diff --git a/samples/sort.md b/samples/sort.md index 60d25592..2069cb51 100644 --- a/samples/sort.md +++ b/samples/sort.md @@ -2,7 +2,7 @@ ## SAMPLES: SORT -**[Sort demo](sort-demo/index.md)** +**[Sort Demo](sort-demo/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [sort](sort.md) diff --git a/samples/sound.md b/samples/sound.md new file mode 100644 index 00000000..73601908 --- /dev/null +++ b/samples/sound.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: SOUND + +**[QSynth](qsynth/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [sound](sound.md), [music](music.md) + +Audio synthesizer by Microsoft. diff --git a/samples/space-shooter.md b/samples/space-shooter.md index eba1db7c..8c86b3b9 100644 --- a/samples/space-shooter.md +++ b/samples/space-shooter.md @@ -2,6 +2,12 @@ ## SAMPLES: SPACE SHOOTER +**[QTrek](qtrek/index.md)** + +[🐝 Philipp Strathausen](philipp-strathausen.md) 🔗 [game](game.md), [space shooter](space-shooter.md) + +Star Trek-like game by Philipp Strathausen. + **[Space64](space64/index.md)** [🐝 Cyperium](cyperium.md) 🔗 [game](game.md), [space shooter](space-shooter.md) diff --git a/samples/sphere.md b/samples/sphere.md index 5622535f..df705ae9 100644 --- a/samples/sphere.md +++ b/samples/sphere.md @@ -4,6 +4,6 @@ **[Globe](globe/index.md)** -[🐝 Glen Jeh](glen-jeh.md) [🐝 8/12/1994](8/12/1994.md) [🐝 William Yu (05-28-96)](william-yu-(05-28-96).md) 🔗 [3d](3d.md), [sphere](sphere.md) +[🐝 Jeh](jeh.md) [🐝 Yu](yu.md) 🔗 [3d](3d.md), [sphere](sphere.md) -'{A little rotating sphere, by Glen Jeh, 8/12/1994, use freely} '{Try messing with the constants.... +Glen Jeh, 8/12/1994, William Yu (05-28-96) '{A little rotating sphere, by Glen Jeh, 8/12/1994, u... diff --git a/samples/splines/index.md b/samples/splines/index.md index 95bad9e3..b1838167 100644 --- a/samples/splines/index.md +++ b/samples/splines/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: SPLINES ![screenshot.png](img/screenshot.png) diff --git a/samples/starfield.md b/samples/starfield.md index 91fed885..7efff164 100644 --- a/samples/starfield.md +++ b/samples/starfield.md @@ -8,7 +8,7 @@ Created by QB community member darokin. -**[Starfield 9 Line](starfield/index.md)** +**[Starfield](starfield/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [starfield](starfield.md), [9 lines](9-lines.md) diff --git a/samples/starfield/index.md b/samples/starfield/index.md index 78ce9a1a..34d85b0d 100644 --- a/samples/starfield/index.md +++ b/samples/starfield/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: STARFIELD 9 LINE +## SAMPLE: STARFIELD ![screenshot.png](img/screenshot.png) diff --git a/samples/steve-m..md b/samples/steve-m..md new file mode 100644 index 00000000..e6904051 --- /dev/null +++ b/samples/steve-m..md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES BY STEVE M. + +**[Mazes of Misery](mazes-of-misery/index.md)** + +[🐝 Steve M.](steve-m..md) 🔗 [game](game.md), [maze](maze.md) + +'Maze of Misery 'By Steve M. (c),May 5,01 '**************** 'Please visit my web page at: www.a... diff --git a/samples/tag-cloud.md b/samples/tag-cloud.md index 2410cd3e..809ba950 100644 --- a/samples/tag-cloud.md +++ b/samples/tag-cloud.md @@ -2,4 +2,4 @@ ## TAGS -[game:20](game.md) • [screenblanker:11](screenblanker.md) • [screensaver:10](screensaver.md) • [fractal:9](fractal.md) • [9 lines:8](9-lines.md) • [3d:5](3d.md) • [geometry:4](geometry.md) • [graphics:4](graphics.md) • [mandelbrot:4](mandelbrot.md) • [intersections:3](intersections.md) • [starfield:3](starfield.md) • [art:2](art.md) • [collisions:2](collisions.md) • [image processing:2](image-processing.md) • [julia set:2](julia-set.md) • [puzzle:2](puzzle.md) • [ray tracing:2](ray-tracing.md) • [space shooter:2](space-shooter.md) • [trigonometry:2](trigonometry.md) • [2 player:1](2-player.md) • [abacus:1](abacus.md) • [arithmetic:1](arithmetic.md) • [ascii:1](ascii.md) • [breakout:1](breakout.md) • [clock:1](clock.md) • [cube:1](cube.md) • [desktop:1](desktop.md) • [drawing:1](drawing.md) • [ellipse:1](ellipse.md) • [fern:1](fern.md) • [fibonacci:1](fibonacci.md) • [filled circle:1](filled-circle.md) • [fire:1](fire.md) • [flight:1](flight.md) • [floorscape:1](floorscape.md) • [gravity:1](gravity.md) • [lorenz:1](lorenz.md) • [maptriangle:1](maptriangle.md) • [matrix:1](matrix.md) • [mosaic:1](mosaic.md) • [multiplayer:1](multiplayer.md) • [particles:1](particles.md) • [pendulum:1](pendulum.md) • [physics:1](physics.md) • [plasma:1](plasma.md) • [platformer:1](platformer.md) • [pong:1](pong.md) • [reflections:1](reflections.md) • [ripple:1](ripple.md) • [rotations:1](rotations.md) • [rpg:1](rpg.md) • [shooter:1](shooter.md) • [snake:1](snake.md) • [sort:1](sort.md) • [sphere:1](sphere.md) • [tic tac toe:1](tic-tac-toe.md) • [tic tac toe rings:1](tic-tac-toe-rings.md) • [torus:1](torus.md) • [tower:1](tower.md) • [tunnel:1](tunnel.md) • [turtle graphics:1](turtle-graphics.md) • [wave motion:1](wave-motion.md) • [zen:1](zen.md) \ No newline at end of file +[game:34](game.md) • [screenblanker:11](screenblanker.md) • [screensaver:10](screensaver.md) • [fractal:9](fractal.md) • [9 lines:8](9-lines.md) • [3d:6](3d.md) • [graphics:5](graphics.md) • [geometry:4](geometry.md) • [mandelbrot:4](mandelbrot.md) • [data management:3](data-management.md) • [intersections:3](intersections.md) • [snake:3](snake.md) • [space shooter:3](space-shooter.md) • [starfield:3](starfield.md) • [art:2](art.md) • [ascii:2](ascii.md) • [breakout:2](breakout.md) • [collisions:2](collisions.md) • [drawing:2](drawing.md) • [image processing:2](image-processing.md) • [julia set:2](julia-set.md) • [maze:2](maze.md) • [puzzle:2](puzzle.md) • [ray tracing:2](ray-tracing.md) • [trigonometry:2](trigonometry.md) • [2 player:1](2-player.md) • [abacus:1](abacus.md) • [arithmetic:1](arithmetic.md) • [artillery:1](artillery.md) • [bitmap:1](bitmap.md) • [clock:1](clock.md) • [cube:1](cube.md) • [defense:1](defense.md) • [desktop:1](desktop.md) • [digger:1](digger.md) • [ellipse:1](ellipse.md) • [fern:1](fern.md) • [fibonacci:1](fibonacci.md) • [filled circle:1](filled-circle.md) • [fire:1](fire.md) • [flight:1](flight.md) • [floorscape:1](floorscape.md) • [gravity:1](gravity.md) • [lander:1](lander.md) • [lights:1](lights.md) • [lorenz:1](lorenz.md) • [maptriangle:1](maptriangle.md) • [matrix:1](matrix.md) • [mosaic:1](mosaic.md) • [multiplayer:1](multiplayer.md) • [music:1](music.md) • [particles:1](particles.md) • [pendulum:1](pendulum.md) • [physics:1](physics.md) • [plasma:1](plasma.md) • [platform:1](platform.md) • [platformer:1](platformer.md) • [pong:1](pong.md) • [raycaster:1](raycaster.md) • [reflections:1](reflections.md) • [ripple:1](ripple.md) • [rotations:1](rotations.md) • [rpg:1](rpg.md) • [shooter:1](shooter.md) • [sort:1](sort.md) • [sound:1](sound.md) • [sphere:1](sphere.md) • [tetris:1](tetris.md) • [tic tac toe:1](tic-tac-toe.md) • [tic tac toe rings:1](tic-tac-toe-rings.md) • [torus:1](torus.md) • [tower:1](tower.md) • [tunnel:1](tunnel.md) • [turtle graphics:1](turtle-graphics.md) • [wave motion:1](wave-motion.md) • [zen:1](zen.md) \ No newline at end of file diff --git a/samples/tetris.md b/samples/tetris.md new file mode 100644 index 00000000..16be3923 --- /dev/null +++ b/samples/tetris.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES: TETRIS + +**[QBlocks](qblocks/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [tetris](tetris.md) + +Tetris clone by Microsoft. diff --git a/samples/trigonometry.md b/samples/trigonometry.md index 797315f7..ec8e186a 100644 --- a/samples/trigonometry.md +++ b/samples/trigonometry.md @@ -4,7 +4,7 @@ **[Lissajous Curve Table](lissajous-curve-table/index.md)** -[🐝 FellippeHeitor](fellippeheitor.md) 🔗 [graphics](graphics.md), [trigonometry](trigonometry.md) +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [graphics](graphics.md), [trigonometry](trigonometry.md) Graphical Lissajou's Figures. For added eye-candy-ness, I've changed the plot line to paint usin... diff --git a/samples/tsiplacov-sergey.md b/samples/tsiplacov-sergey.md index d1b83728..7e2451bf 100644 --- a/samples/tsiplacov-sergey.md +++ b/samples/tsiplacov-sergey.md @@ -2,7 +2,7 @@ ## SAMPLES BY TSIPLACOV SERGEY -**[ArcDemo](arc-demo/index.md)** +**[Arc Demo](arc-demo/index.md)** [🐝 Tsiplacov Sergey](tsiplacov-sergey.md) 🔗 [game](game.md), [platformer](platformer.md) diff --git a/samples/tunnel.md b/samples/tunnel.md index b405d26f..fe37c1a7 100644 --- a/samples/tunnel.md +++ b/samples/tunnel.md @@ -2,7 +2,7 @@ ## SAMPLES: TUNNEL -**[GUJERO2](gujero2/index.md)** +**[Gujero2](gujero2/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [tunnel](tunnel.md) diff --git a/samples/vince.md b/samples/vince.md index 8610882e..475dbad3 100644 --- a/samples/vince.md +++ b/samples/vince.md @@ -2,13 +2,13 @@ ## SAMPLES BY VINCE -**[Chaotic Scattering - Gaspard-Rice system](chaotic-scattering/index.md)** +**[Chaotic Scattering](chaotic-scattering/index.md)** [🐝 vince](vince.md) 🔗 [ray tracing](ray-tracing.md), [reflections](reflections.md) Demo of the Gaspard-Rice system. Left-click to change location. -**[Rotating Lorenz Attractor](lorenz-attractor/index.md)** +**[Lorenz Attractor](lorenz-attractor/index.md)** [🐝 Vince](vince.md) 🔗 [lorenz](lorenz.md), [rotations](rotations.md) diff --git a/samples/william-yu-(05-28-96).md b/samples/william-yu-(05-28-96).md deleted file mode 100644 index bc406d4a..00000000 --- a/samples/william-yu-(05-28-96).md +++ /dev/null @@ -1,9 +0,0 @@ -[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) - -## SAMPLES BY WILLIAM YU (05-28-96) - -**[Globe](globe/index.md)** - -[🐝 Glen Jeh](glen-jeh.md) [🐝 8/12/1994](8/12/1994.md) [🐝 William Yu (05-28-96)](william-yu-(05-28-96).md) 🔗 [3d](3d.md), [sphere](sphere.md) - -'{A little rotating sphere, by Glen Jeh, 8/12/1994, use freely} '{Try messing with the constants.... diff --git a/samples/worms/index.md b/samples/worms/index.md index e0a0efa6..464c20a9 100644 --- a/samples/worms/index.md +++ b/samples/worms/index.md @@ -1,6 +1,6 @@ [Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md) -## SAMPLE: BEZIER +## SAMPLE: WORMS ![screenshot.png](img/screenshot.png) diff --git a/samples/yu.md b/samples/yu.md new file mode 100644 index 00000000..68c9c51f --- /dev/null +++ b/samples/yu.md @@ -0,0 +1,9 @@ +[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md) + +## SAMPLES BY YU + +**[Globe](globe/index.md)** + +[🐝 Jeh](jeh.md) [🐝 Yu](yu.md) 🔗 [3d](3d.md), [sphere](sphere.md) + +Glen Jeh, 8/12/1994, William Yu (05-28-96) '{A little rotating sphere, by Glen Jeh, 8/12/1994, u...