diff --git a/samples.md b/samples.md index 4252c5f..0bb0122 100644 --- a/samples.md +++ b/samples.md @@ -3,69 +3,122 @@ ## SAMPLES - **[3D Cube](samples/3d-cube/index.md)** • [Relsoft](samples/relsoft.md) [3d](samples/3d.md), [cube](samples/cube.md) +- **[3D Engine Prototypes](samples/3d-engine-prototypes/index.md)** • [STxAxTIC](samples/stxaxtic.md) [3d](samples/3d.md), [graph](samples/graph.md) +- **[3D Grapher](samples/3d-grapher/index.md)** • [Ashish Kushwaha](samples/ashish-kushwaha.md) • [STxAxTIC](samples/stxaxtic.md) [3d](samples/3d.md), [gl](samples/gl.md) +- **[3DS Viewer](samples/3ds-viewer/index.md)** • [*missing*](samples/author-missing.md) [3d](samples/3d.md), [wireframe](samples/wireframe.md), [legacy](samples/legacy.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) - **[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) +- **[Bad Box Revenge](samples/bad-box-revenge/index.md)** • [Terry Ritchie](samples/terry-ritchie.md) [game](samples/game.md), [bad boxes](samples/bad-boxes.md) +- **[Bad Boxes](samples/bad-boxes/index.md)** • [Terry Ritchie](samples/terry-ritchie.md) [game](samples/game.md), [bad boxes](samples/bad-boxes.md) +- **[Bar Demo](samples/bar-demo/index.md)** • [Douglas Park](samples/douglas-park.md) [tui](samples/tui.md), [dos world](samples/dos-world.md) +- **[Beatdown](samples/beatdown/index.md)** • [Brian Murphy](samples/brian-murphy.md) [game](samples/game.md), [legacy](samples/legacy.md) - **[Bezier](samples/bezier/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) +- **[Binary Clock](samples/binary-clock/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Binary Counter](samples/binary-counter/index.md)** • [rpgfan3233](samples/rpgfan3233.md) [binary](samples/binary.md), [counter](samples/counter.md) +- **[Biorhythm Chart](samples/biorhythm-chart/index.md)** • [Bob Seguin](samples/bob-seguin.md) [biorhythms](samples/biorhythms.md) - **[Blockout](samples/blockout/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [breakout](samples/breakout.md) +- **[Breakout](samples/breakout/index.md)** • [kinem](samples/kinem.md) [game](samples/game.md), [breakout](samples/breakout.md) +- **[Calc](samples/calc/index.md)** • [William Loughner](samples/william-loughner.md) [calculator](samples/calculator.md), [dos world](samples/dos-world.md) +- **[Calendar](samples/calendar/index.md)** • [A&A De Pasquale](samples/a&a-de-pasquale.md) [calendar](samples/calendar.md), [pdf](samples/pdf.md), [dos world](samples/dos-world.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](samples/chaotic-scattering/index.md)** • [vince](samples/vince.md) [ray tracing](samples/ray-tracing.md), [reflections](samples/reflections.md) +- **[Chess](samples/chess/index.md)** • [Richard Frost](samples/richard-frost.md) [game](samples/game.md), [chess](samples/chess.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) +- **[Cloned Shades](samples/cloned-shades/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md) - **[Colliding Ball Simulation](samples/colliding-ball-simulation/index.md)** • [Timothy Baxendale](samples/timothy-baxendale.md) [physics](samples/physics.md), [collisions](samples/collisions.md) +- **[Colors](samples/colors/index.md)** • [Hardin Brothers](samples/hardin-brothers.md) [color picker](samples/color-picker.md), [dos world](samples/dos-world.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) +- **[Conways Game of Life](samples/conways-game-of-life/index.md)** • [Luke](samples/luke.md) [automata](samples/automata.md), [conway](samples/conway.md) +- **[Cram](samples/cram/index.md)** • [Hardin Brothers](samples/hardin-brothers.md) [game](samples/game.md), [dos world](samples/dos-world.md) +- **[Curve Smoother](samples/curve-smoother/index.md)** • [STxAxTIC](samples/stxaxtic.md) • [Fellippe Heitor](samples/fellippe-heitor.md) [curve](samples/curve.md), [interpolation](samples/interpolation.md) - **[Darokin](samples/darokin/index.md)** • [darokin](samples/darokin.md) [screensaver](samples/screensaver.md), [starfield](samples/starfield.md) +- **[Dec to Frac](samples/dec-to-frac/index.md)** • [A&A De Pasquale](samples/a&a-de-pasquale.md) [math](samples/math.md), [dos world](samples/dos-world.md) +- **[Diamond Pong](samples/diamond-pong/index.md)** • [John Wolfskill](samples/john-wolfskill.md) [game](samples/game.md), [pong](samples/pong.md), [dos world](samples/dos-world.md) +- **[Didris](samples/didris/index.md)** • [Dietmar Moritz](samples/dietmar-moritz.md) [game](samples/game.md), [tetris](samples/tetris.md) +- **[Double Pendulum](samples/double-pendulum/index.md)** • [*missing*](samples/author-missing.md) [physics](samples/physics.md), [pendulum](samples/pendulum.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) +- **[Eliza](samples/eliza/index.md)** • [*missing*](samples/author-missing.md) [ai](samples/ai.md), [eliza](samples/eliza.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) +- **[Fibonacci Variations](samples/fibonacci-variations/index.md)** • [STxAxTIC](samples/stxaxtic.md) [fibonacci](samples/fibonacci.md), [spiral](samples/spiral.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) +- **[Fire 13](samples/fire-13/index.md)** • [*missing*](samples/author-missing.md) [fire](samples/fire.md), [graphics](samples/graphics.md) +- **[Fire Demo](samples/fire-demo/index.md)** • [harixxx](samples/harixxx.md) [graphics](samples/graphics.md), [fire](samples/fire.md) +- **[Flappy Bird](samples/flappy-bird/index.md)** • [Terry Ritchie](samples/terry-ritchie.md) [game](samples/game.md), [flappy bird](samples/flappy-bird.md) - **[Floormaper](samples/floormaper/index.md)** • [Antoni Gual](samples/antoni-gual.md) [graphics](samples/graphics.md), [floorscape](samples/floorscape.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) +- **[Frogger](samples/frogger/index.md)** • [Matt Bross](samples/matt-bross.md) [game](samples/game.md), [frogger](samples/frogger.md) +- **[Frostbite](samples/frostbite/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [frostbite](samples/frostbite.md) +- **[Future Blocks](samples/future-blocks/index.md)** • [Michael Fogleman](samples/michael-fogleman.md) [game](samples/game.md), [tetris](samples/tetris.md) +- **[Ghost Wizard](samples/ghost-wizard/index.md)** • [Zack Johnson](samples/zack-johnson.md) [game](samples/game.md), [roguelike](samples/roguelike.md) - **[Globe](samples/globe/index.md)** • [Jeh](samples/jeh.md) • [Yu](samples/yu.md) [3d](samples/3d.md), [sphere](samples/sphere.md) +- **[Gorillas](samples/gorillas/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [artillery](samples/artillery.md) - **[Gujero2](samples/gujero2/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [tunnel](samples/tunnel.md) +- **[Hangman](samples/hangman/index.md)** • [A&A De Pasquale](samples/a&a-de-pasquale.md) [game](samples/game.md), [hangman](samples/hangman.md), [dos world](samples/dos-world.md) - **[Helicopter Rescue](samples/helicopter-rescue/index.md)** • [TrialAndTerror](samples/trialandterror.md) [game](samples/game.md), [3d](samples/3d.md), [flight](samples/flight.md) +- **[Hunter](samples/hunter/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [maze](samples/maze.md) +- **[Hunters Revenge](samples/hunters-revenge/index.md)** • [Ashish Kushwaha](samples/ashish-kushwaha.md) [game](samples/game.md), [shooter](samples/shooter.md) +- **[Integrators](samples/integrators/index.md)** • [STxAxTIC](samples/stxaxtic.md) [physics](samples/physics.md), [simulation](samples/simulation.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) +- **[Jpeg Maker](samples/jpeg-maker/index.md)** • [Artelius](samples/artelius.md) [jpeg](samples/jpeg.md), [image manipulation](samples/image-manipulation.md) - **[Julia Rings](samples/julia-rings/index.md)** • [Relsoft](samples/relsoft.md) [fractal](samples/fractal.md), [julia set](samples/julia-set.md) - **[Kaleidoscope](samples/kaleidoscope/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Kaleidoscope 3D](samples/kaleidoscope-3d/index.md)** • [qbguy](samples/qbguy.md) [3d](samples/3d.md), [art](samples/art.md) +- **[Kaleidoscope Doodler](samples/kaleidoscope-doodler/index.md)** • [qbguy](samples/qbguy.md) [art](samples/art.md), [drawing](samples/drawing.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) +- **[Lens Simulator](samples/lens-simulator/index.md)** • [STxAxTIC](samples/stxaxtic.md) [2d](samples/2d.md), [ray tracer](samples/ray-tracer.md) +- **[Letter Blast](samples/letter-blast/index.md)** • [A&A De Pasquale](samples/a&a-de-pasquale.md) [game](samples/game.md), [letter](samples/letter.md), [dos world](samples/dos-world.md) +- **[Lightning One](samples/lightning-one/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Lightning Two](samples/lightning-two/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) - **[LightsOn](samples/lightson/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [lights](samples/lights.md) +- **[Lines Intersecting](samples/lines-intersecting/index.md)** • [STxAxTIC](samples/stxaxtic.md) [geometry](samples/geometry.md), [intersections](samples/intersections.md) +- **[Lisp Interpreter](samples/lisp-interpreter/index.md)** • [qbguy](samples/qbguy.md) [interpreter](samples/interpreter.md), [lisp](samples/lisp.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) +- **[Loan Amortization](samples/loan-amortization/index.md)** • [Alan Zeichick](samples/alan-zeichick.md) [finance](samples/finance.md), [dos world](samples/dos-world.md) - **[Lorenz Attractor](samples/lorenz-attractor/index.md)** • [Vince](samples/vince.md) [lorenz](samples/lorenz.md), [rotations](samples/rotations.md) +- **[Lucid Drawing](samples/lucid-drawing/index.md)** • [Lucid](samples/lucid.md) [2d](samples/2d.md), [draw](samples/draw.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 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) +- **[Mandelbrot Spiral](samples/mandelbrot-spiral/index.md)** • [qbguy](samples/qbguy.md) [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md) +- **[Mandelbrot Zoomer](samples/mandelbrot-zoomer/index.md)** • [Tor Myklebust](samples/tor-myklebust.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) +- **[Measure](samples/measure/index.md)** • [A&A De Pasquale](samples/a&a-de-pasquale.md) [measure](samples/measure.md), [dos world](samples/dos-world.md) - **[Mini Clock](samples/mini-clock/index.md)** • [Folker Fritz](samples/folker-fritz.md) [clock](samples/clock.md), [desktop](samples/desktop.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) +- **[MS Phone](samples/ms-phone/index.md)** • [Microsoft](samples/microsoft.md) [data management](samples/data-management.md) +- **[Multi-Mill](samples/multi-mill/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[MyCraft](samples/mycraft/index.md)** • [Galleon](samples/galleon.md) [game](samples/game.md), [minecraft](samples/minecraft.md) +- **[Mystify](samples/mystify/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[Names](samples/names/index.md)** • [David Bannon](samples/david-bannon.md) [data management](samples/data-management.md), [dos world](samples/dos-world.md) - **[Nibbles](samples/nibbles/index.md)** • [Microsoft](samples/microsoft.md) [game](samples/game.md), [snake](samples/snake.md) +- **[Parabolas](samples/parabolas/index.md)** • [STxAxTIC](samples/stxaxtic.md) [zen](samples/zen.md) - **[Particle Fountain](samples/particle-fountain/index.md)** • [bplus](samples/bplus.md) [particles](samples/particles.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) -- **[Phone](samples/phone/index.md)** • [Microsoft](samples/microsoft.md) [data management](samples/data-management.md) +- **[Phone](samples/phone/index.md)** • [Hardin Brothers](samples/hardin-brothers.md) [data management](samples/data-management.md), [dos world](samples/dos-world.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 Effect](samples/plasma-effect/index.md)** • [Cyperium](samples/cyperium.md) [graphics](samples/graphics.md), [plasma](samples/plasma.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) +- **[QB Clock](samples/qb-clock/index.md)** • [Alan Zeichick](samples/alan-zeichick.md) [clock](samples/clock.md) +- **[QB Tank Commander](samples/qb-tank-commander/index.md)** • [Matthew River Knight](samples/matthew-river-knight.md) [game](samples/game.md), [tank](samples/tank.md) +- **[QB-NVentory](samples/qb-nventory/index.md)** • [Nathan Thomas](samples/nathan-thomas.md) [data management](samples/data-management.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) @@ -77,10 +130,16 @@ - **[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) +- **[Ray Tracer Z](samples/ray-tracer-z/index.md)** • [Zom-B](samples/zom-b.md) [3d](samples/3d.md), [ray tracer](samples/ray-tracer.md) - **[RayCaster](samples/raycaster/index.md)** • [Antoni Gual](samples/antoni-gual.md) [3d](samples/3d.md), [raycaster](samples/raycaster.md) +- **[Relief 3D](samples/relief-3d/index.md)** • [Danilin](samples/danilin.md) [graphics](samples/graphics.md), [isometric](samples/isometric.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) +- **[Robo Raider](samples/robo-raider/index.md)** • [Kevin](samples/kevin.md) [game](samples/game.md) +- **[Rockets](samples/rockets/index.md)** • [*missing*](samples/author-missing.md) [screensaver](samples/screensaver.md), [particles](samples/particles.md) - **[Rotozoomer](samples/rotozoomer/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) +- **[Saver](samples/saver/index.md)** • [David Ferrier](samples/david-ferrier.md) [screensaver](samples/screensaver.md), [dos world](samples/dos-world.md) +- **[Schemat](samples/schemat/index.md)** • [Leif J. Burrow](samples/leif-j.-burrow.md) [circuits](samples/circuits.md), [schematics](samples/schematics.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) - **[Shooter](samples/shooter/index.md)** • [*missing*](samples/author-missing.md) [game](samples/game.md), [shooter](samples/shooter.md) - **[Sine Wave Explorer](samples/sine-wave-explorer/index.md)** • [*missing*](samples/author-missing.md) [trigonometry](samples/trigonometry.md) @@ -93,13 +152,20 @@ - **[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) +- **[Stock Watcher](samples/stock-watcher/index.md)** • [*missing*](samples/author-missing.md) [money](samples/money.md), [stocks](samples/stocks.md) +- **[Super Mario Jump](samples/super-mario-jump/index.md)** • [Terry Ritchie](samples/terry-ritchie.md) [game](samples/game.md), [mario](samples/mario.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) +- **[Tic Tac Toe 3D](samples/tic-tac-toe-3d/index.md)** • [qbguy](samples/qbguy.md) [game](samples/game.md), [tic tac toe](samples/tic-tac-toe.md) - **[Tic Tac Toe Rings](samples/tic-tac-toe-rings/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [game](samples/game.md), [tic tac toe rings](samples/tic-tac-toe-rings.md) - **[Torus Demo](samples/torus-demo/index.md)** • [Microsoft](samples/microsoft.md) [geometry](samples/geometry.md), [torus](samples/torus.md) - **[Tower of Hanoi](samples/tower-of-hanoi/index.md)** • [*missing*](samples/author-missing.md) [game](samples/game.md), [tower](samples/tower.md) +- **[Trig Demo](samples/trig-demo/index.md)** • [STxAxTIC](samples/stxaxtic.md) [trigonometry](samples/trigonometry.md) +- **[TUI](samples/tui/index.md)** • [Fellippe Heitor](samples/fellippe-heitor.md) [interface](samples/interface.md), [tui](samples/tui.md) - **[Turtle Graphics](samples/turtle-graphics/index.md)** • [triggered](samples/triggered.md) [fractal](samples/fractal.md), [turtle graphics](samples/turtle-graphics.md) - **[Twirl](samples/twirl/index.md)** • [Antoni Gual](samples/antoni-gual.md) [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md) +- **[Vector Field](samples/vector-field/index.md)** • [STxAxTIC](samples/stxaxtic.md) [2d](samples/2d.md), [vectors](samples/vectors.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) - **[Worms](samples/worms/index.md)** • [Rho Sigma](samples/rho-sigma.md) [screenblanker](samples/screenblanker.md) +- **[XE Hex Editor](samples/xe-hex-editor/index.md)** • [Dav](samples/dav.md) [editor](samples/editor.md), [hex](samples/hex.md) diff --git a/samples/2d.md b/samples/2d.md new file mode 100644 index 0000000..24c3e8b --- /dev/null +++ b/samples/2d.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: 2D + +**[Lens Simulator](lens-simulator/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [2d](2d.md), [ray tracer](ray-tracer.md) + +This program simulates light rays passing through a lens with a given index of refraction and con... + +**[Lucid Drawing](lucid-drawing/index.md)** + +[🐝 Lucid](lucid.md) 🔗 [2d](2d.md), [draw](draw.md) + +Drawing program by Lucid. + +**[Vector Field](vector-field/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [2d](2d.md), [vectors](vectors.md) + +Vector field demonstration. diff --git a/samples/3d-cube/index.md b/samples/3d-cube/index.md index 160cd62..053ea06 100644 --- a/samples/3d-cube/index.md +++ b/samples/3d-cube/index.md @@ -22,9 +22,9 @@ Relsoft 2003 > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "3dcube25.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/3d-cube/src/3dcube25.bas) -* [RUN "3dcube25.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/3d-cube/src/3dcube25.bas) -* [PLAY "3dcube25.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/3d-cube/src/3dcube25.bas) +* [LOAD "3dcube25.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/3d-cube/src/3dcube25.bas) +* [RUN "3dcube25.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/3d-cube/src/3dcube25.bas) +* [PLAY "3dcube25.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/3d-cube/src/3dcube25.bas) ### File(s) diff --git a/samples/3d-engine-prototypes/img/3dengineqb.png b/samples/3d-engine-prototypes/img/3dengineqb.png new file mode 100644 index 0000000..0dbaf81 Binary files /dev/null and b/samples/3d-engine-prototypes/img/3dengineqb.png differ diff --git a/samples/3d-engine-prototypes/img/3dengineqb2.png b/samples/3d-engine-prototypes/img/3dengineqb2.png new file mode 100644 index 0000000..8b75a3f Binary files /dev/null and b/samples/3d-engine-prototypes/img/3dengineqb2.png differ diff --git a/samples/3d-engine-prototypes/index.md b/samples/3d-engine-prototypes/index.md new file mode 100644 index 0000000..fe1efb1 --- /dev/null +++ b/samples/3d-engine-prototypes/index.md @@ -0,0 +1,26 @@ +[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: 3D ENGINE PROTOTYPES + +![3dengineqb.png](img/3dengineqb.png) + +### Author + +[🐝 STxAxTIC](../stxaxtic.md) + +### Description + +```text +Various experiments in software 3D graphics. Warning: Uses no functions or subs! +``` + +### File(s) + +* [3dctrwgraph_fb64.bas](src/3dctrwgraph_fb64.bas) +* [3dctrwgraph_fb64.zip](src/3dctrwgraph_fb64.zip) + +### Additional Image(s) + +![3dengineqb2.png](img/3dengineqb2.png) + +🔗 [3d](../3d.md), [graph](../graph.md) diff --git a/samples/3d-engine-prototypes/src/3dctrwgraph_fb64.bas b/samples/3d-engine-prototypes/src/3dctrwgraph_fb64.bas new file mode 100644 index 0000000..213c9b8 --- /dev/null +++ b/samples/3d-engine-prototypes/src/3dctrwgraph_fb64.bas @@ -0,0 +1,6455 @@ +'#lang "qb" '...for freebasic compiler. Must disable for QB64 features. + +' *** Video settings. *** + +screenwidth = 640 +screenheight = 480 +SCREEN 12 + +' *** Performance settings. *** + +bignumber = 500000 ' Maximum objects per array (determined by memory). +globaldelayinit = 1000 ' Loop damping factor (fine adjustment below). +RANDOMIZE TIMER + +' *** Initialize counters and array sizes. *** + +numparticleorig = bignumber +numparticlevisible = bignumber +numdoubletorig = bignumber +numdoubletclip = bignumber +numdoubletclipwork = bignumber +numdoubletsnip = bignumber +numdoubletsnipwork = bignumber +numdoubletintinfo = bignumber +numtripletorig = bignumber +numtripletfaceon = bignumber +numtripletclip = bignumber +numtripletclipwork = bignumber +numtripletsnip = bignumber +numtripletsnipimage = bignumber +numtripletsnipwork = bignumber +numtripletencpoint = bignumber +numtripletintpointpair = bignumber +numtripletfinal = bignumber + +' *** Define basis arrays and structures. *** + +' Screen vectors in three-space. +' These vectors define the camera angle. +DIM uhat(1 TO 3), vhat(1 TO 3), nhat(1 TO 3) + +' View clipping planes defined in three-space. +DIM nearplane(1 TO 4), farplane(1 TO 4), rightplane(1 TO 4), leftplane(1 TO 4), topplane(1 TO 4), bottomplane(1 TO 4) +DIM nearplanespotlight(1 TO 4), farplanespotlight(1 TO 4), rightplanespotlight(1 TO 4), leftplanespotlight(1 TO 4), topplanespotlight(1 TO 4), bottomplanespotlight(1 TO 4) + +' Basis vectors defined in three-space. +DIM xhat(1 TO 4), yhat(1 TO 4), zhat(1 TO 4) +xhat(1) = 1: xhat(2) = 0: xhat(3) = 0: xhat(4) = 4 +yhat(1) = 0: yhat(2) = 1: yhat(3) = 0: yhat(4) = 2 +zhat(1) = 0: zhat(2) = 0: zhat(3) = 1: zhat(4) = 1 + +' Basis vectors projected into uv two-space. +DIM xhatp(1 TO 2), yhatp(1 TO 2), zhatp(1 TO 2) +DIM xhatp.old(1 TO 2), yhatp.old(1 TO 2), zhatp.old(1 TO 2) + +' *** Define particle arrays and structures. *** + +' Particle vectors defined in three-space. +DIM vec(numparticleorig, 4) +DIM vecdotnhat(numparticleorig) +DIM vecdotnhatunit.old(numparticleorig) +DIM vecvisible(numparticlevisible, 4) +DIM vecvisibledotnhat(numparticlevisible) +DIM vecvisibledotnhatunit.old(numparticlevisible) + +' Particle vectors projected onto infinite uv two-space. +DIM vecpuv(numparticleorig, 1 TO 2) +DIM vecpuv.old(numparticleorig, 1 TO 2) +DIM vecvisiblepuv(numparticlevisible, 1 TO 2) +DIM vecvisiblepuv.old(numparticlevisible, 1 TO 2) + +' Particle projections adjusted for screen uv two-space. +DIM vecpuvs(numparticleorig, 1 TO 2) +DIM vecpuvs.old(numparticleorig, 1 TO 2) +DIM vecvisiblepuvs(numparticlevisible, 1 TO 2) +DIM vecvisiblepuvs.old(numparticlevisible, 1 TO 2) + +' *** Define doublet arrays and structures. *** + +' Doublet vectors defined in three-space. +DIM doubletorig(numdoubletorig, 7) + +' Doublet vectors clipped by view planes. +DIM doubletclip(numdoubletclip, 7) +DIM doubletclipdotnhat(numdoubletclip, 2) +DIM doubletclipdotnhat.old(numdoubletclip, 2) +DIM doubletclipwork(numdoubletclipwork, 7) +DIM doubletclipworkdotnhat(numdoubletclipwork, 2) +DIM doubletclipworkdotnhat.old(numdoubletclipwork, 2) + +' Doublet vectors clipped and projected onto infinite uv two-space. +DIM doubletclippuv(numdoubletclip, 4) +DIM doubletclippuv.old(numdoubletclip, 4) + +' Doublet vectors snipped by apparent intersections. +DIM doubletsnip(numdoubletsnip, 7) +DIM doubletsnipwork(numdoubletsnipwork, 7) +DIM doubletsnipdotnhat(numdoubletsnip, 2) +DIM doubletsnipdotnhat.old(numdoubletsnip, 2) + +' Doublet vectors snipped and projected onto infinite uv two-space. +DIM doubletsnippuv(numdoubletsnip, 4) +DIM doubletsnippuv.old(numdoubletsnip, 4) + +' Array information inferred from apparent intersections. +DIM doubletintinfo(numdoubletintinfo, 2) + +' Doublet projections adjusted for screen uv two-space. +DIM doubletsnippuvs(numdoubletsnip, 4) +DIM doubletsnippuvs.old(numdoubletsnip, 4) +DIM doubletclippuvs(numdoubletclip, 4) +DIM doubletclippuvs.old(numdoubletclip, 4) + +' *** Define triplet arrays and structures. *** + +' Triplet vectors defined in three-space. +DIM tripletorig(numtripletorig, 10) + +' Triplet vectors after discarding outfacing members. +DIM tripletfaceon(numtripletfaceon, 10) +DIM tripletfaceondotnhat(numtripletfaceon, 3) +DIM tripletfaceondotnhat.old(numtripletfaceon, 3) + +' Triplet vectors clipped by view planes. +DIM tripletclip(numtripletclip, 10) +DIM tripletclipdotnhat(numtripletclip, 3) +DIM tripletclipdotnhat.old(numtripletclip, 3) +DIM tripletclipwork(numtripletclipwork, 10) +DIM tripletclipworkdotnhat(numtripletclipwork, 3) +DIM tripletclipworkdotnhat.old(numtripletclipwork, 3) + +' Triplet vectors clipped and projected onto infinite uv two-space. +DIM tripletfaceonpuv(numtripletfaceon, 6) +DIM tripletfaceonpuv.old(numtripletfaceon, 6) +DIM tripletclippuv(numtripletclip, 6) +DIM tripletclippuv.old(numtripletclip, 6) + +' Triplet vectors snipped by apparent intersections. +DIM tripletsnip(numtripletsnip, 10) +DIM tripletsnipimage(numtripletsnipimage, 10) +DIM tripletsnipwork(numtripletsnipwork, 10) +DIM tripletsnipdotnhat(numtripletsnip, 3) +DIM tripletsnipdotnhat.old(numtripletsnip, 3) +DIM tripletfinal(numtripletfinal, 10) +DIM tripletfinaldotnhat(numtripletfinal, 3) +DIM tripletfinaldotnhat.old(numtripletfinal, 3) + +' Triplet vectors snipped and projected onto infinite uv two-space. +'DIM tripletsnippuv(numtripletsnip, 7) +'DIM tripletsnippuv.old(numtripletsnip, 7) +DIM tripletfinalpuv(numtripletfinal, 7) +DIM tripletfinalpuv.old(numtripletfinal, 7) + +' Array information inferred from apparent intersections. +DIM tripletencpoint(9, 8) +DIM tripletintpointpair(9, 21) + +' Triplet projections adjusted for screen uv two-space. +DIM tripletfinalpuvs(numtripletfinal, 6) +DIM tripletfinalpuvs.old(numtripletfinal, 6) + +' *** Define specialized arrays and structures. *** + +' Arrays for tech 2 mesh plotting. +DIM plotflag(numparticleorig) +DIM plotflag.old(numparticleorig) + +' Binary switches for triangle snip algorithm. +snip000enabled = 1 +snip004enabled = 1 +snip030enabled = 1 +snip003enabled = 1 +snip006enabled = 1 +snip012enabled = 1 +snip102enabled = 1 +snip112enabled = 1 +snip022enabled = 1 +snip202enabled = 1 +snip122enabled = 1 +snip212enabled = 1 +snip014enabled = 1 +snip104enabled = 1 +snip114enabled = 1 + +' *** Set mathematical constants. *** + +pi = 3.1415926536 +ee = 2.7182818285 + +mainstart: + +' *** Initialize user input variables. *** +key$ = "" +'mousekey$ = "" + +' *** Show first visual. *** + +CLS +COLOR 15 +PRINT " *** Welcome to 3DCTRWGRAPH ***" +PRINT " by: William F. Barnes" +PRINT +PRINT " 3D Graphics and Physics Engine" +PRINT +COLOR 14 +PRINT " -3D World Prototypes-" +PRINT " 1: 3D world made of only particles. (Type 'file' to load object3d.txt)" +PRINT " 2: 3D world made of line segments with three-space clipping feature." +PRINT " 3: 3D polygon world using advanded three-space clipping algorithm." +COLOR 15 +PRINT +PRINT " -Plotting and Geometry Demonstrations-" +PRINT " 4: Parameterized curve with linear point connecting." +PRINT " 5: Parameterized surface made of single points." +PRINT " 6: Molecule with atoms connected by lines." +PRINT " 7: Abstract 3D objects with near-neighbor tiling." +PRINT " 8: Time-animated surface in simple mesh tiling." +PRINT " 9: Time-animated surface in tech-2 mesh tiling." +COLOR 8 +PRINT " 10: Spherical harmonics (in development) in single point plot mode." +COLOR 15 +PRINT +PRINT " -Physics Engine Demonstrations-" +PRINT " 11: Solution to 2D Laplace equation via relaxation in tech-2 mesh tiling." +PRINT " 12: Sphere with random surface features in tech-2 custom mesh tiling." +PRINT " 13: Wave 2D propagation on flexible membrane in simple mesh tiling." +PRINT " 14: Waves on infinite surface in simple mesh tiling." +PRINT " 15: Brownian mating bacteria in custom single point plot mode." +PRINT " 16: Elementary neural network with three-space neighbor-connections." +PRINT: INPUT " Enter a choice (99 to quit) and press ENTER: ", a$ + +' *** Process first user input. *** + +SELECT CASE a$ + CASE "1": genscheme$ = "3denvparticles": plotmode$ = "3denvparticles" + CASE "file": genscheme$ = "3denvparticlesfile": plotmode$ = "3denvparticles" + CASE "2": genscheme$ = "3denvdoublets": plotmode$ = "3denvdoublets" + CASE "3": genscheme$ = "3denvtriplets": plotmode$ = "3denvtriplets" + CASE "4": genscheme$ = "curve": plotmode$ = "linearconnect" + CASE "5": genscheme$ = "simplepoints": plotmode$ = "simplepoints" + CASE "6": genscheme$ = "molecule": plotmode$ = "molecule" + CASE "7": genscheme$ = "neighbortile": plotmode$ = "neighbortile" + CASE "8": genscheme$ = "animatedflag": plotmode$ = "simplemesh" + CASE "9": genscheme$ = "animatedpretzel": plotmode$ = "meshtech2" + CASE "10": genscheme$ = "sphericalharmonics": plotmode$ = "simplepoints" + CASE "11": genscheme$ = "laplace2d": plotmode$ = "meshtech2" + CASE "12": genscheme$ = "planet": plotmode$ = "meshtech2planet" + CASE "13": genscheme$ = "wave2d": plotmode$ = "simplemesh" + CASE "14": genscheme$ = "wave2dinf": plotmode$ = "simplemesh" + CASE "15": genscheme$ = "bacteria": plotmode$ = "simplepointsbacteria" + CASE "16": genscheme$ = "neuron": plotmode$ = "linearneuron" + CASE "99": END + CASE ELSE: GOTO mainstart +END SELECT + +substart: + +' *** Zero counters and array sizes. *** + +numparticleorig = 0 +numparticlevisible = 0 +numdoubletorig = 0 +numdoubletclip = 0 +numdoubletclipwork = 0 +numdoubletsnip = 0 +numdoubletsnipwork = 0 +numdoubletintinfo = 0 +numtripletorig = 0 +numtripletfaceon = 0 +numtripletclip = 0 +numtripletclipwork = 0 +numtripletsnip = 0 +numtripletsnipimage = 0 +numtripletsnipwork = 0 +numtripletencpoint = 0 +numtripletintpointpair = 0 +numtripletfinal = 0 +pcountparticleorig = 0 +pcountdoubletorig = 0 +pcounttripletorig = 0 + +' *** Constants and switch control. *** + +' Perspective and animation switches/defaults. +fovd = -256 +nearplane(4) = 3 +farplane(4) = -100 +rightplane(4) = 0 '*' fovd * (nhat(1) * rightplane(1) + nhat(2) * rightplane(2) + nhat(3) * rightplane(3)) +leftplane(4) = 0 +topplane(4) = 0 +bottomplane(4) = 0 +spotlightwidth = 1.3 +spotlightthickness = 3 +spotlightwidth = 1.3 +spotlightcenter = 20 +nearplanespotlight(4) = spotlightcenter - spotlightthickness / 2 +farplanespotlight(4) = -(spotlightcenter + spotlightthickness / 2) +rightplanespotlight(4) = 0 +leftplanespotlight(4) = 0 +topplanespotlight(4) = 0 +bottomplanespotlight(4) = 0 +centerx = screenwidth / 2 +centery = screenheight / 2 +speedconst = 50 +falsedepth = .01 +zoom = 30 +timevar = 0 +T = 0 +togglehud = 1 +toggleatomnumbers = -1 +toggletimeanimate = -1 +toggletimealert = 0 +camx = 0 +camy = 0 +camz = 0 +uhat(1) = -3: uhat(2) = 5: uhat(3) = 1 / 4 +vhat(1) = -1: vhat(2) = -1: vhat(3) = 8 + +CLS + +SELECT CASE LCASE$(genscheme$) + CASE "curve": + GOSUB genscheme.curve + numparticleorig = pcountparticleorig + CASE "simplepoints": + uhat(1) = -0.2376385: uhat(2) = 0.970313: uhat(3) = -0.04495043 + vhat(1) = -0.8201708: vhat(2) = -0.1756434: vhat(3) = 0.5444899 + GOSUB genscheme.simplepoints + numparticleorig = pcountparticleorig + CASE "3denvparticles": + globaldelay = globaldelayinit * 1000 + uhat(1) = 0.8251367: uhat(2) = -0.564903: uhat(3) = -0.005829525 + vhat(1) = 0.065519: vhat(2) = 0.08544215: vhat(3) = 0.9941866 + falsedepth = 0 + zoom = 1.95 + toggletimeanimate = 1 + togglehud = -1 + toggletimealert = 1 + camx = 30 + camy = 25 + camz = -25 + GOSUB genscheme.3denvparticles.init + numparticleorig = pcountparticleorig + CASE "3denvparticlesfile": + uhat(1) = 0.8251367: uhat(2) = -0.564903: uhat(3) = -0.005829525 + vhat(1) = 0.065519: vhat(2) = 0.08544215: vhat(3) = 0.9941866 + falsedepth = 0 + zoom = 1.95 + togglehud = -1 + camx = 30 + camy = 30 + camz = -25 + pcountparticleorig = 0 + OPEN "object3d.txt" FOR INPUT AS #1 + DO + pcountparticleorig = pcountparticleorig + 1 + INPUT #1, vec(pcountparticleorig, 1), vec(pcountparticleorig, 2), vec(pcountparticleorig, 3), vec(pcountparticleorig, 4) + LOOP WHILE EOF(1) = 0 + CLOSE #1 + numparticleorig = pcountparticleorig + CASE "molecule": + uhat(1) = -0.7027042: uhat(2) = 0.5818964: uhat(3) = -0.409394 + vhat(1) = -0.6446534: vhat(2) = -0.2772641: vhat(3) = 0.7124231 + zoom = 55 + togglehud = -1 + toggleatomnumbers = 1 + numparticleorig = 12 + REDIM vec(numparticleorig, 10) + REDIM vecvisible(numparticleorig, 10) + FOR i = 1 TO numparticleorig + READ vec(i, 1), vec(i, 2), vec(i, 3), vec(i, 4), vec(i, 5), vec(i, 6), vec(i, 7), vec(i, 8), vec(i, 9), vec(i, 10) + NEXT + GOSUB genscheme.molecule + CASE "neighbortile": + GOSUB genscheme.neighbortile + numparticleorig = pcountparticleorig + CASE "3denvdoublets": + uhat(1) = 0.7941225: uhat(2) = -0.6026734: uhat(3) = -0.07844898 + vhat(1) = 0.2287595: vhat(2) = 0.1768191: vhat(3) = 0.95729 + falsedepth = 0 + zoom = 1.95 + camx = 30 + camy = 45 + camz = -25 + GOSUB genscheme.3denvdoublets + numparticleorig = pcountparticleorig + numdoubletorig = pcountdoubletorig + CASE "3denvtriplets": + uhat(1) = 0.470269: uhat(2) = -0.8823329: uhat(3) = -0.01832148 + vhat(1) = -0.03788515: vhat(2) = -0.0409245: vhat(3) = 0.9984438 + falsedepth = 0 + zoom = 1.95 + camx = 20 + camy = 20 + camz = 17 + GOSUB genscheme.3denvtriplets + numparticleorig = pcountparticleorig + numtripletorig = pcounttripletorig + CASE "animatedflag": + globaldelay = globaldelayinit * 5000 + toggletimeanimate = 1 + togglehud = -1 + toggletimealert = 1 + uhat(1) = .7802773: uhat(2) = -.4759201: uhat(3) = .4058135 + vhat(1) = .2502121: vhat(2) = .8321912: vhat(3) = .4948249 + GOSUB genscheme.animatedsurface.init + numparticleorig = pcountparticleorig + REDIM vec2dztemp(xrange, yrange) + GOSUB genschemeUSAcolors + CASE "animatedpretzel": + globaldelay = globaldelayinit * 5000 + uhat(1) = .7802773: uhat(2) = -.4759201: uhat(3) = .4058135 + vhat(1) = .2502121: vhat(2) = .8321912: vhat(3) = .4948249 + toggletimealert = 1 + GOSUB genscheme.animatedpretzel.init + numparticleorig = pcountparticleorig + CASE "sphericalharmonics": + GOSUB genscheme.sphericalharmonics + numparticleorig = pcountparticleorig + CASE "laplace2d": + uhat(1) = 0.4919244: uhat(2) = 0.869175: uhat(3) = 0.0504497 + vhat(1) = -0.2520696: vhat(2) = 0.08672012: vhat(3) = 0.9638156 + globaldelay = globaldelayinit * 1500 + togglehud = -1 + toggletimealert = 1 + GOSUB genscheme.laplace2d.init + numparticleorig = pcountparticleorig + REDIM vec2dz(xrange, yrange) + REDIM vec2dztemp(xrange, yrange) + REDIM vec2dzfixed(xrange, yrange) + GOSUB genscheme.laplace2d.gridinit + CASE "planet": + globaldelay = globaldelayinit * 1500 + uhat(1) = 0.4868324: uhat(2) = 0.8719549: uhat(3) = -0.05185585 + vhat(1) = 0.458436: vhat(2) = -0.2045161: vhat(3) = 0.8648755 + togglehud = -1 + toggletimealert = 1 + GOSUB genscheme.planet.init + numparticleorig = pcountparticleorig + REDIM vec2ds(xrange, yrange) + REDIM vec2dstemp(xrange, yrange) + REDIM vec2dsfixed(xrange, yrange) + GOSUB genscheme.planet.gridinit + CASE "wave2d": + globaldelay = globaldelayinit * 1500 + uhat(1) = .7802773: uhat(2) = -.4759201: uhat(3) = .4058135 + vhat(1) = .2502121: vhat(2) = .8321912: vhat(3) = .4948249 + togglehud = -1 + toggletimealert = 1 + GOSUB genscheme.wave2d.init + numparticleorig = pcountparticleorig + REDIM vec2dz(xrange, yrange) + REDIM vec2dztemp(xrange, yrange) + REDIM vec2dzprev(xrange, yrange) + GOSUB genschemeUSAcolors + GOSUB genscheme.wave2d.gridinit + CASE "wave2dinf": + globaldelay = globaldelayinit * 4000 + uhat(1) = 0.6781088: uhat(2) = 0.7263383: uhat(3) = 0.1122552 + vhat(1) = -0.4469305: vhat(2) = 0.2862689: vhat(3) = 0.8475278 + toggletimeanimate = 1 + togglehud = -1 + toggletimealert = 1 + GOSUB genscheme.wave2dinf.init + numparticleorig = pcountparticleorig + REDIM vec2dz(xrange, yrange) + REDIM vec2dztemp(xrange, yrange) + REDIM vec2dzfixed(xrange, yrange) + REDIM vec2dzprev(xrange, yrange) + GOSUB genscheme.wave2dinf.gridinit + CASE "bacteria": + falsedepth = 0.001 + globaldelay = globaldelayinit + toggletimeanimate = 1 + toggletimealert = 1 + zoom = 3 + numcreatures = 300 + REDIM vec(numcreatures, 10) + REDIM vecvisible(numcreatures, 10) + GOSUB genscheme.bacteria.init + numparticleorig = pcountparticleorig + CASE "neuron": + globaldelay = globaldelayinit + uhat(1) = 0.3494484: uhat(2) = -0.9331037: uhat(3) = -0.08487199 + vhat(1) = 0.4430568: vhat(2) = 0.08476364: vhat(3) = 0.8924774 + toggletimeanimate = 1 + toggletimealert = 1 + togglehud = -1 + zoom = 1.5 + falsedepth = 0.001 + REDIM vec(bignumber, 15) + REDIM vecvisible(bignumber, 15) + REDIM vecpuvsrev(bignumber, 15) + GOSUB genscheme.neuron.init + numparticleorig = pcountparticleorig +END SELECT + +' Move objects to accomodate initial camera position. +IF camx <> 0 AND camy <> 0 AND camz <> 0 THEN + FOR i = 1 TO numparticleorig + vec(i, 1) = vec(i, 1) + camx + vec(i, 2) = vec(i, 2) + camy + vec(i, 3) = vec(i, 3) + camz + NEXT + FOR i = 1 TO numdoubletorig + doubletorig(i, 1) = doubletorig(i, 1) + camx + doubletorig(i, 2) = doubletorig(i, 2) + camy + doubletorig(i, 3) = doubletorig(i, 3) + camz + doubletorig(i, 4) = doubletorig(i, 4) + camx + doubletorig(i, 5) = doubletorig(i, 5) + camy + doubletorig(i, 6) = doubletorig(i, 6) + camz + NEXT + FOR i = 1 TO numtripletorig + tripletorig(i, 1) = tripletorig(i, 1) + camx + tripletorig(i, 2) = tripletorig(i, 2) + camy + tripletorig(i, 3) = tripletorig(i, 3) + camz + tripletorig(i, 4) = tripletorig(i, 4) + camx + tripletorig(i, 5) = tripletorig(i, 5) + camy + tripletorig(i, 6) = tripletorig(i, 6) + camz + tripletorig(i, 7) = tripletorig(i, 7) + camx + tripletorig(i, 8) = tripletorig(i, 8) + camy + tripletorig(i, 9) = tripletorig(i, 9) + camz + NEXT +END IF + +GOSUB redraw + +' *** Begin main loop. *** +DO + IF toggletimeanimate = 1 THEN + GOSUB timeanimate + flagredraw = 1 + END IF + IF flagredraw = 1 THEN + GOSUB redraw + flagredraw = -1 + END IF + 'GOSUB mouseprocess + GOSUB keyprocess + IF toggletimeanimate = 1 THEN + FOR delaycount = 1 TO globaldelay: NEXT + END IF +LOOP +' *** End main loop. *** + +' *** Begin function definitions. *** + +' Comment out the conents of this gosub for non-QB64 compiler. +mouseprocess: +'DO +' IF _MOUSEMOVEMENTX > 0 THEN +' mousekey$ = "6" +' GOSUB rotate.uhat.plus: GOSUB normalize.screen.vectors: flagredraw = 1 +' END IF +' IF _MOUSEMOVEMENTX < 0 THEN +' mousekey$ = "4" +' GOSUB rotate.uhat.minus: GOSUB normalize.screen.vectors: flagredraw = 1 +' END IF +' IF _MOUSEMOVEMENTY > 0 THEN +' mousekey$ = "8" +' GOSUB rotate.vhat.plus: GOSUB normalize.screen.vectors: flagredraw = 1 +' END IF +' IF _MOUSEMOVEMENTY < 0 THEN +' mousekey$ = "2" +' GOSUB rotate.vhat.minus: GOSUB normalize.screen.vectors: flagredraw = 1 +' END IF +' MouseLB = _MOUSEBUTTON(1) +' MouseRB = _MOUSEBUTTON(2) +'LOOP WHILE _MOUSEINPUT +RETURN + +keyprocess: +'IF mousekey$ <> "" THEN +' key$ = mousekey$ +' mousekey$ = "" +'ELSE +key$ = INKEY$ +'END IF +IF key$ <> "" THEN + flagredraw = 1 +END IF +SELECT CASE LCASE$(key$) + CASE "8": + GOSUB rotate.vhat.plus + CASE "2": + GOSUB rotate.vhat.minus + CASE "4": + GOSUB rotate.uhat.minus + CASE "6": + GOSUB rotate.uhat.plus + CASE "7": + GOSUB rotate.clockwise + CASE "9": + GOSUB rotate.counterclockwise + CASE "1": + GOSUB rotate.uhat.minus: GOSUB normalize.screen.vectors: GOSUB rotate.clockwise + CASE "3": + GOSUB rotate.uhat.plus: GOSUB normalize.screen.vectors: GOSUB rotate.counterclockwise + CASE "w" + GOSUB strafe.objects.nhat.plus + GOSUB strafe.camera.nhat.plus + CASE "s" + GOSUB strafe.objects.nhat.minus + GOSUB strafe.camera.nhat.minus + CASE "a" + GOSUB strafe.objects.uhat.plus + GOSUB strafe.camera.uhat.plus + CASE "d" + GOSUB strafe.objects.uhat.minus + GOSUB strafe.camera.uhat.minus + CASE "q" + GOSUB strafe.objects.vhat.plus + GOSUB strafe.camera.vhat.plus + CASE "e" + GOSUB strafe.objects.vhat.minus + GOSUB strafe.camera.vhat.minus + CASE "x" + uhat(1) = 0: uhat(2) = 1: uhat(3) = 0 + vhat(1) = 0: vhat(2) = 0: vhat(3) = 1 + CASE "y" + uhat(1) = 0: uhat(2) = 0: uhat(3) = 1 + vhat(1) = 1: vhat(2) = 0: vhat(3) = 0 + CASE "z" + uhat(1) = 1: uhat(2) = 0: uhat(3) = 0 + vhat(1) = 0: vhat(2) = 1: vhat(3) = 0 + CASE "," + nearplane(4) = nearplane(4) - 1 + IF nearplane(4) < 0 THEN nearplane(4) = 0 + CASE "." + nearplane(4) = nearplane(4) + 1 + CASE "]" + farplane(4) = farplane(4) - 1 + CASE "[" + farplane(4) = farplane(4) + 1 + CASE "'" + spotlightcenter = spotlightcenter + spotlightthickness / 2 + CASE ";" + spotlightcenter = spotlightcenter - spotlightthickness / 2 + IF spotlightcenter < 0 THEN spotlightcenter = 0 + CASE "t" + toggletimeanimate = -toggletimeanimate + CASE "r" + timevar = 0 + CASE "f" + GOTO substart + CASE "g" + GOTO mainstart + CASE "-" + spotlightthickness = spotlightthickness - .25 + IF spotlightthickness < 0 THEN spotlightthickness = 0 + globaldelay = globaldelay * 1.1 + CASE "=" + spotlightthickness = spotlightthickness + .25 + globaldelay = globaldelay * 0.9 + CASE "`" + globaldelayinit = globaldelay + CASE " " + togglehud = -togglehud + CLS + CASE "n" + toggleatomnumbers = -toggleatomnumbers + CLS + CASE "/" + OPEN "uvn.txt" FOR OUTPUT AS #1 + PRINT #1, uhat(1); uhat(2); uhat(3) + PRINT #1, vhat(1); vhat(2); vhat(3) + PRINT #1, nhat(1); nhat(2); nhat(3) + CLOSE #1 + OPEN "vec1.txt" FOR OUTPUT AS #1 + PRINT #1, vec(1, 1); vec(1, 2); vec(1, 3) + CLOSE #1 + OPEN "object3d.txt" FOR OUTPUT AS #1 + FOR i = 1 TO numparticleorig + PRINT #1, vec(i, 1); " "; vec(i, 2); " "; vec(i, 3); " "; vec(i, 4) + NEXT + CLOSE #1 + CASE CHR$(27) + END +END SELECT +RETURN + +convert: +' Convert graphics from uv-cartesian coordinates to monitor coordinates. +x0 = x: y0 = y +x = x0 + centerx +y = -y0 + centery +IF toggleatomnumbers = 1 THEN + xtext = (x0 + centerx) * (80 / 640) + ytext = (centery - y0) * (30 / 480) + 1 + IF xtext < 1 THEN xtext = 1 + IF xtext > 77 THEN xtext = 77 + IF ytext < 1 THEN ytext = 1 + IF ytext > 27 THEN ytext = 27 +END IF +RETURN + +' *** Define functions for view translation and rotation. *** + +rotate.uhat.plus: +uhat(1) = nhat(1) + speedconst * uhat(1) +uhat(2) = nhat(2) + speedconst * uhat(2) +uhat(3) = nhat(3) + speedconst * uhat(3) +RETURN + +rotate.uhat.minus: +uhat(1) = -nhat(1) + speedconst * uhat(1) +uhat(2) = -nhat(2) + speedconst * uhat(2) +uhat(3) = -nhat(3) + speedconst * uhat(3) +RETURN + +rotate.vhat.plus: +vhat(1) = nhat(1) + speedconst * vhat(1) +vhat(2) = nhat(2) + speedconst * vhat(2) +vhat(3) = nhat(3) + speedconst * vhat(3) +RETURN + +rotate.vhat.minus: +vhat(1) = -nhat(1) + speedconst * vhat(1) +vhat(2) = -nhat(2) + speedconst * vhat(2) +vhat(3) = -nhat(3) + speedconst * vhat(3) +RETURN + +rotate.counterclockwise: +v1 = vhat(1) +v2 = vhat(2) +v3 = vhat(3) +vhat(1) = uhat(1) + speedconst * vhat(1) +vhat(2) = uhat(2) + speedconst * vhat(2) +vhat(3) = uhat(3) + speedconst * vhat(3) +uhat(1) = -v1 + speedconst * uhat(1) +uhat(2) = -v2 + speedconst * uhat(2) +uhat(3) = -v3 + speedconst * uhat(3) +RETURN + +rotate.clockwise: +v1 = vhat(1) +v2 = vhat(2) +v3 = vhat(3) +vhat(1) = -uhat(1) + speedconst * vhat(1) +vhat(2) = -uhat(2) + speedconst * vhat(2) +vhat(3) = -uhat(3) + speedconst * vhat(3) +uhat(1) = v1 + speedconst * uhat(1) +uhat(2) = v2 + speedconst * uhat(2) +uhat(3) = v3 + speedconst * uhat(3) +RETURN +RETURN + +strafe.objects.uhat.plus: +FOR i = 1 TO numparticleorig + vec(i, 1) = vec(i, 1) + uhat(1) * 1 / zoom + vec(i, 2) = vec(i, 2) + uhat(2) * 1 / zoom + vec(i, 3) = vec(i, 3) + uhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numdoubletorig + doubletorig(i, 1) = doubletorig(i, 1) + uhat(1) * 1 / zoom + doubletorig(i, 2) = doubletorig(i, 2) + uhat(2) * 1 / zoom + doubletorig(i, 3) = doubletorig(i, 3) + uhat(3) * 1 / zoom + doubletorig(i, 4) = doubletorig(i, 4) + uhat(1) * 1 / zoom + doubletorig(i, 5) = doubletorig(i, 5) + uhat(2) * 1 / zoom + doubletorig(i, 6) = doubletorig(i, 6) + uhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numtripletorig + tripletorig(i, 1) = tripletorig(i, 1) + uhat(1) * 1 / zoom + tripletorig(i, 2) = tripletorig(i, 2) + uhat(2) * 1 / zoom + tripletorig(i, 3) = tripletorig(i, 3) + uhat(3) * 1 / zoom + tripletorig(i, 4) = tripletorig(i, 4) + uhat(1) * 1 / zoom + tripletorig(i, 5) = tripletorig(i, 5) + uhat(2) * 1 / zoom + tripletorig(i, 6) = tripletorig(i, 6) + uhat(3) * 1 / zoom + tripletorig(i, 7) = tripletorig(i, 7) + uhat(1) * 1 / zoom + tripletorig(i, 8) = tripletorig(i, 8) + uhat(2) * 1 / zoom + tripletorig(i, 9) = tripletorig(i, 9) + uhat(3) * 1 / zoom +NEXT +RETURN + +strafe.objects.uhat.minus: +FOR i = 1 TO numparticleorig + vec(i, 1) = vec(i, 1) - uhat(1) * 1 / zoom + vec(i, 2) = vec(i, 2) - uhat(2) * 1 / zoom + vec(i, 3) = vec(i, 3) - uhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numdoubletorig + doubletorig(i, 1) = doubletorig(i, 1) - uhat(1) * 1 / zoom + doubletorig(i, 2) = doubletorig(i, 2) - uhat(2) * 1 / zoom + doubletorig(i, 3) = doubletorig(i, 3) - uhat(3) * 1 / zoom + doubletorig(i, 4) = doubletorig(i, 4) - uhat(1) * 1 / zoom + doubletorig(i, 5) = doubletorig(i, 5) - uhat(2) * 1 / zoom + doubletorig(i, 6) = doubletorig(i, 6) - uhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numtripletorig + tripletorig(i, 1) = tripletorig(i, 1) - uhat(1) * 1 / zoom + tripletorig(i, 2) = tripletorig(i, 2) - uhat(2) * 1 / zoom + tripletorig(i, 3) = tripletorig(i, 3) - uhat(3) * 1 / zoom + tripletorig(i, 4) = tripletorig(i, 4) - uhat(1) * 1 / zoom + tripletorig(i, 5) = tripletorig(i, 5) - uhat(2) * 1 / zoom + tripletorig(i, 6) = tripletorig(i, 6) - uhat(3) * 1 / zoom + tripletorig(i, 7) = tripletorig(i, 7) - uhat(1) * 1 / zoom + tripletorig(i, 8) = tripletorig(i, 8) - uhat(2) * 1 / zoom + tripletorig(i, 9) = tripletorig(i, 9) - uhat(3) * 1 / zoom +NEXT +RETURN + +strafe.objects.vhat.plus: +FOR i = 1 TO numparticleorig + vec(i, 1) = vec(i, 1) + vhat(1) * 1 / zoom + vec(i, 2) = vec(i, 2) + vhat(2) * 1 / zoom + vec(i, 3) = vec(i, 3) + vhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numdoubletorig + doubletorig(i, 1) = doubletorig(i, 1) + vhat(1) * 1 / zoom + doubletorig(i, 2) = doubletorig(i, 2) + vhat(2) * 1 / zoom + doubletorig(i, 3) = doubletorig(i, 3) + vhat(3) * 1 / zoom + doubletorig(i, 4) = doubletorig(i, 4) + vhat(1) * 1 / zoom + doubletorig(i, 5) = doubletorig(i, 5) + vhat(2) * 1 / zoom + doubletorig(i, 6) = doubletorig(i, 6) + vhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numtripletorig + tripletorig(i, 1) = tripletorig(i, 1) + vhat(1) * 1 / zoom + tripletorig(i, 2) = tripletorig(i, 2) + vhat(2) * 1 / zoom + tripletorig(i, 3) = tripletorig(i, 3) + vhat(3) * 1 / zoom + tripletorig(i, 4) = tripletorig(i, 4) + vhat(1) * 1 / zoom + tripletorig(i, 5) = tripletorig(i, 5) + vhat(2) * 1 / zoom + tripletorig(i, 6) = tripletorig(i, 6) + vhat(3) * 1 / zoom + tripletorig(i, 7) = tripletorig(i, 7) + vhat(1) * 1 / zoom + tripletorig(i, 8) = tripletorig(i, 8) + vhat(2) * 1 / zoom + tripletorig(i, 9) = tripletorig(i, 9) + vhat(3) * 1 / zoom +NEXT +RETURN + +strafe.objects.vhat.minus: +FOR i = 1 TO numparticleorig + vec(i, 1) = vec(i, 1) - vhat(1) * 1 / zoom + vec(i, 2) = vec(i, 2) - vhat(2) * 1 / zoom + vec(i, 3) = vec(i, 3) - vhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numdoubletorig + doubletorig(i, 1) = doubletorig(i, 1) - vhat(1) * 1 / zoom + doubletorig(i, 2) = doubletorig(i, 2) - vhat(2) * 1 / zoom + doubletorig(i, 3) = doubletorig(i, 3) - vhat(3) * 1 / zoom + doubletorig(i, 4) = doubletorig(i, 4) - vhat(1) * 1 / zoom + doubletorig(i, 5) = doubletorig(i, 5) - vhat(2) * 1 / zoom + doubletorig(i, 6) = doubletorig(i, 6) - vhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numtripletorig + tripletorig(i, 1) = tripletorig(i, 1) - vhat(1) * 1 / zoom + tripletorig(i, 2) = tripletorig(i, 2) - vhat(2) * 1 / zoom + tripletorig(i, 3) = tripletorig(i, 3) - vhat(3) * 1 / zoom + tripletorig(i, 4) = tripletorig(i, 4) - vhat(1) * 1 / zoom + tripletorig(i, 5) = tripletorig(i, 5) - vhat(2) * 1 / zoom + tripletorig(i, 6) = tripletorig(i, 6) - vhat(3) * 1 / zoom + tripletorig(i, 7) = tripletorig(i, 7) - vhat(1) * 1 / zoom + tripletorig(i, 8) = tripletorig(i, 8) - vhat(2) * 1 / zoom + tripletorig(i, 9) = tripletorig(i, 9) - vhat(3) * 1 / zoom +NEXT +RETURN + +strafe.objects.nhat.plus: +FOR i = 1 TO numparticleorig + vec(i, 1) = vec(i, 1) + nhat(1) * 1 / zoom + vec(i, 2) = vec(i, 2) + nhat(2) * 1 / zoom + vec(i, 3) = vec(i, 3) + nhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numdoubletorig + doubletorig(i, 1) = doubletorig(i, 1) + nhat(1) * 1 / zoom + doubletorig(i, 2) = doubletorig(i, 2) + nhat(2) * 1 / zoom + doubletorig(i, 3) = doubletorig(i, 3) + nhat(3) * 1 / zoom + doubletorig(i, 4) = doubletorig(i, 4) + nhat(1) * 1 / zoom + doubletorig(i, 5) = doubletorig(i, 5) + nhat(2) * 1 / zoom + doubletorig(i, 6) = doubletorig(i, 6) + nhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numtripletorig + tripletorig(i, 1) = tripletorig(i, 1) + nhat(1) * 1 / zoom + tripletorig(i, 2) = tripletorig(i, 2) + nhat(2) * 1 / zoom + tripletorig(i, 3) = tripletorig(i, 3) + nhat(3) * 1 / zoom + tripletorig(i, 4) = tripletorig(i, 4) + nhat(1) * 1 / zoom + tripletorig(i, 5) = tripletorig(i, 5) + nhat(2) * 1 / zoom + tripletorig(i, 6) = tripletorig(i, 6) + nhat(3) * 1 / zoom + tripletorig(i, 7) = tripletorig(i, 7) + nhat(1) * 1 / zoom + tripletorig(i, 8) = tripletorig(i, 8) + nhat(2) * 1 / zoom + tripletorig(i, 9) = tripletorig(i, 9) + nhat(3) * 1 / zoom +NEXT +RETURN + +strafe.objects.nhat.minus: +FOR i = 1 TO numparticleorig + vec(i, 1) = vec(i, 1) - nhat(1) * 1 / zoom + vec(i, 2) = vec(i, 2) - nhat(2) * 1 / zoom + vec(i, 3) = vec(i, 3) - nhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numdoubletorig + doubletorig(i, 1) = doubletorig(i, 1) - nhat(1) * 1 / zoom + doubletorig(i, 2) = doubletorig(i, 2) - nhat(2) * 1 / zoom + doubletorig(i, 3) = doubletorig(i, 3) - nhat(3) * 1 / zoom + doubletorig(i, 4) = doubletorig(i, 4) - nhat(1) * 1 / zoom + doubletorig(i, 5) = doubletorig(i, 5) - nhat(2) * 1 / zoom + doubletorig(i, 6) = doubletorig(i, 6) - nhat(3) * 1 / zoom +NEXT +FOR i = 1 TO numtripletorig + tripletorig(i, 1) = tripletorig(i, 1) - nhat(1) * 1 / zoom + tripletorig(i, 2) = tripletorig(i, 2) - nhat(2) * 1 / zoom + tripletorig(i, 3) = tripletorig(i, 3) - nhat(3) * 1 / zoom + tripletorig(i, 4) = tripletorig(i, 4) - nhat(1) * 1 / zoom + tripletorig(i, 5) = tripletorig(i, 5) - nhat(2) * 1 / zoom + tripletorig(i, 6) = tripletorig(i, 6) - nhat(3) * 1 / zoom + tripletorig(i, 7) = tripletorig(i, 7) - nhat(1) * 1 / zoom + tripletorig(i, 8) = tripletorig(i, 8) - nhat(2) * 1 / zoom + tripletorig(i, 9) = tripletorig(i, 9) - nhat(3) * 1 / zoom +NEXT +RETURN + +strafe.camera.uhat.plus: +camx = camx + uhat(1) * 1 / zoom +camy = camy + uhat(2) * 1 / zoom +camz = camz + uhat(3) * 1 / zoom +RETURN + +strafe.camera.uhat.minus: +camx = camx - uhat(1) * 1 / zoom +camy = camy - uhat(2) * 1 / zoom +camz = camz - uhat(3) * 1 / zoom +RETURN + +strafe.camera.vhat.plus: +camx = camx + vhat(1) * 1 / zoom +camy = camy + vhat(2) * 1 / zoom +camz = camz + vhat(3) * 1 / zoom +RETURN + +strafe.camera.vhat.minus: +camx = camx - vhat(1) * 1 / zoom +camy = camy - vhat(2) * 1 / zoom +camz = camz - vhat(3) * 1 / zoom +RETURN + +strafe.camera.nhat.plus: +camx = camx + nhat(1) * 1 / zoom +camy = camy + nhat(2) * 1 / zoom +camz = camz + nhat(3) * 1 / zoom +RETURN + +strafe.camera.nhat.minus: +camx = camx - nhat(1) * 1 / zoom +camy = camy - nhat(2) * 1 / zoom +camz = camz - nhat(3) * 1 / zoom +RETURN + +' *** Define core functions. *** + +timeanimate: +timevar = timevar + 1 +IF timevar > 10 ^ 6 THEN timevar = 1 +SELECT CASE genscheme$ + CASE "3denvparticles": GOSUB genscheme.3denvparticles.timeanimate + CASE "animatedflag": GOSUB genscheme.animatedsurface.timeanimate + CASE "animatedpretzel": GOSUB genscheme.animatedpretzel.timeanimate + CASE "laplace2d": GOSUB genscheme.laplace2d.timeanimate + CASE "planet": GOSUB genscheme.planet.timeanimate + CASE "wave2d": GOSUB genscheme.wave2d.timeanimate + CASE "wave2dinf": GOSUB genscheme.wave2dinf.timeanimate + CASE "bacteria": GOSUB genscheme.bacteria.timeanimate + CASE "neuron": GOSUB genscheme.neuron.timeanimate +END SELECT +RETURN + +normalize.screen.vectors: +'normalize the two vectors that define the screen orientation +uhatmag = SQR(uhat(1) ^ 2 + uhat(2) ^ 2 + uhat(3) ^ 2) +uhat(1) = uhat(1) / uhatmag: uhat(2) = uhat(2) / uhatmag: uhat(3) = uhat(3) / uhatmag +vhatmag = SQR(vhat(1) ^ 2 + vhat(2) ^ 2 + vhat(3) ^ 2) +vhat(1) = vhat(1) / vhatmag: vhat(2) = vhat(2) / vhatmag: vhat(3) = vhat(3) / vhatmag +uhatdotvhat = uhat(1) * vhat(1) + uhat(2) * vhat(2) + uhat(3) * vhat(3) +IF SQR(uhatdotvhat ^ 2) > .0005 THEN + CLS: COLOR 15: LOCATE 5, 5: PRINT "Screen vectors are not perpendicular. Press ESC to quit." + 'DO: LOOP UNTIL INKEY$ = CHR$(27): END +END IF +' Compute the normal vector to the view plane. +' The normal vector points toward the eye, away from view frustum. +nhat(1) = uhat(2) * vhat(3) - uhat(3) * vhat(2) +nhat(2) = uhat(3) * vhat(1) - uhat(1) * vhat(3) +nhat(3) = uhat(1) * vhat(2) - uhat(2) * vhat(1) +nhatmag = SQR(nhat(1) ^ 2 + nhat(2) ^ 2 + nhat(3) ^ 2) +nhat(1) = nhat(1) / nhatmag: nhat(2) = nhat(2) / nhatmag: nhat(3) = nhat(3) / nhatmag +RETURN + +redraw: +GOSUB normalize.screen.vectors +GOSUB compute.viewplanes +' Project the three-space basis vectors onto the screen plane. +xhatp(1) = xhat(1) * uhat(1) + xhat(2) * uhat(2) + xhat(3) * uhat(3) +xhatp(2) = xhat(1) * vhat(1) + xhat(2) * vhat(2) + xhat(3) * vhat(3) +yhatp(1) = yhat(1) * uhat(1) + yhat(2) * uhat(2) + yhat(3) * uhat(3) +yhatp(2) = yhat(1) * vhat(1) + yhat(2) * vhat(2) + yhat(3) * vhat(3) +zhatp(1) = zhat(1) * uhat(1) + zhat(2) * uhat(2) + zhat(3) * uhat(3) +zhatp(2) = zhat(1) * vhat(1) + zhat(2) * vhat(2) + zhat(3) * vhat(3) +IF numparticleorig > 0 THEN + GOSUB compute.visible.particles + GOSUB project.particles + GOSUB depth.adjust.particles +END IF +IF numdoubletorig > 0 THEN + GOSUB copy.doublets.orig.clip + GOSUB clip.doublets.viewplanes + GOSUB copy.doublets.clip.snip + GOSUB project.doublets + GOSUB depth.adjust.doublets + GOSUB snip.doublets + GOSUB copy.doublets.snipwork.snip + GOSUB project.doublets + GOSUB depth.adjust.doublets +END IF +IF numtripletorig > 0 THEN + GOSUB reverse.uvnhat + GOSUB triplet.filter.faceon + GOSUB copy.triplets.faceon.clip + GOSUB clip.triplets.viewplanes + GOSUB copy.triplets.clip.snip + GOSUB snip.triplets + GOSUB copy.triplets.snip.final + GOSUB project.triplets + GOSUB depth.adjust.triplets + GOSUB reverse.uvnhat +END IF +GOSUB draw.all.objects +GOSUB store.screen.projections +RETURN + +reverse.uvnhat: +uhat(1) = -uhat(1) +uhat(2) = -uhat(2) +uhat(3) = -uhat(3) +GOSUB normalize.screen.vectors +RETURN + +compute.visible.particles: +numparticlevisible = 0 +FOR i = 1 TO numparticleorig + IF falsedepth = 0 THEN + GOSUB clip.particle.viewplanes + ELSE + SELECT CASE genscheme$ + CASE "molecule" + numparticlevisible = numparticlevisible + 1 + vecvisible(numparticlevisible, 1) = vec(i, 1) + vecvisible(numparticlevisible, 2) = vec(i, 2) + vecvisible(numparticlevisible, 3) = vec(i, 3) + vecvisible(numparticlevisible, 4) = vec(i, 4) + vecvisible(numparticlevisible, 5) = vec(i, 5) + vecvisible(numparticlevisible, 6) = vec(i, 6) + vecvisible(numparticlevisible, 7) = vec(i, 7) + vecvisible(numparticlevisible, 8) = vec(i, 8) + vecvisible(numparticlevisible, 9) = vec(i, 9) + vecvisible(numparticlevisible, 10) = vec(i, 10) + CASE "bacteria" + numparticlevisible = numparticlevisible + 1 + vecvisible(numparticlevisible, 1) = vec(i, 1) + vecvisible(numparticlevisible, 2) = vec(i, 2) + vecvisible(numparticlevisible, 3) = vec(i, 3) + vecvisible(numparticlevisible, 4) = vec(i, 4) + vecvisible(numparticlevisible, 5) = vec(i, 5) + vecvisible(numparticlevisible, 6) = vec(i, 6) + vecvisible(numparticlevisible, 7) = vec(i, 7) + vecvisible(numparticlevisible, 8) = vec(i, 8) + vecvisible(numparticlevisible, 9) = vec(i, 9) + vecvisible(numparticlevisible, 10) = vec(i, 10) + CASE "neuron" + numparticlevisible = numparticlevisible + 1 + vecvisible(numparticlevisible, 1) = vec(i, 1) + vecvisible(numparticlevisible, 2) = vec(i, 2) + vecvisible(numparticlevisible, 3) = vec(i, 3) + vecvisible(numparticlevisible, 4) = vec(i, 4) + vecvisible(numparticlevisible, 5) = vec(i, 5) + vecvisible(numparticlevisible, 6) = vec(i, 6) + vecvisible(numparticlevisible, 7) = vec(i, 7) + vecvisible(numparticlevisible, 8) = vec(i, 8) + vecvisible(numparticlevisible, 9) = vec(i, 9) + vecvisible(numparticlevisible, 10) = vec(i, 10) + vecvisible(numparticlevisible, 11) = vec(i, 11) + vecvisible(numparticlevisible, 12) = vec(i, 12) + vecvisible(numparticlevisible, 13) = vec(i, 13) + vecvisible(numparticlevisible, 14) = vec(i, 14) + vecvisible(numparticlevisible, 15) = vec(i, 15) + CASE ELSE + numparticlevisible = numparticlevisible + 1 + vecvisible(numparticlevisible, 1) = vec(i, 1) + vecvisible(numparticlevisible, 2) = vec(i, 2) + vecvisible(numparticlevisible, 3) = vec(i, 3) + vecvisible(numparticlevisible, 4) = vec(i, 4) + END SELECT + END IF +NEXT +RETURN + +clip.particle.viewplanes: +particleinview = 1 +fogswitch = -1 +' Perform standard view plane clipping and determine depth 'fog effect'. +givenplanex = nearplane(1) +givenplaney = nearplane(2) +givenplanez = nearplane(3) +givenplaned = nearplane(4) +IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN particleinview = 0 +givenplanex = farplane(1) +givenplaney = farplane(2) +givenplanez = farplane(3) +givenplaned = farplane(4) +IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN particleinview = 0 +IF togglehud = -1 THEN IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned * .9 < 0 THEN fogswitch = 1 +givenplanex = rightplane(1) +givenplaney = rightplane(2) +givenplanez = rightplane(3) +givenplaned = rightplane(4) +IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN particleinview = 0 +givenplanex = leftplane(1) +givenplaney = leftplane(2) +givenplanez = leftplane(3) +givenplaned = leftplane(4) +IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN particleinview = 0 +givenplanex = topplane(1) +givenplaney = topplane(2) +givenplanez = topplane(3) +givenplaned = topplane(4) +IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN particleinview = 0 +givenplanex = bottomplane(1) +givenplaney = bottomplane(2) +givenplanez = bottomplane(3) +givenplaned = bottomplane(4) +IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN particleinview = 0 +IF particleinview = 1 AND togglehud = 1 THEN + ' Apply spotlight effect. + givenplanex = nearplanespotlight(1) + givenplaney = nearplanespotlight(2) + givenplanez = nearplanespotlight(3) + givenplaned = nearplanespotlight(4) + IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN fogswitch = 1 + givenplanex = farplanespotlight(1) + givenplaney = farplanespotlight(2) + givenplanez = farplanespotlight(3) + givenplaned = farplanespotlight(4) + IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN fogswitch = 1 + givenplanex = rightplanespotlight(1) + givenplaney = rightplanespotlight(2) + givenplanez = rightplanespotlight(3) + givenplaned = rightplanespotlight(4) + IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN fogswitch = 1 + givenplanex = leftplanespotlight(1) + givenplaney = leftplanespotlight(2) + givenplanez = leftplanespotlight(3) + givenplaned = leftplanespotlight(4) + IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN fogswitch = 1 + givenplanex = topplanespotlight(1) + givenplaney = topplanespotlight(2) + givenplanez = topplanespotlight(3) + givenplaned = topplanespotlight(4) + IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN fogswitch = 1 + givenplanex = bottomplanespotlight(1) + givenplaney = bottomplanespotlight(2) + givenplanez = bottomplanespotlight(3) + givenplaned = bottomplanespotlight(4) + IF vec(i, 1) * givenplanex + vec(i, 2) * givenplaney + vec(i, 3) * givenplanez - givenplaned < 0 THEN fogswitch = 1 +END IF +IF particleinview = 1 THEN + numparticlevisible = numparticlevisible + 1 + vecvisible(numparticlevisible, 1) = vec(i, 1) + vecvisible(numparticlevisible, 2) = vec(i, 2) + vecvisible(numparticlevisible, 3) = vec(i, 3) + vecvisible(numparticlevisible, 4) = vec(i, 4) + IF fogswitch = 1 THEN vecvisible(numparticlevisible, 4) = 8 +END IF +RETURN + +project.particles: +' Project object vectors onto the screen plane. +FOR i = 1 TO numparticlevisible + vecvisibledotnhat(i) = vecvisible(i, 1) * nhat(1) + vecvisible(i, 2) * nhat(2) + vecvisible(i, 3) * nhat(3) + vecvisiblepuv(i, 1) = (vecvisible(i, 1) * uhat(1) + vecvisible(i, 2) * uhat(2) + vecvisible(i, 3) * uhat(3)) + vecvisiblepuv(i, 2) = (vecvisible(i, 1) * vhat(1) + vecvisible(i, 2) * vhat(2) + vecvisible(i, 3) * vhat(3)) +NEXT +RETURN + +depth.adjust.particles: +IF falsedepth = 0 THEN + FOR i = 1 TO numparticlevisible + vecvisiblepuvs(i, 1) = vecvisiblepuv(i, 1) * fovd / vecvisibledotnhat(i) + vecvisiblepuvs(i, 2) = vecvisiblepuv(i, 2) * fovd / vecvisibledotnhat(i) + NEXT +ELSE + FOR i = 1 TO numparticlevisible + vecvisiblepuvs(i, 1) = vecvisiblepuv(i, 1) * (1 + falsedepth * vecvisibledotnhat(i)) + vecvisiblepuvs(i, 2) = vecvisiblepuv(i, 2) * (1 + falsedepth * vecvisibledotnhat(i)) + NEXT +END IF +RETURN + +draw.all.objects: +SELECT CASE plotmode$ + CASE "molecule": GOSUB plotmode.molecule + CASE "simplepoints": GOSUB plotmode.simplepoints + CASE "neighbortile": GOSUB plotmode.neighbortile + CASE "linearconnect": GOSUB plotmode.linearconnect + CASE "3denvparticles": GOSUB plotmode.3denvparticles + CASE "3denvdoublets" + IF numparticleorig > 0 THEN GOSUB plotmode.simplepoints + IF numdoubletorig > 0 THEN GOSUB plotmode.3denvdoublets + CASE "3denvtriplets": GOSUB plotmode.3denvtriplets + CASE "simplemesh": GOSUB plotmode.simplemesh + CASE "meshtech2": GOSUB plotmode.meshtech2 + CASE "meshtech2planet": GOSUB plotmode.meshtech2planet + CASE "simplepointsbacteria": GOSUB plotmode.simplepointsbacteria + CASE "linearneuron": GOSUB plotmode.linearneuron +END SELECT +COLOR 7 +LOCATE 28, 23: PRINT "SPACE = toggle HUD, ESC = quit." +IF togglehud = 1 THEN + ' Replace basis vector triad. + x = 50 * xhatp.old(1): y = 50 * xhatp.old(2): GOSUB convert + LINE (centerx, centery)-(x, y), 0 + x = 50 * yhatp.old(1): y = 50 * yhatp.old(2): GOSUB convert + LINE (centerx, centery)-(x, y), 0 + x = 50 * zhatp.old(1): y = 50 * zhatp.old(2): GOSUB convert + LINE (centerx, centery)-(x, y), 0 + x = 50 * xhatp(1): y = 50 * xhatp(2): GOSUB convert + LINE (centerx, centery)-(x, y), xhat(4) + x = 50 * yhatp(1): y = 50 * yhatp(2): GOSUB convert + LINE (centerx, centery)-(x, y), yhat(4) + x = 50 * zhatp(1): y = 50 * zhatp(2): GOSUB convert + LINE (centerx, centery)-(x, y), zhat(4) + COLOR 14 + LOCATE 26, 2: PRINT "- MOVE -" + COLOR 15 + LOCATE 27, 2: PRINT " q W e" + LOCATE 28, 2: PRINT " A S D" + COLOR 14 + LOCATE 25, 68: PRINT "- VIEW -" + COLOR 15 + LOCATE 26, 68: PRINT " 8 " + LOCATE 27, 68: PRINT "4 6" + LOCATE 28, 68: PRINT " 2 " + COLOR 7 + LOCATE 26, 75: PRINT "7 9" + LOCATE 27, 75: PRINT " " + LOCATE 28, 75: PRINT "1 3" + IF numparticleorig > 0 AND falsedepth = 0 THEN + COLOR 7 + LOCATE 3, 2: PRINT "- Particle Info -" + LOCATE 4, 2: PRINT " Total:"; numparticleorig + LOCATE 5, 2: PRINT " Visible:"; numparticlevisible + LOCATE 6, 2: PRINT " Percent:"; INT(100 * numparticlevisible / numparticleorig) + LOCATE 8, 2: PRINT " Press '/' to" + LOCATE 9, 2: PRINT " export view." + LOCATE 3, 65: PRINT "- View Planes -" + LOCATE 4, 65: PRINT " Far dist:"; -farplane(4) + LOCATE 5, 65: PRINT " Near dist:"; nearplane(4) + LOCATE 6, 65: PRINT " [,] shift Far" + LOCATE 7, 65: PRINT " <,> shift Near" + LOCATE 9, 65: PRINT "- Spotlight -" + LOCATE 10, 64: PRINT " Center:"; spotlightcenter + LOCATE 11, 64: PRINT " Thick:"; spotlightthickness + LOCATE 12, 64: PRINT " Control keys:" + LOCATE 13, 64: PRINT " ; ' - =" + END IF +END IF +IF toggletimealert = 1 THEN + COLOR 7 + LOCATE 1, 25: PRINT "Press 'T' to toggle animation." +END IF +RETURN + +store.screen.projections: +xhatp.old(1) = xhatp(1): xhatp.old(2) = xhatp(2) +yhatp.old(1) = yhatp(1): yhatp.old(2) = yhatp(2) +zhatp.old(1) = zhatp(1): zhatp.old(2) = zhatp(2) +FOR i = 1 TO numparticlevisible + vecvisiblepuvs.old(i, 1) = vecvisiblepuvs(i, 1) + vecvisiblepuvs.old(i, 2) = vecvisiblepuvs(i, 2) +NEXT +numparticlevisible.old = numparticlevisible +FOR i = 1 TO numdoubletsnip + doubletsnippuvs.old(i, 1) = doubletsnippuvs(i, 1) + doubletsnippuvs.old(i, 2) = doubletsnippuvs(i, 2) + doubletsnippuvs.old(i, 3) = doubletsnippuvs(i, 3) + doubletsnippuvs.old(i, 4) = doubletsnippuvs(i, 4) +NEXT +numdoubletsnip.old = numdoubletsnip +FOR i = 1 TO numtripletfinal + tripletfinalpuvs.old(i, 1) = tripletfinalpuvs(i, 1) + tripletfinalpuvs.old(i, 2) = tripletfinalpuvs(i, 2) + tripletfinalpuvs.old(i, 3) = tripletfinalpuvs(i, 3) + tripletfinalpuvs.old(i, 4) = tripletfinalpuvs(i, 4) + tripletfinalpuvs.old(i, 5) = tripletfinalpuvs(i, 5) + tripletfinalpuvs.old(i, 6) = tripletfinalpuvs(i, 6) +NEXT +numtripletfinal.old = numtripletfinal +RETURN + +compute.viewplanes: +' Define normal vectors to all view planes. +nearplane(1) = -nhat(1) +nearplane(2) = -nhat(2) +nearplane(3) = -nhat(3) +farplane(1) = nhat(1) +farplane(2) = nhat(2) +farplane(3) = nhat(3) +rightplane(1) = (screenheight / 4) * fovd * uhat(1) - (screenheight / 4) * (screenwidth / 4) * nhat(1) +rightplane(2) = (screenheight / 4) * fovd * uhat(2) - (screenheight / 4) * (screenwidth / 4) * nhat(2) +rightplane(3) = (screenheight / 4) * fovd * uhat(3) - (screenheight / 4) * (screenwidth / 4) * nhat(3) +mag = SQR((rightplane(1)) ^ 2 + (rightplane(2)) ^ 2 + (rightplane(3)) ^ 2) +rightplane(1) = rightplane(1) / mag +rightplane(2) = rightplane(2) / mag +rightplane(3) = rightplane(3) / mag +leftplane(1) = -(screenheight / 4) * fovd * uhat(1) - (screenheight / 4) * (screenwidth / 4) * nhat(1) +leftplane(2) = -(screenheight / 4) * fovd * uhat(2) - (screenheight / 4) * (screenwidth / 4) * nhat(2) +leftplane(3) = -(screenheight / 4) * fovd * uhat(3) - (screenheight / 4) * (screenwidth / 4) * nhat(3) +mag = SQR((leftplane(1)) ^ 2 + (leftplane(2)) ^ 2 + (leftplane(3)) ^ 2) +leftplane(1) = leftplane(1) / mag +leftplane(2) = leftplane(2) / mag +leftplane(3) = leftplane(3) / mag +topplane(1) = (screenwidth / 4) * fovd * vhat(1) - (screenheight / 4) * (screenwidth / 4) * nhat(1) +topplane(2) = (screenwidth / 4) * fovd * vhat(2) - (screenheight / 4) * (screenwidth / 4) * nhat(2) +topplane(3) = (screenwidth / 4) * fovd * vhat(3) - (screenheight / 4) * (screenwidth / 4) * nhat(3) +mag = SQR((topplane(1)) ^ 2 + (topplane(2)) ^ 2 + (topplane(3)) ^ 2) +topplane(1) = topplane(1) / mag +topplane(2) = topplane(2) / mag +topplane(3) = topplane(3) / mag +bottomplane(1) = -(screenwidth / 4) * fovd * vhat(1) - (screenheight / 4) * (screenwidth / 4) * nhat(1) +bottomplane(2) = -(screenwidth / 4) * fovd * vhat(2) - (screenheight / 4) * (screenwidth / 4) * nhat(2) +bottomplane(3) = -(screenwidth / 4) * fovd * vhat(3) - (screenheight / 4) * (screenwidth / 4) * nhat(3) +mag = SQR((bottomplane(1)) ^ 2 + (bottomplane(2)) ^ 2 + (bottomplane(3)) ^ 2) +bottomplane(1) = bottomplane(1) / mag +bottomplane(2) = bottomplane(2) / mag +bottomplane(3) = bottomplane(3) / mag +IF togglehud = 1 THEN + nearplanespotlight(4) = spotlightcenter - spotlightthickness / 2 + farplanespotlight(4) = -(spotlightcenter + spotlightthickness / 2) + nearplanespotlight(1) = -nhat(1) + nearplanespotlight(2) = -nhat(2) + nearplanespotlight(3) = -nhat(3) + farplanespotlight(1) = nhat(1) + farplanespotlight(2) = nhat(2) + farplanespotlight(3) = nhat(3) + rightplanespotlight(1) = (screenheight / (4 * spotlightwidth)) * fovd * uhat(1) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(1) + rightplanespotlight(2) = (screenheight / (4 * spotlightwidth)) * fovd * uhat(2) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(2) + rightplanespotlight(3) = (screenheight / (4 * spotlightwidth)) * fovd * uhat(3) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(3) + mag = SQR((rightplanespotlight(1)) ^ 2 + (rightplanespotlight(2)) ^ 2 + (rightplanespotlight(3)) ^ 2) + rightplanespotlight(1) = rightplanespotlight(1) / mag + rightplanespotlight(2) = rightplanespotlight(2) / mag + rightplanespotlight(3) = rightplanespotlight(3) / mag + leftplanespotlight(1) = -(screenheight / (4 * spotlightwidth)) * fovd * uhat(1) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(1) + leftplanespotlight(2) = -(screenheight / (4 * spotlightwidth)) * fovd * uhat(2) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(2) + leftplanespotlight(3) = -(screenheight / (4 * spotlightwidth)) * fovd * uhat(3) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(3) + mag = SQR((leftplanespotlight(1)) ^ 2 + (leftplanespotlight(2)) ^ 2 + (leftplanespotlight(3)) ^ 2) + leftplanespotlight(1) = leftplanespotlight(1) / mag + leftplanespotlight(2) = leftplanespotlight(2) / mag + leftplanespotlight(3) = leftplanespotlight(3) / mag + topplanespotlight(1) = (screenwidth / (4 * spotlightwidth)) * fovd * vhat(1) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(1) + topplanespotlight(2) = (screenwidth / (4 * spotlightwidth)) * fovd * vhat(2) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(2) + topplanespotlight(3) = (screenwidth / (4 * spotlightwidth)) * fovd * vhat(3) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(3) + mag = SQR((topplanespotlight(1)) ^ 2 + (topplanespotlight(2)) ^ 2 + (topplanespotlight(3)) ^ 2) + topplanespotlight(1) = topplanespotlight(1) / mag + topplanespotlight(2) = topplanespotlight(2) / mag + topplanespotlight(3) = topplanespotlight(3) / mag + bottomplanespotlight(1) = -(screenwidth / (4 * spotlightwidth)) * fovd * vhat(1) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(1) + bottomplanespotlight(2) = -(screenwidth / (4 * spotlightwidth)) * fovd * vhat(2) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(2) + bottomplanespotlight(3) = -(screenwidth / (4 * spotlightwidth)) * fovd * vhat(3) - (screenheight / (4 * spotlightwidth)) * (screenwidth / (4 * spotlightwidth)) * nhat(3) + mag = SQR((bottomplanespotlight(1)) ^ 2 + (bottomplanespotlight(2)) ^ 2 + (bottomplanespotlight(3)) ^ 2) + bottomplanespotlight(1) = bottomplanespotlight(1) / mag + bottomplanespotlight(2) = bottomplanespotlight(2) / mag + bottomplanespotlight(3) = bottomplanespotlight(3) / mag +END IF +RETURN + +' *** Define functions for doublet manipulations. *** + +project.doublets: +FOR i = 1 TO numdoubletclip + doubletclipdotnhat(i, 1) = doubletclip(i, 1) * nhat(1) + doubletclip(i, 2) * nhat(2) + doubletclip(i, 3) * nhat(3) + doubletclipdotnhat(i, 2) = doubletclip(i, 4) * nhat(1) + doubletclip(i, 5) * nhat(2) + doubletclip(i, 6) * nhat(3) + doubletclippuv(i, 1) = doubletclip(i, 1) * uhat(1) + doubletclip(i, 2) * uhat(2) + doubletclip(i, 3) * uhat(3) + doubletclippuv(i, 2) = doubletclip(i, 1) * vhat(1) + doubletclip(i, 2) * vhat(2) + doubletclip(i, 3) * vhat(3) + doubletclippuv(i, 3) = doubletclip(i, 4) * uhat(1) + doubletclip(i, 5) * uhat(2) + doubletclip(i, 6) * uhat(3) + doubletclippuv(i, 4) = doubletclip(i, 4) * vhat(1) + doubletclip(i, 5) * vhat(2) + doubletclip(i, 6) * vhat(3) +NEXT +FOR i = 1 TO numdoubletsnip + doubletsnipdotnhat(i, 1) = doubletsnip(i, 1) * nhat(1) + doubletsnip(i, 2) * nhat(2) + doubletsnip(i, 3) * nhat(3) + doubletsnipdotnhat(i, 2) = doubletsnip(i, 4) * nhat(1) + doubletsnip(i, 5) * nhat(2) + doubletsnip(i, 6) * nhat(3) + doubletsnippuv(i, 1) = doubletsnip(i, 1) * uhat(1) + doubletsnip(i, 2) * uhat(2) + doubletsnip(i, 3) * uhat(3) + doubletsnippuv(i, 2) = doubletsnip(i, 1) * vhat(1) + doubletsnip(i, 2) * vhat(2) + doubletsnip(i, 3) * vhat(3) + doubletsnippuv(i, 3) = doubletsnip(i, 4) * uhat(1) + doubletsnip(i, 5) * uhat(2) + doubletsnip(i, 6) * uhat(3) + doubletsnippuv(i, 4) = doubletsnip(i, 4) * vhat(1) + doubletsnip(i, 5) * vhat(2) + doubletsnip(i, 6) * vhat(3) +NEXT +RETURN + +depth.adjust.doublets: +FOR i = 1 TO numdoubletclip + doubletclippuvs(i, 1) = doubletclippuv(i, 1) * fovd / doubletclipdotnhat(i, 1) + doubletclippuvs(i, 2) = doubletclippuv(i, 2) * fovd / doubletclipdotnhat(i, 1) + doubletclippuvs(i, 3) = doubletclippuv(i, 3) * fovd / doubletclipdotnhat(i, 2) + doubletclippuvs(i, 4) = doubletclippuv(i, 4) * fovd / doubletclipdotnhat(i, 2) +NEXT +FOR i = 1 TO numdoubletsnip + doubletsnippuvs(i, 1) = doubletsnippuv(i, 1) * fovd / doubletsnipdotnhat(i, 1) + doubletsnippuvs(i, 2) = doubletsnippuv(i, 2) * fovd / doubletsnipdotnhat(i, 1) + doubletsnippuvs(i, 3) = doubletsnippuv(i, 3) * fovd / doubletsnipdotnhat(i, 2) + doubletsnippuvs(i, 4) = doubletsnippuv(i, 4) * fovd / doubletsnipdotnhat(i, 2) +NEXT +RETURN + +' *** Define functions for doublet viewplane clipping. *** + +copy.doublets.orig.clip: +FOR i = 1 TO numdoubletorig + doubletclip(i, 1) = doubletorig(i, 1) + doubletclip(i, 2) = doubletorig(i, 2) + doubletclip(i, 3) = doubletorig(i, 3) + doubletclip(i, 4) = doubletorig(i, 4) + doubletclip(i, 5) = doubletorig(i, 5) + doubletclip(i, 6) = doubletorig(i, 6) + doubletclip(i, 7) = doubletorig(i, 7) +NEXT +numdoubletclip = numdoubletorig +RETURN + +copy.doublets.clipwork.clip: +FOR i = 1 TO pcountdoubletclipwork + doubletclip(i, 1) = doubletclipwork(i, 1) + doubletclip(i, 2) = doubletclipwork(i, 2) + doubletclip(i, 3) = doubletclipwork(i, 3) + doubletclip(i, 4) = doubletclipwork(i, 4) + doubletclip(i, 5) = doubletclipwork(i, 5) + doubletclip(i, 6) = doubletclipwork(i, 6) + doubletclip(i, 7) = doubletclipwork(i, 7) +NEXT +numdoubletclip = pcountdoubletclipwork +RETURN + +'clip.doublets.nearplane: +'pcountdoubletclipwork = 0 +'FOR i = 1 TO numdoubletclip +' doubletclip1dotnearplane = doubletclip(i, 1) * nearplane(1) + doubletclip(i, 2) * nearplane(2) + doubletclip(i, 3) * nearplane(3) +' doubletclip2dotnearplane = doubletclip(i, 4) * nearplane(1) + doubletclip(i, 5) * nearplane(2) + doubletclip(i, 6) * nearplane(3) +' gamma = doubletclip2dotnearplane / doubletclip1dotnearplane +' Ax = (doubletclip(i, 1) - doubletclip(i, 4)) / (1 - gamma) +' Ay = (doubletclip(i, 2) - doubletclip(i, 5)) / (1 - gamma) +' Az = (doubletclip(i, 3) - doubletclip(i, 6)) / (1 - gamma) +' Bx = gamma * Ax +' By = gamma * Ay +' Bz = gamma * Az +' Adotnearplane = Ax * nearplane(1) + Ay * nearplane(2) + Az * nearplane(3) +' Bdotnearplane = Bx * nearplane(1) + By * nearplane(2) + Bz * nearplane(3) +' IF Adotnearplane > nearplane(4) AND Bdotnearplane > nearplane(4) THEN +' pcountdoubletclipwork = pcountdoubletclipwork + 1 +' doubletclipwork(pcountdoubletclipwork, 1) = doubletclip(i, 1) +' doubletclipwork(pcountdoubletclipwork, 2) = doubletclip(i, 2) +' doubletclipwork(pcountdoubletclipwork, 3) = doubletclip(i, 3) +' doubletclipwork(pcountdoubletclipwork, 4) = doubletclip(i, 4) +' doubletclipwork(pcountdoubletclipwork, 5) = doubletclip(i, 5) +' doubletclipwork(pcountdoubletclipwork, 6) = doubletclip(i, 6) +' doubletclipwork(pcountdoubletclipwork, 7) = doubletclip(i, 7) +' END IF +' IF Adotnearplane < nearplane(4) AND Bdotnearplane < nearplane(4) THEN +' END IF +' IF Adotnearplane > nearplane(4) AND Bdotnearplane < nearplane(4) THEN +' pcountdoubletclipwork = pcountdoubletclipwork + 1 +' doubletclipwork(pcountdoubletclipwork, 1) = doubletclip(i, 1) +' doubletclipwork(pcountdoubletclipwork, 2) = doubletclip(i, 2) +' doubletclipwork(pcountdoubletclipwork, 3) = doubletclip(i, 3) +' doubletclipwork(pcountdoubletclipwork, 4) = doubletclip(i, 4) - Bx + nearplane(4) * nearplane(1) +' doubletclipwork(pcountdoubletclipwork, 5) = doubletclip(i, 5) - By + nearplane(4) * nearplane(2) +' doubletclipwork(pcountdoubletclipwork, 6) = doubletclip(i, 6) - Bz + nearplane(4) * nearplane(3) +' doubletclipwork(pcountdoubletclipwork, 7) = doubletclip(i, 7) +' END IF +' IF Adotnearplane < nearplane(4) AND Bdotnearplane > nearplane(4) THEN +' pcountdoubletclipwork = pcountdoubletclipwork + 1 +' doubletclipwork(pcountdoubletclipwork, 1) = doubletclip(i, 1) - Ax + nearplane(4) * nearplane(1) +' doubletclipwork(pcountdoubletclipwork, 2) = doubletclip(i, 2) - Ay + nearplane(4) * nearplane(2) +' doubletclipwork(pcountdoubletclipwork, 3) = doubletclip(i, 3) - Az + nearplane(4) * nearplane(3) +' doubletclipwork(pcountdoubletclipwork, 4) = doubletclip(i, 4) +' doubletclipwork(pcountdoubletclipwork, 5) = doubletclip(i, 5) +' doubletclipwork(pcountdoubletclipwork, 6) = doubletclip(i, 6) +' doubletclipwork(pcountdoubletclipwork, 7) = doubletclip(i, 7) +' END IF +'NEXT +'RETURN + +clip.doublets.viewplanes: +givenplanex = nearplane(1) +givenplaney = nearplane(2) +givenplanez = nearplane(3) +givenplaned = nearplane(4) +GOSUB clip.doublets.givenplane +GOSUB copy.doublets.clipwork.clip +givenplanex = rightplane(1) +givenplaney = rightplane(2) +givenplanez = rightplane(3) +givenplaned = rightplane(4) +GOSUB clip.doublets.givenplane +GOSUB copy.doublets.clipwork.clip +givenplanex = leftplane(1) +givenplaney = leftplane(2) +givenplanez = leftplane(3) +givenplaned = leftplane(4) +GOSUB clip.doublets.givenplane +GOSUB copy.doublets.clipwork.clip +givenplanex = topplane(1) +givenplaney = topplane(2) +givenplanez = topplane(3) +givenplaned = topplane(4) +GOSUB clip.doublets.givenplane +GOSUB copy.doublets.clipwork.clip +givenplanex = bottomplane(1) +givenplaney = bottomplane(2) +givenplanez = bottomplane(3) +givenplaned = bottomplane(4) +GOSUB clip.doublets.givenplane +GOSUB copy.doublets.clipwork.clip +RETURN + +clip.doublets.givenplane: +pcountdoubletclipwork = 0 +FOR i = 1 TO numdoubletclip + doubletclip1dotgivenplane = doubletclip(i, 1) * givenplanex + doubletclip(i, 2) * givenplaney + doubletclip(i, 3) * givenplanez + doubletclip2dotgivenplane = doubletclip(i, 4) * givenplanex + doubletclip(i, 5) * givenplaney + doubletclip(i, 6) * givenplanez + gamma = doubletclip2dotgivenplane / doubletclip1dotgivenplane + Ax = (doubletclip(i, 1) - doubletclip(i, 4)) / (1 - gamma) + Ay = (doubletclip(i, 2) - doubletclip(i, 5)) / (1 - gamma) + Az = (doubletclip(i, 3) - doubletclip(i, 6)) / (1 - gamma) + Bx = gamma * Ax + By = gamma * Ay + Bz = gamma * Az + Adotgivenplane = Ax * givenplanex + Ay * givenplaney + Az * givenplanez - givenplaned + Bdotgivenplane = Bx * givenplanex + By * givenplaney + Bz * givenplanez - givenplaned + IF Adotgivenplane > 0 AND Bdotgivenplane > 0 THEN + pcountdoubletclipwork = pcountdoubletclipwork + 1 + doubletclipwork(pcountdoubletclipwork, 1) = doubletclip(i, 1) + doubletclipwork(pcountdoubletclipwork, 2) = doubletclip(i, 2) + doubletclipwork(pcountdoubletclipwork, 3) = doubletclip(i, 3) + doubletclipwork(pcountdoubletclipwork, 4) = doubletclip(i, 4) + doubletclipwork(pcountdoubletclipwork, 5) = doubletclip(i, 5) + doubletclipwork(pcountdoubletclipwork, 6) = doubletclip(i, 6) + doubletclipwork(pcountdoubletclipwork, 7) = doubletclip(i, 7) + END IF + IF Adotgivenplane > 0 AND Bdotgivenplane < 0 THEN + pcountdoubletclipwork = pcountdoubletclipwork + 1 + doubletclipwork(pcountdoubletclipwork, 1) = doubletclip(i, 1) + doubletclipwork(pcountdoubletclipwork, 2) = doubletclip(i, 2) + doubletclipwork(pcountdoubletclipwork, 3) = doubletclip(i, 3) + doubletclipwork(pcountdoubletclipwork, 4) = doubletclip(i, 4) - Bx + givenplaned * givenplanex + doubletclipwork(pcountdoubletclipwork, 5) = doubletclip(i, 5) - By + givenplaned * givenplaney + doubletclipwork(pcountdoubletclipwork, 6) = doubletclip(i, 6) - Bz + givenplaned * givenplanez + doubletclipwork(pcountdoubletclipwork, 7) = doubletclip(i, 7) + END IF + IF Adotgivenplane < 0 AND Bdotgivenplane > 0 THEN + pcountdoubletclipwork = pcountdoubletclipwork + 1 + doubletclipwork(pcountdoubletclipwork, 1) = doubletclip(i, 1) - Ax + givenplaned * givenplanex + doubletclipwork(pcountdoubletclipwork, 2) = doubletclip(i, 2) - Ay + givenplaned * givenplaney + doubletclipwork(pcountdoubletclipwork, 3) = doubletclip(i, 3) - Az + givenplaned * givenplanez + doubletclipwork(pcountdoubletclipwork, 4) = doubletclip(i, 4) + doubletclipwork(pcountdoubletclipwork, 5) = doubletclip(i, 5) + doubletclipwork(pcountdoubletclipwork, 6) = doubletclip(i, 6) + doubletclipwork(pcountdoubletclipwork, 7) = doubletclip(i, 7) + END IF +NEXT +RETURN + +' *** Define functions for doublet snipping. *** + +copy.doublets.clip.snip: +FOR i = 1 TO numdoubletclip + doubletsnip(i, 1) = doubletclip(i, 1) + doubletsnip(i, 2) = doubletclip(i, 2) + doubletsnip(i, 3) = doubletclip(i, 3) + doubletsnip(i, 4) = doubletclip(i, 4) + doubletsnip(i, 5) = doubletclip(i, 5) + doubletsnip(i, 6) = doubletclip(i, 6) + doubletsnip(i, 7) = doubletclip(i, 7) +NEXT +numdoubletsnip = numdoubletclip +RETURN + +copy.doublets.snipwork.snip: +FOR i = 1 TO snipworkpcount + doubletsnip(i, 1) = doubletsnipwork(i, 1) + doubletsnip(i, 2) = doubletsnipwork(i, 2) + doubletsnip(i, 3) = doubletsnipwork(i, 3) + doubletsnip(i, 4) = doubletsnipwork(i, 4) + doubletsnip(i, 5) = doubletsnipwork(i, 5) + doubletsnip(i, 6) = doubletsnipwork(i, 6) + doubletsnip(i, 7) = doubletsnipwork(i, 7) +NEXT +numdoubletsnip = snipworkpcount +RETURN + +snip.doublets: +snipworkpcount = 0 +FOR i = 1 TO numdoubletsnip + Ax = doubletsnip(i, 1) + Ay = doubletsnip(i, 2) + Az = doubletsnip(i, 3) + Bx = doubletsnip(i, 4) + By = doubletsnip(i, 5) + Bz = doubletsnip(i, 6) + Au = doubletsnippuv(i, 1) + Av = doubletsnippuv(i, 2) + Bu = doubletsnippuv(i, 3) + Bv = doubletsnippuv(i, 4) + An = doubletsnipdotnhat(i, 1) + Bn = doubletsnipdotnhat(i, 2) + Asu = doubletsnippuvs(i, 1) + Asv = doubletsnippuvs(i, 2) + Bsu = doubletsnippuvs(i, 3) + Bsv = doubletsnippuvs(i, 4) + numintersections = 0 + FOR j = 1 TO numdoubletsnip + IF i <> j THEN + Cx = doubletsnip(j, 1) + Cy = doubletsnip(j, 2) + Cz = doubletsnip(j, 3) + Dx = doubletsnip(j, 4) + Dy = doubletsnip(j, 5) + Dz = doubletsnip(j, 6) + Cu = doubletsnippuv(j, 1) + Cv = doubletsnippuv(j, 2) + Du = doubletsnippuv(j, 3) + Dv = doubletsnippuv(j, 4) + Cn = doubletsnipdotnhat(j, 1) + Dn = doubletsnipdotnhat(j, 2) + Csu = doubletsnippuvs(j, 1) + Csv = doubletsnippuvs(j, 2) + Dsu = doubletsnippuvs(j, 3) + Dsv = doubletsnippuvs(j, 4) + magdoubletABps = SQR((Bsu - Asu) ^ 2 + (Bsv - Asv) ^ 2) + magdoubletCDps = SQR((Dsu - Csu) ^ 2 + (Dsv - Csv) ^ 2) + slopeAB = (Bsv - Asv) / (Bsu - Asu) + intAB = Asv - slopeAB * Asu + slopeCD = (Dsv - Csv) / (Dsu - Csu) + intCD = Csv - slopeCD * Csu + xstar = -(intAB - intCD) / (slopeAB - slopeCD) + ystar = slopeAB * xstar + intAB + alphaAB1u = -xstar + Asu + alphaAB1v = -ystar + Asv + alphaAB2u = -xstar + Bsu + alphaAB2v = -ystar + Bsv + alphaCD1u = -xstar + Csu + alphaCD1v = -ystar + Csv + alphaCD2u = -xstar + Dsu + alphaCD2v = -ystar + Dsv + magalphaAB1 = SQR(alphaAB1u ^ 2 + alphaAB1v ^ 2) + magalphaAB2 = SQR(alphaAB2u ^ 2 + alphaAB2v ^ 2) + magalphaCD1 = SQR(alphaCD1u ^ 2 + alphaCD1v ^ 2) + magalphaCD2 = SQR(alphaCD2u ^ 2 + alphaCD2v ^ 2) + IF magalphaAB1 < magdoubletABps AND magalphaAB2 < magdoubletABps AND magalphaCD1 < magdoubletCDps AND magalphaCD2 < magdoubletCDps THEN + qAB1u = (Asu - alphaAB1u) / fovd + '*'qAB1v = (Asv - alphaAB1v) / fovd ' (Nonessential but interesting.) + numerator = qAB1u * An - Au + denominator = Bu - Au + qAB1u * (An - Bn) + betaAB1 = numerator / denominator + '*'betaAB2 = 1 - betaAB1 ' (Nonessential but interesting.) + '*'qCD1u = (Csu - alphaCD1u) / fovd ' (Nonessential but interesting.) + '*'numerator = qCD1u * Cn - Cu ' (Nonessential but interesting.) + '*'denominator = Du - Cu + qCD1u * (Cn - Dn) ' (Nonessential but interesting.) + '*'betaCD1 = numerator / denominator ' (Nonessential but interesting.) + '*'betaCD2 = 1 - betaCD1 ' (Nonessential but interesting.) + numintersections = numintersections + 1 + doubletintinfo(numintersections, 1) = j + doubletintinfo(numintersections, 2) = betaAB1 + END IF + END IF + NEXT + IF numintersections = 0 THEN + snipworkpcount = snipworkpcount + 1 + doubletsnipwork(snipworkpcount, 1) = Ax + doubletsnipwork(snipworkpcount, 2) = Ay + doubletsnipwork(snipworkpcount, 3) = Az + doubletsnipwork(snipworkpcount, 4) = Bx + doubletsnipwork(snipworkpcount, 5) = By + doubletsnipwork(snipworkpcount, 6) = Bz + doubletsnipwork(snipworkpcount, 7) = doubletsnip(i, 7) + ELSE + IF numintersections = 1 THEN + snipworkpcount = snipworkpcount + 1 + doubletsnipwork(snipworkpcount, 1) = Ax + doubletsnipwork(snipworkpcount, 2) = Ay + doubletsnipwork(snipworkpcount, 3) = Az + doubletsnipwork(snipworkpcount, 4) = Ax * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * Bx + doubletsnipwork(snipworkpcount, 5) = Ay * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * By + doubletsnipwork(snipworkpcount, 6) = Az * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * Bz + doubletsnipwork(snipworkpcount, 7) = doubletsnip(i, 7) + snipworkpcount = snipworkpcount + 1 + doubletsnipwork(snipworkpcount, 1) = Ax * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * Bx + doubletsnipwork(snipworkpcount, 2) = Ay * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * By + doubletsnipwork(snipworkpcount, 3) = Az * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * Bz + doubletsnipwork(snipworkpcount, 4) = Bx + doubletsnipwork(snipworkpcount, 5) = By + doubletsnipwork(snipworkpcount, 6) = Bz + doubletsnipwork(snipworkpcount, 7) = doubletsnip(i, 7) + ELSE + snipworkpcount = snipworkpcount + 1 + doubletsnipwork(snipworkpcount, 1) = Ax + doubletsnipwork(snipworkpcount, 2) = Ay + doubletsnipwork(snipworkpcount, 3) = Az + doubletsnipwork(snipworkpcount, 4) = Ax * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * Bx + doubletsnipwork(snipworkpcount, 5) = Ay * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * By + doubletsnipwork(snipworkpcount, 6) = Az * (1 - doubletintinfo(1, 2)) + doubletintinfo(1, 2) * Bz + doubletsnipwork(snipworkpcount, 7) = doubletsnip(i, 7) + snipworkpcount = snipworkpcount + 1 + doubletsnipwork(snipworkpcount, 1) = Ax * (1 - doubletintinfo(numintersections, 2)) + doubletintinfo(numintersections, 2) * Bx + doubletsnipwork(snipworkpcount, 2) = Ay * (1 - doubletintinfo(numintersections, 2)) + doubletintinfo(numintersections, 2) * By + doubletsnipwork(snipworkpcount, 3) = Az * (1 - doubletintinfo(numintersections, 2)) + doubletintinfo(numintersections, 2) * Bz + doubletsnipwork(snipworkpcount, 4) = Bx + doubletsnipwork(snipworkpcount, 5) = By + doubletsnipwork(snipworkpcount, 6) = Bz + doubletsnipwork(snipworkpcount, 7) = doubletsnip(i, 7) + FOR k = 1 TO numintersections - 1 + snipworkpcount = snipworkpcount + 1 + doubletsnipwork(snipworkpcount, 1) = Ax * (1 - doubletintinfo(k, 2)) + doubletintinfo(k, 2) * Bx + doubletsnipwork(snipworkpcount, 2) = Ay * (1 - doubletintinfo(k, 2)) + doubletintinfo(k, 2) * By + doubletsnipwork(snipworkpcount, 3) = Az * (1 - doubletintinfo(k, 2)) + doubletintinfo(k, 2) * Bz + doubletsnipwork(snipworkpcount, 4) = Ax * (1 - doubletintinfo(k + 1, 2)) + doubletintinfo(k + 1, 2) * Bx + doubletsnipwork(snipworkpcount, 5) = Ay * (1 - doubletintinfo(k + 1, 2)) + doubletintinfo(k + 1, 2) * By + doubletsnipwork(snipworkpcount, 6) = Az * (1 - doubletintinfo(k + 1, 2)) + doubletintinfo(k + 1, 2) * Bz + doubletsnipwork(snipworkpcount, 7) = doubletsnip(i, 7) + NEXT + END IF + END IF +NEXT +RETURN + +' *** Define functions for triplet manipulations. *** + +project.triplets: +FOR i = 1 TO numtripletfinal + tripletfinaldotnhat(i, 1) = tripletfinal(i, 1) * nhat(1) + tripletfinal(i, 2) * nhat(2) + tripletfinal(i, 3) * nhat(3) + tripletfinaldotnhat(i, 2) = tripletfinal(i, 4) * nhat(1) + tripletfinal(i, 5) * nhat(2) + tripletfinal(i, 6) * nhat(3) + tripletfinaldotnhat(i, 3) = tripletfinal(i, 7) * nhat(1) + tripletfinal(i, 8) * nhat(2) + tripletfinal(i, 9) * nhat(3) + tripletfinalpuv(i, 1) = tripletfinal(i, 1) * uhat(1) + tripletfinal(i, 2) * uhat(2) + tripletfinal(i, 3) * uhat(3) + tripletfinalpuv(i, 2) = tripletfinal(i, 1) * vhat(1) + tripletfinal(i, 2) * vhat(2) + tripletfinal(i, 3) * vhat(3) + tripletfinalpuv(i, 3) = tripletfinal(i, 4) * uhat(1) + tripletfinal(i, 5) * uhat(2) + tripletfinal(i, 6) * uhat(3) + tripletfinalpuv(i, 4) = tripletfinal(i, 4) * vhat(1) + tripletfinal(i, 5) * vhat(2) + tripletfinal(i, 6) * vhat(3) + tripletfinalpuv(i, 5) = tripletfinal(i, 7) * uhat(1) + tripletfinal(i, 8) * uhat(2) + tripletfinal(i, 9) * uhat(3) + tripletfinalpuv(i, 6) = tripletfinal(i, 7) * vhat(1) + tripletfinal(i, 8) * vhat(2) + tripletfinal(i, 9) * vhat(3) +NEXT +RETURN + +depth.adjust.triplets: +FOR i = 1 TO numtripletfinal + tripletfinalpuvs(i, 1) = tripletfinalpuv(i, 1) * fovd / tripletfinaldotnhat(i, 1) + tripletfinalpuvs(i, 2) = tripletfinalpuv(i, 2) * fovd / tripletfinaldotnhat(i, 1) + tripletfinalpuvs(i, 3) = tripletfinalpuv(i, 3) * fovd / tripletfinaldotnhat(i, 2) + tripletfinalpuvs(i, 4) = tripletfinalpuv(i, 4) * fovd / tripletfinaldotnhat(i, 2) + tripletfinalpuvs(i, 5) = tripletfinalpuv(i, 5) * fovd / tripletfinaldotnhat(i, 3) + tripletfinalpuvs(i, 6) = tripletfinalpuv(i, 6) * fovd / tripletfinaldotnhat(i, 3) +NEXT +RETURN + +' *** Define functions for triplet backface culling. *** + +triplet.filter.faceon: +pcounttripletfaceon = 0 +FOR i = 1 TO numtripletorig + Ax = tripletorig(i, 4) - tripletorig(i, 1) + Ay = tripletorig(i, 5) - tripletorig(i, 2) + Az = tripletorig(i, 6) - tripletorig(i, 3) + Bx = tripletorig(i, 7) - tripletorig(i, 1) + By = tripletorig(i, 8) - tripletorig(i, 2) + Bz = tripletorig(i, 9) - tripletorig(i, 3) + centroiDx = (1 / 3) * (tripletorig(i, 1) + tripletorig(i, 4) + tripletorig(i, 7)) + centroiDy = (1 / 3) * (tripletorig(i, 2) + tripletorig(i, 5) + tripletorig(i, 8)) + centroidz = (1 / 3) * (tripletorig(i, 3) + tripletorig(i, 6) + tripletorig(i, 9)) + PanelNormx = Ay * Bz - Az * By + PanelNormy = Az * Bx - Ax * Bz + PanelNormz = Ax * By - Ay * Bx + mag = SQR(PanelNormx ^ 2 + PanelNormy ^ 2 + PanelNormz ^ 2) + PanelNormx = PanelNormx / mag + PanelNormy = PanelNormy / mag + PanelNormz = PanelNormz / mag + panelnormdotnhat = PanelNormx * nhat(1) + PanelNormy * nhat(2) + PanelNormz * nhat(3) + cullpoint = PanelNormx * centroiDx + PanelNormy * centroiDy + PanelNormz * centroidz + IF panelnormdotnhat >= cullpoint THEN + pcounttripletfaceon = pcounttripletfaceon + 1 + tripletfaceon(pcounttripletfaceon, 1) = tripletorig(i, 1) + tripletfaceon(pcounttripletfaceon, 2) = tripletorig(i, 2) + tripletfaceon(pcounttripletfaceon, 3) = tripletorig(i, 3) + tripletfaceon(pcounttripletfaceon, 4) = tripletorig(i, 4) + tripletfaceon(pcounttripletfaceon, 5) = tripletorig(i, 5) + tripletfaceon(pcounttripletfaceon, 6) = tripletorig(i, 6) + tripletfaceon(pcounttripletfaceon, 7) = tripletorig(i, 7) + tripletfaceon(pcounttripletfaceon, 8) = tripletorig(i, 8) + tripletfaceon(pcounttripletfaceon, 9) = tripletorig(i, 9) + tripletfaceon(pcounttripletfaceon, 10) = tripletorig(i, 10) + ELSE + 'pcounttripletfaceon = pcounttripletfaceon + 1 + 'tripletfaceon(pcounttripletfaceon, 1) = tripletorig(i, 1) + 'tripletfaceon(pcounttripletfaceon, 2) = tripletorig(i, 2) + 'tripletfaceon(pcounttripletfaceon, 3) = tripletorig(i, 3) + 'tripletfaceon(pcounttripletfaceon, 4) = tripletorig(i, 4) + 'tripletfaceon(pcounttripletfaceon, 5) = tripletorig(i, 5) + 'tripletfaceon(pcounttripletfaceon, 6) = tripletorig(i, 6) + 'tripletfaceon(pcounttripletfaceon, 7) = tripletorig(i, 7) + 'tripletfaceon(pcounttripletfaceon, 8) = tripletorig(i, 8) + 'tripletfaceon(pcounttripletfaceon, 9) = tripletorig(i, 9) + 'tripletfaceon(pcounttripletfaceon, 10) = 8 + END IF +NEXT +numtripletfaceon = pcounttripletfaceon +RETURN + +' *** Define functions for triplet viewplane clipping. *** + + +copy.triplets.faceon.clip: +FOR i = 1 TO numtripletfaceon + tripletclip(i, 1) = tripletfaceon(i, 1) + tripletclip(i, 2) = tripletfaceon(i, 2) + tripletclip(i, 3) = tripletfaceon(i, 3) + tripletclip(i, 4) = tripletfaceon(i, 4) + tripletclip(i, 5) = tripletfaceon(i, 5) + tripletclip(i, 6) = tripletfaceon(i, 6) + tripletclip(i, 7) = tripletfaceon(i, 7) + tripletclip(i, 8) = tripletfaceon(i, 8) + tripletclip(i, 9) = tripletfaceon(i, 9) + tripletclip(i, 10) = tripletfaceon(i, 10) +NEXT +numtripletclip = numtripletfaceon +RETURN + +copy.triplets.clipwork.clip: +FOR i = 1 TO pcounttripletclipwork + tripletclip(i, 1) = tripletclipwork(i, 1) + tripletclip(i, 2) = tripletclipwork(i, 2) + tripletclip(i, 3) = tripletclipwork(i, 3) + tripletclip(i, 4) = tripletclipwork(i, 4) + tripletclip(i, 5) = tripletclipwork(i, 5) + tripletclip(i, 6) = tripletclipwork(i, 6) + tripletclip(i, 7) = tripletclipwork(i, 7) + tripletclip(i, 8) = tripletclipwork(i, 8) + tripletclip(i, 9) = tripletclipwork(i, 9) + tripletclip(i, 10) = tripletclipwork(i, 10) +NEXT +numtripletclip = pcounttripletclipwork +RETURN + +clip.triplets.viewplanes: +givenplanex = nearplane(1) +givenplaney = nearplane(2) +givenplanez = nearplane(3) +givenplaned = nearplane(4) +GOSUB clip.triplets.givenplane +GOSUB copy.triplets.clipwork.clip +givenplanex = rightplane(1) +givenplaney = rightplane(2) +givenplanez = rightplane(3) +givenplaned = rightplane(4) +GOSUB clip.triplets.givenplane +GOSUB copy.triplets.clipwork.clip +givenplanex = leftplane(1) +givenplaney = leftplane(2) +givenplanez = leftplane(3) +givenplaned = leftplane(4) +GOSUB clip.triplets.givenplane +GOSUB copy.triplets.clipwork.clip +givenplanex = topplane(1) +givenplaney = topplane(2) +givenplanez = topplane(3) +givenplaned = topplane(4) +GOSUB clip.triplets.givenplane +GOSUB copy.triplets.clipwork.clip +givenplanex = bottomplane(1) +givenplaney = bottomplane(2) +givenplanez = bottomplane(3) +givenplaned = bottomplane(4) +GOSUB clip.triplets.givenplane +GOSUB copy.triplets.clipwork.clip +RETURN + +clip.triplets.givenplane: +pcounttripletclipwork = 0 +FOR i = 1 TO numtripletclip + tripletclip1dotgivenplane = tripletclip(i, 1) * givenplanex + tripletclip(i, 2) * givenplaney + tripletclip(i, 3) * givenplanez - givenplaned + tripletclip2dotgivenplane = tripletclip(i, 4) * givenplanex + tripletclip(i, 5) * givenplaney + tripletclip(i, 6) * givenplanez - givenplaned + tripletclip3dotgivenplane = tripletclip(i, 7) * givenplanex + tripletclip(i, 8) * givenplaney + tripletclip(i, 9) * givenplanez - givenplaned + gamma12 = tripletclip2dotgivenplane / tripletclip1dotgivenplane + gamma23 = tripletclip3dotgivenplane / tripletclip2dotgivenplane + gamma31 = tripletclip1dotgivenplane / tripletclip3dotgivenplane + A12x = (tripletclip(i, 1) - tripletclip(i, 4)) / (1 - gamma12) + A12y = (tripletclip(i, 2) - tripletclip(i, 5)) / (1 - gamma12) + A12z = (tripletclip(i, 3) - tripletclip(i, 6)) / (1 - gamma12) + B12x = gamma12 * A12x + B12y = gamma12 * A12y + B12z = gamma12 * A12z + A23x = (tripletclip(i, 4) - tripletclip(i, 7)) / (1 - gamma23) + A23y = (tripletclip(i, 5) - tripletclip(i, 8)) / (1 - gamma23) + A23z = (tripletclip(i, 6) - tripletclip(i, 9)) / (1 - gamma23) + B23x = gamma23 * A23x + B23y = gamma23 * A23y + B23z = gamma23 * A23z + A31x = (tripletclip(i, 7) - tripletclip(i, 1)) / (1 - gamma31) + A31y = (tripletclip(i, 8) - tripletclip(i, 2)) / (1 - gamma31) + A31z = (tripletclip(i, 9) - tripletclip(i, 3)) / (1 - gamma31) + B31x = gamma31 * A31x + B31y = gamma31 * A31y + B31z = gamma31 * A31z + A12dotgivenplane = A12x * givenplanex + A12y * givenplaney + A12z * givenplanez + B12dotgivenplane = B12x * givenplanex + B12y * givenplaney + B12z * givenplanez + A23dotgivenplane = A23x * givenplanex + A23y * givenplaney + A23z * givenplanez + B23dotgivenplane = B23x * givenplanex + B23y * givenplaney + B23z * givenplanez + A31dotgivenplane = A31x * givenplanex + A31y * givenplaney + A31z * givenplanez + B31dotgivenplane = B31x * givenplanex + B31y * givenplaney + B31z * givenplanez + IF A12dotgivenplane > 0 AND B12dotgivenplane > 0 AND A23dotgivenplane > 0 AND B23dotgivenplane > 0 AND A31dotgivenplane > 0 AND B31dotgivenplane > 0 THEN + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 1) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 2) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 3) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 4) + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 5) + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 6) + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 7) + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 8) + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 9) + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + panelinview = 1 + END IF + IF A12dotgivenplane > 0 AND B12dotgivenplane > 0 AND A23dotgivenplane > 0 AND B23dotgivenplane < 0 AND A31dotgivenplane < 0 AND B31dotgivenplane > 0 THEN + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 1) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 2) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 3) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 1) - B31x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 2) - B31y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 3) - B31z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 7) - B23x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 8) - B23y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 9) - B23z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 1) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 2) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 3) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 4) + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 5) + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 6) + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 7) - B23x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 8) - B23y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 9) - B23z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + END IF + IF A12dotgivenplane < 0 AND B12dotgivenplane > 0 AND A23dotgivenplane > 0 AND B23dotgivenplane > 0 AND A31dotgivenplane > 0 AND B31dotgivenplane < 0 THEN + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 7) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 8) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 9) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 1) - B31x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 2) - B31y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 3) - B31z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 4) + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 5) + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 6) + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 4) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 5) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 6) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 1) - B31x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 2) - B31y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 3) - B31z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 4) - B12x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 5) - B12y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 6) - B12z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + END IF + IF A12dotgivenplane > 0 AND B12dotgivenplane < 0 AND A23dotgivenplane < 0 AND B23dotgivenplane > 0 AND A31dotgivenplane > 0 AND B31dotgivenplane > 0 THEN + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 1) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 2) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 3) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 4) - B12x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 5) - B12y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 6) - B12z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 7) + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 8) + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 9) + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 7) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 8) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 9) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 4) - B12x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 5) - B12y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 6) - B12z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 7) - B23x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 8) - B23y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 9) - B23z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + END IF + IF A12dotgivenplane > 0 AND B12dotgivenplane < 0 AND A23dotgivenplane < 0 AND B23dotgivenplane < 0 AND A31dotgivenplane < 0 AND B31dotgivenplane > 0 THEN + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 1) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 2) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 3) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 4) - B12x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 5) - B12y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 6) - B12z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 1) - B31x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 2) - B31y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 3) - B31z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + END IF + IF A12dotgivenplane < 0 AND B12dotgivenplane > 0 AND A23dotgivenplane > 0 AND B23dotgivenplane < 0 AND A31dotgivenplane < 0 AND B31dotgivenplane < 0 THEN + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 4) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 5) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 6) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 7) - B23x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 8) - B23y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 9) - B23z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 4) - B12x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 5) - B12y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 6) - B12z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + END IF + IF A12dotgivenplane < 0 AND B12dotgivenplane < 0 AND A23dotgivenplane < 0 AND B23dotgivenplane > 0 AND A31dotgivenplane > 0 AND B31dotgivenplane < 0 THEN + pcounttripletclipwork = pcounttripletclipwork + 1 + tripletclipwork(pcounttripletclipwork, 1) = tripletclip(i, 7) + tripletclipwork(pcounttripletclipwork, 2) = tripletclip(i, 8) + tripletclipwork(pcounttripletclipwork, 3) = tripletclip(i, 9) + tripletclipwork(pcounttripletclipwork, 4) = tripletclip(i, 7) - B23x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 5) = tripletclip(i, 8) - B23y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 6) = tripletclip(i, 9) - B23z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 7) = tripletclip(i, 1) - B31x + givenplaned * givenplanex + tripletclipwork(pcounttripletclipwork, 8) = tripletclip(i, 2) - B31y + givenplaned * givenplaney + tripletclipwork(pcounttripletclipwork, 9) = tripletclip(i, 3) - B31z + givenplaned * givenplanez + tripletclipwork(pcounttripletclipwork, 10) = tripletclip(i, 10) + END IF +NEXT +RETURN + +' *** Define functions for triplet snipping. *** + +copy.triplets.clip.snip: +FOR i = 1 TO numtripletclip + tripletsnip(i, 1) = tripletclip(i, 1) + tripletsnip(i, 2) = tripletclip(i, 2) + tripletsnip(i, 3) = tripletclip(i, 3) + tripletsnip(i, 4) = tripletclip(i, 4) + tripletsnip(i, 5) = tripletclip(i, 5) + tripletsnip(i, 6) = tripletclip(i, 6) + tripletsnip(i, 7) = tripletclip(i, 7) + tripletsnip(i, 8) = tripletclip(i, 8) + tripletsnip(i, 9) = tripletclip(i, 9) + tripletsnip(i, 10) = tripletclip(i, 10) +NEXT +numtripletsnip = numtripletclip +RETURN + +snip.triplets: +snipworkpcount = 0 +FOR i = 1 TO numtripletsnip + pcounttripletsnipimage = 1 + tripletsnipimage(1, 1) = tripletsnip(i, 1) + tripletsnipimage(1, 2) = tripletsnip(i, 2) + tripletsnipimage(1, 3) = tripletsnip(i, 3) + tripletsnipimage(1, 4) = tripletsnip(i, 4) + tripletsnipimage(1, 5) = tripletsnip(i, 5) + tripletsnipimage(1, 6) = tripletsnip(i, 6) + tripletsnipimage(1, 7) = tripletsnip(i, 7) + tripletsnipimage(1, 8) = tripletsnip(i, 8) + tripletsnipimage(1, 9) = tripletsnip(i, 9) + tripletsnipimage(1, 10) = tripletsnip(i, 10) + begintripletsnipsubloop: + FOR k = 1 TO pcounttripletsnipimage + FOR j = 1 TO numtripletsnip + IF j <> i THEN + IF pcounttripletsnipimage > numtripletsnip + 5 THEN + ' Error case. The 5 is completely arbitrary. + GOTO bypasssniploop + END IF + Ax = tripletsnipimage(k, 1) + Ay = tripletsnipimage(k, 2) + Az = tripletsnipimage(k, 3) + Bx = tripletsnipimage(k, 4) + By = tripletsnipimage(k, 5) + Bz = tripletsnipimage(k, 6) + Cx = tripletsnipimage(k, 7) + Cy = tripletsnipimage(k, 8) + Cz = tripletsnipimage(k, 9) + Au = Ax * uhat(1) + Ay * uhat(2) + Az * uhat(3) + Av = Ax * vhat(1) + Ay * vhat(2) + Az * vhat(3) + Bu = Bx * uhat(1) + By * uhat(2) + Bz * uhat(3) + Bv = Bx * vhat(1) + By * vhat(2) + Bz * vhat(3) + Cu = Cx * uhat(1) + Cy * uhat(2) + Cz * uhat(3) + Cv = Cx * vhat(1) + Cy * vhat(2) + Cz * vhat(3) + An = Ax * nhat(1) + Ay * nhat(2) + Az * nhat(3) + Bn = Bx * nhat(1) + By * nhat(2) + Bz * nhat(3) + Cn = Cx * nhat(1) + Cy * nhat(2) + Cz * nhat(3) + Asu = Au * fovd / An + Asv = Av * fovd / An + Bsu = Bu * fovd / Bn + Bsv = Bv * fovd / Bn + Csu = Cu * fovd / Cn + Csv = Cv * fovd / Cn + Dx = tripletsnip(j, 1) + Dy = tripletsnip(j, 2) + Dz = tripletsnip(j, 3) + Ex = tripletsnip(j, 4) + Ey = tripletsnip(j, 5) + Ez = tripletsnip(j, 6) + Fx = tripletsnip(j, 7) + Fy = tripletsnip(j, 8) + Fz = tripletsnip(j, 9) + Du = Dx * uhat(1) + Dy * uhat(2) + Dz * uhat(3) + Dv = Dx * vhat(1) + Dy * vhat(2) + Dz * vhat(3) + Eu = Ex * uhat(1) + Ey * uhat(2) + Ez * uhat(3) + Ev = Ex * vhat(1) + Ey * vhat(2) + Ez * vhat(3) + Fu = Fx * uhat(1) + Fy * uhat(2) + Fz * uhat(3) + Fv = Fx * vhat(1) + Fy * vhat(2) + Fz * vhat(3) + Dn = Dx * nhat(1) + Dy * nhat(2) + Dz * nhat(3) + En = Ex * nhat(1) + Ey * nhat(2) + Ez * nhat(3) + Fn = Fx * nhat(1) + Fy * nhat(2) + Fz * nhat(3) + Dsu = Du * fovd / Dn + Dsv = Dv * fovd / Dn + Esu = Eu * fovd / En + Esv = Ev * fovd / En + Fsu = Fu * fovd / Fn + Fsv = Fv * fovd / Fn + GOSUB compute.triplet.sig.components + ' Classify the scheme of triangle overlap and assign a 3-digit code. + signature1 = pointDinside + pointEinside + pointFinside + signature2 = pointAinside + pointBinside + pointCinside + signature3 = intABDE + intBCDE + intCADE + intABEF + intBCEF + intCAEF + intABFD + intBCFD + intCAFD + signature1text$ = STR$(signature1) + signature2text$ = STR$(signature2) + signature3text$ = STR$(signature3) + signaturefull$ = signature1text$ + signature2text$ + signature3text$ + GOSUB triplet.image.generate + END IF + NEXT + NEXT + bypasssniploop: + FOR m = 1 TO pcounttripletsnipimage + snipworkpcount = snipworkpcount + 1 + tripletsnipwork(snipworkpcount, 1) = tripletsnipimage(m, 1) + tripletsnipwork(snipworkpcount, 2) = tripletsnipimage(m, 2) + tripletsnipwork(snipworkpcount, 3) = tripletsnipimage(m, 3) + tripletsnipwork(snipworkpcount, 4) = tripletsnipimage(m, 4) + tripletsnipwork(snipworkpcount, 5) = tripletsnipimage(m, 5) + tripletsnipwork(snipworkpcount, 6) = tripletsnipimage(m, 6) + tripletsnipwork(snipworkpcount, 7) = tripletsnipimage(m, 7) + tripletsnipwork(snipworkpcount, 8) = tripletsnipimage(m, 8) + tripletsnipwork(snipworkpcount, 9) = tripletsnipimage(m, 9) + tripletsnipwork(snipworkpcount, 10) = tripletsnipimage(m, 10) + NEXT +NEXT +FOR i = 1 TO snipworkpcount + tripletsnip(i, 1) = tripletsnipwork(i, 1) + tripletsnip(i, 2) = tripletsnipwork(i, 2) + tripletsnip(i, 3) = tripletsnipwork(i, 3) + tripletsnip(i, 4) = tripletsnipwork(i, 4) + tripletsnip(i, 5) = tripletsnipwork(i, 5) + tripletsnip(i, 6) = tripletsnipwork(i, 6) + tripletsnip(i, 7) = tripletsnipwork(i, 7) + tripletsnip(i, 8) = tripletsnipwork(i, 8) + tripletsnip(i, 9) = tripletsnipwork(i, 9) + tripletsnip(i, 10) = tripletsnipwork(i, 10) + ' Code for troubleshooting. + 'centsnipx = (1 / 3) * (tripletsnipwork(i, 1) + tripletsnipwork(i, 4) + tripletsnipwork(i, 7)) + 'centsnipy = (1 / 3) * (tripletsnipwork(i, 2) + tripletsnipwork(i, 5) + tripletsnipwork(i, 8)) + 'centsnipz = (1 / 3) * (tripletsnipwork(i, 3) + tripletsnipwork(i, 6) + tripletsnipwork(i, 9)) + 'centmag = SQR((centsnipx) ^ 2 + (centsnipy) ^ 2 + (centsnipz) ^ 2) +NEXT +numtripletsnip = snipworkpcount +RETURN + +compute.triplet.sig.components: +' Begin calculations for enclosed points: DEF inside ABC. + +pointDinside = -1 +pointEinside = -1 +pointFinside = -1 +pcounttripletencpoint = 0 + +tan12uv = (Asv - Bsv) / (Asu - Bsu) +norm12u = -(Asv - Bsv) +norm12v = (Asu - Bsu) +mag = SQR(norm12u ^ 2 + norm12v ^ 2) +norm12u = norm12u / mag +norm12v = norm12v / mag +Asdotnorm12 = Asu * norm12u + Asv * norm12v +Bsdotnorm12 = Bsu * norm12u + Bsv * norm12v +Dsdotnorm12 = Dsu * norm12u + Dsv * norm12v +Esdotnorm12 = Esu * norm12u + Esv * norm12v +Fsdotnorm12 = Fsu * norm12u + Fsv * norm12v + +tan23uv = (Bsv - Csv) / (Bsu - Csu) +norm23u = -(Bsv - Csv) +norm23v = (Bsu - Csu) +mag = SQR(norm23u ^ 2 + norm23v ^ 2) +norm23u = norm23u / mag +norm23v = norm23v / mag +Bsdotnorm23 = Bsu * norm23u + Bsv * norm23v +Csdotnorm23 = Csu * norm23u + Csv * norm23v +Dsdotnorm23 = Dsu * norm23u + Dsv * norm23v +Esdotnorm23 = Esu * norm23u + Esv * norm23v +Fsdotnorm23 = Fsu * norm23u + Fsv * norm23v + +tan31uv = (Csv - Asv) / (Csu - Asu) +norm31u = -(Csv - Asv) +norm31v = (Csu - Asu) +mag = SQR(norm31u ^ 2 + norm31v ^ 2) +norm31u = norm31u / mag +norm31v = norm31v / mag +Csdotnorm31 = Csu * norm31u + Csv * norm31v +Asdotnorm31 = Asu * norm31u + Asv * norm31v +Dsdotnorm31 = Dsu * norm31u + Dsv * norm31v +Esdotnorm31 = Esu * norm31u + Esv * norm31v +Fsdotnorm31 = Fsu * norm31u + Fsv * norm31v + +pointDdist12 = Dsdotnorm12 - (1 / 2) * (Asdotnorm12 + Bsdotnorm12) +pointDdist23 = Dsdotnorm23 - (1 / 2) * (Bsdotnorm23 + Csdotnorm23) +pointDdist31 = Dsdotnorm31 - (1 / 2) * (Csdotnorm31 + Asdotnorm31) + +pointEdist12 = Esdotnorm12 - (1 / 2) * (Asdotnorm12 + Bsdotnorm12) +pointEdist23 = Esdotnorm23 - (1 / 2) * (Bsdotnorm23 + Csdotnorm23) +pointEdist31 = Esdotnorm31 - (1 / 2) * (Csdotnorm31 + Asdotnorm31) + +pointFdist12 = Fsdotnorm12 - (1 / 2) * (Asdotnorm12 + Bsdotnorm12) +pointFdist23 = Fsdotnorm23 - (1 / 2) * (Bsdotnorm23 + Csdotnorm23) +pointFdist31 = Fsdotnorm31 - (1 / 2) * (Csdotnorm31 + Asdotnorm31) + +IF pointDdist12 > 0 AND pointDdist23 > 0 AND pointDdist31 > 0 THEN + pointDinside = 1 + Q = Dsu / fovd + R = Q * (Bn - An) - (Bu - Au) + S = Q * (Cn - An) - (Cu - Au) + T = Au - Q * An + Z = Dsv / fovd + U = Z * (Bn - An) - (Bv - Av) + V = Z * (Cn - An) - (Cv - Av) + W = Av - Z * An + factor1 = (T / S - W / V) / (R / S - U / V) + factor2 = (T / R - W / U) / (S / R - V / U) + pcounttripletencpoint = pcounttripletencpoint + 1 + tripletencpoint(pcounttripletencpoint, 1) = Dx + tripletencpoint(pcounttripletencpoint, 2) = Dy + tripletencpoint(pcounttripletencpoint, 3) = Dz + tripletencpoint(pcounttripletencpoint, 4) = Ax + factor1 * (Bx - Ax) + factor2 * (Cx - Ax) + tripletencpoint(pcounttripletencpoint, 5) = Ay + factor1 * (By - Ay) + factor2 * (Cy - Ay) + tripletencpoint(pcounttripletencpoint, 6) = Az + factor1 * (Bz - Az) + factor2 * (Cz - Az) + tripletencpoint(pcounttripletencpoint, 7) = Dsu + tripletencpoint(pcounttripletencpoint, 8) = Dsv +ELSE + pointDinside = 0 +END IF + +IF pointEdist12 > 0 AND pointEdist23 > 0 AND pointEdist31 > 0 THEN + pointEinside = 1 + Q = Esu / fovd + R = Q * (Bn - An) - (Bu - Au) + S = Q * (Cn - An) - (Cu - Au) + T = Au - Q * An + Z = Esv / fovd + U = Z * (Bn - An) - (Bv - Av) + V = Z * (Cn - An) - (Cv - Av) + W = Av - Z * An + factor1 = (T / S - W / V) / (R / S - U / V) + factor2 = (T / R - W / U) / (S / R - V / U) + pcounttripletencpoint = pcounttripletencpoint + 1 + tripletencpoint(pcounttripletencpoint, 1) = Ex + tripletencpoint(pcounttripletencpoint, 2) = Ey + tripletencpoint(pcounttripletencpoint, 3) = Ez + tripletencpoint(pcounttripletencpoint, 4) = Ax + factor1 * (Bx - Ax) + factor2 * (Cx - Ax) + tripletencpoint(pcounttripletencpoint, 5) = Ay + factor1 * (By - Ay) + factor2 * (Cy - Ay) + tripletencpoint(pcounttripletencpoint, 6) = Az + factor1 * (Bz - Az) + factor2 * (Cz - Az) + tripletencpoint(pcounttripletencpoint, 7) = Esu + tripletencpoint(pcounttripletencpoint, 8) = Esv +ELSE + pointEinside = 0 +END IF + +IF pointFdist12 > 0 AND pointFdist23 > 0 AND pointFdist31 > 0 THEN + pointFinside = 1 + Q = Fsu / fovd + R = Q * (Bn - An) - (Bu - Au) + S = Q * (Cn - An) - (Cu - Au) + T = Au - Q * An + Z = Fsv / fovd + U = Z * (Bn - An) - (Bv - Av) + V = Z * (Cn - An) - (Cv - Av) + W = Av - Z * An + factor1 = (T / S - W / V) / (R / S - U / V) + factor2 = (T / R - W / U) / (S / R - V / U) + pcounttripletencpoint = pcounttripletencpoint + 1 + tripletencpoint(pcounttripletencpoint, 1) = Fx + tripletencpoint(pcounttripletencpoint, 2) = Fy + tripletencpoint(pcounttripletencpoint, 3) = Fz + tripletencpoint(pcounttripletencpoint, 4) = Ax + factor1 * (Bx - Ax) + factor2 * (Cx - Ax) + tripletencpoint(pcounttripletencpoint, 5) = Ay + factor1 * (By - Ay) + factor2 * (Cy - Ay) + tripletencpoint(pcounttripletencpoint, 6) = Az + factor1 * (Bz - Az) + factor2 * (Cz - Az) + tripletencpoint(pcounttripletencpoint, 7) = Fsu + tripletencpoint(pcounttripletencpoint, 8) = Fsv +ELSE + pointFinside = 0 +END IF + +' Begin calculations for enclosed points: ABC inside DEF. + +pointAinside = -1 +pointBinside = -1 +pointCinside = -1 + +tan12uv = (Dsv - Esv) / (Dsu - Esu) +norm12u = -(Dsv - Esv) +norm12v = (Dsu - Esu) +mag = SQR(norm12u ^ 2 + norm12v ^ 2) +norm12u = norm12u / mag +norm12v = norm12v / mag +Dsdotnorm12 = Dsu * norm12u + Dsv * norm12v +Esdotnorm12 = Esu * norm12u + Esv * norm12v +Asdotnorm12 = Asu * norm12u + Asv * norm12v +Bsdotnorm12 = Bsu * norm12u + Bsv * norm12v +Csdotnorm12 = Csu * norm12u + Csv * norm12v + +tan23uv = (Esv - Fsv) / (Esu - Fsu) +norm23u = -(Esv - Fsv) +norm23v = (Esu - Fsu) +mag = SQR(norm23u ^ 2 + norm23v ^ 2) +norm23u = norm23u / mag +norm23v = norm23v / mag +Esdotnorm23 = Esu * norm23u + Esv * norm23v +Fsdotnorm23 = Fsu * norm23u + Fsv * norm23v +Asdotnorm23 = Asu * norm23u + Asv * norm23v +Bsdotnorm23 = Bsu * norm23u + Bsv * norm23v +Csdotnorm23 = Csu * norm23u + Csv * norm23v + +tan31uv = (Fsv - Dsv) / (Fsu - Dsu) +norm31u = -(Fsv - Dsv) +norm31v = (Fsu - Dsu) +mag = SQR(norm31u ^ 2 + norm31v ^ 2) +norm31u = norm31u / mag +norm31v = norm31v / mag +Fsdotnorm31 = Fsu * norm31u + Fsv * norm31v +Dsdotnorm31 = Dsu * norm31u + Dsv * norm31v +Asdotnorm31 = Asu * norm31u + Asv * norm31v +Bsdotnorm31 = Bsu * norm31u + Bsv * norm31v +Csdotnorm31 = Csu * norm31u + Csv * norm31v + +pointAdist12 = Asdotnorm12 - (1 / 2) * (Dsdotnorm12 + Esdotnorm12) +pointAdist23 = Asdotnorm23 - (1 / 2) * (Esdotnorm23 + Fsdotnorm23) +pointAdist31 = Asdotnorm31 - (1 / 2) * (Fsdotnorm31 + Dsdotnorm31) + +pointBdist12 = Bsdotnorm12 - (1 / 2) * (Dsdotnorm12 + Esdotnorm12) +pointBdist23 = Bsdotnorm23 - (1 / 2) * (Esdotnorm23 + Fsdotnorm23) +pointBdist31 = Bsdotnorm31 - (1 / 2) * (Fsdotnorm31 + Dsdotnorm31) + +pointCdist12 = Csdotnorm12 - (1 / 2) * (Dsdotnorm12 + Esdotnorm12) +pointCdist23 = Csdotnorm23 - (1 / 2) * (Esdotnorm23 + Fsdotnorm23) +pointCdist31 = Csdotnorm31 - (1 / 2) * (Fsdotnorm31 + Dsdotnorm31) + +IF pointAdist12 > 0 AND pointAdist23 > 0 AND pointAdist31 > 0 THEN + pointAinside = 1 + Q = Asu / fovd + R = Q * (En - Dn) - (Eu - Du) + S = Q * (Fn - Dn) - (Fu - Du) + T = Du - Q * Dn + Z = Asv / fovd + U = Z * (En - Dn) - (Ev - Dv) + V = Z * (Fn - Dn) - (Fv - Dv) + W = Dv - Z * Dn + factor1 = (T / S - W / V) / (R / S - U / V) + factor2 = (T / R - W / U) / (S / R - V / U) + pcounttripletencpoint = pcounttripletencpoint + 1 + tripletencpoint(pcounttripletencpoint, 1) = Ax + tripletencpoint(pcounttripletencpoint, 2) = Ay + tripletencpoint(pcounttripletencpoint, 3) = Az + tripletencpoint(pcounttripletencpoint, 4) = Dx + factor1 * (Ex - Dx) + factor2 * (Fx - Dx) + tripletencpoint(pcounttripletencpoint, 5) = Dy + factor1 * (Ey - Dy) + factor2 * (Fy - Dy) + tripletencpoint(pcounttripletencpoint, 6) = Dz + factor1 * (Ez - Dz) + factor2 * (Fz - Dz) + tripletencpoint(pcounttripletencpoint, 7) = Asu + tripletencpoint(pcounttripletencpoint, 8) = Asv +ELSE + pointAinside = 0 +END IF + +IF pointBdist12 > 0 AND pointBdist23 > 0 AND pointBdist31 > 0 THEN + pointBinside = 1 + Q = Bsu / fovd + R = Q * (En - Dn) - (Eu - Du) + S = Q * (Fn - Dn) - (Fu - Du) + T = Du - Q * Dn + Z = Bsv / fovd + U = Z * (En - Dn) - (Ev - Dv) + V = Z * (Fn - Dn) - (Fv - Dv) + W = Dv - Z * Dn + factor1 = (T / S - W / V) / (R / S - U / V) + factor2 = (T / R - W / U) / (S / R - V / U) + pcounttripletencpoint = pcounttripletencpoint + 1 + tripletencpoint(pcounttripletencpoint, 1) = Bx + tripletencpoint(pcounttripletencpoint, 2) = By + tripletencpoint(pcounttripletencpoint, 3) = Bz + tripletencpoint(pcounttripletencpoint, 4) = Dx + factor1 * (Ex - Dx) + factor2 * (Fx - Dx) + tripletencpoint(pcounttripletencpoint, 5) = Dy + factor1 * (Ey - Dy) + factor2 * (Fy - Dy) + tripletencpoint(pcounttripletencpoint, 6) = Dz + factor1 * (Ez - Dz) + factor2 * (Fz - Dz) + tripletencpoint(pcounttripletencpoint, 7) = Bsu + tripletencpoint(pcounttripletencpoint, 8) = Bsv +ELSE + pointBinside = 0 +END IF + +IF pointCdist12 > 0 AND pointCdist23 > 0 AND pointCdist31 > 0 THEN + pointCinside = 1 + Q = Csu / fovd + R = Q * (En - Dn) - (Eu - Du) + S = Q * (Fn - Dn) - (Fu - Du) + T = Du - Q * Dn + Z = Csv / fovd + U = Z * (En - Dn) - (Ev - Dv) + V = Z * (Fn - Dn) - (Fv - Dv) + W = Dv - Z * Dn + factor1 = (T / S - W / V) / (R / S - U / V) + factor2 = (T / R - W / U) / (S / R - V / U) + pcounttripletencpoint = pcounttripletencpoint + 1 + tripletencpoint(pcounttripletencpoint, 1) = Cx + tripletencpoint(pcounttripletencpoint, 2) = Cy + tripletencpoint(pcounttripletencpoint, 3) = Cz + tripletencpoint(pcounttripletencpoint, 4) = Dx + factor1 * (Ex - Dx) + factor2 * (Fx - Dx) + tripletencpoint(pcounttripletencpoint, 5) = Dy + factor1 * (Ey - Dy) + factor2 * (Fy - Dy) + tripletencpoint(pcounttripletencpoint, 6) = Dz + factor1 * (Ez - Dz) + factor2 * (Fz - Dz) + tripletencpoint(pcounttripletencpoint, 7) = Csu + tripletencpoint(pcounttripletencpoint, 8) = Csv +ELSE + pointCinside = 0 +END IF + +' Begin calculations for triplet line intersections. + +magtripletABps = SQR((Asu - Bsu) ^ 2 + (Asv - Bsv) ^ 2) +magtripletBCps = SQR((Bsu - Csu) ^ 2 + (Bsv - Csv) ^ 2) +magtripletCAps = SQR((Csu - Asu) ^ 2 + (Csv - Asv) ^ 2) + +magtripletDEps = SQR((Dsu - Esu) ^ 2 + (Dsv - Esv) ^ 2) +magtripletEFps = SQR((Esu - Fsu) ^ 2 + (Esv - Fsv) ^ 2) +magtripletFDps = SQR((Fsu - Dsu) ^ 2 + (Fsv - Dsv) ^ 2) + +slopeAB = (Bsv - Asv) / (Bsu - Asu) +intAB = Asv - slopeAB * Asu +slopeBC = (Csv - Bsv) / (Csu - Bsu) +intBC = Bsv - slopeBC * Bsu +slopeCA = (Asv - Csv) / (Asu - Csu) +intCA = Csv - slopeCA * Csu + +slopeDE = (Esv - Dsv) / (Esu - Dsu) +intDE = Dsv - slopeDE * Dsu +slopeEF = (Fsv - Esv) / (Fsu - Esu) +intEF = Esv - slopeEF * Esu +slopeFD = (Dsv - Fsv) / (Dsu - Fsu) +intFD = Fsv - slopeFD * Fsu + +xstarABDE = -(intAB - intDE) / (slopeAB - slopeDE) +ystarABDE = slopeAB * xstarABDE + intAB +xstarABEF = -(intAB - intEF) / (slopeAB - slopeEF) +ystarABEF = slopeAB * xstarABEF + intAB +xstarABFD = -(intAB - intFD) / (slopeAB - slopeFD) +ystarABFD = slopeAB * xstarABFD + intAB + +xstarBCDE = -(intBC - intDE) / (slopeBC - slopeDE) +ystarBCDE = slopeBC * xstarBCDE + intBC +xstarBCEF = -(intBC - intEF) / (slopeBC - slopeEF) +ystarBCEF = slopeBC * xstarBCEF + intBC +xstarBCFD = -(intBC - intFD) / (slopeBC - slopeFD) +ystarBCFD = slopeBC * xstarBCFD + intBC + +xstarCADE = -(intCA - intDE) / (slopeCA - slopeDE) +ystarCADE = slopeCA * xstarCADE + intCA +xstarCAEF = -(intCA - intEF) / (slopeCA - slopeEF) +ystarCAEF = slopeCA * xstarCAEF + intCA +xstarCAFD = -(intCA - intFD) / (slopeCA - slopeFD) +ystarCAFD = slopeCA * xstarCAFD + intCA + +alphaABDE1u = -xstarABDE + Asu +alphaABDE1v = -ystarABDE + Asv +alphaABDE2u = -xstarABDE + Bsu +alphaABDE2v = -ystarABDE + Bsv +alphaABEF1u = -xstarABEF + Asu +alphaABEF1v = -ystarABEF + Asv +alphaABEF2u = -xstarABEF + Bsu +alphaABEF2v = -ystarABEF + Bsv +alphaABFD1u = -xstarABFD + Asu +alphaABFD1v = -ystarABFD + Asv +alphaABFD2u = -xstarABFD + Bsu +alphaABFD2v = -ystarABFD + Bsv + +alphaBCDE1u = -xstarBCDE + Bsu +alphaBCDE1v = -ystarBCDE + Bsv +alphaBCDE2u = -xstarBCDE + Csu +alphaBCDE2v = -ystarBCDE + Csv +alphaBCEF1u = -xstarBCEF + Bsu +alphaBCEF1v = -ystarBCEF + Bsv +alphaBCEF2u = -xstarBCEF + Csu +alphaBCEF2v = -ystarBCEF + Csv +alphaBCFD1u = -xstarBCFD + Bsu +alphaBCFD1v = -ystarBCFD + Bsv +alphaBCFD2u = -xstarBCFD + Csu +alphaBCFD2v = -ystarBCFD + Csv + +alphaCADE1u = -xstarCADE + Csu +alphaCADE1v = -ystarCADE + Csv +alphaCADE2u = -xstarCADE + Asu +alphaCADE2v = -ystarCADE + Asv +alphaCAEF1u = -xstarCAEF + Csu +alphaCAEF1v = -ystarCAEF + Csv +alphaCAEF2u = -xstarCAEF + Asu +alphaCAEF2v = -ystarCAEF + Asv +alphaCAFD1u = -xstarCAFD + Csu +alphaCAFD1v = -ystarCAFD + Csv +alphaCAFD2u = -xstarCAFD + Asu +alphaCAFD2v = -ystarCAFD + Asv + +alphaDEAB1u = -xstarABDE + Dsu +alphaDEAB1v = -ystarABDE + Dsv +alphaDEAB2u = -xstarABDE + Esu +alphaDEAB2v = -ystarABDE + Esv +alphaDEBC1u = -xstarBCDE + Dsu +alphaDEBC1v = -ystarBCDE + Dsv +alphaDEBC2u = -xstarBCDE + Esu +alphaDEBC2v = -ystarBCDE + Esv +alphaDECA1u = -xstarCADE + Dsu +alphaDECA1v = -ystarCADE + Dsv +alphaDECA2u = -xstarCADE + Esu +alphaDECA2v = -ystarCADE + Esv + +alphaEFAB1u = -xstarABEF + Esu +alphaEFAB1v = -ystarABEF + Esv +alphaEFAB2u = -xstarABEF + Fsu +alphaEFAB2v = -ystarABEF + Fsv +alphaEFBC1u = -xstarBCEF + Esu +alphaEFBC1v = -ystarBCEF + Esv +alphaEFBC2u = -xstarBCEF + Fsu +alphaEFBC2v = -ystarBCEF + Fsv +alphaEFCA1u = -xstarCAEF + Esu +alphaEFCA1v = -ystarCAEF + Esv +alphaEFCA2u = -xstarCAEF + Fsu +alphaEFCA2v = -ystarCAEF + Fsv + +alphaFDAB1u = -xstarABFD + Fsu +alphaFDAB1v = -ystarABFD + Fsv +alphaFDAB2u = -xstarABFD + Dsu +alphaFDAB2v = -ystarABFD + Dsv +alphaFDBC1u = -xstarBCFD + Fsu +alphaFDBC1v = -ystarBCFD + Fsv +alphaFDBC2u = -xstarBCFD + Dsu +alphaFDBC2v = -ystarBCFD + Dsv +alphaFDCA1u = -xstarCAFD + Fsu +alphaFDCA1v = -ystarCAFD + Fsv +alphaFDCA2u = -xstarCAFD + Dsu +alphaFDCA2v = -ystarCAFD + Dsv + +magalphaABDE1 = SQR(alphaABDE1u ^ 2 + alphaABDE1v ^ 2) +magalphaABDE2 = SQR(alphaABDE2u ^ 2 + alphaABDE2v ^ 2) +magalphaABEF1 = SQR(alphaABEF1u ^ 2 + alphaABEF1v ^ 2) +magalphaABEF2 = SQR(alphaABEF2u ^ 2 + alphaABEF2v ^ 2) +magalphaABFD1 = SQR(alphaABFD1u ^ 2 + alphaABFD1v ^ 2) +magalphaABFD2 = SQR(alphaABFD2u ^ 2 + alphaABFD2v ^ 2) + +magalphaBCDE1 = SQR(alphaBCDE1u ^ 2 + alphaBCDE1v ^ 2) +magalphaBCDE2 = SQR(alphaBCDE2u ^ 2 + alphaBCDE2v ^ 2) +magalphaBCEF1 = SQR(alphaBCEF1u ^ 2 + alphaBCEF1v ^ 2) +magalphaBCEF2 = SQR(alphaBCEF2u ^ 2 + alphaBCEF2v ^ 2) +magalphaBCFD1 = SQR(alphaBCFD1u ^ 2 + alphaBCFD1v ^ 2) +magalphaBCFD2 = SQR(alphaBCFD2u ^ 2 + alphaBCFD2v ^ 2) + +magalphaCADE1 = SQR(alphaCADE1u ^ 2 + alphaCADE1v ^ 2) +magalphaCADE2 = SQR(alphaCADE2u ^ 2 + alphaCADE2v ^ 2) +magalphaCAEF1 = SQR(alphaCAEF1u ^ 2 + alphaCAEF1v ^ 2) +magalphaCAEF2 = SQR(alphaCAEF2u ^ 2 + alphaCAEF2v ^ 2) +magalphaCAFD1 = SQR(alphaCAFD1u ^ 2 + alphaCAFD1v ^ 2) +magalphaCAFD2 = SQR(alphaCAFD2u ^ 2 + alphaCAFD2v ^ 2) + +magalphaDEAB1 = SQR(alphaDEAB1u ^ 2 + alphaDEAB1v ^ 2) +magalphaDEAB2 = SQR(alphaDEAB2u ^ 2 + alphaDEAB2v ^ 2) +magalphaDEBC1 = SQR(alphaDEBC1u ^ 2 + alphaDEBC1v ^ 2) +magalphaDEBC2 = SQR(alphaDEBC2u ^ 2 + alphaDEBC2v ^ 2) +magalphaDECA1 = SQR(alphaDECA1u ^ 2 + alphaDECA1v ^ 2) +magalphaDECA2 = SQR(alphaDECA2u ^ 2 + alphaDECA2v ^ 2) + +magalphaEFAB1 = SQR(alphaEFAB1u ^ 2 + alphaEFAB1v ^ 2) +magalphaEFAB2 = SQR(alphaEFAB2u ^ 2 + alphaEFAB2v ^ 2) +magalphaEFBC1 = SQR(alphaEFBC1u ^ 2 + alphaEFBC1v ^ 2) +magalphaEFBC2 = SQR(alphaEFBC2u ^ 2 + alphaEFBC2v ^ 2) +magalphaEFCA1 = SQR(alphaEFCA1u ^ 2 + alphaEFCA1v ^ 2) +magalphaEFCA2 = SQR(alphaEFCA2u ^ 2 + alphaEFCA2v ^ 2) + +magalphaFDAB1 = SQR(alphaFDAB1u ^ 2 + alphaFDAB1v ^ 2) +magalphaFDAB2 = SQR(alphaFDAB2u ^ 2 + alphaFDAB2v ^ 2) +magalphaFDBC1 = SQR(alphaFDBC1u ^ 2 + alphaFDBC1v ^ 2) +magalphaFDBC2 = SQR(alphaFDBC2u ^ 2 + alphaFDBC2v ^ 2) +magalphaFDCA1 = SQR(alphaFDCA1u ^ 2 + alphaFDCA1v ^ 2) +magalphaFDCA2 = SQR(alphaFDCA2u ^ 2 + alphaFDCA2v ^ 2) + +' Determine and store the mutual intersection points of triplets ABD and DEF. + +intABDE = -1 +intBCDE = -1 +intCADE = -1 +intABEF = -1 +intBCEF = -1 +intCAEF = -1 +intABFD = -1 +intBCFD = -1 +intCAFD = -1 +pcounttripletintpointpair = 0 + +IF magalphaABDE1 - magtripletABps < 0 AND magalphaABDE2 - magtripletABps < 0 AND magalphaDEAB1 - magtripletDEps < 0 AND magalphaDEAB2 - magtripletDEps < 0 THEN + qAB1u = (Asu - alphaABDE1u) / fovd + numerator = qAB1u * An - Au + denominator = Bu - Au + qAB1u * (An - Bn) + betaABDE = numerator / denominator + qDE1u = (Dsu - alphaDEAB1u) / fovd + numerator = qDE1u * Dn - Du + denominator = Eu - Du + qDE1u * (Dn - En) + betaDEAB = numerator / denominator + intABDE = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Ax * (1 - betaABDE) + betaABDE * Bx + tripletintpointpair(pcounttripletintpointpair, 2) = Ay * (1 - betaABDE) + betaABDE * By + tripletintpointpair(pcounttripletintpointpair, 3) = Az * (1 - betaABDE) + betaABDE * Bz + tripletintpointpair(pcounttripletintpointpair, 4) = Dx * (1 - betaDEAB) + betaDEAB * Ex + tripletintpointpair(pcounttripletintpointpair, 5) = Dy * (1 - betaDEAB) + betaDEAB * Ey + tripletintpointpair(pcounttripletintpointpair, 6) = Dz * (1 - betaDEAB) + betaDEAB * Ez + tripletintpointpair(pcounttripletintpointpair, 7) = Cx + tripletintpointpair(pcounttripletintpointpair, 8) = Cy + tripletintpointpair(pcounttripletintpointpair, 9) = Cz + tripletintpointpair(pcounttripletintpointpair, 10) = Ax + tripletintpointpair(pcounttripletintpointpair, 11) = Ay + tripletintpointpair(pcounttripletintpointpair, 12) = Az + tripletintpointpair(pcounttripletintpointpair, 13) = Bx + tripletintpointpair(pcounttripletintpointpair, 14) = By + tripletintpointpair(pcounttripletintpointpair, 15) = Bz + tripletintpointpair(pcounttripletintpointpair, 16) = Dx + tripletintpointpair(pcounttripletintpointpair, 17) = Dy + tripletintpointpair(pcounttripletintpointpair, 18) = Dz + tripletintpointpair(pcounttripletintpointpair, 19) = Ex + tripletintpointpair(pcounttripletintpointpair, 20) = Ey + tripletintpointpair(pcounttripletintpointpair, 21) = Ez +ELSE + intABDE = 0 +END IF + +IF magalphaBCDE1 - magtripletBCps < 0 AND magalphaBCDE2 - magtripletBCps < 0 AND magalphaDEBC1 - magtripletDEps < 0 AND magalphaDEBC2 - magtripletDEps < 0 THEN + qBC1u = (Bsu - alphaBCDE1u) / fovd + numerator = qBC1u * Bn - Bu + denominator = Cu - Bu + qBC1u * (Bn - Cn) + betaBCDE = numerator / denominator + qDE1u = (Dsu - alphaDEBC1u) / fovd + numerator = qDE1u * Dn - Du + denominator = Eu - Du + qDE1u * (Dn - En) + betaDEBC = numerator / denominator + intBCDE = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Bx * (1 - betaBCDE) + betaBCDE * Cx + tripletintpointpair(pcounttripletintpointpair, 2) = By * (1 - betaBCDE) + betaBCDE * Cy + tripletintpointpair(pcounttripletintpointpair, 3) = Bz * (1 - betaBCDE) + betaBCDE * Cz + tripletintpointpair(pcounttripletintpointpair, 4) = Dx * (1 - betaDEBC) + betaDEBC * Ex + tripletintpointpair(pcounttripletintpointpair, 5) = Dy * (1 - betaDEBC) + betaDEBC * Ey + tripletintpointpair(pcounttripletintpointpair, 6) = Dz * (1 - betaDEBC) + betaDEBC * Ez + tripletintpointpair(pcounttripletintpointpair, 7) = Ax + tripletintpointpair(pcounttripletintpointpair, 8) = Ay + tripletintpointpair(pcounttripletintpointpair, 9) = Az + tripletintpointpair(pcounttripletintpointpair, 10) = Bx + tripletintpointpair(pcounttripletintpointpair, 11) = By + tripletintpointpair(pcounttripletintpointpair, 12) = Bz + tripletintpointpair(pcounttripletintpointpair, 13) = Cx + tripletintpointpair(pcounttripletintpointpair, 14) = Cy + tripletintpointpair(pcounttripletintpointpair, 15) = Cz + tripletintpointpair(pcounttripletintpointpair, 16) = Dx + tripletintpointpair(pcounttripletintpointpair, 17) = Dy + tripletintpointpair(pcounttripletintpointpair, 18) = Dz + tripletintpointpair(pcounttripletintpointpair, 19) = Ex + tripletintpointpair(pcounttripletintpointpair, 20) = Ey + tripletintpointpair(pcounttripletintpointpair, 21) = Ez +ELSE + intBCDE = 0 +END IF + +IF magalphaCADE1 - magtripletCAps < 0 AND magalphaCADE2 - magtripletCAps < 0 AND magalphaDECA1 - magtripletDEps < 0 AND magalphaDECA2 - magtripletDEps < 0 THEN + qCA1u = (Csu - alphaCADE1u) / fovd + numerator = qCA1u * Cn - Cu + denominator = Au - Cu + qCA1u * (Cn - An) + betaCADE = numerator / denominator + qDE1u = (Dsu - alphaDECA1u) / fovd + numerator = qDE1u * Dn - Du + denominator = Eu - Du + qDE1u * (Dn - En) + betaDECA = numerator / denominator + intCADE = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Cx * (1 - betaCADE) + betaCADE * Ax + tripletintpointpair(pcounttripletintpointpair, 2) = Cy * (1 - betaCADE) + betaCADE * Ay + tripletintpointpair(pcounttripletintpointpair, 3) = Cz * (1 - betaCADE) + betaCADE * Az + tripletintpointpair(pcounttripletintpointpair, 4) = Dx * (1 - betaDECA) + betaDECA * Ex + tripletintpointpair(pcounttripletintpointpair, 5) = Dy * (1 - betaDECA) + betaDECA * Ey + tripletintpointpair(pcounttripletintpointpair, 6) = Dz * (1 - betaDECA) + betaDECA * Ez + tripletintpointpair(pcounttripletintpointpair, 7) = Bx + tripletintpointpair(pcounttripletintpointpair, 8) = By + tripletintpointpair(pcounttripletintpointpair, 9) = Bz + tripletintpointpair(pcounttripletintpointpair, 10) = Cx + tripletintpointpair(pcounttripletintpointpair, 11) = Cy + tripletintpointpair(pcounttripletintpointpair, 12) = Cz + tripletintpointpair(pcounttripletintpointpair, 13) = Ax + tripletintpointpair(pcounttripletintpointpair, 14) = Ay + tripletintpointpair(pcounttripletintpointpair, 15) = Az + tripletintpointpair(pcounttripletintpointpair, 16) = Dx + tripletintpointpair(pcounttripletintpointpair, 17) = Dy + tripletintpointpair(pcounttripletintpointpair, 18) = Dz + tripletintpointpair(pcounttripletintpointpair, 19) = Ex + tripletintpointpair(pcounttripletintpointpair, 20) = Ey + tripletintpointpair(pcounttripletintpointpair, 21) = Ez +ELSE + intCADE = 0 +END IF + +IF magalphaABEF1 - magtripletABps < 0 AND magalphaABEF2 - magtripletABps < 0 AND magalphaEFAB1 - magtripletEFps < 0 AND magalphaEFAB2 - magtripletEFps < 0 THEN + qAB1u = (Asu - alphaABEF1u) / fovd + numerator = qAB1u * An - Au + denominator = Bu - Au + qAB1u * (An - Bn) + betaABEF = numerator / denominator + qEF1u = (Esu - alphaEFAB1u) / fovd + numerator = qEF1u * En - Eu + denominator = Fu - Eu + qEF1u * (En - Fn) + betaEFAB = numerator / denominator + intABEF = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Ax * (1 - betaABEF) + betaABEF * Bx + tripletintpointpair(pcounttripletintpointpair, 2) = Ay * (1 - betaABEF) + betaABEF * By + tripletintpointpair(pcounttripletintpointpair, 3) = Az * (1 - betaABEF) + betaABEF * Bz + tripletintpointpair(pcounttripletintpointpair, 4) = Ex * (1 - betaEFAB) + betaEFAB * Fx + tripletintpointpair(pcounttripletintpointpair, 5) = Ey * (1 - betaEFAB) + betaEFAB * Fy + tripletintpointpair(pcounttripletintpointpair, 6) = Ez * (1 - betaEFAB) + betaEFAB * Fz + tripletintpointpair(pcounttripletintpointpair, 7) = Cx + tripletintpointpair(pcounttripletintpointpair, 8) = Cy + tripletintpointpair(pcounttripletintpointpair, 9) = Cz + tripletintpointpair(pcounttripletintpointpair, 10) = Ax + tripletintpointpair(pcounttripletintpointpair, 11) = Ay + tripletintpointpair(pcounttripletintpointpair, 12) = Az + tripletintpointpair(pcounttripletintpointpair, 13) = Bx + tripletintpointpair(pcounttripletintpointpair, 14) = By + tripletintpointpair(pcounttripletintpointpair, 15) = Bz + tripletintpointpair(pcounttripletintpointpair, 16) = Ex + tripletintpointpair(pcounttripletintpointpair, 17) = Ey + tripletintpointpair(pcounttripletintpointpair, 18) = Ez + tripletintpointpair(pcounttripletintpointpair, 19) = Fx + tripletintpointpair(pcounttripletintpointpair, 20) = Fy + tripletintpointpair(pcounttripletintpointpair, 21) = Fz +ELSE + intABEF = 0 +END IF + +IF magalphaBCEF1 - magtripletBCps < 0 AND magalphaBCEF2 - magtripletBCps < 0 AND magalphaEFBC1 - magtripletEFps < 0 AND magalphaEFBC2 - magtripletEFps < 0 THEN + qBC1u = (Bsu - alphaBCEF1u) / fovd + numerator = qBC1u * Bn - Bu + denominator = Cu - Bu + qBC1u * (Bn - Cn) + betaBCEF = numerator / denominator + qEF1u = (Esu - alphaEFBC1u) / fovd + numerator = qEF1u * En - Eu + denominator = Fu - Eu + qEF1u * (En - Fn) + betaEFBC = numerator / denominator + intBCEF = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Bx * (1 - betaBCEF) + betaBCEF * Cx + tripletintpointpair(pcounttripletintpointpair, 2) = By * (1 - betaBCEF) + betaBCEF * Cy + tripletintpointpair(pcounttripletintpointpair, 3) = Bz * (1 - betaBCEF) + betaBCEF * Cz + tripletintpointpair(pcounttripletintpointpair, 4) = Ex * (1 - betaEFBC) + betaEFBC * Fx + tripletintpointpair(pcounttripletintpointpair, 5) = Ey * (1 - betaEFBC) + betaEFBC * Fy + tripletintpointpair(pcounttripletintpointpair, 6) = Ez * (1 - betaEFBC) + betaEFBC * Fz + tripletintpointpair(pcounttripletintpointpair, 7) = Ax + tripletintpointpair(pcounttripletintpointpair, 8) = Ay + tripletintpointpair(pcounttripletintpointpair, 9) = Az + tripletintpointpair(pcounttripletintpointpair, 10) = Bx + tripletintpointpair(pcounttripletintpointpair, 11) = By + tripletintpointpair(pcounttripletintpointpair, 12) = Bz + tripletintpointpair(pcounttripletintpointpair, 13) = Cx + tripletintpointpair(pcounttripletintpointpair, 14) = Cy + tripletintpointpair(pcounttripletintpointpair, 15) = Cz + tripletintpointpair(pcounttripletintpointpair, 16) = Ex + tripletintpointpair(pcounttripletintpointpair, 17) = Ey + tripletintpointpair(pcounttripletintpointpair, 18) = Ez + tripletintpointpair(pcounttripletintpointpair, 19) = Fx + tripletintpointpair(pcounttripletintpointpair, 20) = Fy + tripletintpointpair(pcounttripletintpointpair, 21) = Fz +ELSE + intBCEF = 0 +END IF + +IF magalphaCAEF1 - magtripletCAps < 0 AND magalphaCAEF2 - magtripletCAps < 0 AND magalphaEFCA1 - magtripletEFps < 0 AND magalphaEFCA2 - magtripletEFps < 0 THEN + qCA1u = (Csu - alphaCAEF1u) / fovd + numerator = qCA1u * Cn - Cu + denominator = Au - Cu + qCA1u * (Cn - An) + betaCAEF = numerator / denominator + qEF1u = (Esu - alphaEFCA1u) / fovd + numerator = qEF1u * En - Eu + denominator = Fu - Eu + qEF1u * (En - Fn) + betaEFCA = numerator / denominator + intCAEF = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Cx * (1 - betaCAEF) + betaCAEF * Ax + tripletintpointpair(pcounttripletintpointpair, 2) = Cy * (1 - betaCAEF) + betaCAEF * Ay + tripletintpointpair(pcounttripletintpointpair, 3) = Cz * (1 - betaCAEF) + betaCAEF * Az + tripletintpointpair(pcounttripletintpointpair, 4) = Ex * (1 - betaEFCA) + betaEFCA * Fx + tripletintpointpair(pcounttripletintpointpair, 5) = Ey * (1 - betaEFCA) + betaEFCA * Fy + tripletintpointpair(pcounttripletintpointpair, 6) = Ez * (1 - betaEFCA) + betaEFCA * Fz + tripletintpointpair(pcounttripletintpointpair, 7) = Bx + tripletintpointpair(pcounttripletintpointpair, 8) = By + tripletintpointpair(pcounttripletintpointpair, 9) = Bz + tripletintpointpair(pcounttripletintpointpair, 10) = Cx + tripletintpointpair(pcounttripletintpointpair, 11) = Cy + tripletintpointpair(pcounttripletintpointpair, 12) = Cz + tripletintpointpair(pcounttripletintpointpair, 13) = Ax + tripletintpointpair(pcounttripletintpointpair, 14) = Ay + tripletintpointpair(pcounttripletintpointpair, 15) = Az + tripletintpointpair(pcounttripletintpointpair, 16) = Ex + tripletintpointpair(pcounttripletintpointpair, 17) = Ey + tripletintpointpair(pcounttripletintpointpair, 18) = Ez + tripletintpointpair(pcounttripletintpointpair, 19) = Fx + tripletintpointpair(pcounttripletintpointpair, 20) = Fy + tripletintpointpair(pcounttripletintpointpair, 21) = Fz +ELSE + intCAEF = 0 +END IF + +IF magalphaABFD1 - magtripletABps < 0 AND magalphaABFD2 - magtripletABps < 0 AND magalphaFDAB1 - magtripletFDps < 0 AND magalphaFDAB2 - magtripletFDps < 0 THEN + qAB1u = (Asu - alphaABFD1u) / fovd + numerator = qAB1u * An - Au + denominator = Bu - Au + qAB1u * (An - Bn) + betaABFD = numerator / denominator + qFD1u = (Fsu - alphaFDAB1u) / fovd + numerator = qFD1u * Fn - Fu + denominator = Du - Fu + qFD1u * (Fn - Dn) + betaFDAB = numerator / denominator + intABFD = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Ax * (1 - betaABFD) + betaABFD * Bx + tripletintpointpair(pcounttripletintpointpair, 2) = Ay * (1 - betaABFD) + betaABFD * By + tripletintpointpair(pcounttripletintpointpair, 3) = Az * (1 - betaABFD) + betaABFD * Bz + tripletintpointpair(pcounttripletintpointpair, 4) = Fx * (1 - betaFDAB) + betaFDAB * Dx + tripletintpointpair(pcounttripletintpointpair, 5) = Fy * (1 - betaFDAB) + betaFDAB * Dy + tripletintpointpair(pcounttripletintpointpair, 6) = Fz * (1 - betaFDAB) + betaFDAB * Dz + tripletintpointpair(pcounttripletintpointpair, 7) = Cx + tripletintpointpair(pcounttripletintpointpair, 8) = Cy + tripletintpointpair(pcounttripletintpointpair, 9) = Cz + tripletintpointpair(pcounttripletintpointpair, 10) = Ax + tripletintpointpair(pcounttripletintpointpair, 11) = Ay + tripletintpointpair(pcounttripletintpointpair, 12) = Az + tripletintpointpair(pcounttripletintpointpair, 13) = Bx + tripletintpointpair(pcounttripletintpointpair, 14) = By + tripletintpointpair(pcounttripletintpointpair, 15) = Bz + tripletintpointpair(pcounttripletintpointpair, 16) = Fx + tripletintpointpair(pcounttripletintpointpair, 17) = Fy + tripletintpointpair(pcounttripletintpointpair, 18) = Fz + tripletintpointpair(pcounttripletintpointpair, 19) = Dx + tripletintpointpair(pcounttripletintpointpair, 20) = Dy + tripletintpointpair(pcounttripletintpointpair, 21) = Dz +ELSE + intABFD = 0 +END IF + +IF magalphaBCFD1 - magtripletBCps < 0 AND magalphaBCFD2 - magtripletBCps < 0 AND magalphaFDBC1 - magtripletFDps < 0 AND magalphaFDBC2 - magtripletFDps < 0 THEN + qBC1u = (Bsu - alphaBCFD1u) / fovd + numerator = qBC1u * Bn - Bu + denominator = Cu - Bu + qBC1u * (Bn - Cn) + betaBCFD = numerator / denominator + qFD1u = (Fsu - alphaFDBC1u) / fovd + numerator = qFD1u * Fn - Fu + denominator = Du - Fu + qFD1u * (Fn - Dn) + betaFDBC = numerator / denominator + intBCFD = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Bx * (1 - betaBCFD) + betaBCFD * Cx + tripletintpointpair(pcounttripletintpointpair, 2) = By * (1 - betaBCFD) + betaBCFD * Cy + tripletintpointpair(pcounttripletintpointpair, 3) = Bz * (1 - betaBCFD) + betaBCFD * Cz + tripletintpointpair(pcounttripletintpointpair, 4) = Fx * (1 - betaFDBC) + betaFDBC * Dx + tripletintpointpair(pcounttripletintpointpair, 5) = Fy * (1 - betaFDBC) + betaFDBC * Dy + tripletintpointpair(pcounttripletintpointpair, 6) = Fz * (1 - betaFDBC) + betaFDBC * Dz + tripletintpointpair(pcounttripletintpointpair, 7) = Ax + tripletintpointpair(pcounttripletintpointpair, 8) = Ay + tripletintpointpair(pcounttripletintpointpair, 9) = Az + tripletintpointpair(pcounttripletintpointpair, 10) = Bx + tripletintpointpair(pcounttripletintpointpair, 11) = By + tripletintpointpair(pcounttripletintpointpair, 12) = Bz + tripletintpointpair(pcounttripletintpointpair, 13) = Cx + tripletintpointpair(pcounttripletintpointpair, 14) = Cy + tripletintpointpair(pcounttripletintpointpair, 15) = Cz + tripletintpointpair(pcounttripletintpointpair, 16) = Fx + tripletintpointpair(pcounttripletintpointpair, 17) = Fy + tripletintpointpair(pcounttripletintpointpair, 18) = Fz + tripletintpointpair(pcounttripletintpointpair, 19) = Dx + tripletintpointpair(pcounttripletintpointpair, 20) = Dy + tripletintpointpair(pcounttripletintpointpair, 21) = Dz +ELSE + intBCFD = 0 +END IF + +IF magalphaCAFD1 - magtripletCAps < 0 AND magalphaCAFD2 - magtripletCAps < 0 AND magalphaFDCA1 - magtripletFDps < 0 AND magalphaFDCA2 - magtripletFDps < 0 THEN + qCA1u = (Csu - alphaCAFD1u) / fovd + numerator = qCA1u * Cn - Cu + denominator = Au - Cu + qCA1u * (Cn - An) + betaCAFD = numerator / denominator + qFD1u = (Fsu - alphaFDCA1u) / fovd + numerator = qFD1u * Fn - Fu + denominator = Du - Fu + qFD1u * (Fn - Dn) + betaFDCA = numerator / denominator + intCAFD = 1 + pcounttripletintpointpair = pcounttripletintpointpair + 1 + tripletintpointpair(pcounttripletintpointpair, 1) = Cx * (1 - betaCAFD) + betaCAFD * Ax + tripletintpointpair(pcounttripletintpointpair, 2) = Cy * (1 - betaCAFD) + betaCAFD * Ay + tripletintpointpair(pcounttripletintpointpair, 3) = Cz * (1 - betaCAFD) + betaCAFD * Az + tripletintpointpair(pcounttripletintpointpair, 4) = Fx * (1 - betaFDCA) + betaFDCA * Dx + tripletintpointpair(pcounttripletintpointpair, 5) = Fy * (1 - betaFDCA) + betaFDCA * Dy + tripletintpointpair(pcounttripletintpointpair, 6) = Fz * (1 - betaFDCA) + betaFDCA * Dz + tripletintpointpair(pcounttripletintpointpair, 7) = Bx + tripletintpointpair(pcounttripletintpointpair, 8) = By + tripletintpointpair(pcounttripletintpointpair, 9) = Bz + tripletintpointpair(pcounttripletintpointpair, 10) = Cx + tripletintpointpair(pcounttripletintpointpair, 11) = Cy + tripletintpointpair(pcounttripletintpointpair, 12) = Cz + tripletintpointpair(pcounttripletintpointpair, 13) = Ax + tripletintpointpair(pcounttripletintpointpair, 14) = Ay + tripletintpointpair(pcounttripletintpointpair, 15) = Az + tripletintpointpair(pcounttripletintpointpair, 16) = Fx + tripletintpointpair(pcounttripletintpointpair, 17) = Fy + tripletintpointpair(pcounttripletintpointpair, 18) = Fz + tripletintpointpair(pcounttripletintpointpair, 19) = Dx + tripletintpointpair(pcounttripletintpointpair, 20) = Dy + tripletintpointpair(pcounttripletintpointpair, 21) = Dz +ELSE + intCAFD = 0 +END IF +RETURN + +triplet.image.generate: +flagimagechange = 0 + +SELECT CASE signaturefull$ + + CASE " 0 0 0" '*' 1 of 15 + 'LOCATE 1, 1: PRINT signaturefull$ + + CASE " 0 0 4" '*' 2 of 15 + ' Load information on overlap triangle. + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + int3ABCx = tripletintpointpair(3, 1) + int3ABCy = tripletintpointpair(3, 2) + int3ABCz = tripletintpointpair(3, 3) + int3DEFx = tripletintpointpair(3, 4) + int3DEFy = tripletintpointpair(3, 5) + int3DEFz = tripletintpointpair(3, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip004enabled = 1 THEN + 'LOCATE 2, 1: PRINT signaturefull$ + flagimagechange = 1 + ' Classify the two outer points of ABC. + outerpoint1x = tripletintpointpair(1, 7) + outerpoint1y = tripletintpointpair(1, 8) + outerpoint1z = tripletintpointpair(1, 9) + possibleoutpoint2x = tripletintpointpair(2, 7) + possibleoutpoint2y = tripletintpointpair(2, 8) + possibleoutpoint2z = tripletintpointpair(2, 9) + possibleoutpoint3x = tripletintpointpair(3, 7) + possibleoutpoint3y = tripletintpointpair(3, 8) + possibleoutpoint3z = tripletintpointpair(3, 9) + '*'possibleoutpoint4x = tripletintpointpair(4, 7) + '*'possibleoutpoint4y = tripletintpointpair(4, 8) + '*'possibleoutpoint4z = tripletintpointpair(4, 9) + IF SQR((outerpoint1x - possibleoutpoint2x) ^ 2 + (outerpoint1y - possibleoutpoint2y) ^ 2 + (outerpoint1z - possibleoutpoint2z) ^ 2) < 0.0001 THEN + outerpoint2x = possibleoutpoint3x + outerpoint2y = possibleoutpoint3y + outerpoint2z = possibleoutpoint3z + ELSE + outerpoint2x = possibleoutpoint2x + outerpoint2y = possibleoutpoint2y + outerpoint2z = possibleoutpoint2z + END IF + ' Classify the lonely point of ABC. + possibleinpoint1x = tripletintpointpair(1, 10) + possibleinpoint1y = tripletintpointpair(1, 11) + possibleinpoint1z = tripletintpointpair(1, 12) + possibleinpoint2x = tripletintpointpair(1, 13) + possibleinpoint2y = tripletintpointpair(1, 14) + possibleinpoint2z = tripletintpointpair(1, 15) + IF SQR((possibleinpoint1x - outerpoint1x) ^ 2 + (possibleinpoint1y - outerpoint1y) ^ 2 + (possibleinpoint1z - outerpoint1z) ^ 2) > 0.1 AND SQR((possibleinpoint1x - outerpoint2x) ^ 2 + (possibleinpoint1y - outerpoint2y) ^ 2 + (possibleinpoint1z - outerpoint2z) ^ 2) > 0.1 THEN + innerpointx = possibleinpoint1x + innerpointy = possibleinpoint1y + innerpointz = possibleinpoint1z + ELSE + innerpointx = possibleinpoint2x + innerpointy = possibleinpoint2y + innerpointz = possibleinpoint2z + END IF + ' Determine the closest and furthest int points on each int line for lonely point. + test1pointx = tripletintpointpair(1, 1) + test1pointy = tripletintpointpair(1, 2) + test1pointz = tripletintpointpair(1, 3) + test1pointuninvolvedx = tripletintpointpair(1, 7) + test1pointuninvolvedy = tripletintpointpair(1, 8) + test1pointuninvolvedz = tripletintpointpair(1, 9) + disttotest1point = SQR((innerpointx - test1pointx) ^ 2 + (innerpointy - test1pointy) ^ 2 + (innerpointz - test1pointz) ^ 2) + disttotest1pointuninvolved = SQR((innerpointx - test1pointuninvolvedx) ^ 2 + (innerpointy - test1pointuninvolvedy) ^ 2 + (innerpointz - test1pointuninvolvedz) ^ 2) + test2pointx = tripletintpointpair(2, 1) + test2pointy = tripletintpointpair(2, 2) + test2pointz = tripletintpointpair(2, 3) + test2pointuninvolvedx = tripletintpointpair(2, 7) + test2pointuninvolvedy = tripletintpointpair(2, 8) + test2pointuninvolvedz = tripletintpointpair(2, 9) + disttotest2point = SQR((innerpointx - test2pointx) ^ 2 + (innerpointy - test2pointy) ^ 2 + (innerpointz - test2pointz) ^ 2) + disttotest2pointuninvolved = SQR((innerpointx - test2pointuninvolvedx) ^ 2 + (innerpointy - test2pointuninvolvedy) ^ 2 + (innerpointz - test2pointuninvolvedz) ^ 2) + test3pointx = tripletintpointpair(3, 1) + test3pointy = tripletintpointpair(3, 2) + test3pointz = tripletintpointpair(3, 3) + test3pointuninvolvedx = tripletintpointpair(3, 7) + test3pointuninvolvedy = tripletintpointpair(3, 8) + test3pointuninvolvedz = tripletintpointpair(3, 9) + disttotest3point = SQR((innerpointx - test3pointx) ^ 2 + (innerpointy - test3pointy) ^ 2 + (innerpointz - test3pointz) ^ 2) + disttotest3pointuninvolved = SQR((innerpointx - test3pointuninvolvedx) ^ 2 + (innerpointy - test3pointuninvolvedy) ^ 2 + (innerpointz - test3pointuninvolvedz) ^ 2) + test4pointx = tripletintpointpair(4, 1) + test4pointy = tripletintpointpair(4, 2) + test4pointz = tripletintpointpair(4, 3) + test4pointuninvolvedx = tripletintpointpair(4, 7) + test4pointuninvolvedy = tripletintpointpair(4, 8) + test4pointuninvolvedz = tripletintpointpair(4, 9) + disttotest4point = SQR((innerpointx - test4pointx) ^ 2 + (innerpointy - test4pointy) ^ 2 + (innerpointz - test4pointz) ^ 2) + disttotest4pointuninvolved = SQR((innerpointx - test4pointuninvolvedx) ^ 2 + (innerpointy - test4pointuninvolvedy) ^ 2 + (innerpointz - test4pointuninvolvedz) ^ 2) + testpoint1used = 0 + testpoint2used = 0 + testpoint3used = 0 + testpoint4used = 0 + IF SQR((disttotest1pointuninvolved - disttotest2pointuninvolved) ^ 2) < 0.0001 THEN + testpoint1used = 1 + testpoint2used = 1 + IF disttotest1point < disttotest2point THEN + firsttriangleleftx = test1pointx + firsttrianglelefty = test1pointy + firsttriangleleftz = test1pointz + firstfurtherpointx = test2pointx + firstfurtherpointy = test2pointy + firstfurtherpointz = test2pointz + ELSE + firsttriangleleftx = test2pointx + firsttrianglelefty = test2pointy + firsttriangleleftz = test2pointz + firstfurtherpointx = test1pointx + firstfurtherpointy = test1pointy + firstfurtherpointz = test1pointz + END IF + END IF + IF SQR((disttotest1pointuninvolved - disttotest3pointuninvolved) ^ 2) < 0.0001 THEN + testpoint1used = 1 + testpoint3used = 1 + IF disttotest1point < disttotest3point THEN + firsttriangleleftx = test1pointx + firsttrianglelefty = test1pointy + firsttriangleleftz = test1pointz + firstfurtherpointx = test3pointx + firstfurtherpointy = test3pointy + firstfurtherpointz = test3pointz + ELSE + firsttriangleleftx = test3pointx + firsttrianglelefty = test3pointy + firsttriangleleftz = test3pointz + firstfurtherpointx = test1pointx + firstfurtherpointy = test1pointy + firstfurtherpointz = test1pointz + END IF + END IF + IF SQR((disttotest1pointuninvolved - disttotest4pointuninvolved) ^ 2) < 0.0001 THEN + testpoint1used = 1 + testpoint4used = 1 + IF disttotest1point < disttotest4point THEN + firsttriangleleftx = test1pointx + firsttrianglelefty = test1pointy + firsttriangleleftz = test1pointz + firstfurtherpointx = test4pointx + firstfurtherpointy = test4pointy + firstfurtherpointz = test4pointz + ELSE + firsttriangleleftx = test4pointx + firsttrianglelefty = test4pointy + firsttriangleleftz = test4pointz + firstfurtherpointx = test1pointx + firstfurtherpointy = test1pointy + firstfurtherpointz = test1pointz + END IF + END IF + IF testpoint2used = 0 AND testpoint3used = 0 THEN + IF disttotest2point < disttotest3point THEN + firsttrianglerightx = test2pointx + firsttrianglerighty = test2pointy + firsttrianglerightz = test2pointz + secondfurtherpointx = test3pointx + secondfurtherpointy = test3pointy + secondfurtherpointz = test3pointz + ELSE + firsttrianglerightx = test3pointx + firsttrianglerighty = test3pointy + firsttrianglerightz = test3pointz + secondfurtherpointx = test2pointx + secondfurtherpointy = test2pointy + secondfurtherpointz = test2pointz + END IF + END IF + IF testpoint3used = 0 AND testpoint4used = 0 THEN + IF disttotest3point < disttotest4point THEN + firsttrianglerightx = test3pointx + firsttrianglerighty = test3pointy + firsttrianglerightz = test3pointz + secondfurtherpointx = test4pointx + secondfurtherpointy = test4pointy + secondfurtherpointz = test4pointz + ELSE + firsttrianglerightx = test4pointx + firsttrianglerighty = test4pointy + firsttrianglerightz = test4pointz + secondfurtherpointx = test3pointx + secondfurtherpointy = test3pointy + secondfurtherpointz = test3pointz + END IF + END IF + IF testpoint4used = 0 AND testpoint2used = 0 THEN + IF disttotest4point < disttotest2point THEN + firsttrianglerightx = test4pointx + firsttrianglerighty = test4pointy + firsttrianglerightz = test4pointz + secondfurtherpointx = test2pointx + secondfurtherpointy = test2pointy + secondfurtherpointz = test2pointz + ELSE + firsttrianglerightx = test2pointx + firsttrianglerighty = test2pointy + firsttrianglerightz = test2pointz + secondfurtherpointx = test4pointx + secondfurtherpointy = test4pointy + secondfurtherpointz = test4pointz + END IF + END IF + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = innerpointx + basepointy = innerpointy + basepointz = innerpointz + rightpointx = firsttrianglerightx + rightpointy = firsttrianglerighty + rightpointz = firsttrianglerightz + leftpointx = firsttriangleleftx + leftpointy = firsttrianglelefty + leftpointz = firsttriangleleftz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = firstfurtherpointx + basepointy = firstfurtherpointy + basepointz = firstfurtherpointz + rightpointx = secondfurtherpointx + rightpointy = secondfurtherpointy + rightpointz = secondfurtherpointz + leftpointx = outerpoint1x + leftpointy = outerpoint1y + leftpointz = outerpoint1z + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = firstfurtherpointx + basepointy = firstfurtherpointy + basepointz = firstfurtherpointz + rightpointx = outerpoint1x + rightpointy = outerpoint1y + rightpointz = outerpoint1z + leftpointx = outerpoint2x + leftpointy = outerpoint2y + leftpointz = outerpoint2z + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 0 3 0" '*' 3 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 1) + int3ABCy = tripletencpoint(1, 2) + int3ABCz = tripletencpoint(1, 3) + int3DEFx = tripletencpoint(1, 4) + int3DEFy = tripletencpoint(1, 5) + int3DEFz = tripletencpoint(1, 6) + int1ABCx = tripletencpoint(2, 1) + int1ABCy = tripletencpoint(2, 2) + int1ABCz = tripletencpoint(2, 3) + int1DEFx = tripletencpoint(2, 4) + int1DEFy = tripletencpoint(2, 5) + int1DEFz = tripletencpoint(3, 6) + int2ABCx = tripletencpoint(3, 1) + int2ABCy = tripletencpoint(3, 2) + int2ABCz = tripletencpoint(3, 3) + int2DEFx = tripletencpoint(3, 4) + int2DEFy = tripletencpoint(3, 5) + int2DEFz = tripletencpoint(3, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND snip030enabled = 1 THEN + 'IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0 AND areaDEF > 0 AND snip030enabled = 1 THEN + 'LOCATE 3, 1: PRINT signaturefull$ + flagimagechange = 1 + flagindexkused = 0 + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 3 0 0" '*' 4 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 4) + int3ABCy = tripletencpoint(1, 5) + int3ABCz = tripletencpoint(1, 6) + int3DEFx = tripletencpoint(1, 1) + int3DEFy = tripletencpoint(1, 2) + int3DEFz = tripletencpoint(1, 3) + int1ABCx = tripletencpoint(2, 4) + int1ABCy = tripletencpoint(2, 5) + int1ABCz = tripletencpoint(2, 6) + int1DEFx = tripletencpoint(2, 1) + int1DEFy = tripletencpoint(2, 2) + int1DEFz = tripletencpoint(2, 3) + int2ABCx = tripletencpoint(3, 4) + int2ABCy = tripletencpoint(3, 5) + int2ABCz = tripletencpoint(3, 6) + int2DEFx = tripletencpoint(3, 1) + int2DEFy = tripletencpoint(3, 2) + int2DEFz = tripletencpoint(3, 3) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip300enabled = 1 THEN + 'LOCATE 4, 1: PRINT signaturefull$ + flagimagechange = 1 + centDEFx = (1 / 3) * (tripletencpoint(1, 4) + tripletencpoint(2, 4) + tripletencpoint(3, 4)) + centDEFy = (1 / 3) * (tripletencpoint(1, 5) + tripletencpoint(2, 5) + tripletencpoint(3, 5)) + centDEFz = (1 / 3) * (tripletencpoint(1, 6) + tripletencpoint(2, 6) + tripletencpoint(3, 6)) + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = centDEFx + basepointy = centDEFy + basepointz = centDEFz + rightpointx = Ax + rightpointy = Ay + rightpointz = Az + leftpointx = Bx + leftpointy = By + leftpointz = Bz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = centDEFx + basepointy = centDEFy + basepointz = centDEFz + rightpointx = Bx + rightpointy = By + rightpointz = Bz + leftpointx = Cx + leftpointy = Cy + leftpointz = Cz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = centDEFx + basepointy = centDEFy + basepointz = centDEFz + rightpointx = Cx + rightpointy = Cy + rightpointz = Cz + leftpointx = Ax + leftpointy = Ay + leftpointz = Az + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 0 0 6" '*' 5 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletintpointpair(3, 1) + int3ABCy = tripletintpointpair(3, 2) + int3ABCz = tripletintpointpair(3, 3) + int3DEFx = tripletintpointpair(3, 4) + int3DEFy = tripletintpointpair(3, 5) + int3DEFz = tripletintpointpair(3, 6) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip006enabled = 1 THEN + 'LOCATE 5, 1: PRINT signaturefull$ + flagimagechange = 1 + centDEFx = (1 / 3) * (Dx + Ex + Fx) '(tripletencpoint(1, 4) + tripletencpoint(2, 4) + tripletencpoint(3, 4)) + centDEFy = (1 / 3) * (Dy + Ey + Fy) '(tripletencpoint(1, 5) + tripletencpoint(2, 5) + tripletencpoint(3, 5)) + centDEFz = (1 / 3) * (Dz + Ez + Fz) '(tripletencpoint(1, 6) + tripletencpoint(2, 6) + tripletencpoint(3, 6)) + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = centDEFx + basepointy = centDEFy + basepointz = centDEFz + rightpointx = Ax + rightpointy = Ay + rightpointz = Az + leftpointx = Bx + leftpointy = By + leftpointz = Bz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = centDEFx + basepointy = centDEFy + basepointz = centDEFz + rightpointx = Bx + rightpointy = By + rightpointz = Bz + leftpointx = Cx + leftpointy = Cy + leftpointz = Cz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = centDEFx + basepointy = centDEFy + basepointz = centDEFz + rightpointx = Cx + rightpointy = Cy + rightpointz = Cz + leftpointx = Ax + leftpointy = Ay + leftpointz = Az + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 0 1 2" '*' 6 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 1) + int3ABCy = tripletencpoint(1, 2) + int3ABCz = tripletencpoint(1, 3) + int3DEFx = tripletencpoint(1, 4) + int3DEFy = tripletencpoint(1, 5) + int3DEFz = tripletencpoint(1, 6) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip012enabled = 1 THEN + 'LOCATE 6, 1: PRINT signaturefull$ + flagimagechange = 1 + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = tripletintpointpair(2, 7) + basepointy = tripletintpointpair(2, 8) + basepointz = tripletintpointpair(2, 9) + rightpointx = int1ABCx + rightpointy = int1ABCy + rightpointz = int1ABCz + leftpointx = tripletintpointpair(1, 7) + leftpointy = tripletintpointpair(1, 8) + leftpointz = tripletintpointpair(1, 9) + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = int2ABCx + basepointy = int2ABCy + basepointz = int2ABCz + rightpointx = tripletintpointpair(1, 7) + rightpointy = tripletintpointpair(1, 8) + rightpointz = tripletintpointpair(1, 9) + leftpointx = int1ABCx + leftpointy = int1ABCy + leftpointz = int1ABCz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 1 0 2" '*' 7 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 4) + int3ABCy = tripletencpoint(1, 5) + int3ABCz = tripletencpoint(1, 6) + int3DEFx = tripletencpoint(1, 1) + int3DEFy = tripletencpoint(1, 2) + int3DEFz = tripletencpoint(1, 3) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip102enabled = 1 THEN + 'LOCATE 7, 1: PRINT signaturefull$ + flagimagechange = 1 + outerpointx = tripletintpointpair(1, 7) + outerpointy = tripletintpointpair(1, 8) + outerpointz = tripletintpointpair(1, 9) + leftvertpointx = tripletintpointpair(1, 10) + leftvertpointy = tripletintpointpair(1, 11) + leftvertpointz = tripletintpointpair(1, 12) + rightvertpointx = tripletintpointpair(1, 13) + rightvertpointy = tripletintpointpair(1, 14) + rightvertpointz = tripletintpointpair(1, 15) + int1ABCdistleftvertpoint = SQR((leftvertpointx - int1ABCx) ^ 2 + (leftvertpointy - int1ABCy) ^ 2 + (leftvertpointz - int1ABCz) ^ 2) + '*'int1ABCdistrightvertpoint = SQR((rightvertpointx - int1ABCx) ^ 2 + (rightvertpointy - int1ABCy) ^ 2 + (rightvertpointz - int1ABCz) ^ 2) + int2ABCdistleftvertpoint = SQR((leftvertpointx - int2ABCx) ^ 2 + (leftvertpointy - int2ABCy) ^ 2 + (leftvertpointz - int2ABCz) ^ 2) + '*'int2ABCdistrightvertpoint = SQR((rightvertpointx - int2ABCx) ^ 2 + (rightvertpointy - int2ABCy) ^ 2 + (rightvertpointz - int2ABCz) ^ 2) + IF int1ABCdistleftvertpoint < int2ABCdistleftvertpoint THEN + intleftclosestx = int1ABCx + intleftclosesty = int1ABCy + intleftclosestz = int1ABCz + intrightclosestx = int2ABCx + intrightclosesty = int2ABCy + intrightclosestz = int2ABCz + ELSE + intleftclosestx = int2ABCx + intleftclosesty = int2ABCy + intleftclosestz = int2ABCz + intrightclosestx = int1ABCx + intrightclosesty = int1ABCy + intrightclosestz = int1ABCz + END IF + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = leftvertpointx + basepointy = leftvertpointy + basepointz = leftvertpointz + rightpointx = intleftclosestx + rightpointy = intleftclosesty + rightpointz = intleftclosestz + leftpointx = int3ABCx + leftpointy = int3ABCy + leftpointz = int3ABCz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = outerpointx + basepointy = outerpointy + basepointz = outerpointz + rightpointx = leftvertpointx + rightpointy = leftvertpointy + rightpointz = leftvertpointz + leftpointx = int3ABCx + leftpointy = int3ABCy + leftpointz = int3ABCz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = outerpointx + basepointy = outerpointy + basepointz = outerpointz + rightpointx = int3ABCx + rightpointy = int3ABCy + rightpointz = int3ABCz + leftpointx = rightvertpointx + leftpointy = rightvertpointy + leftpointz = rightvertpointz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Fourth new triangle. + basepointx = rightvertpointx + basepointy = rightvertpointy + basepointz = rightvertpointz + rightpointx = int3ABCx + rightpointy = int3ABCy + rightpointz = int3ABCz + leftpointx = intrightclosestx + leftpointy = intrightclosesty + leftpointz = intrightclosestz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + CASE " 1 1 2" '*' 8 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 4) ' + int3ABCy = tripletencpoint(1, 5) ' + int3ABCz = tripletencpoint(1, 6) ' + int3DEFx = tripletencpoint(1, 1) ' + int3DEFy = tripletencpoint(1, 2) ' + int3DEFz = tripletencpoint(1, 3) ' + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip112enabled = 1 THEN + 'LOCATE 8, 1: PRINT signaturefull$ + flagimagechange = 1 + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = int3ABCx ' + basepointy = int3ABCy ' + basepointz = int3ABCz ' + rightpointx = int1ABCx + rightpointy = int1ABCy + rightpointz = int1ABCz + leftpointx = tripletintpointpair(2, 7) + leftpointy = tripletintpointpair(2, 8) + leftpointz = tripletintpointpair(2, 9) + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = int3ABCx ' + basepointy = int3ABCy ' + basepointz = int3ABCz ' + rightpointx = tripletintpointpair(1, 7) + rightpointy = tripletintpointpair(1, 8) + rightpointz = tripletintpointpair(1, 9) + leftpointx = tripletintpointpair(2, 7) + leftpointy = tripletintpointpair(2, 8) + leftpointz = tripletintpointpair(2, 9) + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = int3ABCx ' + basepointy = int3ABCy ' + basepointz = int3ABCz ' + rightpointx = int2ABCx + rightpointy = int2ABCy + rightpointz = int2ABCz + leftpointx = tripletintpointpair(1, 7) + leftpointy = tripletintpointpair(1, 8) + leftpointz = tripletintpointpair(1, 9) + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 0 2 2" '*' 9 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 1) + int3ABCy = tripletencpoint(1, 2) + int3ABCz = tripletencpoint(1, 3) + int3DEFx = tripletencpoint(1, 4) + int3DEFy = tripletencpoint(1, 5) + int3DEFz = tripletencpoint(1, 6) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip022enabled = 1 THEN + 'LOCATE 9, 1: PRINT signaturefull$ + flagimagechange = 1 + ' Classify the outer point of ABC. + possibleoutpoint1x = tripletintpointpair(1, 10) + possibleoutpoint1y = tripletintpointpair(1, 11) + possibleoutpoint1z = tripletintpointpair(1, 12) + possibleoutpoint2x = tripletintpointpair(1, 13) + possibleoutpoint2y = tripletintpointpair(1, 14) + possibleoutpoint2z = tripletintpointpair(1, 15) + IF SQR((possibleoutpoint1x - tripletencpoint(1, 1)) ^ 2 + (possibleoutpoint1y - tripletencpoint(1, 2)) ^ 2 + (possibleoutpoint1z - tripletencpoint(1, 3)) ^ 2) > 0.1 AND SQR((possibleoutpoint1x - tripletencpoint(2, 1)) ^ 2 + (possibleoutpoint1y - tripletencpoint(2, 2)) ^ 2 + (possibleoutpoint1z - tripletencpoint(2, 3)) ^ 2) > 0.1 THEN + outerpointx = possibleoutpoint1x + outerpointy = possibleoutpoint1y + outerpointz = possibleoutpoint1z + ELSE + outerpointx = possibleoutpoint2x + outerpointy = possibleoutpoint2y + outerpointz = possibleoutpoint2z + END IF + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = int1ABCx + basepointy = int1ABCy + basepointz = int1ABCz + rightpointx = outerpointx + rightpointy = outerpointy + rightpointz = outerpointz + leftpointx = int2ABCx + leftpointy = int2ABCy + leftpointz = int2ABCz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 2 0 2" '*' 10 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 4) + int3ABCy = tripletencpoint(1, 5) + int3ABCz = tripletencpoint(1, 6) + int3DEFx = tripletencpoint(1, 1) + int3DEFy = tripletencpoint(1, 2) + int3DEFz = tripletencpoint(1, 3) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip202enabled = 1 THEN + 'LOCATE 10, 1: PRINT signaturefull$ + flagimagechange = 1 + verttopx = tripletintpointpair(1, 7) + verttopy = tripletintpointpair(1, 8) + verttopz = tripletintpointpair(1, 9) + vertleftx = tripletintpointpair(1, 10) + vertlefty = tripletintpointpair(1, 11) + vertleftz = tripletintpointpair(1, 12) + vertrightx = tripletintpointpair(1, 13) + vertrighty = tripletintpointpair(1, 14) + vertrightz = tripletintpointpair(1, 15) + disttointpoint1 = SQR((vertleftx - tripletintpointpair(1, 1)) ^ 2 + (vertlefty - tripletintpointpair(1, 2)) ^ 2 + (vertleftz - tripletintpointpair(1, 3)) ^ 2) + disttointpoint2 = SQR((vertleftx - tripletintpointpair(2, 1)) ^ 2 + (vertlefty - tripletintpointpair(2, 2)) ^ 2 + (vertleftz - tripletintpointpair(2, 3)) ^ 2) + IF disttointpoint1 < disttointpoint2 THEN + intleftx = tripletintpointpair(1, 1) + intlefty = tripletintpointpair(1, 2) + intleftz = tripletintpointpair(1, 3) + intrightx = tripletintpointpair(2, 1) + intrighty = tripletintpointpair(2, 2) + intrightz = tripletintpointpair(2, 3) + candencleft1x = tripletintpointpair(1, 16) + candencleft1y = tripletintpointpair(1, 17) + candencleft1z = tripletintpointpair(1, 18) + candencleft2x = tripletintpointpair(1, 19) + candencleft2y = tripletintpointpair(1, 20) + candencleft2z = tripletintpointpair(1, 21) + ELSE + intleftx = tripletintpointpair(2, 1) + intlefty = tripletintpointpair(2, 2) + intleftz = tripletintpointpair(2, 3) + intrightx = tripletintpointpair(1, 1) + intrighty = tripletintpointpair(1, 2) + intrightz = tripletintpointpair(1, 3) + candencleft1x = tripletintpointpair(2, 16) + candencleft1y = tripletintpointpair(2, 17) + candencleft1z = tripletintpointpair(2, 18) + candencleft2x = tripletintpointpair(2, 19) + candencleft2y = tripletintpointpair(2, 20) + candencleft2z = tripletintpointpair(2, 21) + END IF + IF SQR((candencleft1x - tripletencpoint(1, 1)) ^ 2 + (candencleft1y - tripletencpoint(1, 2)) ^ 2 + (candencleft1z - tripletencpoint(1, 3)) ^ 2) < 0.0001 OR SQR((candencleft2x - tripletencpoint(1, 1)) ^ 2 + (candencleft2y - tripletencpoint(1, 2)) ^ 2 + (candencleft2z - tripletencpoint(1, 3)) ^ 2) < 0.0001 THEN + encpointleftx = tripletencpoint(1, 4) + encpointlefty = tripletencpoint(1, 5) + encpointleftz = tripletencpoint(1, 6) + encpointrightx = tripletencpoint(2, 4) + encpointrighty = tripletencpoint(2, 5) + encpointrightz = tripletencpoint(2, 6) + ELSE + encpointleftx = tripletencpoint(2, 4) + encpointlefty = tripletencpoint(2, 5) + encpointleftz = tripletencpoint(2, 6) + encpointrightx = tripletencpoint(1, 4) + encpointrighty = tripletencpoint(1, 5) + encpointrightz = tripletencpoint(1, 6) + END IF + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = intleftx + basepointy = intlefty + basepointz = intleftz + rightpointx = encpointleftx + rightpointy = encpointlefty + rightpointz = encpointleftz + leftpointx = vertleftx + leftpointy = vertlefty + leftpointz = vertleftz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = encpointleftx + basepointy = encpointlefty + basepointz = encpointleftz + rightpointx = verttopx + rightpointy = verttopy + rightpointz = verttopz + leftpointx = vertleftx + leftpointy = vertlefty + leftpointz = vertleftz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = encpointrightx + basepointy = encpointrighty + basepointz = encpointrightz + rightpointx = verttopx + rightpointy = verttopy + rightpointz = verttopz + leftpointx = encpointleftx + leftpointy = encpointlefty + leftpointz = encpointleftz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Fourth new triangle. + basepointx = vertrightx + basepointy = vertrighty + basepointz = vertrightz + rightpointx = verttopx + rightpointy = verttopy + rightpointz = verttopz + leftpointx = encpointrightx + leftpointy = encpointrighty + leftpointz = encpointrightz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Fifth new triangle. + basepointx = vertrightx + basepointy = vertrighty + basepointz = vertrightz + rightpointx = encpointrightx + rightpointy = encpointrighty + rightpointz = encpointrightz + leftpointx = intrightx + leftpointy = intrighty + leftpointz = intrightz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 1 2 2" '*' 11 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 1) + int3ABCy = tripletencpoint(1, 2) + int3ABCz = tripletencpoint(1, 3) + int3DEFx = tripletencpoint(1, 4) + int3DEFy = tripletencpoint(1, 5) + int3DEFz = tripletencpoint(1, 6) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip122enabled = 1 THEN + 'LOCATE 11, 1: PRINT signaturefull$ + flagimagechange = 1 + candouterpoint1x = tripletintpointpair(1, 10) + candouterpoint1y = tripletintpointpair(1, 11) + candouterpoint1z = tripletintpointpair(1, 12) + candouterpoint2x = tripletintpointpair(1, 13) + candouterpoint2y = tripletintpointpair(1, 14) + candouterpoint2z = tripletintpointpair(1, 15) + IF SQR((candouterpoint1x - tripletencpoint(1, 1)) ^ 2 + (candouterpoint1y - tripletencpoint(1, 2)) ^ 2 + (candouterpoint1z - tripletencpoint(1, 3)) ^ 2) > 0.1 AND SQR((candouterpoint1x - tripletencpoint(2, 1)) ^ 2 + (candouterpoint1y - tripletencpoint(2, 2)) ^ 2 + (candouterpoint1z - tripletencpoint(2, 3)) ^ 2) > 0.1 THEN + outerpointx = candouterpoint1x + outerpointy = candouterpoint1y + outerpointz = candouterpoint1z + ELSE + outerpointx = candouterpoint1x + outerpointy = candouterpoint1y + outerpointz = candouterpoint1z + END IF + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = int3DEFx + basepointy = int3DEFy + basepointz = int3DEFz + rightpointx = outerpointx + rightpointy = outerpointy + rightpointz = outerpointz + leftpointx = int1ABCx + leftpointy = int1ABCy + leftpointz = int1ABCz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = int3DEFx + basepointy = int3DEFy + basepointz = int3DEFz + rightpointx = outerpointx + rightpointy = outerpointy + rightpointz = outerpointz + leftpointx = int2ABCx + leftpointy = int2ABCy + leftpointz = int2ABCz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + CASE " 2 1 2" '*' 12 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 4) + int3ABCy = tripletencpoint(1, 5) + int3ABCz = tripletencpoint(1, 6) + int3DEFx = tripletencpoint(1, 1) + int3DEFy = tripletencpoint(1, 2) + int3DEFz = tripletencpoint(1, 3) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip212enabled = 1 THEN + 'LOCATE 12, 1: PRINT signaturefull$ + flagimagechange = 1 + outvert1x = tripletintpointpair(2, 7) + outvert1y = tripletintpointpair(2, 8) + outvert1z = tripletintpointpair(2, 9) + outvert2x = tripletintpointpair(1, 7) + outvert2y = tripletintpointpair(1, 8) + outvert2z = tripletintpointpair(1, 9) + IF SQR((tripletintpointpair(1, 16) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(1, 17) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(1, 18) - tripletencpoint(1, 3)) ^ 2) < 0.0001 OR SQR((tripletintpointpair(1, 19) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(1, 20) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(1, 21) - tripletencpoint(1, 3)) ^ 2) < 0.0001 THEN + encpoint1x = tripletencpoint(1, 4) + encpoint1y = tripletencpoint(1, 5) + encpoint1z = tripletencpoint(1, 6) + encpoint2x = tripletencpoint(2, 4) + encpoint2y = tripletencpoint(2, 5) + encpoint2z = tripletencpoint(2, 6) + ELSE + encpoint1x = tripletencpoint(2, 4) + encpoint1y = tripletencpoint(2, 5) + encpoint1z = tripletencpoint(2, 6) + encpoint2x = tripletencpoint(1, 4) + encpoint2y = tripletencpoint(1, 5) + encpoint2z = tripletencpoint(1, 6) + END IF + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = outvert2x + basepointy = outvert2y + basepointz = outvert2z + rightpointx = int2ABCx + rightpointy = int2ABCy + rightpointz = int2ABCz + leftpointx = encpoint2x + leftpointy = encpoint2y + leftpointz = encpoint2z + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = outvert2x + basepointy = outvert2y + basepointz = outvert2z + rightpointx = encpoint2x + rightpointy = encpoint2y + rightpointz = encpoint2z + leftpointx = encpoint1x + leftpointy = encpoint1y + leftpointz = encpoint1z + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = outvert1x + basepointy = outvert1y + basepointz = outvert1z + rightpointx = outvert2x + rightpointy = outvert2y + rightpointz = outvert2z + leftpointx = encpoint1x + leftpointy = encpoint1y + leftpointz = encpoint1z + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Fourth new triangle. + basepointx = outvert1x + basepointy = outvert1y + basepointz = outvert1z + rightpointx = encpoint1x + rightpointy = encpoint1y + rightpointz = encpoint1z + leftpointx = int1ABCx + leftpointy = int1ABCy + leftpointz = int1ABCz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 0 1 4" '*' 13 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 1) + int3ABCy = tripletencpoint(1, 2) + int3ABCz = tripletencpoint(1, 3) + int3DEFx = tripletencpoint(1, 4) + int3DEFy = tripletencpoint(1, 5) + int3DEFz = tripletencpoint(1, 6) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip014enabled = 1 THEN + 'LOCATE 13, 1: PRINT signaturefull$ + flagimagechange = 1 + ' Identify the two triangles. + leftedgefound = 0 + FOR f = 1 TO 4 + IF SQR((tripletintpointpair(f, 7) - int3ABCx) ^ 2 + (tripletintpointpair(f, 8) - int3ABCy) ^ 2 + (tripletintpointpair(f, 9) - int3ABCz) ^ 2) > 0.1 THEN + possibleoutpoint1x = tripletintpointpair(f, 10) + possibleoutpoint1y = tripletintpointpair(f, 11) + possibleoutpoint1z = tripletintpointpair(f, 12) + possibleoutpoint2x = tripletintpointpair(f, 13) + possibleoutpoint2y = tripletintpointpair(f, 14) + possibleoutpoint2z = tripletintpointpair(f, 15) + intpointfwdx = tripletintpointpair(f, 1) + intpointfwdy = tripletintpointpair(f, 2) + intpointfwdz = tripletintpointpair(f, 3) + IF leftedgefound = 0 THEN + IF SQR((possibleoutpoint1x - int3ABCx) ^ 2 + (possibleoutpoint1y - int3ABCy) ^ 2 + (possibleoutpoint1z - int3ABCz) ^ 2) < 0.0001 THEN + outerpointleftx = possibleoutpoint2x + outerpointlefty = possibleoutpoint2y + outerpointleftz = possibleoutpoint2z + intpointfwdleftx = intpointfwdx + intpointfwdlefty = intpointfwdy + intpointfwdleftz = intpointfwdz + ELSE + outerpointleftx = possibleoutpoint1x + outerpointlefty = possibleoutpoint1y + outerpointleftz = possibleoutpoint1z + intpointfwdleftx = intpointfwdx + intpointfwdlefty = intpointfwdy + intpointfwdleftz = intpointfwdz + END IF + disttointpointmin = 10 ^ 5 + FOR m = 1 TO 4 + IF m <> W THEN + IF SQR((tripletintpointpair(m, 7) - int3ABCx) ^ 2 + (tripletintpointpair(m, 8) - int3ABCy) ^ 2 + (tripletintpointpair(m, 9) - int3ABCz) ^ 2) < 0.0001 THEN + disttointpoint = SQR((outerpointleftx - tripletintpointpair(m, 1)) ^ 2 + (outerpointlefty - tripletintpointpair(m, 2)) ^ 2 + (outerpointleftz - tripletintpointpair(m, 3)) ^ 2) + IF disttointpoint < disttointpointmin THEN + intpointbackleftx = tripletintpointpair(m, 1) + intpointbacklefty = tripletintpointpair(m, 2) + intpointbackleftz = tripletintpointpair(m, 3) + disttointpointmin = disttointpoint + END IF + + END IF + END IF + NEXT + leftedgefound = 1 + ELSE + IF SQR((possibleoutpoint1x - int3ABCx) ^ 2 + (possibleoutpoint1y - int3ABCy) ^ 2 + (possibleoutpoint1z - int3ABCz) ^ 2) < 0.0001 THEN + outerpointrightx = possibleoutpoint2x + outerpointrighty = possibleoutpoint2y + outerpointrightz = possibleoutpoint2z + intpointfwdrightx = intpointfwdx + intpointfwdrighty = intpointfwdy + intpointfwdrightz = intpointfwdz + ELSE + outerpointrightx = possibleoutpoint1x + outerpointrighty = possibleoutpoint1y + outerpointrightz = possibleoutpoint1z + intpointfwdrightx = intpointfwdx + intpointfwdrighty = intpointfwdy + intpointfwdrightz = intpointfwdz + END IF + disttointpointmin = 10 ^ 5 + FOR m = 1 TO 4 + IF m <> W THEN + IF SQR((tripletintpointpair(m, 7) - int3ABCx) ^ 2 + (tripletintpointpair(m, 8) - int3ABCy) ^ 2 + (tripletintpointpair(m, 9) - int3ABCz) ^ 2) < 0.0001 THEN + disttointpoint = SQR((outerpointrightx - tripletintpointpair(m, 1)) ^ 2 + (outerpointrighty - tripletintpointpair(m, 2)) ^ 2 + (outerpointrightz - tripletintpointpair(m, 3)) ^ 2) + IF disttointpoint < disttointpointmin THEN + intpointbackrightx = tripletintpointpair(m, 1) + intpointbackrighty = tripletintpointpair(m, 2) + intpointbackrightz = tripletintpointpair(m, 3) + disttointpointmin = disttointpoint + END IF + END IF + END IF + NEXT + END IF + END IF + NEXT + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = outerpointrightx + basepointy = outerpointrighty + basepointz = outerpointrightz + rightpointx = intpointfwdrightx + rightpointy = intpointfwdrighty + rightpointz = intpointfwdrightz + leftpointx = intpointbackrightx + leftpointy = intpointbackrighty + leftpointz = intpointbackrightz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = outerpointleftx + basepointy = outerpointlefty + basepointz = outerpointleftz + rightpointx = intpointbackleftx + rightpointy = intpointbacklefty + rightpointz = intpointbackleftz + leftpointx = intpointfwdleftx + leftpointy = intpointfwdlefty + leftpointz = intpointfwdleftz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 1 0 4" '*' 14 of 15 + int3ABCx = tripletintpointpair(3, 1) + int3ABCy = tripletintpointpair(3, 2) + int3ABCz = tripletintpointpair(3, 3) + int3DEFx = tripletintpointpair(3, 4) + int3DEFy = tripletintpointpair(3, 5) + int3DEFz = tripletintpointpair(3, 6) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip104enabled = 1 THEN + 'LOCATE 14, 1: PRINT signaturefull$ + flagimagechange = 1 + ''intpointbackleftused = 0 + ''FOR m = 1 TO 4 + '' IF SQR((tripletintpointpair(m, 16) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 17) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 18) - tripletencpoint(1, 3)) ^ 2) > 0.1 AND SQR((tripletintpointpair(m, 19) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 20) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 21) - tripletencpoint(1, 3)) ^ 2) > 0.1 THEN + '' IF intpointbackleftused = 0 THEN + '' intpointbackleftx = tripletintpointpair(m, 1) + '' intpointbacklefty = tripletintpointpair(m, 2) + '' intpointbackleftz = tripletintpointpair(m, 3) + '' backleftindex = m + '' intpointbackleftused = 1 + '' ELSE + '' intpointbackrightx = tripletintpointpair(m, 1) + '' intpointbackrighty = tripletintpointpair(m, 2) + '' intpointbackrightz = tripletintpointpair(m, 3) + '' backrightindex = m + '' END IF + '' END IF + ''NEXT + ''cand1x = tripletintpointpair(backleftindex, 10) + ''cand1y = tripletintpointpair(backleftindex, 11) + ''cand1z = tripletintpointpair(backleftindex, 12) + ''cand2x = tripletintpointpair(backleftindex, 13) + ''cand2y = tripletintpointpair(backleftindex, 14) + ''cand2z = tripletintpointpair(backleftindex, 15) + ''cand3x = tripletintpointpair(backrightindex, 10) + ''cand3y = tripletintpointpair(backrightindex, 11) + ''cand3z = tripletintpointpair(backrightindex, 12) + ''cand4x = tripletintpointpair(backrightindex, 13) + ''cand4y = tripletintpointpair(backrightindex, 14) + ''cand4z = tripletintpointpair(backrightindex, 15) + ''diff13 = SQR((cand1x - cand3x) ^ 2 + (cand1y - cand3y) ^ 2 + (cand1z - cand3z) ^ 2) + ''diff14 = SQR((cand1x - cand4x) ^ 2 + (cand1y - cand4y) ^ 2 + (cand1z - cand4z) ^ 2) + ''diff23 = SQR((cand2x - cand3x) ^ 2 + (cand2y - cand3y) ^ 2 + (cand2z - cand3z) ^ 2) + ''diff24 = SQR((cand2x - cand4x) ^ 2 + (cand2y - cand4y) ^ 2 + (cand2z - cand4z) ^ 2) + ''IF diff13 < 0.0001 THEN + '' pointbackoutx = cand1x + '' pointbackouty = cand1y + '' pointbackoutz = cand1z + '' pointfwdoutleftx = cand2x + '' pointfwdoutlefty = cand2y + '' pointfwdoutleftz = cand2z + '' pointfwdoutrightx = cand4x + '' pointfwdoutrighty = cand4y + '' pointfwdoutrightz = cand4z + ''END IF + ''IF diff14 < 0.0001 THEN + '' pointbackoutx = cand1x + '' pointbackouty = cand1y + '' pointbackoutz = cand1z + '' pointfwdoutleftx = cand2x + '' pointfwdoutlefty = cand2y + '' pointfwdoutleftz = cand2z + '' pointfwdoutrightx = cand3x + '' pointfwdoutrighty = cand3y + '' pointfwdoutrightz = cand3z + ''END IF + ''IF diff23 < 0.0001 THEN + '' pointbackoutx = cand2x + '' pointbackouty = cand2y + '' pointbackoutz = cand2z + '' pointfwdoutleftx = cand1x + '' pointfwdoutlefty = cand1y + '' pointfwdoutleftz = cand1z + '' pointfwdoutrightx = cand4x + '' pointfwdoutrighty = cand4y + '' pointfwdoutrightz = cand4z + ''END IF + ''IF diff24 < 0.0001 THEN + '' pointbackoutx = cand2x + '' pointbackouty = cand2y + '' pointbackoutz = cand2z + '' pointfwdoutleftx = cand1x + '' pointfwdoutlefty = cand1y + '' pointfwdoutleftz = cand1z + '' pointfwdoutrightx = cand3x + '' pointfwdoutrighty = cand3y + '' pointfwdoutrightz = cand3z + ''END IF + ''FOR m = 1 TO 4 + '' IF SQR((tripletintpointpair(m, 16) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 17) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 18) - tripletencpoint(1, 3)) ^ 2) < 0.0001 OR SQR((tripletintpointpair(m, 19) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 20) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 21) - tripletencpoint(1, 3)) ^ 2) < 0.0001 THEN + '' IF SQR((tripletintpointpair(m, 7) - tripletintpointpair(backleftindex, 7)) ^ 2 + (tripletintpointpair(m, 8) - tripletintpointpair(backleftindex, 8)) ^ 2 + (tripletintpointpair(m, 9) - tripletintpointpair(backleftindex, 9)) ^ 2) < 0.0001 THEN + '' intpointfwdleftx = tripletintpointpair(m, 1) + '' intpointfwdlefty = tripletintpointpair(m, 2) + '' intpointfwdleftz = tripletintpointpair(m, 3) + '' END IF + '' IF SQR((tripletintpointpair(m, 7) - tripletintpointpair(backrightindex, 7)) ^ 2 + (tripletintpointpair(m, 8) - tripletintpointpair(backrightindex, 8)) ^ 2 + (tripletintpointpair(m, 9) - tripletintpointpair(backrightindex, 9)) ^ 2) < 0.0001 THEN + '' intpointfwdrightx = tripletintpointpair(m, 1) + '' intpointfwdrighty = tripletintpointpair(m, 2) + '' intpointfwdrightz = tripletintpointpair(m, 3) + '' END IF + '' END IF + ''NEXT + ''flagindexkused = 0 + ''' First new triangle overwrites old one. + ''basepointx = pointbackoutx + ''basepointy = pointbackouty + ''basepointz = pointbackoutz + ''rightpointx = intpointbackrightx + ''rightpointy = intpointbackrighty + ''rightpointz = intpointbackrightz + ''leftpointx = intpointbackleftx + ''leftpointy = intpointbacklefty + ''leftpointz = intpointbackleftz + ''GOSUB compute.triangle.areas.cents + ''GOSUB create.image.triangle + ''' Second new triangle. + ''basepointx = intpointfwdleftx + ''basepointy = intpointfwdlefty + ''basepointz = intpointfwdleftz + ''rightpointx = tripletencpoint(1, 4) + ''rightpointy = tripletencpoint(1, 5) + ''rightpointz = tripletencpoint(1, 6) + ''leftpointx = pointfwdoutleftx + ''leftpointy = pointfwdoutlefty + ''leftpointz = pointfwdoutleftz + ''GOSUB compute.triangle.areas.cents + ''GOSUB create.image.triangle + ''' Third new triangle. + ''basepointx = tripletencpoint(1, 4) + ''basepointy = tripletencpoint(1, 5) + ''basepointz = tripletencpoint(1, 6) + ''rightpointx = pointfwdoutrightx + ''rightpointy = pointfwdoutrighty + ''rightpointz = pointfwdoutrightz + ''leftpointx = pointfwdoutleftx + ''leftpointy = pointfwdoutlefty + ''leftpointz = pointfwdoutleftz + ''GOSUB compute.triangle.areas.cents + ''GOSUB create.image.triangle + ''' Fourth new triangle. + ''basepointx = tripletencpoint(1, 4) + ''basepointy = tripletencpoint(1, 5) + ''basepointz = tripletencpoint(1, 6) + ''rightpointx = intpointfwdrightx + ''rightpointy = intpointfwdrighty + ''rightpointz = intpointfwdrightz + ''leftpointx = pointfwdoutrightx + ''leftpointy = pointfwdoutrighty + ''leftpointz = pointfwdoutrightz + ''GOSUB compute.triangle.areas.cents + ''GOSUB create.image.triangle + centsharedx = (1 / 3) * (int1ABCx + int2ABCx + int3ABCx) + centsharedy = (1 / 3) * (int1ABCy + int2ABCy + int3ABCy) + centsharedz = (1 / 3) * (int1ABCz + int2ABCz + int3ABCz) + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = centsharedx + basepointy = centsharedy + basepointz = centsharedz + rightpointx = Ax + rightpointy = Ay + rightpointz = Az + leftpointx = Bx + leftpointy = By + leftpointz = Bz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = centsharedx + basepointy = centsharedy + basepointz = centsharedz + rightpointx = Bx + rightpointy = By + rightpointz = Bz + leftpointx = Cx + leftpointy = Cy + leftpointz = Cz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = centsharedx + basepointy = centsharedy + basepointz = centsharedz + rightpointx = Cx + rightpointy = Cy + rightpointz = Cz + leftpointx = Ax + leftpointy = Ay + leftpointz = Az + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE " 1 1 4" '*' 15 of 15 + ' Load information on overlap triangle. + int3ABCx = tripletencpoint(1, 1) + int3ABCy = tripletencpoint(1, 2) + int3ABCz = tripletencpoint(1, 3) + int3DEFx = tripletencpoint(1, 4) + int3DEFy = tripletencpoint(1, 5) + int3DEFz = tripletencpoint(1, 6) + int1ABCx = tripletintpointpair(1, 1) + int1ABCy = tripletintpointpair(1, 2) + int1ABCz = tripletintpointpair(1, 3) + int1DEFx = tripletintpointpair(1, 4) + int1DEFy = tripletintpointpair(1, 5) + int1DEFz = tripletintpointpair(1, 6) + int2ABCx = tripletintpointpair(2, 1) + int2ABCy = tripletintpointpair(2, 2) + int2ABCz = tripletintpointpair(2, 3) + int2DEFx = tripletintpointpair(2, 4) + int2DEFy = tripletintpointpair(2, 5) + int2DEFz = tripletintpointpair(2, 6) + GOSUB perform.overlap.calculations + ' Compare the apparent overlap tringles using centroid. + IF magcentABC > magcentDEF AND magdiff > 0 AND areaABC > 0.005 AND areaDEF > 0.005 AND snip114enabled = 1 THEN + 'LOCATE 15, 1: PRINT signaturefull$ + flagimagechange = 1 + ' Identify the left int points. + FOR m = 1 TO 4 + IF SQR((tripletintpointpair(m, 7) - tripletencpoint(2, 1)) ^ 2 + (tripletintpointpair(m, 8) - tripletencpoint(2, 2)) ^ 2 + (tripletintpointpair(m, 9) - tripletencpoint(2, 3)) ^ 2) > 0.1 THEN + IF SQR((tripletintpointpair(m, 16) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 17) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 18) - tripletencpoint(1, 3)) ^ 2) < 0.0001 OR SQR((tripletintpointpair(m, 19) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 20) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 21) - tripletencpoint(1, 3)) ^ 2) < 0.0001 THEN + intpointfwdleftx = tripletintpointpair(m, 1) + intpointfwdlefty = tripletintpointpair(m, 2) + intpointfwdleftz = tripletintpointpair(m, 3) + IF SQR((tripletintpointpair(m, 10) - tripletencpoint(2, 1)) ^ 2 + (tripletintpointpair(m, 11) - tripletencpoint(2, 2)) ^ 2 + (tripletintpointpair(m, 12) - tripletencpoint(2, 3)) ^ 2) < 0.0001 THEN + intpointfwdoutx = tripletintpointpair(m, 13) + intpointfwdouty = tripletintpointpair(m, 14) + intpointfwdoutz = tripletintpointpair(m, 15) + ELSE + intpointfwdoutx = tripletintpointpair(m, 10) + intpointfwdouty = tripletintpointpair(m, 11) + intpointfwdoutz = tripletintpointpair(m, 12) + END IF + ELSE + intpointbackleftx = tripletintpointpair(m, 1) + intpointbacklefty = tripletintpointpair(m, 2) + intpointbackleftz = tripletintpointpair(m, 3) + IF SQR((tripletintpointpair(m, 10) - tripletencpoint(2, 1)) ^ 2 + (tripletintpointpair(m, 11) - tripletencpoint(2, 2)) ^ 2 + (tripletintpointpair(m, 12) - tripletencpoint(2, 3)) ^ 2) < 0.0001 THEN + intpointbackoutx = tripletintpointpair(m, 13) + intpointbackouty = tripletintpointpair(m, 14) + intpointbackoutz = tripletintpointpair(m, 15) + ELSE + intpointbackoutx = tripletintpointpair(m, 10) + intpointbackouty = tripletintpointpair(m, 11) + intpointbackoutz = tripletintpointpair(m, 12) + END IF + END IF + ELSE + IF SQR((tripletintpointpair(m, 16) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 17) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 18) - tripletencpoint(1, 3)) ^ 2) < 0.0001 OR SQR((tripletintpointpair(m, 19) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 20) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 21) - tripletencpoint(1, 3)) ^ 2) < 0.0001 THEN + intpointfwdrightx = tripletintpointpair(m, 1) + intpointfwdrighty = tripletintpointpair(m, 2) + intpointfwdrightz = tripletintpointpair(m, 3) + END IF + IF SQR((tripletintpointpair(m, 16) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 17) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 18) - tripletencpoint(1, 3)) ^ 2) > 0.1 AND SQR((tripletintpointpair(m, 19) - tripletencpoint(1, 1)) ^ 2 + (tripletintpointpair(m, 20) - tripletencpoint(1, 2)) ^ 2 + (tripletintpointpair(m, 21) - tripletencpoint(1, 3)) ^ 2) > 0.1 THEN + intpointbackrightx = tripletintpointpair(m, 1) + intpointbackrighty = tripletintpointpair(m, 2) + intpointbackrightz = tripletintpointpair(m, 3) + END IF + END IF + NEXT + flagindexkused = 0 + ' First new triangle overwrites old one. + basepointx = tripletencpoint(1, 4) + basepointy = tripletencpoint(1, 5) + basepointz = tripletencpoint(1, 6) + rightpointx = intpointfwdoutx + rightpointy = intpointfwdouty + rightpointz = intpointfwdoutz + leftpointx = intpointfwdleftx + leftpointy = intpointfwdlefty + leftpointz = intpointfwdleftz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Second new triangle. + basepointx = intpointfwdrightx + basepointy = intpointfwdrighty + basepointz = intpointfwdrightz + rightpointx = intpointfwdoutx + rightpointy = intpointfwdouty + rightpointz = intpointfwdoutz + leftpointx = tripletencpoint(1, 4) + leftpointy = tripletencpoint(1, 5) + leftpointz = tripletencpoint(1, 6) + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + ' Third new triangle. + basepointx = intpointbackoutx + basepointy = intpointbackouty + basepointz = intpointbackoutz + rightpointx = intpointbackrightx + rightpointy = intpointbackrighty + rightpointz = intpointbackrightz + leftpointx = intpointbackleftx + leftpointy = intpointbacklefty + leftpointz = intpointbackleftz + GOSUB compute.triangle.areas.cents + GOSUB create.image.triangle + END IF + IF flagimagechange = 1 THEN + IF flagindexkused = 1 THEN + GOTO begintripletsnipsubloop + ELSE + GOSUB triplet.image.repack + END IF + END IF + + CASE ELSE + ' Code for troubleshooting. + 'LOCATE 16, 1: PRINT "else" + 'rdy = INT(RND * 9) + 'IF i = 1 AND j = 3 THEN COLOR 4 + 'LOCATE 17 + rdy, 1: PRINT signaturefull$ + 'COLOR 15 +END SELECT +RETURN + +compute.triangle.areas.cents: +rightarmx = rightpointx - basepointx +rightarmy = rightpointy - basepointy +rightarmz = rightpointz - basepointz +leftarmx = leftpointx - basepointx +leftarmy = leftpointy - basepointy +leftarmz = leftpointz - basepointz +trianglearea3Dvecx = rightarmy * leftarmz - rightarmz * leftarmy +trianglearea3Dvecy = rightarmz * leftarmx - rightarmx * leftarmz +trianglearea3Dvecz = rightarmx * leftarmy - rightarmy * leftarmx +trianglearea3D = (1 / 2) * (SQR(trianglearea3Dvecx ^ 2 + trianglearea3Dvecy ^ 2 + trianglearea3Dvecz ^ 2)) +trianglecent3Dx = (1 / 3) * (basepointx + rightpointx + leftpointx) +trianglecent3Dy = (1 / 3) * (basepointy + rightpointy + leftpointy) +trianglecent3Dz = (1 / 3) * (basepointz + rightpointz + leftpointz) +trianglecent3Dmag = SQR(trianglecent3Dx ^ 2 + trianglecent3Dy ^ 2 + trianglecent3Dz ^ 2) +baseu = basepointx * uhat(1) + basepointy * uhat(2) + basepointz * uhat(3) +basev = basepointx * vhat(1) + basepointy * vhat(2) + basepointz * vhat(3) +rightu = rightpointx * uhat(1) + rightpointy * uhat(2) + rightpointz * uhat(3) +rightv = rightpointx * vhat(1) + rightpointy * vhat(2) + rightpointz * vhat(3) +leftu = leftpointx * uhat(1) + leftpointy * uhat(2) + leftpointz * uhat(3) +leftv = leftpointx * vhat(1) + leftpointy * vhat(2) + leftpointz * vhat(3) +basen = (basepointx * nhat(1) + basepointy * nhat(2) + basepointz * nhat(3)) +rightn = (rightpointx * nhat(1) + rightpointy * nhat(2) + rightpointz * nhat(3)) +leftn = (leftpointx * nhat(1) + leftpointy * nhat(2) + leftpointz * nhat(3)) +basesu = baseu * fovd / basen +basesv = basev * fovd / basen +rightsu = rightu * fovd / rightn +rightsv = rightv * fovd / rightn +leftsu = leftu * fovd / leftn +leftsv = leftv * fovd / leftn +rightarmsu = rightsu - basesu +rightarmsv = rightsv - basesv +leftarmsu = leftsu - basesu +leftarmsv = leftsv - basesv +trianglearea2Dsvecncomp = rightarmsu * leftarmsv - rightarmsv * leftarmsu +trianglearea2Ds = (1 / 2) * (SQR(trianglearea2Dsvecncomp ^ 2)) +trianglecent2Dsu = (1 / 3) * (basesu + rightsu + leftsu) +trianglecent2Dsv = (1 / 3) * (basesv + rightsv + leftsv) +trianglecent2Dmag = SQR(trianglecent2Dsu ^ 2 + trianglecent2Dsv ^ 2) +RETURN + +perform.overlap.calculations: +basepointx = int3ABCx +basepointy = int3ABCy +basepointz = int3ABCz +rightpointx = int1ABCx +rightpointy = int1ABCy +rightpointz = int1ABCz +leftpointx = int2ABCx +leftpointy = int2ABCy +leftpointz = int2ABCz +GOSUB compute.triangle.areas.cents +areaABC = trianglearea3D +magcentABC = trianglecent3Dmag +basepointx = int3DEFx +basepointy = int3DEFy +basepointz = int3DEFz +rightpointx = int1DEFx +rightpointy = int1DEFy +rightpointz = int1DEFz +leftpointx = int2DEFx +leftpointy = int2DEFy +leftpointz = int2DEFz +GOSUB compute.triangle.areas.cents +areaDEF = trianglearea3D +magcentDEF = trianglecent3Dmag +magdiff = SQR((magcentABC - magcentDEF) ^ 2) +RETURN + +create.image.triangle: +IF trianglearea3D > 0 AND trianglearea2Ds > 0 THEN + IF flagindexkused = 0 THEN + imageindex = k + flagindexkused = 1 + ELSE + pcounttripletsnipimage = pcounttripletsnipimage + 1 + imageindex = pcounttripletsnipimage + END IF + ' Code for troubleshooting. + 'shrinkfactor = .90 + 'centimagex = (1 / 3) * (basepointx + rightpointx + leftpointx) + 'centimagey = (1 / 3) * (basepointy + rightpointy + leftpointy) + 'centimagez = (1 / 3) * (basepointz + rightpointz + leftpointz) + 'basepointx = centimagex + (shrinkfactor) * (basepointx - centimagex) + 'basepointy = centimagey + (shrinkfactor) * (basepointy - centimagey) + 'basepointz = centimagez + (shrinkfactor) * (basepointz - centimagez) + 'rightpointx = centimagex + (shrinkfactor) * (rightpointx - centimagex) + 'rightpointy = centimagey + (shrinkfactor) * (rightpointy - centimagey) + 'rightpointz = centimagez + (shrinkfactor) * (rightpointz - centimagez) + 'leftpointx = centimagex + (shrinkfactor) * (leftpointx - centimagex) + 'leftpointy = centimagey + (shrinkfactor) * (leftpointy - centimagey) + 'leftpointz = centimagez + (shrinkfactor) * (leftpointz - centimagez) + tripletsnipimage(imageindex, 1) = basepointx + tripletsnipimage(imageindex, 2) = basepointy + tripletsnipimage(imageindex, 3) = basepointz + tripletsnipimage(imageindex, 4) = rightpointx + tripletsnipimage(imageindex, 5) = rightpointy + tripletsnipimage(imageindex, 6) = rightpointz + tripletsnipimage(imageindex, 7) = leftpointx + tripletsnipimage(imageindex, 8) = leftpointy + tripletsnipimage(imageindex, 9) = leftpointz + tripletsnipimage(imageindex, 10) = tripletsnip(i, 10) +END IF +RETURN + +copy.triplets.snip.final: +FOR i = 1 TO numtripletsnip + tripletfinal(i, 1) = tripletsnip(i, 1) + tripletfinal(i, 2) = tripletsnip(i, 2) + tripletfinal(i, 3) = tripletsnip(i, 3) + tripletfinal(i, 4) = tripletsnip(i, 4) + tripletfinal(i, 5) = tripletsnip(i, 5) + tripletfinal(i, 6) = tripletsnip(i, 6) + tripletfinal(i, 7) = tripletsnip(i, 7) + tripletfinal(i, 8) = tripletsnip(i, 8) + tripletfinal(i, 9) = tripletsnip(i, 9) + tripletfinal(i, 10) = tripletsnip(i, 10) +NEXT +numtripletfinal = numtripletsnip +RETURN + +triplet.image.repack: +pcountimagerepack = 0 +FOR m = 1 TO pcounttripletsnipimage + IF m <> k THEN + pcountimagerepack = pcountimagerepack + 1 + tripletsnipimage(pcountimagerepack, 1) = tripletsnipimage(m, 1) + tripletsnipimage(pcountimagerepack, 2) = tripletsnipimage(m, 2) + tripletsnipimage(pcountimagerepack, 3) = tripletsnipimage(m, 3) + tripletsnipimage(pcountimagerepack, 4) = tripletsnipimage(m, 4) + tripletsnipimage(pcountimagerepack, 5) = tripletsnipimage(m, 5) + tripletsnipimage(pcountimagerepack, 6) = tripletsnipimage(m, 6) + tripletsnipimage(pcountimagerepack, 7) = tripletsnipimage(m, 7) + tripletsnipimage(pcountimagerepack, 8) = tripletsnipimage(m, 8) + tripletsnipimage(pcountimagerepack, 9) = tripletsnipimage(m, 9) + tripletsnipimage(pcountimagerepack, 10) = tripletsnipimage(m, 10) + END IF +NEXT +pcounttripletsnipimage = pcountimagerepack +RETURN + +' *** Define functions for plot modes. *** + +plotmode.linearconnect: +' Erase old graphics. +FOR i = 1 TO numparticlevisible - 1 + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs.old(i + 1, 1): y = zoom * vecvisiblepuvs.old(i + 1, 2): GOSUB convert: x2 = x: y2 = y + LINE (x1, y1)-(x2, y2), 0 +NEXT +' Draw new graphics. +FOR i = 1 TO numparticlevisible - 1 + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs(i + 1, 1): y = zoom * vecvisiblepuvs(i + 1, 2): GOSUB convert: x2 = x: y2 = y + IF vecvisibledotnhat(i) > 0 THEN + LINE (x1, y1)-(x2, y2), vecvisible(i, 4) + ELSE + LINE (x1, y1)-(x2, y2), 8 + END IF +NEXT +RETURN + +plotmode.simplepoints: +' Erase old graphics. +FOR i = 1 TO numparticlevisible + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert + IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN + PSET (x, y), 0 + END IF +NEXT +' Draw new graphics. +FOR i = 1 TO numparticlevisible + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert + IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN + PSET (x, y), vecvisible(i, 4) + END IF +NEXT + +plotmode.3denvparticles: +CLS +FOR i = 1 TO numparticlevisible + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert + PSET (x, y), vecvisible(i, 4) +NEXT +RETURN + +plotmode.molecule: +'FOR i = numparticlevisible TO 1 STEP -1 +FOR i = 1 TO numparticlevisible + FOR j = 6 TO 10 + IF vecvisible(i, j) = 0 THEN + EXIT FOR + ELSE + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs.old((vecvisible(i, j)), 1): y = zoom * vecvisiblepuvs.old((vecvisible(i, j)), 2): GOSUB convert: x2 = x: y2 = y + LINE (x1, y1)-(x2, y2), 0 + END IF + NEXT + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2) + GOSUB convert + IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN + CIRCLE (x, y), INT(3 + 4 * vecvisible(i, 4) / biggestatom), 0 + IF toggleatomnumbers = 1 THEN + COLOR 0 + LOCATE ytext, xtext: PRINT vecvisible(i, 5) + END IF + END IF + FOR j = 6 TO 10 + IF vecvisible(i, j) = 0 THEN + EXIT FOR + ELSE + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs((vecvisible(i, j)), 1): y = zoom * vecvisiblepuvs((vecvisible(i, j)), 2): GOSUB convert: x2 = x: y2 = y + LINE (x1, y1)-(x2, y2), vecvisible(i, 4) + END IF + NEXT + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2) + GOSUB convert + IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN + CIRCLE (x, y), INT(3 + 4 * vecvisible(i, 4) / biggestatom), vecvisible(i, 4) + IF toggleatomnumbers = 1 THEN + COLOR vecvisible(i, 4) + LOCATE ytext, xtext: PRINT vecvisible(i, 5) + END IF + END IF +NEXT +RETURN + +plotmode.neighbortile: +tilemin = 1: tilemax = 3 +FOR i = 1 TO numparticlevisible - 1 + FOR j = (i + 1) TO numparticlevisible + vecvisiblesep = SQR((vecvisible(j, 1) - vecvisible(i, 1)) ^ 2 + (vecvisible(j, 2) - vecvisible(i, 2)) ^ 2 + (vecvisible(j, 3) - vecvisible(i, 3)) ^ 2) + IF vecvisiblesep > tilemin AND vecvisiblesep < tilemax THEN + ' Erase old graphics. + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs.old(j, 1): y = zoom * vecvisiblepuvs.old(j, 2): GOSUB convert: x2 = x: y2 = y + LINE (x1, y1)-(x2, y2), 0 + ' Draw new graphics. + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs(j, 1): y = zoom * vecvisiblepuvs(j, 2): GOSUB convert: x2 = x: y2 = y + IF vecvisibledotnhat(j) < 0 THEN + LINE (x1, y1)-(x2, y2), 8 + ELSE + LINE (x1, y1)-(x2, y2), vecvisible(j, 4) + END IF + END IF + NEXT +NEXT +RETURN + +plotmode.3denvdoublets: +FOR i = 1 TO numdoubletsnip.old + ' Erase old graphics. + x = zoom * doubletsnippuvs.old(i, 1): y = zoom * doubletsnippuvs.old(i, 2): GOSUB convert + u1 = x: v1 = y + CIRCLE (u1, v1), 5, 0 + x = zoom * doubletsnippuvs.old(i, 3): y = zoom * doubletsnippuvs.old(i, 4): GOSUB convert + u2 = x: v2 = y + CIRCLE (u2, v2), 3, 0 + LINE (u1, v1)-(u2, v2), 0 +NEXT +FOR i = 1 TO numdoubletsnip + ' Draw new graphics. + x = zoom * doubletsnippuvs(i, 1): y = zoom * doubletsnippuvs(i, 2): GOSUB convert + u1 = x: v1 = y + CIRCLE (u1, v1), 5, doubletsnip(i, 7) + x = zoom * doubletsnippuvs(i, 3): y = zoom * doubletsnippuvs(i, 4): GOSUB convert + u2 = x: v2 = y + CIRCLE (u2, v2), 3, doubletsnip(i, 7) + LINE (u1, v1)-(u2, v2), doubletsnip(i, 7) +NEXT +RETURN + +plotmode.3denvtriplets: +'FOR i = 1 TO numtripletfinal.old +' ' Erase old graphics. +' x = zoom * tripletfinalpuvs.old(i, 1): y = zoom * tripletfinalpuvs.old(i, 2): GOSUB convert +' u1 = x: v1 = y +' 'CIRCLE (u1, v1), 5, 0 +' x = zoom * tripletfinalpuvs.old(i, 3): y = zoom * tripletfinalpuvs.old(i, 4): GOSUB convert +' u2 = x: v2 = y +' 'CIRCLE (u2, v2), 4, 0 +' x = zoom * tripletfinalpuvs.old(i, 5): y = zoom * tripletfinalpuvs.old(i, 6): GOSUB convert +' u3 = x: v3 = y +' 'CIRCLE (u3, v3), 3, 0 +' centu = (1 / 3) * (u1 + u2 + u3) +' centv = (1 / 3) * (v1 + v2 + v3) +' LINE (u1, v1)-(u2, v2), 0 +' LINE (u2, v2)-(u3, v3), 0 +' LINE (u3, v3)-(u1, v1), 0 +' 'PAINT (centu, centv), 0, 0 +'NEXT +CLS +FOR i = 1 TO numtripletfinal + ' Draw new graphics. + x = zoom * tripletfinalpuvs(i, 1): y = zoom * tripletfinalpuvs(i, 2): GOSUB convert + u1 = x: v1 = y + 'CIRCLE (u1, v1), 5, tripletfinal(i, 10) + x = zoom * tripletfinalpuvs(i, 3): y = zoom * tripletfinalpuvs(i, 4): GOSUB convert + u2 = x: v2 = y + 'CIRCLE (u2, v2), 4, tripletfinal(i, 10) + x = zoom * tripletfinalpuvs(i, 5): y = zoom * tripletfinalpuvs(i, 6): GOSUB convert + u3 = x: v3 = y + 'CIRCLE (u3, v3), 3, tripletfinal(i, 10) + LINE (u1, v1)-(u2, v2), tripletfinal(i, 10) + LINE (u2, v2)-(u3, v3), tripletfinal(i, 10) + LINE (u3, v3)-(u1, v1), tripletfinal(i, 10) + centu = (1 / 3) * (u1 + u2 + u3) + centv = (1 / 3) * (v1 + v2 + v3) + 'PAINT (centu, centv), tripletfinal(i, 10), tripletfinal(i, 10) +NEXT +RETURN + +plotmode.simplemesh: +FOR i = 1 TO numparticlevisible - 1 + IF i MOD yrange <> 0 THEN 'point obeys normal neighbor-connect scheme + ' Erase old graphics. + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs.old(i + 1, 1): y = zoom * vecvisiblepuvs.old(i + 1, 2): GOSUB convert: x2 = x: y2 = y + x = zoom * vecvisiblepuvs.old(i + yrange, 1): y = zoom * vecvisiblepuvs.old(i + yrange, 2): GOSUB convert: x3 = x: y3 = y + LINE (x1, y1)-(x2, y2), 0 + IF i < (numparticlevisible - yrange) THEN LINE (x1, y1)-(x3, y3), 0 + ' Draw new graphics. + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs(i + 1, 1): y = zoom * vecvisiblepuvs(i + 1, 2): GOSUB convert: x2 = x: y2 = y + x = zoom * vecvisiblepuvs(i + yrange, 1): y = zoom * vecvisiblepuvs(i + yrange, 2): GOSUB convert: x3 = x: y3 = y + LINE (x1, y1)-(x2, y2), vecvisible(i, 4) + IF i < (numparticlevisible - yrange) THEN LINE (x1, y1)-(x3, y3), vecvisible(i, 4) + ELSE 'point does not obey normal neighbor-connect scheme + ' Erase old graphics. + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs.old(i + yrange, 1): y = zoom * vecvisiblepuvs.old(i + yrange, 2): GOSUB convert: x3 = x: y3 = y + IF i < (numparticlevisible - yrange + 1) THEN LINE (x1, y1)-(x3, y3), 0 + ' Draw new graphics. + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs(i + yrange, 1): y = zoom * vecvisiblepuvs(i + yrange, 2): GOSUB convert: x3 = x: y3 = y + IF i < (numparticlevisible - yrange + 1) THEN LINE (x1, y1)-(x3, y3), vecvisible(i, 4) + END IF +NEXT +RETURN + +plotmode.meshtech2: +FOR i = 1 TO numparticlevisible - yrange + vecvisible1temp1 = vecvisible(i + 1, 1) - vecvisible(i, 1) + vecvisible1temp2 = vecvisible(i + 1, 2) - vecvisible(i, 2) + vecvisible1temp3 = vecvisible(i + 1, 3) - vecvisible(i, 3) + vecvisible2temp1 = vecvisible(i + yrange, 1) - vecvisible(i, 1) + vecvisible2temp2 = vecvisible(i + yrange, 2) - vecvisible(i, 2) + vecvisible2temp3 = vecvisible(i + yrange, 3) - vecvisible(i, 3) + vecvisiblet1 = -vecvisible1temp2 * vecvisible2temp3 + vecvisible1temp3 * vecvisible2temp2 + vecvisiblet2 = -vecvisible1temp3 * vecvisible2temp1 + vecvisible1temp1 * vecvisible2temp3 + vecvisiblet3 = -vecvisible1temp1 * vecvisible2temp2 + vecvisible1temp2 * vecvisible2temp1 + vecvisibletdotnhat = vecvisiblet1 * nhat(1) + vecvisiblet2 * nhat(2) + vecvisiblet3 * nhat(3) + IF vecvisibletdotnhat > 0 THEN plotflag(i) = 1 ELSE plotflag(i) = -1 +NEXT +FOR i = 1 TO numparticlevisible - yrange + IF i MOD yrange <> 0 THEN 'point obeys normal neighbor-connect scheme + ' Erase old graphics. + IF plotflag.old(i) = 1 THEN + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs.old(i + 1, 1): y = zoom * vecvisiblepuvs.old(i + 1, 2): GOSUB convert: x2 = x: y2 = y + x = zoom * vecvisiblepuvs.old(i + yrange, 1): y = zoom * vecvisiblepuvs.old(i + yrange, 2): GOSUB convert: x3 = x: y3 = y + LINE (x1, y1)-(x2, y2), 0 + LINE (x1, y1)-(x3, y3), 0 + END IF + ' Draw new graphics. + IF plotflag(i) = 1 THEN + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs(i + 1, 1): y = zoom * vecvisiblepuvs(i + 1, 2): GOSUB convert: x2 = x: y2 = y + x = zoom * vecvisiblepuvs(i + yrange, 1): y = zoom * vecvisiblepuvs(i + yrange, 2): GOSUB convert: x3 = x: y3 = y + LINE (x1, y1)-(x2, y2), vecvisible(i, 4) + LINE (x1, y1)-(x3, y3), vecvisible(i, 4) + END IF + plotflag.old(i) = plotflag(i) + END IF +NEXT +RETURN + +plotmode.meshtech2planet: +FOR i = 1 TO numparticlevisible - 1 + IF i MOD yrange <> 0 THEN + ' Erase old graphics. + IF vecvisibledotnhatunit.old(i) > 0 THEN + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs.old(i + 1, 1): y = zoom * vecvisiblepuvs.old(i + 1, 2): GOSUB convert: x2 = x: y2 = y + x = zoom * vecvisiblepuvs.old(i + yrange, 1): y = zoom * vecvisiblepuvs.old(i + yrange, 2): GOSUB convert: x3 = x: y3 = y + LINE (x1, y1)-(x2, y2), 0 + IF i < (numparticlevisible - yrange) THEN LINE (x1, y1)-(x3, y3), 0 + END IF + ' Draw new graphics. + IF vecvisibledotnhat(i) > 0 THEN + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs(i + 1, 1): y = zoom * vecvisiblepuvs(i + 1, 2): GOSUB convert: x2 = x: y2 = y + x = zoom * vecvisiblepuvs(i + yrange, 1): y = zoom * vecvisiblepuvs(i + yrange, 2): GOSUB convert: x3 = x: y3 = y + LINE (x1, y1)-(x2, y2), vecvisible(i, 4) + IF i < (numparticlevisible - yrange) THEN LINE (x1, y1)-(x3, y3), vecvisible(i, 4) + END IF + END IF + vecvisibledotnhatunit.old(i) = vecvisibledotnhat(i) +NEXT +RETURN + +plotmode.simplepointsbacteria: +FOR i = numparticlevisible TO 1 STEP -1 + IF vecvisible(i, 4) = 8 THEN + ' Erase old graphics. + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert + IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN + PSET (x, y), 0 + END IF + ' Draw new graphics. + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert + IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN + IF vecvisibledotnhat(i) > 0 THEN + PSET (x, y), vecvisible(i, 4) + ELSE + PSET (x, y), 8 + END IF + END IF + ELSE + ' Erase old graphics. + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert + IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN + CIRCLE (x, y), INT(vecvisible(i, 7) * zoom) + 1, 0 + END IF + ' Draw new graphics. + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert + IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN + CIRCLE (x, y), INT(vecvisible(i, 6) * zoom) + 1, vecvisible(i, 4) + END IF + END IF +NEXT +RETURN + +plotmode.linearneuron: +FOR i = 1 TO numneuralnodes + FOR j = 1 TO numparticlevisible + IF i <> j AND vecvisible(j, 5) = i THEN + ' Erase old graphics. + x = zoom * vecvisiblepuvs.old(i, 1): y = zoom * vecvisiblepuvs.old(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs.old(j, 1): y = zoom * vecvisiblepuvs.old(j, 2): GOSUB convert: x2 = x: y2 = y + IF x1 > 0 AND x1 < 640 AND y1 > 0 AND y1 < 480 AND x2 > 0 AND x2 < 640 AND y2 > 0 AND y2 < 480 THEN + LINE (x1, y1)-(x2, y2), 0 + END IF + ' Draw new graphics. + x = zoom * vecvisiblepuvs(i, 1): y = zoom * vecvisiblepuvs(i, 2): GOSUB convert: x1 = x: y1 = y + x = zoom * vecvisiblepuvs(j, 1): y = zoom * vecvisiblepuvs(j, 2): GOSUB convert: x2 = x: y2 = y + IF x1 > 0 AND x1 < 640 AND y1 > 0 AND y1 < 480 AND x2 > 0 AND x2 < 640 AND y2 > 0 AND y2 < 480 THEN + LINE (x1, y1)-(x2, y2), vecvisible(j, 4) + END IF + END IF + NEXT +NEXT +RETURN + +' *** Define functions for generation schemes. *** + +' ***************************************************************************** +'ALLYLDICHLOROSILANE SGI MOLECULE BEGIN +DATA 0.000000,0.000000,0.000000,6,1,2,0,0,0,0 +DATA 0.000000,0.000000,1.317000,6,2,0,0,0,0,0 +DATA 1.253339,0.000000,2.174135,6,3,2,0,0,0,0 +DATA 1.648740,-1.728751,2.759165,14,4,3,0,0,0,0 +DATA 1.861829,-2.662286,1.657558,1,5,4,0,0,0,0 +DATA 0.909973,0.026847,-0.570958,1,6,1,0,0,0,0 +DATA -0.914351,-0.018888,-0.560617,1,7,1,0,0,0,0 +DATA -0.931482,-0.023791,1.853298,1,8,2,0,0,0,0 +DATA 1.132146,0.660744,3.028965,1,9,3,0,0,0,0 +DATA 2.102271,0.367006,1.600915,1,10,3,0,0,0,0 +DATA 3.353124,-1.699853,3.896830,17,11,4,0,0,0,0 +DATA 0.105750,-2.448640,3.896713,17,12,4,0,0,0,0 +'DATA x, y, z, atomic number, atom index, neighbor 1, neighbor 2, etc. +'ALLYLDICHLOROSILANE SGI MOLECULE END +' ***************************************************************************** + +genschemeUSAcolors: +'delinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dztemp(i, j) = vec(pcountparticleorig, 4) + NEXT +NEXT +FOR i = 1 TO xrange + FOR jj = 0 TO 12 STEP 2 + FOR j = jj * yrange / 13 + 1 TO (jj + 1) * yrange / 13 + vec2dztemp(i, j) = 4 + NEXT + NEXT + FOR jj = 1 TO 11 STEP 2 + FOR j = jj * yrange / 13 + 1 TO (jj + 1) * yrange / 13 + vec2dztemp(i, j) = 7 + NEXT + NEXT +NEXT +starflag = -1 +FOR i = 1 TO xrange * .76 / 1.9 + FOR j = yrange TO yrange * .5385 STEP -1 + IF starflag = 1 THEN + vec2dztemp(i, j) = 15 + ELSE + vec2dztemp(i, j) = 1 + END IF + starflag = -starflag + NEXT +NEXT +'relinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 4) = vec2dztemp(i, j) + NEXT +NEXT +RETURN + +genscheme.curve: +helixL = 15 +helixR1 = 5 +helixR2 = 2.5 +helixalpha = .1 +xl = -helixL / 2: xr = helixL / 2: Dx = .005 +gridxhalfsize = 10 +gridyhalfsize = 30 +gridzhalfsize = 5 +gridxstep = 1 +gridystep = 1 +gridzstep = 1 +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + pcountparticleorig = pcountparticleorig + 1 + RZ = helixR1 - (helixR1 - helixR2) * (i + helixL / 2) / helixL + vec(pcountparticleorig, 1) = RZ * COS(i) + vec(pcountparticleorig, 2) = RZ * SIN(i) + vec(pcountparticleorig, 3) = helixalpha * i + vec(pcountparticleorig, 4) = 5 +NEXT +RETURN + +genscheme.simplepoints: +xl = -3.2: xr = 5.98 +yl = -4.01: yr = 6.1 +Dx = .2: Dy = .1 +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = COS((i ^ 2 - j ^ 2)) + vec(pcountparticleorig, 4) = 9 + NEXT +NEXT +RETURN + +genscheme.3denvparticles.init: +pcountparticleorig = 0 +'particle grass +FOR i = -50 TO 50 STEP 1 + FOR j = -50 TO 50 STEP 1 + k = 0 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + RND - RND + vec(pcountparticleorig, 2) = j + RND - RND + vec(pcountparticleorig, 3) = k - COS((i - 15) * .08) + COS((j - 6) * .12) + IF COS((i - 15) * .08) + COS((j - 6) * .12) < .5 THEN + vec(pcountparticleorig, 4) = 2 + ELSE + IF RND > .2 THEN + vec(pcountparticleorig, 4) = 9 + ELSE + vec(pcountparticleorig, 4) = 1 + END IF + END IF + NEXT +NEXT +'particle sky +FOR i = -50 TO 50 STEP 1 + FOR j = -50 TO 50 STEP 1 + k = -50 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + RND + vec(pcountparticleorig, 2) = j + RND + vec(pcountparticleorig, 3) = -k - RND + IF RND > .5 THEN + vec(pcountparticleorig, 4) = 9 + ELSE + vec(pcountparticleorig, 4) = 15 + END IF + NEXT +NEXT +'particle wave art 1 +FOR i = 1 TO 5 STEP .05 + FOR k = 1 TO 5 STEP .05 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = -7 * i + vec(pcountparticleorig, 2) = 50 + 1 * COS(2 * ((i - 7) ^ 2 - (k - 5) ^ 2)) + vec(pcountparticleorig, 3) = 10 + 7 * k + IF vec(pcountparticleorig, 2) < 50 THEN + vec(pcountparticleorig, 4) = 13 + ELSE + vec(pcountparticleorig, 4) = 4 + END IF + NEXT +NEXT +'particle wave art 2 +FOR i = 1 TO 5 STEP .05 + FOR k = 1 TO 5 STEP .05 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = 7 * i + vec(pcountparticleorig, 2) = 50 + 1 * COS((i ^ 2 - k ^ 2)) + vec(pcountparticleorig, 3) = 10 + 7 * k + IF vec(pcountparticleorig, 2) < 50 THEN + vec(pcountparticleorig, 4) = 2 + ELSE + vec(pcountparticleorig, 4) = 1 + END IF + NEXT +NEXT +'air ball +FOR j = 1 TO 5 + p1 = RND * 5 + p2 = RND * 5 + p3 = RND * 5 + FOR i = -pi TO pi STEP .15 '.0005 for Menon demo + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = 30 + 5 * COS(i) * SIN(p1 * i) + SIN(p3 * i) + vec(pcountparticleorig, 2) = 20 + 5 * SIN(i) * COS(p2 * i) + COS(p2 * i) + vec(pcountparticleorig, 3) = 20 - 5 * COS(i) * SIN(p3 * i) + SIN(p1 * i) + vec(pcountparticleorig, 4) = 6 + NEXT +NEXT +animpcountparticleflag = pcountparticleorig +'particle snake +FOR i = -pi TO pi STEP .005 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = -10 + 5 * COS(i) + vec(pcountparticleorig, 2) = -20 + 5 * SIN(i) + vec(pcountparticleorig, 3) = 25 - 3 * COS(6 * i) * SIN(3 * i) + vec(pcountparticleorig, 4) = 12 +NEXT +'rain drops +FOR i = -50 TO 50 STEP 5 + FOR j = -50 TO 50 STEP 5 + k = 50 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + RND + vec(pcountparticleorig, 2) = j + RND + vec(pcountparticleorig, 3) = k * RND + IF RND > .66 THEN + vec(pcountparticleorig, 4) = 9 + ELSE + vec(pcountparticleorig, 4) = 7 + END IF + NEXT +NEXT +RETURN + +genscheme.3denvparticles.timeanimate: +T = timevar / 50 +pcountparticleorig = animpcountparticleflag +'particle snake +FOR i = -pi TO pi STEP .005 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = camx - 10 + 5 * COS(i + T) + vec(pcountparticleorig, 2) = camy - 20 + 5 * SIN(i + T) + vec(pcountparticleorig, 3) = camz + 25 - 3 * COS(6 * i + T) * SIN(3 * i + T) + vec(pcountparticleorig, 4) = 12 +NEXT +'rain drops +FOR i = -50 TO 50 STEP 5 + FOR j = -50 TO 50 STEP 5 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = vec(pcountparticleorig, 1) + vec(pcountparticleorig, 2) = vec(pcountparticleorig, 2) + vec(pcountparticleorig, 3) = vec(pcountparticleorig, 3) - .3 + IF vec(pcountparticleorig, 3) < camz THEN vec(pcountparticleorig, 3) = vec(pcountparticleorig, 3) + 50 + NEXT +NEXT +RETURN + +' ***************************************************************************** +'ETHANE MOLECULE BEGIN +'DATA 0,0,-0.771209,6,1,0,0,0,0,0 +'DATA 0,0,0.771209,6,2,1,0,0,0,0 +'DATA 1.013466,0,1.156212,2,3,2,0,0,0,0 +'DATA -1.013466,0,-1.156212,2,4,1,0,0,0,0 +'DATA -0.506733,-0.877687,1.156212,2,5,2,0,0,0,0 +'DATA -0.506733,0.877687,1.156212,2,6,2,0,0,0,0 +'DATA 0.506733,-0.877687,-1.156212,2,7,1,0,0,0,0 +'DATA 0.506733,0.877687,-1.156212,2,8,1,0,0,0,0 +'DATA x, y, z, atomic number, atom index, neighbor 1, neighbor 2, etc. +'ETHANE MOLECULE END +' ***************************************************************************** + +genscheme.molecule: +'DATA x, y, z, atomic number, atom index, neighbor 1, neighbor 2, etc. +biggestatom = -999999999 +FOR i = 1 TO numparticleorig + IF vec(i, 4) > 15 THEN + DO + vec(i, 4) = vec(i, 4) * .75 + LOOP UNTIL vec(i, 4) <= 15 + END IF + IF vec(i, 4) > biggestatom THEN biggestatom = vec(i, 4) +NEXT +RETURN + +genscheme.neighbortile: +pcountparticleorig = 0 +pcountparticleorig = 0 +FOR i = -8 TO 8 STEP 1 + FOR j = -8 TO 8 STEP 1 + FOR k = -8 TO 8 STEP 1 + mag = SQR((i ^ 2) + (j ^ 2) + (k ^ 2)) - 6 + IF SQR(mag ^ 2) < .1 AND i > 0 THEN + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = k + vec(pcountparticleorig, 4) = 4 + END IF + mag = SQR((i ^ 2) + (j ^ 2) + (k ^ 2)) - 3 + IF SQR(mag ^ 2) < .1 AND i < 2 THEN + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i - 5 + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = k + vec(pcountparticleorig, 4) = 5 + END IF + NEXT + NEXT +NEXT +FOR i = -3 TO 2 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i: vec(pcountparticleorig, 2) = -3: vec(pcountparticleorig, 3) = -3: vec(pcountparticleorig, 4) = 2 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i: vec(pcountparticleorig, 2) = -3: vec(pcountparticleorig, 3) = 3: vec(pcountparticleorig, 4) = 2 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i: vec(pcountparticleorig, 2) = 3: vec(pcountparticleorig, 3) = -3: vec(pcountparticleorig, 4) = 2 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i: vec(pcountparticleorig, 2) = 3: vec(pcountparticleorig, 3) = 3: vec(pcountparticleorig, 4) = 2 +NEXT +RETURN + +genscheme.3denvdoublets: +pcountdoubletorig = 0 +pcountdoubletorig = pcountdoubletorig + 1 +doubletorig(pcountdoubletorig, 1) = 5 +doubletorig(pcountdoubletorig, 2) = 0 +doubletorig(pcountdoubletorig, 3) = 0 +doubletorig(pcountdoubletorig, 4) = 30 +doubletorig(pcountdoubletorig, 5) = 0 +doubletorig(pcountdoubletorig, 6) = 0 +doubletorig(pcountdoubletorig, 7) = 14 +FOR j = 1 TO 5 + pcountdoubletorig = pcountdoubletorig + 1 + doubletorig(pcountdoubletorig, 1) = 5 + doubletorig(pcountdoubletorig, 2) = -20 + doubletorig(pcountdoubletorig, 3) = j + doubletorig(pcountdoubletorig, 4) = 5 + doubletorig(pcountdoubletorig, 5) = 20 + doubletorig(pcountdoubletorig, 6) = j + doubletorig(pcountdoubletorig, 7) = 13 +NEXT +FOR j = 1 TO 5 + pcountdoubletorig = pcountdoubletorig + 1 + doubletorig(pcountdoubletorig, 1) = 15 + doubletorig(pcountdoubletorig, 2) = j + doubletorig(pcountdoubletorig, 3) = -20 + doubletorig(pcountdoubletorig, 4) = 15 + doubletorig(pcountdoubletorig, 5) = j + doubletorig(pcountdoubletorig, 6) = 20 + doubletorig(pcountdoubletorig, 7) = 4 +NEXT +'dot grid +pcountparticleorig = 0 +FOR i = -20 TO 20 STEP 2 + FOR j = -20 TO 20 STEP 2 + FOR k = -20 TO 20 STEP 5 + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = k + vec(pcountparticleorig, 4) = 6 + NEXT + NEXT +NEXT +RETURN + +genscheme.3denvtriplets: +pcounttripletorig = 0 +'cubes +length = 5 +cubecenterx = 0: cubecentery = 0: cubecenterz = -15: GOSUB genscheme.3denvtriplets.makecube +cubecenterx = 20: cubecentery = 15: cubecenterz = -15: GOSUB genscheme.3denvtriplets.makecube +cubecenterx = 40: cubecentery = 0: cubecenterz = -25: GOSUB genscheme.3denvtriplets.makecube +RETURN + +genscheme.3denvtriplets.makecube: +basepointx = cubecenterx + length +basepointy = cubecentery + length +basepointz = cubecenterz - length +rightpointx = cubecenterx + length +rightpointy = cubecentery - length +rightpointz = cubecenterz - length +leftpointx = cubecenterx - length +leftpointy = cubecentery + length +leftpointz = cubecenterz - length +panelcolor = INT(RND * 14) + 1 +GOSUB create.original.triangle +basepointx = cubecenterx - length +basepointy = cubecentery + length +basepointz = cubecenterz - length +rightpointx = cubecenterx + length +rightpointy = cubecentery - length +rightpointz = cubecenterz - length +leftpointx = cubecenterx - length +leftpointy = cubecentery - length +leftpointz = cubecenterz - length +'panelcolor = 9 +GOSUB create.original.triangle +basepointx = cubecenterx - length +basepointy = cubecentery + length +basepointz = cubecenterz - length +rightpointx = cubecenterx - length +rightpointy = cubecentery - length +rightpointz = cubecenterz - length +leftpointx = cubecenterx - length +leftpointy = cubecentery + length +leftpointz = cubecenterz + length +panelcolor = INT(RND * 14) + 1 +GOSUB create.original.triangle +basepointx = cubecenterx - length +basepointy = cubecentery + length +basepointz = cubecenterz + length +rightpointx = cubecenterx - length +rightpointy = cubecentery - length +rightpointz = cubecenterz - length +leftpointx = cubecenterx - length +leftpointy = cubecentery - length +leftpointz = cubecenterz + length +'panelcolor = 10 +GOSUB create.original.triangle +basepointx = cubecenterx - length +basepointy = cubecentery - length +basepointz = cubecenterz - length +rightpointx = cubecenterx + length +rightpointy = cubecentery - length +rightpointz = cubecenterz - length +leftpointx = cubecenterx - length +leftpointy = cubecentery - length +leftpointz = cubecenterz + length +panelcolor = INT(RND * 14) + 1 +GOSUB create.original.triangle +basepointx = cubecenterx - length +basepointy = cubecentery - length +basepointz = cubecenterz + length +rightpointx = cubecenterx + length +rightpointy = cubecentery - length +rightpointz = cubecenterz - length +leftpointx = cubecenterx + length +leftpointy = cubecentery - length +leftpointz = cubecenterz + length +'panelcolor = 11 +GOSUB create.original.triangle +basepointx = cubecenterx - length +basepointy = cubecentery + length +basepointz = cubecenterz + length +rightpointx = cubecenterx - length +rightpointy = cubecentery - length +rightpointz = cubecenterz + length +leftpointx = cubecenterx + length +leftpointy = cubecentery + length +leftpointz = cubecenterz + length +panelcolor = INT(RND * 14) + 1 +GOSUB create.original.triangle +basepointx = cubecenterx + length +basepointy = cubecentery + length +basepointz = cubecenterz + length +rightpointx = cubecenterx - length +rightpointy = cubecentery - length +rightpointz = cubecenterz + length +leftpointx = cubecenterx + length +leftpointy = cubecentery - length +leftpointz = cubecenterz + length +'panelcolor = 12 +GOSUB create.original.triangle +basepointx = cubecenterx + length +basepointy = cubecentery - length +basepointz = cubecenterz - length +rightpointx = cubecenterx + length +rightpointy = cubecentery + length +rightpointz = cubecenterz - length +leftpointx = cubecenterx + length +leftpointy = cubecentery - length +leftpointz = cubecenterz + length +panelcolor = INT(RND * 14) + 1 +GOSUB create.original.triangle +basepointx = cubecenterx + length +basepointy = cubecentery - length +basepointz = cubecenterz + length +rightpointx = cubecenterx + length +rightpointy = cubecentery + length +rightpointz = cubecenterz - length +leftpointx = cubecenterx + length +leftpointy = cubecentery + length +leftpointz = cubecenterz + length +'panelcolor = 13 +GOSUB create.original.triangle +basepointx = cubecenterx + length +basepointy = cubecentery + length +basepointz = cubecenterz - length +rightpointx = cubecenterx - length +rightpointy = cubecentery + length +rightpointz = cubecenterz - length +leftpointx = cubecenterx + length +leftpointy = cubecentery + length +leftpointz = cubecenterz + length +panelcolor = INT(RND * 14) + 1 +GOSUB create.original.triangle +basepointx = cubecenterx + length +basepointy = cubecentery + length +basepointz = cubecenterz + length +rightpointx = cubecenterx - length +rightpointy = cubecentery + length +rightpointz = cubecenterz - length +leftpointx = cubecenterx - length +leftpointy = cubecentery + length +leftpointz = cubecenterz + length +'panelcolor = 14 +GOSUB create.original.triangle +RETURN + +create.original.triangle: +shrinkfactor = .90 +centorigx = (1 / 3) * (basepointx + rightpointx + leftpointx) +centorigy = (1 / 3) * (basepointy + rightpointy + leftpointy) +centorigz = (1 / 3) * (basepointz + rightpointz + leftpointz) +basepointx = centorigx + (shrinkfactor) * (basepointx - centorigx) +basepointy = centorigy + (shrinkfactor) * (basepointy - centorigy) +basepointz = centorigz + (shrinkfactor) * (basepointz - centorigz) +rightpointx = centorigx + (shrinkfactor) * (rightpointx - centorigx) +rightpointy = centorigy + (shrinkfactor) * (rightpointy - centorigy) +rightpointz = centorigz + (shrinkfactor) * (rightpointz - centorigz) +leftpointx = centorigx + (shrinkfactor) * (leftpointx - centorigx) +leftpointy = centorigy + (shrinkfactor) * (leftpointy - centorigy) +leftpointz = centorigz + (shrinkfactor) * (leftpointz - centorigz) +pcounttripletorig = pcounttripletorig + 1 +tripletorig(pcounttripletorig, 1) = basepointx +tripletorig(pcounttripletorig, 2) = basepointy +tripletorig(pcounttripletorig, 3) = basepointz +tripletorig(pcounttripletorig, 4) = rightpointx +tripletorig(pcounttripletorig, 5) = rightpointy +tripletorig(pcounttripletorig, 6) = rightpointz +tripletorig(pcounttripletorig, 7) = leftpointx +tripletorig(pcounttripletorig, 8) = leftpointy +tripletorig(pcounttripletorig, 9) = leftpointz +tripletorig(pcounttripletorig, 10) = panelcolor +RETURN + +genscheme.animatedsurface.init: +xl = -1.9: xr = 1.9 +yl = -1: yr = 1 +xl = xl * 4: xr = xr * 4: yl = yl * 4: yr = yr * 4 +Dx = .32 +Dy = .32 +xrange = 1 + INT((-xl + xr) / Dx) +yrange = 1 + INT((-yl + yr) / Dy) +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = .25 + .25 * COS(i - 2 * T) ^ 2 - .25 * SIN(j - T) ^ 2 + '*'vec(pcountparticleorig, 4) = 14 'use special color scheme + NEXT +NEXT +RETURN + +genscheme.animatedsurface.timeanimate: +T = timevar / 5 +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = .25 + .25 * COS(i - 2 * T) ^ 2 - .25 * SIN(j - T) ^ 2 + '*'vec(pcountparticleorig, 4) = 14 'use special color scheme + NEXT +NEXT +RETURN + +genscheme.animatedpretzel.init: +rho = 4: beta = .5: a = 1: b = 5: L = 4 +xl = -L: xr = L +yl = 0: yr = 2 * pi +Dx = .10: Dy = .157 +xrange = 1 + INT((-xl + xr) / Dx) +yrange = 1 + INT((-yl + yr) / Dy) +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + R = rho - (T / 100) * beta * (i ^ 2) + h = a * SQR(1 - (i / b) ^ 2) + k = 1 / SQR((2 * beta * i) ^ 2 + R ^ 2) + vec(pcountparticleorig, 1) = R * COS(i) + h * k * (R * COS(i) - 2 * beta * i * SIN(i)) * COS(j) + vec(pcountparticleorig, 2) = R * SIN(i) + h * k * (R * SIN(i) + 2 * beta * i * COS(i)) * COS(j) + vec(pcountparticleorig, 3) = h * SIN(j) + vec(pcountparticleorig, 4) = 5 + NEXT +NEXT +RETURN + +genscheme.animatedpretzel.timeanimate: +T = timevar +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + R = rho - (T / 100) * beta * (i ^ 2) + h = a * SQR(1 - (i / b) ^ 2) + k = 1 / SQR((2 * beta * i) ^ 2 + R ^ 2) + vec(pcountparticleorig, 1) = R * COS(i) + h * k * (R * COS(i) - 2 * beta * i * SIN(i)) * COS(j) + vec(pcountparticleorig, 2) = R * SIN(i) + h * k * (R * SIN(i) + 2 * beta * i * COS(i)) * COS(j) + vec(pcountparticleorig, 3) = h * SIN(j) + vec(pcountparticleorig, 4) = 5 + NEXT +NEXT +RETURN + +genscheme.sphericalharmonics: +xl = 0: xr = pi: Dx = .05 +yl = 0: yr = 2 * pi: Dy = .05 +xrange = 1 + INT((-xl + xr) / Dx) +yrange = 1 + INT((-yl + yr) / Dy) +L = 0 +ml = 0 +PRINT " Choose the orbital L value (must be >= 0)." +PRINT: INPUT " Enter a choice: ", L +IF L < 0 THEN L = 0 +PRINT +PRINT " Choose the orbital mL value (must have -L < mL < L)." +PRINT: INPUT " Enter a choice: ", ml +IF ml < -L THEN ml = -L +IF ml > L THEN ml = L +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + x0 = 10 * SIN(i) * COS(j) + y0 = 10 * SIN(i) * SIN(j) + z0 = 10 * COS(i) + SELECT CASE L + CASE 0 + vec(pcountparticleorig, 1) = x0 * (1 / 2) * SQR(1 / pi) + vec(pcountparticleorig, 2) = y0 * (1 / 2) * SQR(1 / pi) + vec(pcountparticleorig, 3) = z0 * (1 / 2) * SQR(1 / pi) + vec(pcountparticleorig, 4) = 9 + CASE 1 + SELECT CASE ml + CASE -1 + vec(pcountparticleorig, 1) = x0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(j) + vec(pcountparticleorig, 2) = y0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(j) + vec(pcountparticleorig, 3) = z0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(j) + vec(pcountparticleorig, 4) = 9 + CASE 0 + vec(pcountparticleorig, 1) = x0 * (1 / 2) * SQR(3 / pi) * COS(i) + vec(pcountparticleorig, 2) = y0 * (1 / 2) * SQR(3 / pi) * COS(i) + vec(pcountparticleorig, 3) = z0 * (1 / 2) * SQR(3 / pi) * COS(i) + vec(pcountparticleorig, 4) = 9 + CASE 1 + vec(pcountparticleorig, 1) = x0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(j) + vec(pcountparticleorig, 2) = y0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(j) + vec(pcountparticleorig, 3) = z0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(j) + vec(pcountparticleorig, 4) = 9 + END SELECT + CASE 2 + SELECT CASE ml + CASE -2 + vec(pcountparticleorig, 1) = x0 * (1 / 2) * SQR(3 / pi) * SIN(i) ^ 2 * COS(2 * j) + vec(pcountparticleorig, 2) = y0 * (1 / 2) * SQR(3 / pi) * SIN(i) ^ 2 * COS(2 * j) + vec(pcountparticleorig, 3) = z0 * (1 / 2) * SQR(3 / pi) * SIN(i) ^ 2 * COS(2 * j) + vec(pcountparticleorig, 4) = 9 + CASE -1 + vec(pcountparticleorig, 1) = x0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(i) * COS(j) + vec(pcountparticleorig, 2) = y0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(i) * COS(j) + vec(pcountparticleorig, 3) = z0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(i) * COS(j) + vec(pcountparticleorig, 4) = 9 + CASE 0 + vec(pcountparticleorig, 1) = x0 * (1 / 4) * SQR(5 / pi) * (3 * COS(i) ^ 2 - 1) + vec(pcountparticleorig, 2) = y0 * (1 / 4) * SQR(5 / pi) * (3 * COS(i) ^ 2 - 1) + vec(pcountparticleorig, 3) = z0 * (1 / 4) * SQR(5 / pi) * (3 * COS(i) ^ 2 - 1) + vec(pcountparticleorig, 4) = 9 + CASE 1 + vec(pcountparticleorig, 1) = x0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(i) * COS(j) + vec(pcountparticleorig, 2) = y0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(i) * COS(j) + vec(pcountparticleorig, 3) = z0 * (1 / 2) * SQR(3 / pi) * SIN(i) * COS(i) * COS(j) + vec(pcountparticleorig, 4) = 9 + CASE 2 + vec(pcountparticleorig, 1) = x0 * (1 / 2) * SQR(3 / pi) * SIN(i) ^ 2 * COS(2 * j) + vec(pcountparticleorig, 2) = y0 * (1 / 2) * SQR(3 / pi) * SIN(i) ^ 2 * COS(2 * j) + vec(pcountparticleorig, 3) = z0 * (1 / 2) * SQR(3 / pi) * SIN(i) ^ 2 * COS(2 * j) + vec(pcountparticleorig, 4) = 9 + END SELECT + CASE 3 + SELECT CASE ml + CASE -3 + CASE -2 + CASE -1 + CASE 0 + CASE 1 + CASE 2 + CASE 3 + END SELECT + CASE ELSE + L = 0 + ml = 0 + END SELECT + NEXT +NEXT +RETURN + +genscheme.laplace2d.init: +xl = -5: xr = 5 +yl = -7: yr = 7 +Dx = .25 +Dy = .25 +xrange = 1 + INT((-xl + xr) / Dx) +yrange = 1 + INT((-yl + yr) / Dy) +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = 0 + vec(pcountparticleorig, 4) = 6 + NEXT +NEXT +RETURN + +genscheme.laplace2d.gridinit: +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dzfixed(i, j) = -1 + ''' + randnum = RND * 1000 + IF randnum < 40 AND i > xrange * .33 AND i < xrange * .66 AND j > yrange * .33 AND j < yrange * .66 THEN + vec(pcountparticleorig, 3) = RND * 6 + vec(pcountparticleorig, 4) = 15 + vec2dzfixed(i, j) = 1 + END IF + IF randnum > 995 THEN + vec(pcountparticleorig, 3) = -RND * 5 + vec(pcountparticleorig, 4) = 1 + vec2dzfixed(i, j) = 1 + END IF + ''' + ''' + ' IF i = 1 THEN + ' vec2dzfixed(i, j) = 1 + ' vec(pcountparticleorig, 3) = pi / 2 + ' END IF + ' IF i = xrange THEN + ' vec2dzfixed(i, j) = 1 + ' vec(pcountparticleorig, 3) = 0 + ' END IF + ' IF j = 1 THEN + ' vec2dzfixed(i, j) = 1 + ' vec(pcountparticleorig, 3) = pi / 2 + ' END IF + ' IF j = yrange THEN + ' vec2dzfixed(i, j) = 1 + ' vec(pcountparticleorig, 3) = pi / 2 + ' END IF + ''' + NEXT +NEXT +RETURN + +genscheme.laplace2d.timeanimate: +'delinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dztemp(i, j) = vec(pcountparticleorig, 3) + NEXT +NEXT +'begin relax process +FOR i = 2 TO xrange - 1 'boDy, no edges + FOR j = 2 TO yrange - 1 + IF vec2dzfixed(i, j) = -1 THEN + rx1 = vec2dztemp(i + 1, j) + rx2 = vec2dztemp(i - 1, j) + rx3 = vec2dztemp(i, j - 1) + rx4 = vec2dztemp(i, j + 1) + vec2dz(i, j) = (1 / 4) * (rx1 + rx2 + rx3 + rx4) + END IF + NEXT +NEXT +FOR j = 2 TO yrange - 1 'left edge, right edge, no corners + i = 1 + IF vec2dzfixed(i, j) = -1 THEN + rx1 = vec2dztemp(i + 1, j) + rx3 = vec2dztemp(i, j - 1) + rx4 = vec2dztemp(i, j + 1) + vec2dz(i, j) = (1 / 3) * (rx1 + rx3 + rx4) + END IF + i = xrange + IF vec2dzfixed(i, j) = -1 THEN + rx2 = vec2dztemp(i - 1, j) + rx3 = vec2dztemp(i, j - 1) + rx4 = vec2dztemp(i, j + 1) + vec2dz(i, j) = (1 / 3) * (rx2 + rx3 + rx4) + END IF +NEXT +FOR i = 2 TO xrange - 1 'top edge, bottom edge, no corners + j = 1 + IF vec2dzfixed(i, j) = -1 THEN + rx1 = vec2dztemp(i + 1, j) + rx2 = vec2dztemp(i - 1, j) + rx4 = vec2dztemp(i, j + 1) + vec2dz(i, j) = (1 / 3) * (rx1 + rx2 + rx4) + END IF + j = yrange + IF vec2dzfixed(i, j) = -1 THEN + rx1 = vec2dztemp(i + 1, j) + rx2 = vec2dztemp(i - 1, j) + rx3 = vec2dztemp(i, j - 1) + vec2dz(i, j) = (1 / 3) * (rx1 + rx2 + rx3) + END IF +NEXT +'four corners +IF vec2dzfixed(1, 1) = -1 THEN vec2dz(1, 1) = (1 / 2) * (vec2dztemp(1, 2) + vec2dztemp(2, 1)) +IF vec2dzfixed(xrange, 1) = -1 THEN vec2dz(xrange, 1) = (1 / 2) * (vec2dztemp(xrange - 1, 1) + vec2dztemp(xrange, 2)) +IF vec2dzfixed(1, yrange) = -1 THEN vec2dz(1, yrange) = (1 / 2) * (vec2dztemp(2, yrange) + vec2dztemp(1, yrange - 1)) +IF vec2dzfixed(xrange, yrange) = -1 THEN vec2dz(xrange, yrange) = (1 / 2) * (vec2dztemp(xrange - 1, yrange) + vec2dztemp(xrange, yrange - 1)) +'relinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + IF vec2dzfixed(i, j) = -1 THEN vec(pcountparticleorig, 3) = vec2dz(i, j) + IF vec2dz(i, j) > 2 THEN vec(pcountparticleorig, 4) = 15 + IF vec2dz(i, j) < -1 THEN vec(pcountparticleorig, 4) = 1 + NEXT +NEXT +RETURN + +genscheme.planet.init: +planetradius = 5 +Dx = .0628 +Dy = .0628 +xl = 0: xr = 2 * pi +yl = 0: yr = pi +xrange = 1 + INT((-xl + xr) / Dx) +yrange = 1 + INT((-yl + yr) / Dy) +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + theta = i * Dx - Dx + phi = j * Dy - Dy + vec(pcountparticleorig, 1) = planetradius * SIN(phi) * COS(theta) + vec(pcountparticleorig, 2) = planetradius * SIN(phi) * SIN(theta) + vec(pcountparticleorig, 3) = planetradius * COS(phi) + vec(pcountparticleorig, 4) = 2 + 'randnum = RND * 1000 + 'IF randnum > 600 THEN vec(pcountparticleorig, 4) = 2 + NEXT +NEXT +RETURN + +genscheme.planet.gridinit: +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + theta = i * Dx - Dx + phi = j * Dy - Dy + vec2dsfixed(i, j) = -1 + IF phi > pi / 8 AND phi < pi - pi / 8 THEN + randnum = RND * 1000 + IF randnum < 20 THEN + plrad = planetradius + RND * 1.25 + vec(pcountparticleorig, 1) = plrad * SIN(phi) * COS(theta) + vec(pcountparticleorig, 2) = plrad * SIN(phi) * SIN(theta) + vec(pcountparticleorig, 3) = plrad * COS(phi) + vec2dsfixed(i, j) = 1 + END IF + IF randnum > 980 THEN + plrad = planetradius - RND * 1.25 + vec(pcountparticleorig, 1) = plrad * SIN(phi) * COS(theta) + vec(pcountparticleorig, 2) = plrad * SIN(phi) * SIN(theta) + vec(pcountparticleorig, 3) = plrad * COS(phi) + vec2dsfixed(i, j) = 1 + END IF + vec(pcountparticleorig, 4) = 2 + ELSE + vec(pcountparticleorig, 4) = 15 + END IF + NEXT +NEXT +RETURN + +genscheme.planet.timeanimate: +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dstemp(i, j) = SQR(vec(pcountparticleorig, 1) ^ 2 + vec(pcountparticleorig, 2) ^ 2 + vec(pcountparticleorig, 3) ^ 2) + NEXT +NEXT +'begin relax process +FOR i = 2 TO xrange - 1 'boDy, no seam + FOR j = 2 TO yrange - 1 + IF vec2dsfixed(i, j) = -1 THEN + rx1 = vec2dstemp(i + 1, j) + rx2 = vec2dstemp(i - 1, j) + rx3 = vec2dstemp(i, j - 1) + rx4 = vec2dstemp(i, j + 1) + vec2ds(i, j) = (1 / 4) * (rx1 + rx2 + rx3 + rx4) + END IF + NEXT +NEXT +FOR j = 2 TO yrange - 1 'seam + IF vec2dsfixed(1, j) = -1 THEN + rx1 = vec2dstemp(2, j) + rx2 = vec2dstemp(xrange, j) + rx3 = vec2dstemp(1, j - 1) + rx4 = vec2dstemp(1, j + 1) + vec2ds(1, j) = (1 / 4) * (rx1 + rx2 + rx3 + rx4) + END IF + IF vec2dsfixed(xrange, j) = -1 THEN + rx1 = vec2dstemp(1, j) + rx2 = vec2dstemp(xrange - 1, j) + rx3 = vec2dstemp(xrange, j - 1) + rx4 = vec2dstemp(xrange, j + 1) + vec2ds(xrange, j) = (1 / 4) * (rx1 + rx2 + rx3 + rx4) + END IF +NEXT +'relinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + IF vec2dsfixed(i, j) = -1 AND j <> 1 AND j <> yrange THEN + vec(pcountparticleorig, 1) = vec(pcountparticleorig, 1) * vec2ds(i, j) / vec2dstemp(i, j) + vec(pcountparticleorig, 2) = vec(pcountparticleorig, 2) * vec2ds(i, j) / vec2dstemp(i, j) + vec(pcountparticleorig, 3) = vec(pcountparticleorig, 3) * vec2ds(i, j) / vec2dstemp(i, j) + END IF + SELECT CASE SQR(vec(pcountparticleorig, 1) ^ 2 + vec(pcountparticleorig, 2) ^ 2 + vec(pcountparticleorig, 3) ^ 2) + CASE IS > planetradius + 0.25 + vec(pcountparticleorig, 4) = 6 + CASE IS < planetradius - 0.25 + vec(pcountparticleorig, 4) = 1 + END SELECT + NEXT +NEXT +RETURN + +genscheme.wave2d.init: +xl = -1.9: xr = 1.9 +yl = -1: yr = 1 +xl = xl * 4: xr = xr * 4: yl = yl * 4: yr = yr * 4 +Dx = .32 +Dy = .32 +xrange = 1 + INT((-xl + xr) / Dx) +yrange = 1 + INT((-yl + yr) / Dy) +alpha = .25 +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = 0 + '*' vec(pcountparticleorig, 4) = 14 'use special color scheme + NEXT +NEXT +RETURN + +genscheme.wave2d.gridinit: +'delinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dztemp(i, j) = vec(pcountparticleorig, 3) + NEXT +NEXT +'initial position condition +'FOR i = 1 TO xrange 'random high points +' FOR j = 1 TO yrange +' nrand = RND * 1000 +' IF nrand < 10 THEN +' vec2dz(i, j) = 5 +' END IF +' NEXT +'NEXT +'vec2dz(xrange * .8, yrange * .2) = -2.5 'single plucked point +'FOR i = 1 TO xrange 'cross arm +' vec2dz(i, yrange / 3) = 2 +'NEXT +'FOR j = 1 TO yrange 'cross arm +' vec2dz(xrange / 2, j) = 1 +'NEXT +'sync +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dzprev(i, j) = vec2dz(i, j) + vec2dztemp(i, j) = vec2dz(i, j) + NEXT +NEXT +'initial velocity condition +vec2dzprev(xrange * .8, yrange * .8) = 1.5 'single struck point +'relinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 3) = vec2dz(i, j) + NEXT +NEXT +RETURN + +genscheme.wave2d.timeanimate: +'delinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dztemp(i, j) = vec(pcountparticleorig, 3) + NEXT +NEXT +'begin propagation process +FOR i = 2 TO xrange - 1 'boDy, no edges + FOR j = 2 TO yrange - 1 + wp1 = alpha * (vec2dztemp(i + 1, j) + vec2dztemp(i - 1, j)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + wp2 = alpha * (vec2dztemp(i, j + 1) + vec2dztemp(i, j - 1)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + vec2dz(i, j) = (1 / 2) * (wp1 + wp2) + NEXT +NEXT +'comment out this section for fixed edges (or pieces of this section) +i = 1 'left edge +FOR j = 2 TO yrange - 1 + wfp = vec2dztemp(i, j) + wp1 = alpha * (vec2dztemp(i + 1, j) + wfp) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + wp2 = alpha * (vec2dztemp(i, j + 1) + vec2dztemp(i, j - 1)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + 'vec2dz(i, j) = (1 / 2) * (wp1 + wp2) +NEXT +i = xrange 'right edge +FOR j = 2 TO yrange - 1 + wfp = vec2dztemp(i, j) + wp1 = alpha * (wfp + vec2dztemp(i - 1, j)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + wp2 = alpha * (vec2dztemp(i, j + 1) + vec2dztemp(i, j - 1)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + vec2dz(i, j) = (1 / 2) * (wp1 + wp2) +NEXT +j = 1 'bottom edge +FOR i = 2 TO xrange - 1 + wfp = vec2dztemp(i, j) + wp2 = alpha * (vec2dztemp(i, j + 1) + wfp) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + wp1 = alpha * (vec2dztemp(i + 1, j) + vec2dztemp(i - 1, j)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + vec2dz(i, j) = (1 / 2) * (wp1 + wp2) +NEXT +j = yrange 'top edge +FOR i = 2 TO xrange - 1 + wfp = vec2dztemp(i, j) + wp2 = alpha * (wfp + vec2dztemp(i, j - 1)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + wp1 = alpha * (vec2dztemp(i + 1, j) + vec2dztemp(i - 1, j)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + vec2dz(i, j) = (1 / 2) * (wp1 + wp2) +NEXT +'bottom left corner +i = 1: j = 1 +wfp1 = vec2dztemp(i, j) +wfp2 = vec2dztemp(i, j) +wp1 = alpha * (vec2dztemp(i + 1, j) + wfp1) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) +wp2 = alpha * (vec2dztemp(i, j + 1) + wfp2) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) +'vec2dz(i, j) = (1 / 2) * (wp1 + wp2) +'bottom right corner +i = xrange: j = 1 +wfp1 = vec2dztemp(i, j) +wfp2 = vec2dztemp(i, j) +wp1 = alpha * (wfp1 + vec2dztemp(i - 1, j)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) +wp2 = alpha * (vec2dztemp(i, j + 1) + wfp2) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) +vec2dz(i, j) = (1 / 2) * (wp1 + wp2) +'top left corner +i = 1: j = yrange +wfp1 = vec2dztemp(i, j) +wfp2 = vec2dztemp(i, j) +wp1 = alpha * (vec2dztemp(i + 1, j) + wfp1) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) +wp2 = alpha * (wfp2 + vec2dztemp(i, j - 1)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) +'vec2dz(i, j) = (1 / 2) * (wp1 + wp2) +'top right corner +i = xrange: j = yrange +wfp1 = vec2dztemp(i, j) +wfp2 = vec2dztemp(i, j) +wp1 = alpha * (wfp1 + vec2dztemp(i - 1, j)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) +wp2 = alpha * (wfp2 + vec2dztemp(i, j - 1)) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) +vec2dz(i, j) = (1 / 2) * (wp1 + wp2) +'start special movements +T = timevar / 5 +IF T < pi THEN 'wave left edge just once + FOR j = 1 TO yrange + i = 1 + vec2dz(i, j) = (j / yrange) * 1.5 * SIN(T) + NEXT +END IF +IF T < pi THEN 'wave bottom edge just once + FOR i = 1 TO xrange + j = 1 + vec2dz(i, j) = (i / xrange) * .45 * SIN(T) + NEXT +END IF +'relinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dzprev(i, j) = vec2dztemp(i, j) + vec2dztemp(i, j) = vec2dz(i, j) + vec(pcountparticleorig, 3) = vec2dz(i, j) + NEXT +NEXT +RETURN + +genscheme.wave2dinf.init: +xl = -12: xr = 12 +yl = -12: yr = 12 +Dx = .33 +Dy = .33 +xrange = 1 + INT((-xl + xr) / Dx) +yrange = 1 + INT((-yl + yr) / Dy) +alpha = .25 +pcountparticleorig = 0 +FOR i = xl TO xr STEP Dx + FOR j = yl TO yr STEP Dy + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = i + vec(pcountparticleorig, 2) = j + vec(pcountparticleorig, 3) = 0 + vec(pcountparticleorig, 4) = 1 + NEXT +NEXT +RETURN + +genscheme.wave2dinf.gridinit: +'delinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dzfixed(i, j) = -1 + vec2dztemp(i, j) = vec(pcountparticleorig, 3) + NEXT +NEXT +'set edge damping constants +xrdamp = INT(xrange / 10) +yrdamp = INT(yrange / 10) +'create fixed heights +FOR j = 1 TO INT(yrange / 2 - 3) + FOR i = INT(xrange / 3 - 5) TO INT(xrange / 3 - 3) + vec2dzfixed(i, j) = 1 + vec2dz(i, j) = 0 + NEXT +NEXT +FOR j = INT(yrange / 2 + 3) TO yrange + FOR i = INT(xrange / 3 - 5) TO INT(xrange / 3 - 3) + vec2dzfixed(i, j) = 1 + vec2dz(i, j) = 0 + NEXT +NEXT +'initial position condition +'FOR i = 1 TO xrange 'random high points +' FOR j = 1 TO yrange +' nrand = RND * 1000 +' IF nrand < 10 THEN +' vec2dz(i, j) = 1 +' END IF +' NEXT +'NEXT +'i = xrange / 2: j = yrange / 2: vec2dz(i, j) = 8 'pluck middle +'sync +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dzprev(i, j) = vec2dz(i, j) + vec2dztemp(i, j) = vec2dz(i, j) + NEXT +NEXT +'initial velocity condition +'vec2dzprev(xrange / 2, yrange / 2) = 1.5 'single struck point +'relinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 3) = vec2dz(i, j) + IF i < xrdamp THEN vec(pcountparticleorig, 4) = 8 + IF i > xrange - xrdamp THEN vec(pcountparticleorig, 4) = 8 + IF j < yrdamp THEN vec(pcountparticleorig, 4) = 8 + IF j > yrange - yrdamp THEN vec(pcountparticleorig, 4) = 8 + IF vec2dzfixed(i, j) = 1 THEN vec(pcountparticleorig, 4) = 4 + NEXT +NEXT +RETURN + +genscheme.wave2dinf.timeanimate: +'delinearize +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dztemp(i, j) = vec(pcountparticleorig, 3) + NEXT +NEXT +'start pre-propagation special movements +T = timevar +IF RND * 250 < 10 THEN 'rain drops + i = INT(RND * xrange - xrdamp - 2) + xrdamp + 2 + j = INT(RND * yrange - yrdamp - 2) + yrdamp + 2 + 'IF vec2dzfixed(i, j) = -1 THEN vec2dzprev(i, j) = -2 'set velocity or + IF vec2dzfixed(i, j) = -1 THEN vec2dztemp(i, j) = 2 'set position +END IF +'begin propagation process +FOR i = 2 TO xrange - 1 'boDy, no edges + FOR j = 2 TO yrange - 1 + vp1 = vec2dztemp(i + 1, j) + vp2 = vec2dztemp(i - 1, j) + vp3 = vec2dztemp(i, j + 1) + vp4 = vec2dztemp(i, j - 1) + IF vec2dzfixed(i + 1, j) = 1 THEN vp1 = 0 + IF vec2dzfixed(i - 1, j) = 1 THEN vp2 = 0 + IF vec2dzfixed(i, j + 1) = 1 THEN vp3 = 0 + IF vec2dzfixed(i, j - 1) = 1 THEN vp4 = 0 + wp1 = alpha * (vp1 + vp2) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + wp2 = alpha * (vp3 + vp4) + 2 * (1 - alpha) * vec2dztemp(i, j) - vec2dzprev(i, j) + vec2dz(i, j) = (1 / 2) * (wp1 + wp2) + NEXT +NEXT +'damp out motion at edges +'left edge +FOR j = 2 TO yrange - 1 + FOR i = xrdamp TO 2 STEP -1 + vec2dz(i, j) = (1 / 4) * (vec2dztemp(i, j) + vec2dztemp(i + 1, j) + vec2dztemp(i, j + 1) + vec2dztemp(i, j - 1)) + NEXT +NEXT +'right edge +FOR j = 2 TO yrange - 1 + FOR i = (xrange - xrdamp) TO (xrange - 1) + vec2dz(i, j) = (1 / 4) * (vec2dztemp(i, j) + vec2dztemp(i - 1, j) + vec2dztemp(i, j + 1) + vec2dztemp(i, j - 1)) + NEXT +NEXT +'bottom edge +FOR i = 2 TO xrange - 1 + FOR j = yrdamp TO 2 STEP -1 + vec2dz(i, j) = (1 / 4) * (vec2dztemp(i, j) + vec2dztemp(i, j + 1) + vec2dztemp(i + 1, j) + vec2dztemp(i - 1, j)) + NEXT +NEXT +'top edge +FOR i = 2 TO xrange - 1 + FOR j = (yrange - yrdamp) TO (yrange - 1) + vec2dz(i, j) = (1 / 4) * (vec2dztemp(i, j) + vec2dztemp(i, j - 1) + vec2dztemp(i + 1, j) + vec2dztemp(i - 1, j)) + NEXT +NEXT +'adjust for error caused by boundary conditions +nrbcerr = 0 +FOR j = 1 TO yrange + nrbcerr = nrbcerr + vec2dz(xrange - 1, j) + nrbcerr = nrbcerr + vec2dz(2, j) +NEXT +FOR i = 1 TO xrange + nrbcerr = nrbcerr + vec2dz(i, yrange - 1) + nrbcerr = nrbcerr + vec2dz(i, 2) +NEXT +nrbcerr = nrbcerr / (2 * xrange + 2 * yrange) +'start post-propagation special movements +'IF t < pi THEN 'wave middle just once +' i = xrange / 2 +' j = yrange / 2 +' vec2dz(i, j) = -4.5 * SIN(t) +'END IF +'IF t < pi THEN 'wave some place +FOR j = 1 + 2.5 * yrdamp TO yrange - 2.5 * yrdamp + i = xrdamp + 1 + vec2dz(i, j) = .75 * SIN(.5 * T) +NEXT +'END IF +'relinearize and correct for nonreflecting boundary condition error +pcountparticleorig = 0 +FOR i = 1 TO xrange + FOR j = 1 TO yrange + pcountparticleorig = pcountparticleorig + 1 + vec2dzprev(i, j) = vec2dztemp(i, j) - nrbcerr + vec2dztemp(i, j) = vec2dz(i, j) - nrbcerr + IF vec2dzfixed(i, j) = -1 THEN vec(pcountparticleorig, 3) = vec2dz(i, j) - nrbcerr + IF vec2dzfixed(i, j) = -1 AND i >= xrdamp AND i <= xrange - xrdamp AND j >= yrdamp AND j <= yrange - yrdamp THEN + IF vec2dz(i, j) > .2 THEN vec(pcountparticleorig, 4) = 9 ELSE vec(pcountparticleorig, 4) = 1 + END IF + NEXT +NEXT +RETURN + +genscheme.bacteria.init: +gridxhalfsize = 50 +gridyhalfsize = 50 +gridzhalfsize = 50 +gridxstep = 2 +gridystep = 2 +gridzstep = 2 +numcreatures1 = numcreatures +numcreatures2 = 0 +numcreatures3 = 0 +creatureinitrad = 0.5 +pcountparticleorig = 0 +FOR i = 1 TO numcreatures + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 5) = .15 'step constant + vec(pcountparticleorig, 6) = creatureinitrad 'creature radius + vec(pcountparticleorig, 7) = vec(pcountparticleorig, 6) 'old creature radius + IF RND > .5 THEN 'determine gender of species 1 + vec(pcountparticleorig, 4) = 9 + vec(pcountparticleorig, 8) = 1 'species 1 male + ELSE + vec(pcountparticleorig, 4) = 13 + vec(pcountparticleorig, 8) = 2 'species 1 female + END IF + placecreature: + vec(pcountparticleorig, 1) = RND * (2 * gridxhalfsize) - gridxhalfsize 'x position + vec(pcountparticleorig, 2) = RND * (2 * gridyhalfsize) - gridyhalfsize 'y position + vec(pcountparticleorig, 3) = RND * (2 * gridzhalfsize) - gridzhalfsize 'z position + FOR j = 1 TO i 'initial overlap prevention + IF i <> j THEN + deltax = vec(i, 1) - vec(j, 1) + deltay = vec(i, 2) - vec(j, 2) + deltaz = vec(i, 3) - vec(j, 3) + deltar = SQR(deltax ^ 2 + deltay ^ 2 + deltaz ^ 2) + IF deltar < (vec(i, 6) + vec(j, 6)) THEN GOTO placecreature + END IF + NEXT +NEXT +RETURN + +genscheme.bacteria.timeanimate: +FOR i = 1 TO numcreatures + 'store old creature radius + vec(i, 7) = vec(i, 6) + 'determine if creature grows in radius + IF RND > .66 THEN + vec(i, 6) = vec(i, 6) * (1 + RND * 0.001) + END IF + 'creature is too large and explodes + IF vec(i, 6) > 8 * creatureinitrad THEN + vec(i, 6) = creatureinitrad + SELECT CASE vec(i, 8) 'erase creature count of particular species + CASE 1: numcreatures1 = numcreatures1 - 1 + CASE 2: numcreatures1 = numcreatures1 - 1 + CASE 3: numcreatures2 = numcreatures2 - 1 + CASE 4: numcreatures2 = numcreatures2 - 1 + CASE 5: numcreatures3 = numcreatures3 - 1 + CASE 6: numcreatures3 = numcreatures3 - 1 + END SELECT + 'perform weighted average over species for replacement creature + j1 = RND * numcreatures1 + j2 = RND * numcreatures2 + j3 = RND * numcreatures3 + IF j1 > j2 AND j1 > j3 THEN + numcreatures1 = numcreatures1 + 1 + IF RND > .5 THEN + vec(i, 4) = 9 + vec(i, 8) = 1 'species 1 male + ELSE + vec(i, 4) = 13 + vec(i, 8) = 2 'species 1 female + END IF + END IF + IF j2 > j1 AND j2 > j3 THEN + numcreatures2 = numcreatures2 + 1 + IF RND > .5 THEN + vec(i, 4) = 14 + vec(i, 8) = 3 'species 2 male + ELSE + vec(i, 4) = 15 + vec(i, 8) = 4 'species 2 female + END IF + END IF + IF j3 > j1 AND j3 > j2 THEN + numcreatures3 = numcreatures3 + 1 + IF RND > .99 THEN + IF RND > .5 THEN + vec(i, 4) = 11 + vec(i, 8) = 5 'species 3 male + ELSE + vec(i, 4) = 11 + vec(i, 8) = 6 'species 3 female + END IF + END IF + END IF + END IF + 'move creature in random direction (to fix) + creaturexstep = (RND - .5) + creatureystep = (RND - .5) + creaturezstep = (RND - .5) + stepmag = SQR(creaturexstep ^ 2 + creatureystep ^ 2 + creaturezstep ^ 2) + creaturexstep = creaturexstep / stepmag + creatureystep = creatureystep / stepmag + creaturezstep = creaturezstep / stepmag + vec(i, 1) = vec(i, 1) + creaturexstep * vec(i, 5) * (1 + 1.5 / vec(i, 6)) + vec(i, 2) = vec(i, 2) + creatureystep * vec(i, 5) * (1 + 1.5 / vec(i, 6)) + vec(i, 3) = vec(i, 3) + creaturezstep * vec(i, 5) * (1 + 1.5 / vec(i, 6)) + 'collision with wall + IF vec(i, 1) >= gridxhalfsize THEN vec(i, 1) = vec(i, 1) - creaturexstep + IF vec(i, 1) <= -gridxhalfsize THEN vec(i, 1) = vec(i, 1) - creaturexstep + IF vec(i, 2) >= gridyhalfsize THEN vec(i, 2) = vec(i, 2) - creatureystep + IF vec(i, 2) <= -gridyhalfsize THEN vec(i, 2) = vec(i, 2) - creatureystep + IF vec(i, 3) >= gridzhalfsize THEN vec(i, 3) = vec(i, 3) - creaturezstep + IF vec(i, 3) <= -gridzhalfsize THEN vec(i, 3) = vec(i, 3) - creaturezstep + 'ckeck for collision with another creature + FOR j = 1 TO numcreatures + IF i <> j THEN + deltax = vec(i, 1) - vec(j, 1) + deltay = vec(i, 2) - vec(j, 2) + deltaz = vec(i, 3) - vec(j, 3) + deltar = SQR(deltax ^ 2 + deltay ^ 2 + deltaz ^ 2) + 'collision between mature creatures + IF deltar < (vec(i, 6) + vec(j, 6)) AND vec(i, 6) > 1.5 * creatureinitrad AND vec(j, 6) > 1.5 * creatureinitrad THEN + IF vec(i, 8) <> vec(j, 8) THEN 'collision between opposing genders + vec(i, 1) = vec(i, 1) - creaturexstep + vec(i, 2) = vec(i, 2) - creatureystep + vec(i, 3) = vec(i, 3) - creaturezstep + 'species 1 mating + IF vec(i, 8) >= 1 AND vec(i, 8) <= 2 AND vec(j, 8) >= 1 AND vec(j, 8) <= 2 THEN + IF RND > .95 THEN 'determine if offspring is mutates to species 2 + numcreatures1 = numcreatures1 - 1 + numcreatures2 = numcreatures2 + 1 + IF RND > .5 THEN 'determine gender of species 2 + vec(i, 4) = 14 + vec(i, 8) = 3 'species 2 male + ELSE + vec(i, 4) = 15 + vec(i, 8) = 4 'species 2 female + END IF + END IF + GOTO donemating + END IF + 'species 2 mating + IF vec(i, 8) >= 3 AND vec(i, 8) <= 4 AND vec(j, 8) >= 3 AND vec(j, 8) <= 4 THEN + IF RND > .95 THEN 'determine if offspring is mutates to species 3 + numcreatures2 = numcreatures2 - 1 + numcreatures3 = numcreatures3 + 1 + IF RND > .5 THEN 'determine gender of species 3 + vec(i, 4) = 11 + vec(i, 8) = 5 'species 3 male + ELSE + vec(i, 4) = 11 + vec(i, 8) = 6 'species 3 female + END IF + END IF + GOTO donemating + END IF + donemating: + vec(i, 6) = creatureinitrad + END IF + END IF + END IF + NEXT +NEXT +RETURN + +genscheme.neuron.init: +numneuralnodes = 75 +brainsize = 350 +pcountparticleorig = 0 +FOR i = 1 TO numneuralnodes + pcountparticleorig = pcountparticleorig + 1 + vec(pcountparticleorig, 1) = brainsize * (RND - .5) + vec(pcountparticleorig, 2) = brainsize * (RND - .5) + vec(pcountparticleorig, 3) = brainsize * (RND - .5) / 5 + vec(pcountparticleorig, 4) = 14 + vec(pcountparticleorig, 5) = i 'node index + vec(pcountparticleorig, 6) = -1 'stimulation index (-1 for no stimulation) + vec(pcountparticleorig, 7) = 0 'dead time counter +NEXT +FOR i = 1 TO numneuralnodes + FOR j = 2 TO 21 + pcountparticleorig = pcountparticleorig + 1 + neuronxstep = (RND - .5) + neuronystep = (RND - .5) + neuronzstep = (RND - .5) + stepmag = SQR(neuronxstep ^ 2 + neuronystep ^ 2 + neuronzstep ^ 2) + neuronxstep = neuronxstep / stepmag + neuronystep = neuronystep / stepmag + neuronzstep = neuronzstep / stepmag + vec(pcountparticleorig, 1) = vec(i, 1) + .25 * neuronxstep * (brainsize * RND) + vec(pcountparticleorig, 2) = vec(i, 2) + .25 * neuronystep * (brainsize * RND) + vec(pcountparticleorig, 3) = vec(i, 3) + .25 * neuronzstep * (brainsize * RND) / 3 + vec(pcountparticleorig, 4) = 7 + vec(pcountparticleorig, 5) = i + vec(pcountparticleorig, 6) = -1 + vec(pcountparticleorig, 7) = 0 + NEXT +NEXT +randomneuron = INT(RND * (pcountparticleorig - numneuralnodes)) + numneuralnodes +vec(randomneuron, 4) = 14 +vec(randomneuron, 6) = 1 +RETURN + +'Things to check: +'Question: is nhat.old a necessary construction? +'Question: is work.nhat a necessary construction? +'Unify snipworkpcount nomenclature +'There is an overall minus sign problem somewhere: +' doublets and particles clip differenetly for nearplane. +' This may have been solved. See comment below, too. +' The triplet snipping broke after I started playing with +' the normal vector. The temporary patch is the two calls of +' the function reverse.uvnhat. Triplet viewplane clipping has +' not been retested. +'The 'file' input mode for particle world has not been re- +' tested since the simple time animation setup, June 2013. + +genscheme.neuron.timeanimate: +FOR i = 1 TO numparticleorig + vecpuvsrev(i, 1) = vec(i, 1) + vecpuvsrev(i, 2) = vec(i, 2) + vecpuvsrev(i, 3) = vec(i, 3) + vecpuvsrev(i, 4) = vec(i, 4) + vecpuvsrev(i, 5) = vec(i, 5) + vecpuvsrev(i, 6) = vec(i, 6) + vecpuvsrev(i, 7) = vec(i, 7) +NEXT +FOR i = numneuralnodes + 1 TO numparticleorig + 'single neuron activates whole cluster if cluster is ready + IF vecpuvsrev(i, 6) = 1 AND vecpuvsrev(vecpuvsrev(i, 5), 6) = -1 AND vecpuvsrev(vecpuvsrev(i, 5), 7) = 0 THEN + vec(vec(i, 5), 6) = 1 + vec(vec(i, 5), 7) = 3000 + FOR j = numneuralnodes + 1 TO numparticleorig + IF vecpuvsrev(i, 5) = vecpuvsrev(j, 5) THEN + vec(j, 4) = 4 + vec(j, 6) = 1 + END IF + NEXT + END IF + 'cluster is fully active: probe neighbors and then become inactive + IF vecpuvsrev(i, 6) = 1 AND vecpuvsrev(vecpuvsrev(i, 5), 6) = 1 THEN + vec(i, 4) = 7 + vec(i, 6) = -1 + vec(vec(i, 5), 6) = -1 + FOR j = numneuralnodes + 1 TO numparticleorig + IF vecpuvsrev(i, 5) <> vecpuvsrev(j, 5) THEN + vecsep = SQR((vecpuvsrev(j, 1) - vecpuvsrev(i, 1)) ^ 2 + (vecpuvsrev(j, 2) - vecpuvsrev(i, 2)) ^ 2 + (vecpuvsrev(j, 3) - vecpuvsrev(i, 3)) ^ 2) + IF vecsep < 7 AND vecpuvsrev(j, 6) = -1 THEN + vec(j, 4) = 7 + vec(j, 6) = 1 + END IF + END IF + NEXT + END IF + IF vec(vec(i, 5), 7) > 0 THEN vec(vec(i, 5), 7) = vec(vec(i, 5), 7) - 1 +NEXT +RETURN + +'*' diff --git a/samples/3d-engine-prototypes/src/3dctrwgraph_fb64.zip b/samples/3d-engine-prototypes/src/3dctrwgraph_fb64.zip new file mode 100644 index 0000000..b31fa6a Binary files /dev/null and b/samples/3d-engine-prototypes/src/3dctrwgraph_fb64.zip differ diff --git a/samples/3d-grapher/img/screenshot.png b/samples/3d-grapher/img/screenshot.png new file mode 100644 index 0000000..f829cba Binary files /dev/null and b/samples/3d-grapher/img/screenshot.png differ diff --git a/samples/3d-grapher/index.md b/samples/3d-grapher/index.md new file mode 100644 index 0000000..873ae5d --- /dev/null +++ b/samples/3d-grapher/index.md @@ -0,0 +1,26 @@ +[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: 3D GRAPHER + +![screenshot.png](img/screenshot.png) + +### Authors + +[🐝 Ashish Kushwaha](../ashish-kushwaha.md) [🐝 STxAxTIC](../stxaxtic.md) + +### Description + +```text +3D Grapher made in QB64. +``` + +### File(s) + +* [3d-grapher---legacy.bas](src/3d-grapher---legacy.bas) +* [3d-grapher---parametric.bas](src/3d-grapher---parametric.bas) +* [3d-grapher.zip](src/3d-grapher.zip) + +🔗 [3d](../3d.md), [gl](../gl.md) + + +Reference: [github.com](https://github.com/AshishKingdom/3D-Grapher) diff --git a/samples/3d-grapher/src/3d-grapher---legacy.bas b/samples/3d-grapher/src/3d-grapher---legacy.bas new file mode 100644 index 0000000..5513ac9 --- /dev/null +++ b/samples/3d-grapher/src/3d-grapher---legacy.bas @@ -0,0 +1,714 @@ +'############################################################################## +'3D Grapher in QB64 using OpenGL +' +'Contributors: +' Ashish Kushwaha (primary) +' FellipeHeitor +' STxAxTIC +' +'See README.bm. + +OPTION _EXPLICIT + +REM $INCLUDE: 'sxript.bi' +REM $Include: 'sxmath.bi' + +DO UNTIL _SCREENEXISTS: LOOP +_TITLE "3D Grapher" + +SCREEN _NEWIMAGE(600, 600, 32) + +DECLARE LIBRARY + SUB gluLookAt (BYVAL eyeX#, BYVAL eyeY#, BYVAL eyeZ#, BYVAL centerX#, BYVAL centerY#, BYVAL centerZ#, BYVAL upX#, BYVAL upY#, BYVAL upZ#) +END DECLARE + +' Types. +TYPE rgb + r AS SINGLE + g AS SINGLE + b AS SINGLE +END TYPE + +' Master switch for SUB _GL(). +DIM SHARED glAllow AS INTEGER + +' Plot structure. +DIM SHARED mainEquation AS STRING +DIM SHARED shadeMap(100, 100) AS rgb +DIM SHARED vert(100, 100) + +' Plot settings. +DIM SHARED stepFactor AS DOUBLE +DIM SHARED zStretch AS DOUBLE + +' Camera settings. +DIM SHARED xRot AS DOUBLE +DIM SHARED yRot AS DOUBLE +DIM SHARED zoomFactor + +' Render settings. +DIM SHARED graph_render_mode + +' Initialize. +CALL setShades +stepFactor = .1 +zStretch = 5 +zoomFactor = 1.0 +mainEquation = "sin((x^2)-(y^2))" + +IF (COMMAND$ <> "") THEN + OPEN COMMAND$ FOR INPUT AS #1 + INPUT #1, mainEquation + CLOSE #1 +ELSE + CALL getEquation +END IF + +' Prime main loop. +CALL initSequence + +' Main loop. +DO + CALL mouseProcess + IF (glAllow = 0) THEN + CALL getEquation + CALL initSequence + END IF + CALL keyProcess + _LIMIT 60 +LOOP + +END + +SUB _GL () STATIC + IF (glAllow = 0) THEN EXIT SUB + + DIM x AS INTEGER + DIM z AS INTEGER + + ' Environment. + _glClear _GL_COLOR_BUFFER_BIT OR _GL_DEPTH_BUFFER_BIT + _glEnable _GL_DEPTH_TEST + _glEnable _GL_BLEND + _glMatrixMode _GL_PROJECTION + + _gluPerspective 50, 1, 0.1, 40 + _glMatrixMode _GL_MODELVIEW + + _glLoadIdentity + + gluLookAt 0, 7, 15, 0, 0, 0, 0, 1, 0 + + ' Set camera angle. + _glRotatef xRot, 1, 0, 0 + _glRotatef yRot, 0, 1, 0 + + ' Set camera zoom. + _glScalef zoomFactor, zoomFactor, zoomFactor + + ' Draw axes. + _glBegin _GL_LINES + _glLineWidth 2.0 + ' x-axis + _glColor3f 1, 0, 0 + _glVertex3f -5, 0, 0 + _glVertex3f 5, 0, 0 + ' z-axis + _glColor3f 0, 1, 0 + _glVertex3f 0, -5, 0 + _glVertex3f 0, 5, 0 + ' y-axis + _glColor3f 0, 0, 1 + _glVertex3f 0, 0, -5 + _glVertex3f 0, 0, 5 + _glEnd + + ' Draw the surface. + FOR z = -50 TO 49 + FOR x = -50 TO 49 + + ' Each square patch is really two triangles. + + IF (graph_render_mode = 1) THEN _glBegin _GL_TRIANGLE_STRIP ELSE _glBegin _GL_LINE_STRIP + _glColor4f shadeMap(x + 50, z + 50).r, shadeMap(x + 50, z + 50).g, shadeMap(x + 50, z + 50).b, 0.7 + _glLineWidth 1.0 + _glVertex3f x, vert(x + 50, z + 50), z + _glVertex3f x + 1, vert(x + 51, z + 50), z + _glVertex3f x, vert(x + 50, z + 51), z + 1 + _glEnd + + IF (graph_render_mode = 1) THEN _glBegin _GL_TRIANGLE_STRIP ELSE _glBegin _GL_LINE_STRIP + _glColor4f shadeMap(x + 50, z + 50).r, shadeMap(x + 50, z + 50).g, shadeMap(x + 50, z + 50).b, 0.7 + _glLineWidth 1.0 + _glVertex3f x + 1, vert(x + 51, z + 51), z + 1 + _glVertex3f x + 1, vert(x + 51, z + 50), z + _glVertex3f x, vert(x + 50, z + 51), z + 1 + _glEnd + + NEXT + NEXT + +END SUB + +'By Fellipe Heitor +FUNCTION INPUTBOX (tTitle$, tMessage$, InitialValue AS STRING, NewValue AS STRING, Selected) + 'INPUTBOX --------------------------------------------------------------------- + 'Show a dialog and allow user input. Returns 1 = OK or 2 = Cancel. ' + ' ' + '- tTitle$ is the desired dialog title. If not provided, it'll be "Input" ' + ' ' + '- tMessage$ is the prompt that'll be shown to the user. You can show ' + ' a multiline message by adding line breaks with CHR$(10). ' + ' ' + ' - InitialValue can be passed both as a string literal or as a variable. ' + ' ' + '- Actual user input is returned by altering NewValue, so it must be ' + ' passed as a variable. ' + ' ' + '- Selected indicates wheter the initial value will be preselected when the ' + ' dialog is first shown. -1 preselects the whole text; positive values ' + ' select only part of the initial value (from the character position passed ' + ' to the end of the initial value). ' + ' ' + 'Intended for use with 32-bit screen modes. ' + '------------------------------------------------------------------------------ + + 'Variable declaration: + DIM Message$, Title$, CharW AS INTEGER, MaxLen AS INTEGER + DIM lineBreak AS INTEGER, totalLines AS INTEGER, prevlinebreak AS INTEGER + DIM Cursor AS INTEGER, Selection.Start AS INTEGER, InputViewStart AS INTEGER + DIM FieldArea AS INTEGER, DialogH AS INTEGER, DialogW AS INTEGER + DIM DialogX AS INTEGER, DialogY AS INTEGER, InputField.X AS INTEGER + DIM TotalButtons AS INTEGER, B AS INTEGER, ButtonLine$ + DIM cb AS INTEGER, DIALOGRESULT AS INTEGER, i AS INTEGER + DIM message.X AS INTEGER, SetCursor#, cursorBlink% + DIM DefaultButton AS INTEGER, k AS LONG + DIM shiftDown AS _BYTE, ctrlDown AS _BYTE, Clip$ + DIM FindLF%, s1 AS INTEGER, s2 AS INTEGER + DIM Selection.Value$ + DIM prevCursor AS INTEGER, ss1 AS INTEGER, ss2 AS INTEGER, mb AS _BYTE + DIM mx AS INTEGER, my AS INTEGER, nmx AS INTEGER, nmy AS INTEGER + DIM FGColor AS LONG, BGColor AS LONG + + 'Data type used for the dialog buttons: + TYPE BUTTONSTYPE + ID AS LONG + CAPTION AS STRING * 120 + X AS INTEGER + Y AS INTEGER + W AS INTEGER + END TYPE + + 'Color constants. You can customize colors by changing these: + CONST TitleBarColor = _RGB32(0, 178, 179) + CONST DialogBGColor = _RGB32(255, 255, 255) + CONST TitleBarTextColor = _RGB32(0, 0, 0) + CONST DialogTextColor = _RGB32(0, 0, 0) + CONST InputFieldColor = _RGB32(200, 200, 200) + CONST InputFieldTextColor = _RGB32(0, 0, 0) + CONST SelectionColor = _RGBA32(127, 127, 127, 100) + + 'Initial variable setup: + Message$ = tMessage$ + Title$ = RTRIM$(LTRIM$(tTitle$)) + IF Title$ = "" THEN Title$ = "Input" + NewValue = RTRIM$(LTRIM$(InitialValue)) + DefaultButton = 1 + + 'Save the current drawing page so it can be restored later: + FGColor = _DEFAULTCOLOR + BGColor = _BACKGROUNDCOLOR + PCOPY 0, 1 + + 'Figure out the print width of a single character (in case user has a custom font applied) + CharW = _PRINTWIDTH("_") + + 'Place a color overlay over the old screen image so the focus is on the dialog: + LINE (0, 0)-STEP(_WIDTH - 1, _HEIGHT - 1), _RGBA32(170, 170, 170, 170), BF + + 'Message breakdown, in case CHR$(10) was used as line break: + REDIM MessageLines(1) AS STRING + MaxLen = 1 + DO + lineBreak = INSTR(lineBreak + 1, Message$, CHR$(10)) + IF lineBreak = 0 AND totalLines = 0 THEN + totalLines = 1 + MessageLines(1) = Message$ + MaxLen = LEN(Message$) + EXIT DO + ELSEIF lineBreak = 0 AND totalLines > 0 THEN + totalLines = totalLines + 1 + REDIM _PRESERVE MessageLines(1 TO totalLines) AS STRING + MessageLines(totalLines) = RIGHT$(Message$, LEN(Message$) - prevlinebreak + 1) + IF LEN(MessageLines(totalLines)) > MaxLen THEN MaxLen = LEN(MessageLines(totalLines)) + EXIT DO + END IF + IF totalLines = 0 THEN prevlinebreak = 1 + totalLines = totalLines + 1 + REDIM _PRESERVE MessageLines(1 TO totalLines) AS STRING + MessageLines(totalLines) = MID$(Message$, prevlinebreak, lineBreak - prevlinebreak) + IF LEN(MessageLines(totalLines)) > MaxLen THEN MaxLen = LEN(MessageLines(totalLines)) + prevlinebreak = lineBreak + 1 + LOOP + + Cursor = LEN(NewValue) + Selection.Start = 0 + InputViewStart = 1 + FieldArea = _WIDTH \ CharW - 4 + IF FieldArea > 62 THEN FieldArea = 62 + IF Selected > 0 THEN Selection.Start = Selected: Selected = -1 + + 'Calculate dialog dimensions and print coordinates: + DialogH = _FONTHEIGHT * (6 + totalLines) + 10 + DialogW = (CharW * FieldArea) + 10 + IF DialogW < MaxLen * CharW + 10 THEN DialogW = MaxLen * CharW + 10 + + DialogX = _WIDTH / 2 - DialogW / 2 + DialogY = _HEIGHT / 2 - DialogH / 2 + InputField.X = (DialogX + (DialogW / 2)) - (((FieldArea * CharW) - 10) / 2) - 4 + + 'Calculate button's print coordinates: + TotalButtons = 2 + DIM Buttons(1 TO TotalButtons) AS BUTTONSTYPE + B = 1 + Buttons(B).ID = 1: Buttons(B).CAPTION = "< OK >": B = B + 1 + Buttons(B).ID = 2: Buttons(B).CAPTION = "< Cancel >": B = B + 1 + ButtonLine$ = " " + FOR cb = 1 TO TotalButtons + ButtonLine$ = ButtonLine$ + RTRIM$(LTRIM$(Buttons(cb).CAPTION)) + " " + Buttons(cb).Y = DialogY + 5 + _FONTHEIGHT * (5 + totalLines) + Buttons(cb).W = _PRINTWIDTH(RTRIM$(LTRIM$(Buttons(cb).CAPTION))) + NEXT cb + Buttons(1).X = _WIDTH / 2 - _PRINTWIDTH(ButtonLine$) / 2 + FOR cb = 2 TO TotalButtons + Buttons(cb).X = Buttons(1).X + _PRINTWIDTH(SPACE$(INSTR(ButtonLine$, RTRIM$(LTRIM$(Buttons(cb).CAPTION))))) + NEXT cb + + 'Main loop: + DIALOGRESULT = 0 + _KEYCLEAR + DO: _LIMIT 500 + 'Draw the dialog. + LINE (DialogX, DialogY)-STEP(DialogW - 1, DialogH - 1), DialogBGColor, BF + LINE (DialogX, DialogY)-STEP(DialogW - 1, _FONTHEIGHT + 1), TitleBarColor, BF + COLOR TitleBarTextColor + _PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(Title$) / 2, DialogY + 1), Title$ + + COLOR DialogTextColor, _RGBA32(0, 0, 0, 0) + FOR i = 1 TO totalLines + message.X = _WIDTH / 2 - _PRINTWIDTH(MessageLines(i)) / 2 + _PRINTSTRING (message.X, DialogY + 5 + _FONTHEIGHT * (i + 1)), MessageLines(i) + NEXT i + + 'Draw the input field + LINE (InputField.X - 2, DialogY + 3 + _FONTHEIGHT * (3 + totalLines))-STEP(FieldArea * CharW, _FONTHEIGHT + 4), InputFieldColor, BF + COLOR InputFieldTextColor + _PRINTSTRING (InputField.X, DialogY + 5 + _FONTHEIGHT * (3 + totalLines)), MID$(NewValue, InputViewStart, FieldArea) + + 'Selection highlight: + GOSUB SelectionHighlight + + 'Cursor blink: + IF TIMER - SetCursor# > .4 THEN + SetCursor# = TIMER + IF cursorBlink% = 1 THEN cursorBlink% = 0 ELSE cursorBlink% = 1 + END IF + IF cursorBlink% = 1 THEN + LINE (InputField.X + (Cursor - (InputViewStart - 1)) * CharW, DialogY + 5 + _FONTHEIGHT * (3 + totalLines))-STEP(0, _FONTHEIGHT), _RGB32(0, 0, 0) + END IF + + 'Check if buttons have been clicked or are being hovered: + GOSUB CheckButtons + + 'Draw buttons: + FOR cb = 1 TO TotalButtons + _PRINTSTRING (Buttons(cb).X, Buttons(cb).Y), RTRIM$(LTRIM$(Buttons(cb).CAPTION)) + IF cb = DefaultButton THEN + COLOR _RGB32(255, 255, 0) + _PRINTSTRING (Buttons(cb).X, Buttons(cb).Y), "<" + SPACE$(LEN(RTRIM$(LTRIM$(Buttons(cb).CAPTION))) - 2) + ">" + COLOR _RGB32(0, 178, 179) + _PRINTSTRING (Buttons(cb).X - 1, Buttons(cb).Y - 1), "<" + SPACE$(LEN(RTRIM$(LTRIM$(Buttons(cb).CAPTION))) - 2) + ">" + COLOR _RGB32(0, 0, 0) + END IF + NEXT cb + + _DISPLAY + + 'Process input: + k = _KEYHIT + IF k = 100303 OR k = 100304 THEN shiftDown = -1 + IF k = -100303 OR k = -100304 THEN shiftDown = 0 + IF k = 100305 OR k = 100306 THEN ctrlDown = -1 + IF k = -100305 OR k = -100306 THEN ctrlDown = 0 + + SELECT CASE k + CASE 13: DIALOGRESULT = 1 + CASE 27: DIALOGRESULT = 2 + CASE 32 TO 126 'Printable ASCII characters + IF k = ASC("v") OR k = ASC("V") THEN 'Paste from clipboard (Ctrl+V) + IF ctrlDown THEN + Clip$ = _CLIPBOARD$ + FindLF% = INSTR(Clip$, CHR$(13)) + IF FindLF% > 0 THEN Clip$ = LEFT$(Clip$, FindLF% - 1) + FindLF% = INSTR(Clip$, CHR$(10)) + IF FindLF% > 0 THEN Clip$ = LEFT$(Clip$, FindLF% - 1) + IF LEN(RTRIM$(LTRIM$(Clip$))) > 0 THEN + IF NOT Selected THEN + IF Cursor = LEN(NewValue) THEN + NewValue = NewValue + Clip$ + Cursor = LEN(NewValue) + ELSE + NewValue = LEFT$(NewValue, Cursor) + Clip$ + MID$(NewValue, Cursor + 1) + Cursor = Cursor + LEN(Clip$) + END IF + ELSE + s1 = Selection.Start + s2 = Cursor + IF s1 > s2 THEN SWAP s1, s2 + NewValue = LEFT$(NewValue, s1) + Clip$ + MID$(NewValue, s2 + 1) + Cursor = s1 + LEN(Clip$) + Selected = 0 + END IF + END IF + k = 0 + END IF + ELSEIF k = ASC("c") OR k = ASC("C") THEN 'Copy selection to clipboard (Ctrl+C) + IF ctrlDown THEN + _CLIPBOARD$ = Selection.Value$ + k = 0 + END IF + ELSEIF k = ASC("x") OR k = ASC("X") THEN 'Cut selection to clipboard (Ctrl+X) + IF ctrlDown THEN + _CLIPBOARD$ = Selection.Value$ + GOSUB DeleteSelection + k = 0 + END IF + ELSEIF k = ASC("a") OR k = ASC("A") THEN 'Select all text (Ctrl+A) + IF ctrlDown THEN + Cursor = LEN(NewValue) + Selection.Start = 0 + Selected = -1 + k = 0 + END IF + END IF + + IF k > 0 THEN + IF NOT Selected THEN + IF Cursor = LEN(NewValue) THEN + NewValue = NewValue + CHR$(k) + Cursor = Cursor + 1 + ELSE + NewValue = LEFT$(NewValue, Cursor) + CHR$(k) + MID$(NewValue, Cursor + 1) + Cursor = Cursor + 1 + END IF + IF Cursor > FieldArea THEN InputViewStart = (Cursor - FieldArea) + 2 + ELSE + s1 = Selection.Start + s2 = Cursor + IF s1 > s2 THEN SWAP s1, s2 + NewValue = LEFT$(NewValue, s1) + CHR$(k) + MID$(NewValue, s2 + 1) + Selected = 0 + Cursor = s1 + 1 + END IF + END IF + CASE 8 'Backspace + IF LEN(NewValue) > 0 THEN + IF NOT Selected THEN + IF Cursor = LEN(NewValue) THEN + NewValue = LEFT$(NewValue, LEN(NewValue) - 1) + Cursor = Cursor - 1 + ELSEIF Cursor > 1 THEN + NewValue = LEFT$(NewValue, Cursor - 1) + MID$(NewValue, Cursor + 1) + Cursor = Cursor - 1 + ELSEIF Cursor = 1 THEN + NewValue = RIGHT$(NewValue, LEN(NewValue) - 1) + Cursor = Cursor - 1 + END IF + ELSE + GOSUB DeleteSelection + END IF + END IF + CASE 21248 'Delete + IF NOT Selected THEN + IF LEN(NewValue) > 0 THEN + IF Cursor = 0 THEN + NewValue = RIGHT$(NewValue, LEN(NewValue) - 1) + ELSEIF Cursor > 0 AND Cursor <= LEN(NewValue) - 1 THEN + NewValue = LEFT$(NewValue, Cursor) + MID$(NewValue, Cursor + 2) + END IF + END IF + ELSE + GOSUB DeleteSelection + END IF + CASE 19200 'Left arrow key + GOSUB CheckSelection + IF Cursor > 0 THEN Cursor = Cursor - 1 + CASE 19712 'Right arrow key + GOSUB CheckSelection + IF Cursor < LEN(NewValue) THEN Cursor = Cursor + 1 + CASE 18176 'Home + GOSUB CheckSelection + Cursor = 0 + CASE 20224 'End + GOSUB CheckSelection + Cursor = LEN(NewValue) + END SELECT + + 'Cursor adjustments: + GOSUB CursorAdjustments + LOOP UNTIL DIALOGRESULT > 0 + + _KEYCLEAR + INPUTBOX = DIALOGRESULT + + 'Restore previous display: + PCOPY 1, 0 + COLOR FGColor, BGColor + EXIT SUB + + CursorAdjustments: + IF Cursor > prevCursor THEN + IF Cursor - InputViewStart + 2 > FieldArea THEN InputViewStart = (Cursor - FieldArea) + 2 + ELSEIF Cursor < prevCursor THEN + IF Cursor < InputViewStart - 1 THEN InputViewStart = Cursor + END IF + prevCursor = Cursor + IF InputViewStart < 1 THEN InputViewStart = 1 + RETURN + + CheckSelection: + IF shiftDown = -1 THEN + IF Selected = 0 THEN + Selected = -1 + Selection.Start = Cursor + END IF + ELSEIF shiftDown = 0 THEN + Selected = 0 + END IF + RETURN + + DeleteSelection: + NewValue = LEFT$(NewValue, s1) + MID$(NewValue, s2 + 1) + Selected = 0 + Cursor = s1 + RETURN + + SelectionHighlight: + IF Selected THEN + s1 = Selection.Start + s2 = Cursor + IF s1 > s2 THEN + SWAP s1, s2 + IF InputViewStart > 1 THEN + ss1 = s1 - InputViewStart + 1 + ELSE + ss1 = s1 + END IF + ss2 = s2 - s1 + IF ss1 + ss2 > FieldArea THEN ss2 = FieldArea - ss1 + ELSE + ss1 = s1 + ss2 = s2 - s1 + IF ss1 < InputViewStart THEN ss1 = 0: ss2 = s2 - InputViewStart + 1 + IF ss1 > InputViewStart THEN ss1 = ss1 - InputViewStart + 1: ss2 = s2 - s1 + END IF + Selection.Value$ = MID$(NewValue, s1 + 1, s2 - s1) + + LINE (InputField.X + ss1 * CharW, DialogY + 5 + _FONTHEIGHT * (3 + totalLines))-STEP(ss2 * CharW, _FONTHEIGHT), _RGBA32(255, 255, 255, 150), BF + END IF + RETURN + + CheckButtons: + 'Hover highlight: + WHILE _MOUSEINPUT: WEND + mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY + FOR cb = 1 TO TotalButtons + IF (mx >= Buttons(cb).X) AND (mx <= Buttons(cb).X + Buttons(cb).W) THEN + IF (my >= Buttons(cb).Y) AND (my < Buttons(cb).Y + _FONTHEIGHT) THEN + LINE (Buttons(cb).X, Buttons(cb).Y)-STEP(Buttons(cb).W, _FONTHEIGHT - 1), _RGBA32(230, 230, 230, 235), BF + END IF + END IF + NEXT cb + + IF mb THEN + IF mx >= InputField.X AND my >= DialogY + 3 + _FONTHEIGHT * (3 + totalLines) AND mx <= InputField.X + (FieldArea * CharW - 10) AND my <= DialogY + 3 + _FONTHEIGHT * (3 + totalLines) + _FONTHEIGHT + 4 THEN + 'Clicking inside the text field positions the cursor + WHILE _MOUSEBUTTON(1) + _LIMIT 500 + mb = _MOUSEINPUT + WEND + Cursor = ((mx - InputField.X) / CharW) + (InputViewStart - 1) + IF Cursor > LEN(NewValue) THEN Cursor = LEN(NewValue) + Selected = 0 + RETURN + END IF + + FOR cb = 1 TO TotalButtons + IF (mx >= Buttons(cb).X) AND (mx <= Buttons(cb).X + Buttons(cb).W) THEN + IF (my >= Buttons(cb).Y) AND (my < Buttons(cb).Y + _FONTHEIGHT) THEN + DefaultButton = cb + WHILE _MOUSEBUTTON(1): _LIMIT 500: mb = _MOUSEINPUT: WEND + mb = 0: nmx = _MOUSEX: nmy = _MOUSEY + IF nmx = mx AND nmy = my THEN DIALOGRESULT = cb + RETURN + END IF + END IF + NEXT cb + END IF + RETURN +END FUNCTION + +FUNCTION hsb~& (__H AS _FLOAT, __S AS _FLOAT, __B AS _FLOAT, A AS _FLOAT) + 'method adapted form http://stackoverflow.com/questions/4106363/converting-rgb-to-hsb-colors + DIM H AS _FLOAT, S AS _FLOAT, B AS _FLOAT + + H = map(__H, 0, 255, 0, 360) + S = map(__S, 0, 255, 0, 1) + B = map(__B, 0, 255, 0, 1) + + IF S = 0 THEN + hsb~& = _RGBA32(B * 255, B * 255, B * 255, A) + EXIT FUNCTION + END IF + + DIM fmx AS _FLOAT, fmn AS _FLOAT + DIM fmd AS _FLOAT, iSextant AS INTEGER + DIM imx AS INTEGER, imd AS INTEGER, imn AS INTEGER + + IF B > .5 THEN + fmx = B - (B * S) + S + fmn = B + (B * S) - S + ELSE + fmx = B + (B * S) + fmn = B - (B * S) + END IF + + iSextant = INT(H / 60) + + IF H >= 300 THEN + H = H - 360 + END IF + + H = H / 60 + H = H - (2 * INT(((iSextant + 1) MOD 6) / 2)) + + IF iSextant MOD 2 = 0 THEN + fmd = (H * (fmx - fmn)) + fmn + ELSE + fmd = fmn - (H * (fmx - fmn)) + END IF + + imx = _ROUND(fmx * 255) + imd = _ROUND(fmd * 255) + imn = _ROUND(fmn * 255) + + SELECT CASE INT(iSextant) + CASE 1 + hsb~& = _RGBA32(imd, imx, imn, A) + CASE 2 + hsb~& = _RGBA32(imn, imx, imd, A) + CASE 3 + hsb~& = _RGBA32(imn, imd, imx, A) + CASE 4 + hsb~& = _RGBA32(imd, imn, imx, A) + CASE 5 + hsb~& = _RGBA32(imx, imn, imd, A) + CASE ELSE + hsb~& = _RGBA32(imx, imd, imn, A) + END SELECT +END FUNCTION + +SUB getEquation + DIM inputStatus AS INTEGER + CLS + inputStatus = INPUTBOX("Equation Editor", "Enter the expression for z = (ex. x*y)", mainEquation, mainEquation, -1) + IF (inputStatus = 2) THEN END +END SUB + +SUB initSequence + CLS + PRINT "Generating..." + _DISPLAY + CALL generatePlot(mainEquation) + CLS , 1 + COLOR , 1 + PRINT "z = " + mainEquation + _DISPLAY + _GLRENDER _BEHIND + graph_render_mode = 1 ' 1=solid surface, -1=lines + glAllow = 1 +END SUB + +SUB mouseProcess + DIM x AS DOUBLE + DIM y AS DOUBLE + WHILE _MOUSEINPUT + IF (zoomFactor > 0.1) THEN + zoomFactor = zoomFactor + _MOUSEWHEEL * 0.05 + ELSE + zoomFactor = 0.11 + END IF + WEND + IF (_MOUSEBUTTON(1)) THEN + x = _MOUSEX + y = _MOUSEY + WHILE _MOUSEBUTTON(1) + WHILE _MOUSEINPUT: WEND + yRot = yRot + (_MOUSEX - x) + xRot = xRot + (_MOUSEY - y) + x = _MOUSEX + y = _MOUSEY + WEND + END IF + IF (_MOUSEBUTTON(2)) THEN + glAllow = 0 + END IF +END SUB + +SUB keyProcess + DIM k AS INTEGER + k = _KEYHIT + IF (k = ASC(" ")) THEN graph_render_mode = graph_render_mode * -1 + _KEYCLEAR +END SUB + +SUB generatePlot (TheExpression AS STRING) + DIM x AS INTEGER + DIM z AS INTEGER + DIM i AS INTEGER + DIM ca AS STRING + DIM ex AS STRING + FOR x = -50 TO 50 + FOR z = -50 TO 50 + ex = "" + FOR i = 1 TO LEN(TheExpression) + ca = MID$(TheExpression, i, 1) + IF (LCASE$(ca) = "x") THEN ca = _TRIM$("(" + STR$(x * stepFactor) + ")") + IF (LCASE$(ca) = "y") THEN ca = _TRIM$("(" + STR$(z * stepFactor) + ")") + ex = ex + ca + NEXT + vert(x + 50, z + 50) = zStretch * VAL(SxriptEval(ex)) + NEXT + NEXT +END SUB + +SUB setShades + DIM x AS INTEGER + DIM z AS INTEGER + DIM c AS _UNSIGNED LONG + FOR x = -50 TO 50 + FOR z = -50 TO 50 + c = hsb(map(z, -50, 50, 0, 255), 255, 128, 255) + shadeMap(x + 50, z + 50).r = _RED(c) / 255 + shadeMap(x + 50, z + 50).g = _GREEN(c) / 255 + shadeMap(x + 50, z + 50).b = _BLUE(c) / 255 + NEXT + NEXT +END SUB + +FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!) + map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange! +END FUNCTION + +REM $INCLUDE: 'sxript.bm' +REM $Include: 'sxmath.bm' diff --git a/samples/3d-grapher/src/3d-grapher---parametric.bas b/samples/3d-grapher/src/3d-grapher---parametric.bas new file mode 100644 index 0000000..f82880a --- /dev/null +++ b/samples/3d-grapher/src/3d-grapher---parametric.bas @@ -0,0 +1,770 @@ +'############################################################################## +'3D Grapher in QB64 using OpenGL +' +'Contributors: +' Ashish Kushwaha +' FellipeHeitor +' STxAxTIC +' +'See README.bm. + +OPTION _EXPLICIT + +REM $INCLUDE: 'sxript.bi' +REM $Include: 'sxmath.bi' + +DO UNTIL _SCREENEXISTS: LOOP +_TITLE "3D Grapher" + +_ACCEPTFILEDROP + +SCREEN _NEWIMAGE(600, 600, 32) + +DECLARE LIBRARY + SUB gluLookAt (BYVAL eyeX#, BYVAL eyeY#, BYVAL eyeZ#, BYVAL centerX#, BYVAL centerY#, BYVAL centerZ#, BYVAL upX#, BYVAL upY#, BYVAL upZ#) +END DECLARE + +' Types. +TYPE rgb + r AS SINGLE + g AS SINGLE + b AS SINGLE +END TYPE + +TYPE vector + x AS DOUBLE + y AS DOUBLE + z AS DOUBLE +END TYPE + +TYPE paraSpec + p AS INTEGER + i AS STRING + x AS STRING + y AS STRING + z AS STRING +END TYPE + +' Master switch for SUB _GL(). +DIM SHARED glAllow AS INTEGER + +' Plot structure. +DIM SHARED mainEquation AS paraSpec +DIM SHARED paraVert1(2500) AS vector +DIM SHARED paraVert2(50, 50) AS vector +DIM SHARED paraShade1(2500) AS rgb +DIM SHARED paraShade2(50, 50) AS rgb + +' Camera settings. +DIM SHARED xRot AS DOUBLE +DIM SHARED yRot AS DOUBLE +DIM SHARED zoomFactor + +' Render settings. +DIM SHARED graph_render_mode + +' Initialize. +zoomFactor = 1.0 +CALL setShade + +' Sphere +mainEquation.p = 2 +mainEquation.i = "" +mainEquation.x = "15 * sin([theta]) * cos([phi])" +mainEquation.y = "15 * sin([theta]) * sin([phi])" +mainEquation.z = "15 * cos([theta])" + +IF (COMMAND$ <> "") THEN + OPEN COMMAND$ FOR INPUT AS #1 + INPUT #1, mainEquation.p ' number of parameters + LINE INPUT #1, mainEquation.i ' helper calcuations + LINE INPUT #1, mainEquation.x ' x-equation + LINE INPUT #1, mainEquation.y ' y-equation + LINE INPUT #1, mainEquation.z ' z-equation + CLOSE #1 +END IF + +' Prime main loop. +CALL initSequence + +' Main loop. +DO + CALL mouseProcess + CALL keyProcess + CALL CheckFile + _LIMIT 60 +LOOP + +END + +SUB _GL () STATIC + IF (glAllow = 0) THEN EXIT SUB + + ' Environment. + _glClear _GL_COLOR_BUFFER_BIT OR _GL_DEPTH_BUFFER_BIT + _glEnable _GL_DEPTH_TEST + _glEnable _GL_BLEND + _glMatrixMode _GL_PROJECTION + + _gluPerspective 50, 1, 0.1, 40 + _glMatrixMode _GL_MODELVIEW + + _glLoadIdentity + + gluLookAt 0, 7, 15, 0, 0, 0, 0, 1, 0 + + ' Set camera angle. + _glRotatef xRot, 1, 0, 0 + _glRotatef yRot, 0, 1, 0 + + ' Set camera zoom. + _glScalef zoomFactor, zoomFactor, zoomFactor + + ' Draw axes. + _glBegin _GL_LINES + _glLineWidth 2.0 + ' x-axis + _glColor3f 1, 0, 0 + _glVertex3f -5, 0, 0 + _glVertex3f 5, 0, 0 + ' z-axis + _glColor3f 0, 1, 0 + _glVertex3f 0, -5, 0 + _glVertex3f 0, 5, 0 + ' y-axis + _glColor3f 0, 0, 1 + _glVertex3f 0, 0, -5 + _glVertex3f 0, 0, 5 + _glEnd + + ' Draw the surface. + DIM k1 AS INTEGER + DIM k2 AS INTEGER + IF (mainEquation.p = 1) THEN + FOR k1 = 1 TO 2500 - 1 + _glBegin _GL_LINE_STRIP + _glColor4f paraShade1(k1).r, paraShade1(k1).g, paraShade1(k1).b, 1 + _glLineWidth 1.0 + _glVertex3f paraVert1(k1).x, paraVert1(k1).z, paraVert1(k1).y + _glVertex3f paraVert1(k1 + 1).x, paraVert1(k1 + 1).z, paraVert1(k1 + 1).y + _glEnd + NEXT + END IF + IF (mainEquation.p = 2) THEN + FOR k1 = 1 TO 50 - 1 + FOR k2 = 1 TO 50 - 1 + IF (graph_render_mode = 1) THEN _glBegin _GL_TRIANGLE_STRIP ELSE _glBegin _GL_LINE_STRIP + _glColor4f paraShade2(k1, k2).r, paraShade2(k1, k2).g, paraShade2(k1, k2).b, 1 + _glLineWidth 1.0 + _glVertex3f paraVert2(k1, k2).x, paraVert2(k1, k2).z, paraVert2(k1, k2).y + _glVertex3f paraVert2(k1 + 1, k2).x, paraVert2(k1 + 1, k2).z, paraVert2(k1 + 1, k2).y + _glVertex3f paraVert2(k1 + 1, k2 + 1).x, paraVert2(k1 + 1, k2 + 1).z, paraVert2(k1 + 1, k2 + 1).y + _glEnd + + IF (graph_render_mode = 1) THEN _glBegin _GL_TRIANGLE_STRIP ELSE _glBegin _GL_LINE_STRIP + _glColor4f paraShade2(k1, k2).r, paraShade2(k1, k2).g, paraShade2(k1, k2).b, 1 + _glLineWidth 1.0 + _glVertex3f paraVert2(k1, k2).x, paraVert2(k1, k2).z, paraVert2(k1, k2).y + _glVertex3f paraVert2(k1, k2 + 1).x, paraVert2(k1, k2 + 1).z, paraVert2(k1, k2 + 1).y + _glVertex3f paraVert2(k1 + 1, k2 + 1).x, paraVert2(k1 + 1, k2 + 1).z, paraVert2(k1 + 1, k2 + 1).y + _glEnd + NEXT + NEXT + END IF +END SUB + +SUB initSequence + CLS + PRINT "Generating..." + _DISPLAY + CALL generatePlot + CLS , 1 + COLOR , 1 + 'PRINT "(params) = " + mainEquation.i + PRINT "x = " + mainEquation.x + PRINT "y = " + mainEquation.y + PRINT "z = " + mainEquation.z + _DISPLAY + _GLRENDER _BEHIND + graph_render_mode = -1 ' 1=solid surface, -1=lines + glAllow = 1 +END SUB + +SUB mouseProcess + DIM x AS DOUBLE + DIM y AS DOUBLE + WHILE _MOUSEINPUT + IF (zoomFactor > 0.1) THEN + zoomFactor = zoomFactor + _MOUSEWHEEL * 0.05 + ELSE + zoomFactor = 0.11 + END IF + WEND + IF (_MOUSEBUTTON(1)) THEN + x = _MOUSEX + y = _MOUSEY + WHILE _MOUSEBUTTON(1) + WHILE _MOUSEINPUT: WEND + yRot = yRot + (_MOUSEX - x) + xRot = xRot + (_MOUSEY - y) + x = _MOUSEX + y = _MOUSEY + WEND + END IF +END SUB + +SUB keyProcess + DIM k AS INTEGER + k = _KEYHIT + IF (k = ASC(" ")) THEN graph_render_mode = graph_render_mode * -1 + _KEYCLEAR +END SUB + +SUB CheckFile + DIM theFile AS STRING + IF (_TOTALDROPPEDFILES > 0) THEN + IF (_FILEEXISTS(_DROPPEDFILE$(1))) THEN + glAllow = 0 + theFile = _DROPPEDFILE$(1) + OPEN theFile FOR INPUT AS #1 + INPUT #1, mainEquation.p + LINE INPUT #1, mainEquation.i + LINE INPUT #1, mainEquation.x + LINE INPUT #1, mainEquation.y + LINE INPUT #1, mainEquation.z + CLOSE #1 + CALL initSequence + glAllow = 1 + END IF + _FINISHDROP + END IF +END SUB + +SUB generatePlot + DIM a AS STRING + DIM k1 AS INTEGER + DIM k2 AS INTEGER + IF (mainEquation.p = 1) THEN + FOR k1 = 1 TO 2500 + a = SxriptEval$("let(u," + STR$(k1) + ")") + a = SxriptEval$(mainEquation.i) + paraVert1(k1).x = VAL(SxriptEval$(mainEquation.x)) + paraVert1(k1).y = VAL(SxriptEval$(mainEquation.y)) + paraVert1(k1).z = VAL(SxriptEval$(mainEquation.z)) + NEXT + END IF + IF (mainEquation.p = 2) THEN + FOR k1 = 1 TO 50 + FOR k2 = 1 TO 50 + a = SxriptEval$("let(u," + STR$(k1) + ")") + a = SxriptEval$("let(v," + STR$(k2) + ")") + a = SxriptEval$(mainEquation.i) + paraVert2(k1, k2).x = VAL(SxriptEval$(mainEquation.x)) + paraVert2(k1, k2).y = VAL(SxriptEval$(mainEquation.y)) + paraVert2(k1, k2).z = VAL(SxriptEval$(mainEquation.z)) + NEXT + NEXT + END IF +END SUB + +SUB setShade + DIM k1 AS INTEGER + DIM k2 AS INTEGER + FOR k1 = 1 TO 2500 + paraShade1(k1).r = 1 - k1 / 2500 + paraShade1(k1).g = .25 + paraShade1(k1).b = k1 / 2500 + NEXT + FOR k1 = 1 TO 50 + FOR k2 = 1 TO 50 + paraShade2(k1, k2).r = .1 + .9 * SIN(3.14159 * k1 / 50) ^ 2 + paraShade2(k1, k2).g = 0 + paraShade2(k1, k2).b = 1 - .9 * SIN(3.14159 * k2 / 50) ^ 2 + NEXT + NEXT +END SUB + +REM $INCLUDE: 'sxript.bm' +REM $Include: 'sxmath.bm' + +''' LEGACY CODE + +''By Fellipe Heitor +'FUNCTION INPUTBOX (tTitle$, tMessage$, InitialValue AS STRING, NewValue AS STRING, Selected) +' 'INPUTBOX --------------------------------------------------------------------- +' 'Show a dialog and allow user input. Returns 1 = OK or 2 = Cancel. ' +' ' ' +' '- tTitle$ is the desired dialog title. If not provided, it'll be "Input" ' +' ' ' +' '- tMessage$ is the prompt that'll be shown to the user. You can show ' +' ' a multiline message by adding line breaks with CHR$(10). ' +' ' ' +' ' - InitialValue can be passed both as a string literal or as a variable. ' +' ' ' +' '- Actual user input is returned by altering NewValue, so it must be ' +' ' passed as a variable. ' +' ' ' +' '- Selected indicates wheter the initial value will be preselected when the ' +' ' dialog is first shown. -1 preselects the whole text; positive values ' +' ' select only part of the initial value (from the character position passed ' +' ' to the end of the initial value). ' +' ' ' +' 'Intended for use with 32-bit screen modes. ' +' '------------------------------------------------------------------------------ + +' 'Variable declaration: +' DIM Message$, Title$, CharW AS INTEGER, MaxLen AS INTEGER +' DIM lineBreak AS INTEGER, totalLines AS INTEGER, prevlinebreak AS INTEGER +' DIM Cursor AS INTEGER, Selection.Start AS INTEGER, InputViewStart AS INTEGER +' DIM FieldArea AS INTEGER, DialogH AS INTEGER, DialogW AS INTEGER +' DIM DialogX AS INTEGER, DialogY AS INTEGER, InputField.X AS INTEGER +' DIM TotalButtons AS INTEGER, B AS INTEGER, ButtonLine$ +' DIM cb AS INTEGER, DIALOGRESULT AS INTEGER, i AS INTEGER +' DIM message.X AS INTEGER, SetCursor#, cursorBlink% +' DIM DefaultButton AS INTEGER, k AS LONG +' DIM shiftDown AS _BYTE, ctrlDown AS _BYTE, Clip$ +' DIM FindLF%, s1 AS INTEGER, s2 AS INTEGER +' DIM Selection.Value$ +' DIM prevCursor AS INTEGER, ss1 AS INTEGER, ss2 AS INTEGER, mb AS _BYTE +' DIM mx AS INTEGER, my AS INTEGER, nmx AS INTEGER, nmy AS INTEGER +' DIM FGColor AS LONG, BGColor AS LONG + +' 'Data type used for the dialog buttons: +' TYPE BUTTONSTYPE +' ID AS LONG +' CAPTION AS STRING * 120 +' X AS INTEGER +' Y AS INTEGER +' W AS INTEGER +' END TYPE + +' 'Color constants. You can customize colors by changing these: +' CONST TitleBarColor = _RGB32(0, 178, 179) +' CONST DialogBGColor = _RGB32(255, 255, 255) +' CONST TitleBarTextColor = _RGB32(0, 0, 0) +' CONST DialogTextColor = _RGB32(0, 0, 0) +' CONST InputFieldColor = _RGB32(200, 200, 200) +' CONST InputFieldTextColor = _RGB32(0, 0, 0) +' CONST SelectionColor = _RGBA32(127, 127, 127, 100) + +' 'Initial variable setup: +' Message$ = tMessage$ +' Title$ = RTRIM$(LTRIM$(tTitle$)) +' IF Title$ = "" THEN Title$ = "Input" +' NewValue = RTRIM$(LTRIM$(InitialValue)) +' DefaultButton = 1 + +' 'Save the current drawing page so it can be restored later: +' FGColor = _DEFAULTCOLOR +' BGColor = _BACKGROUNDCOLOR +' PCOPY 0, 1 + +' 'Figure out the print width of a single character (in case user has a custom font applied) +' CharW = _PRINTWIDTH("_") + +' 'Place a color overlay over the old screen image so the focus is on the dialog: +' LINE (0, 0)-STEP(_WIDTH - 1, _HEIGHT - 1), _RGBA32(170, 170, 170, 170), BF + +' 'Message breakdown, in case CHR$(10) was used as line break: +' REDIM MessageLines(1) AS STRING +' MaxLen = 1 +' DO +' lineBreak = INSTR(lineBreak + 1, Message$, CHR$(10)) +' IF lineBreak = 0 AND totalLines = 0 THEN +' totalLines = 1 +' MessageLines(1) = Message$ +' MaxLen = LEN(Message$) +' EXIT DO +' ELSEIF lineBreak = 0 AND totalLines > 0 THEN +' totalLines = totalLines + 1 +' REDIM _PRESERVE MessageLines(1 TO totalLines) AS STRING +' MessageLines(totalLines) = RIGHT$(Message$, LEN(Message$) - prevlinebreak + 1) +' IF LEN(MessageLines(totalLines)) > MaxLen THEN MaxLen = LEN(MessageLines(totalLines)) +' EXIT DO +' END IF +' IF totalLines = 0 THEN prevlinebreak = 1 +' totalLines = totalLines + 1 +' REDIM _PRESERVE MessageLines(1 TO totalLines) AS STRING +' MessageLines(totalLines) = MID$(Message$, prevlinebreak, lineBreak - prevlinebreak) +' IF LEN(MessageLines(totalLines)) > MaxLen THEN MaxLen = LEN(MessageLines(totalLines)) +' prevlinebreak = lineBreak + 1 +' LOOP + +' Cursor = LEN(NewValue) +' Selection.Start = 0 +' InputViewStart = 1 +' FieldArea = _WIDTH \ CharW - 4 +' IF FieldArea > 62 THEN FieldArea = 62 +' IF Selected > 0 THEN Selection.Start = Selected: Selected = -1 + +' 'Calculate dialog dimensions and print coordinates: +' DialogH = _FONTHEIGHT * (6 + totalLines) + 10 +' DialogW = (CharW * FieldArea) + 10 +' IF DialogW < MaxLen * CharW + 10 THEN DialogW = MaxLen * CharW + 10 + +' DialogX = _WIDTH / 2 - DialogW / 2 +' DialogY = _HEIGHT / 2 - DialogH / 2 +' InputField.X = (DialogX + (DialogW / 2)) - (((FieldArea * CharW) - 10) / 2) - 4 + +' 'Calculate button's print coordinates: +' TotalButtons = 2 +' DIM Buttons(1 TO TotalButtons) AS BUTTONSTYPE +' B = 1 +' Buttons(B).ID = 1: Buttons(B).CAPTION = "< OK >": B = B + 1 +' Buttons(B).ID = 2: Buttons(B).CAPTION = "< Cancel >": B = B + 1 +' ButtonLine$ = " " +' FOR cb = 1 TO TotalButtons +' ButtonLine$ = ButtonLine$ + RTRIM$(LTRIM$(Buttons(cb).CAPTION)) + " " +' Buttons(cb).Y = DialogY + 5 + _FONTHEIGHT * (5 + totalLines) +' Buttons(cb).W = _PRINTWIDTH(RTRIM$(LTRIM$(Buttons(cb).CAPTION))) +' NEXT cb +' Buttons(1).X = _WIDTH / 2 - _PRINTWIDTH(ButtonLine$) / 2 +' FOR cb = 2 TO TotalButtons +' Buttons(cb).X = Buttons(1).X + _PRINTWIDTH(SPACE$(INSTR(ButtonLine$, RTRIM$(LTRIM$(Buttons(cb).CAPTION))))) +' NEXT cb + +' 'Main loop: +' DIALOGRESULT = 0 +' _KEYCLEAR +' DO: _LIMIT 500 +' 'Draw the dialog. +' LINE (DialogX, DialogY)-STEP(DialogW - 1, DialogH - 1), DialogBGColor, BF +' LINE (DialogX, DialogY)-STEP(DialogW - 1, _FONTHEIGHT + 1), TitleBarColor, BF +' COLOR TitleBarTextColor +' _PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(Title$) / 2, DialogY + 1), Title$ + +' COLOR DialogTextColor, _RGBA32(0, 0, 0, 0) +' FOR i = 1 TO totalLines +' message.X = _WIDTH / 2 - _PRINTWIDTH(MessageLines(i)) / 2 +' _PRINTSTRING (message.X, DialogY + 5 + _FONTHEIGHT * (i + 1)), MessageLines(i) +' NEXT i + +' 'Draw the input field +' LINE (InputField.X - 2, DialogY + 3 + _FONTHEIGHT * (3 + totalLines))-STEP(FieldArea * CharW, _FONTHEIGHT + 4), InputFieldColor, BF +' COLOR InputFieldTextColor +' _PRINTSTRING (InputField.X, DialogY + 5 + _FONTHEIGHT * (3 + totalLines)), MID$(NewValue, InputViewStart, FieldArea) + +' 'Selection highlight: +' GOSUB SelectionHighlight + +' 'Cursor blink: +' IF TIMER - SetCursor# > .4 THEN +' SetCursor# = TIMER +' IF cursorBlink% = 1 THEN cursorBlink% = 0 ELSE cursorBlink% = 1 +' END IF +' IF cursorBlink% = 1 THEN +' LINE (InputField.X + (Cursor - (InputViewStart - 1)) * CharW, DialogY + 5 + _FONTHEIGHT * (3 + totalLines))-STEP(0, _FONTHEIGHT), _RGB32(0, 0, 0) +' END IF + +' 'Check if buttons have been clicked or are being hovered: +' GOSUB CheckButtons + +' 'Draw buttons: +' FOR cb = 1 TO TotalButtons +' _PRINTSTRING (Buttons(cb).X, Buttons(cb).Y), RTRIM$(LTRIM$(Buttons(cb).CAPTION)) +' IF cb = DefaultButton THEN +' COLOR _RGB32(255, 255, 0) +' _PRINTSTRING (Buttons(cb).X, Buttons(cb).Y), "<" + SPACE$(LEN(RTRIM$(LTRIM$(Buttons(cb).CAPTION))) - 2) + ">" +' COLOR _RGB32(0, 178, 179) +' _PRINTSTRING (Buttons(cb).X - 1, Buttons(cb).Y - 1), "<" + SPACE$(LEN(RTRIM$(LTRIM$(Buttons(cb).CAPTION))) - 2) + ">" +' COLOR _RGB32(0, 0, 0) +' END IF +' NEXT cb + +' _DISPLAY + +' 'Process input: +' k = _KEYHIT +' IF k = 100303 OR k = 100304 THEN shiftDown = -1 +' IF k = -100303 OR k = -100304 THEN shiftDown = 0 +' IF k = 100305 OR k = 100306 THEN ctrlDown = -1 +' IF k = -100305 OR k = -100306 THEN ctrlDown = 0 + +' SELECT CASE k +' CASE 13: DIALOGRESULT = 1 +' CASE 27: DIALOGRESULT = 2 +' CASE 32 TO 126 'Printable ASCII characters +' IF k = ASC("v") OR k = ASC("V") THEN 'Paste from clipboard (Ctrl+V) +' IF ctrlDown THEN +' Clip$ = _CLIPBOARD$ +' FindLF% = INSTR(Clip$, CHR$(13)) +' IF FindLF% > 0 THEN Clip$ = LEFT$(Clip$, FindLF% - 1) +' FindLF% = INSTR(Clip$, CHR$(10)) +' IF FindLF% > 0 THEN Clip$ = LEFT$(Clip$, FindLF% - 1) +' IF LEN(RTRIM$(LTRIM$(Clip$))) > 0 THEN +' IF NOT Selected THEN +' IF Cursor = LEN(NewValue) THEN +' NewValue = NewValue + Clip$ +' Cursor = LEN(NewValue) +' ELSE +' NewValue = LEFT$(NewValue, Cursor) + Clip$ + MID$(NewValue, Cursor + 1) +' Cursor = Cursor + LEN(Clip$) +' END IF +' ELSE +' s1 = Selection.Start +' s2 = Cursor +' IF s1 > s2 THEN SWAP s1, s2 +' NewValue = LEFT$(NewValue, s1) + Clip$ + MID$(NewValue, s2 + 1) +' Cursor = s1 + LEN(Clip$) +' Selected = 0 +' END IF +' END IF +' k = 0 +' END IF +' ELSEIF k = ASC("c") OR k = ASC("C") THEN 'Copy selection to clipboard (Ctrl+C) +' IF ctrlDown THEN +' _CLIPBOARD$ = Selection.Value$ +' k = 0 +' END IF +' ELSEIF k = ASC("x") OR k = ASC("X") THEN 'Cut selection to clipboard (Ctrl+X) +' IF ctrlDown THEN +' _CLIPBOARD$ = Selection.Value$ +' GOSUB DeleteSelection +' k = 0 +' END IF +' ELSEIF k = ASC("a") OR k = ASC("A") THEN 'Select all text (Ctrl+A) +' IF ctrlDown THEN +' Cursor = LEN(NewValue) +' Selection.Start = 0 +' Selected = -1 +' k = 0 +' END IF +' END IF + +' IF k > 0 THEN +' IF NOT Selected THEN +' IF Cursor = LEN(NewValue) THEN +' NewValue = NewValue + CHR$(k) +' Cursor = Cursor + 1 +' ELSE +' NewValue = LEFT$(NewValue, Cursor) + CHR$(k) + MID$(NewValue, Cursor + 1) +' Cursor = Cursor + 1 +' END IF +' IF Cursor > FieldArea THEN InputViewStart = (Cursor - FieldArea) + 2 +' ELSE +' s1 = Selection.Start +' s2 = Cursor +' IF s1 > s2 THEN SWAP s1, s2 +' NewValue = LEFT$(NewValue, s1) + CHR$(k) + MID$(NewValue, s2 + 1) +' Selected = 0 +' Cursor = s1 + 1 +' END IF +' END IF +' CASE 8 'Backspace +' IF LEN(NewValue) > 0 THEN +' IF NOT Selected THEN +' IF Cursor = LEN(NewValue) THEN +' NewValue = LEFT$(NewValue, LEN(NewValue) - 1) +' Cursor = Cursor - 1 +' ELSEIF Cursor > 1 THEN +' NewValue = LEFT$(NewValue, Cursor - 1) + MID$(NewValue, Cursor + 1) +' Cursor = Cursor - 1 +' ELSEIF Cursor = 1 THEN +' NewValue = RIGHT$(NewValue, LEN(NewValue) - 1) +' Cursor = Cursor - 1 +' END IF +' ELSE +' GOSUB DeleteSelection +' END IF +' END IF +' CASE 21248 'Delete +' IF NOT Selected THEN +' IF LEN(NewValue) > 0 THEN +' IF Cursor = 0 THEN +' NewValue = RIGHT$(NewValue, LEN(NewValue) - 1) +' ELSEIF Cursor > 0 AND Cursor <= LEN(NewValue) - 1 THEN +' NewValue = LEFT$(NewValue, Cursor) + MID$(NewValue, Cursor + 2) +' END IF +' END IF +' ELSE +' GOSUB DeleteSelection +' END IF +' CASE 19200 'Left arrow key +' GOSUB CheckSelection +' IF Cursor > 0 THEN Cursor = Cursor - 1 +' CASE 19712 'Right arrow key +' GOSUB CheckSelection +' IF Cursor < LEN(NewValue) THEN Cursor = Cursor + 1 +' CASE 18176 'Home +' GOSUB CheckSelection +' Cursor = 0 +' CASE 20224 'End +' GOSUB CheckSelection +' Cursor = LEN(NewValue) +' END SELECT + +' 'Cursor adjustments: +' GOSUB CursorAdjustments +' LOOP UNTIL DIALOGRESULT > 0 + +' _KEYCLEAR +' INPUTBOX = DIALOGRESULT + +' 'Restore previous display: +' PCOPY 1, 0 +' COLOR FGColor, BGColor +' EXIT SUB + +' CursorAdjustments: +' IF Cursor > prevCursor THEN +' IF Cursor - InputViewStart + 2 > FieldArea THEN InputViewStart = (Cursor - FieldArea) + 2 +' ELSEIF Cursor < prevCursor THEN +' IF Cursor < InputViewStart - 1 THEN InputViewStart = Cursor +' END IF +' prevCursor = Cursor +' IF InputViewStart < 1 THEN InputViewStart = 1 +' RETURN + +' CheckSelection: +' IF shiftDown = -1 THEN +' IF Selected = 0 THEN +' Selected = -1 +' Selection.Start = Cursor +' END IF +' ELSEIF shiftDown = 0 THEN +' Selected = 0 +' END IF +' RETURN + +' DeleteSelection: +' NewValue = LEFT$(NewValue, s1) + MID$(NewValue, s2 + 1) +' Selected = 0 +' Cursor = s1 +' RETURN + +' SelectionHighlight: +' IF Selected THEN +' s1 = Selection.Start +' s2 = Cursor +' IF s1 > s2 THEN +' SWAP s1, s2 +' IF InputViewStart > 1 THEN +' ss1 = s1 - InputViewStart + 1 +' ELSE +' ss1 = s1 +' END IF +' ss2 = s2 - s1 +' IF ss1 + ss2 > FieldArea THEN ss2 = FieldArea - ss1 +' ELSE +' ss1 = s1 +' ss2 = s2 - s1 +' IF ss1 < InputViewStart THEN ss1 = 0: ss2 = s2 - InputViewStart + 1 +' IF ss1 > InputViewStart THEN ss1 = ss1 - InputViewStart + 1: ss2 = s2 - s1 +' END IF +' Selection.Value$ = MID$(NewValue, s1 + 1, s2 - s1) + +' LINE (InputField.X + ss1 * CharW, DialogY + 5 + _FONTHEIGHT * (3 + totalLines))-STEP(ss2 * CharW, _FONTHEIGHT), _RGBA32(255, 255, 255, 150), BF +' END IF +' RETURN + +' CheckButtons: +' 'Hover highlight: +' WHILE _MOUSEINPUT: WEND +' mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY +' FOR cb = 1 TO TotalButtons +' IF (mx >= Buttons(cb).X) AND (mx <= Buttons(cb).X + Buttons(cb).W) THEN +' IF (my >= Buttons(cb).Y) AND (my < Buttons(cb).Y + _FONTHEIGHT) THEN +' LINE (Buttons(cb).X, Buttons(cb).Y)-STEP(Buttons(cb).W, _FONTHEIGHT - 1), _RGBA32(230, 230, 230, 235), BF +' END IF +' END IF +' NEXT cb + +' IF mb THEN +' IF mx >= InputField.X AND my >= DialogY + 3 + _FONTHEIGHT * (3 + totalLines) AND mx <= InputField.X + (FieldArea * CharW - 10) AND my <= DialogY + 3 + _FONTHEIGHT * (3 + totalLines) + _FONTHEIGHT + 4 THEN +' 'Clicking inside the text field positions the cursor +' WHILE _MOUSEBUTTON(1) +' _LIMIT 500 +' mb = _MOUSEINPUT +' WEND +' Cursor = ((mx - InputField.X) / CharW) + (InputViewStart - 1) +' IF Cursor > LEN(NewValue) THEN Cursor = LEN(NewValue) +' Selected = 0 +' RETURN +' END IF + +' FOR cb = 1 TO TotalButtons +' IF (mx >= Buttons(cb).X) AND (mx <= Buttons(cb).X + Buttons(cb).W) THEN +' IF (my >= Buttons(cb).Y) AND (my < Buttons(cb).Y + _FONTHEIGHT) THEN +' DefaultButton = cb +' WHILE _MOUSEBUTTON(1): _LIMIT 500: mb = _MOUSEINPUT: WEND +' mb = 0: nmx = _MOUSEX: nmy = _MOUSEY +' IF nmx = mx AND nmy = my THEN DIALOGRESULT = cb +' RETURN +' END IF +' END IF +' NEXT cb +' END IF +' RETURN +'END FUNCTION + +'FUNCTION hsb~& (__H AS _FLOAT, __S AS _FLOAT, __B AS _FLOAT, A AS _FLOAT) +' 'method adapted form http://stackoverflow.com/questions/4106363/converting-rgb-to-hsb-colors +' DIM H AS _FLOAT, S AS _FLOAT, B AS _FLOAT + +' H = map(__H, 0, 255, 0, 360) +' S = map(__S, 0, 255, 0, 1) +' B = map(__B, 0, 255, 0, 1) + +' IF S = 0 THEN +' hsb~& = _RGBA32(B * 255, B * 255, B * 255, A) +' EXIT FUNCTION +' END IF + +' DIM fmx AS _FLOAT, fmn AS _FLOAT +' DIM fmd AS _FLOAT, iSextant AS INTEGER +' DIM imx AS INTEGER, imd AS INTEGER, imn AS INTEGER + +' IF B > .5 THEN +' fmx = B - (B * S) + S +' fmn = B + (B * S) - S +' ELSE +' fmx = B + (B * S) +' fmn = B - (B * S) +' END IF + +' iSextant = INT(H / 60) + +' IF H >= 300 THEN +' H = H - 360 +' END IF + +' H = H / 60 +' H = H - (2 * INT(((iSextant + 1) MOD 6) / 2)) + +' IF iSextant MOD 2 = 0 THEN +' fmd = (H * (fmx - fmn)) + fmn +' ELSE +' fmd = fmn - (H * (fmx - fmn)) +' END IF + +' imx = _ROUND(fmx * 255) +' imd = _ROUND(fmd * 255) +' imn = _ROUND(fmn * 255) + +' SELECT CASE INT(iSextant) +' CASE 1 +' hsb~& = _RGBA32(imd, imx, imn, A) +' CASE 2 +' hsb~& = _RGBA32(imn, imx, imd, A) +' CASE 3 +' hsb~& = _RGBA32(imn, imd, imx, A) +' CASE 4 +' hsb~& = _RGBA32(imd, imn, imx, A) +' CASE 5 +' hsb~& = _RGBA32(imx, imn, imd, A) +' CASE ELSE +' hsb~& = _RGBA32(imx, imd, imn, A) +' END SELECT +'END FUNCTION + +'SUB getEquation +' DIM inputStatus AS INTEGER +' CLS +' inputStatus = INPUTBOX("Equation Editor", "Enter the expression for z = (ex. x*y)", mainEquation, mainEquation, -1) +' IF (inputStatus = 2) THEN END +'END SUB + +'FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!) +' map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange! +'END FUNCTION + diff --git a/samples/3d-grapher/src/3d-grapher.zip b/samples/3d-grapher/src/3d-grapher.zip new file mode 100644 index 0000000..973c7dc Binary files /dev/null and b/samples/3d-grapher/src/3d-grapher.zip differ diff --git a/samples/3d.md b/samples/3d.md index 12f3730..ae64760 100644 --- a/samples/3d.md +++ b/samples/3d.md @@ -8,6 +8,24 @@ 3d cube polygon filled using paint. ;*) I could probably shorten the code in less than 20 lines b... +**[3D Engine Prototypes](3d-engine-prototypes/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [3d](3d.md), [graph](graph.md) + +Various experiments in software 3D graphics. Warning: Uses no functions or subs! + +**[3D Grapher](3d-grapher/index.md)** + +[🐝 Ashish Kushwaha](ashish-kushwaha.md) [🐝 STxAxTIC](stxaxtic.md) 🔗 [3d](3d.md), [gl](gl.md) + +3D Grapher made in QB64. + +**[3DS Viewer](3ds-viewer/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [3d](3d.md), [wireframe](wireframe.md), [legacy](legacy.md) + +3D Grapher made in QB64. + **[Globe](globe/index.md)** [🐝 Jeh](jeh.md) [🐝 Yu](yu.md) 🔗 [3d](3d.md), [sphere](sphere.md) @@ -20,12 +38,24 @@ Glen Jeh, 8/12/1994, William Yu (05-28-96) '{A little rotating sphere, by Glen ================================================================================= H E L ... +**[Kaleidoscope 3D](kaleidoscope-3d/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [3d](3d.md), [art](art.md) + +Move mouse to rotate, escape to quit + **[Maptriangle in 3D](maptriangle-in-3d/index.md)** [🐝 Petr](petr.md) 🔗 [3d](3d.md), [maptriangle](maptriangle.md) A demo to show rotation in 3D using MAPTRIANGLE 3D, without direct OpenGL statements. Librarian'... +**[Ray Tracer Z](ray-tracer-z/index.md)** + +[🐝 Zom-B](zom-b.md) 🔗 [3d](3d.md), [ray tracer](ray-tracer.md) + +This is a ray tracer I've been working on for the past 6 years. Well, on and off of course :) It'... + **[RayCaster](raycaster/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [3d](3d.md), [raycaster](raycaster.md) diff --git a/samples/3ds-viewer/img/screenshot.png b/samples/3ds-viewer/img/screenshot.png new file mode 100644 index 0000000..5cc1190 Binary files /dev/null and b/samples/3ds-viewer/img/screenshot.png differ diff --git a/samples/3ds-viewer/index.md b/samples/3ds-viewer/index.md new file mode 100644 index 0000000..cce5ec1 --- /dev/null +++ b/samples/3ds-viewer/index.md @@ -0,0 +1,19 @@ +[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: 3DS VIEWER + +![screenshot.png](img/screenshot.png) + +### Description + +```text +3D Grapher made in QB64. +``` + +### File(s) + +* [3dsviewer.bas](src/3dsviewer.bas) +* [3dsviewer.zip](src/3dsviewer.zip) +* [car.3ds](src/car.3ds) + +🔗 [3d](../3d.md), [wireframe](../wireframe.md), [legacy](../legacy.md) diff --git a/samples/3ds-viewer/src/3dsviewer.bas b/samples/3ds-viewer/src/3dsviewer.bas new file mode 100644 index 0000000..e4e4a17 --- /dev/null +++ b/samples/3ds-viewer/src/3dsviewer.bas @@ -0,0 +1,447 @@ +'CHDIR ".\samples\n54\big\3dsviewer" + +'----sub declarations +'--file stuff +DECLARE SUB ReadChunkInfo (ChunkInfoHolder AS ANY, BytePosition AS LONG) +DECLARE SUB SkipChunk (ChunkInfoHolder AS ANY, BytePosition AS LONG) +DECLARE SUB SearchForChunk (ChunkInfoHolder AS ANY) +DECLARE SUB ReadObject () +'--3D engine stuff +DECLARE SUB multiplyMatrices (matrixA(), matrixB(), result()) +DECLARE SUB getScalingMatrix (sX, sY, sZ, result()) +DECLARE SUB getRotationXMatrix (rX, result()) +DECLARE SUB getRotationYMatrix (rY, result()) +DECLARE SUB getRotationZMatrix (rZ, result()) +DECLARE SUB getTranslationMatrix (tX, tY, tZ, result()) +DECLARE SUB getCombinedMatrix (sX, sY, sZ, rX, rY, rZ, tX, tY, tZ, temp(), temp2(), result()) +DECLARE SUB getNewXYZ (X, Y, Z, combinedMatrix()) +DECLARE SUB getScreenXY (X, Y, Z) + +'----global declarations +Rem $DYNAMIC +Dim Shared PointsArray(0, 0) As Single +Dim Shared NewPointsArray(0, 0) As Long +Dim Shared FaceArray(0, 0) As Integer +Rem $STATIC +Dim Shared numberVertices As Integer +Dim Shared numberFaces As Integer +Dim Shared CurrentBytePosition As Long +Dim Shared FindChunk$ + +'----type definitions +Type ChunkInfo + ID As Integer + Size As Long + Position As Long +End Type + +'----open file +Cls +Print "Would you like to view car.3ds (y/n)?" +Do + k$ = InKey$ +Loop Until k$ <> "" +If UCase$(k$) = "N" Then + Input "Please input the file you wish to load:", fileName$ +Else + fileName$ = "car.3ds" +End If +Open fileName$ For Binary As #1 + +'----initialise variables +sX = 5 +sY = 5 +sZ = 5 +rX = 0 +rY = 0 +rZ = 0 +tX = 0 +tY = 0 +tZ = 500 +currentFrame = 0 + +'----allocate space for matrix calcs +Dim temp(3, 3) +Dim temp2(3, 3) +Dim result(3, 3) + +'----MAIN PROGRAM +Cls +Print "3DS Object Viewer 0.5" +Print "---------------------" +Print "By David Llewellyn" +Print "24/10/2004" +Print "" +Call ReadObject +Print "" +Print "Press any key to continue" +Do +Loop Until InKey$ > Chr$(0) + +'3D-Section +Screen 7, , 0, 1 +Colour = 4 +oldTime = Timer + +Do + + Call getCombinedMatrix(sX, sY, sZ, rX, rY, rZ, tX, tY, tZ, temp(), temp2(), result()) + Cls + + For i = 0 To numberVertices 'load screen coordinates into new array + X = PointsArray(0, i) + Y = PointsArray(1, i) + Z = PointsArray(2, i) + Call getNewXYZ(X, Y, Z, result()) + Call getScreenXY(X, Y, Z) + NewPointsArray(0, i) = X + NewPointsArray(1, i) = Y + Next i 'load screen coordinates into new array + + For i = 0 To numberFaces - 1 'draw faces + 'line from point 0 to 1 + Line (NewPointsArray(0, FaceArray(0, i)), NewPointsArray(1, FaceArray(0, i)))-(NewPointsArray(0, FaceArray(1, i)), NewPointsArray(1, FaceArray(1, i))), Colour + 'line from point 1 to 2 + Line (NewPointsArray(0, FaceArray(1, i)), NewPointsArray(1, FaceArray(1, i)))-(NewPointsArray(0, FaceArray(2, i)), NewPointsArray(1, FaceArray(2, i))), Colour + 'line from point 2 to 0 + Line (NewPointsArray(0, FaceArray(2, i)), NewPointsArray(1, FaceArray(2, i)))-(NewPointsArray(0, FaceArray(0, i)), NewPointsArray(1, FaceArray(0, i))), Colour + Next i 'draw faces + + PCopy 0, 1 + frames = frames + 1 + + A$ = InKey$ + rX = rX + .00065 + rY = rY + .00545 + If A$ = "=" Then tZ = tZ - 5 + If A$ = "-" Then tZ = tZ + 5 + +Loop Until A$ = Chr$(27) + +newTime = Timer +timeTaken = newTime - oldTime +Screen 13 +Print Using "##.##"; frames / timeTaken +Print "frames per second" +Do +Loop Until InKey$ > Chr$(0) + +System + +Sub getCombinedMatrix (sX, sY, sZ, rX, rY, rZ, tX, tY, tZ, temp(), temp2(), result()) + + Erase temp2 + Call getScalingMatrix(sX, sY, sZ, result()) + Call getRotationXMatrix(rX, temp()) + Call multiplyMatrices(result(), temp(), temp2()) 'combine with x rotation + + Call getRotationYMatrix(rY, temp()) + Erase result + Call multiplyMatrices(temp2(), temp(), result()) 'combine with y rotation + + Call getRotationZMatrix(rZ, temp()) + Erase temp2 + Call multiplyMatrices(result(), temp(), temp2()) 'combine with z rotation + + Call getTranslationMatrix(tX, tY, tZ, temp()) + Erase result + Call multiplyMatrices(temp2(), temp(), result()) 'combine with translation + +End Sub + +Sub getNewXYZ (X, Y, Z, combinedMatrix()) + + newX = (combinedMatrix(0, 0) * X) + (combinedMatrix(0, 1) * Y) + (combinedMatrix(0, 2) * Z) + combinedMatrix(0, 3) 'new X point + newY = (combinedMatrix(1, 0) * X) + (combinedMatrix(1, 1) * Y) + (combinedMatrix(1, 2) * Z) + combinedMatrix(1, 3) 'new Y point + newZ = (combinedMatrix(2, 0) * X) + (combinedMatrix(2, 1) * Y) + (combinedMatrix(2, 2) * Z) + combinedMatrix(2, 3) 'new Z point + + X = newX + Y = newY + Z = newZ + +End Sub + +Sub getRotationXMatrix (rX, result()) + + result(0, 0) = 1 + result(1, 0) = 0 + result(2, 0) = 0 + result(3, 0) = 0 + + result(0, 1) = 0 + result(1, 1) = Cos(rX) + result(2, 1) = Sin(rX) + result(3, 1) = 0 + + result(0, 2) = 0 + result(1, 2) = -Sin(rX) + result(2, 2) = Cos(rX) + result(3, 2) = 0 + + result(0, 3) = 0 + result(1, 3) = 0 + result(2, 3) = 0 + result(3, 3) = 1 + +End Sub + +Sub getRotationYMatrix (rY, result()) + + result(0, 0) = Cos(rY) + result(1, 0) = 0 + result(2, 0) = -Sin(rY) + result(3, 0) = 0 + + result(0, 1) = 0 + result(1, 1) = 1 + result(2, 1) = 0 + result(3, 1) = 0 + + result(0, 2) = Sin(rY) + result(1, 2) = 0 + result(2, 2) = Cos(rY) + result(3, 2) = 0 + + result(0, 3) = 0 + result(1, 3) = 0 + result(2, 3) = 0 + result(3, 3) = 1 + +End Sub + +Sub getRotationZMatrix (rZ, result()) + + result(0, 0) = Cos(rZ) + result(1, 0) = Sin(rZ) + result(2, 0) = 0 + result(3, 0) = 0 + + result(0, 1) = -Sin(rZ) + result(1, 1) = Cos(rZ) + result(2, 1) = 0 + result(3, 1) = 0 + + result(0, 2) = 0 + result(1, 2) = 0 + result(2, 2) = 1 + result(3, 2) = 0 + + result(0, 3) = 0 + result(1, 3) = 0 + result(2, 3) = 0 + result(3, 3) = 1 + +End Sub + +Sub getScalingMatrix (sX, sY, sZ, result()) + + result(0, 0) = sX + result(1, 0) = 0 + result(2, 0) = 0 + result(3, 0) = 0 + + result(0, 1) = 0 + result(1, 1) = sY + result(2, 1) = 0 + result(3, 1) = 0 + + result(0, 2) = 0 + result(1, 2) = 0 + result(2, 2) = sZ + result(3, 2) = 0 + + result(0, 3) = 0 + result(1, 3) = 0 + result(2, 3) = 0 + result(3, 3) = 1 + +End Sub + +Sub getScreenXY (X, Y, Z) + + If Z = 0 Then + X = X * 280 + Y = Y * 240 + Else + X = (X * 280) / Z + Y = (Y * 240) / Z + End If + + X = Int(X + 160) + Y = Int(Y + 100) + +End Sub + +Sub getTranslationMatrix (tX, tY, tZ, result()) + + result(0, 0) = 1 + result(1, 0) = 0 + result(2, 0) = 0 + result(3, 0) = 0 + + result(0, 1) = 0 + result(1, 1) = 1 + result(2, 1) = 0 + result(3, 1) = 0 + + result(0, 2) = 0 + result(1, 2) = 0 + result(2, 2) = 1 + result(3, 2) = 0 + + result(0, 3) = tX + result(1, 3) = tY + result(2, 3) = tZ + result(3, 3) = 1 + +End Sub + +Sub multiplyMatrices (matrixA(), matrixB(), result()) + + For i = 0 To 3 + For j = 0 To 3 + For k = 0 To 3 + result(j, i) = result(j, i) + (matrixB(j, k) * matrixA(k, i)) + Next k + Next j + Next i + +End Sub + +Sub ReadChunkInfo (ChunkInfoHolder As ChunkInfo, BytePosition As Long) + + Get #1, BytePosition, ChunkInfoHolder.ID + Get #1, BytePosition + 2, ChunkInfoHolder.Size + ChunkInfoHolder.Position = BytePosition + +End Sub + +Sub ReadObject + + Dim ChunkH As ChunkInfo + CurrentBytePosition = 1 'start of file + Call ReadChunkInfo(ChunkH, CurrentBytePosition) + FindChunk$ = "3D3D" + Call SearchForChunk(ChunkH) 'CBP should now be 3D3D(EDIT3DS) + Call ReadChunkInfo(ChunkH, CurrentBytePosition) + FindChunk$ = "4000" + Call SearchForChunk(ChunkH) 'CBP should now be 4000(NAMED_OBJECT) + '\/Read & display object name + i = 0 + Do + ObjectName$ = " " + Get #1, CurrentBytePosition + 6 + i, ObjectName$ + i = i + 1 + Loop Until Asc(ObjectName$) = 0 + ObjectName$ = String$(i - 1, " ") + Get #1, CurrentBytePosition + 6, ObjectName$ + Print "Object Name: "; ObjectName$ + '/\Read & display object name + Call ReadChunkInfo(ChunkH, CurrentBytePosition) + ChunkH.Position = CurrentBytePosition + i 'skip past name area + ChunkH.Size = ChunkH.Size - i 'skip past name area + FindChunk$ = "4100" + Call SearchForChunk(ChunkH) 'CBP should now be 4100(OBJ_MESH) + Call ReadChunkInfo(ChunkH, CurrentBytePosition) + Dim BackupBytePosition As Long + BackupBytePosition = CurrentBytePosition + FindChunk$ = "4110" + Call SearchForChunk(ChunkH) 'CBP should now be 4110(MESH_VERTICES) + '\/Read & display vertices + 'Number of vertices + CurrentBytePosition = CurrentBytePosition + 6 + Get #1, CurrentBytePosition, numberVertices + Print "Number of vertices:"; numberVertices + ReDim PointsArray(2, numberVertices) As Single 'allocate space for 3d points + ReDim NewPointsArray(1, numberVertices) As Long 'allocate space for screen points + CurrentBytePosition = CurrentBytePosition + 2 + 'Actual vertice data + Dim vertex As Single + For i = 0 To numberVertices + Get #1, CurrentBytePosition, vertex + 'PRINT "X-vertex"; vertex + PointsArray(0, i) = vertex + CurrentBytePosition = CurrentBytePosition + 4 + Get #1, CurrentBytePosition, vertex + 'PRINT "Y-vertex"; vertex + PointsArray(1, i) = vertex + CurrentBytePosition = CurrentBytePosition + 4 + Get #1, CurrentBytePosition, vertex + 'PRINT "Z-vertex"; vertex + PointsArray(2, i) = vertex + CurrentBytePosition = CurrentBytePosition + 4 + Next i + '/\Read & display vertices + Call ReadChunkInfo(ChunkH, BackupBytePosition) 'ChunkH should now be 4100(OBJ_MESH) + FindChunk$ = "4120" + Call SearchForChunk(ChunkH) 'CBP should now be 4120(MESH_FACES) + '\/Read & display faces + 'Number of faces + CurrentBytePosition = CurrentBytePosition + 6 + Get #1, CurrentBytePosition, numberFaces + Print "Number of faces:"; numberFaces + ReDim FaceArray(2, numberFaces) As Integer 'allocate space for face points + CurrentBytePosition = CurrentBytePosition + 2 + 'Actual face data + Dim face As Integer + For i = 0 To numberFaces + Get #1, CurrentBytePosition, face + 'PRINT "Face-point 1:"; face + FaceArray(0, i) = face + CurrentBytePosition = CurrentBytePosition + 2 + Get #1, CurrentBytePosition, face + 'PRINT "Face-point 2:"; face + FaceArray(1, i) = face + CurrentBytePosition = CurrentBytePosition + 2 + Get #1, CurrentBytePosition, face + 'PRINT "Face-point 3:"; face + FaceArray(2, i) = face + CurrentBytePosition = CurrentBytePosition + 2 + Get #1, CurrentBytePosition, face + 'PRINT "Face-visibility:"; face + CurrentBytePosition = CurrentBytePosition + 2 + Next i + '\/Read & display faces + + +End Sub + +Sub SearchForChunk (ChunkInfoHolder As ChunkInfo) + + Dim InnerBytePosition As Long + Dim MaxBytePosition As Long + InnerBytePosition = ChunkInfoHolder.Position + 6 + MaxBytePosition = ChunkInfoHolder.Position + ChunkInfoHolder.Size + ChunkName$ = Hex$(ChunkInfoHolder.ID) + + Found = 0 + + Do + + Call ReadChunkInfo(ChunkInfoHolder, InnerBytePosition) + + If FindChunk$ = Hex$(ChunkInfoHolder.ID) Then + Found = 1 + Else + Call SkipChunk(ChunkInfoHolder, InnerBytePosition) + End If + + Loop Until InnerBytePosition >= MaxBytePosition Or Found = 1 Or InKey$ = Chr$(27) Or ChunkInfoHolder.Size = 0 + + If Found = 0 Then + Print "" + Print FindChunk$; " was not found within "; ChunkName$; "!" + Print "" + System + Else + CurrentBytePosition = ChunkInfoHolder.Position + End If + +End Sub + +Sub SkipChunk (ChunkInfoHolder As ChunkInfo, BytePosition As Long) + + BytePosition = BytePosition + ChunkInfoHolder.Size + +End Sub + diff --git a/samples/3ds-viewer/src/3dsviewer.zip b/samples/3ds-viewer/src/3dsviewer.zip new file mode 100644 index 0000000..dd87b5e Binary files /dev/null and b/samples/3ds-viewer/src/3dsviewer.zip differ diff --git a/samples/3ds-viewer/src/car.3ds b/samples/3ds-viewer/src/car.3ds new file mode 100644 index 0000000..0d6763d Binary files /dev/null and b/samples/3ds-viewer/src/car.3ds differ diff --git a/samples/a&a-de-pasquale.md b/samples/a&a-de-pasquale.md new file mode 100644 index 0000000..1d2e4ee --- /dev/null +++ b/samples/a&a-de-pasquale.md @@ -0,0 +1,33 @@ +[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 A&A DE PASQUALE + +**[Calendar](calendar/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [calendar](calendar.md), [pdf](pdf.md), [dos world](dos-world.md) + +' Antonio & Alfonso De Pasquale ' Copyright (C) 1993 DOS Resource Guide ' Published in Issue #8, ... + +**[Dec to Frac](dec-to-frac/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [math](math.md), [dos world](dos-world.md) + +' DEC_FRAC.BAS - Fraction/Decimal conversion functions ' and sample program ' b... + +**[Hangman](hangman/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [game](game.md), [hangman](hangman.md), [dos world](dos-world.md) + +' HANGMAN.BAS by Antonio & Alfonso De Pasquale ' Copyright (C) 1993, 1994 DOS Resource Guide ' ... + +**[Letter Blast](letter-blast/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [game](game.md), [letter](letter.md), [dos world](dos-world.md) + +' LETBLAST.BAS - Shoot the falling letters! ' by Antonio & Alfonso De Pasquale ' ' Copyr... + +**[Measure](measure/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [measure](measure.md), [dos world](dos-world.md) + +' MEASURE.BAS - A program for performing measurement conversions ' by Antonio & Alfonso De P... diff --git a/samples/ai.md b/samples/ai.md new file mode 100644 index 0000000..bcf65f0 --- /dev/null +++ b/samples/ai.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: AI + +**[Eliza](eliza/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [ai](ai.md), [eliza](eliza.md) + +The original chatbot, Eliza. diff --git a/samples/alan-zeichick.md b/samples/alan-zeichick.md new file mode 100644 index 0000000..4ff45bc --- /dev/null +++ b/samples/alan-zeichick.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 BY ALAN ZEICHICK + +**[Loan Amortization](loan-amortization/index.md)** + +[🐝 Alan Zeichick](alan-zeichick.md) 🔗 [finance](finance.md), [dos world](dos-world.md) + +' Loan amortization program ' Alan Zeichick, March 16, 1993 ' Copyright (c) 1993 DOS Resource Gui... + +**[QB Clock](qb-clock/index.md)** + +[🐝 Alan Zeichick](alan-zeichick.md) 🔗 [clock](clock.md) + +' Analog Clock for QBasic ' by Alan Zeichick copyright (c) 1986, 1992 ' Copyright (C) 1992 DOS Re... diff --git a/samples/art.md b/samples/art.md index 6737181..de870fd 100644 --- a/samples/art.md +++ b/samples/art.md @@ -13,3 +13,15 @@ A Graphics/Animation utility by Bob Seguin. NOTE: This game requires graphics f [🐝 Zom-B](zom-b.md) 🔗 [fractal](fractal.md), [art](art.md) This is [...] a series of fractal artworks that I ported from Ultra Fractal to Quick Basic 4.5 wi... + +**[Kaleidoscope 3D](kaleidoscope-3d/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [3d](3d.md), [art](art.md) + +Move mouse to rotate, escape to quit + +**[Kaleidoscope Doodler](kaleidoscope-doodler/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [art](art.md), [drawing](drawing.md) + +Left-click to draw, right click or middle click to clear screen, escape to quit. diff --git a/samples/artelius.md b/samples/artelius.md new file mode 100644 index 0000000..f8c61e1 --- /dev/null +++ b/samples/artelius.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 ARTELIUS + +**[Jpeg Maker](jpeg-maker/index.md)** + +[🐝 Artelius](artelius.md) 🔗 [jpeg](jpeg.md), [image manipulation](image-manipulation.md) + +'JPEG Encoder v2 by Artelius 'WARNING: OVERWRITES TEST.JPG diff --git a/samples/artillery.md b/samples/artillery.md index d10564f..ce047d6 100644 --- a/samples/artillery.md +++ b/samples/artillery.md @@ -2,6 +2,12 @@ ## SAMPLES: ARTILLERY +**[Gorillas](gorillas/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [artillery](artillery.md) + +Gorilla-based artillery game by Microsoft. + **[QShips](qships/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [artillery](artillery.md) diff --git a/samples/ashish-kushwaha.md b/samples/ashish-kushwaha.md new file mode 100644 index 0000000..3e623f4 --- /dev/null +++ b/samples/ashish-kushwaha.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 BY ASHISH KUSHWAHA + +**[3D Grapher](3d-grapher/index.md)** + +[🐝 Ashish Kushwaha](ashish-kushwaha.md) [🐝 STxAxTIC](stxaxtic.md) 🔗 [3d](3d.md), [gl](gl.md) + +3D Grapher made in QB64. + +**[Hunters Revenge](hunters-revenge/index.md)** + +[🐝 Ashish Kushwaha](ashish-kushwaha.md) 🔗 [game](game.md), [shooter](shooter.md) + +# Hunter-Revenge A shooting game created in QB64 diff --git a/samples/author-cloud.md b/samples/author-cloud.md index 0ea69b6..b9f11fe 100644 --- a/samples/author-cloud.md +++ b/samples/author-cloud.md @@ -2,4 +2,4 @@ ## AUTHORS -[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 +[Microsoft:31](microsoft.md) • [Fellippe Heitor:27](fellippe-heitor.md) • [Antoni Gual:25](antoni-gual.md) • [*missing*:23](author-missing.md) • [STxAxTIC:23](stxaxtic.md) • [Rho Sigma:19](rho-sigma.md) • [qbguy:11](qbguy.md) • [A&A De Pasquale:9](a&a-de-pasquale.md) • [bplus:9](bplus.md) • [Bob Seguin:7](bob-seguin.md) • [Terry Ritchie:7](terry-ritchie.md) • [Hardin Brothers:5](hardin-brothers.md) • [Relsoft:5](relsoft.md) • [Richard Frost:5](richard-frost.md) • [Zom-B:5](zom-b.md) • [Alan Zeichick:3](alan-zeichick.md) • [Ashish Kushwaha:3](ashish-kushwaha.md) • [Cyperium:3](cyperium.md) • [Dav:3](dav.md) • [vince:3](vince.md) • [Artelius:1](artelius.md) • [Brian Murphy:1](brian-murphy.md) • [Chris Chadwick:1](chris-chadwick.md) • [Cobalt:1](cobalt.md) • [Danilin:1](danilin.md) • [darokin:1](darokin.md) • [David Bannon:1](david-bannon.md) • [David Ferrier:1](david-ferrier.md) • [David Joffe:1](david-joffe.md) • [Dietmar Moritz:1](dietmar-moritz.md) • [Douglas Park:1](douglas-park.md) • [Folker Fritz:1](folker-fritz.md) • [Galleon:1](galleon.md) • [Glenn Powell:1](glenn-powell.md) • [harixxx:1](harixxx.md) • [Jeh:1](jeh.md) • [Jeremy Munn:1](jeremy-munn.md) • [JKC:1](jkc.md) • [John Wolfskill:1](john-wolfskill.md) • [Kevin:1](kevin.md) • [kinem:1](kinem.md) • [Leif J. Burrow:1](leif-j.-burrow.md) • [Lucid:1](lucid.md) • [Luke:1](luke.md) • [Matt Bross:1](matt-bross.md) • [Matthew:1](matthew.md) • [Matthew River Knight:1](matthew-river-knight.md) • [Mennonite:1](mennonite.md) • [Michael Fogleman:1](michael-fogleman.md) • [Nathan Thomas:1](nathan-thomas.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) • [RETROQB45:1](retroqb45.md) • [RhoSigma:1](rhosigma.md) • [rpgfan3233:1](rpgfan3233.md) • [Steve M.:1](steve-m..md) • [Timothy Baxendale:1](timothy-baxendale.md) • [Tor Myklebust:1](tor-myklebust.md) • [TrialAndTerror:1](trialandterror.md) • [triggered:1](triggered.md) • [Tsiplacov Sergey:1](tsiplacov-sergey.md) • [TylerDarko:1](tylerdarko.md) • [William Loughner:1](william-loughner.md) • [Yu:1](yu.md) • [Zack Johnson:1](zack-johnson.md) \ No newline at end of file diff --git a/samples/author-missing.md b/samples/author-missing.md index 35b3ac8..4fcd3c9 100644 --- a/samples/author-missing.md +++ b/samples/author-missing.md @@ -2,7 +2,25 @@ ## SAMPLES BY *MISSING* -**[Fire](fire/index.md)** +**[3DS Viewer](3ds-viewer/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [3d](3d.md), [wireframe](wireframe.md), [legacy](legacy.md) + +3D Grapher made in QB64. + +**[Double Pendulum](double-pendulum/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [physics](physics.md), [pendulum](pendulum.md) + +Simulated double pendulum with damping. + +**[Eliza](eliza/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [ai](ai.md), [eliza](eliza.md) + +The original chatbot, Eliza. + +**[Fire 13](fire-13/index.md)** [🐝 *missing*](author-missing.md) 🔗 [fire](fire.md), [graphics](graphics.md) @@ -20,11 +38,11 @@ The legendary fractal fern. Mandelbrot animator. -**[Mandelbrot Zoomer](mandelbrot-zoomer/index.md)** +**[Rockets](rockets/index.md)** -[🐝 *missing*](author-missing.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) +[🐝 *missing*](author-missing.md) 🔗 [screensaver](screensaver.md), [particles](particles.md) -'QBDEMO (C) 2002 Tor Myklebust 'The fractal zoomer should run at 60FPS on a 500MHz machine. I d... +Screensaver with rocket-like particles. **[Shooter](shooter/index.md)** @@ -38,6 +56,12 @@ Mandelbrot animator. Sine Wave Explorer +**[Stock Watcher](stock-watcher/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [money](money.md), [stocks](stocks.md) + +Stock Watcher program. + **[Tower of Hanoi](tower-of-hanoi/index.md)** [🐝 *missing*](author-missing.md) 🔗 [game](game.md), [tower](tower.md) diff --git a/samples/automata.md b/samples/automata.md new file mode 100644 index 0000000..13af409 --- /dev/null +++ b/samples/automata.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: AUTOMATA + +**[Conways Game of Life](conways-game-of-life/index.md)** + +[🐝 Luke](luke.md) 🔗 [automata](automata.md), [conway](conway.md) + +Standard Conway's Game of Life simulation. diff --git a/samples/bad-box-revenge/img/screenshot.png b/samples/bad-box-revenge/img/screenshot.png new file mode 100644 index 0000000..8954a27 Binary files /dev/null and b/samples/bad-box-revenge/img/screenshot.png differ diff --git a/samples/bad-box-revenge/index.md b/samples/bad-box-revenge/index.md new file mode 100644 index 0000000..02788b3 --- /dev/null +++ b/samples/bad-box-revenge/index.md @@ -0,0 +1,26 @@ +[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: BAD BOX REVENGE + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Terry Ritchie](../terry-ritchie.md) + +### Description + +```text +'** +'** Revenge of the Bad Boxes! V1.0 +'** +'** by Terry Ritchie 02/11/13 +'** +``` + +### File(s) + +* [revenge.bas](src/revenge.bas) +* [revenge.zip](src/revenge.zip) + +🔗 [game](../game.md), [bad boxes](../bad-boxes.md) diff --git a/samples/bad-box-revenge/src/revenge.bas b/samples/bad-box-revenge/src/revenge.bas new file mode 100644 index 0000000..1e9ca9b --- /dev/null +++ b/samples/bad-box-revenge/src/revenge.bas @@ -0,0 +1,1085 @@ +'** +'** Revenge of the Bad Boxes! V1.0 +'** +'** by Terry Ritchie 02/11/13 +'** +'****************************************************************************** +'* INITIALIZATION SECTION * +'****************************************************************************** + +Const FALSE = 0 +Const TRUE = Not FALSE ' boolean truth detectors +Const SWIDTH = 1280 ' width of screen +Const SHEIGHT = 720 ' height of screen + +Type BULLET ' the player's bullet + x As Single ' X location of bullet + y As Single ' Y location of bullet + xv As Single ' X velocity of bullet + yv As Single ' Y velocity of bullet + live As Integer ' TRUE if bullet active, FALSE otherwise +End Type + +Type ENEMY ' the enemies + x As Single ' X location of enemy or corner of square + y As Single ' Y location of enemy or corner of square + xv As Single ' X velocity of enemy + yv As Single ' Y velocity of enemy + sx As Single ' rotated X location of corner of square on screen + sy As Single ' rotated Y location of corner of square on screen + live As Integer ' TRUE if enemy is active, FALSE otherwise + angle As Single ' the rotation angle of corner of box + spin As Single ' the spin rate and direction of enemy + size As Integer ' the size of the enemy + good As Integer ' TRUE if good guy, FALSE otherwise +End Type + +Type POINT3D ' star 3D location + x As Single ' X location of star + y As Single ' Y location of star + z As Single ' Z loaction of star +End Type + +Type SPARK ' explosion sparks + count As Integer ' sparkle countdown counter + x As Single ' x location of sparkle + y As Single ' y location of sparkle + xdir As Single ' x velocity of sparkle + ydir As Single ' y velocity of sparkle + speed As Single ' speed of sparkle + fade As Integer ' decreases to fade sparkle away +End Type + +ReDim sparks(0) As SPARK ' create the sparks array + +Dim StarSize% ' the size of the stars +Dim Stars% ' the number of stars on screen +Dim Limit% ' the frames per second the game runs at +Dim MaxBullets%% ' the maximum bullets the player can fire at a time +Dim MaxEnemies%% ' the maximum enemies on the screen at a time +Dim BulletSpeed! ' the speed of the player's bullets +Dim EnemyFrameCount% ' enemy elapsed time counter between enemy appearances +Dim EnemyTimer% ' the minumum amount of time elapsed before another enemy appears +Dim EnemySpeed! ' the maximum speed of the enemies +Dim SpinRate! ' the maximum spin rate of the enemies +Dim PowerLevel% ' the player's current power level +Dim Score% + +MaxBullets% = 3 ' set maximum bullets player allowed to fire at a time +MaxEnemies% = 10 ' set maximum enemies alolowed on screen at one time +Stars% = 32 ' set number of stars on the screen +EnemyTimer% = 100 ' set minimum amount of time between enemy appearances +StarSize% = 1 ' set the size of the stars +EnemySpeed! = 1 ' set the maximum speed of the enemies +SpinRate! = 1 ' set the maximum spin rate of the enemies +PowerLevel% = 100 ' set the maximum power level + +ReDim StarPos(Stars%) As POINT3D ' create the starfield array +Dim Bullet(MaxBullets%) As BULLET ' create the bullet array +Dim Enemy(25, 4) As ENEMY ' create the enemy array +Dim Centerx%, Centery% ' center X,Y coordinates of screen +Dim Turretx%, Turrety% ' X,Y location of turret opening +Dim Mx%, My% ' mouse X,Y corrdinates +Dim Fcount% ' frame counter +Dim Pan! ' used to pan camera around in starfield +Dim Count% ' generic counter +Dim Hit% ' TRUE when player hit by enemy, FALSE otherwise +Dim HitCounter% ' how long to show turret in hit condition +Dim LevelCounter% ' how long to wait until advancing to next level +Dim Level% ' the current level of play + +Dim sndBackground& ' background music +Dim sndBullet& ' bullet sound +Dim sndExplode&(3) ' 3 random enemy explosions +Dim sndGameOver& ' "Game Over" voice +Dim sndGetReady& ' "Get Ready" voice +Dim sndGo& ' "Go" voice +Dim sndGoodBye& ' "Goodbye" voice +Dim sndGreenBox& ' sound when green box hits player +Dim sndGreenBoxHit& ' sound when player shoots a green box (bad player!) +Dim sndLevelUp& ' sound when level increases +Dim sndRedBox& ' sound when red box hits player +Dim sndWarpDriveReady& ' "Warp Drive Ready" voice +Dim DelayStart% ' used to delay the start of the game (intro) + +sndBackground& = _SndOpen("revengebackground.ogg", "VOL,SYNC") ' load sounds into memory +sndBullet& = _SndOpen("revengebullet.ogg", "VOL,SYNC") +sndExplode&(1) = _SndOpen("revengeexplode1.ogg", "VOL,SYNC") +sndExplode&(2) = _SndOpen("revengeexplode2.ogg", "VOL,SYNC") +sndExplode&(3) = _SndOpen("revengeexplode3.ogg", "VOL,SYNC") +sndGameOver& = _SndOpen("revengegameover.ogg", "VOL,SYNC") +sndGetReady& = _SndOpen("revengegetready.ogg", "VOL,SYNC") +sndGo& = _SndOpen("revengego.ogg", "VOL,SYNC") +sndGoodBye& = _SndOpen("revengegoodbye.ogg", "VOL,SYNC") +sndGreenBox& = _SndOpen("revengegreenbox.ogg", "VOL,SYNC") +sndGreenBoxHit& = _SndOpen("revengegreenboxhit.ogg", "VOL,SYNC") +sndLevelUp& = _SndOpen("revengelevelup.ogg", "VOL,SYNC") +sndRedBox& = _SndOpen("revengeredbox.ogg", "VOL,SYNC") +sndWarpDriveReady& = _SndOpen("revengewarpdriveready.ogg", "VOL,SYNC") + +Centerx% = SWIDTH \ 2 ' calculate the horizontal center of the screen +Centery% = SHEIGHT \ 2 ' calculate the vertical center of the screen +Turretx% = Centerx% ' set turret X to horizontal center of screen +Turrety% = Centery% - 16 ' set turret Y to vertical center of screen +BulletSpeed! = 10 ' set the bullet speed (higher numbers = faster) +Limit% = 60 ' set the frames per second of game play +Pan! = 20 ' set the starfield camera angle +LevelCounter% = 1800 ' set how many frames must pass util next level up +Level% = 1 ' set the initial level +DelayStart% = Limit% * 6 ' set the time to delay game (intro) + +'****************************************************************************** +'* MAIN PROGRAM LOOP BEGINS HERE * +'****************************************************************************** + +Randomize Timer ' seed the random number generator + +For Count% = 1 To Stars% ' position stars in random 3D space + StarPos(Count%).x = Rnd * 200 - 100 + StarPos(Count%).y = Rnd * 200 - 100 + StarPos(Count%).z = Count% + .1 +Next + +Screen _NewImage(SWIDTH, SHEIGHT, 32) ' initiate a graphics screen +_ScreenMove _Middle ' move the screen to the middle of desktop +_FullScreen ' go full screen +_MouseHide ' hide the mouse pointer +_Delay 1 ' wait for screen to go full screen +_SndPlay sndGetReady& ' tell player to "Get Ready" +_Delay 1 ' wait another second +_SndLoop sndBackground& ' start the background music +Do ' start the game intro loop + _Limit Limit% ' set the FPS limit + Cls ' clear the screen + DelayStart% = DelayStart% - 1 ' decrement the delay timer + If DelayStart% < Limit% * 3 Then DRAWSTARS ' display the starfield after 3 seconds + If DelayStart% = Limit% * 3 Then _SndPlay sndWarpDriveReady& ' tell the user "Warp Drive Ready" + While _MouseInput: Wend ' get the latest mouse information + Mx% = _MouseX ' save the mouse X coordinate + My% = _MouseY ' save the mouse Y coordinate + AngleToMouse! = VECTORTOANGLE(Centerx%, Centery%, Mx%, My%) ' get the angle from the mouse to center of screen + DRAWTURRET AngleToMouse!, Hit% ' draw turret with gun pointing toward mouse + DRAWCROSSHAIRS Mx%, My% ' draw the crosshairs at mouse X,Y + SHOWSCORE ' show the score + _Display ' update screen with all previous changes +Loop Until DelayStart% = 0 ' stop looping when delay time has reached 0 +_SndPlay sndGo& ' tell the user "Go" +_SndVol sndBackground&, .75 ' tone down the background music slightly +Do ' start the main game play loop + _Limit Limit% ' set the FPS limit + Cls ' clear the screen + DRAWSTARS ' draw the moving starfield + While _MouseInput: Wend ' get the latest mouse information + Mx% = _MouseX ' save the mouse X coordinate + My% = _MouseY ' save the mouse Y coordinate + AngleToMouse! = VECTORTOANGLE(Centerx%, Centery%, Mx%, My%) ' get the angle from the mouse to center of screen + If _MouseButton(1) And Fcount% = 0 Then ' is player pressing left button and ok to fire? + FIREBULLET AngleToMouse!, BulletSpeed! ' yes, fire a bullet toward the crosshairs + Fcount% = Limit% \ 8 ' calculate how long to wait before another bullet fired + End If + DRAWBULLETS ' update any bullets currently flying on screen + DRAWTURRET AngleToMouse!, Hit% ' draw turret with gun pointing toward mouse + If EnemyFrameCount% = 0 Then ' is it time to spawn another enemy? + MAKEENEMY ' yes, make a new enemy + EnemyFrameCount% = EnemyTimer% - Int(Rnd(1) * EnemyTimer%) ' calculate how long to wait before spawning another + End If + DRAWENEMIES ' update any enemies currently flying on screen + DRAWCROSSHAIRS Mx%, My% ' draw the crosshair at mouse positon + CHECKFORCOLLISIONS ' check for collisions between things flying on screen + UPDATESPARKS ' update any sparks currently flying on screen + SHOWSCORE ' show the score, level and health meter on screen + If LevelCounter% = 0 Then ' is it time to level up? + LEVELUP ' yes, increase the level of difficulty + LevelCounter% = 1800 ' how long to wait until next level up + Else ' no + LevelCounter% = LevelCounter% - 1 ' decrement the level counter + End If + _Display ' update the display with all previous chganges +Loop Until PowerLevel% = 0 ' keep playing until player out of power +_SndPlay sndGameOver& ' tell the user "Game Over" +Do: Loop Until Not _SndPlaying(sndGameOver&) ' loop until computer is done speaking +Sleep ' wait for a key press +_SndStop sndBackground& ' stop the background music +_SndPlay sndGoodBye& ' tell the user "Goodbye" +Do: Loop Until Not _SndPlaying(sndGoodBye&) ' loop until the computer is done speaking +System ' return to Windows + +'****************************************************************************** +'* MAIN PROGRAM LOOP ENDS HERE * +'****************************************************************************** + +'****************************************************************************** +'* SUBROUTINES AND FUNCTIONS * +'****************************************************************************** + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub SHOWSCORE () + + '** + '** displays the score, level and power meter on screen + '** + + Shared PowerLevel% ' need access to power level + Shared Score% ' need access to player score + Shared Level% ' need access to current level of play + + Dim Clr~& ' color of power meter + Dim Red%, Green%, Blue% ' RGB components of color + Dim s$, l$ ' score and level converted to strings + + If PowerLevel% > 50 Then ' is power level 51% or higher? + Red% = 0 ' yes, set color to GREEN + Green% = 255 + Blue% = 0 + ElseIf PowerLevel% > 25 Then ' no, is power level 26% or higher? + Red% = 255 ' yes, set color to YELLOW + Green% = 255 + Blue% = 0 + Else ' no, we are less than 26% power! + Red% = 255 ' set color to RED + Green% = 0 + Blue% = 0 + End If + Clr~& = _RGB32(Red%, Green%, Blue%) ' save power meter color + Locate 1, 2 ' locate the cursor + Print "POWER:"; ' print power meter label + Line (60, 2)-(264, 12), _RGB32(255, 255, 255), B ' draw power meter bounding box + Line (62, 4)-(PowerLevel% * 2 + 62, 10), Clr~&, BF ' draw power meter + s$ = Right$("0000" + LTrim$(Str$(Score%)), 4) ' format the score string + Locate 1, 74 ' locate the cursor + Print "SCORE: "; s$; ' print score label and score + l$ = Right$("000" + LTrim$(Str$(Level%)), 3) ' format the level string + Locate 1, 148 ' locate the cursor + Print "LEVEL: "; l$; ' print level label and level + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub LEVELUP () Static + + '** + '** Increases the level of difficulty (a work in progress) + '** + + Shared StarPos() As POINT3D ' need access to the starfield array + Shared sndLevelUp& ' need access to the level up sound + Shared Stars% ' need access to number of stars on screen + Shared StarSize% ' need access to the size of the stars + Shared Limit% ' need access to the game FPS limit + Shared MaxBullets% ' need access to the maximum allowed bullets on screen + Shared MaxEnemies% ' need access to the maximum number of enemies on screen + Shared BulletSpeed! ' need access to the bullet speed + Shared EnemyTimer% ' need access to the enemy timer + Shared EnemySpeed! ' need access to the enemy speed + Shared SpinRate! ' need access to the enemy spin rate + Shared Level% ' need access to the current level of difficulty + + Dim Upper% ' the upper boundary of the starfield array + + _SndPlay sndLevelUp& ' play the level up sound + Level% = Level% + 1 ' increment the level + If Level% Mod 5 = 0 Then StarSize% = StarSize% + 1 ' increment the star size every five levels + If StarSize% > 10 Then StarSize% = 10 ' keep the maximum star size to 10 + EnemyTimer% = EnemyTimer% - 5 ' make the enemies come out quicker + If EnemyTimer% < Limit% \ 4 Then EnemyTimer% = Limit% \ 4 ' keep the enemy timer to no less that 1/4 second + EnemySpeed! = EnemySpeed! + .1 ' increase the speed of the enemies + If EnemySpeed! > 5 Then EnemySpeed! = 5 ' keep the maximum enemy speed to 5 + MaxEnemies% = MaxEnemies% + 5 ' allow 5 more enemies on the screen + If MaxEnemies% > 25 Then MaxEnemies% = 25 ' keep the maximum enemies on screen to 25 + SpinRate! = SpinRate! + .25 ' increase the spin rate of the enemies + If SpinRate! > 5 Then SpinRate! = 5 ' keep the maximum spin rate to 5 + Stars% = Stars% + 32 ' add 32 more stors to the star field + If Stars% > 128 Then ' are there more than 128 stars? + Stars% = 128 ' yes, keep maximum stars to 128 + Else ' no + Upper% = UBound(StarPos) ' get the array's upper limit + ReDim _Preserve StarPos(Stars%) As POINT3D ' increase the array by 32 + For Count% = Upper% + 1 To Stars% ' randomize the 32 new stars added + StarPos(Count%).x = Rnd * 200 - 100 + StarPos(Count%).y = Rnd * 200 - 100 + StarPos(Count%).z = Count% + .1 + Next + End If + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub CHECKFORCOLLISIONS () + + '** + '** Checks for collisions between bullets and enemies and enemies and player + '** + + Shared Enemy() As ENEMY ' need access to the enemy array + Shared Bullet() As BULLET ' need access to teh bullet array + Shared MaxEnemies% ' need access to the maximum enemies on screen + Shared MaxBullets% ' need access to the maximum bullets on screen + Shared PowerLevel% ' need access to the current player power level + Shared Centerx%, Centery% ' need access to the center X,Y of the screen + Shared Hit% ' need access to the player hit indicator + Shared HitCounter% ' need access to the player hit counter + Shared Limit% ' need access to the current game FPS + Shared Score% ' need access to the player's score + Shared sndExplode&() ' need access to the 3 explosion sounds + Shared sndGreenBox& ' need access to the green box hitting player sound + Shared sndRedBox& ' need access to the red box hitting player sound + Shared sndGreenBoxHit& ' need access to the bullet hitting green box sound (bad player!) + + Dim BulletCount% ' generic counter to cycle through all bullets + Dim EnemyCount% ' generic counter to cycle through all enemies + Dim Count% ' just another generic counter + + Do ' start the bullet collision loop + BulletCount% = BulletCount% + 1 ' increment the bullet counter + If Bullet(BulletCount%).live Then ' is this bullet live on the screen? + EnemyCount% = 0 ' reset the enemy counter + Do ' start the bullet/enemy collision loop + EnemyCount% = EnemyCount% + 1 ' increment the enemy counter + If Enemy(EnemyCount%, 0).live Then ' is this enemy live on the screen? + '** + '** yes, check for a collision between this bullet and the enemy + '** + If ROUNDCOLLISION(Bullet(BulletCount%).x, Bullet(BulletCount%).y, 10, Enemy(EnemyCount%, 0).x, Enemy(EnemyCount%, 0).y, Enemy(EnemyCount%, 0).size) Then + Enemy(EnemyCount%, 0).live = FALSE ' a collision! this enemy is now dead + Bullet(BulletCount%).live = FALSE ' this bullet is now dead + If Enemy(EnemyCount%, 0).good Then ' was this a green enemy? + Score% = Score% - 10 ' yes, take points from player (bad player!) + _SndPlay sndGreenBoxHit& ' play the bullet hitting green box xound + Else ' no, this was a red box (good player!) + Score% = Score% + 1 ' increase the player's score + _SndPlay sndExplode&(Int(Rnd(1) * 3) + 1) ' play one of three random explosion sounds + End If + MAKESPARKS Bullet(BulletCount%).x, Bullet(BulletCount%).y ' make explosion sparks where bullet was + Exit Do ' no need to check other enemies + End If + End If + Loop Until EnemyCount% = MaxEnemies% ' keep looping until all enemies checked + End If + Loop Until BulletCount% = MaxBullets% ' keep looping until all bullets checked + EnemyCount% = 0 ' reset the enemy counter + Do ' start the enemy/player collision loop + EnemyCount% = EnemyCount% + 1 ' increase the enemy counter + If Enemy(EnemyCount%, 0).live Then ' is this enemy live? + '** + '** yes, is there a collision between this enemy and the turret? + '** + If ROUNDCOLLISION(Centerx%, Centery%, 30, Enemy(EnemyCount%, 0).x, Enemy(EnemyCount%, 0).y, Enemy(EnemyCount%, 0).size) Then + Enemy(EnemyCount%, 0).live = FALSE ' a collision! this enemy is dead + Hit% = TRUE ' set the player hit flag + HitCounter% = Limit% \ 8 ' how long should player be seen as hit? + MAKESPARKS Enemy(EnemyCount%, 0).x, Enemy(EnemyCount%, 0).y ' make explosion sparks at enemy position + If Enemy(EnemyCount%, 0).good Then ' was this a green enemy box? + _SndPlay sndGreenBox& ' yes, play green box hitting player sound + PowerLevel% = PowerLevel% + Enemy(EnemyCount%, 0).size \ 5 ' increase the player's power level based on box size + If PowerLevel% > 100 Then PowerLevel% = 100 ' keep the power level at 100 + Else ' no, this was a red box + _SndPlay sndRedBox& ' play red box hitting player sound + PowerLevel% = PowerLevel% - Enemy(EnemyCount%, 0).size \ 5 ' decrease the player's power level based on box size + If PowerLevel% < 0 Then PowerLevel% = 0 ' keep the power level at 0 + End If + End If + End If + Loop Until EnemyCount% = MaxEnemies% ' keep looping until all enemies checked + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub MAKESPARKS (x%, y%) + + '** + '** Initiates explosion sparks at the X,Y coordinate given + '** + + Shared sparks() As SPARK ' need access to the aprk array + + Dim cleanup%, count%, topspark% ' local variables + + cleanup% = TRUE ' assume array will need cleaned + For count% = 1 To UBound(sparks) ' cycle through the spark array + If sparks(count%).count <> 0 Then ' is this spark active? + cleanup% = FALSE ' yes, the array is in use, no cleanup + Exit For ' exit the FOR/NEXT loop + End If + Next count% + If cleanup% Then ReDim sparks(0) As SPARK ' reset the array is cleanup needed + topspark% = UBound(sparks) ' get the upper boundary of spark array + ReDim _Preserve sparks(topspark% + 11) As SPARK ' add more sparks to the spark array + For count% = 1 To 10 ' cycle through the new sparks + sparks(topspark% + count%).count = 32 ' spark frames to live + sparks(topspark% + count%).x = x% ' set the spark X starting point + sparks(topspark% + count%).y = y% ' set the spark Y starting point + sparks(topspark% + count%).fade = 255 ' set the intensity of the spark + sparks(topspark% + count%).speed = Int(Rnd(1) * 6) + 6 ' set the velocity of the spark + sparks(topspark% + count%).xdir = Rnd(1) - Rnd(1) ' set the X vector of the spark + sparks(topspark% + count%).ydir = Rnd(1) - Rnd(1) ' set the Y vector of the spark + Next count% + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub UPDATESPARKS () + + '** + '** Updates any sparks currently on the screen + '** + + Shared sparks() As SPARK ' need access to the spark array + + Dim count%, fade1%, fade2% ' local variables + + For count% = 1 To UBound(sparks) ' cycle through the spark array + If sparks(count%).count > 0 Then ' is this spark alive? + fade1% = sparks(count%).fade / 2 ' yes, calculate how much to fade the spark + fade2% = sparks(count%).fade / 4 + PSet (sparks(count%).x, sparks(count%).y), _RGB(sparks(count%).fade, sparks(count%).fade, sparks(count%).fade) ' draw the spark + PSet (sparks(count%).x + 1, sparks(count%).y), _RGB(fade1%, fade1%, fade1%) + PSet (sparks(count%).x - 1, sparks(count%).y), _RGB(fade1%, fade1%, fade1%) + PSet (sparks(count%).x, sparks(count%).y + 1), _RGB(fade1%, fade1%, fade1%) + PSet (sparks(count%).x, sparks(count%).y - 1), _RGB(fade1%, fade1%, fade1%) + PSet (sparks(count%).x + 1, sparks(count%).y + 1), _RGB(fade2%, fade2%, fade2%) + PSet (sparks(count%).x - 1, sparks(count%).y - 1), _RGB(fade2%, fade2%, fade2%) + PSet (sparks(count%).x - 1, sparks(count%).y + 1), _RGB(fade2%, fade2%, fade2%) + PSet (sparks(count%).x + 1, sparks(count%).y - 1), _RGB(fade2%, fade2%, fade2%) + sparks(count%).fade = sparks(count%).fade - 8 ' decrease the intensity level of this spark + sparks(count%).x = sparks(count%).x + sparks(count%).xdir * sparks(count%).speed ' update the X location of this spark + sparks(count%).y = sparks(count%).y + sparks(count%).ydir * sparks(count%).speed ' update the Y location of this spark + sparks(count%).speed = sparks(count%).speed / 1.1 ' slow the spark down a bit + sparks(count%).count = sparks(count%).count - 1 ' decrement this spark's life meter + End If + Next count% + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub DRAWENEMIES () + + '** + '** Draws any live enemies on the screen + '** + + Shared Enemy() As ENEMY ' need access to the enemy array + Shared MaxEnemies% ' need access to the maximum enemies on screen + Shared EnemyFrameCount% ' need access tot he enemy frame counter + + Dim Count% ' generic counter + Dim Red%, Green%, Blue% ' color components + + Do ' start the enemy check loop + Count% = Count% + 1 ' increment the enemy counter + If Enemy(Count%, 0).live Then ' is this enemy live on screen? + If Enemy(Count%, 0).good Then ' yes, is it a good enemy (GREEN)? + Red% = 0 ' yes, set color to GREEN + Green% = 255 + Blue% = 0 + Else ' no, this is a bad enemy (RED) + Red% = 255 ' set color to RED + Green% = 0 + Blue% = 0 + End If + Enemy(Count%, 0).x = Enemy(Count%, 0).x + Enemy(Count%, 0).xv ' update enemy center X location + Enemy(Count%, 0).y = Enemy(Count%, 0).y + Enemy(Count%, 0).yv ' update enemy center Y location + Enemy(Count%, 1).x = Enemy(Count%, 0).x ' set upper left corner X location + Enemy(Count%, 1).y = Enemy(Count%, 0).y - Enemy(Count%, 0).size ' set upper left corner Y location + Enemy(Count%, 1).angle = Enemy(Count%, 1).angle + Enemy(Count%, 0).spin ' update angle to account for spin + Enemy(Count%, 2).x = Enemy(Count%, 0).x + Enemy(Count%, 0).size ' set upper right corner X location + Enemy(Count%, 2).y = Enemy(Count%, 0).y ' set upper right corner Y location + Enemy(Count%, 2).angle = Enemy(Count%, 2).angle + Enemy(Count%, 0).spin ' update angle to account for spin + Enemy(Count%, 3).x = Enemy(Count%, 0).x ' set lower right corner X location + Enemy(Count%, 3).y = Enemy(Count%, 0).y + Enemy(Count%, 0).size ' set lower right corner Y location + Enemy(Count%, 3).angle = Enemy(Count%, 3).angle + Enemy(Count%, 0).spin ' update angle to account for spin + Enemy(Count%, 4).x = Enemy(Count%, 0).x - Enemy(Count%, 0).size ' set lower left corner X location + Enemy(Count%, 4).y = Enemy(Count%, 0).y ' set lower left corner Y location + Enemy(Count%, 4).angle = Enemy(Count%, 4).angle + Enemy(Count%, 0).spin ' update angle to account for spin + For Rotate% = 1 To 4 ' cyle through all four corner points + Enemy(Count%, Rotate%).sx = Enemy(Count%, Rotate%).x ' set the screen X location + Enemy(Count%, Rotate%).sy = Enemy(Count%, Rotate%).y ' set the screen Y location + '** + '** calculate the new X,Y screen coordinate of corner + '** + ROTATEPOINT Enemy(Count%, Rotate%).sx, Enemy(Count%, Rotate%).sy, Enemy(Count%, 0).x, Enemy(Count%, 0).y, Enemy(Count%, Rotate%).angle + Next Rotate% + '** + '** draw the box by connecting lines between the four corners + '** + Line (Enemy(Count%, 1).sx, Enemy(Count%, 1).sy)-(Enemy(Count%, 2).sx, Enemy(Count%, 2).sy), _RGB32(Red%, Green%, Blue% + Count%) + Line -(Enemy(Count%, 3).sx, Enemy(Count%, 3).sy), _RGB32(Red%, Green%, Blue% + Count%) + Line -(Enemy(Count%, 4).sx, Enemy(Count%, 4).sy), _RGB32(Red%, Green%, Blue% + Count%) + Line -(Enemy(Count%, 1).sx, Enemy(Count%, 1).sy), _RGB32(Red%, Green%, Blue% + Count%) + Paint (Enemy(Count%, 0).x, Enemy(Count%, 0).y), _RGB32(Red%, Green%, Blue%), _RGB32(Red%, Green%, Blue% + Count%) + End If + Loop Until Count% = MaxEnemies% ' keep looping until all enemies updated + EnemyFrameCount% = EnemyFrameCount% - 1 ' decrement the enemy frame counter + If EnemyFrameCount% < 0 Then EnemyFrameCount% = 0 ' keep the frame counter at 0 + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub MAKEENEMY () + + '** + '** creates a new enemy on screen + '** + + Shared Enemy() As ENEMY ' need access to the enemy array + Shared Centerx%, Centery% ' need access to the center X,Y of screen + Shared MaxEnemies% ' need access to maximum enemies on screen + Shared EnemySpeed! ' need access to enemy speed + Shared SpinRate! ' need access to spin rate + Shared PowerLevel% ' need access to player power level + + Dim Count% ' generic counter + Dim AngleToCenter! ' holds the angle from new enemy to center of screen + Dim EnemySize% ' the enemy size to create + + Do ' start loop to cycle through enemy array + Count% = Count% + 1 ' increment the enemy counter + If Not Enemy(Count%, 0).live Then ' is this position in array not being used? + Enemy(Count%, 0).live = TRUE ' yes, mark this position as now a live enemy + If Int(Rnd(1) * (PowerLevel% \ 4)) = 1 Then ' randomly determine if good or bad enemy + Enemy(Count%, 0).good = TRUE ' good enemy (GREEN), remember + Else ' bad enemy (RED) + Enemy(Count%, 0).good = FALSE ' remember + End If + Select Case Int(Rnd(1) * 4) + 1 ' randomly choose which side of screen to start at + Case 1 ' start from the top + Enemy(Count%, 0).x = Int(Rnd(1) * SWIDTH) ' choose a random X start location + Enemy(Count%, 0).y = 0 ' set Y location to top of screen + Case 2 ' start from the right + Enemy(Count%, 0).x = SWIDTH ' set X location to right of screen + Enemy(Count%, 0).y = Int(Rnd(1) * SHEIGHT) ' choose a random Y start location + Case 3 ' start from the bottom + Enemy(Count%, 0).x = Int(Rnd(1) * SWIDTH) ' choose a random X start location + Enemy(Count%, 0).y = SHEIGHT ' set Y location to bottom of screen + Case 4 ' start from the left + Enemy(Count%, 0).x = 0 ' set X location to left of screen + Enemy(Count%, 0).y = Int(Rnd(1) * SHEIGHT) ' choose a random Y start location + End Select + AngleToCenter! = VECTORTOANGLE(Centerx%, Centery%, Enemy(Count%, 0).x, Enemy(Count%, 0).y) - 180 ' get angle between enemy and turret + ANGLETOVECTOR AngleToCenter!, Enemy(Count%, 0).xv, Enemy(Count%, 0).yv ' set enemy vectors according to angle + Enemy(Count%, 0).xv = Enemy(Count%, 0).xv * EnemySpeed! ' set X vector speed + Enemy(Count%, 0).yv = Enemy(Count%, 0).yv * EnemySpeed! ' set Y vector speed + Enemy(Count%, 0).spin = (Rnd(1) - Rnd(1)) * SpinRate! ' set enemy spin rate + EnemySize% = Int(Rnd(1) * 30) + 30 ' set random enemy size from 30 to 60 + Enemy(Count%, 0).size = EnemySize% ' remember enemy size + Enemy(Count%, 1).angle = 0 ' upper left corner has angle of 0 + Enemy(Count%, 2).angle = 90 ' upper right corner has angle of 90 + Enemy(Count%, 3).angle = 180 ' lower right corner has angle of 180 + Enemy(Count%, 4).angle = 270 ' lower left corner has angle of 270 + Exit Sub ' no need to check enemy array any further + End If + Loop Until Count% = MaxEnemies% ' keep looping until all enemy array positions checked + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub DRAWSTARS () + '** + '** This subroutine was supplied by harixxx on (4-23-2010) on the QB64.NET web site + '** + + Shared StarPos() As POINT3D + Shared Pan! + Shared StarSize% + Shared Stars% + + Dim Count% + + Pan! = Pan! + .1 + For Count% = 1 To Stars% '------------------------------------------- draw stars + S = StarSize% - StarPos(Count%).z * .01 '------------------------ star size + px = StarPos(Count%).x * 25 / StarPos(Count%).z * 30 + SWIDTH \ 2 '----- star x + py = StarPos(Count%).y * 25 / StarPos(Count%).z * 30 + SHEIGHT \ 2 '----- star y + bri = 255 - StarPos(Count%).z / 100 * 255 '----------------- star color + Line (px, py)-Step(S, S), _RGB32(bri, bri, bri), BF + + StarPos(Count%).x = StarPos(Count%).x + Sin(Pan * .15) * .12 '--------- 3d panning rotation + StarPos(Count%).y = StarPos(Count%).y + Sin(Pan * .14) * .15 + StarPos(Count%).z = StarPos(Count%).z + Sin(Pan * .12) * .25 + + If StarPos(Count%).x > 25 Then StarPos(Count%).x = StarPos(Count%).x - 50 '--- set 3d position limit + If StarPos(Count%).x < -25 Then StarPos(Count%).x = StarPos(Count%).x + 50 + If StarPos(Count%).y > 25 Then StarPos(Count%).y = StarPos(Count%).y - 50 + If StarPos(Count%).y < -25 Then StarPos(Count%).y = StarPos(Count%).y + 50 + If StarPos(Count%).z > 100 Then StarPos(Count%).z = StarPos(Count%).z - 100 + If StarPos(Count%).z < 1 Then StarPos(Count%).z = StarPos(Count%).z + 100 + Next Count% + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub DRAWBULLETS () + + '** + '** draws current live bullets on screen + '** + + Shared Bullet() As BULLET ' need access to bullet array + Shared Fcount% ' need access to bullet frame counter + Shared MaxBullets% ' need access to maximum bullets allowed + + Dim Count% ' generic counter + + Do ' start loop to cycle through bullet array + Count% = Count% + 1 ' increment the bullet counter + If Bullet(Count%).live Then ' is this bullet live? + Bullet(Count%).x = Bullet(Count%).x + Bullet(Count%).xv ' update bullet X location + Bullet(Count%).y = Bullet(Count%).y + Bullet(Count%).yv ' update bullet Y location + If Bullet(Count%).x <= 5 Or Bullet(Count%).x >= SWIDTH - 5 Then ' has bullet X gone off screen? + Bullet(Count%).live = FALSE ' yes, this bullet is now dead + End If + If Bullet(Count%).y <= 5 Or Bullet(Count%).y >= SHEIGHT - 5 Then ' has bullet Y gone off screen? + Bullet(Count%).live = FALSE ' yes, this bullet is now dead + End If + If Bullet(Count%).live Then ' is the bullet still alive? + CIRCLES Bullet(Count%).x, Bullet(Count%).y, 10, _RGB32(126, 126, 126), 0, 0, 0 ' yes, draw bullet + Paint (Bullet(Count%).x, Bullet(Count%).y), _RGB32(126, 126, 126), _RGB32(126, 126, 126) ' paint the bullet + End If + End If + Loop Until Count% = MaxBullets% ' keep looping until all bullets checked + Fcount% = Fcount% - 1 ' decrement the bullet frame counter + If Fcount% < 0 Then Fcount% = 0 ' keep bullet frame counter to 0 + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub FIREBULLET (Angle!, Speed!) + + '** + '** creates a new bullet + '** + + Shared Bullet() As BULLET ' need access to bullet array + Shared Centerx%, Centery% ' need access to the center of screen + Shared MaxBullets% ' need access to the maximum number of bullets allowed + Shared sndBullet& ' need access to the bullet fired sound + + Dim Count% ' generic counter + + Do ' start looping through bullet array + Count% = Count% + 1 ' increment the bullet counter + If Not Bullet(Count%).live Then ' can this position be used for a bullet? + _SndPlay sndBullet& ' yes, play the bullet fired sound + Bullet(Count%).live = TRUE ' mark this array position with active bullet + Bullet(Count%).x = Centerx% ' set the X location of bullet + Bullet(Count%).y = Centery% ' set the Y location of bullet + ANGLETOVECTOR Angle!, Bullet(Count%).xv, Bullet(Count%).yv ' set bullet X,Y vectors according to current turret angle + Bullet(Count%).xv = Bullet(Count%).xv * Speed! ' set the bullet X vecotr speed + Bullet(Count%).yv = Bullet(Count%).yv * Speed! ' set the bullet Y vector speed + Exit Sub ' no need to check bullet array any further + End If + Loop Until Count% = MaxBullets% ' keep looping until all bullets checked + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub DRAWTURRET (Angle!, Hit%) + + '** + '** draws the player's turret + '** + + Shared Centerx%, Centery% ' need access to center X,Y of screen + Shared Turretx%, Turrety% ' need access to turret X,Y location + Shared Hit% ' need access to turret hit flag + Shared HitCounter% ' need access to hit counter + + Dim tx!, ty! ' turret X,Y location + Dim Red%, Green%, Blue% ' color components + + If Hit% Then ' was the turret hit? + HitCounter% = HitCounter% - 1 ' yes, decrement the hit counter + If HitCounter% < 0 Then ' is the hit counter now less than 0? + Hit% = FALSE ' reset the hit flag + HitCounter% = 0 ' reset the hit counter + End If + Red% = 255 ' set turret color to bright white + Green% = 255 + Blue% = 255 + Else ' no, turret was not hit + Red% = 127 ' set the turret color to standard gray + Green% = 127 + Blue% = 127 + End If + tx! = Turretx% ' get turret X location + ty! = Turrety% ' get turret Y location + ROTATEPOINT tx!, ty!, Centerx%, Centery%, Angle! ' rotate the barrel around turret + CIRCLES Centerx%, Centery%, 30, _RGB32(Red%, Green%, Blue%), 0, 0, 0 ' draw the turret + CIRCLES tx!, ty!, 13, _RGB32(Red%, Green%, Blue%), 0, 0, 0 ' draw the turret barrel + Paint (Centerx%, Centery%), _RGB32(Red% \ 2, Green% \ 2, Blue% \ 2), _RGB32(Red%, Green%, Blue%) ' paint the turret + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub DRAWCROSSHAIRS (mx%, my%) + + '** + '** draws the cross hairs at the current mouse location + '** + + CIRCLES mx%, my%, 17, _RGB32(255, 255, 255), 0, 0, 0 ' draw the cross hairs + CIRCLES mx%, my%, 16, _RGB32(127, 127, 127), 0, 0, 0 + CIRCLES mx%, my%, 15, _RGB32(32, 32, 32), 0, 0, 0 + Line (mx% - 16, my%)-(mx% + 16, my%), _RGB32(32, 32, 32) + Line (mx% - 8, my%)-(mx% + 8, my%), _RGB32(64, 64, 64) + Line (mx% - 2, my%)-(mx% + 2, my%), _RGB32(128, 128, 128) + Line (mx%, my% - 16)-(mx%, my% + 16), _RGB32(32, 32, 32) + Line (mx%, my% - 8)-(mx%, my% + 8), _RGB32(64, 64, 64) + Line (mx%, my% - 2)-(mx%, my% + 2), _RGB32(128, 128, 128) + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub ANGLETOVECTOR (An!, x1!, y1!) ' ANGLETOVECTOR + + '** + '** Computes the angle from vectors passed in. + '** + '** 315 000 045 + '** \ | / Angles must be passed based + '** 270 --+-- 090 on the diagram to the left + '** / | \ + '** 225 180 135 + '** + '** INPUT : An! - the angle to convert to a vector + '** + '** OUTPUT: x1! - the horizontal vector + '** y1! - the vertical vector + '** + '** REFERENCE: http://www.idevgames.com/forums/thread-9221.html + '** + + x1! = XVELOCITY(An!, 1) ' compute the horizontal vector based on angle and speed of 1 + y1! = YVELOCITY(An!, 1) ' compute the vertical vector based on angle and speed of 1 + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Function VECTORTOANGLE (x1c!, y1c!, x2!, y2!) ' VECTORTOANGLE + + '** + '** Computes the angle to a point from a second originating point (center). + '** + '** 315 000 045 + '** \ | / Angles will be returned based + '** 270 --+-- 090 on the diagram to the left + '** / | \ + '** 225 180 135 + '** + '** INPUT : x1c! - the X coordinate of the point of reference (center point) + '** y1c! - the Y coordinate of the point of reference (center point) + '** x2! - the X coordinate of the point being resolved + '** y2! - the Y coordinate of the point being resolved + '** + '** OUTPUT: VECTORTOANGLE - the angle resolved from the point position in relation to the reference (center) point + '** + '** NOTES : QB64 does not have an ATN2() function, so ATN() must be used instead taking into account + '** which of the 4 quadrants the point being resolved lies in. This work is based off Galleon's + '** getangle# function found at: http://www.qb64.net/forum/index.php?topic=3934.0 + '** + '** REFERENCE: http://msdn.microsoft.com/en-us/library/system.math.atan2.aspx + '** + + If y2! = y1c! Then + If x1c! = x2! Then Exit Function + If x2! > x1c! Then VECTORTOANGLE = 90 Else VECTORTOANGLE = 270 + Exit Function + End If + If x2! = x1c! Then + If y2! > y1c! Then VECTORTOANGLE = 180 + Exit Function + End If + If y2! < y1c! Then + If x2! > x1c! Then + VECTORTOANGLE = Atn((x2! - x1c!) / (y2! - y1c!)) * -57.2957795131 + Else + VECTORTOANGLE = Atn((x2! - x1c!) / (y2! - y1c!)) * -57.2957795131 + 360 + End If + Else + VECTORTOANGLE = Atn((x2! - x1c!) / (y2! - y1c!)) * -57.2957795131 + 180 + End If + +End Function + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Function ROUNDCOLLISION (Round1X!, Round1Y!, Round1Radius!, Round2X!, Round2Y!, Round2Radius!) ' ROUNDCOLLISION + + '** + '** Detects if two circular areas are in collision by first checking the object's bounding box for a collision. + '** If a bounding box collision has occurred then a more accurate circular collision is checked for. + '** + '** INPUT : Round1X! - the center X location of object 1 + '** Round1Y! - the center Y location of object 1 + '** Round1Radius! - the radius of object 1's bounding circle + '** Round2X! - the center X location of object 2 + '** Round2Y! - the center Y location of object 2 + '** Round2Radius! - the radius of object 2's bounding circle + '** + '** OUTPUT: ROUNDCOLLISION - 0 (FALSE) for no collision, -1 (TRUE) for collision + '** + '** USES : BOXCOLLISION - used to check for bounding box collision first, for function speed. + '** + + If BOXCOLLISION(Round1X! - Round1Radius!, Round1Y! - Round1Radius!, 2 * Round1Radius!, 2 * Round1Radius!, Round2X! - Round2Radius!, Round2Y! - Round2Radius, 2 * Round2Radius!, 2 * Round2Radius!) Then + If Sqr((Round1X! - Round2X!) ^ 2 + (Round1Y! - Round2Y!) ^ 2) < Round1Radius! + Round2Radius! Then ROUNDCOLLISION = -1 + End If + +End Function + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Function BOXCOLLISION (Box1X!, Box1Y!, Box1Width!, Box1Height!, Box2X!, Box2Y!, Box2Width!, Box2Height!) ' BOXCOLLISION + + '** + '** Detects if two bounding box areas are in collision + '** + '** INPUT : Box1X! - upper left corner X location of bounding box 1 + '** Box1Y! - upper left corner Y location of bounding box 1 + '** Box1Width! - the width of bounding box 1 + '** Box1Height! - the height of bounding box 1 + '** Box2X! - upper left corner X location of bounding box 2 + '** Box2Y! - upper left corner Y location of bounding box 2 + '** Box2Width! - the width of bounding box 2 + '** Box2Height! - the height of bounding box 2 + '** + '** OUTPUT: BOXCOLLISION - 0 (FALSE) for no collision, -1 (TRUE) for collision + '** + + If Box1X! <= Box2X! + Box2Width! Then + If Box1X! + Box1Width! >= Box2X! Then + If Box1Y! <= Box2Y! + Box2Height! Then + If Box1Y! + Box1Height! >= Box2Y! Then + BOXCOLLISION = -1 + End If + End If + End If + End If + +End Function + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub ROTATEPOINT (PointX!, PointY!, CenterX!, CenterY!, Angle!) ' ROTATEPOINT + + '** + '** Plots a point on a circle's circumference given the point's current location, the center of rotation + '** and the angle to move the point to using the parametric equation for a circle. + '** + '** 315 000 045 + '** \ | / Angles must be passed in based + '** 270 --+-- 090 on the diagram to the left + '** / | \ + '** 225 180 135 + '** + '** INPUT : PointX! - the current X location of the point + '** PointY! - the current Y location of the point + '** CenterX! - the X center of rotation (the middle of the circle) + '** CenterY! - the Y center of location (the middle of the circle) + '** Angle! - the angle to rotate the point to + '** + '** OUTPUT: PointX! - will be modified to contain the new X location of the point (see warning) + '** PointY! - will be modified to contain the new Y location of the point (see warning) + '** + '** USES : ANGLETORADIAN - function to return the radian that equates to the angle passed in + '** based on the diagram above. + '** + '** WARNING: This subroutine modifies the PointX! and PointY! values passed in. This means the variables you used + '** to pass this information will be modfied as well. If you need to retain your variable's original + '** values then you need to take steps to save these values before passing them to this subroutine. + '** + '** REFERENCE: http://stackoverflow.com/questions/839899/how-do-i-calculate-a-point-on-a-circles-circumference + '** + + Dim Radius! ' the calculated distance from current point location to center of rotation + + Radius! = Sqr((CenterX! - PointX!) ^ 2 + (CenterY! - PointY!) ^ 2) ' calculate the point to center of rotation distance + PointX! = CenterX! + Radius! * Cos(ANGLETORADIAN(Angle! - 90)) ' calculate the point's new X location + PointY! = CenterY! + Radius! * Sin(ANGLETORADIAN(Angle! - 90)) ' calculate the point's new Y location + +End Sub + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Function YVELOCITY (Angle!, Speed!) ' YVELOCITY + + '** + '** Returns the Y velocity (vector) based on angle and speed + '** + '** 315 000 045 + '** \ | / Angles must be passed in based + '** 270 --+-- 090 on the diagram to the left + '** / | \ + '** 225 180 135 + '** + '** INPUT : Angle! - the angle the object is traveling in. (0 to 360) + '** Speed! - the speed the object is moving at. + '** + '** OUTPUT: YVELOCITY - the computed Y velocity (vector) value. + '** + '** USES : ANGLETORADIAN - function to return the radian that equates to the angle passed in + '** based on the diagram above. + '** + '** REFERENCE: http://www.rodedev.com/tutorials/gamephysics/ + '** + + YVELOCITY = Speed! * Sin(ANGLETORADIAN(Angle! - 90)) + +End Function + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Function XVELOCITY (Angle!, Speed!) ' XVELOCITY + + '** + '** Returns the X velocity (vector) based on angle and speed + '** + '** 315 000 045 + '** \ | / Angles must be passed in based + '** 270 --+-- 090 on the diagram to the left + '** / | \ + '** 225 180 135 + '** + '** INPUT : Angle! - the angle the object is traveling in. (0 to 360) + '** Speed! - the speed the object is moving at. + '** + '** OUTPUT: XVELOCITY - the computed X velocity (vector) value. + '** + '** USES : ANGLETORADIAN - function to return the radian that equates to the angle passed in + '** based on the diagram above. + '** + '** REFERENCE: http://www.rodedev.com/tutorials/gamephysics/ + '** + + XVELOCITY = Speed! * Cos(ANGLETORADIAN(Angle! - 90)) + +End Function + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Function ANGLETORADIAN (Angle!) ' ANGLETORADIAN + + '** + '** Converts an angle to radian translating to the following: + '** + '** 1.75 0/2 0.25 + '** 315 000 045 + '** \ | / Inner number = degrees + '** 1.5 270 --+-- 090 0.5 + '** / | \ Outer number = radians + '** 225 180 135 + '** 1.25 0.75 + '** + '** INPUT : Angle! - the angle value passed in. (0 to 360) + '** + '** OUTPUT: ANGLETORADIAN - the radian that matches the angle passed in. (0 to 2) + '** + + ANGLETORADIAN = Angle! / 57.2957795131 + +End Function + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Function RADIANTOANGLE (Radian!) ' RADIANTOANGLE + + '** + '** Converts a radian to angle translated to the following: + '** + '** 1.75 0/2 0.25 + '** 315 000 045 + '** \ | / Inner number = degrees + '** 1.5 270 --+-- 090 0.5 + '** / | \ Outer number = radians + '** 225 180 135 + '** 1.25 0.75 + '** + '** INPUT : Radian! - the radian value passed in. (0 to 2) + '** + '** OUTPUT: RADIANTOANGLE - the angle that matches the radian passed in. (0 to 360) + '** + + RADIANTOANGLE = Radian! * 57.2957795131 + +End Function + +'------------------------------------------------------------------------------------------------------------------------------------------ + +Sub CIRCLES (cx%, cy%, r!, c~&, s!, e!, a!) ' CIRCLES + + '** + '** Draws circles much the same as the native QB64 CIRCLE command with some variations (see notes) + '** + '** SYNTAX: CIRCLES x%, y%, radius!, color~&, start_radian!, end_radian!, aspect_ratio! + '** + '** x% - center X coordinate of circle + '** y% - center Y coordinate of circle + '** radius! - the radius of the circle + '** color~& - the circle's color + '** start_radian! - the radian on circle circumference to begin drawing at + '** end_radian! - the radian on circle circumference to end drawing at + '** aspect_ratio! - the aspect ratio of the circle + '** + '** NOTES : + '** 0/2 Unlike the native CIRCLE command, the CIRCLES command has been + '** ********* ~~\ designed to emulate the coordinate systems of the other commands + '** *** | *** \ in this library. Start and end radians have been rotated 90 degrees + '** ** | ** \ counter-clockwise and the circle is drawn in a clockwise fashion. + '** * | * | + '** * | * V Just as with the native CIRCLE command, supplying a negative value for + '** * | r! * either or both radians will result in a line being drawn from the + '** 1.5 *-----------+-----------* 0.5 center of the circle to the radian. + '** * cx%,cy% * + '** * | * + '** * | * + '** ** | ** + '** *** | *** + '** ********* + '** + '** + + Dim s%, e%, nx%, ny%, xr!, yr!, st!, en!, asp! ' local variables used + Dim stepp!, c! + + st! = s! ' copy start radian to local variable + en! = e! ' copy end radian to local variable + asp! = a! ' copy aspect ratio to local variable + If asp! <= 0 Then asp! = 1 ' keep aspect ratio between 0 and 4 + If asp! > 4 Then asp! = 4 + If asp! < 1 Then xr! = r! * asp! * 4 Else xr! = r! ' calculate x/y radius based on aspect ratio + If asp! > 1 Then yr! = r! * asp! Else yr! = r! + If st! < 0 Then s% = -1: st! = -st! ' remember if line needs drawn from center to start radian + If en! < 0 Then e% = -1: en! = -en! ' remember if line needs drawn from center to end radian + If s% Then ' draw line from center to start radian? + nx% = cx% + xr! * Cos(st! - 1.5707963) ' yes, compute starting point on circle's circumference + ny% = cy% + yr! * Sin(st! - 1.5707963) ' (rotated 90 degrees counter-clockwise) + Line (cx%, cy%)-(nx%, ny%), c~& ' draw line from center to radian + End If + If en! <= st! Then en! = en! + 6.2831852 ' come back around to proper location (draw counterclockwise) + stepp! = 0.159154945806 / r! + c! = st! ' cycle from start radian to end radian + Do + nx% = cx% + xr! * Cos(c! - 1.5707963) ' compute next point on circle's circumfrerence + ny% = cy% + yr! * Sin(c! - 1.5707963) ' (rotated 90 degrees counter-clockwise) + PSet (nx%, ny%), c~& ' draw the point + c! = c! + stepp! + Loop Until c! >= en! + If e% Then Line -(cx%, cy%), c~& ' draw line from center to end radian if needed + +End Sub + +'---------------------------------------------------------------------------------------------------------------------- + diff --git a/samples/bad-box-revenge/src/revenge.zip b/samples/bad-box-revenge/src/revenge.zip new file mode 100644 index 0000000..3ad4fd7 Binary files /dev/null and b/samples/bad-box-revenge/src/revenge.zip differ diff --git a/samples/bad-boxes.md b/samples/bad-boxes.md new file mode 100644 index 0000000..d5eeddb --- /dev/null +++ b/samples/bad-boxes.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: BAD BOXES + +**[Bad Box Revenge](bad-box-revenge/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [bad boxes](bad-boxes.md) + +'** '** Revenge of the Bad Boxes! V1.0 '** '** by Terry Ritchie 02/11/13 '** + +**[Bad Boxes](bad-boxes/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [bad boxes](bad-boxes.md) + +'** '** Program Name: Bad Boxes '** Version : 1.0 '** Author : Terry Ritchie '** Date ... diff --git a/samples/bad-boxes/img/screenshot.png b/samples/bad-boxes/img/screenshot.png new file mode 100644 index 0000000..9ac65aa Binary files /dev/null and b/samples/bad-boxes/img/screenshot.png differ diff --git a/samples/bad-boxes/index.md b/samples/bad-boxes/index.md new file mode 100644 index 0000000..2e478aa --- /dev/null +++ b/samples/bad-boxes/index.md @@ -0,0 +1,32 @@ +[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: BAD BOXES + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Terry Ritchie](../terry-ritchie.md) + +### Description + +```text +'** +'** Program Name: Bad Boxes +'** Version : 1.0 +'** Author : Terry Ritchie +'** Date : January 23rd, 2013 +'** Description : Use your yellow box to capture the green (good) boxes for points while avoiding the red (bad) boxes. +'** +'** Controls : Use the mouse to move the yellow box around the screen. +'** +'** Notes : Good luck! The game gets progrssively harder. +'** +``` + +### File(s) + +* [badbox.bas](src/badbox.bas) +* [badbox.zip](src/badbox.zip) + +🔗 [game](../game.md), [bad boxes](../bad-boxes.md) diff --git a/samples/bad-boxes/src/badbox.bas b/samples/bad-boxes/src/badbox.bas new file mode 100644 index 0000000..eb1d20a --- /dev/null +++ b/samples/bad-boxes/src/badbox.bas @@ -0,0 +1,349 @@ +'** +'** Program Name: Bad Boxes +'** Version : 1.0 +'** Author : Terry Ritchie +'** Date : January 23rd, 2013 +'** Description : Use your yellow box to capture the green (good) boxes for points while avoiding the red (bad) boxes. +'** +'** Controls : Use the mouse to move the yellow box around the screen. +'** +'** Notes : Good luck! The game gets progrssively harder. +'** + +'************************************ +'* * +'* INITIALIZATION SECTION * ********************************************************************************* +'* * +'************************************ + +Const FALSE = 0, TRUE = Not FALSE ' booleans used to test/set for truth +Const SWIDTH = 1280 ' width of screen +Const SHEIGHT = 720 ' height of screen +Const MINWIDTH = SWIDTH / 20 ' minimum width of a square box +Const MAXWIDTH = SWIDTH / 10 ' maximum width of a square box +Const MAXBOXES = 100 ' maximum number of boxes to ever appear on screen +Const HEADS = TRUE ' used in coin toss function +Const TAILS = FALSE ' used in coin toss function +Const DIFFICULTY = 1 ' difficulty level of game (1 - easy to 10 - HARD!) +Const TEXTWIDTH = SWIDTH / 8 ' the maximum text characters the given screen can have + +Type BOX ' box object (spreadsheet columns) + Xpos As Single ' X location of box on screen + Ypos As Single ' Y location of box on screen + Xvel As Single ' X (horizontal) velocity of box + Yvel As Single ' Y (vertical) velocity of box + Size As Integer ' length of each side of box + Colour As _Unsigned Long ' color of box (green = good guy, red = bad guy) +End Type + +Dim Box(MAXBOXES) As BOX ' create array (spreadsheet) to hold MAXBOXES rows of information +Dim Saying$(20) ' sayings the game can display to you while playing +Dim Player As BOX ' create player character +Dim BoxesOnScreen% ' total number of boxes currently allowed on screen +Dim Box% ' a generic counter +Dim maxspeed! ' the current maximum speed boxes are allowed to obtain +Dim Frame% ' keeps track of the number of frames that have elapsed +Dim Score% ' the player's score +Dim GameOver% ' will go TRUE when the game is over +Dim Boxbackground& ' background music +Dim Boxgameover& ' that's it man .. game over man, game over +Dim Boxgreen&(4) ' green box hit sounds +Dim Boxlevelup& ' level up sound +Dim Boxquit& ' laughing demon sound +Dim Boxred& ' red box hit sound + +'************************************ +'* * +'* MAIN CODE SECTION * ********************************************************************************* +'* * +'************************************ + +Boxbackground& = _SndOpen("boxbackground.ogg", "VOL,SYNC,LEN") ' load the game sounds into memory +Boxgameover& = _SndOpen("boxgameover.ogg", "VOL,SYNC,LEN") +Boxgreen&(1) = _SndOpen("boxgreen1.ogg", "VOL,SYNC,LEN") +Boxgreen&(2) = _SndOpen("boxgreen2.ogg", "VOL,SYNC,LEN") +Boxgreen&(3) = _SndOpen("boxgreen3.ogg", "VOL,SYNC,LEN") +Boxgreen&(4) = _SndOpen("boxgreen4.ogg", "VOL,SYNC,LEN") +Boxlevelup& = _SndOpen("boxlevelup.ogg", "VOL,SYNC,LEN") +Boxquit& = _SndOpen("boxquit.ogg", "VOL,SYNC,LEN") +Boxred& = _SndOpen("boxred.ogg", "VOL,SYNC,LEN") + +maxspeed! = 1 ' start the game with a maximum box speed of 1 +BoxesOnScreen% = 20 ' start the game with 10 boxes on the screen +Level% = 1 ' start the game at level 1 + +Player.Xpos = SWIDTH / 2 + 1 ' start player in the center X location of screen +Player.Ypos = SHEIGHT / 2 + 1 ' start player in the center Y location of screen +Player.Size = 10 ' set player's size +Player.Colour = _RGB32(255, 255, 0) ' set player's color (yellow) + +For Box% = 1 To BoxesOnScreen% ' cycle through the array of current boxes on screen + RANDOMBOX Box% ' assign random properties to each box +Next Box% + +Saying$(1) = "Here we go!" ' the twenty taunts the computer can say +Saying$(2) = "Off to a good start!" +Saying$(3) = "Feeling boxed in yet?" +Saying$(4) = "Ok, you're better than average..." +Saying$(5) = "Here, have some more boxes!" +Saying$(6) = "Come on, die already!" +Saying$(7) = "Getting tired yet?" +Saying$(8) = "Your momma wears combat boots!" +Saying$(9) = "We're coming to get you Barbara..." +Saying$(10) = "WooHoo! Sideways baby!" +Saying$(11) = "Ok, you might be a little awesome." +Saying$(12) = "Are you a machine?" +Saying$(13) = "You have got to be cheating!" +Saying$(14) = "You are a box evading god!" +Saying$(15) = "How are you still alive??" +Saying$(16) = "You should take up boxing .. get it?" +Saying$(17) = "You have cat like reflexes!" +Saying$(18) = "This is simply incredible!" +Saying$(19) = "You must have robot in your family tree!" +Saying$(20) = "O . M . G . !!!" + +Screen _NewImage(SWIDTH, SHEIGHT, 32) ' display a graphics screen +_ScreenMove _Middle ' move the graphics screen to the middle of the desktop +_FullScreen ' go to full screen mode +_MouseHide ' hide the mouse pointer from the player +_MouseMove Player.Xpos - Player.Size / 2, Player.Ypos - Player.Size / 2 ' move the mouse pointer to the player's position + +_SndLoop Boxbackground& ' start the background music +_SndVol Boxbackground&, .25 ' turn the background music down to one quarter + +Do ' ** START OF MAIN PROGRAM LOOP ** + _Limit 120 ' limit the game to 120 frames per second + Cls ' clear the screen + Frame% = Frame% + 1 ' increment the frame counter + If Frame% = Int(1000 / DIFFICULTY) Then ' has this difficulty number of frames passed? + _SndPlayCopy Boxlevelup& ' play level up sound + Frame% = 0 ' yes, reset the frame counter + Level% = Level% + 1 ' increment to the next game level + maxspeed! = maxspeed! + .1 ' increase the speed the boxes are allowed to achieve + Player.Size = Player.Size + 2 ' increase the size of the player's box + If Player.Size > 30 Then Player.Size = 30 ' but don't let the player get larger than 30 pixels + BoxesOnScreen% = BoxesOnScreen% + 1 ' add another box to the screen + If BoxesOnScreen% > MAXBOXES Then ' have we exceeded the maximum number of boxes allowed? + BoxesOnScreen% = MAXBOXES ' yes, don't exceed the maximum number of boxes + Else ' no, we have not exceeded the maximum boxes allowed + RANDOMBOX BoxesOnScreen% ' assign random properties to this new box + End If + End If + UPDATEPLAYER ' update the player's position on the screen + For Box% = 1 To BoxesOnScreen% ' cycle through all the boxes currently on the screen + MOVEBOX Box% ' update this box's position on the screen + CHECKFORCOLLISION Box% ' check for a collision between this box and the player + Next Box% + DISPLAYSCORE ' update the score and other on screen information + _Display ' display all changes that have been made in this frame +Loop Until InKey$ = Chr$(27) Or GameOver% ' end game when player hits red box or presses ESC key +' ** END OF MAIN PROGRAM LOOP ** +_SndStop Boxbackground& ' stop the background music from playing +_SndPlayCopy Boxred& ' make one last red box hit sound +_Delay 2 ' wait two seconds for defeat to sink in :) +_SndPlay Boxgameover& ' play the game over sound clip from aliens +Do: Loop Until Not _SndPlaying(Boxgameover&) ' wait until the game over sound clip has finished +_SndPlay Boxquit& ' let the little demon make his snarky laugh +_Delay 2 ' wait another two seconds +End ' ** END OF PROGRAM ** + +'************************************ +'* * +'* SUBROUTINE & FUNCTION SECTION * ********************************************************************************* +'* * +'************************************ + +'------------------------------------------------------------------------------------------------------------ + +Sub DISPLAYSCORE () + + '** + '** Displays the score, level and computer sayings on the screen during game play + '** + + Shared Score% + Shared Level% + Shared Saying$() + + Dim Lvl% ' will hold a copy of the value of Level% + + Locate 1, 2 ' place the cursor at row 1, column 2 + Print "SCORE:"; Score%; ' print the score at this location + Locate 1, TEXTWIDTH - 9 ' place the cursor at row 1, 9 places from the right side of screen + Print "LEVEL:"; Level%; ' print the current level player is on + Lvl% = Level% ' get a copy of the level number + If Lvl% > 20 Then Lvl% = 20 ' if the level is greater than 20 then keep the level at 20 + Locate 1, (TEXTWIDTH - Len(Saying$(Lvl%))) / 2 ' locate the cursor at row 1, centered in the row for current saying + Print Saying$(Lvl%); ' print the current computer saying + +End Sub + +'------------------------------------------------------------------------------------------------------------ + +Function BOXCOLLISION (Box1X!, Box1Y!, Box1Width!, Box1Height!, Box2X!, Box2Y!, Box2Width!, Box2Height!) + + '** + '** Tests two rectangular areas for collision + '** + + If Box1X! <= Box2X! + Box2Width! Then + If Box1X! + Box1Width! >= Box2X! Then + If Box1Y! <= Box2Y! + Box2Height! Then + If Box1Y! + Box1Height! >= Box2Y! Then + BOXCOLLISION = TRUE + End If + End If + End If + End If + +End Function + +'------------------------------------------------------------------------------------------------------------ + +Sub CHECKFORCOLLISION (Box%) + + '** + '** Checks for a collision between this box (Box%) and the player's box + '** + + Shared Player As BOX + Shared Box() As BOX + Shared Boxgreen&() + Shared Score% + Shared GameOver% + ' + '** Check for a box collision between this box and the player + ' + If BOXCOLLISION(Player.Xpos - Player.Size / 2, Player.Ypos - Player.Size / 2, Player.Size, Player.Size, Box(Box%).Xpos, Box(Box%).Ypos, Box(Box%).Size, Box(Box%).Size) Then + If Box(Box%).Colour = _RGB32(0, 255, 0) Then ' there was a collision, was it with a green box? + _SndPlayCopy Boxgreen&(Int(Rnd(1) * 4) + 1) ' play one of four random green box hit sounds + Score% = Score% + 1 ' yes, add a point to the player's score + RANDOMBOX Box% ' have this box appear randomly some where else + Else ' no, the player hit a red box! + GameOver% = TRUE ' the game is now over :( + End If + End If + +End Sub + +'------------------------------------------------------------------------------------------------------------ + +Sub UPDATEPLAYER () + + '** + '** Updates the player's location based on mouse location and draw's the player's box + '** + + Shared Player As BOX + + While _MouseInput: Wend ' get the latest mouse location + Player.Xpos = _MouseX ' set player X position to mouse X location + Player.Ypos = _MouseY ' set player Y position to mouse Y location + ' + '** Draw the player's box + ' + Line (Player.Xpos - Player.Size / 2, Player.Ypos - Player.Size / 2)-(Player.Xpos + Player.Size / 2, Player.Ypos + Player.Size / 2), Player.Colour, BF + +End Sub + +'------------------------------------------------------------------------------------------------------------ + +Sub MOVEBOX (Box%) + + '** + '** Moves the current box (Box%) to it's new location + '** + + Shared Box() As BOX + Shared Score% + Shared Boxred& + + Box(Box%).Xpos = Box(Box%).Xpos + Box(Box%).Xvel ' update the X position of this box + Box(Box%).Ypos = Box(Box%).Ypos + Box(Box%).Yvel ' update the Y position of this box + ' + '** Check to see if the box has gone off screen + ' + If (Box(Box%).Xpos < -Box(Box%).Size) Or Box(Box%).Xpos > SWIDTH Or Box(Box%).Ypos < -Box(Box%).Size Or Box(Box%).Ypos > SHEIGHT Then + If Box(Box%).Colour = _RGB32(0, 255, 0) Then ' was this a green box that flew off the screen? + 'Score% = Score% - 1 ' yes, subtract from player's score if green box missed + _SndPlayCopy Boxred& ' play a red box hit sound if a green box is missed + End If + RANDOMBOX Box% ' have this box appear randomly some where else + End If + ' + '** Draw this box at it's new location + ' + Line (Box(Box%).Xpos, Box(Box%).Ypos)-(Box(Box%).Xpos + Box(Box%).Size, Box(Box%).Ypos + Box(Box%).Size), Box(Box%).Colour, BF + +End Sub + +'------------------------------------------------------------------------------------------------------------ + +Sub RANDOMBOX (Box%) + + '** + '** Sets a box's (Box%) attributes with random values + '** + + Shared Box() As BOX + Shared maxspeed! + Shared Level% + + Box(Box%).Size = Int(Rnd(1) * (MAXWIDTH - MINWIDTH)) + MINWIDTH ' create random sized box between min and max + If COINTOSS = HEADS Then ' let's create a horizontal moving box + Box(Box%).Ypos = Int(Rnd(1) * (SHEIGHT - Box(Box%).Size)) ' find a random Y start position for this box + Box(Box%).Xvel = Rnd(1) * maxspeed! ' create a random X motion factor for this box + If Level% < 10 Then ' if the player is below level 10 + Box(Box%).Yvel = 0 ' then there will be no Y motion for this box + Else ' otherwise + Box(Box%).Yvel = Rnd(1) * maxspeed! ' let's add some Y motion to the box + End If + If COINTOSS = HEADS Then ' this box will appear from the left side + Box(Box%).Xpos = -Box(Box%).Size ' position the box off the screen to the left + Else ' this box will appear from the right side + Box(Box%).Xpos = SWIDTH ' position the box off the screen to the right + Box(Box%).Xvel = -Box(Box%).Xvel ' we need to reverse the X motion factor + End If + Else ' let's create a vertical moving box + Box(Box%).Xpos = Int(Rnd(1) * (SWIDTH - Box(Box%).Size)) ' find a random X start position for this box + Box(Box%).Yvel = Rnd(1) * maxspeed! ' create a random Y motion factor for this box + If Level% < 10 Then ' if the player is below level 10 + Box(Box%).Xvel = 0 ' then there will be no X motion for this box + Else ' otherwise + Box(Box%).Xvel = Rnd(1) * maxspeed! ' let's add some X motion to the box + End If + If COINTOSS = HEADS Then ' this box will appear from the top of the screen + Box(Box%).Ypos = -Box(Box%).Size ' position the box off the screen at the top + Else ' this box will appear from the bottom of the screen + Box(Box%).Ypos = SHEIGHT ' position the box off the screen at the bottom + Box(Box%).Yvel = -Box(Box%).Yvel ' we need to reverse the Y motion factor + End If + End If + If COINTOSS = HEADS Then ' let's determine the color of the box randomly + Box(Box%).Colour = _RGB32(255, 0, 0) ' set it to red + Else + Box(Box%).Colour = _RGB32(0, 255, 0) ' set it to green + End If + +End Sub + +'------------------------------------------------------------------------------------------------------------ + +Function COINTOSS () + + '** + '** Simulates a coin toss with a 50/50 outcome. HEADS = TRUE, TAILS = FALSE + '** + + Randomize Timer ' seed the random number generator + + If Int(Rnd(1) * 2) + 1 = 1 Then ' if we get a random number of 1 + COINTOSS = HEADS ' return COINTOSS as HEADS (or TRUE) + Else ' the random number must have been 2 + COINTOSS = TAILS ' return COINTOSS as TAILS (or FALSE) + End If + +End Function + +'------------------------------------------------------------------------------------------------------------ + diff --git a/samples/bad-boxes/src/badbox.zip b/samples/bad-boxes/src/badbox.zip new file mode 100644 index 0000000..90e4b0a Binary files /dev/null and b/samples/bad-boxes/src/badbox.zip differ diff --git a/samples/bar-demo/img/screenshot.png b/samples/bar-demo/img/screenshot.png new file mode 100644 index 0000000..7487f55 Binary files /dev/null and b/samples/bar-demo/img/screenshot.png differ diff --git a/samples/bar-demo/index.md b/samples/bar-demo/index.md new file mode 100644 index 0000000..6fd67ed --- /dev/null +++ b/samples/bar-demo/index.md @@ -0,0 +1,92 @@ +[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: BAR DEMO + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Douglas Park](../douglas-park.md) + +### Description + +```text +' BARDEMO.BAS +' by Douglas Park +' Copyright (C) 1995 DOS World Magazine +' Published in Issue #19, January 1995, page 60 + +***************************************************************************** + BARDEMO.BAS + by Douglas Park + Copyright (C) 1995 DOS World Magazine + Published in Issue #19, January 1995, page 60 + +If you often find graphs easier to understand than numbers, the CHART +subroutine in this program will allow you to compare two numbers visually in +the form of bar graphs. BARDEMO.BAS is a demonstration program that +illustrates the usage of CHART. As a bonus, the program also includes the +BOX subroutine, which makes it easy to draw boxes on the display. + +To run the program from the DOS command line, change to the directory +containing BARDEMO.BAS, then type: + +QBASIC /RUN BARDEMO + + +When you run BARDEMO.BAS, it first displays two graphs, each of which +visually compares two numbers. One graph occupies the full width of the +display, and a smaller one is centered in the middle of the display. A third +graph appears at the bottom of the display when you press a key in response +to the on-screen prompt. The lengths of the bars in this graph change each +time you press a key. + +The CHART subroutine uses one of DOS’s shaded box characters to create its +bar graph, automatically adjusting the length of the bar representing the +largest quantity so it will fit on a standard 80-column display. The length +of the bar representing the smaller of the two quantities is automatically +adjusted in proportion to the larger bar. CHART limits the length of the +longest bar to 56 characters. + +Calls to CHART are in the following form: + +CALL CHART (STR1$, STR2$, NUM1%, NUM2%, WID%, X%, Y%) + +Thus, CHART requires that your program specify seven values: + +STR1$ and STR2$ are the labels for the two bars. +NUM1% and NUM2% are the two numbers (integers) you wish to compare. The + largest integer allowed by QBasic is 32767. +WID% is the maximum width of the longer of the two bars. If you specify a + value larger than 56, CHART reduces it to 56. +X% and Y% are the row and column on the screen where the graph will be + displayed. + +The BOX subroutine draws a single-line border of any size you specify. Calls +to BOX are in the following form: + +CALL BOX (Y1%, X1%, Y2%, X2%) + +The first two values, Y1% and X1%, are the row and column on the screen of +the upper-left corner of the box. The third and fourth values, Y2% and X2%, +are the row and column of the lower right corner of the box. + +These two subroutines can be incorporated into your own programs. Use CHART +when you want a visual representation of the relative sizes of two numbers. +Use BOX as a quick and easy way to draw boxes around portions of the screen +display. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "bardemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/bar-demo/src/bardemo.bas) +* [RUN "bardemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/bar-demo/src/bardemo.bas) +* [PLAY "bardemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/bar-demo/src/bardemo.bas) + +### File(s) + +* [bardemo.bas](src/bardemo.bas) + +🔗 [tui](../tui.md), [dos world](../dos-world.md) diff --git a/samples/bar-demo/src/bardemo.bas b/samples/bar-demo/src/bardemo.bas new file mode 100644 index 0000000..ef4626e --- /dev/null +++ b/samples/bar-demo/src/bardemo.bas @@ -0,0 +1,76 @@ +' BARDEMO.BAS +' by Douglas Park +' Copyright (C) 1995 DOS World Magazine +' Published in Issue #19, January 1995, page 60 + +DECLARE SUB BOX (Y1%, X1%, Y2%, X2%) +DECLARE SUB CHART (STR1$, STR2$, NUM1%, NUM2%, WID%, X%, Y%) + +CALL BOX(1, 1, 23, 80) +CALL BOX(2, 2, 8, 79) +CALL CHART("STRING1", "STRING2", 500, 5000, 54, 2, 2) +CALL BOX(9, 19, 15, 60) +CALL CHART("STRING1", "STRING2", 1, 2, 20, 19, 9) +LOCATE 23, 10: PRINT " Press a Key " +DO 'Pause for a keystroke + KEY$ = INKEY$ +LOOP WHILE KEY$ = "" +J% = 8 +FOR I% = 1 TO J% + 8 + CALL CHART("I : " + STR$(I%), "J : " + STR$(J%), I%, J%, 54, 2, 16) +DO 'Pause for a keystroke + KEY$ = INKEY$ +LOOP WHILE KEY$ = "" +NEXT I% +END + +SUB BOX (Y1%, X1%, Y2%, X2%) + BOXWIDTH = X2% - X1% + 1 + LOCATE Y1%, X1% + PRINT CHR$(218); STRING$(BOXWIDTH - 2, CHR$(196)); CHR$(191) + FOR I = Y1% + 1 TO Y2% - 1 + LOCATE I, X1% + PRINT CHR$(179); SPACE$(BOXWIDTH - 2); CHR$(179) + NEXT I + LOCATE Y2%, X1% + PRINT CHR$(192); STRING$(BOXWIDTH - 2, CHR$(196)); CHR$(217) +END SUB + +SUB CHART (STR1$, STR2$, NUM1%, NUM2%, WID%, X%, Y%) + TEMPSTRING$ = "" + IF WID% > 56 THEN WID% = 56 'Fit chart to 80 columns + IF NUM1% <= NUM2% THEN 'Determine largest number + KEYNUM% = NUM2% + ELSE + KEYNUM% = NUM1% + END IF + IF WID% < KEYNUM% THEN 'Adjust to fit display + DO + KEYNUM% = KEYNUM% \ 2: NUM1% = NUM1% \ 2: NUM2% = NUM2% \ 2 + LOOP WHILE WID% < KEYNUM% + END IF + BARLENGTH1 = (NUM1% * (WID% / KEYNUM%)) + BARLENGTH2 = (NUM2% * (WID% / KEYNUM%)) + LOCATE (Y% + 2), (X% + 4): PRINT STR1$ 'Write the first title + FOR I = 1 TO BARLENGTH1 'Draw the bar + TEMPSTRING$ = TEMPSTRING$ + CHR$(178) + NEXT I + IF BARLENGTH1 < BARLENGTH2 THEN + FOR I = BARLENGTH1 + 1 TO BARLENGTH2 + TEMPSTRING$ = TEMPSTRING$ + " " + NEXT I + END IF + LOCATE (Y% + 2), (X% + 20): PRINT TEMPSTRING$ + TEMPSTRING$ = "" + LOCATE (Y% + 4), (X% + 4): PRINT STR2$ 'Write the second title + FOR I = 1 TO BARLENGTH2 'Draw the bar + TEMPSTRING$ = TEMPSTRING$ + CHR$(178) + NEXT I + IF BARLENGTH2 < BARLENGTH1 THEN + FOR I = BARLENGTH2 + 1 TO BARLENGTH1 + TEMPSTRING$ = TEMPSTRING$ + " " + NEXT I + END IF + LOCATE (Y% + 4), (X% + 20): PRINT TEMPSTRING$ + END SUB + diff --git a/samples/beatdown/img/screenshot.png b/samples/beatdown/img/screenshot.png new file mode 100644 index 0000000..abea204 Binary files /dev/null and b/samples/beatdown/img/screenshot.png differ diff --git a/samples/beatdown/index.md b/samples/beatdown/index.md new file mode 100644 index 0000000..bd15d53 --- /dev/null +++ b/samples/beatdown/index.md @@ -0,0 +1,31 @@ +[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: BEATDOWN + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Brian Murphy](../brian-murphy.md) + +### Description + +```text +' Beat Down +' 1998 MicroTrip +' V1.1 Origanally availible on +' 12-14-98 +' +' Visit our Web Site At +' At +' http://www.geocities.com/SiliconValley/Platform/8409/qbasic.html +' E-Mail me at microtrip@geocities.com +' ***Hit `F5' to play!!*** +``` + +### File(s) + +* [beatdown.bas](src/beatdown.bas) +* [beatdown.zip](src/beatdown.zip) + +🔗 [game](../game.md), [legacy](../legacy.md) diff --git a/samples/beatdown/src/beatdown.bas b/samples/beatdown/src/beatdown.bas new file mode 100644 index 0000000..5b849f8 --- /dev/null +++ b/samples/beatdown/src/beatdown.bas @@ -0,0 +1,737 @@ +' **** ***** * ***** **** *** * * * * +' * * * * * * * * * * * * ** * +' * * * * * * * * * * * * ** * +' **** **** ***** * * * * * * * * * * * +' * * * * * * * * * * * * * * * * +' * * * * * * * * * * * * * * ** +' **** ***** * * * **** *** ***** * ** +' Beat Down +' 1998 MicroTrip +' V1.1 Origanally availible on +' 12-14-98 +' +' Visit our Web Site At +' At +' http://www.geocities.com/SiliconValley/Platform/8409/qbasic.html +' E-Mail me at microtrip@geocities.com +' ***Hit `F5' to play!!*** + + + + + +title: +'Beat Down Title Screen +'By Brian Murphy of MicroTrip + +SCREEN 8 +CLS +LINE (50, 50)-(50, 100), 14 +LINE (50, 50)-(70, 50), 14 +LINE (50, 100)-(70, 100), 14 +LINE (70, 50)-(80, 55), 14 +LINE (70, 100)-(80, 95), 14 +LINE (80, 55)-(80, 70), 14 +LINE (80, 95)-(80, 80), 14 +LINE (80, 70)-(75, 75), 14 +LINE (80, 80)-(75, 75), 14 +LINE (75, 75)-(50, 75), 14 + +'**************E************* +LINE (90, 50)-(90, 100), 14 +LINE (90, 50)-(120, 50), 14 +LINE (90, 75)-(110, 75), 14 +LINE (90, 100)-(120, 100), 14 + +'**************A************* +LINE (145, 50)-(130, 100), 14 +LINE (145, 50)-(160, 100), 14 +LINE (137.5, 75)-(152.5, 75), 14 + +'*************T************** +LINE (170, 50)-(200, 50), 14 +LINE (185, 50)-(185, 100), 14 + +'***************D************ +LINE (260, 50)-(260, 100), 14 +LINE (260, 50)-(280, 50), 14 +LINE (260, 100)-(280, 100), 14 +LINE (280, 50)-(290, 55), 14 +LINE (280, 100)-(290, 95), 14 +LINE (290, 55)-(290, 95), 14 + +'***************O************ +LINE (300, 55)-(300, 95), 14 +LINE (300, 55)-(310, 50), 14 +LINE (300, 95)-(310, 100), 14 +LINE (330, 55)-(330, 95), 14 +LINE (320, 50)-(330, 55), 14 +LINE (320, 100)-(330, 95), 14 +LINE (320, 100)-(310, 100), 14 +LINE (310, 50)-(320, 50), 14 + +'**************W************* +LINE (340, 50)-(340, 100), 14 +LINE (370, 50)-(370, 100), 14 +LINE (340, 100)-(355, 75), 14 +LINE (370, 100)-(355, 75), 14 + +'**************N************* +LINE (380, 50)-(380, 100), 14 +LINE (410, 50)-(410, 100), 14 +LINE (380, 50)-(410, 100), 14 + +'************************All done + + +COLOR 14 +LOCATE 24, 32: PRINT "Beat Down V1.1" + + +FOR i = 1 TO 2 + FOR x = 550 TO 37 STEP -5 + SOUND x + 5, .2 + a$ = INKEY$: IF a$ <> "" THEN LET d = 1: EXIT FOR + NEXT x + IF d = 1 THEN EXIT FOR + FOR x = 37 TO 550 STEP 5 + SOUND x + 5, .2 + a$ = INKEY$: IF a$ <> "" THEN LET d = 1: EXIT FOR + NEXT x + IF d = 1 THEN EXIT FOR +NEXT i + IF d = 1 THEN GOTO you + +'/Title + + +GOSUB intro + IF nn = 0 GOTO you + IF nn = 1 GOTO title + +you: +'Main Menu +snd$ = "on" +speed$ = "normal" +num = 9 +oldnum = 9 +colour1 = 1 +colour2 = 1 +mainmenu: +COLOR 14 +CLS +LINE (50, 45)-(550, 150), 14, B +LOCATE 5, 33: PRINT "Main Menu" +LINE (60, 55)-(540, 140), 14, B +PAINT (51, 46), 10, 14 +LOCATE 9, 15: PRINT "Start Game" +LOCATE 10, 15: PRINT "Veiw Controls" +LOCATE 11, 15: PRINT "Speed" +LOCATE 12, 15: PRINT "Sound" +LOCATE 13, 15: PRINT "Credits" +LOCATE 14, 15: PRINT "Color of player 1" +LOCATE 15, 15: PRINT "Color of player 2" +LOCATE 16, 15: PRINT "Quit" + +LISTEN$ = "mb T180 o2 P2 P8 L8 GGG L2 E-" +FATE$ = "mb P24 P8 L8 FFF L2 D" +PLAY LISTEN$ + FATE$ + +mm2: + LOCATE 11, 21: PRINT " ": LOCATE 11, 21: PRINT speed$ + LOCATE 12, 21: PRINT " ": LOCATE 12, 21: PRINT snd$; "" + LOCATE 14, 33: PRINT " ": LOCATE 14, 33: COLOR colour1: PRINT colour1 + LOCATE 15, 33: PRINT " ": LOCATE 15, 33: COLOR colour2: PRINT colour2 + COLOR 14 + IF oldnum <> num THEN LOCATE 14, 13: PRINT " ": LOCATE 9, 13: PRINT " ": LOCATE 10, 13: PRINT " ": LOCATE 11, 13: PRINT " ": LOCATE 12, 13: PRINT " ": LOCATE 13, 13: PRINT " ": LOCATE 15, 13: PRINT " ": LOCATE 16, 13: PRINT " ": oldnum = num + LOCATE num, 13: PRINT "o" + DO + a$ = INKEY$ + LOOP UNTIL a$ <> "" + IF a$ = "" THEN GOTO mm2 + IF a$ = "8" AND num = 9 THEN num = 16: GOTO mm2 + IF a$ = "8" THEN num = num - 1: GOTO mm2 + IF a$ = "2" AND num = 16 THEN num = 9: GOTO mm2 + IF a$ = "2" THEN num = num + 1: GOTO mm2 + IF a$ = "5" AND num = 9 THEN GOTO start + IF a$ = "4" AND num = 12 THEN + IF snd$ = "on" THEN snd$ = "off": GOTO mm2 + IF snd$ = "off" THEN snd$ = "on": GOTO mm2 + END IF + IF a$ = "6" AND num = 12 THEN + IF snd$ = "on" THEN snd$ = "off": GOTO mm2 + IF snd$ = "off" THEN snd$ = "on": GOTO mm2 + END IF + IF a$ = "4" AND num = 11 THEN + IF speed$ = "fastest" THEN speed$ = "mid-fast": GOTO mm2 + IF speed$ = "mid-fast" THEN speed$ = "normal": GOTO mm2 + IF speed$ = "normal" THEN speed$ = "mid-slow": GOTO mm2 + IF speed$ = "mid-slow" THEN speed$ = "slow": GOTO mm2 + IF speed$ = "slow" THEN speed$ = "fastest": GOTO mm2 + END IF + IF a$ = "6" AND num = 11 THEN + IF speed$ = "fastest" THEN speed$ = "slow": GOTO mm2 + IF speed$ = "mid-fast" THEN speed$ = "fastest": GOTO mm2 + IF speed$ = "normal" THEN speed$ = "mid-fast": GOTO mm2 + IF speed$ = "mid-slow" THEN speed$ = "normal": GOTO mm2 + IF speed$ = "slow" THEN speed$ = "mid-slow": GOTO mm2 + END IF + IF a$ = "6" AND num = 14 THEN + IF colour1 = 15 THEN colour1 = 0: GOTO mm2 + IF colour1 = 10 THEN colour1 = 12: GOTO mm2 + colour1 = colour1 + 1 + END IF + IF a$ = "4" AND num = 14 THEN + IF colour1 = 0 THEN colour1 = 15: GOTO mm2 + IF colour1 = 12 THEN colour1 = 10: GOTO mm2 + colour1 = colour1 - 1 + END IF + IF a$ = "6" AND num = 15 THEN + IF colour2 = 15 THEN colour2 = 0: GOTO mm2 + IF colour2 = 10 THEN colour2 = 12: GOTO mm2 + colour2 = colour2 + 1 + END IF + IF a$ = "4" AND num = 15 THEN + IF colour2 = 0 THEN colour2 = 15: GOTO mm2 + IF colour2 = 12 THEN colour2 = 10: GOTO mm2 + colour2 = colour2 - 1 + END IF + IF a$ = "5" AND num = 13 THEN GOTO credits + IF a$ = "5" AND num = 10 THEN GOTO controls + IF a$ = "5" AND num = 16 THEN GOTO 666 + GOTO mm2 + +'***********Credits************** +credits: +CLS +PRINT "Graphics Director...........Jacob Suckow" +PRINT " Title Screen Picture......Brian Murphy" +PRINT " Main Menu.................Brian Murphy" +PRINT " Fighting Section..........Brian Murphy" +PRINT " Ending (Circle)...........Brian Murphy" +PRINT "Programming Director........Brian Murphy" +PRINT " Engine....................Brian Murphy" +PRINT " Menu System...............Brian Murphy" +PRINT " Other.....................Brian Murphy" +PRINT "Sound Director..............Jeremy Suckow" +PRINT " Title Screen..............Brian Murphy" +PRINT " MicroTrip Screen..........Brian Murphy" +PRINT " Fighting..................Brian Murphy" +PRINT +PRINT " 1998 MicroTrip" +PRINT " Any key to continue..." +WHILE INKEY$ = "": WEND +GOTO mainmenu +'***********/Credits************* + +'***********Controls************* +controls: +CLS +PRINT "Player One" +PRINT "Move left.....a" +PRINT "Move right....s" +PRINT "Punch.........q" +PRINT "High Punch....z" +PRINT "Kick..........w" +PRINT "Low Kick.....x" +PRINT +PRINT "Player Two" +PRINT "Move Left.....4" +PRINT "Move Right....6" +PRINT "Punch.........8" +PRINT "High Punch..../" +PRINT "Kick..........2" +PRINT "Low Kick......0" +PRINT +PRINT "To quit.....Esc" +PRINT +PRINT "Any key to continue..." +WHILE INKEY$ = "": WEND +GOTO mainmenu +'************/Controls************* + +start: +IF speed$ = "slow" THEN speed = 100000 +IF speed$ = "mid-slow" THEN speed = 50000 +IF speed$ = "normal" THEN speed = 25000 +IF speed$ = "mid-fast" THEN speed = 10000 +IF speed$ = "fastest" THEN speed = 1000 + +IF snd$ = "on" THEN snd = 1 +IF snd$ = "off" THEN snd = 0 + +CLS +SCREEN 8 + +LET a = 50 +LET B = 50 +LET c = 20 +LET d = c +LET e = 600 +LET f = e + +COLOR 15 + +'********Ground******** +LINE (0, 151)-(640, 161), 2, BF +LINE (0, 161)-(640, 171), 10, BF +LINE (0, 171)-(640, 200), 6, BF +'********/Ground******* + +'********Top Thing***** +LINE (0, 0)-(640, 20), 13, B +PAINT (2, 2), 13, 13 +'********/Top Thing**** +'********Background**** +LINE (0, 150)-(640, 21), 11, BF +'********/BackGround*** + +1 +10 IF a <= 0 THEN GOTO 600 +20 IF B <= 0 THEN GOTO 610 + +30 LINE (c, 110)-(c, 130), colour1 'body + LINE (c, 130)-(c - 20, 150), colour1 'leg + LINE (c, 130)-(c + 20, 150), colour1 'other leg + IF c < e THEN LINE (c, 120)-(c + 15, 110), colour1'arm + IF c > e THEN LINE (c, 120)-(c - 15, 110), colour1'arm other + CIRCLE (c, 105), 10, colour1 'head +60 LINE (e, 110)-(e, 130), colour2 + LINE (e, 130)-(e - 20, 150), colour2 + LINE (e, 130)-(e + 20, 150), colour2 + IF e > c THEN LINE (e, 120)-(e - 15, 110), colour2 + IF e < c THEN LINE (e, 120)-(e + 15, 110), colour2 + CIRCLE (e, 105), 10, colour2 + +90 LINE (5, 4)-((a * 5) + 5, 10), 14, BF 'Life Bar + IF a <> 50 THEN LINE ((a * 5) + 1 + 5, 4)-(255, 10), 4, BF + LINE (4, 3)-((a * 5) + 6, 11), 14, B + + LINE (390, 4)-((B * 5) + 390, 10), 14, BF 'Life Bar P2 + LINE ((B * 5) + 390 + 1, 4)-(640, 10), 4, BF + LINE (389, 3)-((B * 5) + 390 + 1, 11), 14, B + +130 a$ = INKEY$ +140 IF a$ = "" THEN GOTO 1 +150 IF a$ = "q" THEN GOTO 200 'punch 1 +155 IF a$ = "z" THEN GOTO highpunch1 +160 IF a$ = "w" THEN GOTO 210 'kick 1 +165 IF a$ = "x" THEN GOTO highkick1 +170 IF a$ = "a" THEN GOTO 220 'left 1 +175 IF a$ = "s" THEN GOTO 270 'right 1 +180 IF a$ = "4" THEN GOTO 230 'left 2 +185 IF a$ = "6" THEN GOTO 240 'right 2 +190 IF a$ = "8" THEN GOTO 250 'punch 2 + IF a$ = "/" THEN GOTO highpunch2 +195 IF a$ = "2" THEN GOTO 260 'kick 2 + IF a$ = "0" THEN GOTO highkick2 +196 IF a$ = CHR$(27) THEN GOTO 616 +197 GOTO 1 + +200 IF c > e THEN GOTO 205 + LINE (c, 120)-(c + 15, 110), 11 + LINE (c, 120)-(c + 30, 120), colour1 + FOR i = 1 TO speed + NEXT i + LINE (c, 120)-(c + 15, 110), colour1 + LINE (c, 120)-(c + 30, 120), 11 + GOTO 209 +205 LINE (c, 120)-(c - 30, 120), colour1 + LINE (c, 120)-(c - 15, 110), 11 + FOR i = 1 TO speed + NEXT i + LINE (c, 120)-(c - 15, 110), colour1 + LINE (c, 120)-(c - 30, 120), 11 + GOTO 209 +209 IF c + 29 = e OR c - 29 = e OR c + 30 = e OR c - 30 = e THEN + B = B - 2 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 24 = e OR c - 24 = e OR c + 25 = e OR c - 25 = e THEN + B = B - 3 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 19 = e OR c - 19 = e OR c + 20 = e OR c - 20 = e THEN + B = B - 1 + IF snd = 1 THEN SOUND 50, 1 + END IF + GOTO 1 + + + +highkick1: + IF c > e THEN GOTO hk1 + LINE (c, 130)-(c + 20, 150), 11 + LINE (c, 130)-(c + 30, 140), colour1 + FOR i = 1 TO speed + NEXT i + LINE (c, 130)-(c + 20, 150), colour1 + LINE (c, 130)-(c + 30, 140), 11 + GOTO hk1x +hk1: + LINE (c, 130)-(c - 20, 150), 11 + LINE (c, 130)-(c - 30, 140), colour1 + FOR i = 1 TO speed + NEXT i + LINE (c, 130)-(c - 20, 150), colour1 + LINE (c, 130)-(c - 30, 140), 11 + GOTO hk1x +hk1x: + IF c + 29 = e OR c - 29 = e OR c + 30 = e OR c - 30 = e THEN + B = B - 2 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 24 = e OR c - 24 = e OR c + 25 = e OR c - 25 = e THEN + B = B - 3 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 19 = e OR c - 19 = e OR c + 20 = e OR c - 20 = e THEN + B = B - 1 + IF snd = 1 THEN SOUND 50, 1 + END IF + GOTO 1 + + +highpunch1: + IF c > e THEN GOTO hp1 + LINE (c, 120)-(c + 15, 110), 11 + LINE (c, 120)-(c + 30, 110), colour1 + FOR i = 1 TO speed + NEXT i + LINE (c, 120)-(c + 15, 110), colour1 + LINE (c, 120)-(c + 30, 110), 11 + GOTO hp1x +hp1: + LINE (c, 120)-(c - 15, 110), 11 + LINE (c, 120)-(c - 30, 110), colour1 + FOR i = 1 TO speed + NEXT i + LINE (c, 120)-(c - 15, 110), colour1 + LINE (c, 120)-(c - 30, 110), 11 + GOTO hp1x +hp1x: + IF c + 29 = e OR c - 29 = e OR c + 30 = e OR c - 30 = e THEN + B = B - 2 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 24 = e OR c - 24 = e OR c + 25 = e OR c - 25 = e THEN + B = B - 3 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 19 = e OR c - 19 = e OR c + 20 = e OR c - 20 = e THEN + B = B - 1 + IF snd = 1 THEN SOUND 50, 1 + END IF + GOTO 1 + + +210 IF c > e THEN GOTO 215 + LINE (c, 130)-(c + 20, 150), 11 + LINE (c, 130)-(c + 30, 130), colour1 + FOR i = 1 TO speed + NEXT i + LINE (c, 130)-(c + 20, 150), colour1 + LINE (c, 130)-(c + 30, 130), 11 + GOTO 219 +215 LINE (c, 130)-(c - 20, 150), 11 + LINE (c, 130)-(c - 30, 130), colour1 + FOR i = 1 TO speed + NEXT i + LINE (c, 130)-(c - 20, 150), colour1 + LINE (c, 130)-(c - 30, 130), 11 + GOTO 219 +219 IF c + 29 = e OR c - 29 = e OR c + 30 = e OR c - 30 = e THEN + B = B - 2 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 24 = e OR c - 24 = e OR c + 25 = e OR c - 25 = e THEN + B = B - 3 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 19 = e OR c - 19 = e OR c + 20 = e OR c - 20 = e THEN + B = B - 1 + IF snd = 1 THEN SOUND 50, 1 + END IF + GOTO 1 + +220 IF c < 6 THEN GOTO 1 +221 c = c - 5 +222 LINE (d, 110)-(d, 130), 11 + LINE (d, 130)-(d - 20, 150), 11 + LINE (d, 130)-(d + 20, 150), 11 +223 LINE (d, 120)-(d - 15, 110), 11 + LINE (d, 120)-(d + 15, 110), 11 +224 CIRCLE (d, 105), 10, 11 +225 d = c +226 GOTO 1 + +270 IF c > 595 THEN GOTO 1 +271 c = c + 5 +272 LINE (d, 110)-(d, 130), 11 + LINE (d, 130)-(d - 20, 150), 11 + LINE (d, 130)-(d + 20, 150), 11 +273 CIRCLE (d, 105), 10, 11 +274 LINE (d, 120)-(d - 15, 110), 11 + LINE (d, 120)-(d + 15, 110), 11 +275 d = c +276 GOTO 1 + +230 IF e < 5 THEN GOTO 1 +231 e = e - 5 +232 LINE (f, 110)-(f, 130), 11 + LINE (f, 130)-(f - 20, 150), 11 + LINE (f, 130)-(f + 20, 150), 11 +233 CIRCLE (f, 105), 10, 11 +234 LINE (f, 120)-(f - 15, 110), 11 + LINE (f, 120)-(f + 15, 110), 11 +235 f = e +236 GOTO 1 + +240 IF e > 595 THEN GOTO 1 +241 e = e + 5 +242 LINE (f, 110)-(f, 130), 11 + LINE (f, 130)-(f - 20, 150), 11 + LINE (f, 130)-(f + 20, 150), 11 +243 CIRCLE (f, 105), 10, 11 +244 LINE (f, 120)-(f - 15, 110), 11 + LINE (f, 120)-(f + 15, 110), 11 +245 f = e +246 GOTO 1 + +250 IF c < e THEN GOTO 255 + LINE (e, 120)-(e + 15, 110), 11 + LINE (e, 120)-(e + 30, 120), colour2 + FOR i = 1 TO speed + NEXT i + LINE (e, 120)-(e + 15, 110), colour2 + LINE (e, 120)-(e + 30, 120), 11 + GOTO 259 +255 LINE (e, 120)-(e - 30, 120), colour2 + LINE (e, 120)-(e - 15, 110), 11 + FOR i = 1 TO speed + NEXT i + LINE (e, 120)-(e - 30, 120), colour2 + LINE (e, 120)-(e - 30, 120), 11 + GOTO 259 +259 IF c + 29 = e OR c - 29 = e OR c + 30 = e OR c - 30 = e THEN + a = a - 2 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 24 = e OR c - 24 = e OR c + 25 = e OR c - 25 = e THEN + a = a - 3 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 19 = e OR c - 19 = e OR c + 20 = e OR c - 25 = e THEN + a = a - 1 + IF snd = 1 THEN SOUND 50, 1 + END IF + GOTO 1 + +260 IF c < e THEN GOTO 265 + LINE (e, 130)-(e + 20, 150), 11 + LINE (e, 130)-(e + 30, 130), colour2 + FOR i = 1 TO speed + NEXT i + LINE (e, 130)-(e + 20, 150), colour2 + LINE (e, 130)-(e + 30, 130), 11 + GOTO 269 +265 LINE (e, 130)-(e - 20, 150), 11 + LINE (e, 130)-(e - 30, 130), colour2 + FOR i = 1 TO speed + NEXT i + LINE (e, 130)-(e - 20, 150), colour2 + LINE (e, 130)-(e - 30, 130), 11 + GOTO 269 +269 IF c + 29 = e OR c - 29 = e OR c + 30 = e OR c - 30 = e THEN + a = a - 2 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 24 = e OR c - 24 = e OR c + 25 = e OR c - 25 = e THEN + a = a - 3 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF c + 19 = e OR c - 19 = e OR c + 20 = e OR c - 20 = e THEN + a = a - 1 + IF snd = 1 THEN SOUND 50, 1 + END IF + GOTO 1 + + +highkick2: + IF c < e THEN GOTO hk2 + LINE (e, 130)-(e + 20, 150), 11 + LINE (e, 130)-(e + 30, 140), colour2 + FOR i = 1 TO speed + NEXT i + LINE (e, 130)-(e + 20, 150), colour2 + LINE (e, 130)-(e + 30, 140), 11 + GOTO hk2x +hk2: + LINE (e, 130)-(e - 20, 150), 11 + LINE (e, 130)-(e - 30, 140), colour2 + FOR i = 1 TO speed + NEXT i + LINE (e, 130)-(e - 20, 150), colour1 + LINE (e, 130)-(e - 30, 140), 11 + GOTO hk2x +hk2x: + IF e + 29 = c OR e - 29 = c OR e + 30 = c OR e - 30 = c THEN + a = a - 2 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF e + 24 = c OR e - 24 = c OR e + 25 = c OR e - 25 = c THEN + a = a - 3 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF e + 19 = c OR e - 19 = c OR e + 20 = c OR e - 20 = c THEN + a = a - 1 + IF snd = 1 THEN SOUND 50, 1 + END IF + GOTO 1 + + +highpunch2: + IF c < e THEN GOTO hp2 + LINE (e, 120)-(e + 15, 110), 11 + LINE (e, 120)-(e + 30, 110), colour1 + FOR i = 1 TO speed + NEXT i + LINE (e, 120)-(e + 15, 110), colour1 + LINE (e, 120)-(e + 30, 110), 11 + GOTO hp2x +hp2: + LINE (e, 120)-(e - 15, 110), 11 + LINE (e, 120)-(e - 30, 110), colour1 + FOR i = 1 TO speed + NEXT i + LINE (e, 120)-(e - 15, 110), colour1 + LINE (e, 120)-(e - 30, 110), 11 + GOTO hp2x +hp2x: + IF e + 29 = c OR e - 29 = c OR e + 30 = c OR e - 30 = c THEN + a = a - 2 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF e + 24 = c OR e - 24 = c OR e + 25 = c OR e - 25 = c THEN + a = a - 3 + IF snd = 1 THEN SOUND 50, 1 + END IF + IF e + 19 = c OR e - 19 = c OR e + 20 = c OR e - 20 = c THEN + a = a - 1 + IF snd = 1 THEN SOUND 50, 1 + END IF + GOTO 1 + + + +600 FOR iii = 1 TO 8000 + LOCATE 12, 32: PRINT "Player 1 Losses!" + NEXT iii + FOR ii = 10 TO 1 STEP -1 + CIRCLE (c, 105), ii + 1, 11 + CIRCLE (c, 105), ii, colour1 + FOR i = 1 TO speed + NEXT i + NEXT ii + GOTO 615 +610 FOR iii = 1 TO 8000 + LOCATE 12, 32: PRINT "Player 2 Losses!" + NEXT iii + FOR ii = 10 TO 1 STEP -1 + CIRCLE (e, 105), ii + 1, 11 + CIRCLE (e, 105), ii, colour2 + FOR i = 1 TO speed + NEXT i + NEXT ii + GOTO 615 + +615 + FOR i = 400 TO 1 STEP -1 + CIRCLE (320, 100), i + PAINT (1, 1), 11 + CIRCLE (320, 100), i + 1, 11 + FOR ii = 1 TO speed / 10 + NEXT ii + NEXT i + +616 GOTO mainmenu + +intro: + + 'MicroTrip + CLS + SCREEN 8 + COLOR 15 + LOCATE 12, 35: PRINT "MicroTrip" + LINE (260, 85)-(350, 97), 1, B + PAINT (259, 84), 9, 1 + PLAY "mb L16 ed L4 e P64 L4 L16 fe L32 f P8 e P8 L4 d P4" + PLAY "mb L16 ed L4 e P64 L4 L17 fe L32 f P8 e P8 L4 d P4" + IF a$ <> "" THEN RETURN + + 'Move Guy + + c = 5 + e = 1000 +moveguy: + LINE (c, 110)-(c, 130) 'body + LINE (c, 130)-(c - 20, 150) 'leg + LINE (c, 130)-(c + 20, 150) 'other leg + IF c < e THEN LINE (c, 120)-(c + 15, 110)'arm + IF c > e THEN LINE (c, 120)-(c - 15, 110)'arm other + CIRCLE (c, 105), 10 'head + FOR i = 1 TO 9000 + NEXT i + LINE (c, 110)-(c, 130), 9 'body + LINE (c, 130)-(c - 20, 150), 9 'leg + LINE (c, 130)-(c + 20, 150), 9 'other leg + IF c < e THEN LINE (c, 120)-(c + 15, 110), 9'arm + IF c > e THEN LINE (c, 120)-(c - 15, 110), 9'arm other + CIRCLE (c, 105), 10, 9 'head + c = c + 1 + a$ = INKEY$ + IF a$ <> "" THEN LET nn = 0: RETURN + IF c >= 595 THEN LET nn = 1: RETURN + GOTO moveguy + +'****I have to fill this in later. It won't work right.**** +story: + CLS + fart = 0 + PAINT (1, 1), 0 + COLOR 4 + LOCATE 1, 1: PRINT "It was the year 1998 when you and Jake decided to start your" + GOTO yeah +first: + PRINT "own 'wrestling' association. You were sick of how fake all of the " + GOTO yeah +second: + PRINT "others including WCW, WWF and NWO, were. Then, simoultaniously, you both" + GOTO yeah +third: + PRINT "had a good idea. What if your 'wrestling' association wasn't fake? What" + GOTO yeah +fourth: + PRINT "if you had all of the 'wrestlers' sign a Beat Down contract saying that " + GOTO yeah +fifth: + PRINT "they would fight to the death? This was gonna' be a kick @$$ 'fighting'" + GOTO yeah +sixth: + PRINT "association! It would be known as the Beat Down Fighting Association!(BDFA)" + GOTO yeah + +endofstory: + IF nn = 0 THEN RETURN + LET nn = 1: RETURN + +yeah: + a$ = INKEY$ + IF a$ <> "" THEN nn = 0: GOTO endofstory + FOR i = 1 TO 1000000 + NEXT i + fart = fart + 1 + ON poop GOTO first, second, third, fourth, fifth, sixth + +666 + diff --git a/samples/beatdown/src/beatdown.zip b/samples/beatdown/src/beatdown.zip new file mode 100644 index 0000000..1ac2ce5 Binary files /dev/null and b/samples/beatdown/src/beatdown.zip differ diff --git a/samples/bezier/index.md b/samples/bezier/index.md index 6141798..d4213c2 100644 --- a/samples/bezier/index.md +++ b/samples/bezier/index.md @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "bezier.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/bezier/src/bezier.bas) -* [RUN "bezier.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/bezier/src/bezier.bas) -* [PLAY "bezier.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/bezier/src/bezier.bas) +* [LOAD "bezier.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/bezier/src/bezier.bas) +* [RUN "bezier.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/bezier/src/bezier.bas) +* [PLAY "bezier.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/bezier/src/bezier.bas) ### File(s) diff --git a/samples/binary-clock/index.md b/samples/binary-clock/index.md index 3a77a76..21967ec 100644 --- a/samples/binary-clock/index.md +++ b/samples/binary-clock/index.md @@ -6,7 +6,7 @@ ### Author -[🐝 RhoSigma](../rhosigma.md) +[🐝 Rho Sigma](../rho-sigma.md) ### Description @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "binclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/binary-clock/src/binclock.bas) -* [RUN "binclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/binary-clock/src/binclock.bas) -* [PLAY "binclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/binary-clock/src/binclock.bas) +* [LOAD "binclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/binary-clock/src/binclock.bas) +* [RUN "binclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/binary-clock/src/binclock.bas) +* [PLAY "binclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/binary-clock/src/binclock.bas) ### File(s) diff --git a/samples/binary-counter/img/screenshot.png b/samples/binary-counter/img/screenshot.png new file mode 100644 index 0000000..27e9563 Binary files /dev/null and b/samples/binary-counter/img/screenshot.png differ diff --git a/samples/binary-counter/index.md b/samples/binary-counter/index.md new file mode 100644 index 0000000..c43e08a --- /dev/null +++ b/samples/binary-counter/index.md @@ -0,0 +1,35 @@ +[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: BINARY COUNTER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 rpgfan3233](../rpgfan3233.md) + +### Description + +```text +' This program is a 12-bit Binary counter, displayed using a 3x4 grid. +' It was created in the honour of an old acquaintance who became +' obsessed with the binary number system. +' +' It uses extended character code 219 from IBM code page 437 to render +' the ON state and a simple space (character code 32) to render the +' OFF state. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "binarycounter.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/binary-counter/src/binarycounter.bas) +* [RUN "binarycounter.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/binary-counter/src/binarycounter.bas) +* [PLAY "binarycounter.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/binary-counter/src/binarycounter.bas) + +### File(s) + +* [binarycounter.bas](src/binarycounter.bas) + +🔗 [binary](../binary.md), [counter](../counter.md) diff --git a/samples/binary-counter/src/binarycounter.bas b/samples/binary-counter/src/binarycounter.bas new file mode 100644 index 0000000..3cb8095 --- /dev/null +++ b/samples/binary-counter/src/binarycounter.bas @@ -0,0 +1,47 @@ +' This program is a 12-bit Binary counter, displayed using a 3x4 grid. +' It was created in the honour of an old acquaintance who became +' obsessed with the binary number system. +' +' It uses extended character code 219 from IBM code page 437 to render +' the ON state and a simple space (character code 32) to render the +' OFF state. +' +' If you don't want to run it and just want to see what it does, check +' out the video on YouTube that inspired the program - +' +' http://www.youtube.com/watch?v=Isydb_TCz_4 +DefInt A-Z +Screen 1 +Cls + +bits = 1 + +Do + bitpos = 1 + row = 3 + col = 4 + + Do + Locate row, col + If bits And bitpos Then Print Chr$(219); Else Print " "; + + bitpos = bitpos * 2 + + col = col - 1 + If col = 0 Then + col = 4 + row = row - 1 + End If + + Loop While row + + Locate 7, 1 + Print LTrim$(RTrim$(Str$(bits))) + + bits = bits + 1 + + _Delay 0.005 'Uncomment this line in QB64 if it runs too quickly. +Loop While bits < 4096 + +System + diff --git a/samples/binary.md b/samples/binary.md new file mode 100644 index 0000000..0e66bf0 --- /dev/null +++ b/samples/binary.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: BINARY + +**[Binary Counter](binary-counter/index.md)** + +[🐝 rpgfan3233](rpgfan3233.md) 🔗 [binary](binary.md), [counter](counter.md) + +' This program is a 12-bit Binary counter, displayed using a 3x4 grid. ' It was created in the ho... diff --git a/samples/biorhythm-chart/img/screenshot.png b/samples/biorhythm-chart/img/screenshot.png new file mode 100644 index 0000000..2a9b691 Binary files /dev/null and b/samples/biorhythm-chart/img/screenshot.png differ diff --git a/samples/biorhythm-chart/index.md b/samples/biorhythm-chart/index.md new file mode 100644 index 0000000..6575bef --- /dev/null +++ b/samples/biorhythm-chart/index.md @@ -0,0 +1,25 @@ +[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: BIORHYTHM CHART + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Bob Seguin](../bob-seguin.md) + +### Description + +```text +'****************************************************************************' +'------------------------- B I O C H A R T . B A S --------------------------' +'------------- Copyright (C) 2007 by Bob Seguin (Freeware)-------------------' +'****************************************************************************' +``` + +### File(s) + +* [biochart.bas](src/biochart.bas) +* [biochart.zip](src/biochart.zip) + +🔗 [biorhythms](../biorhythms.md) diff --git a/samples/biorhythm-chart/src/biochart.bas b/samples/biorhythm-chart/src/biochart.bas new file mode 100644 index 0000000..908fbb8 --- /dev/null +++ b/samples/biorhythm-chart/src/biochart.bas @@ -0,0 +1,314 @@ +'****************************************************************************' +'------------------------- B I O C H A R T . B A S --------------------------' +'------------- Copyright (C) 2007 by Bob Seguin (Freeware)-------------------' +'****************************************************************************' + +DefInt A-Z + +Dim Shared NumBOX(300) +Dim Shared Box(12000) +Dim Shared FontBOX(6000) +Dim Shared xBOX(1 To 9) +Def Seg = VarSeg(FontBOX(0)) +BLoad "brsmssb.fnt", VarPtr(FontBOX(0)) +Def Seg = VarSeg(NumBOX(0)) +BLoad "brsnums.bsv", VarPtr(NumBOX(0)) +Def Seg + +Const Degree! = 3.14159 / 180 +Const Physical! = 90 / 23 +Const Emotional! = 90 / 28 +Const Intellectual! = 90 / 33 +Const Intuitive! = 90 / 38 + +Dim Shared DATE2$, Birthdate$ +Dim Shared Hour! +Dim Shared Months(1 To 12) As Integer +Restore MonthDATA +For n = 1 To 12: Read Months(n): Next n +Restore xDATA +For n = 1 To 8: Read xBOX(n): Next n + +Screen 12 +GoSub SetPALETTE +DATE2$ = Date$ + +Graphics +Birthday + +Do + k$ = UCase$(InKey$) + Select Case k$ + Case "B" + Put (162, 176), Box(), PSet + B$ = GetDATE$ + If B$ = "NULL" Then + System + Else + Birthdate$ = B$ + ChartBD + End If + Case "T" + Put (162, 181), Box(3500), PSet + B$ = GetDATE$ + If B$ = "NULL" Then DATE2$ = Date$ Else DATE2$ = B$ + Line (194, 419)-(294, 434), 0, BF + PrintSTRING 196, 420, "DATE: " + DATE2$ + ChartBD + Case Chr$(27): Exit Do + End Select +Loop + +System + +xDATA: +Data 379,386,402,409,425,432,439,446 + +MonthDATA: +Data 31,28,31,30,31,30,31,31,30,31,30,31 + +SetPALETTE: +Restore SetPALETTE +Data 0,0,21,21,8,43,24,10,48,26,11,53 +Data 28,12,58,32,13,63,63,63,21,42,42,42 +Data 63,0,0,21,31,63,52,41,63,55,55,55 +Data 0,0,42,63,21,63,32,32,42,63,63,63 +Restore SetPALETTE +Out &H3C8, 0 +For n = 1 To 48 + Read Colr + Out &H3C9, Colr +Next n +Return + +Sub Birthday + + Open "brbd.dta" For Binary As #1 + If LOF(1) Then + Close #1 + Open "brbd.dta" For Input As #1 + Input #1, Birthdate$ + Close #1 + Else + Close #1 + Put (162, 176), Box(), PSet + B$ = GetDATE$ + If B$ = "NULL" Then + System + Else + Birthdate$ = B$ + End If + End If + ChartBD + +End Sub + +Sub ChartBD + + Line (220, 89)-(420, 102), 0, BF + PrintSTRING 240, 89, "For a person born" + PrintSTRING 340, 89, Birthdate$ + Open "brbd.dta" For Output As #1 + Print #1, Birthdate$ + Close #1 + ChartGFX + + Hour! = Val(Mid$(Time$, 1, 2)) * .83 + Line (310 + Hour!, 110)-(310 + Hour!, 426), 11 + Line (310 + Hour!, 426)-(338, 426), 11 + PSet (310, 410), 7: Draw "D16L12" + + Month$ = Mid$(DATE2$, 1, 2) + Day$ = Mid$(DATE2$, 4, 2) + Year$ = Mid$(DATE2$, 7, 4) + M$ = Mid$(Birthdate$, 1, 2) + D$ = Mid$(Birthdate$, 4, 2) + y$ = Mid$(Birthdate$, 7, 4) + FirstMONTH = Months(Val(M$)) - Val(D$) + 1 + For n = (Val(M$) + 1) To 12 + BalMONTHS = BalMONTHS + Months(n) + If n = 2 And ((Val(y$) Mod 4) = 0) Then BalMONTHS = BalMONTHS + 1 + Next n + FirstYEAR = FirstMONTH + BalMONTHS + For n = (Val(y$) + 1) To (Val(Year$) - 1) + If n Mod 4 = 0 Then Yr = 366 Else Yr = 365 + TDays = TDays + Yr + Next n + TDays = TDays + FirstYEAR + + For n = 1 To Val(Month$) - 1 + Days = Days + Months(n) + If n = 2 Then + If Val(Year$) Mod 4 = 0 Then Days = Days + 1 + End If + Next n + + TDays = TDays + Days + Val(Day$) - 1 + + View Screen(10, 110)-(630, 410) + + 'EMOTIONAL + PreviousX = 320 - (((TDays Mod 28) + 28) * 20) + PreviousY = 260 + C! = 0 + For x = 320 - (((TDays Mod 28) + 28) * 20) To 630 Step 5 + Line (PreviousX, PreviousY)-(x, 260 + Sin(C! * Degree!) * 150), 8 + PreviousX = x + PreviousY = 260 + Sin(C! * Degree!) * 150 + C! = C! - Emotional! + Next x + + 'INTELLECTUAL + PreviousX = 320 - (((TDays Mod 33) + 33) * 20) + PreviousY = 260 + C! = 0 + For x = 320 - (((TDays Mod 33) + 33) * 20) To 630 Step 5 + Line (PreviousX, PreviousY)-(x, 260 + Sin(C! * Degree!) * 150), 6 + PreviousX = x + PreviousY = 260 + Sin(C! * Degree!) * 150 + C! = C! - Intellectual! + Next x + + PreviousX = 10 + PreviousY = 260 + C! = 0 + 'PHYSICAL + PreviousX = 320 - (((TDays Mod 23) + 23) * 20) + PreviousY = 250 + For x = 320 - (((TDays Mod 23) + 23) * 20) To 630 Step 5 + Line (PreviousX, PreviousY)-(x, 260 + Sin(C! * Degree!) * 150), 9 + PreviousX = x + PreviousY = 260 + Sin(C! * Degree!) * 150 + C! = C! - Physical! + Next x + + + 'INTUITIVE + PreviousX = 320 - (((TDays Mod 38) + 38) * 20) + PreviousY = 260 + C! = 0 + For x = 320 - (((TDays Mod 38) + 38) * 20) To 630 Step 5 + Line (PreviousX, PreviousY)-(x, 260 + Sin(C! * Degree!) * 150), 13 + PreviousX = x + PreviousY = 260 + Sin(C! * Degree!) * 150 + C! = C! - Intuitive! + Next x + + View + +End Sub + +DefSng A-Z +Sub ChartGFX + + Line (5, 106)-(634, 414), 7, BF + Line (9, 109)-(631, 170), 1, BF + Line (9, 170)-(631, 230), 2, BF + Line (9, 230)-(631, 290), 3, BF + Line (9, 290)-(631, 350), 2, BF + Line (9, 350)-(631, 411), 1, BF + Line (9, 109)-(631, 411), 7, B + For x = 30 To 610 Step 20 + Line (x, 110)-(x, 410), 7 + If x = 330 Then Paint (x - 10, 260), 7 + Next x + Line (10, 260)-(630, 260), 7 + +End Sub + +DefInt A-Z +Function GetDATE$ + i = 1: Interval! = .25: Colr = 15 + Do + Wait &H3DA, 8: Wait &H3DA, 8, 8 + If i < 9 Then Line (xBOX(i) + 1, 201)-(xBOX(i) + 6, 202), Colr, B + k$ = InKey$ + Select Case k$ + Case "0" To "9" + If i < 9 Then + Line (xBOX(i) + 1, 201)-(xBOX(i) + 6, 202), 15, BF + PutNUMS xBOX(i), Val(k$) + D$ = D$ + k$ + i = i + 1 + End If + Case Chr$(13) 'Enter + If Len(D$) = 8 Then + mm$ = Mid$(D$, 1, 2) + dd$ = Mid$(D$, 3, 2) + yy$ = Mid$(D$, 5, 4) + If Val(mm$) > 0 And Val(mm$) < 13 Then + If Val(dd$) > 0 And Val(dd$) < 32 Then + If Val(yy$) > 1900 And Val(yy$) < 3000 Then + GetDATE$ = mm$ + "-" + dd$ + "-" + yy$ + Else + GetDATE$ = "NULL" + End If + Else + GetDATE$ = "NULL" + End If + Else + GetDATE$ = "NULL" + End If + Else + GetDATE$ = "NULL" + End If + Exit Function + Case Chr$(8) 'Backspace + If i > 1 Then + If i < 9 Then Line (xBOX(i), 193)-(xBOX(i) + 6, 202), 15, BF + i = i - 1 + Line (xBOX(i), 193)-(xBOX(i) + 6, 202), 15, BF + D$ = Mid$(D$, 1, Len(D$) - 1) + End If + End Select + + If Timer > StartTIME! + Interval! Then + StartTIME! = Timer + If Colr = 15 Then Colr = 7 Else Colr = 15 + End If + + Loop + +End Function + +Sub Graphics + Def Seg = VarSeg(Box(0)) + BLoad "brsheads.bsv", VarPtr(Box(0)) + Def Seg + Put (78, 32), Box() + Put (20, 440), Box(7000) + Put (10, 6), Box(10000) + Put (500, 6), Box(11200) + + PrintSTRING 196, 420, "DATE: " + DATE2$ + PrintSTRING 342, 420, "TIME: " + Time$ + PrintSTRING 12, 460, "Press [B] to enter a new birth date" + PrintSTRING 270, 460, "Press [T] to enter a target date" + PrintSTRING 520, 460, "Press [ESC] to QUIT" + + ChartGFX + + Def Seg = VarSeg(Box(0)) + BLoad "brsinpt.bsv", VarPtr(Box(0)) + Def Seg + +End Sub + +Sub PrintSTRING (x, y, Prnt$) + + For i = 1 To Len(Prnt$) + Char$ = Mid$(Prnt$, i, 1) + If Char$ = " " Then + x = x + FontBOX(1) + Else + Index = (Asc(Char$) - 33) * FontBOX(0) + 2 + Put (x, y), FontBOX(Index) + x = x + FontBOX(Index) + End If + Next i + +End Sub + +Sub PutNUMS (x, Num) + Put (x, 191), NumBOX(Num * 30) +End Sub diff --git a/samples/biorhythm-chart/src/biochart.zip b/samples/biorhythm-chart/src/biochart.zip new file mode 100644 index 0000000..a7c78bd Binary files /dev/null and b/samples/biorhythm-chart/src/biochart.zip differ diff --git a/samples/biorhythms.md b/samples/biorhythms.md new file mode 100644 index 0000000..184c2b7 --- /dev/null +++ b/samples/biorhythms.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: BIORHYTHMS + +**[Biorhythm Chart](biorhythm-chart/index.md)** + +[🐝 Bob Seguin](bob-seguin.md) 🔗 [biorhythms](biorhythms.md) + +'****************************************************************************' '-----------------... diff --git a/samples/blockout/index.md b/samples/blockout/index.md index c3cb5a8..b476144 100644 --- a/samples/blockout/index.md +++ b/samples/blockout/index.md @@ -18,9 +18,9 @@ A Breakout clone with DXBall aspirations. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "blockout.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/blockout/src/blockout.bas) -* [RUN "blockout.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/blockout/src/blockout.bas) -* [PLAY "blockout.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/blockout/src/blockout.bas) +* [LOAD "blockout.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/blockout/src/blockout.bas) +* [RUN "blockout.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/blockout/src/blockout.bas) +* [PLAY "blockout.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/blockout/src/blockout.bas) ### File(s) diff --git a/samples/bob-seguin.md b/samples/bob-seguin.md index 2fcce06..4a7f2f5 100644 --- a/samples/bob-seguin.md +++ b/samples/bob-seguin.md @@ -14,6 +14,12 @@ Abacus app by Bob Seguin. NOTE: This game requires graphics files created by an A Graphics/Animation utility by Bob Seguin. NOTE: This game requires graphics files created by a... +**[Biorhythm Chart](biorhythm-chart/index.md)** + +[🐝 Bob Seguin](bob-seguin.md) 🔗 [biorhythms](biorhythms.md) + +'****************************************************************************' '-----------------... + **[Rattler](rattler/index.md)** [🐝 Bob Seguin](bob-seguin.md) 🔗 [game](game.md), [snake](snake.md) diff --git a/samples/breakout.md b/samples/breakout.md index c9d27dc..ebe5961 100644 --- a/samples/breakout.md +++ b/samples/breakout.md @@ -8,6 +8,12 @@ A Breakout clone with DXBall aspirations. +**[Breakout](breakout/index.md)** + +[🐝 kinem](kinem.md) 🔗 [game](game.md), [breakout](breakout.md) + +Breakout game. + **[QBricks](qbricks/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [breakout](breakout.md) diff --git a/samples/breakout/img/breakout-kinem.png b/samples/breakout/img/breakout-kinem.png new file mode 100644 index 0000000..044ccb6 Binary files /dev/null and b/samples/breakout/img/breakout-kinem.png differ diff --git a/samples/breakout/index.md b/samples/breakout/index.md new file mode 100644 index 0000000..8d37f87 --- /dev/null +++ b/samples/breakout/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: BREAKOUT + +![breakout-kinem.png](img/breakout-kinem.png) + +### Author + +[🐝 kinem](../kinem.md) + +### Description + +```text +Breakout game. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "breakoutkinem.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/breakout/src/breakoutkinem.bas) +* [RUN "breakoutkinem.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/breakout/src/breakoutkinem.bas) +* [PLAY "breakoutkinem.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/breakout/src/breakoutkinem.bas) + +### File(s) + +* [breakoutkinem.bas](src/breakoutkinem.bas) + +🔗 [game](../game.md), [breakout](../breakout.md) diff --git a/samples/breakout/src/breakoutkinem.bas b/samples/breakout/src/breakoutkinem.bas new file mode 100644 index 0000000..4d8fe33 --- /dev/null +++ b/samples/breakout/src/breakoutkinem.bas @@ -0,0 +1,31 @@ +'$lang:"qb" 'BO5.BAS 'kinem 'QB4.5 +Screen 13: Dim circ(26): Circle (2, 2), 2: qb = (Point(2, 0) > 0): Cls +Line (1, 0)-(3, 0): Line (1, 4)-(3, 4): Line (0, 1)-(0, 3): Line (4, 1)-(4, 3) +Get (0, 0)-(4, 4), circ() +Line (0, 30)-(319, 50), 3, BF: Line (0, 70)-(319, 80), 2, BF: siz = 20 +Line (0, 80)-(319, 90), 1, BF: Line (0, 0)-(319, 10), 4, BF: px = 160 +Locate 25, 1: Print "press space to start";: Do: i$ = InKey$: vx = 2: vy = 2 +Loop Until i$ = " ": Locate 25, 1: Print String$(20, 32);: bx = 80: by = 100 +Put (bx - 2, by - 2), circ(), Xor +1 If opx <> px Or siz <> osiz Then Line (opx - 20, 192)-(opx + 20, 199), 0, BF +Line (px - siz, 192)-(px + siz, 199), 7, BF: opx = px: osiz = siz +Line (px - siz, 199)-(px - siz + 7, 192), 8 +Line (px + siz, 199)-(px + siz - 7, 192), 8 +i$ = Right$(InKey$, 1): If i$ = "M" And px < 317 - siz Then px = px + 3 +If i$ = "K" And px > siz + 2 Then px = px - 3 +Put (bx - 2, by - 2), circ(), Xor +bx = bx + vx: by = by + vy: If bx < 2 Then vx = Abs(vx): bx = 2 +If bx > 317 Then vx = -Abs(vx): bx = 317 +If by < 2 Then vy = Abs(vy): by = 2: If siz > 7 Then siz = siz - 1 +Put (bx - 2, by - 2), circ(), Xor +bt = Point(bx, by): t = Timer: Do: Loop Until Timer - t >= .05 +If bt And bt < 7 Then + Put (bx - 2, by - 2), circ(), Xor + vy = -vy: For r = 0 To RR Step 1: Circle (bx, by), r, 0 + Circle (bx, by + 1), r, 0: Next: Put (bx - 2, by - 2), circ(), Xor + s = s + bt * (1 - (vy < 0)): Locate 1, 1: Print "score"; s: RR = RR + .5 +End If: dx = bx - px +If by > 190 And Abs(dx) < siz + 1 Then vy = -vy: vx = vx + dx / siz +If i$ <> Chr$(27) And by < 193 GoTo 1 +If Not qb Then t = Timer: Do: Loop Until Timer - t >= .25: Sleep + diff --git a/samples/brian-murphy.md b/samples/brian-murphy.md new file mode 100644 index 0000000..a7dff44 --- /dev/null +++ b/samples/brian-murphy.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 BRIAN MURPHY + +**[Beatdown](beatdown/index.md)** + +[🐝 Brian Murphy](brian-murphy.md) 🔗 [game](game.md), [legacy](legacy.md) + +' Beat Down ' 1998 MicroTrip ' ... diff --git a/samples/calc/img/screenshot.png b/samples/calc/img/screenshot.png new file mode 100644 index 0000000..c99390c Binary files /dev/null and b/samples/calc/img/screenshot.png differ diff --git a/samples/calc/index.md b/samples/calc/index.md new file mode 100644 index 0000000..3847196 --- /dev/null +++ b/samples/calc/index.md @@ -0,0 +1,80 @@ +[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: CALC + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 William Loughner](../william-loughner.md) + +### Description + +```text +' CALC.BAS +' by William Loughner +' Copyright (c) 1994 DOS Resource Guide +' Published in Issue #14, March 1994, page 58 + +============================================================================== + +---------- + CALC.BAS +---------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x. + +WHAT CALC.BAS DOES: +CALC.BAS is a simple calculator program that you can use whenever you need to +make arithmetic calculations involving addition, subtraction, multiplication, +division, and raising to a power (exponentiation). + +USING CALC.BAS +To load the program, type QBASIC CALC.BAS (using path names if necessary) at +the DOS prompt. Then run the program by selecting the Start option in QBasic's +Run menu, or press Shift-F5. After clearing the screen, CALC.BAS displays a +line where you may enter your calculation and a second line that keeps a +running total for you. Like a standard calculator, it displays keystrokes as +you type them and evaluates expressions from left to right. When you type the +equal sign (=) or press Enter, the program clears the calculation, tells you +that the running total is the answer, and reminds you what keystrokes to press +to proceed. + +Permissible keystrokes are the numbers from zero to 9; a decimal point; the +operators for addition, subtraction, multiplication, division, and raising to +a power (+, -, *, /, and ^); open and close parentheses (); open and close +brackets []; an equal sign; Enter; and an upper- or lowercase "x." If you +press other keys, CALC.BAS issues an error message. Typing x or X ends the +program. + +CALC.BAS can handle one level of parentheses. An open parentheses sets the +running total to zero, and a close parentheses resets the running total to +that of the entire expression. + +To access CALC.BAS quickly and easily, create the following one-line batch +file, and place it in your C:\BATCH directory: + +@QBASIC /RUN CALC + +If you name this batch file CALC.BAT and include the C:\BATCH directory in the +PATH statement in your AUTOEXEC.BAT file, you can start QBasic and run +CALC.BAS by typing CALC at the DOS prompt. + +For further details on CALC.BAS, see "It All Adds Up" (Readers' Queue, DRG +#14, March 1994, page 58). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "calc.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/calc/src/calc.bas) +* [RUN "calc.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/calc/src/calc.bas) +* [PLAY "calc.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/calc/src/calc.bas) + +### File(s) + +* [calc.bas](src/calc.bas) + +🔗 [calculator](../calculator.md), [dos world](../dos-world.md) diff --git a/samples/calc/src/calc.bas b/samples/calc/src/calc.bas new file mode 100644 index 0000000..6364b2a --- /dev/null +++ b/samples/calc/src/calc.bas @@ -0,0 +1,79 @@ +' CALC.BAS +' by William Loughner +' Copyright (c) 1994 DOS Resource Guide +' Published in Issue #14, March 1994, page 58 + +DO +Total = 0: Calculation$ = "": Op$ = "+": Key$ = "x": NegFlag% = 0 +DO +GOSUB GetKeyStroke +SELECT CASE Key$ + CASE "(", "[" + IF NParen% = 1 THEN + Key$ = "" + ELSE + IF NegFlag% = 1 THEN ParenNeg% = 1: NegFlag% = 0 + Operand$ = "": NParen% = 1: ParenTotal = Total: Total = 0 + ParenOp$ = Op$: Op$ = "+" + END IF + CASE ")", "]" + IF NParen% = 0 THEN + Key$ = "" + ELSE + GOSUB Operate: IF ParenNeg% = 1 THEN Total = -Total: ParenNeg% = 0 + Op$ = ParenOp$: Operand$ = STR$(Total): Total = ParenTotal + GOSUB Operate: NParen% = 0 + END IF + CASE "=", CHR$(13) + IF NParen% = 1 THEN + Key$ = "" + ELSE + GOSUB Operate: EXIT DO + END IF + CASE "s", "+", "*", "/", "^" + GOSUB Operate: NegFlag% = 0: IF Key$ = "s" THEN Key$ = "-" + CASE "-", ".", "0" TO "9" + Operand$ = Operand$ + Key$: NegFlag% = 1 + CASE ELSE + Key$ = "" +END SELECT +Calculation$ = Calculation$ + Key$ +LOOP +GOSUB GetKeyStroke +LOOP + +GetKeyStroke: +CLS : PRINT "Calculation: "; Calculation$ +LOCATE 7, 1: PRINT "Running total: "; Total +SELECT CASE Key$ + CASE "" + PRINT "** You can't do that **" + CASE "=", CHR$(13) + PRINT "** ANSWER ** (Press X to quit, any other key to calculate again.)" +END SELECT +DO: Key$ = INKEY$: LOOP UNTIL Key$ <> "" +SELECT CASE Key$ + CASE "x", "X" + END + CASE "-" + IF NegFlag% = 1 THEN Key$ = "s" +END SELECT +RETURN + +Operate: +Operand = VAL(Operand$): Operand$ = "" +SELECT CASE Op$ + CASE "+" + Total = Total + Operand + CASE "s" + Total = Total - Operand + CASE "*" + Total = Total * Operand + CASE "/" + Total = Total / Operand + CASE "^" + Total = Total ^ Operand +END SELECT +Op$ = Key$ +RETURN + diff --git a/samples/calculator.md b/samples/calculator.md new file mode 100644 index 0000000..86393b0 --- /dev/null +++ b/samples/calculator.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: CALCULATOR + +**[Calc](calc/index.md)** + +[🐝 William Loughner](william-loughner.md) 🔗 [calculator](calculator.md), [dos world](dos-world.md) + +' CALC.BAS ' by William Loughner ' Copyright (c) 1994 DOS Resource Guide ' Published i... diff --git a/samples/calendar.md b/samples/calendar.md new file mode 100644 index 0000000..2630d4b --- /dev/null +++ b/samples/calendar.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: CALENDAR + +**[Calendar](calendar/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [calendar](calendar.md), [pdf](pdf.md), [dos world](dos-world.md) + +' Antonio & Alfonso De Pasquale ' Copyright (C) 1993 DOS Resource Guide ' Published in Issue #8, ... diff --git a/samples/calendar/img/screenshot.png b/samples/calendar/img/screenshot.png new file mode 100644 index 0000000..e58ed1b Binary files /dev/null and b/samples/calendar/img/screenshot.png differ diff --git a/samples/calendar/index.md b/samples/calendar/index.md new file mode 100644 index 0000000..5d6d739 --- /dev/null +++ b/samples/calendar/index.md @@ -0,0 +1,60 @@ +[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: CALENDAR + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 A&A De Pasquale](../a&a-de-pasquale.md) + +### Description + +```text +' Antonio & Alfonso De Pasquale +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #8, March 1993, page 47 + +============================================================================== + +-------------- + CALENDAR.BAS +-------------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x, and a dot-matrix or HP LaserJet-compatible printer. + +WHAT CALENDAR.BAS DOES: +This QBasic program lets you print out a full year's calendar on a single +page. CALENDAR.BAS accounts for leap years and works for 1753 and any year +thereafter. + +USING CALENDAR.BAS: +To load the program, type QBASIC CALENDAR.BAS (using path names if necessary) +at the DOS prompt. Then run the program by selecting the Start option in +QBasic's Run menu, or press Shift-F5. The screen clears, and a greeting +appears. The program then asks you to enter the year for which you want a +calendar. + +When you enter an acceptable year, the program performs its calculations and +reminds you to make sure your printer is turned on and on line. Press Enter to +begin printing the calendar. The program displays a message when printing +finishes. + +For further details on CALENDAR.BAS, see "The Perpetual Calendar" (DRG #8, +March 1993, page 47). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "calendar.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/calendar/src/calendar.bas) +* [RUN "calendar.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/calendar/src/calendar.bas) +* [PLAY "calendar.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/calendar/src/calendar.bas) + +### File(s) + +* [calendar.bas](src/calendar.bas) + +🔗 [calendar](../calendar.md), [pdf](../pdf.md), [dos world](../dos-world.md) diff --git a/samples/calendar/src/calendar.bas b/samples/calendar/src/calendar.bas new file mode 100644 index 0000000..c0457e5 --- /dev/null +++ b/samples/calendar/src/calendar.bas @@ -0,0 +1,183 @@ +' Antonio & Alfonso De Pasquale +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #8, March 1993, page 47 +' +' PERPETUAL CALENDAR PROGRAM + +Setup: + CLS + CLEAR + DIM Year(12, 6, 7), Month$(12), Month(12), Day$(7) + FOR X = 1 TO 12 + FOR Y = 0 TO 6 + FOR Z = 0 TO 7 + Year(X, Y, Z) = 0 + NEXT Z + NEXT Y + NEXT X + +GetYear: + CLS + PRINT TAB(30); "Calendar Creator" + PRINT + PRINT TAB(20); "By Antonio and Alfonso De Pasquale" + PRINT + INPUT "What is the calendar year you want"; Year$ + YR = VAL(Year$) + + IF YR < 1753 THEN + PRINT + PRINT "Year must be greater than 1752. "; + INPUT "Press to try again"; A$ + GOTO GetYear + END IF + + PRINT + PRINT "Please make sure your printer is turned on and is on-line" + PRINT "Also, make sure the paper is set to the top of the form" + PRINT + INPUT "Press when you are ready to continue"; A$ + PRINT + PRINT "Calculating dates...please wait" + PRINT + +CalcYear: + C = INT(YR / 100) + IF RIGHT$(STR$(YR), 2) = "00" THEN C = C - 1 + D = (YR - (100 * C)) - 1 + IF D = -1 THEN D = 99 + K = 1 + M = 11 + X = (INT(2.6 * M - .2) + K + D + INT(D / 4) + INT(C / 4) - (2 * C)) / 7 + G = ABS(X - INT(X)) + F = INT(7 * G + .00001) + 1 + + IF (YR / 4) = INT(YR / 4) AND RIGHT$(Year$, 2) <> "00" THEN + LY = 1 + GOTO FillYear + END IF + + IF (YR / 400) = INT(YR / 400) AND RIGHT$(Year$, 2) = "00" THEN + LY = 1 + GOTO FillYear + END IF + + LY = 0 + +FillYear: + FOR X = 1 TO 7 + READ Day$(X) + NEXT X + FOR X = 1 TO 12 + READ Month$(X) + NEXT X + FOR X = 1 TO 12 + READ Month(X) + NEXT X + IF LY = 1 THEN Month(2) = 29 + + FOR X = 1 TO 12 + R = 1 + FOR G = 1 TO Month(X) + Year(X, R, F) = G + F = F + 1 + IF F = 8 THEN F = 1: R = R + 1 + NEXT G + NEXT X + DATA S,M,T,W,T,F,S + DATA JANUARY,FEBRUARY,MARCH,APRIL,MAY,JUNE,JULY + DATA AUGUST,SEPTEMBER,OCTOBER,NOVEMBER,DECEMBER + DATA 31,28,31,30,31,30,31,31,30,31,30,31 + +BuildCalendar: + LPRINT + LPRINT + LPRINT SPACE$(36); + FOR X = 1 TO 5 + LPRINT MID$(Year$, X, 1); " "; + NEXT X + LPRINT + LPRINT + FOR I = 1 TO 12 STEP 2 + GOSUB PrintStars + GOSUB PrintMonth + GOSUB PrintWeek + FOR Week = 1 TO 6 + LPRINT SPACE$(7); + LPRINT "* "; + FOR X = 1 TO 7 + SELECT CASE Year(I, Week, X) + CASE IS = 0 + LPRINT SPACE$(4); + CASE IS < 10 + SPV = 1 + LPRINT SPACE$(SPV); Year(I, Week, X); + CASE IS > 9 + SPV = 0 + LPRINT SPACE$(SPV); Year(I, Week, X); + END SELECT + NEXT X + LPRINT SPACE$(2); "* "; + FOR X = 1 TO 7 + SELECT CASE Year(I + 1, Week, X) + CASE IS = 0 + LPRINT SPACE$(4); + CASE IS < 10 + SPV = 1 + LPRINT SPACE$(SPV); Year(I + 1, Week, X); + CASE IS > 9 + SPV = 0 + LPRINT SPACE$(SPV); Year(I + 1, Week, X); + END SELECT + NEXT X + LPRINT SPACE$(2); "*" + NEXT Week + NEXT I + GOSUB PrintStars + LPRINT CHR$(12) + PRINT "Calendar has been printed." + END + +PrintStars: + LPRINT SPACE$(7); + FOR A = 1 TO 65 + LPRINT "*"; + NEXT A + LPRINT + RETURN + +PrintMonth: + FOR B = 1 TO 12 STEP 2 + IF B = I THEN + GOSUB FindMonth + END IF + NEXT B + RETURN + +PrintWeek: + LPRINT SPACE$(7); + LPRINT "*"; SPACE$(3); + FOR D = 1 TO 2 + FOR D1 = 1 TO 7 + LPRINT Day$(D1); SPACE$(3); + NEXT D1 + LPRINT "*"; SPACE$(3); + NEXT D + LPRINT + RETURN + +FindMonth: + T1 = LEN(Month$(B)) + T2 = LEN(Month$(B + 1)) + T3 = INT((33 - T1) / 2) + T4 = INT((33 - T2) / 2) + LPRINT SPACE$(7); "*"; + LPRINT SPACE$(T3); Month$(B); + RT = 33 - T3 - T1 + LPRINT SPACE$(RT - 2); "*"; + LPRINT SPACE$(T4); Month$(B + 1); + RT = 33 - T4 - T2 + LPRINT SPACE$(RT - 2); "*"; + LPRINT + RETURN + diff --git a/samples/castle/index.md b/samples/castle/index.md index 2eda29b..000e6a1 100644 --- a/samples/castle/index.md +++ b/samples/castle/index.md @@ -18,9 +18,9 @@ A turn-based artillery game by Microsoft. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "castle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/castle/src/castle.bas) -* [RUN "castle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/castle/src/castle.bas) -* [PLAY "castle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/castle/src/castle.bas) +* [LOAD "castle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/castle/src/castle.bas) +* [RUN "castle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/castle/src/castle.bas) +* [PLAY "castle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/castle/src/castle.bas) ### File(s) diff --git a/samples/chess.md b/samples/chess.md new file mode 100644 index 0000000..8698f69 --- /dev/null +++ b/samples/chess.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: CHESS + +**[Chess](chess/index.md)** + +[🐝 Richard Frost](richard-frost.md) 🔗 [game](game.md), [chess](chess.md) + +Eccentric chess implementation by Richard Frost. diff --git a/samples/chess/img/screenshot.png b/samples/chess/img/screenshot.png new file mode 100644 index 0000000..5f3197c Binary files /dev/null and b/samples/chess/img/screenshot.png differ diff --git a/samples/chess/index.md b/samples/chess/index.md new file mode 100644 index 0000000..bcd2080 --- /dev/null +++ b/samples/chess/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: CHESS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Richard Frost](../richard-frost.md) + +### Description + +```text +Eccentric chess implementation by Richard Frost. +``` + +### File(s) + +* [chess.bas](src/chess.bas) +* [chess.zip](src/chess.zip) + +🔗 [game](../game.md), [chess](../chess.md) diff --git a/samples/chess/src/chess.bas b/samples/chess/src/chess.bas new file mode 100644 index 0000000..00c8ebf --- /dev/null +++ b/samples/chess/src/chess.bas @@ -0,0 +1,8614 @@ +' CHESS aka Dodo Zero aka Deep Color aka Dim Blue +' Author: rfrost@mail.com +' Last update: Feb 28, 2022 - 6880 active lines + +' - compile with QB64 Windows or Linux version 1.3 or better, 64 or 32 bit version +' - not necessary to compile minimax unless one wishes to use it +' - not tested by author in MacOS +' - critical bits of code ugly due to branchless programming for speed + +' NOTE: +' The method for moving pieces WAS, by default, unique. Hover the mouse +' cursor over a piece for 2 seconds and it will be selected. Hover the +' mouse cursor over the destination square for 2 seconds and it will be +' selected. This is a nice mode for using a trackpad, however, the +' downside is that one must remember to move the cursor elsewhere after +' moving so the piece is not autoselected on the next move. Hover may +' be activated in the Setup menu. + +' todo: UCI/Winboard interface +' connectivity to play online +' Increment/Bronstein/Simple delay for clocks +' better screenhide during initializations +' alpha/beta pruning +' playback from black side +' allow mix/match from sets +' convert castle$ to numeric + +' COMMAND$ options: +' n - plies (2 stupid, 4 default, 5+ too slow) +' / - computer plays itself (for screensaver) +' init - ignore configuration file (reads chessb.dat) +' nim - no intro music (loads faster) +' match - play Minimax endlessly +' server - be a waitress (local) +' server2 - be a waitress & fire up client (local) +' client - connect to server (local) + +' Tiny numbers at top are: +' 1) left - points ahead/behind (in normal print with other display) +' perpetual:draw (game stops at 3 for perpetual, 50 for draw) +' 2) middle - current time (currently disabled) +' 3) right: +' a) total seconds delayed this session (CPU overheat fix) +' b) current moves per second +' c) best moves per second this session +' d) total moves computed this session + +' Undocumented keys/mouse: +' ` - cycle thru 12 schemes of colors/clock/pieces +' 0 - plasma toggle +' D - deep (only for top 2 or 3 moves, but really slows it down) +' G - MPS scale top/seen +' I - identify players (name input) +' j - examine FEN positions/replies +' J - add FEN/reply +' k - minimal info (way faster) +' L - endless loop in Playback (to memorize classic games) +' m - Dodo vs Minimax, one game (at main menu) +' M - magnify mouse position +' q - quit (unless promoting) +' R - developer mode toggle (debugging, extra info, extra features) +' x - sound test if sound on (intro music) +' X - disable takeback for current game +' z - show all sets +' Z - show pieces for funny set +' \ - scores on board +' +/- - resize pieces (not saved) +' PgUp/PgDn - volume + +' In menu, but quicker: +' 1 - color white squares +' 2 - color black squares +' 3 - color clock & text highlight +' 4 - color background +' 5 - background pattern toggle +' B - square border style +' c - clock type: font,7 segment, Nixie +' C - cursor type +' f - slide speed +' F - file playback +' g - plasma restart +' H - hover mode +' l - legend +' m - markers +' N - notation algebraic/descriptive +' S - change chess set +' t - same as c (time) + +Option _Explicit +DefLng A-Z ' faster than integer, makes no sense to me but is +$Checking:Off +$Resize:On + +Const true = 1, false = 0 + +Common Shared minty, dircmd$, delcmd$, rencmd$, editcmd$ +$If WIN Then + $ExeIcon:'.\chessdat\chess.ico' + Const slash = "\" + Declare Library "./mem" ' S McNeill CPU load tracking, Linux uses sensors + Function GetCPULoad# + End Declare + dircmd$ = "dir " + delcmd$ = "del " + rencmd$ = "ren " + editcmd$ = "notepad " +$Else + $ExeIcon:'./chessdat/chess.ico' + Const slash = "/" ' + minty = true + dircmd$ = "ls -lt " + delcmd$ = "rm " ' remove file (delete) + rencmd$ = "mv " ' rename file + editcmd$ = "xed " ' all versions of Linux have this editor, I hope +$End If + +Const alphaz$ = "abcdefgh" ' a is for apple +Const tbmax = 128 ' takeback history +Const mult = 32 ' piece value multiplier + +Const intro = 1, click1 = 2, click2 = 3, movedone = 4, takeback = 5 ' sounds +Const checkn = 6, won = 7, stalemate = 8, promotion = 9, illegal = 10, resign = 11 + +Const Rook = 1, Knight = 2, Bishop = 3, Queen = 4, King = 5, Pawn = 6 ' the usual suspects + +Type mtype ' move + fc As _Byte ' from column + fr As _Byte ' from row + tc As _Byte ' to column + tr As _Byte ' to row + 'os As Integer ' original score + sc As Integer ' score + 'mi As _byte ' move index +End Type + +Common Shared As _Byte abort ' stop thinking & move now +Common Shared As _Byte alfred, alfredon ' Alfred E. Nueman +Common Shared As _Byte allsetsloaded +Common Shared As _Byte altbg ' 0hexagon 1Sierpinski 2Shaded 3Off 4Cheetos 5Fruit Loops +Common Shared As _Byte asci ' ASCII of INKEY$ +Common Shared As _Byte autopause ' Leeloo multipass +Common Shared As _Byte b1, b2 ' mouse button left and right +Common Shared As _Byte backok ' take back move (turn off with X) +Common Shared As _Byte bgc ' background color index +Common Shared bgi ' background image +Common Shared As _Byte bgmax ' 5 normal, 7 me +Common Shared boltx1, boltx2, bolty1, bolty2 +Common Shared As _Byte bri ' brightness +'Common Shared btoggle +Common Shared As _Unsigned _Byte captions 'for funny pix +Common Shared As _Byte cflag ' castling +Common Shared As _Byte check, incheck ' God Save the King +Common Shared As _Byte click ' mouse noise +Common Shared As _Byte barebones ' turn off captured, log, and clock +Common Shared As _Byte chimp +Common Shared As _Byte cmatch ' Dodo vs Minimax +Common Shared As _Byte cmate ' Coffeemate, an edible oil product +Common Shared As _Byte cmode ' clock mode (laudry countdown timer) +Common Shared As _Byte colori1 ' index to white square color +Common Shared As _Byte colori2 ' index to black square color +Common Shared As _Byte colori3 ' index to clock color +Common Shared As _Byte cursortype ' crosshair, link, normal, etc +Common Shared As _Byte deep ' experimental, look deeper for top 2 or 3 moves +Common Shared As _Byte dev ' development mode +Common Shared As _Byte defaultfontsize ' 14 for now +Common Shared As _Byte clocktype ' 0 font, 1 7-segment, 2 Nixie +Common Shared As _Byte cycle ' a bicycle built for 3 +Common Shared As _Byte drawcount ' 0 - 50 +Common Shared As _Byte dosmallboard ' inactive, too slow +Common Shared As _Byte endgame ' flag +Common Shared As _Byte Enter10 ' shift-Enter skips 10 moves in playback +Common Shared explosion ' exit amusement +Common Shared As _Byte fast ' speed of sliding for pieces +Common Shared As _Byte fc, fr ' from row, from column +Common Shared As _Byte fullscreenflag ' blueberry waffle +Common Shared As _Byte getwbflag ' asking, ignore most keys except W or B +Common Shared As _Byte giveup +Common Shared As _Byte graphics ' plasma: 0 off, 1 w sq, 2 b sq, 3 all sq +Common Shared As _Byte gscale ' MPS scale top/seen +Common Shared As _Byte hinit ' human cursor initializion flag +Common Shared As _Byte hover ' move by hovering +Common Shared As _Byte human, humanc ' 0 auto, 1 human vs computer, 2 humans +Common Shared As _Byte iflag ' invert board, autoflipping for 2 human players +Common Shared As _Byte ingetfile ' flag +Common Shared As _Byte ingetnames ' flag +Common Shared As _Byte inhelp ' showing help +Common Shared As _Byte inpause ' prevent reentry to SUB Pause +Common Shared As _Byte insettings ' prevent reentry to Setup +Common Shared As _Byte insetup ' flag +Common Shared As _Byte inshow ' sets or funny images +Common Shared As _Byte invert ' black player at bottom +Common Shared As _Byte ipfile ' needed for tf.bas (included) +Common Shared As _Byte lasth ' last human +Common Shared As _Byte lastc ' last color +Common Shared As _Byte lasthsav ' stack for above +Common Shared As _Byte lastcsav +Common Shared As _Byte lcb ' Liquor Control Board +Common Shared As _Byte legend ' flag for a-h at bottom, 1-8 on left +Common Shared As _Byte li ' length of INKEY$ +Common Shared As _Byte loadsetsinbackground +Common Shared As _Byte logging ' of game to disk +Common Shared As _Byte lostfocus ' user doing something else, add delays +Common Shared As _Byte lpoints ' last (previous) points +Common Shared As _Byte makenoise ' pressure waves in air +Common Shared As _Byte markers ' highlight last move +Common Shared As _Byte markerfc ' from column +Common Shared As _Byte markerfr ' from row +Common Shared As _Byte markertc ' to column +Common Shared As _Byte markertr ' to row +Common Shared As _Byte masterlevel ' usually 4 +Common Shared As _Byte masterm1 ' master minus one (plies) +Common Shared As _Byte match ' playing MiniMax +Common Shared mdelay!, tdelay! ' overheat fix +Common Shared midway ' x of middle of Style button +Common Shared mig ' moves in game (playback) +Common Shared As _Byte minactive ' MiniMax +Common Shared As _Byte mloop ' speed waiting for input (no performance effect) +Common Shared move ' counter +Common Shared mps ' moves per second +Common Shared mscreen, mscreenr ' main screen, rotated +Common Shared As _Byte names +Common Shared As Integer mx, my ' adjusted mouse position +Common Shared As Integer ux, uy ' actual mouse position +Common Shared As _Byte nbox ' clickable buttons on screen +Common Shared ndelay ' how many delays +Common Shared As _Byte newinfo ' flag +Common Shared As _Byte no_intro_music ' flag +Common Shared As _Byte noresign ' force continuation +Common Shared As _Byte nosend ' flag for match +Common Shared As _Byte descriptive ' 0 algebraic 1 descriptive +Common Shared As _Byte nvalid ' count of valid moves +Common Shared As _Byte onplayback ' viewing stored game +Common Shared As _Byte oply ' old ply +Common Shared As _Byte p ' piece, usually +Common Shared As _Byte pawndir ' W = 1, B = -1 +Common Shared As _Byte perpetual ' counter, game ends in draw at 3 +Common Shared As _Byte piece_style ' 0 funny,1 ugly,2 best,3 alternate,4 fancy +Common Shared As _Byte binvert ' 0screen, 1board (human vs human) +Common Shared As _Byte plasma_init ' flag +Common Shared As _Byte plasmaint ' plasma intensity +Common Shared As _Byte points ' ahead/behind +Common Shared As _Byte pregame ' flag +Common Shared As _Byte promoting ' waiting for user to select piece, ignore many keys +Common Shared As _Byte psize ' piece size +Common Shared ptaken, ptcc As Single, ptakent As Double +Common Shared As _Byte redoflag ' time machine +Common Shared As _Byte readonly ' after playback or setup +Common Shared As _Byte rickfile ' logging stuff for me +Common Shared As _Byte rflag ' in recursion, computer thinking +Common Shared As _Byte rotate ' 0none, 1 -90, 2 180, 3 90 +Common Shared rto ' return to origin +Common Shared As _Byte SaveWorB ' because I monkey with WorB +Common Shared As _Byte scheme ' 1-12 predefined color/set/clock +Common Shared As _Byte screensaver ' fully automatic +Common Shared As _Byte sfast ' save fast (playback/Enter10) +Common Shared sfx1, sfx2, sfy1 +Common Shared shia ' start history at +Common Shared As _Byte showright ' 0 history,1 small boards,3 thinkin +Common Shared As _Byte showthinkingf ' flag +Common Shared As _Byte showmousepos ' magnifying lens +Common Shared smoves0, smovest +Common Shared As _Byte smode, smode0 ' screen mode +Common Shared As _Byte sob ' scores on board +Common Shared As _Byte soundloaded ' flag +Common Shared As _Byte squaretrim ' four styles - off, single thick, two +Common Shared As _Byte smallclock ' elapsed time this move +Common Shared As _Byte takebackflag ' cheater! +'Common Shared tel! ' subroutine time tracker +Common Shared As _Byte testing ' flag +Common Shared top_mps ' moves per second +'Common Shared As _Byte ttflag ' time tracking +Common Shared As _Byte usd ' upsidedown +Common Shared As _Byte wasFEN ' FEN move +Common Shared As _Byte wasplayback +Common Shared As _Byte wasreadonly +Common Shared As _Byte WorB ' whose move it is, 0 black 1 white +Common Shared xmas, xmasc, xmast As _Float +Common Shared As _Byte xq, yq, hxq, hyq ' square size, half size +Common Shared xc, yc, xm, ym ' center, max +Common Shared tlx, trx, blx, brx, tly, try, bly, bry ' top left, bottom rught, etc + +Common Shared As _Byte bkc, bkr, wkc, wkr ' King locations +Common Shared As _Byte bpc, bpr, wpc, wpr ' pawn locations +Common Shared As _Byte hfc, hfr, htc, htr ' human from column/row, to column/row +Common Shared As _Byte lfc, lfr, ltc, ltr ' human from column/row, to column/row + +Common Shared FEN, FENcount, FENmax, FENpcount +Common Shared FEN$, FENm$, FENmess$, FENold$, FENreply$, FENreplyold$, FENpartial$ +Dim Shared FEN$(1000), FENreply$(1000), FENperp$(511) + +Common Shared boardwhite As _Unsigned Long ' white squares +Common Shared boardblack As _Unsigned Long ' black squares +Common Shared black As _Unsigned Long ' Johnny Cash +Common Shared blue As _Unsigned Long ' a Joni Mitchell album +Common Shared clockc As _Unsigned Long ' clock AND any non-board text/markers +Common Shared gray As _Unsigned Long ' Confederate soldiers +Common Shared green As _Unsigned Long ' Patty Gurdy song +Common Shared red As _Unsigned Long ' Communists! +Common Shared white As _Unsigned Long ' Vanna White +Common Shared yellow As _Unsigned Long ' coward +Common Shared zip As _Unsigned Long ' Saran Wrap +Common Shared menubg As _Unsigned Long ' dim background for main menu at bottom +Common Shared As _Unsigned Long c1, c2 ' general purpose colors + +Dim Shared tcount As _Unsigned _Integer64 ' total count moves computed +Dim Shared ocount As _Unsigned _Integer64 ' previous (old) count of above + +Common Shared castle$ ' status, 4 chars BQ BK WQ WK +Common Shared ConfigFile$ ' settings +Common Shared datapath$ ' .\chessdat\ +Common Shared debug$ ' crap I print at top left for debugging +Common Shared desc$ +Common Shared Enter$, Esc$ ' keyboard +Common Shared epsq$ ' target square for en passant +Common Shared gamepath$ ' .\chessdat\games +Common Shared logfile$, logfiled$ ' saved moves +Common Shared m$ ' algebraic move +Common Shared ComputerName$ ' hostname +Common Shared draw$ ' "draw" or half/half +Common Shared f$ ' filename, usually +Common Shared fd$ ' file date +Common Shared i$ ' INKEY$ +Common Shared istuff$ ' feeding mouse box contents to inkey SUB +Common Shared lct$ ' last centered text +Common Shared msg$ ' abort, usually +Common Shared NameEntered$ ' better be Chuck Norris +Common Shared pf$ ' playback file +Common Shared q$ ' quote, chr$(34) +Common Shared promote$ ' what a piece was promoted to +Common Shared s$ ' invisible space, chr$(255) +Common Shared TempMess$ ' messages to Shirley Temple + +Common Shared ClockTime As Double ' same as Miller Time +Common Shared cursoron As Double ' cursor turns off to help concentration +Common Shared drawblink As Double +Common Shared NoChangeUntil As Double +Common Shared start As Double +Common Shared waituntil As Double +Common Shared keypressedat As Double +Common Shared lastclick As Double +Common Shared mousemovedat As Double + +'Dim Shared ant(10) +'Dim Shared As _Byte active(200) ' SUB time tracking +Dim Shared alphal$(8) ' a b d e f g h +Dim Shared alphap$(8) ' for smallboards +'Dim Shared attackc(10) +Dim Shared As _Byte b(8, 8) ' main board +Dim Shared As _Byte b2(8, 8) ' board to display +'Dim Shared best(6) +Dim Shared bolt(1) +Dim Shared cc(1) As _Unsigned Long +Dim Shared As _Byte ca1(2, 5), ca2(2, 5) ' castling data +Dim Shared As _Byte CanMove(5) ' for endgame strategy +Dim Shared caption$(500) ' id funny pix +Dim Shared castle$(tbmax) ' takeback stack +Dim Shared cenbuff(22000) ' quick bottom of screen menu replot +Dim Shared ColorDesc$(32) +Dim Shared cp(32) As _Unsigned Long ' colors +Dim Shared As _Byte du(6, 7), dd(6, 7), dl(6, 7), dr(6, 7) ' piece up/down/left/right +Dim Shared etime(1, 1) As Double ' elapsed +Dim Shared myfont(32) ' not your font +Dim Shared FunnyPix$(500) ' unusual pieces +Dim Shared As _Byte ksv(8, 8) ' king square value (endgame, favor center for safety) +Dim Shared lmove(tbmax) As mtype ' log for takeback +Dim Shared mcount(8) As _Unsigned _Integer64 ' move counts +Dim Shared mfx1(99), mfx2(99), mfy1(99), mfy2(99), mft$(99) ' boundaries of clickable +Dim Shared move(8, 511) As mtype ' generated and scored +Dim Shared As _Byte Moves(8) ' by level +Dim Shared mlog$(511, 3) ' move: black alg, white alg, black desc, white desc +'Dim Shared name$(200) ' SUB timing tracking +'Dim Shared time_used(200) As Single ' SUB timing tracking +'Dim Shared mi(10) +Dim Shared As _Byte o(8, 8) ' original board +Dim Shared As _Byte onboard(14) ' we must count the coconuts +Dim Shared pcount(1, 6), points(1) ' what's left on the board, value totalled +Dim Shared As _Byte tb(8, 8, tbmax) ' takeback move stack +Dim Shared pix(10, 14) ' sets of pieces +Dim Shared pixh(10, 14) ' hardware version of pieces +Dim Shared As _Byte myr(32), myg(32), myb(32) ' rgb for each color, 63 max +Dim Shared piecef$(14) ' funny set filename +Dim Shared As _Byte piecefn(14) ' funny set number (x of y choices) +Dim Shared PlayerName$(3), pdate$ ' who's playing and when +'Dim Shared as _byte protc(10) +Dim Shared psa(10, 1) ' piece size adjustments +Dim Shared sfile(14), svol(14) As Single ' sound files and volume +Dim Shared As _Byte sloaded(10) ' set loaded flags +Dim Shared ssb(500) ' save small board +Dim Shared thinkv(500) As Integer ' optional show thinking +Dim Shared think$(500) ' optional show thinking +Dim Shared value(14) As Integer ' for capture + +Dim Shared As _Byte s1(8, 8), s2(8, 8), s3(8, 8), s4(8, 8), s5(8, 8), s6(8, 8), s7(8, 8), s8(8, 8) +Dim Shared m(10) As _MEM + +Dim mi ' move index +Dim As _Byte i, tc, tr, WorBs, isdraw, tpoints, wsb ' more main loop vars + +'activated for debugging +'Console +'_Console On + +InitSystem ' one time initializations + +' ------------------------------------------------------------------ THE BIG ENCHILADA (MAIN LOOP) ------------------------------------------------------- +begin: +WorBs = 0 +InitGame ' initializations for each game + +mainloop: +usd = -((human = 2) And (WorB = 0) And (binvert = 0)) ' upsidedown +If onplayback Then wasplayback = true +If msg$ = "Checkmate" Then + AddSymbol "+" + If onplayback Then + Erase etime + start = ExtendedTimer + End If + onplayback = false + GoTo popcornstand +End If +FENold$ = FEN$ +FENreplyold$ = FENreply$ +FENmake +If perpetual > 2 Then + msg$ = "Perpetual" + GoTo popcornstand +End If +SaveWorB = WorB ' white (1) or black (0) + +redo: +_MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' copy working b() to display board b2() +Reset_To_Zero ' does a level 0 & level 1 check +i = onplayback Xor 1 ' playback issues checks, stop repeating +Fking i ' find Kings (did you suspect otherwise?) +'TakeBest 0, 0 +If Len(FENmess$) Then TempMess$ = FENmess$: FENmess$ = "" +PlotScreen false +If onplayback Then Erase etime: start = ExtendedTimer +onplayback = false +isdraw = false +tpoints = points(0) + points(1) +If tpoints = 0 Then isdraw = true ' only Kings on board +If (points(1) < 4) And (points(0) < 4) And ((pcount(0, 6) + pcount(1, 6)) = 0) Then isdraw = true ' must be just a knight or bishop each +If drawcount > 49 Then isdraw = true +If isdraw Then msg$ = "Draw": GoTo popcornstand +i = incheck ' save for a few lines down +RemoveIllegal 0 ' there's a new Sheriff in town +BoardStats + +If Moves(0) = 0 Then ' no legal moves + If i Then ' incheck, saved from 2 lines up + msg$ = "Checkmate" + AddSymbol "+" ' throw another log on the fire + PlaySound won + Else + msg$ = "Stalemate" + AddSymbol "draw" + PlaySound stalemate + End If + GoTo popcornstand +End If + +ocount = 0 +oply = -1 +nosend = false +If cmode = 0 Then + start = ExtendedTimer + etime(1, WorB) = 0 +End If + +If (human And (humanc = WorB)) Or (human = 2) Then ' 2 is two humans + If human = 2 Then invert = (WorB = 0) + Do + If match = 3 Then + ToFrom 1, m$, match ' get move from Minimax + hfc = InStr(alphaz$, Left$(m$, 1)) ' from column + hfr = Val(Mid$(m$, 2, 1)) ' from row + htc = InStr(alphaz$, Mid$(m$, 3, 1)) ' to column + htr = Val(Mid$(m$, 4, 1)) ' to row + GoTo woof + Else + HumanMove + End If + If human = 0 Then GoTo redo ' pressed A for automatic (computer play) + If Len(msg$) Then GoTo popcornstand ' quit or resign + If onplayback Then GoTo mainloop + If redoflag Then redoflag = false: GoTo redo ' was in setup + If takebackflag Then + If dev = 0 Then PlaySound takeback ' so your mom knows you're cheating :) + GoTo takebackmove ' take back move (or tunnel boring machine) + End If + woof: + fc = hfc: fr = hfr: tc = htc: tr = htr + p = b(fc, fr) And 7 + If (p = King) And (fc = 5) And (tc = 7) Then fc = -fc ' kingside castle + If (p = King) And (fc = 5) And (tc = 3) Then fr = -fr ' queenside castle + For mi = 1 To Moves(0) ' check against legal list + If (fc = move(0, mi).fc) And (fr = move(0, mi).fr) And (tc = move(0, mi).tc) And (tr = move(0, mi).tr) Then Exit Do + Next mi + If makenoise Then PlaySound illegal + TempMess$ = "Not legal" + Loop + If (match > 0) And (fc > 0) And (fr > 0) Then PieceSlide fc, fr, tc, tr + markerfc = 0 ' markers + smoves0 = 0 +ElseIf (match = 1) Or (match = 2) Then + Do: _Limit mloop + ToFrom 1, m$, match ' get move from remote player + PlotScreen true + KeyScan + Loop Until Len(m$) + If InStr("en ng", m$) Then msg$ = "Resign": GoTo popcornstand ' end or new game + nosend = true + fc = InStr(alphaz$, Left$(m$, 1)) ' from column + fr = Val(Mid$(m$, 2, 1)) ' from row + tc = InStr(alphaz$, Mid$(m$, 3, 1)) ' to column + tr = Val(Mid$(m$, 4, 1)) ' to row +Else + If giveup > 0 Then + giveup = false + GoTo hack + End If + + FENcheck + If Len(FENm$) = 0 Then + wasFEN = false + Else + TempMess$ = "FEN move" + fc = InStr("abcdefgh", Mid$(FENm$, 1, 1)) + fr = Val(Mid$(FENm$, 2, 1)) + tc = InStr("abcdefgh", Mid$(FENm$, 3, 1)) + tr = Val(Mid$(FENm$, 4, 1)) + FENm$ = "" + GoTo gotmove + End If + + abort = false ' initialize, spacebar will set this true + rflag = true ' flag in recursion to stop displaying board + Center 0, "", true, false ' instructions at bottom + plasma_init = false + + 'TimeTrack "Recurse", 1 + 'For mi = 1 To Moves(0) + ' move(0, mi).mi = i + 'Next mi + wsb = dosmallboard + If cycle Then dosmallboard = true + ClockTime = ExtendedTimer + Recurse 1 + If cycle Then dosmallboard = wsb + 'TimeTrack "Recurse", 0 + + oply = -1 + smoves0 = Moves(0) + If abort Then + abort = false + msg$ = "" + WorB = SaveWorB + End If + TakeBest 0, true + + ShowTaken false ' do not display, tally up points + WorB = SaveWorB + + giveup = false + + If (points(WorB) = 0) And (move(0, 1).sc < 32) Then ' no captures + If onboard(Rook - (WorB = 0) * 8) Then giveup = 1 ' king vs king+rook + If points(WorB Xor 1) > 6 Then giveup = 2 ' king vs lots + End If + If move(0, 1).sc < -600 Then giveup = 3 ' mate next move + + 'If masterlevel = 4 Then + ' j = true + ' For i = 1 To smoves0 + ' If Right$(think$(i), 4) <> "777" Then j = false + ' Next i + ' If j Then giveup = 4 ' mate in two + 'End If + + If (giveup > 0) And (noresign = false) Then + If minactive Then ToFrom 0, "re", match ' signal Minimax new game + msg$ = Mid$("BlackWhite", WorB * 5 + 1, 5) + " resigns" + 'If rickfile Then msg$ = msg$ + Str$(giveup) + Str$(points(0)) + Str$(points(1)) + Str$(move(0, 1).sc) + rflag = 0 + PlotScreen true ' to show the "res" in history + PlaySound resign + newinfo = true + GoTo popcornstand + End If + + ' highly optional block, looks deeper for top 2 or 3 moves, very slow, activated with D + 'If (deep = 0) Or (Moves(0) < 2) Then GoTo not_today + 'z$ = ToAlg(0, 1) + 'Line (tlx, 2)-(trx, tly - 1), bg0, BF + 'sm = masterlevel + 'Moves(0) = deep + 1 ' re-evaluate 1 or 2 moves + 'masterlevel = 4 + deep ' 5 or 6 (if running default 4 plies) + 'Recurse 1 ' + 'TakeBest 0, true + 'masterlevel = sm + 'If dev And (z$ <> ToAlg(0, 1)) Then Sound 555, 1 + 'TempMess$ = z$ + " " + ToAlg(0, 1) + 'not_today: + + hack: + fc = move(0, 1).fc: fr = move(0, 1).fr: tc = move(0, 1).tc: tr = move(0, 1).tr + + PlaySound movedone + rflag = 0 ' recursion flag off + keypressedat = ExtendedTimer + mousemovedat = ExtendedTimer + newinfo = true + If sob Then HistoryX: ScoresOnBoard +End If + +gotmove: +shia = 0 +If Len(msg$) Then WorBs = WorB + 1: GoTo popcornstand +WorB = SaveWorB +If match Or Not ((human = 1) And (WorB = humanc)) Then MarkerSave fc, fr, tc, tr +MoveItReal fc, fr, tc, tr +m$ = alphal$(Abs(fc)) + CHRN$(Abs(fr)) + alphal$(Abs(tc)) + CHRN$(tr) +If fc < 0 Then m$ = "O-O" ' kingside castle +If fr < 0 Then m$ = "O-O-O" ' queenside castle +AddLog ' log, written on program exit +FENreply$ = m$ +WorB = SaveWorB Xor 1 ' toggle white/black +PlotScreen true +If perpetual > 2 Then msg$ = "Perpetual": GoTo popcornstand +If drawcount > 49 Then msg$ = "Draw": GoTo popcornstand + +If (match > 0) And (nosend = false) Then + m$ = alphal$(Abs(fc)) + CHRN$(Abs(fr)) + alphal$(Abs(tc)) + CHRN$(tr) + ToFrom 0, m$, match ' sending move + nosend = false +End If + +If move < 501 Then GoTo mainloop ' end of main loop +msg$ = "Over 500 moves..." + +popcornstand: ' end of a game +If rickfile Then Print #rickfile, "" ' mps.txt, long term averaging +If (msg$ = "Over 500 moves...") Or (msg$ = "Draw") Or (msg$ = "Perpetual") Then AddSymbol "draw" +If InStr(LCase$(msg$), "res") Then AddSymbol "res" +WriteLog false +PlotScreen true +Playagain ' white/black/humans/computer +abort = false ' flag reset +msg$ = "" ' nothing to see here people, move along + +If (human = 0) Or (i$ = "n") Then GoTo begin + +i = move - 1 - (move = 0) +If i$ = "b" Then GoTo takebackmove + +If WorBs Then ' must be r for resume + WorB = WorBs - 1: WorBs = 0 ' resume with same color + WorB = WorB Xor 1 +End If +GoTo redo + +takebackmove: +move = move + (InStr(mlog$(move, 1), "draw") > 0) +move = move - 1 +If move < 0 Then move = 0 +If WorB = 0 Then + mlog$(move, 0) = "" ' black alg + mlog$(move, 2) = "" ' black desc +End If +mlog$(move + 1, 1) = "" ' white alg +mlog$(move + 1, 0) = "" ' black alg +mlog$(move + 1, 3) = "" ' white desc +mlog$(move + 1, 2) = "" ' black desc + +TakeBackPop +takebackflag = false +_MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' copy working b() to display board b2() +PlotScreen false +SaveWorB = WorB ' white (1) or black (0) +oply = false +GoTo redo + +Sub AboveBoardInfo () + Static onscreen$, mtime As Double + Dim As _Byte i + Dim As Integer tx, ci, ai + + Buttons 0, 0 + + If barebones Or inhelp Then Exit Sub + 'TimeTrack "AboveBoard", 1 + + If Len(TempMess$) Then ' new message + onscreen$ = TempMess$ + TempMess$ = "" + mtime = ExtendedTimer + 3 + End If + + If Len(LTrim$(onscreen$)) = 0 Then + If loadsetsinbackground And (allsetsloaded = false) Then + If dev Then + For i = 0 To 9 ' show progress of loading sets + tx = xc + (i - 4.5) * 8 + If sloaded(i) Then c1 = _RGB32(0, 200, 0) Else c1 = _RGB32(200, 0, 0) + Circle (tx, 28), 2, c1 + Paint (tx, 28), c1, c1 + Next i + End If + + c1 = ExtendedTimer - keypressedat + c2 = ExtendedTimer - mousemovedat + If (keypressedat > 0) And (c1 > 2) And (c2 > 2) Then + allsetsloaded = true + For i = 0 To 9 + If sloaded(i) = false Then + allsetsloaded = false + LoadPieces (i) + keypressedat = ExtendedTimer + mousemovedat = ExtendedTimer + Exit For + End If + Next i + End If + End If + Else + _PutImage (tlx, 0)-(trx, try - 1), bgi, 0, (tlx, 0)-(trx, try - 1) + For tx = tlx To trx ' shaded background + ci = 170 - Abs((tlx + trx) \ 2 - tx) ' color intensity + If ci < 0 Then ci = 0 + ai = (ci + 80) \ 2 ' alpha intensity + If ai > 255 Then ai = 255 + Select Case bgc + Case 0: c1 = _RGBA(ci, 0, 0, ai) ' red + Case 1: c1 = _RGBA(0, ci, 0, ai) ' green + Case 2: c1 = _RGBA(0, 0, ci, ai) ' blue + Case 3: c1 = _RGBA(0, ci, ci, ai) ' cyan + Case 4: c1 = _RGBA(ci, ci, 0, ai) ' yellow + Case 5: c1 = _RGBA(ci, ci, ci, ai) ' white + End Select + Line (tx, 0)-(tx, try - 1), c1 + Next tx + + SetFont defaultfontsize + ShadowPrint xc - _PrintWidth(onscreen$) \ 2, 17, onscreen$, white + + If Left$(onscreen$, 9) = "Genevieve" Then ' Bujold, accent over last "e" + Line (xc - 50, 16)-Step(2, 1), black + Line (xc - 50, 15)-Step(2, 1), white + End If + End If + + If (mtime > 0) And (ExtendedTimer > mtime) Then ' time up, erase message + onscreen$ = "" + mtime = 0 + End If + + If (pregame = 0) And (ingetfile = 0) Then + ShowPoints ' ahead/behind, plus perpetual:draw + 'If Len(onscreen$) = 0 Then R_T_C ' ordinary clock + If piece_style > 0 Then DispStats ' don't want this data obscuring piece descriptions + End If + + 'TimeTrack "AboveBoard", 0 +End Sub + +Sub AddMove (level As _Byte, score, fc As _Byte, fr As _Byte, tc As _Byte, tr As _Byte) + mcount(level) = mcount(level) + 1 ' for fun, tracking moves evaluated per second + Moves(level) = Moves(level) + 1 ' count, baron, viceroy, pick one + move(level, Moves(level)).fc = fc ' from column + move(level, Moves(level)).fr = fr ' from row + move(level, Moves(level)).tc = tc ' to column + move(level, Moves(level)).tr = tr ' to row + 'move(level, Moves(level)).os = score ' original score + move(level, Moves(level)).sc = score ' hey man, can I score a lid? + 'move(level, Moves(level)).mi = mi(level) ' move index +End Sub + +Sub AddLog ' put another log on the fi-ire... + Dim tm$ + tm$ = m$ ' temporary copy to modify + + If Len(promote$) Then ' Q, usually + tm$ = tm$ + promote$ + desc$ = desc$ + "(" + promote$ + ")" + promote$ = "" ' discard after use + End If + + move = move + WorB ' increment on White + mlog$(move, WorB) = tm$ ' algebraic notation + mlog$(move, 2 + WorB) = desc$ ' descriptive notation + WriteLog false +End Sub + +Sub AddSymbol (sym$) ' play log + + If sym$ = "res" Then ' resign + If WorB Then ' white + move = move + 1 + (InStr(mlog$(move, 1), "res") > 0) + mlog$(move, 1) = "res" ' white alg + mlog$(move, 3) = "res" ' white desc + Else ' black + mlog$(move, 0) = "res" ' black alg + mlog$(move, 2) = "res" ' black desc + End If + ElseIf sym$ = "draw" Then ' draw + If WorB Then ' white + move = move + 1 + (InStr(mlog$(move, 1), draw$) > 0) + mlog$(move, 1) = draw$ ' white alg + mlog$(move, 3) = draw$ ' white desc + Else ' black + mlog$(move, 0) = draw$ ' black alg + mlog$(move, 2) = draw$ ' black desc + End If + Else ' check, checkmate, stalemate + If Len(LTrim$(mlog$(move, 1 - WorB))) > 0 Then + If Right$(mlog$(move, 1 - WorB), 1) <> sym$ Then mlog$(move, 1 - WorB) = mlog$(move, 1 - WorB) + sym$ + If Right$(mlog$(move, 3 - WorB), 1) <> sym$ Then mlog$(move, 3 - WorB) = mlog$(move, 3 - WorB) + sym$ + End If + If InStr(LCase$(msg$), "checkmate") And (Right$(mlog$(move, 1 - WorB), 2) <> "++") Then + mlog$(move, 1 - WorB) = mlog$(move, 1 - WorB) + "+" + mlog$(move, 3 - WorB) = mlog$(move, 3 - WorB) + "+" + End If + End If + oply = false + PlotScreen false + WriteLog false +End Sub + +Sub Alarms Static ' personal use sub, an alarm clock since I'm playing/testing so much + Dim As _Byte alarminit, i, d, m, dow, z1, z2, z3, weekend, alarmfor + Dim f, y + + If alarminit = false Then + Dim dow$(10), alarm$(10) + dow$(1) = "wd": alarm$(1) = "07:30" ' weekdays breakfast + dow$(2) = "we": alarm$(2) = "10:30" ' weekends brunch + dow$(3) = "wd": alarm$(3) = "11:45" ' weekdays lunch + dow$(4) = "all": alarm$(4) = "14:10" ' all days afternoon snack + dow$(5) = "all": alarm$(5) = "17:15" ' all days dinner + dow$(6) = "all": alarm$(6) = "20:10" ' all days late snack + + d = Val(Mid$(Date$, 4, 2)) ' month + m = Val(Mid$(Date$, 1, 2)) ' month + y = Val(Mid$(Date$, 7, 4)) ' year + f = y * 365 + 31 * (m - 1) + d + If m < 3 Then + f = f + (y - 1) \ 4 - (.75 * (y - 1) \ 100 + 1) + Else + f = f - Int(.4 * m + 2.3) + (y \ 4) - (.75 * (y - 1) \ 100 + 1) + End If + f = f - (y > 2000) + dow = f Mod 7 ' 0sat,1sun,2mon,3tue,4wed,5thu,6fri + If dow < 2 Then weekend = true + alarminit = true + + dow$(0) = "all" ' for testing + i = Val(Mid$(Time$, 4, 2)) + 1 + alarm$(0) = Left$(Time$, 3) + Right$("0" + LTrim$(Str$(i)), 2) + End If + + If (alarmfor = 0) And (Val(Mid$(Time$, 7, 2)) = 1) Then + For i = 1 To 6 ' make 0 to 6 for testing + z1 = (dow$(i) = "all") + z2 = (dow$(i) = "we") And (weekend = true) + z3 = (dow$(i) = "wd") And (weekend = false) + If (Left$(Time$, 5) = alarm$(i)) And (z1 Or z2 Or z3) Then alarmfor = 10 + Next i + End If + + If alarmfor Then + alarmfor = alarmfor - 1 + Sound 7777, 1 + End If +End Sub + +Sub AnyKey ' Yes Virginia, there is a Santa Claus + Dim x, tscreen, t$ + t$ = "Any key or mouse click to return to the game" + x = _Width \ 2 - _PrintWidth(t$) \ 2 + 8 + ShadowPrint x, _Height - 20, t$, white + DisplayMaster true + tscreen = _CopyImage(0) + nbox = 4 + Do: _Limit 10 + _PutImage , tscreen, 0 + t$ = InKey$ + MouseIn + Loop Until (Len(t$) > 0) Or b1 Or b2 + If dev And (t$ = "q") Then Quit + _FreeImage tscreen + ClearBuffers +End Sub + +Sub Background + Dim i, k, y, z + + If bgi < -1 Then + _PutImage , bgi, 0 + Else + Cls , black + If altbg < 4 Then + k = 177 + For i = 1 To _Height \ 2 + y = _Height - 1 - i * 2 + z = 200 - i + z = z * bri / 4 + Select Case bgc + Case Is = 0: c1 = _RGBA(z, 0, 0, k) ' red + Case Is = 1: c1 = _RGBA(0, z, 0, k) ' green + Case Is = 2: c1 = _RGBA(0, 0, z, k) ' blue + Case Is = 3: c1 = _RGBA(0, z, z, k) ' cyan + Case Is = 4: c1 = _RGBA(z, z, 0, k) ' yellow + Case Is = 5: c1 = _RGBA(z, z, z, k) ' white + End Select + Line (0, y)-(_Width - 1, y - 1), c1, BF + Next i + End If + Select Case altbg + Case 0: bg2 ' hexagons + Case 1: bg3 ' rotated squares + Case 2: Serp ' Sierpinski curve + ' 3 plain shaded + ' 4 none (black) + Case 5 ' Cheetos + c1 = _LoadImage(datapath$ + "bg_ch.jpg") + If c1 < -1 Then + _PutImage , c1, 0 + _FreeImage c1 + End If + Case 6 ' Fruit Loops + c1 = _LoadImage(datapath$ + "bg_fl.jpg") + If c1 < -1 Then + _PutImage , c1, 0 + _FreeImage c1 + End If + End Select + If bgi < -1 Then _FreeImage bgi + bgi = _CopyImage(0) + If ssb(1) < -1 Then _FreeImage ssb(1): ssb(1) = 0 + oply = -1 + lpoints = -1 + End If +End Sub + +Sub bg2 ' hexagon background + Dim xc, yc, xb, xo, z1, z2, a, x, y, i, s, tr, tg, tb + + c1 = Point(1, _Height - 40) + tr = _Red32(c1) + tg = _Green32(c1) + tb = _Blue32(c1) + For yc = 44 To 560 Step 9 + xb = xb Xor 1 + xo = xb * 16 ' offset + c1 = yc / 560 * 100 ' alpha + c2 = 100 - c1 ' a different alpha + For xc = 8 To 790 Step 32 + For z1 = -1 To 0 ' joggle x origin + For z2 = -1 To 0 ' joggle y origin + For s = 0 To 1 ' size (radius) + For i = 0 To 6 ' sides + a = (i + 3) * 60 ' angle + x = xc + (10 - s + z1) * Cos(_D2R(a)) + xo + y = yc + (10 - s + z2) * Sin(_D2R(a)) + If s = 0 Then ' draw all sides at this size + If i = 0 Then PSet (x + z1, y + z2), _RGBA(0, 0, 0, c2) + Line -(x + z1, y + z2), _RGBA(0, 0, 0, c2) + End If + If s = 1 And i < 3 Then ' two sides of inner hexagon + If i = 0 Then PSet (x + z1, y + z2), _RGBA(tr, tg, tb, c1) + Line -(x + z1, y + z2), _RGBA(tr, tg, tb, c1) + End If + Next i + Next s + Next z2 + Next z1 + Next xc + Next yc +End Sub + +Sub bg3 + Dim i, d, x, y, z, xc, yc, ang1, ang2, tr, tg, tb, x(100), y(100), rad! + Static rd + + rd = rd Xor 1 + c1 = Point(1, _Height - 40) + tr = _Red32(c1) + tg = _Green32(c1) + tb = _Blue32(c1) + + d = 28 + For ang1 = 0 To 100 Step 10 + d = d - 2 + For ang2 = 0 To 4 + rad! = _D2R(ang1 + ang2 * 90 - 45) + i = i + 1 + x(i) = d * Sin(rad!) + y(i) = d * Cos(rad!) + Next ang2 + Next ang1 + + For yc = 54 To 560 Step 38 + z = Sgn(((yc \ 38) Mod 2) - .5) + For xc = 19 To 780 Step 38 + i = 0 + For ang1 = 0 To 100 Step 10 + For ang2 = 0 To 4 + i = i + 1 + x = xc + x(i) * z + y = yc + y(i) + c2 = _RGB32(tr, tg, tb, yc \ 2.4) + If ang2 = 0 Then PSet (x, y), c2 Else Line -(x, y), c2 + Next ang2 + Next ang1 + If rd Then z = -z + Next xc + Next yc +End Sub + +Sub BoardStats ' sets canmove array, for strategy + Dim As _Byte i, k + Dim mi, seen$(32) + + For i = 0 To 1 ' 0 current player, 1 next move + CanMove(i) = 0 + If Moves(i) Then + For mi = 1 To Moves(i) + k = move(i, mi).fc + If (k > 0) And (move(i, mi).fr > 0) Then + m$ = alphal$(k) + CHRN$(move(i, mi).fr) + For k = 1 To CanMove(i) + If m$ = seen$(k) Then GoTo ni + Next k + CanMove(i) = CanMove(i) + 1 + seen$(CanMove(i)) = m$ + End If + ni: ' we are the knights who say ni + Next mi + End If + Next i +End Sub + +Sub BrightnessAdjust (set As _Byte, piece As _Byte) + Dim i, r, g, b, xs, ys, tx, ty, tscreen, itemp, tr, tg, tb, tbright As Single + + tscreen = _CopyImage(0) + Cls , zip + xs = xq - 1 + ys = yq - 1 + _PutImage (0, 0)-(xs, ys), pix(set, piece), 0 + + If (set = 7) And (piece = 2) Then ' fix black knight of set 8 + c1 = _RGB32(1, 1, 1) + Circle (26, 27), 5, c1 + Paint (26, 27), c1, c1 + Line (10, 26)-Step(12, 6), c1, BF + End If + + If (set = 0) And (InStr(f$, "bishop13") > 0) Then ' invert white bishop of set 0 + itemp = _NewImage(xq, yq, 32) + Screen itemp + _PutImage , pix(0, piece), 0 + _FreeImage pix(0, piece) + For ty = 0 To ys + For tx = 0 To xs + c1 = Point(tx, ty) + tr = 255 - _Red32(c1) + tg = 255 - _Green32(c1) + tb = 255 - _Blue32(c1) + PSet (tx, ty), _RGB32(tr, tg, tb) + Next tx + Next ty + pix(0, piece) = _CopyImage(0) + Screen mscreen + _PutImage (0, 0)-(xs, ys), pix(0, piece), 0 + _FreeImage itemp + End If + + tbright = bri * .25 + + For ty = 0 To ys + For tx = 0 To xs + c1 = Point(tx, ty) + If c1 <> zip Then + r = tbright * _Red32(c1) + g = tbright * _Green32(c1) + b = tbright * _Blue32(c1) + PSet (tx, ty), _RGBA(r, g, b, 255) + End If + Next tx + Next ty + + If set = 0 Then ' funny set, make borders + If piece < 7 Then c1 = black Else c1 = _RGBA(tbright * 255, tbright * 255, tbright * 255, 255) + For i = 0 To 5 + Line (i, i)-(xs - i, ys - i), c1, B + Next i + End If + _PutImage , 0, pix(set, piece), (0, 0)-(xs, ys) + If pixh(set, piece) < -1 Then _FreeImage pixh(set, piece) + pixh(set, piece) = _CopyImage(pix(set, piece), 33) + + _PutImage , tscreen, 0 + _FreeImage tscreen +End Sub + +Sub Buttons (ptc As _Unsigned Long, se As _Byte) + Dim As _Byte i, xi, xs + Dim x0, x1, x2, y1, tc As _Unsigned Long + + 'TimeTrack "Buttons", 1 + + If rotate And (inhelp = false) Then x0 = trx + 8 Else x0 = _Width + x0 = x0 - 86 + (inshow = 2) * 35 + tc = ptc + xs = 10 + xi = 20 + x1 = x0 + y1 = 21 + + If fullscreenflag Then + + If (tc = 0) Or inhelp Then tc = _RGB32(80, 80, 80) + + If inhelp Or insetup Then + If (ptc <> 0) And (se > 0) Then tc = white Else tc = gray + End If + + If (se = 0) Or (se = 1) Then ' help + Color tc, zip + SetFont 16 + If inhelp = false Then _PrintString (x1 + 1, y1 - 12), "?" + End If + + x1 = x1 + xi: x2 = x1 + xs + If (se = 0) Or (se = 2) Then + Line (x1, 20)-(x2, 20), tc ' minimize + End If + + x1 = x1 + xi: x2 = x1 + xs + If (se = 0) Or (se = 3) Then + Line (x1, y1)-(x2, y1 - 10), tc, B ' fullscreen + Line (x1 + 2, y1 - 2)-(x2 + 2, y1 - 12), tc, B + End If + + x1 = x1 + xi: x2 = x1 + xs + If (se = 0) Or (se = 4) Then + Line (x1, y1)-(x2, y1 - 10), tc ' exit + Line (x2, y1)-(x1, y1 - 10), tc + End If + + For i = 1 To 4 ' store locations for mouse clicking + mfx1(i) = x0 + (i - 1) * xi - 2 + mfy1(i) = 8 + mfx2(i) = mfx1(i) + xs + 5 + mfy2(i) = mfy1(i) + 17 + Next i + End If + + If (promoting + inhelp + pregame + insettings + insetup + ingetfile + inshow - (se > 0)) Then GoTo flopdoodle + + nbox = 5 + mft$(5) = "k" ' bare bones toggle + mfx1(5) = boltx1 + mfy1(5) = bolty1 + mfx2(5) = boltx2 + mfy2(5) = bolty2 + If barebones Then chimp = 5: GoTo flopdoodle + ' --------------------------------------------------------------------------------------------------------- + tc = _SHL(bri, 4) + tc = _RGB32(tc, tc, tc) + SetFont defaultfontsize + + If (move > 0) And (dosmallboard = 0) And (showthinkingf = 0) Then + nbox = nbox + 1 + mft$(nbox) = "Alg" ' algebraic + mfx1(nbox) = trx + 10 + mfx2(nbox) = mfx1(nbox) + 15 + mfy1(nbox) = try + 2 + mfy2(nbox) = mfy1(nbox) + 16 + Line (mfx1(nbox), mfy1(nbox))-(mfx2(nbox), mfy2(nbox)), tc, BF + ShadowBox mfx1(nbox), mfy1(nbox), mfx2(nbox), mfy2(nbox) + ShadowPrint mfx1(nbox) + 4, mfy1(nbox) + 4, "A", gray + + nbox = nbox + 1 + mft$(nbox) = "Des" ' descriptive + mfx1(nbox) = trx + 10 + mfx2(nbox) = mfx1(nbox) + 15 + mfy1(nbox) = mfy2(nbox - 1) + 4 + mfy2(nbox) = mfy1(nbox) + 16 + Line (mfx1(nbox), mfy1(nbox))-(mfx2(nbox), mfy2(nbox)), tc, BF + ShadowBox mfx1(nbox), mfy1(nbox), mfx2(nbox), mfy2(nbox) + ShadowPrint mfx1(nbox) + 4, mfy1(nbox) + 4, "D", gray + ' ------------------------------------------------------------------------------------------------------ + If move > 49 Then ' up/down buttons only appear when needed + + nbox = nbox + 1 + mft$(nbox) = "hup" ' history up + mfx1(nbox) = trx + 10 + mfx2(nbox) = mfx1(nbox) + 15 + mfy1(nbox) = try + 58 + mfy2(nbox) = mfy1(nbox) + 16 + + nbox = nbox + 1 + mft$(nbox) = "hup" ' history up + mfx1(nbox) = trx + 10 + mfx2(nbox) = mfx1(nbox) + 15 + mfy1(nbox) = _Height - 64 + mfy2(nbox) = mfy1(nbox) + 16 + + nbox = nbox + 1 + mft$(nbox) = "hdo" ' history down + mfx1(nbox) = trx + 10 + mfx2(nbox) = mfx1(nbox) + 15 + mfy1(nbox) = mfy2(nbox - 2) + 4 + mfy2(nbox) = mfy1(nbox) + 16 + + nbox = nbox + 1 + mft$(nbox) = "hdo" ' history down + mfx1(nbox) = trx + 10 + mfx2(nbox) = mfx1(nbox) + 15 + mfy1(nbox) = mfy2(nbox - 2) + 4 + mfy2(nbox) = mfy1(nbox) + 16 + + For i = nbox - 3 To nbox + Line (mfx1(i), mfy1(i))-(mfx2(i), mfy2(i)), tc, BF + ShadowBox mfx1(i), mfy1(i), mfx2(i), mfy2(i) + ShadowPrint mfx1(i) + 2, mfy1(i) + 3, Chr$(31 + (i < (nbox - 1))), gray + Next i + End If + End If + + nbox = nbox + 1 + mft$(nbox) = "l" + mfx1(nbox) = tlx - 12 ' legend on left + mfx2(nbox) = tlx - 1 + mfy1(nbox) = tly + mfy2(nbox) = bly + + nbox = nbox + 1 + mft$(nbox) = "l" + mfx1(nbox) = blx ' legend at bottom + mfx2(nbox) = brx + mfy1(nbox) = bly + 1 + mfy2(nbox) = bly + 16 + + If (pregame = false) And (onplayback = false) Then + nbox = nbox + 1 + mft$(nbox) = "t" ' clock type toggle by clicking on clock area + mfx1(nbox) = blx + mfx2(nbox) = brx + mfy1(nbox) = bly + 37 + mfy2(nbox) = _Height - 21 + + nbox = nbox + 1 + mft$(nbox) = "I" ' identify (player names) + mfx1(nbox) = blx + mfx2(nbox) = brx + mfy1(nbox) = bly + 17 + mfy2(nbox) = bly + 36 + End If + + 'If rickfile And dev Then ' SUB timings + ' nbox = nbox + 1 + ' mft$(nbox) = "T" ' T is for turtle + ' mfx1(nbox) = 0 + ' mfx2(nbox) = tlx - 22 + ' mfy1(nbox) = 0 + ' mfy2(nbox) = _Height - 20 + 'End If + + If rickfile And dev Then ' graph scaling + nbox = nbox + 1 + mft$(nbox) = "Graph" + mfx1(nbox) = 24 + mfx2(nbox) = tlx - 20 + mfy1(nbox) = bly + mfy2(nbox) = _Height - 21 + End If + + flopdoodle: + If nbox > chimp Then chimp = nbox + 'TimeTrack "Buttons", 0 +End Sub + +Sub Center (tr As _Byte, t$, highlight As _Byte, tflag As _Byte) ' instructions for various modes, and creates mouse clickable boxes + Dim As _Byte i, j, tok + Dim x, y, c$, e$, z$ + + If chimp > 0 Then nbox = chimp Else nbox = 5 + If insetup Then nbox = 4 + If barebones Or insettings Or inhelp Then Exit Sub + + If (t$ = "") And ((pregame + inhelp + endgame) = 0) Then + If match Then + t$ = " Noise Invert Pause " + ElseIf getwbflag Then + t$ = " you are White or Black? " + ElseIf onplayback Then + t$ = " Enter:move Stop Non-stop Loop " + ElseIf human Then + t$ = " Auto Back Noise Pause Resign Invert Setup " + If fullscreenflag = 0 Then t$ = t$ + " F1" + s$ + "info " + Else + t$ = " White Black Noise Pause Invert Setup " + If fullscreenflag = 0 Then t$ = t$ + " F1" + s$ + "info " + End If + highlight = true + End If + + If (tr = 0) And (rflag = 0) And (t$ = lct$) And (pregame = 0) And (onplayback = 0) Then ' bottom instructions + Put (0, _Height - 20), cenbuff(), PSet + nbox = lcb + RainbowButton + Exit Sub + End If + + If pregame And (t$ <> " @ Enter ") Then x = 14 Else x = 12 ' bigger font for startup Wh Bl Hu Co menu + SetFont x + x = xc - _PrintWidth(t$) \ 2 + + If tr = 0 Then ' bottom + If pregame = 0 Then Line (0, _Height - 19)-(_Width - 1, _Height - 1), menubg, BF + y = _Height - 13 + Else ' probably screen center + y = tr / (_Height / 16) * _Height - 6 * tflag + 4 + End If + + e$ = "@?/*: -" + s$ ' exempt from highlighting + + For i = 1 To Len(t$) + c1 = gray + c$ = Mid$(t$, i, 1) + If (insetup = false) And (c$ = "B") And (backok = 0) And (InStr(t$, "Back") > 0) Then tok = 0 Else tok = 1 + If tok And highlight And (c$ = UCase$(c$)) And (InStr(e$, c$) = 0) Then + If clockc = black Then c1 = white Else c1 = clockc + nbox = nbox + 1 ' make item available to mouse + If nbox > 99 Then QuitWithError "nbox", Str$(nbox) ' this should not happen! + mft$(nbox) = LCase$(c$) ' character when box is clicked on + If InStr(t$, "Rename") Then mft$(nbox) = mft$(nbox) + Mid$(t$, i + 1, 1) ' make "re" because "r" is resign + If (c$ = "F") And (Mid$(t$, i + 1, 1) = "1") And (onplayback = false) And (insetup = false) Then mft$(nbox) = "help" ' F1 + z$ = Mid$(t$, i, InStr(i + 1, t$, " ") - i) ' find where to end box + mfx1(nbox) = x - 2 + mfy1(nbox) = y - 6 + (tr = 16) + mfx2(nbox) = x + _PrintWidth(z$) + 2 + mfy2(nbox) = y + _FontHeight - 1 + If mfy2(nbox) >= _Height Then mfy2(nbox) = _Height - 1 + End If + If t$ = "Deleting..." Then c1 = white + ShadowPrint x, y - 2, c$, c1 + x = x + _PrintWidth(c$) + Next i + + If (barebones + pregame + ingetfile + insetup + ingetnames) = 0 Then + + SetFont 10 + ShadowPrint 24, _Height - 14, "Slide:", white + + RoundButtonInfo: + Data 64,OFF,sp0 + Data 102,Slow,sp1 + Data 144,Fast,sp2 + Data 591,Log,sr0 + Data 629,Boards,sr1 + Data 683,Thinking,sr2 + Data 748,Style,` + + Restore RoundButtonInfo + For i = 0 To 6 + Read x, e$, c$ + j = ((i < 3) And (i = fast)) Or ((Left$(c$, 2) = "sr") And ((i - 3) = showright)) + Round_Button x, _Height - 14, e$, c$, j, true + Next i + End If + + If tr = 0 Then + lcb = nbox + lct$ = t$ + Get (0, _Height - 20)-(_Width - 1, _Height - 1), cenbuff() + End If +End Sub + +Sub RainbowButton + Round_Button 748, _Height - 14, "Style", "'", false, false +End Sub + +Sub Round_Button (x, y, wut$, whenmousemashed$, highlight As _Byte, addbutton As _Byte) + Static rainbowindex, rainbowtime As Double + Dim As _Byte i, j, lw, pw, rainbowflag + Dim z + + If barebones Or pregame Or inhelp Or insettings Or insetup Or ingetfile Then Exit Sub + + rainbowflag = (wut$ = "Style") ' make this word stand out + + SetFont 11 + lw = Len(wut$) + pw = _PrintWidth(wut$) + z = x + pw + (lw > 3) * 2 + (lw > 4) * 2 + (wut$ = "Slow") * 2 + (wut$ = "Log") - (wut$ = "Style") + If rainbowflag Then c1 = black Else c1 = gray ' special background for Style + For c2 = x To z + Circle (c2, y + 4), 7, c1 + Next c2 + + If rainbowflag Then ' multi-color for Style + j = 0 + If ExtendedTimer > rainbowtime Then + rainbowindex = rainbowindex + 1 + rainbowtime = ExtendedTimer + .1 + End If + For i = 1 To 5 + rainbowindex = (rainbowindex + 1) Mod 5 + If rainbowindex = 0 Then c1 = red + If rainbowindex = 1 Then c1 = green + If rainbowindex = 2 Then c1 = blue + If rainbowindex = 3 Then c1 = yellow + If rainbowindex = 4 Then c1 = _RGB32(120, 0, 160) ' purple + Color c1, zip + _PrintString (x + j, y), Mid$(wut$, i, 1) + j = j + _PrintWidth(Mid$(wut$, i, 1)) + Next i + ElseIf highlight Then + ShadowPrint x, y, wut$, white + Else + Color black, zip + _PrintString (x, y), wut$ + End If + + If addbutton Then + nbox = nbox + 1 + mft$(nbox) = whenmousemashed$ + mfx1(nbox) = x - 8 + mfy1(nbox) = y - 4 + mfx2(nbox) = x + _PrintWidth(wut$) + 7 + mfy2(nbox) = _Height - 1 + If mft$(nbox) = "`" Then midway = (mfx1(nbox) + mfx2(nbox)) \ 2 + End If +End Sub + +Sub CheckBoard (level As _Byte) + Dim mi ' move index + Dim As _Byte mp, cq, ck, cz, lm, rn, rn2, tp, castle, nr, pr, ne, co, cn, cs, p, op + + points = points(0) - points(1) ' ahead/behind in points + points = points - WorB * points * 2 ' branchless version of IF WorB THEN ab = -ab + + Moves(level) = 0 ' moves this level + pawndir = WorB + (WorB = 0) ' direction pawn moves, 1W, -1B + rto = (move < 16) * 200 ' -200 for early return to origin + + fr = 0 ' from row + Do + fr = fr + 1 ' from row + fc = 0 ' from column + Do ' scooby-doobie-doo + fc = fc + 1 + mp = b(fc, fr) ' move piece + If WorB = Sgn(mp And 8) Then + Select Case mp And 7 + Case Is = Pawn: MovePawn level + Case Is = Rook: MoveRook level + Case Is = Knight: MoveKnight level + Case Is = Bishop: MoveBishop level + Case Is = Queen: MoveQueen level + Case Is = King: MoveKing level + End Select + End If + Loop Until fc = 8 + Loop Until fr = 8 + + If level > 1 Then Exit Sub ' only check for castling first 2 plys, for speed + + cq = true: ck = true ' castling + rn = WorB - (WorB = 0) * 8 ' faster + rn2 = WorB * 2 - (WorB = 0) * 7 + + tp = b(5, rn) And 7 + If tp <> King Then cq = false: ck = false: Exit Sub ' no King here + incheck = false + If level = 0 Then lm = 1 Else lm = level - 1 + For mi = 1 To Moves(lm) ' can any opponent piece move there? + If (move(lm, mi).tc = 5) And (rn = move(lm, mi).tr) Then + cq = false ' castle queenside + ck = false ' castle kingside + incheck = true + Exit Sub + End If + Next mi + + ' WHITE BLACK + ' 8 R N B Q K B N R 1 R N B K Q B N R + ' 7 P P P P P P P P 2 P P P P P P P P + ' 6 3 + ' 5 4 + ' 4 5 + ' 3 6 + ' 2 P P P P P P P P 7 P P P P P P P P + ' 1 R N B Q K B N R 8 R N B K Q B N R + ' a b c d e f g h h g f e d c b a + + For castle = 1 To 2 ' queenside, then kingside + nr = false ' no rook + pr = false ' prior condition + ne = false ' not empty + co = false ' controlled space + c2 = false ' controlled space by PAWN (I'm not so sure about this, despite what Stockfish says) + + ' bbww + ' castle$ format "qkQK" * if ok, X if nulled by King or Rook move + If Mid$(castle$, WorB * 2 + castle, 1) <> "*" Then pr = true: GoTo nocando ' prior condition (moved King or rook) + + If castle = 1 Then cn = 1 Else cn = 8 ' column number + p = b(cn, rn) And 7 + If p <> Rook Then nr = true: GoTo nocando ' no rook + + If castle = 1 Then cz = 4 Else cz = 5 + op = 14 - WorB * 8 + For cs = 1 To cz + cn = ca1(castle, cs) + If b(cn, rn2) = op Then c2 = true: GoTo nocando ' control by pawn + Next cs + + If castle = 1 Then cz = 3 Else cz = 2 + For cs = 1 To cz ' look at spaces between king and rook + cn = ca2(castle, cs) + If b(cn, rn) > 0 Then ne = true: GoTo nocando ' not empty + + If Not ((cs = 1) And (castle = 1)) Then ' queenside knight + If level Then lm = 0 Else lm = 1 + For mi = 1 To Moves(lm) ' see what can move here + If (cn = move(lm, mi).tc) And (rn = move(lm, mi).tr) Then + co = true ' yes, something can + GoTo nocando + End If + Next mi + End If + Next cs + + nocando: + If (nr + pr + ne + co + c2) > 0 Then ' some test failed + If castle = 1 Then cq = false Else ck = false + End If + Next castle + + ' note that kingside has negative from column, queenside negative from row + If WorB Then + If ck Then AddMove level, 15, -5, 1, 7, 1 ' what's it worth? keep adjusting! + If cq Then AddMove level, 16, 5, -1, 3, 1 + Else + If ck Then AddMove level, 15, -5, 8, 7, 8 ' what's it worth? keep adjusting! + If cq Then AddMove level, 16, 5, -8, 3, 8 + End If +End Sub + +Function CHRN$ (n) + CHRN$ = Chr$(48 + n) +End Function + +Sub ClearBuffers + While _Resize + _Delay .1 + Wend + 'While Len(InKey$): Wend + i$ = "" ' inkey variable + istuff$ = "" ' mouse generated inkey override + While _MouseInput: Wend + b1 = false ' mouse button left + b2 = false ' mouse button right +End Sub + +Sub ClearTemp ' invalidate saved screens + Dim i + For i = 0 To 500 ' small board images + If ssb(i) < -1 Then _FreeImage ssb(i): ssb(i) = 0 + Next i + lpoints = -1 + oply = -1 ' force replot of captured pieces +End Sub + +Sub Clocks ' total used per player, this move + Static clockinit, segment(7, 4) As _Byte, segleg$(9) + Dim As _Byte i, j, k, who, s, m, n, z, zz, az, p1, qq, sn, sxq, syq + Dim As _Unsigned _Byte ra, ga, ba + Dim h, x0, x1, x2, x3, y0, y1, y2, tx + Dim te As Double, t As Double, z!, s$, m$, h$, t$, z$ + + cdata: + Data a,0,-2,1,-2,b,1,-2,1,-1,c,1,-1,1,0,d,0,0,1,0,e,0,-1,0,0,f,0,-2,0,-1,g,0,-1,1,-1 + Data 0,abcdef,1,bc,2,abedg,3,abcdg,4,fbcg,5,acdfg,6,acdefg,7,abc,8,abcdefg,9,abcdfg + + If barebones Then Exit Sub + + 'TimeTrack "Clocks", 1 + + If pregame Then + etime(0, 0) = 12 * 3600 + 34 * 60 + 56 ' show time of 12:34:56 on big clocks + etime(0, 1) = etime(0, 0) + etime(1, 0) = 0 ' time this move (tiny clocks) + etime(1, 1) = 0 + start = ExtendedTimer + End If + + If clockinit = false Then + Restore cdata ' where to plot segments of 7 digit display + For i = 1 To 7 + Read t$ ' garbage + For j = 1 To 4 + Read segment(i, j) + Next j + Next i + For i = 0 To 9 + Read t$, segleg$(i) + Next i + clockinit = true + End If + + who = SaveWorB + te = ExtendedTimer - start + If inpause Or onplayback Or getwbflag Then te = 0 + If endgame And (cmode = 0) Then te = 0 + start = ExtendedTimer + If cmode = 0 Then ' normal user mode + etime(0, who) = etime(0, who) + te ' total elapsed + etime(1, who) = etime(1, who) + te ' elapsed this move + + Else ' 30/60m countdown timer for author + etime(0, 1) = etime(0, 1) + te ' white timer shows current time + etime(0, 0) = etime(0, 0) - te ' black timer shows countdown timer + If Int(etime(0, 0)) <= 0 Then ' time up! + etime(0, 0) = 0 ' in case it was negative + Sound 7777, 1 ' audible alarm + cmode = 0 ' special clock mode off + End If + End If + + z = pregame * -20 ' pregame offset, to fit music credits + y0 = 566 + z + + For i = 0 To 1 + t = etime(0, i) + s = t Mod 60 ' seconds + m = (t \ 60) Mod 60 ' minutes + h = t \ 3600 ' hours + If h > 99 Then h = 0: m = 0: s = 0 + h$ = Right$("0" + LTrim$(Str$(h)), 2) + m$ = Right$("0" + LTrim$(Str$(m)), 2) + s$ = Right$("0" + LTrim$(Str$(s)), 2) + + If clocktype = 0 Then ' big font clock + SetFont 32 + t$ = h$ + ":" + m$ + ":" + s$ + x1 = blx - (i = 0) * xq * 4 + 28 + y1 = 532 + z + For j = 1 To 8 ' print one character at a time to move the colon up + x2 = x1 + _PrintWidth(Left$(t$, j - 1)) + z$ = Mid$(t$, j, 1) + ShadowPrint x2, y1 + (z$ = ":") * 2, z$, clockc + Next j + x2 = x1 + 130 + y2 = y1 + 26 + _PutImage (x1 - 12, y1 - 12)-(x2 + 12, y2 + 12), 0, 0, (x1, y1)-(x2, y2) + Else + t$ = h$ + m$ + s$ ' time used this side + For j = 1 To 6 ' hh mm ss + n = Val(Mid$(t$, j, 1)) + If clocktype = 2 Then + NixieTubeClock i, j, n + _Continue + End If + sxq = 14: syq = 20: qq = 3 ' big digits + If j > 4 Then sxq = 7: syq = 10: qq = 1 ' small digits for seconds + For k = 1 To 8 + p1 = InStr(segleg$(n), Mid$("abcdefg", k, 1)) + If p1 Then + z$ = Mid$(segleg$(n), p1, 1) + sn = Asc(z$) - 96 + + x0 = blx - (i = 0) * xq * 4 + j * 26 + 6 + x0 = x0 + (j = 6) * 10 ' seconds + x0 = x0 + (j < 3) * 10 ' hour + x0 = x0 - (j > 4) * 4 ' seconds + + x1 = x0 + segment(sn, 1) * sxq + x2 = x0 + segment(sn, 3) * sxq + y1 = y0 + segment(sn, 2) * syq + y2 = y0 + segment(sn, 4) * syq + If InStr("agd", z$) Then ' horizontal + x1 = x1 + 1: x2 = x2 - 1 + For zz = -qq To qq + GoSub mcolor + Line (x1 + az, y1 + zz)-(x2 - az, y2 + zz), c1 + Next zz + Else ' vertical + y1 = y1 + 1: y2 = y2 - 1 + For zz = -qq To qq + GoSub mcolor + Line (x1 + zz, y1 + az)-(x2 + zz, y2 - az), c1 + Next zz + End If + End If + Next k + Next j + + If clocktype = 2 Then _Continue ' Nixie + + x0 = blx + xq * 1.5 - (i = 0) * xq * 4 + 3 ' must be clocktype 1 (7 segments) + Line (x0, 539 + z)-Step(2, 2), clockc, BF ' colons + Line (x0, 549 + z)-Step(2, 2), clockc, BF + End If + x1 = blx + i * xq * 4 + 4 + If cmode = 0 Then ' cmode > 0 means countdown timer + SetFont 8 + i * 3 + x2 = x1 + i * 2 + ShadowPrint x2, 538 + z, Mid$("WB", i + 1, 1), clockc ' identify clocks (W & B) + End If + Next i + + If smallclock And (clocktype <> 2) And (cmode = 0) Then ' elapsed time per move + If colori3 = 3 Then c1 = black Else c1 = clockc + For i = 0 To 1 + t = etime(1, i) + s = t Mod 60 ' seconds + m = (t \ 60) Mod 60 ' minutes + h = t \ 3600 ' hours + If h > 99 Then h = 0: m = 0: s = 0 + s$ = Right$("0" + LTrim$(Str$(s)), 2) + m$ = Right$("0" + LTrim$(Str$(m)), 2) + h$ = Right$("0" + LTrim$(Str$(h)), 2) + t$ = h$ + ":" + m$ + ":" + s$ + tx = blx - (i = 0) * xq * 4 + 132 + j = -(clocktype = 0) + TinyFont t$, tx - j * 2, 526 - j * 10 + z, c1 + Next i + End If + + SetFont 10 ' player names + For i = 0 To 1 + If i Then x3 = xc - 2 * xq Else x3 = xc + 2 * xq + t$ = LTrim$(RTrim$(PlayerName$(i))) + tx = x3 - _PrintWidth(t$) \ 2 + If (colori3 = 5) Or (colori3 = 3) Then c1 = white Else c1 = clockc 'black or blue to white + If pregame = 0 Then ShadowPrint tx, y0 - 60, t$, c1 + Next i + + 'TimeTrack "Clocks", 0 + Exit Sub + + mcolor: + az = Abs(zz) + z! = 255 - az * 60 + z! = z! * (bri + 1 + (bri = 4)) * .25 + ra = z! * Sgn(_Red32(clockc)) + ga = z! * Sgn(_Green32(clockc)) + ba = z! * Sgn(_Blue32(clockc)) + c1 = _RGB32(ra, ga, ba) + If clockc = black Then c1 = black + Return +End Sub + +Sub ColorSet + Dim i, tr, tg, tb + + lpoints = -1 ' force replot of pieces taken + oply = -1 + If bgi < -1 Then _FreeImage bgi: bgi = 0 + + For i = 0 To 31 + cp(i) = _RGB32(myr(i) * bri, myg(i) * bri, myb(i) * bri) + Next i + + black = _RGB32(2, 2, 2) + blue = cp(12) + gray = cp(8) + green = cp(23) + red = cp(30) + white = cp(7) + yellow = cp(18) + zip = _RGBA(1, 1, 1, 0) + + tr = myr(colori1 + 10) + tg = myg(colori1 + 10) + tb = myb(colori1 + 10) + boardwhite = _RGB32(tr * bri, tg * bri, tb * bri) + + tr = myr(colori2 + 10) + tg = myg(colori2 + 10) + tb = myb(colori2 + 10) + boardblack = _RGB32(tr * bri, tg * bri, tb * bri) + + If colori3 = 0 Then clockc = red + If colori3 = 1 Then clockc = green + If colori3 = 2 Then clockc = yellow + If colori3 = 3 Then clockc = blue + If colori3 = 4 Then clockc = white + If colori3 = 5 Then clockc = black + + If colori3 = 5 Or colori3 = 3 Then ' override if black or blue (too dim) + menubg = _RGB32(50) + Else + tr = _Red(clockc) \ 4 + tg = _Green(clockc) \ 4 + tb = _Blue(clockc) \ 4 + menubg = _RGB32(tr, tg, tb) + End If + +End Sub + +Sub ConfigRead + Dim i, j, k, tf, g, g$ + + f$ = ConfigFile$ + If (InStr(Command$, "init") > 0) Or (_FileExists(f$) = 0) Then f$ = datapath$ + "chessb.dat" + FileCheck + tf = FreeFile + Open f$ For Input As #tf + Input #tf, g$, bgc ' 1 + Input #tf, g$, bri ' 2 + Input #tf, g$, click ' 3 + Input #tf, g$, colori1 ' 4 + Input #tf, g$, colori2 ' 5 + Input #tf, g$, colori3 ' 6 + Input #tf, g$, clocktype ' 7 + Input #tf, g$, cursortype ' 8 + Input #tf, g$, fast ' 9 + Input #tf, g$, fullscreenflag ' 10 + Input #tf, g$, graphics ' 11 + Input #tf, g$, altbg ' 12 + Input #tf, g$, binvert ' 13 + Input #tf, g$, legend ' 14 + Input #tf, g$, logging ' 15 + Input #tf, g$, descriptive ' 16 + Input #tf, g$, makenoise ' 17 + Input #tf, g$, piece_style ' 18 + Input #tf, g$, smallclock ' 19 + Input #tf, g$, smode0 ' 20 + Input #tf, g$, squaretrim ' 21 + Input #tf, g$, hover ' 22 + Input #tf, g$, markers ' 23 + + If (piece_style < 0) Or (piece_style > 9) Then piece_style = 9 + For i = 0 To 1 ' black then white + For j = 1 To 6 ' piece + k = i * 8 + j ' 1 2 3 4 5 6 9 10 11 12 13 14 + piecef$(k) = RTrim$(Mid$("rook knightbishopqueen king pawn ", (j - 1) * 6 + 1, 6)) + Input #tf, g$, piecefn(k) + If piecefn(k) < 1 Then piecefn(k) = 1 + f$ = datapath$ + "sfunny" + slash + piecef$(k) + LTrim$(Str$(piecefn(k))) + ".jpg" + FileCheck + Next j + Next i + + Input #tf, g$, PlayerName$(1) + Input #tf, g$, PlayerName$(0) + Input #tf, g$, lasth + Input #tf, g$, lastc + Close #tf + + Restore rgb + For i = 0 To 31 + Read g, myr(i), myg(i), myb(i), ColorDesc$(i) + Next i + + rgb: + Data 0,1,1,1,Black + Data 1,50,50,50,Board white + Data 2,30,30,30,Board black + Data 3,60,60,60,White piece + Data 4,12,12,30,White highlight + Data 5,0,0,0,Black piece + Data 6,50,12,12,Black highlight + Data 7,63,63,63,Bright white + Data 8,30,30,30,Gray + Data 9,0,0,0,Black + Data 10,43,43,63,Gunmetal + Data 11,11,29,52,Sky Blue + Data 12,0,0,50,Blue + Data 13,30,19,40,Lt Purple + Data 14,25,13,26,Dk Purple + Data 15,35,5,35,Purple + Data 16,60,50,4,Gold + Data 17,63,30,0,Flame + Data 18,60,60,0,Yellow + Data 19,63,55,30,Lt Brown + Data 20,40,20,0,Brown + Data 21,0,63,22,Mint + Data 22,20,55,10,Lt Green + Data 23,0,40,0,Green + Data 24,38,38,38,Gray + Data 25,18,18,18,Dk Gray + Data 26,63,63,63,White + Data 27,63,35,35,Pink + Data 28,61,23,24,Flesh + Data 29,55,13,25,Cherry + Data 30,50,0,0,Red + Data 31,41,37,18,Khaki + +End Sub + +Sub ConfigWrite + Dim i, j, k, tf, t$ + If match > 0 Then Exit Sub + + tf = FreeFile + Open ConfigFile$ For Output As #tf + Print #tf, " 1 Background,"; bgc + Print #tf, " 2 Brightness,"; bri + Print #tf, " 3 Click,"; click + Print #tf, " 4 Color W sq,"; colori1 + Print #tf, " 5 Color B sq,"; colori2 + Print #tf, " 6 Clock color,"; colori3 + Print #tf, " 7 Clock type,"; clocktype + Print #tf, " 8 Cursor type,"; cursortype + Print #tf, " 9 Piece slide,"; fast + Print #tf, "10 Fullscreen,"; _FullScreen + Print #tf, "11 Graphics,"; graphics + Print #tf, "12 BG type,"; altbg + Print #tf, "13 Invert,"; binvert + Print #tf, "14 Legend,"; legend + Print #tf, "15 Logging,"; logging + Print #tf, "16 Notation,"; descriptive + Print #tf, "17 Sound,"; makenoise + Print #tf, "18 Set,"; piece_style + Print #tf, "19 Timer,"; smallclock + Print #tf, "20 Screen,"; smode + Print #tf, "21 Trim,"; squaretrim + Print #tf, "22 Hover,"; hover + Print #tf, "23 Markers,"; markers + + ' save funny piece selection (may have changed) + For i = 0 To 1 ' black then white + For j = 1 To 6 ' piece + k = i * 8 + j ' 1 2 3 4 5 6 9 10 11 12 13 14 + t$ = RTrim$(Mid$("rook knightbishopqueen king pawn ", (j - 1) * 6 + 1, 6)) + Print #tf, q$; Mid$("BW", i + 1, 1); " "; t$; q$; ","; piecefn(k) + Next j + Next i + + Print #tf, "White,"; q$; PlayerName$(1); q$ + Print #tf, "Black,"; q$; PlayerName$(0); q$ + Print #tf, "lasth,"; lasth + Print #tf, "lastc,"; lastc + Close #tf +End Sub + +Sub Cursor (column As _Byte, row As _Byte, to_flag As _Byte) ' highlight edge of square with green (to move) or red (destination) + Dim As _Byte i, c, r + Dim x, y + + c = column + r = 9 - row + If invert Then r = 9 - r: c = 9 - c + x = tlx + (c - 1) * xq + y = tly + (8 - r) * yq + If to_flag Then c1 = _RGB32(240, 10, 10) Else c1 = _RGB32(20, 240, 20) + For i = 0 To 3 + Line (x + i, y + i)-(x + xq - i, y + yq - i), c1, B + Next i +End Sub + +Function cx (t$) + cx = (tlx + trx) \ 2 - _PrintWidth(t$) \ 2 +End Function + +Sub DescriptiveNotation (tlevel As _Byte, tfc As _Byte, tfr As _Byte, ttc As _Byte, ttr As _Byte) + Dim mi + Dim As _Byte rcount, fc, fr, tc, tr, pm, pass, id1, id2 + Dim t$, tm$, ff$, tf$, fr$, tr$, qkf$, qkt$, z1$, z2$, z3$ + + 'TimeTrack "DNot", 1 + If tfc < 0 Then desc$ = "O-O": Exit Sub + If tfr < 0 Then desc$ = "O-O-O": Exit Sub + + pm = b(tfc, tfr) ' piece moving + + GoSub mmove + desc$ = t$ + Do ' loops until move is uniquely identified + rcount = 0 + For mi = 1 To Moves(tlevel) + fc = move(tlevel, mi).fc ' from column + fr = move(tlevel, mi).fr ' from row + If (fc < 1) Or (fr < 1) Then _Continue ' castling + If pm <> b(fc, fr) Then _Continue ' move other than moving piece + tc = move(tlevel, mi).tc ' to column + tr = move(tlevel, mi).tr ' to row + GoSub trans + If t$ = tm$ Then + rcount = rcount + 1 + If rcount > 1 Then + Select Case pass + Case 0: id1 = 0: id2 = 0 ' RxP + Case 1: id1 = 0: id2 = 1 ' RxBP + Case 2: id1 = 0: id2 = 2 ' RxKBP + Case 3: id1 = 0: id2 = 3 ' RxP(B4) + Case 4: id1 = 0: id2 = 4 ' RxP(KB4) + Case 5: id1 = 1: id2 = 0 ' R(B4)xP + Case 6: id1 = 2: id2 = 0 ' R(KB4)xP + Case 7: id1 = 2: id2 = 1 ' R(KB4)xNP + Case 8: id1 = 2: id2 = 2 ' R(KB4)xKNP + Case 9: id1 = 2: id2 = 3 ' R(KB4)xP(N3) + Case 10: id1 = 2: id2 = 4 ' R(KB4)xP(KN3) + Case Else: QuitWithError "DESC > 10", t$ + End Select + End If + End If + Next mi + GoSub mmove + pass = pass + 1 + Loop Until rcount = 1 + + If ((pm And 7) = Pawn) And (b(ttc, ttr) = 0) And (tfc <> ttc) Then t$ = t$ + "ep" ' en passant + + desc$ = t$ + 'TimeTrack "DNot", 0 + Exit Sub + + mmove: + fc = Abs(tfc) + fr = Abs(tfr) + tc = ttc + tr = ttr + GoSub trans + tm$ = t$ + Return + + trans: + t$ = "": ff$ = "": tf$ = "": qkf$ = "": qkt$ = "": z1$ = "": z2$ = "": z3$ = "" + + ff$ = Mid$("RNBQKBNR", fc, 1) ' from file + tf$ = Mid$("RNBQKBNR", tc, 1) ' to file + If WorB Then fr$ = CHRN$(fr) Else fr$ = CHRN$(9 - fr) ' from row + If WorB Then tr$ = CHRN$(tr) Else tr$ = CHRN$(9 - tr) ' to row + + If fc < 4 Then qkf$ = "Q" ' from queenside + If fc > 5 Then qkf$ = "K" ' from kingside + If tc < 4 Then qkt$ = "Q" ' to queenside + If tc > 5 Then qkt$ = "K" ' to kingside + + If id1 = 1 Then z3$ = "(" + ff$ + fr$ + ")" ' left side, (R5) + If id1 = 2 Then z3$ = "(" + qkf$ + ff$ + fr$ + ")" ' left side, (KR8) + t$ = Mid$("RNBQKP", pm And 7, 1) + z3$ + + If b(tc, tr) = 0 Then ' move with no capture + z1$ = "" + If id2 = 2 Then z1$ = qkt$ ' K or Q + t$ = t$ + "-" + z1$ + tf$ + tr$ ' KR or QR + Else ' move with capture + z1$ = "": z2$ = "": z3$ = "" + If id2 = 2 Then z1$ = qkt$ ' K or Q + If (id2 = 1) Or (id2 = 2) Then z2$ = tf$ ' 1-8 + If id2 = 3 Then z3$ = "(" + tf$ + tr$ + ")" ' (R8) + If id2 = 4 Then z3$ = "(" + qkt$ + tf$ + tr$ + ")" ' (KR8) + t$ = t$ + "x" + z1$ + z2$ + Mid$("RNBQKP", b(tc, tr) And 7, 1) + z3$ + End If + Return +End Sub + +Sub DispStats + Dim ns, tx, t$ + + If (human <> 2) And (insettings = false) Then ' 2 humans playing + If inpause Or insettings Then mps = 0 + ns = tdelay! + If ns Then t$ = Str$(ns) ' seconds delayed (CPU overheat) + t$ = t$ + " " + fnum$(mps) + " " + fnum$(top_mps) + " " + fnum$(tcount) + tx = trx - Len(t$) * 4 - 4 + If (colori3 = 3) Or (colori3 = 5) Then c1 = white Else c1 = clockc + TinyFont t$, tx, 27, c1 ' delay in seconds, moves per second, best moves per second, total moves + End If +End Sub + +Function ExtendedTimer# ' this function @SMcNeill + Dim As _Byte i, l, l1, m + Dim d, y, d$, s As _Unsigned Long + + d$ = Date$ + l = InStr(d$, "-") + l1 = InStr(l + 1, d$, "-") + m = Val(Left$(d$, l)) + d = Val(Mid$(d$, l + 1)) + y = Abs(Val(Mid$(d$, l1 + 1)) - 2020) + For i = 1 To m + Select Case i ' add the number of days for each previous month passed + Case 1: d = d ' January doesn't have any carry over days + Case 2, 4, 6, 8, 9, 11: d = d + 31 + Case 3: d = d + 28 + Case 5, 7, 10, 12: d = d + 30 + End Select + Next + For i = 1 To y + d = d + 365 + Next + For i = 2 To y Step 4 + If m > 2 Then d = d + 1 ' add an extra day for leap year every 4 years, starting in 1970 + Next + d = d - 1 ' for year 2000 + s = CDbl(d) * 24 * 60 * 60 ' seconds are days * 24 hours * 60 minutes * 60 seconds + ExtendedTimer# = s + Timer +End Function + +Function f6$ (t$) + f6$ = Left$(t$ + Space$(6), 6) +End Function + +Function f12$ (t$) + f12$ = Left$(t$ + Space$(12), 12) +End Function + +Sub FENcheck ' canned response for saved positions represented by FEN strings + Dim i, p, t$, c1$, c2$ + + 'If dev Then _Dest _Console + p = InStr(FEN$, " ") + c1$ = Left$(FEN$, p + 1) + 'If dev Then Print c1$ + For i = 1 To FENcount + c2$ = FEN$(i) + p = InStr(c2$, " ") + c2$ = Left$(c2$, p + 1) + 'If dev Then Print c2$ + If c1$ = c2$ Then + t$ = FENreply$(i) + If (Len(t$) > 0) And (t$ = UCase$(t$)) Then + wasFEN = i + FENm$ = LCase$(t$) + 'If dev Then Print FENm$ + Exit For + End If + End If + Next i + 'If dev Then _Dest 0 +End Sub + +Sub FENmake ' create FEN string of current board + Dim As _Byte b, r, c + Dim t$ + + FEN$ = "" + For r = 1 To 8 + For c = 1 To 8 + p = b(c, 9 - r) + If p > 0 Then + GoSub blanks + FEN$ = FEN$ + Mid$("rnbqkp RNBQKP", p, 1) + Else + b = b + 1 + End If + Next c + GoSub blanks + If r < 8 Then FEN$ = FEN$ + "/" + Next r + + FEN$ = FEN$ + " " + Mid$("bw", WorB + 1, 1) ' (b) or (w)hite to move + + ' castle$ is **** (qkQK), want KQkq + t$ = "" ' castling availability + For r = 1 To 4 + If Mid$(castle$, 5 - r, 1) = "*" Then t$ = t$ + Mid$("KQkq", r, 1) + Next r + If t$ = "" Then t$ = "-" + FEN$ = FEN$ + " " + t$ + + FEN$ = FEN$ + " " + epsq$ ' en passant square (even if an en passant is not available!) + FENpartial$ = FEN$ ' used to check for perpetual + FEN$ = FEN$ + " " + LTrim$(Str$(drawcount)) ' halfmoves since pawn move or capture + FEN$ = FEN$ + " " + LTrim$(Str$(move)) ' + + Exit Sub + + blanks: + If b Then FEN$ = FEN$ + CHRN$(b) + b = 0 + Return +End Sub + +Sub FENread ' load from file + Dim tf, f$, t1$, t2$ + + FENcount = 0 + f$ = datapath$ + "fen.dat" + If _FileExists(f$) = 0 Then Exit Sub + tf = FreeFile + Open f$ For Input As #tf + While Not (EOF(tf)) + Input #tf, t1$ + If Not (EOF(tf)) Then Input #tf, t2$ + If t2$ = UCase$(t2$) Then + FENcount = FENcount + 1 + (FENcount = FENmax) + FEN$(FENcount) = t1$ + FENreply$(FENcount) = t2$ + End If + Wend + Close #tf +End Sub + +Sub FENshow ' show boards of all FEN strings with reply, start with most recent + Static FENindex + Dim As _Byte i, r, c, n + Dim t$, c$ + + FENindex = FENindex - 1 + If FENindex < 1 Then FENindex = FENcount + t$ = FEN$(FENindex) + FENmess$ = FENreply$(FENindex) + i = 1 + r = 1 + c = 1 + For i = 1 To Len(t$) + c$ = Mid$(t$, i, 1) + If c$ = "/" Then + c = 1 + r = r + 1 + ElseIf InStr("123456789", c$) Then + n = Val(c$) + While n > 0 + b(c, 9 - r) = 0 + c = c + 1 + n = n - 1 + Wend + Else + If (c > 8) Or (r > 8) Then + WorB = InStr("bw", Mid$(t$, i, 1)) + SaveWorB = WorB + humanc = WorB + If WorB = 0 Then invert = true + redoflag = true + Exit For + End If + b(c, 9 - r) = InStr("rnbqkp RNBQKP", c$) + c = c + 1 + End If + Next i +End Sub + +Sub FENwrite ' save FEN strings to disk + Dim i, tf, t$ + If FENcount = 0 Then Exit Sub + tf = FreeFile + Open datapath$ + "fen.dat" For Output As #tf + For i = 0 To FENcount + t$ = FENreply$(i) + If Len(t$) > 0 Then + If t$ = UCase$(t$) Then + Print #tf, FEN$(i); ","; FENreply$(i) + End If + End If + Next i + Close #tf +End Sub + +Sub FileCheck + If _FileExists(f$) = false Then QuitWithError "File", f$ +End Sub + +Sub Fking (notify As _Byte) ' find kings, tally up score, count pieces + Dim mi + Dim As _Byte i, p, z, c, r, bking, wking, bpawn, wpawn + + Erase pcount, points + + bking = King: wking = bking Or 8 + bpawn = Pawn: wpawn = bpawn Or 8 + + bpc = 0: bpr = 0: wpc = 0: wpr = 0 ' pawn location + + For r = 1 To 8 + For c = 1 To 8 + z = b(c, r) ' 1-12 + p = z And 7 ' 1-6 + i = Sgn(z And 8) ' 0 black, 1 white + pcount(i, p) = pcount(i, p) + 1 + If p <> King Then points(i) = points(i) + value(p) \ mult + If z = bking Then bkr = r: bkc = c ' save row and column + If z = wking Then wkr = r: wkc = c + If (z = bpawn) And (Rnd > .5) Then bpr = r: bpc = c + If (z = wpawn) And (Rnd > .5) Then wpr = r: wpc = c + Next c + Next r + points = points(0) - points(1) ' to discourage pawn moves when sufficient power to mate + If WorB Then points = -points + + check = false: incheck = false + If WorB Then + c = wkc: r = wkr ' location of white King + Else + c = bkc: r = bkr ' location of black King + End If + For mi = 1 To Moves(1) ' can any opponent piece move there? + If (c = move(1, mi).tc) And (r = move(1, mi).tr) Then + incheck = true + Exit For + End If + Next mi + + If incheck And notify Then + check = true + TempMess$ = "Check!" + PlaySound checkn + AddSymbol "+" + End If +End Sub + +Sub ForRick ' statistics + Dim As _Byte c, r, i, p, tf + Dim tt, t$ + + If rickfile = 0 Then Exit Sub + + tf = FreeFile + If _FileExists("top.txt") Then + Open "top.txt" For Input As #tf + Input #tf, tt + Close #tf + If top_mps < tt Then Exit Sub ' not larger, abort saving + End If + + Open "top.txt" For Output As #tf + Print #tf, LTrim$(Str$(top_mps)) + Print #tf, Date$; " "; Time$ + For i = 0 To 1 ' what pieces were on the board, black then white + If i Then Print #tf, "White"; Else Print #tf, "Black"; + For p = 1 To 6 + If p = 5 Then _Continue ' skip King + t$ = Str$(pcount(i, p)) + Mid$("RNBQKP", p, 1) + If pcount(i, p) = 0 Then t$ = " " + Print #tf, t$; + Next p + Print #tf, "" + Next i + Print #tf, "" + If WorB Then t$ = "White" Else t$ = "Black" + If invert Then t$ = "Inverted, " + t$ + Print #tf, t$; " to move" + Print #tf, "" + + For r = 8 To 1 Step -1 ' board + For c = 1 To 8 + If invert Then p = b(9 - c, 9 - r) Else p = b(c, r) + p = p + (p > 6) * 2 + 1 + Print #tf, Mid$(".rnbqkpRNBQKP", p, 1); " "; + Next c + Print #tf, "" + Next r + Print #tf, "" + Print #tf, logfiled$; " @move"; move + Close #tf +End Sub + +Function fnum$ (n As _Unsigned _Integer64) ' format number for display with commas + Dim As _Byte i, zz + Dim n$, z$ + + n$ = LTrim$(Str$(n)) + For i = Len(n$) To 1 Step -1 + z$ = Mid$(n$, i, 1) + z$ + zz = zz + 1 + If ((zz Mod 3) = 0) And (i > 1) Then z$ = "," + z$ + Next i + fnum$ = z$ +End Function + +Function GetField$ (p$, y, chars As _Byte, sflag As _Byte, z$) + Dim As _Byte a, i, p, pw + Dim x, tx, tscreen, t$, c$ + + t$ = Left$(z$ + Space$(chars), chars) + p = 1 + tscreen = _CopyImage(0) + + Do: _Limit mloop + _PutImage , tscreen, 0 + + SetFont defaultfontsize + If InStr(p$, "Black") Then + c$ = "White: " + PlayerName$(1) + x = xc - _PrintWidth(c$) \ 2 + ShadowPrint x, 520, c$, white + End If + + GraphLoad + SetFont defaultfontsize + x = xc - _PrintWidth(p$ + RTrim$(LTrim$(t$))) \ 2 + ShadowPrint x, y, p$, white + tx = x + _PrintWidth(p$) + For i = 1 To chars + c$ = Mid$(t$, i, 1) + pw = _PrintWidth(c$) + ShadowPrint tx, y, c$, white + If i = p Then + Line (tx, y + 14)-Step(pw, 0), _RGB32(200, 200, 200) ' cursor + Line (tx + 1, y + 15)-Step(pw, 0), black ' cursor shadow + End If + tx = tx + pw + Next i + + If sflag Then chimp = 0: Center 0, " @ Enter ", true, false ' row, what, highlight, y offset + i$ = InKey$ + MouseIn + + If (i$ = " ") And ingetfile Then i$ = q$ + If istuff$ = "e" Then i$ = Enter$: istuff$ = "" + + Select Case Len(i$) + Case Is = 1 + If i$ = Esc$ Then Quit + If i$ = Enter$ Then + GetField$ = LTrim$(RTrim$(t$)) + _PutImage (x, y + 14)-(xm - 1, y + 15), bgi, 0, (x, y + 14)-(xm - 1, y + 15) ' erase cursor + i$ = "": asci = 0 + _PutImage , tscreen, 0 + _FreeImage tscreen + Exit Function + End If + If i$ = Chr$(8) Then p = p - 1 - (p = 1): _Continue ' backspace + If (LCase$(i$) <> UCase$(i$)) Or (InStr(" 0123456789_", i$) > 0) Then ' valid characters + Mid$(t$, p, 1) = i$ + p = p + 1 + If p > chars Then p = chars: Sound 4444, 1 + Else ' error beep for invalid character + Sound 222, 1 + End If + Case Is = 2 + a = Asc(i$, 2) + If a = 83 Then ' del + t$ = Left$(t$, p - 1) + Right$(t$, chars - p) + " " + _Continue + End If + p = p + (a = 75) - (a = 77) ' left or right arrow + If p < 1 Then p = 1 + If p > chars Then p = chars + End Select + Loop +End Function + + +Sub GetFileForPlayback + Static f$(10000), d$(10000), t$(10000), header$(10) ' file, date, time, who/when/result + + Dim se, i, j, k, cp, fc, fo, kk, lc, n, p, tf, ud, x1, x2, y1, y2, np, tx, ty, tscreen, tscreen2 + Dim bx1, bx2, by1, by2, y0, yt, yb, ic, nlines, effectflg, sbi + Dim o$, t$, x$, c$, d$, m$, y$, nf$, tf$, waslegend, fmax, zorba + Dim As _Unsigned Long tbg, bright + + fmax = 10000 + GoSub gfinit + + Do + woof: + _PutImage , tscreen, 0 + SetFont defaultfontsize + For i = 1 To np + j = i + fo + If j > n Then Exit For + yt = y1 + (i - 1) * 17 + 5 + + t$ = f$(j) + While _PrintWidth(t$) > 140 + t$ = Left$(t$, Len(t$) - 1) + Wend + c1 = gray + If j = se Then ' selected item, highlight + Line (x1 + 4, yt - 3)-(bx1 - 4, yt + 14), gray, BF + cp = i + c1 = white + End If + ShadowPrint x1 + 10, yt, t$, c1 ' filename + ShadowPrint x1 + 196, yt, d$(j), c1 ' date + ShadowPrint x1 + 268, yt, t$(j), c1 ' time + Next i + + If f$(se) <> "-deleted" Then GoSub file_info + + Line (x1 - 1, y1)-(x2, y2), white, B ' box around file get area + Line (bx1, by1)-(bx2, by2), tbg, BF ' erase scroll bar area + Line (bx1, by1)-(bx2, by2), white, B ' box around scroll bar area + + y0 = by1 + (se - 1) / (n - 1) * (by2 - by1 - 20) + 10 ' scroll bar + yt = y0 - 10: If yt < (by1 + 1) Then yt = by1 + 1 + yb = y0 + 10: If yb > (by2 - 1) Then yb = by2 - 1 + Line (bx1 + 1, yt)-(bx2 - 1, yb), gray, BF + Line (bx1 + 1, yt)-(bx2 - 1, yb), tbg, B + + tscreen2 = _CopyImage(0) + + Do: _Limit mloop + If effectflg = false Then ' effect on entry, not replots + _PutImage , tscreen, 0 + WindowEffect 3, tscreen2, x1, y1, x2, y2 ' 0zoom 1unfold 2random 3fade + effectflg = true + End If + _PutImage , tscreen2, 0 + GraphLoad + TempMess$ = "Option select via mouse" ' mouse because letters are for searching + nbox = zorba + chimp = 0 + AboveBoardInfo + + t$ = Str$(se) + ":" + LTrim$(Str$(n)) ' selected of selections, optional + TinyFont t$, tlx + 14, tly - 6, white ' show at top left + + GraphLoad ' always monitor CPU + lct$ = "" + Center 0, " Play Rename Delete Edit Wipe Back ", 1, 0 ' playback menu + + GoSub elstupido ' highlight scroll button + + KeyScan + + If Len(istuff$) Then i$ = istuff$: istuff$ = "" + If Len(i$) > 0 Then + i$ = UCase$(i$) + If i$ = Enter$ Then i$ = "PL" ' equate Enter key as Play + If (i$ = Esc$) Or (i$ = "BA") Then Exit Do + If (f$(se) = "-deleted") Then + If (LCase$(i$) = UCase$(i$)) Or (i$ = "SCROLL") Or (i$ = "FILENAME") Then Exit Do + _Continue + End If + End If + Loop Until Len(i$) + + _FreeImage tscreen2 + lc = se ' save last selected because clicking on an item twice selects it + If (i$ = Esc$) Or (i$ = "BA") Then f$ = "": Exit Do + + 'debug$ = "*" + i$ + "* " + Select Case i$ + Case Is = "WI" + Sound 222, 2 + _PutImage (blx, bly + 1)-(brx, _Height - 20), bgi, 0, (blx, bly + 1)-(brx, _Height - 20) + Center 33, "Delete all ch*.* files", 0, 0 + Center 0, " confirm wipe Y / N ", true, false + Do: _Limit 10 + KeyScan + If asci = 27 Then Exit Do + If i$ = "" Then i$ = " " + Loop Until InStr("yn", LCase$(i$)) + If i$ = "y" Then + Center 0, "Deleting...", 0, 0 + DisplayMaster true + _Delay 1 + Shell _Hide delcmd$ + gamepath$ + "ch0*.*" + GoSub gfinit + GoTo woof + End If + Case Is = "ED" ' edit + Do: _Limit mloop + Center 0, " Algebraic or Descriptive? ", true, false + KeyScan + If asci = 27 Then Exit Do + If i$ = "" Then i$ = " " + Loop Until InStr("ad", i$) + If asci <> 27 Then + If i$ = "a" Then t$ = ".alg" Else t$ = ".des" + t$ = gamepath$ + f$(se) + t$ + If _FileExists(t$) Then Shell _DontWait editcmd$ + t$ + End If + Case Is = "FILENAME" ' filename (clicked on) + se = fo + Int((my - y1) / (y2 - y1) * np) + 1 + If se < 1 Then se = 1 + If se > n Then se = n + If se > (fo + np) Then + se = fo + np + If se > n Then se = n + End If + If se = lc Then + f$ = f$(se) + fd$ = d$(se) + readonly = -(Len(header$(7)) > 0) ' if game had an end, disable file writes + Exit Do + End If + Case Is = "PL" ' play + f$ = f$(se) + fd$ = d$(se) + Exit Do + Case Is = "RE" ' rename + GoSub clearbottom + nf$ = GetField$("New filename: ", 520, 14, 0, "") + If Len(nf$) = 0 Then _Continue + For i = 1 To n + If nf$ = f$(i) Then + If makenoise Then PlaySound illegal Else Sound 7777, 1 + t$ = "Filename in use!" + _Font 14 + ShadowPrint (tlx + trx) \ 2 - _PrintWidth(t$) \ 2, 520, t$, white + DisplayMaster true + Sleep 2 + GoTo woof + End If + Next i + + If minty Then ' Linux + c$ = rencmd$ + gamepath$ + f$(se) + ".alg " + gamepath$ + nf$ + ".alg" + Shell _Hide c$ + c$ = rencmd$ + gamepath$ + f$(se) + ".des " + gamepath$ + nf$ + ".des" + Shell _Hide c$ + Else ' above method not working in XP - too long? + tf = FreeFile + c$ = _CWD$ + Open "temp.bat" For Output As #tf + Print #tf, "cd "; gamepath$ + Print #tf, "ren "; f$(se); ".alg "; nf$; ".alg" + Print #tf, "ren "; f$(se); ".des "; nf$; ".des" + Print #tf, c$ + Close #tf + Shell _Hide "temp" + End If + + If logfiled$ = (f$(se) + ".alg") Then + logfiled$ = nf$ + ".alg" + logfile$ = gamepath$ + logfiled$ + End If + f$(se) = nf$ + Case Is = "SCROLL" ' mouse scroll area + ty = my + If ty < (by1 + 10) Then ty = ty - 10 + If ty > (by2 - 10) Then ty = ty + 10 + se = Int((ty - by1) / (by2 - by1) * n) + GoSub to_middle + Case Is = "DE" ' delete + Do: _Limit mloop + Center 0, " confirm delete Y / N ", true, false + KeyScan + If i$ = "" Then i$ = " " + Loop Until InStr("yn", i$) + If i$ = "y" Then + + tf$ = gamepath$ + f$(se) + ".des" ' descriptive + c$ = delcmd$ + tf$ + Shell _Hide _DontWait c$ + + tf$ = gamepath$ + f$(se) + ".alg" ' algrebraic + c$ = delcmd$ + tf$ + Shell _Hide _DontWait c$ + + f$(se) = "-deleted" + GoSub clearbottom + End If + Case Else ' search for first letter + For i = 1 To n + j = se + i + If j > n Then j = j - n + If LCase$(i$) = LCase$(Left$(f$(j), 1)) Then + se = j + GoSub to_middle + Exit For + End If + Next i + End Select + + If Len(i$) = 2 Then ' extended key, most likely up or down + kk = Asc(i$, 2) + If kk = 71 Then ' Home, jump to top of list + se = 1 + fo = 0 + End If + If kk = 79 Then ' End, jump to end of list + se = n + fo = n - 25: If fo < 0 Then fo = 0 + End If + ud = (kk = 72) - (kk = 80) - (kk = 81) * 10 + (kk = 73) * 10 ' up/down/PgUp/PgDn + For i = 1 To Abs(ud) + se = se + Sgn(ud) + fc = 0 + If (ud < 0) And (cp < 2) Then fc = -1 + If (ud > 0) And (cp > (np - 1)) Then fc = 1 + fo = fo + fc + If fo < 0 Then fo = 0 + If se < 1 Then se = 1: fo = 0 + If se > n Then se = n: fo = fo - 1 + If fc = 0 Then cp = cp + Sgn(ud) + Next i + If n < np Then fo = 0 + End If + Loop + + TempMess$ = " " + ingetfile = false + legend = waslegend + PlotScreen false + oply = false + chimp = 0 + Exit Sub + ' --------------------------------------------------------------------------------------------- + elstupido: + sbi = (sbi + 1) Mod 100 + For i = 1 To 6 + If (i + sbi) Mod 2 Then c1 = white Else c1 = black + Line (bx1 + i, yt + i)-(bx2 - i, yb - i), c1, B + Next i + Return + ' --------------------------------------------------------------------------------------------- + to_middle: + If se < 1 Then se = 1 + If se > n Then se = n + If (se > np) Or (se < (n - np)) Then + fo = se - 14 + If fo < 0 Then fo = 0 + If fo > (n - np) Then fo = n - np + End If + Return + ' --------------------------------------------------------------------------------------------- + clearbottom: + _PutImage (blx, bly + 1)-(brx, _Height - 20), bgi, 0, (blx, bly + 1)-(brx, _Height - 20) + Return + ' --------------------------------------------------------------------------------------------- + gfinit: + tbg = _RGBA(0, 0, 0, 230) ' temporary background + n = 0 + lct$ = "" + giveup = false + nbox = 4 + waslegend = legend ' save because I turn it off for a nicer look + legend = false + TempMess$ = "Looking for files..." + PlotScreen true + c$ = dircmd$ + gamepath$ + "*.alg /o-d >temp.dir" ' does Linux understand /o-d? check... + Shell _Hide c$ + tf = FreeFile + Open "temp.dir" For Input As #tf + While Not (EOF(tf)) And (n < fmax) + Line Input #tf, o$ + o$ = LCase$(o$) + p = InStr(o$, ".alg") + If p Then + i = p + While InStr(" /", Mid$(o$, i, 1)) = 0 + i = i - 1 + Wend + t$ = LTrim$(Mid$(o$, i + 1, p - i - 1)) + p = InStr(t$, " "): If p > 0 Then t$ = Right$(t$, Len(t$) - p) + n = n + 1 + f$(n) = t$ + + If minty Then ' Linux Mint + m$ = Mid$(o$, 29, 3) + p = InStr(" janfebmaraprmayjunjulaugsepoctnovdec", m$) \ 3 ' convert month to numeric + m$ = Right$("0" + LTrim$(Str$(p)), 2) ' alphanumeric + + d$ = Mid$(o$, 33, 2) ' day + If Left$(d$, 1) = " " Then Mid$(d$, 1, 1) = "0" ' prefix 0 if d < 10 + + If Mid$(o$, 38, 1) = ":" Then ' is time + t$ = Mid$(o$, 36, 5) + kk = Val(Left$(t$, 2)) + t$ = Mid$("ampm", 3 + (kk < 12) * 2, 2) + If kk > 12 Then kk = kk - 12 + t$(n) = Right$("0" + LTrim$(Str$(kk)), 2) + Mid$(o$, 38, 3) + " " + t$ + y$ = Mid$(Date$, 7, 4) + Else + t$(n) = "24:00 am" + y$ = Mid$(o$, 37, 4) + End If + t$(n) = " " + t$(n) + d$(n) = y$ + "." + m$ + "." + d$ ' yyyy.mm.dd + Else + t$ = Mid$(o$, 4, 1) + If LCase$(t$) <> UCase$(t$) Then ' date format must be dd MMM yyyy + t$ = LCase$(Mid$(o$, 4, 3)) ' isolate month + p = InStr(" janfebmaraprmayjunjulaugsepoctnovdec", t$) \ 3 ' convert month to numeric + d$(n) = "20" + Mid$(o$, 8, 2) + "." + Right$("0" + LTrim$(Str$(p)), 2) + "." + Left$(o$, 2) ' convert to yyyy.mm.dd + t$(n) = Mid$(o$, 12, 9) ' time + Else + t$ = Left$(o$, 10) ' date format is mm/dd/yy + If Right$(t$, 2) = " " Then + d$(n) = "20" + Right$(t$, 2) + "." + Left$(t$, 2) + "." + Mid$(t$, 4, 2) + Else + d$(n) = Right$(t$, 4) + "." + Left$(t$, 2) + "." + Mid$(t$, 4, 2) + End If + t$(n) = Mid$(o$, 12, 9) ' time + End If + End If + End If + Wend + Close #tf + TempMess$ = " " + + If n = 0 Then + TempMess$ = "No saved files!" + PlotScreen true + _Delay 1 + End If + + If n = 1 Then f$ = f$(1) + If n < 2 Then oply = false: ingetfile = false: Exit Sub + + ingetfile = true + PlotScreen false + _PutImage (blx, bly)-(brx, _Height - 1), bgi, 0, (blx, bly)-(brx, _Height - 1) + Center 0, " Play Rename Delete Edit Back ", true, false + + SetFont defaultfontsize + bright = _RGB32(250, 250, 250) + np = 25 + If se = 0 Then se = 1 + xc = (tlx + trx) \ 2 + x1 = xc - 176 + x2 = xc + 176 + y1 = 44 + y2 = y1 + np * 17 + 4 + + nbox = 4 + nbox = nbox + 1 + mft$(nbox) = Chr$(0) + Chr$(72) ' arrow up + mfx1(nbox) = x2 - 19 + mfx2(nbox) = x2 + mfy1(nbox) = y1 + 1 + mfy2(nbox) = y1 + 18 + + nbox = nbox + 1 + mft$(nbox) = Chr$(0) + Chr$(80) ' arrow down + mfx1(nbox) = x2 - 19 + mfx2(nbox) = x2 + mfy1(nbox) = y2 - 19 + mfy2(nbox) = y2 + + bx1 = x2 - 19 + bx2 = x2 + by1 = y1 + 19 + by2 = y2 - 19 + + nbox = nbox + 1 + sbi = nbox + mft$(nbox) = "SCROLL" + mfx1(nbox) = bx1 ' scroll area + mfx2(nbox) = bx2 + mfy1(nbox) = by1 + mfy2(nbox) = by2 + + nbox = nbox + 1 + mft$(nbox) = "FILENAME" + mfx1(nbox) = x1 ' filename area + mfx2(nbox) = x2 - 20 + mfy1(nbox) = y1 + mfy2(nbox) = y2 + + zorba = nbox + chimp = nbox + + SetFont 16 + For i = 5 To 6 ' fill in up/down + Line (bx1, mfy1(i))-(bx2, mfy2(i)), gray, BF + tx = bx1 + 2 + ty = mfy1(i) + 1 - (i = 6) * 2 + ShadowPrint tx, ty, Chr$(30 - (i = 6)), white + Line (bx1, mfy1(i))-(bx2, mfy2(i)), white, B + Next i + + For i = 1 To 4 + Line (x1 - i - 1, y1 - i)-(bx2 + i, y2 + i), tbg, B + Next i + Line (x1 - 1 - 5, y1 - 5)-(bx2 + 5, y2 + 5), gray, B + Line (x1 - 1, y1)-(mfx2(8), y2), tbg, BF ' erase file get area + Line (tlx, 0)-(trx, tly - 1), black, BF + If tscreen < -1 Then _FreeImage tscreen + tscreen = _CopyImage(0) + Return + ' -------------------------------------------------------------------------------- + file_info: + tf = FreeFile + f$ = gamepath$ + f$(se) + ".alg" + + If _FileExists(f$) = 0 Then Return + Open f$ For Input As #tf + nlines = 0 + For i = 1 To 10 + header$(i) = "" + Next i + While Not (EOF(tf)) + nlines = nlines + 1 + Line Input #tf, t$ + If (nlines < 8) And (InStr(t$ + " ", "[") > 0) Then + t$ = Mid$(t$, 2, Len(t$) - 2) + header$(nlines) = t$ + End If + Wend + Close #tf + mig = nlines - 7 + header$(1) = "Moves" + Str$(mig) + + SetFont defaultfontsize + GoSub clearbottom + For i = 1 To 5 + j = Val(Mid$("56317", i, 1)) + x$ = header$(j) + t$ = "" + ic = Val(Mid$("66567", i, 1)) + For k = 1 To Len(x$) + c$ = Mid$(x$, k, 1) + If k = ic Then t$ = t$ + ":" + If c$ <> q$ Then t$ = t$ + c$ + Next k + j = InStr(t$, ":") + x$ = Left$(t$, j) + t$ = Right$(t$, Len(t$) - j) + If t$ = " " Then t$ = "Unknown" + ShadowPrint xc - _PrintWidth(x$) - 6, bly - 4 + i * 16, x$, gray + ShadowPrint xc, bly - 4 + i * 16, t$, white + Next i + Return +End Sub + +Sub ReadLinuxTemperatures + Static xtemp + Dim As _Byte tf, p1, p2, newinfo + Dim t1, t2, t$ + + 'TimeTrack "ReadTemp", 1 + + If ExtendedTimer < newinfo Then + c1 = xtemp + Else + Shell _Hide "sensors > temp.dat" ' kosher with all flavors of Linux I hope + c1 = 0 ' return value default + If _FileExists("temp.dat") = 0 Then Exit Sub ' in case sensors was invalid + tf = FreeFile + Open "temp.dat" For Input As #tf + While Not (EOF(tf)) + Line Input #tf, t$ + If Left$(t$, 4) = "Core" Then ' core 0 to whatever + p1 = InStr(t$, "+") + 1 ' location of core temperature + p2 = InStr(p1 + 1, t$, "+") + 1 ' location of critical temperature + t1 = Val(Mid$(t$, p1, 3)) ' core temperature + t2 = Val(Mid$(t$, p2, 3)) ' critical temperature + c2 = t1 * 100 / t2 ' % + If c2 < 0 Then c2 = 0 + If c2 > 127 Then c2 = 127 + If c2 > c1 Then c1 = c2 ' take highest % + End If + Wend + Close #tf + xtemp = c1 + newinfo = ExtendedTimer + .2 + End If + 'TimeTrack "ReadTemp", 0 +End Sub + +Sub GetWB ' white or black [after file playback or setup] + ClearBuffers + getwbflag = true + Do: _Limit mloop + If msg$ = "Checkmate" Then TempMess$ = msg$ + nbox = 4 + chimp = 0 + PlotScreen false + KeyScan + If Len(i$) = 0 Then i$ = "*" + p = InStr("bw", i$) + Loop Until p + nbox = chimp + TempMess$ = " " + getwbflag = false + human = true + humanc = p - 1 + invert = humanc Xor 1 + abort = true + _Delay .2 + ClearBuffers +End Sub + +Sub GraphLoad Static + Dim As _Unsigned _Byte gsinit, i, n, cpuavg, sa + Dim na, np, x1, y1, x2, y2, p1, p2, spx, spy, zz, z1, z2, ospx, ospy, tx, mmax + Dim As _Unsigned Long tred, tgreen, tyellow, tc(3) + Dim inf$(4), inc(4) As _Unsigned Long, inf(4), inx(4) As _Byte + Dim gp(152) As gpoints + Dim As _MEM m0, m1 + m0 = _Mem(gp(0)): m1 = _Mem(gp(1)) + Dim tf, t$ + $If WIN Then + Dim lt, ltc As Double + $Else + Dim lfreq, ltemp, nline, tcpu As Single + $End If + + Type gpoints + tem As _Byte + loa As _Byte + mps As Long + avl As _Byte + avm As Long + End Type + + If barebones Then Exit Sub + + If gsinit = false Then + tred = _RGB32(220, 20, 20) ' colors a bit off from any background so they stand out + tgreen = _RGB32(20, 220, 20) + tyellow = _RGB32(230, 230, 0) + + tc(1) = tgreen + tc(2) = tyellow + tc(3) = tred + + x1 = 24 + x2 = tlx - 20 + y1 = bly + y2 = _Height - 21 + + np = x2 - x1 ' number of points + na = 4 ' number to average + p1 = np + 1: p2 = na + 1 ' pointers + + $If WIN Then + tf = FreeFile + Open "temp2.bat" For Output As #tf + Print #tf, "@echo off" + Print #tf, "for /f " + q$ + "skip=1 tokens=2 delims==" + q$ + " %%A in ('wmic /namespace:\\root\wmi PATH MSAcpi_ThermalZoneTemperature get CurrentTemperature /value') do set /a " + q$ + "HunDegCel=(%%~A*10)-27315" + q$ + Print #tf, "echo %HunDegCel:~0,-2%.%HunDegCel:~-2% Degrees Celsius" + Close #tf + $End If + + SetFont 9 + inf(1) = -1: inc(1) = tred + inf(2) = -1: inc(2) = tyellow: inf$(2) = "LOAD": inx(2) = _PrintWidth(inf$(2)) + inf(3) = -1: inc(3) = tgreen: inf$(3) = "MPS": inx(3) = _PrintWidth(inf$(3)) + inf(4) = -1: inc(4) = _RGB32(222, 222, 222) + + gsinit = true + End If + + _MemCopy m1, m1.OFFSET, m1.SIZE To m0, m0.OFFSET + p1 = p1 - 1 - (p1 = 1) ' decrement pointer if >1 + p2 = p2 - 1 - (p2 = 1) ' pointers into array + + If (rflag = 0) Or insettings Then mps = 0 + gp(np).mps = mps + + $If WIN Then + gp(np).loa = GetCPULoad * 100 + + If ExtendedTimer > ltc Then ' limited to once every 5 seconds + Shell _Hide "temp2.bat > temp2.dat" ' get temperature from wmic.exe + If _FileExists("temp2.dat") Then + tf = FreeFile + Open "temp2.dat" For Input As #tf + If Not (EOF(tf)) Then Line Input #tf, t$ ' ya never know! (checking off, be cautious) + lt = Val(t$) + If lt < 0 Then lt = 0 ' should not happen - read error? + If lt > 127 Then lt = 127 ' cover all bases + gp(np).tem = lt + Close #tf + End If + ltc = ExtendedTimer + 5 + Else + gp(np).tem = lt ' use last temperature read + End If + $Else + lfreq = (lfreq + 1) Mod 5 + If lfreq = 1 Then + + ReadLinuxTemperatures ' uses sensors command + ltemp = c1 + If ltemp < 0 Then ltemp = 0 + If ltemp > 127 Then ltemp = 127 + + tcpu = 0 ' CPU load + nline = 0 + Shell _Hide "top -b -i -n 1 > temp.dat" + If _FileExists("temp.dat") Then + tf = FreeFile + Open "temp.dat" For Input As #tf + While Not (EOF(tf)) + Line Input #tf, t$ + nline = nline + 1 + If nline > 7 Then tcpu = tcpu + Val(Mid$(t$, 48, 5)) + Wend + Close #tf + End If + If tcpu < 0 Then tcpu = 0 + If tcpu > 100 Then tcpu = 100 + End If + gp(np).tem = ltemp + gp(np).loa = tcpu + $End If + + z1 = 0: z2 = 0 + For i = na To p2 Step -1 ' smooth numbers + z1 = z1 + gp(np - i + 1).loa + z2 = z2 + gp(np - i + 1).mps + Next i + gp(np).avl = z1 \ (na - p2 + 1) ' average load + If mps = top_mps Then ' cancel averaging for this point to let graph hit top + gp(np).avm = mps + Else + gp(np).avm = z2 \ (na - p2 + 1) + End If + + If minty Then cpuavg = gp(np).tem Else cpuavg = gp(np).loa ' for Linux, use actual temperature: for Windows, CPU load + + If cpuavg > 98 Then ' throttle performance + If ((ndelay Mod 10) = 0) And (mloop > 1) Then mloop = mloop - 1 + ndelay = ndelay + 1 ' track how many delays + If mdelay! = 0 Then mdelay! = .1 + _Delay mdelay! ' prevent CPU overheating + tdelay! = tdelay! + mdelay! + End If + + If (cpuavg < 70) And (mloop < 10) Then mloop = mloop + 1 ' restore performance + + If pregame Then Exit Sub ' don't show graph on main menu + + _PutImage (x1, y1 - 12)-(x2, y2), bgi, 0, (x1, y1 - 12)-(x2, y2) ' clear graph area + + If (bgc = 0) Or (bgc = 2) Then c1 = gray Else c1 = black ' red & blue + For zz = y1 To y2 Step (y2 - y1) / 11 + Line (x1, zz)-(x2, zz), c1, , &H8080 + Next zz + + If gscale Then + mmax = top_mps ' set max to top seen this session + Else + mmax = 0 ' set max to top IN VIEW + For i = 0 To np + If gp(i).mps > mmax Then mmax = gp(i).mps + Next i + End If + + z1 = y2 - y1 ' save a little computation in next loop + z2 = z1 - 10 ' ditto + sa = 1 - (mmax = 0) ' skip plotting mps if 0 + + For n = sa To 3 + For i = p1 To np - 1 + spx = x1 + i + Select Case n + Case 1 ' moves per second + spy = y2 - z2 * gp(i).avm \ mmax + Case 2 ' CPU load + spy = y2 - z1 * gp(i).avl \ 110 + Case 3 ' temperature + spy = y2 - z1 * gp(i).tem \ 110 + End Select + If spy <= (y1 + 1) Then spy = y1 + 1 + If spy > (y2 - 1) Then spy = y2 - 1 + If i > p1 Then + Line (ospx + 1, ospy + 1)-(spx + 1, spy + 1), black ' helps lines stand out against background + Line (ospx, ospy)-(spx, spy), tc(n) ' plot graph + End If + ospx = spx: ospy = spy ' + Next i + Next n + + SetFont 9 + + If gp(np).tem <> inf(1) Then + inf$(1) = LTrim$(Str$(gp(np).tem)) + Chr$(248) + "C" + inf(1) = gp(np).tem + inx(1) = _PrintWidth(inf$(1)) + End If + + If mloop <> inf(4) Then + inf$(4) = "FPS" + Str$(mloop) + inf(4) = mloop + inx(4) = _PrintWidth(inf$(4)) + End If + + tx = x1 + For i = 1 To 4 + ShadowPrint tx, bly - 10, inf$(i), inc(i) + tx = tx + inx(i) + 10 + Next i + ShadowPrint tx - 8, bly - 10, "/10", inc(4) +End Sub + +Sub Help + Dim p, lp, tf, np, xp, yp, xmin, xmax, ls, pw, sp, tscreen, sbri, mybit + Dim birdie, t$, w$, xtimer As Double + + If inhelp Then Exit Sub + inhelp = true + + sbri = bri ' save user selected brightness + bri = 3 ' brightness + ColorSet + Cls , black + + If fullscreenflag > 0 Then Buttons 0, 0 ' ?, min, resize, exit + + boardwhite = _RGB32(200, 200, 200) + SetFont 18 + xmin = 20: xmax = _Width - xmin ' set left and right margin + yp = 40 + + xp = xmin ' left margin + ls = _FontHeight + 1 ' line spacing + sp = _PrintWidth(" ") - 1 ' space size + + Color boardwhite + f$ = datapath$ + "help.txt" ' .\chessdat\help.txt + If _FileExists(f$) = 0 Then Exit Sub + + t$ = datapath$ + "dodo.png" ' optional dodo picture + If _FileExists(t$) Then birdie = _LoadImage(t$) + If birdie < -1 Then GoSub DumbBird + + tf = FreeFile + Open f$ For Input As #tf + While Not (EOF(tf)) + Line Input #tf, t$ + lp = 1 ' last position of a blank + Do + p = InStr(lp, t$ + " ", " ") ' find next space + If p < 3 Then Exit Do ' done with this line + w$ = LTrim$(RTrim$(Mid$(t$, lp, p - lp + 1))) ' grab a word + lp = p + 1 ' update last chr$(32) + If Len(w$) = 0 Then _Continue ' takes care of any double space + np = (Right$(w$, 2) = "/p") ' detect new paragraph + If np Then + w$ = Left$(w$, Len(w$) - 2) ' remove command + If rotate = 0 Then DisplayMaster true + End If + pw = _PrintWidth(w$) + If (xp + pw) > xmax Then xp = xmin: yp = yp + ls ' new line + 'ShadowPrint xp, yp, w$, boardwhite ' slow, ineffective with a dark background + _PrintString (xp, yp), w$ + xp = xp + pw + sp + If np Then xp = xmin: yp = yp + ls * 1.5 ' new paragraph + Loop + Wend + Close #tf + + ClearBuffers ' inkey and buttons + xtimer = ExtendedTimer - 1 + tscreen = _CopyImage(0) ' base image + nbox = 3 + Do: _Limit mloop + _PutImage , tscreen, 0 ' the text on a blank screen + Buttons 0, 0 ' min/resize/close + If birdie < -1 Then GoSub DumbBird + KeyScan ' check input + If ExtendedTimer > xtimer Then + plasma_init = false + xtimer = ExtendedTimer + 5 ' change background plasma in 5 seconds + mybit = mybit Xor 1 ' bird orientation (facing left or right) + End If + If dev And (i$ = "q") Then Quit + Loop Until (asci = 27) Or b1 Or b2 ' Esc or mouse button + + _FreeImage birdie + _FreeImage tscreen ' free up memory + b1 = false + b2 = false + bri = sbri + ColorSet + inhelp = false + PlotScreen true + Exit Sub + + DumbBird: + If mybit Then + _PutImage (xmax, 40)-(xmax - 110, 150), birdie, 0 ' facing right + Else + _PutImage (xmax - 110, 40)-(xmax, 150), birdie, 0 ' facing left + End If + Return +End Sub + +Sub InfoOnRight + Static ply, iscreen + + If barebones Then Exit Sub + + If (rotate = 1) Or (rotate = 3) Then Exit Sub + If (human = 2) And (showthinkingf Or dosmallboard) Then Exit Sub + 'TimeTrack "IOR", 1 + + If rflag And showthinkingf Then oply = -1 + ply = move * 2 + WorB + If ply = oply Then + _PutImage (trx + 1, try)-(_Width - 1, _Height - 20), iscreen, 0, (trx + 1, try)-(_Width - 1, _Height - 20) + GoTo es + End If + oply = ply + + If dosmallboard Then + If ssb(1) < -1 Then _PutImage (trx + 1, try)-(_Width - 1, _Height - 20), ssb(1), 0, (trx + 1, try)-(_Width - 1, _Height - 20) + GoTo ss + End If + If showthinkingf Then ShowThinking Else HistoryX + + ss: + If iscreen < -1 Then _FreeImage iscreen + iscreen = _CopyImage(0) + + es: + 'TimeTrack "IOR", 0 +End Sub + +Sub HistoryX + Dim mi, j, sa, sx, sy, dx, dy, ox, oy, c$, t$, lc$ + + 'If dev Then Sound 9999, 1 + sx = trx + 35 + sy = tly + 3 + dx = sx + dy = sy ' set writing to top line + SetFont 9 + sa = shia + move - 48 + If sa < 1 Then sa = 1 + + For mi = sa To sa + 48 + t$ = "" + If mi <= move Then + If descriptive Then + t$ = f12$(mlog$(mi, 3)) + " " + f12$(mlog$(mi, 2)) + Else + t$ = f12$(mlog$(mi, 1)) + " " + f12$(mlog$(mi, 0)) + End If + If Len(t$) Then t$ = Rjust$(mi, 4) + " " + t$ ' prefix the move number + GoSub xprint + End If + Next mi + + Exit Sub + ' ----------------------------------------------------------------------------------------- + xprint: ' similar to X-files + + t$ = RTrim$(t$) ' else "w" in draw gets cut off + + If (dy \ (_FontHeight + 2)) Mod 2 Then ' alternate blank/shaded like old printer paper + j = _SHL(bri, 4) ' j = bri * 8 + Line (dx, dy - 1)-Step(185, _FontHeight), _RGB32(j, j, j), BF + End If + Color white, zip + + For j = 1 To Len(t$) ' print one character at a time to get nice spacing (kerning) + c$ = Mid$(t$, j, 1) ' the character + If c$ <> " " Then + ox = 0 ' offset x + If c$ = "?" Then ox = 2 + If c$ = "(" Then ox = 2 + + If c$ = "-" Then + If lc$ <> ")" Then ox = 2 + If lc$ = ")" Then ox = 1 + If lc$ = "P" Then ox = 1 + End If + + If c$ = "+" Then + If lc$ <> "O" Then ox = 1 + If lc$ = ")" Then ox = 0 + If lc$ = "R" Then ox = 2 + If lc$ = "+" Then ox = 2 + If lc$ = "Q" Then ox = 2 + End If + + If (c$ = "P") And (lc$ <> " ") Then ox = 1 + + If lc$ = "x" Then ox = 1 + If (c$ = "x") And (lc$ = ")") Then ox = -1 + + If InStr("bdg", c$) Then ox = -1 + + If (j > 4) And descriptive And (InStr("e12345678)", c$) > 0) Then ox = 1 + oy = (c$ = "-") + (c$ = "g") ' offset y + ShadowPrint dx + (j - 1) * 6 + ox, dy + oy, c$, white + End If + lc$ = c$ ' save last char + Next j + dy = dy + _FontHeight + 2 + Return +End Sub + +Sub HumanMove Static + Static As _Byte cc, rr + Static As Long dx, dy, smx, smy + Dim As _Byte i, z, cd, rd, mp, onboard, pc, tp + Dim x, y + + If hinit = false Then ' initialize (cursor on king pawn) + mx = 999 ' old Mexican + cc = 5 ' column + rr = 7 ' row + dx = tlx + cc * xq - hxq + dy = tly + rr * yq - hyq + hinit = true + End If + + mp = 0 ' moving piece + pc = 0 ' plot cursor + + redo: + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' copy working b() to display board b2() + + For i = 0 To 1 + + cursoron = ExtendedTimer + 2 + + Do: _Limit mloop + If i = 0 Then mp = 0 + PlotScreen false + If onboard And (piece_style = 0) Then ID_or_ChangePiece cc, rr ' funny pictures - Mel Brooks, Trump, SpongeBob, etc. + If (mp > 0) And (mx > tlx) And (mx < trx) And (my > try) And (my < bly) Then + z = PieceSize(mp) + _PutImage (dx - hxq + z, dy - hyq + z)-(dx - hxq + xq - z, dy - hyq + yq - z), pix(piece_style, mp), 0 + End If + + If (cursoron < ExtendedTimer) And hover And onboard Then + tp = b(cc, 9 - rr) + If i Then + If (tp = 0) Or (WorB <> Sgn(tp And 8)) Then istuff$ = Enter$ + Else + If (tp > 0) And (WorB = Sgn(tp And 8)) And (nvalid > 0) Then istuff$ = Enter$ + End If + If (istuff$ = Enter$) And click Then + If i Then PlaySound click2 Else PlaySound click1 + End If + End If + If pc And ((istuff$ = Enter$) Or (cursoron > ExtendedTimer)) Then + If i Then + ShowValid hfc, hfr + Else + ShowValid cc, 9 - rr + End If + Cursor cc, rr, i + 'debug$ = Str$(cc) + Str$(rr) + Str$(mx) + Str$(my) + End If + + smx = mx + smy = my + KeyScan + If asci = 27 Then GoTo redo ' pressed Esc + If (human = false) Or (abort = 2) Or redoflag Or onplayback Or takebackflag Then Exit Sub + If Len(i$) Then GoTo ik + + If (mx <> smx) Or (my <> smy) Then + x = (mx - tlx + hxq - 1) / xq + y = (my - tly + hyq - 1) / yq + If (x < 1) Or (x > 8) Or (y < 1) Or (y > 8) Then + onboard = false + pc = false + GoTo redo + Else + onboard = true + pc = true + cc = x + rr = y + If invert Or usd Then + cc = 9 - cc + rr = 9 - rr + End If + dx = mx + dy = my + If (mx <> smx) Or (my <> smy) Then cursoron = ExtendedTimer + 2 + End If + End If + + If b1 Or b2 Then ' button pressed + b1 = false + b2 = false + If onboard = false Then + PlaySound illegal + GoTo redo + End If + asci = 13 ' simulate pressing Enter + ClearBuffers + _Delay .2 ' cuts down problem of 2 mouse clicks + Else + _Continue + End If + + ik: + onboard = true + If asci = 13 Then ' Enter + i$ = "": asci = 0 + z = b2(cc, 9 - rr) ' what piece is at this square + If i = 0 Then + If (WorB = -(z > 6)) And (z > false) Then + mp = z + b2(cc, 9 - rr) = false + hfc = cc + hfr = 9 - rr + Exit Do + End If + Else + If ((cc = hfc) And (rr = (9 - hfr))) = false And ((z = false) Or (WorB <> -(z > 6))) Then + b2(cc, 9 - rr) = mp + htc = cc + htr = 9 - rr + Exit Do + End If + End If + End If + + If li = 2 Then ' possibly arrow keys + cd = (asci = 75) - (asci = 77) ' left right + rd = (asci = 72) - (asci = 80) ' up down + If invert Then cd = -cd: rd = -rd + If cd Or rd Then + cc = cc + cd ' left right + rr = rr + rd ' up down + If cc < 1 Then cc = 1 + If cc > 8 Then cc = 8 + If rr < 1 Then rr = 1 + If rr > 8 Then rr = 8 + pc = true + + If invert Then + dx = tlx + (9 - cc) * xq - hxq + dy = tly + (9 - rr) * yq - hyq + Else + dx = tlx + cc * xq - hxq + dy = tly + rr * yq - hyq + End If + cursoron = ExtendedTimer + 2 + End If + End If + Loop + Next i +End Sub + +Sub ID_or_ChangePiece (tc As _Byte, tr As _Byte) ' various pictures for pieces (change: cursor on piece, spacebar) + Dim As _Byte i, tp + Dim z$, z2$, zc, what$ + + tp = b(tc, 9 - tr) ' temporary piece = from board + + If asci = 32 Then ' spacebar, change piece + zeropiece: + piecefn(tp) = piecefn(tp) + 1 + f$ = datapath$ + "sfunny" + slash + piecef$(tp) + LTrim$(Str$(piecefn(tp))) + ".jpg" + If _FileExists(f$) Then + If pix(0, tp) < -1 Then _FreeImage pix(0, tp) + pix(0, tp) = _LoadImage(f$) + If pix(0, tp) = -1 Then QuitWithError "Image file", z$ ' corrupt file? + BrightnessAdjust 0, tp + lpoints = -1 + Else ' non-existent, loop back and start over + piecefn(tp) = 0 + GoTo zeropiece + End If + Else ' not spacebar, just identify piece + If tp = 0 Then + TempMess$ = " " + Else + zc = Sgn(tp And 8) + z$ = "(" + Mid$("blackwhite", zc * 5 + 1, 5) + what$ = z$ + " " + LCase$(piecef$(tp)) + ")" + z2$ = LCase$(piecef$(tp) + LTrim$(Str$(piecefn(tp))) + ".jpg") + TempMess$ = what$ + For i = 1 To captions + z$ = LCase$(FunnyPix$(i) + ".jpg") + If InStr(z2$, z$) Then + If Len(caption$(i)) < 25 Then + TempMess$ = caption$(i) + " " + what$ + Else + TempMess$ = caption$(i) + End If + End If + Next i + End If + End If +End Sub + +Sub InitSystem + Dim i, c, r, p, t, m, d, c$, p$, t$, udlr$, title$ + + pregame = true ' suppress clock during color selection + + Do Until _ScreenExists: Loop + _ScreenMove _Middle + t$ = "Loading..." + Locate 12, 40 - Len(t$) \ 2 + Print t$ + + 'loadsetsinbackground = true ' good idea? maybe... + + m(0) = _Mem(b(0, 0)): m(10) = _Mem(b2(0, 0)) ' working board, display board + m(1) = _Mem(s1(0, 0)): m(2) = _Mem(s2(0, 0)): m(3) = _Mem(s3(0, 0)): m(4) = _Mem(s4(0, 0)) ' saving states for recursion + m(5) = _Mem(s5(0, 0)): m(6) = _Mem(s6(0, 0)): m(7) = _Mem(s7(0, 0)): m(8) = _Mem(s8(0, 0)) + + dev = Abs(_FileExists("rick.txt")) ' easy way to detect myself + + t$ = LCase$(Command$) + Space$(20) + + If InStr(t$, "wonka") Then dev = false + If InStr(t$, "dev") Then dev = true + If (dev = true) Or (InStr(t$, "nim") > 0) Then no_intro_music = true + If InStr(t$, "xmas") Then xmas = true + + If InStr(t$, "server") Then match = 1 + If InStr(t$, "client") Then match = 2 + If InStr(t$, "match") Then cmatch = true + + If InStr(_OS$, "64") Then + title$ = " Dodo Zero x64" + Else + title$ = " Dodo Zero x32" + End If + + If match = 2 Then title$ = title$ + " Client" + If match = 1 Then + title$ = title$ + " Server" + If InStr(t$, "server2") Then Shell _DontWait "chess client" + End If + _Title title$ + + masterlevel = Val(t$) ' 2 fast but stupid, 4 default, 6 too slow + + t$ = LTrim$(Str$(masterlevel)) + If InStr("023456", t$) = 0 Then + Print "Invalid parameters" + Sleep + System + End If + If masterlevel < 2 Then masterlevel = 4 + masterm1 = masterlevel - 1 + + InitPath + ConfigRead + + If _FileExists("rick.txt") Then ' for long term averaging of moves per second + rickfile = FreeFile + If _FileExists("mps.txt") Then + Open "mps.txt" For Append As #rickfile + Else + Open "mps.txt" For Output As #rickfile + End If + End If + + If rickfile Then bgmax = 6 Else bgmax = 4 ' extra Cheetos & Fruit Loops backgrounds for me + + If Len(NameEntered$) Then + ComputerName$ = NameEntered$ + Else + t = FreeFile + Shell _Hide "CMD /c hostname > temp.dat" + If _FileExists("temp.dat") Then + Open "temp.dat" For Input As #t + If Not (EOF(t)) Then Input #t, t$ + Close #t + End If + For i = 1 To Len(t$) + c$ = Mid$(t$, i, 1) + If LCase$(c$) = UCase$(c$) Then + Exit For + Else + If i = 1 Then c$ = UCase$(c$) + ComputerName$ = ComputerName$ + c$ + End If + Next i + If Len(ComputerName$) > 25 Then ComputerName$ = Left$(ComputerName$, 25) + + ' I get tired of typing in my name. + If ComputerName$ = "DESKTOP" Then ComputerName$ = "Frost" + If ComputerName$ = "WinXPIE" Then ComputerName$ = "Frost" + End If + + Randomize Timer ' seed generator + + cursoron = false + 'draw$ = Chr$(171) + "-" + Chr$(171) ' symbol for 1/2 + draw$ = "draw" ' simpler/nicer? + Enter$ = Chr$(13) ' to order a pizza + Esc$ = Chr$(27) ' to quit program + FENmax = 1000 ' canned responses + human = 1 ' assume human playing white + iflag = true ' automatic board reversal if 2 human players selected + mloop = 8 ' loop speed while waiting for input (no performance effect) + plasmaint = 1 ' plasma intensity. ` to change + q$ = Chr$(34) ' quote + s$ = Chr$(255) ' invisible space + + m = Val(Left$(Date$, 2)) ' month + d = Val(Mid$(Date$, 4, 2)) ' day + If (dev = 0) And (m = 12) And (d > 24) Then xmas = true ' Christmas, do something nutty with colors (red & green) + + screensaver = _FileExists("auto.") Or InStr(Command$, "/") ' yeah, slash anything or nothing, because I can never remember + + yq = 56 ' size of squares, a compromise to fit most resolutions + xq = 46 + + hxq = xq \ 2 + hyq = yq \ 2 + + For i = 1 To 8 ' lookup tables improve speed + alphal$(i) = Mid$(alphaz$, i, 1) + alphap$(i) = Mid$("RNBQKPxx", i, 1) + Next i + + Restore Legal ' value of pieces and how they move + For i = 1 To 6 + ' RNBQKP + value(i) = Val(Mid$("533901", i, 1)) * mult ' point value for captures + If i = Bishop Then value(i) = value(i) + 4 ' make bishop worth a bit more than knight + If i = King Then value(i) = 777 + value(i + 8) = value(i) ' copy for white pieces + + Read p$ ' piece, not saved + For t = 0 To 7 ' 8 each + Read udlr$ + du(i, t) = Val(Mid$(udlr$, 1, 1)) ' direction up + dd(i, t) = Val(Mid$(udlr$, 2, 1)) ' direction down + dl(i, t) = Val(Mid$(udlr$, 3, 1)) ' direction left + dr(i, t) = Val(Mid$(udlr$, 4, 1)) ' direction right + Next t + Next i + + Restore KingSquares ' when favoring moving King towards center + For r = 1 To 8 ' row + For c = 1 To 8 ' column + Read ksv(c, r) ' King square value + Next c + Next r + + Restore captions ' blurb identifying each funny pix + i = 0 + Do + i = i + 1 + Read FunnyPix$(i), caption$(i) + Loop Until caption$(i) = "end" + captions = i - 1 + + Cls + ScreenInit + $If WIN Then + _Icon + $End If + t$ = "Loading..." + Color _RGB32(255, 0, 0) + _PrintString (_Width \ 2 - _PrintWidth(t$) \ 2, 250), t$ + _Display + _AllowFullScreen , _Smooth + ColorSet + LoadFont ' liberati.ttf + LoadPieces piece_style ' starting set + + t$ = LCase$(Command$ + " ") ' T is for turtle + p = InStr(t$, "s") ' override settings with this scheme + If p Then + i = Val(Mid$(t$, p + 1, 2)) - 1 + If (i >= 0) And (i < 12) Then scheme = i: SetScheme + End If + + _MouseShow RTrim$(Mid$("LINK CROSSHAIRTEXT DEFAULT ", cursortype * 9 + 1, 9)) + + xc = _Width \ 2 - 20 ' x center + yc = 258 ' y center + tlx = xc - 4 * xq: tly = yc - 4 * yq ' top left x, top left y + trx = xc + 4 * xq: try = yc - 4 * yq ' top right x, top right y + blx = xc - 4 * xq: bly = yc + 4 * yq ' bottom left x, bottom left y + brx = xc + 4 * xq: bry = yc + 4 * yq ' bottom right x, bottom right y + + alfred = _LoadImage(datapath$ + "alfred.jpg") ' Alfred E. Neuman + 'explosion = _LoadImage(datapath$ + "exp2.png") ' takes 2 seconds to load + + ca1(1, 1) = 2: ca1(1, 2) = 3: ca1(1, 3) = 4: ca1(1, 4) = 5 ' castling + ca1(2, 1) = 4: ca1(2, 2) = 5: ca1(2, 3) = 6: ca1(2, 4) = 7: ca1(2, 5) = 8 + ca2(1, 1) = 2: ca2(1, 2) = 3: ca2(1, 3) = 4 + ca2(2, 1) = 6: ca2(2, 2) = 7 + + ScreenInit + + For i = 0 To 9 ' piece size adjustments + ' 1 2 3 4 5 6 7 8 9 0 + psa(i, 0) = Val(Mid$(" 1 3 1-1 010 0 1 1 3", i * 2 + 1, 2)) + psa(i, 1) = Val(Mid$(" 1 2 3 3 012 6 5 5 5", i * 2 + 1, 2)) + Next i + + Legal: ' moves defined + ' udlr,udlr,udlr,udlr,udlr,udlr,udlr,udlr + Data R,1000,0001,0100,0010,0000,0000,0000,0000 + Data N,2010,2001,1002,0102,0201,0210,0120,1020 + Data B,1001,0101,0110,1010,0000,0000,0000,0000 + Data Q,1000,1001,0001,0101,0100,0110,0010,1010 + Data K,1000,1001,0001,0101,0100,0110,0010,1010 + Data P,1000,1001,1010,0000,0000,0000,0000,0000 + + KingSquares: + Data 1,2,3,4,4,3,2,1 + Data 2,5,6,7,7,6,5,2 + Data 3,6,8,8,8,8,6,3 + Data 4,7,8,9,9,8,7,4 + Data 4,7,8,9,9,8,7,4 + Data 3,6,8,8,8,8,6,3 + Data 2,5,6,7,7,6,5,2 + Data 1,2,3,4,4,3,2,1 + + captions: + Data bishop1,"Bishop from Aliens" + Data bishop2,"Orson Welles" + Data bishop3,"Pope Zelensky" + Data bishop4,"Chuck Norris" + + Data king1,"Donald Trump" + Data king2,"It's good to be the King! - Mel Brooks" + Data king3,"Henry VIII" + Data king4,"Napoleon" + Data king5,"Napoleon" + Data king6,"Napoleon" + Data king7,"Frenchie" + Data king8,"Chuck Norris" + Data king9,"Louis XVI" + Data king10,"Blue King" + Data king13,"Stephen King" + Data king18,"Emperor Palpatine" + Data king19,"Emperor Palpatine" + Data king20,"Emperor Palpatine" + Data king21,"Darth Vader" + Data king22,"Darth Vader" + Data king23,"Darth Vader" + Data king24,"Jabba the Hutt" + Data king25,"Eric Cartman" + Data king26,"Sean Connery" + Data king27,"random geek" + Data king28,"Dictator Trump" + Data king29,"Bobby Fischer (R.I.P.)" + Data king30,"Bobby Fischer (R.I.P.)" + Data king31,"Garry Kasparov" + Data king33,"$DEBUG is your friend!" + + Data knight1,"Monty Python Black Knight" + Data knight2,"Roger Moore/Simon Templar" + Data knight3,"Sean Connery" + Data knight12,"Monty Python Black Knight" + Data knight13,"Monty Python Black Knight" + Data knight14,"Luke Skywalker" + Data knight15,"Luke Skywalker" + Data knight16,"Luke Skywalker" + Data knight17,"Luke Skywalker" + Data knight19,"Han Solo" + Data knight20,"Inigo Montoya" + Data knight21,"Jaws" + Data knight23,"Don't worry - got API!" + + Data pawn1,"Star Trek red t-shirt guy" + Data pawn2,"shrimp" + Data pawn3,"Rick Moranis" + Data pawn4,"Gomer Pyle" + Data pawn5,"Gomer Pyle" + Data pawn6,"I'm a SOMEBODY! -Steve Martin" + Data pawn7,"Homer Simpson" + Data pawn8,"Adam Sandler" + Data pawn11,"Pigpen (Peanuts)" + Data pawn14,"Charlie Brown" + Data pawn15,"Lee Harvey Oswald" + Data pawn16,"Lee Harvey Oswald" + Data pawn18,"Kenny from South Park" + Data pawn19,"Kenny from South Park" + Data pawn20,"Kenny from South Park" + + Data queen1,"Queen Elizabeth II" + Data queen3,"Anjelica Huston/Addams Family" + Data queen4,"Evil Queen from Snow White" + Data queen5,"Cate Blanchett" + Data queen6,"Cleopatra" + Data queen7,"Cleopatra" + Data queen8,"Queen Elizabeth I" + Data queen9,"Queen Elizabeth I" + Data queen10,"Queen Elizabeth II" + Data queen11,"Queen Victoria" + Data queen13,"Anya Taylor-Joy" + Data queen14,"Anya Taylor-Joy" + Data queen15,"Anya Taylor-Joy" + Data queen16,"Anya Taylor-Joy" + Data queen17,"Ayn Rand" + Data queen18,"Lucy van Pelt" + Data queen19,"Princess Leia" + Data queen20,"Princess Bride" + Data queen21,"Judit Polgar" + Data queen23,"Genevieve Bujold" + Data queen24,"CIA spy" + + Data rook1,"Spongebob Squarepants" + Data rook2,"Disneyland" + Data rook3,"Galata Tower" + Data rook4,"Galata Tower" + Data end,end +End Sub + +Sub InitPath + Dim cwd$ + + cwd$ = _CWD$ ' current working directory + If Right$(cwd$, 1) = slash Then cwd$ = Left$(cwd$, Len(cwd$) - 1) ' root (maybe USB stick?), take off slash + datapath$ = cwd$ + slash + "chessdat" + slash ' being Linux friendly + gamepath$ = datapath$ + "games" + slash$ + ConfigFile$ = datapath$ + "chess.dat" +End Sub + +Sub InitGame + Dim x1, x2, y1, y2, q, z, zz, t$, ti$, cat As Double + + pregame = true ' suppress clock during color selection + WorB = 1 ' white or black + SetupBoard + TempMess$ = " " + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' working to display + + If human = 0 Then GoTo isauto + If (match = 1) Or (match = 2) Then + human = 1 + humanc = -(match = 1) + GoTo isauto + End If + + If minactive Then ToFrom 0, "ng", match ' signal Minimax new game + If match = 3 Then match = false + + lct$ = "" + barebones = false + onplayback = false + cat = ExtendedTimer + 300 ' not a dog (scheme change at) + + keypressedat = ExtendedTimer ' to detect inactivity, load a set + mousemovedat = ExtendedTimer + + Do: _Limit mloop ' main menu + + If rickfile And (ExtendedTimer > cat) Then ' others probably wouldn't like this + scheme = (scheme + 1) Mod 12 ' scheme=color,set,background,clock type + SetScheme + cat = ExtendedTimer + 5 ' change at + End If + + PlotScreen false ' plot but do not display + + If cmatch = false Then ' not playing Minimax, do the menu + zz = xq * 3 + 4 + x1 = xc - zz + y1 = yc - 50 + x2 = xc + zz + y2 = yc + 50 + Line (x1, y1 + 20)-(x2 + 2, y2 - 20), _RGBA(1, 1, 1, 200), BF + For q = 2 To 18 Step 4 ' overlapping rectangles + For z = 0 To 1 + Line (x1 - q + z, y1 + q + z)-(x2 + q + z, y2 - q + z), black, B + Next z + Next q + End If + + If makenoise And (soundloaded = false) Then + If no_intro_music = false Then + Center 16, "Loading sound...", false, true + DisplayMaster true + End If + LoadSounds + cat = ExtendedTimer + 10 + NoChangeUntil = ExtendedTimer + 2 + _Continue + End If + + If makenoise And (no_intro_music = false) Then + PlaySound intro + Color red, zip + t$ = " Music: Anomaly by Carl Finlay " + SetFont 12 + If sfile(1) Then ShadowPrint xc - _PrintWidth(t$) \ 2, _Height - 30, t$, red + End If + + If cmatch = false Then Center 16, " White Black Humans Computer ", true, true + + i$ = InKey$ ' speak to me, human + If (i$ = "q") Or (i$ = Esc$) Then Quit + If (i$ = Enter$) Or (Len(i$) = 0) Then ' Enter same as mouse click + MouseIn + If Len(istuff$) Then + i$ = LCase$(istuff$) + istuff$ = "" + End If + End If + If (human = 0) Or screensaver Then i$ = "c" ' in autoplay or there's a / in COMMAND$ + ti$ = i$ + If i$ = "" Then i$ = " " ' instr doesn't handle nulls + p = InStr("bwhc", LCase$(i$)) + + 'If (p = 0) And (Len(ti$) > 0) Then cat = ExtendedTimer - 1 + + If (i$ = "m") Or cmatch Then + match = 3 + If minty Then + If _FileExists("minimax") = 0 Then QuitWithError "minimax", "does not exist" + Else + If _FileExists("minimax.exe") = 0 Then QuitWithError "minimax.exe", "does not exist" + End If + If minactive = false Then + If fullscreenflag Then + fullscreenflag = false + ScreenInit + End If + zz = _DesktopWidth - _Width - 20 + _ScreenMove zz, 50 + minactive = true + If minty Then + Shell _DontWait "./minimax" + Str$(p) + Else + Shell _DontWait "minimax" + Str$(p) + End If + _Delay 2 + End If + PlayerName$(0) = "Minimax" + PlayerName$(1) = "Dodo Zero" + p = 1 + Exit Do + End If + KeepAlive + Loop Until p + + keypressedat = ExtendedTimer + mousemovedat = ExtendedTimer + + 'ColorSet + + If minactive And (match = false) Then + ToFrom 0, "en", match ' signal Minimax to terminate + PlayerName$(0) = "" + PlayerName$(1) = "" + lasth = -1 + lastc = -1 + minactive = false + End If + + invert = 0 + Select Case p + Case 1: human = 1: humanc = 0: invert = true ' player is black + Case 2: human = 1: humanc = 1 ' player is white + Case 3: human = 2 ' human vs. human + Case 4 ' computer vs. computer, just watch + human = 0 + humanc = 1 ' white still goes first + invert = -(Rnd < .5) ' random board orientation + End Select + If match = 3 Then invert = false + If match = false Then + lct$ = "" + PlotScreen false + NameAssign + ClearBuffers + End If + + isauto: + 'ColorSet + If match Then backok = false Else backok = true + + castle$ = "****" ' flags QKQK (B then W) + epsq$ = "-" ' for FENmake + FENpcount = 0 + giveup = false + hinit = false ' human initialize, putting the cursor at e2 + logfile$ = "" ' so WriteLog will create a new one + logfiled$ = "" + lpoints = -1 + markerfc = 0 ' no last move + mps = 0 ' moves per second + noresign = false + ocount = 0 + oply = -1 ' old ply, controls replot of pieces taken + perpetual = 0 + pf$ = "" ' playback file + Erase points + pregame = false ' clock suppresion during color selection + readonly = false ' activated on playback to prevent duplicate logs + shia = 0 + smoves0 = 0 + tcount = 0 ' total move computed count + + Erase Moves, mcount, lmove, mlog$ + If _SndLen(sfile(1)) Then _SndStop sfile(1) + WorB = 0 + FENread + FENmake + TakeBackPush + WorB = 1 ' white=1, black=0 + ShowTaken false + lct$ = "" + + If cmode = 0 Then + start = ExtendedTimer + Erase etime + End If + +End Sub + +Sub KeepAlive ' Dodo/Minimax interface timeout prevention + Static katime! ' keep alive + If minactive And ((katime! = 0) Or (Timer > katime!)) Then + ToFrom 0, "*", match + katime! = Timer + 1 + End If +End Sub + +Sub KeyScan + Dim As _Byte i, ud, h, m, s, wasbri + Dim k, tscreen, t$ + + 'TimeTrack "KeyScan", 1 + + If insettings = false Then RainbowButton + MouseIn ' may put something in istuff$ + + asci = 0 ' ASCII value of inkey + li = 0 ' length of inkey + + If istuff$ = "help" Then Help: istuff$ = "" ' special case + + If Len(istuff$) Then ' MouseIn simulating a key + i$ = istuff$ + asci = Asc(Right$(i$, 1)) + li = 1 + istuff$ = "" + GoTo stuffed + End If + + ' a feature I find handy, but most would detest - fullscreen toggle with right shift + If (dev = true) And (_KeyDown(100303) = -1) Then + fullscreenflag = Sgn(fullscreenflag) Xor 1 + ScreenInit + GoTo kend + End If + + i$ = InKey$ + stuffed: ' MouseIn may simulate a key + li = Len(i$) + If li Then + nbox = false + oply = false + asci = Asc(Right$(i$, 1)) + cursoron = ExtendedTimer + 2 + lct$ = "" + keypressedat = ExtendedTimer + Else + asci = false + GoTo kend + End If + + If inhelp Then GoTo kend + If ingetfile Then GoTo fkeys + If insetup And (InStr("fsqre" + Esc$, i$) = 0) Then GoTo try2 + + If (_KeyDown(100303) Or _KeyDown(100304)) And (asci = 13) And onplayback Then ' shift-Enter, jump 10 moves in playback + sfast = fast ' piece slide speed + fast = 0 + Enter10 = 20 ' 20 plys = 10 moves + GoTo kend + End If + + If li = 1 Then ' ordinary keypress + + If promoting And (InStr("rnbq", i$) > 0) Then GoTo kend + + If i$ = "t" Then i$ = "c" ' t or c for clock/time + + k = InStr("GTv#M)/\Dq-+=jJ|", i$) ' special features + If (dev = 0) And (k > 0) Then + TempMess$ = "Dev feature" + If makenoise Then + PlaySound illegal + Else ' sound off, so bink screen instead + tscreen = _CopyImage(0) + For i = 0 To 4 + If i Mod 2 Then + Cls , red + Else + _PutImage , tscreen, 0 + End If + DisplayMaster true + _Delay .1 + Next i + _PutImage , tscreen, 0 + _FreeImage tscreen + End If + GoTo kend + End If + + If i$ = "?" Then AddSymbol "?" ' mark move questionable + If i$ = "!" Then AddSymbol "!" ' mark move wow + + If i$ = "/" Then ' play position from testing.txt + legend = true + markers = true + testing = testing Xor 1 + TempMess$ = "Testing " + OnOff$(testing) + SetupBoard + i$ = "|" + End If + + Select Case i$ + Case " " ' space, the final frontier + If rflag Then ' early move requested + msg$ = "abort" + abort = true + TempMess$ = "Abort" + 'TimeTrack "KeyScan", 0 + GoTo kend + End If + Case "`" + If (mx > midway) Or (my < (_Height - 20)) Then + scheme = (scheme + 1) Mod 12 + Else + scheme = scheme - 1 + If scheme < 0 Then scheme = 11 + End If + SetScheme + ClearTemp + TempMess$ = "Style" + Str$(scheme + 1) + " of 12" + Case "=" ' 30/60 minute countdown timer for me (laundry wash/dry!) + If rickfile = 0 Then GoTo kend + If cmode = 0 Then + PlayerNamePush + PlayerName$(1) = "Current" + PlayerName$(0) = "Countdown" + End If + cmode = (cmode + 1) Mod 3 + If cmode = 0 Then PlayerNamePop + t$ = Time$ + Do: _Limit 100 + Loop Until t$ <> Time$ + h = Val(Mid$(Time$, 1, 2)) + m = Val(Mid$(Time$, 4, 2)) + s = Val(Mid$(Time$, 7, 2)) + etime(0, 1) = h * 3600 + m * 60 + s + start = ExtendedTimer + Select Case cmode + Case 0 + Erase etime + start = ExtendedTimer + Case 1 + etime(0, 0) = 1800 ' 30 minutes + Case 2 + etime(0, 0) = 3600 ' 60 minutes + End Select + Case "<" ' master _LIMIT (doesn't seem to make much differnece) + mloop = mloop - 1 - (mloop = 1) + TempMess$ = "Speed" + Str$(mloop) + Case ">" + mloop = mloop + 1 + (mloop = 500) + TempMess$ = "Speed" + Str$(mloop) + Case "+" ' change piece size (not saved between sessions) + psize = psize - 1 + TempMess$ = "Piece size" + Str$(psize) + Case "-" ' change piece size (not saved between sessions) + psize = psize + 1 + TempMess$ = "Piece size" + Str$(psize) + Case "0" ' plasma toggle + plasmaint = (plasmaint + 1) Mod 2 + TempMess$ = "Plasma " + OnOff$(plasmaint) + Case "\" ' show scores on board + sob = (sob + 1) Mod 3 + If sob = 0 Then TempMess$ = "Debug mode OFF" + If sob = 1 Then TempMess$ = "Debug with pause" + If sob = 2 Then TempMess$ = "Debug with delay" + graphics = Sgn(sob) Xor 1 + WorB = 1 + SaveWorB = 1 + PlotScreen true + Case "|" ' better setup for seeing onboard scores or diagnostics + altbg = 4 ' no background (black) + bgc = 5 ' white bg + bri = 1 ' lowest brightness + colori1 = 14 ' light gray + colori2 = 15 ' dark gray + colori3 = 4 ' white clock + fast = false ' sliding quick + graphics = false ' kill plasma + legend = 0 + markers = 0 ' markers off + redoflag = true + squaretrim = 0 ' no trim + ColorSet + PlotScreen true + Case "1" ' white square color + colori1 = (colori1 + 1) Mod 22 + ColorSet + Case "2" ' black square color + colori2 = (colori2 + 1) Mod 22 + ColorSet + Case "3" ' clock color: red, green, yellow, blue, white + colori3 = (colori3 + 1) Mod 6 + ColorSet + Case "4" '' background color + bgc = (bgc + 1) Mod 6 + ColorSet + Case "5" '' background type + altbg = (altbg + 1) Mod (bgmax + 1) + ColorSet + Case "~" ' what info to show at right + showright = (showright + 1) Mod 3 + dosmallboard = -(showright = 1) + showthinkingf = (showright = 2) + Case "a" ' switch to/from automatic (computer playing itself) + If human = false Then + human = true + humanc = WorB + Else + human = false + End If + TempMess$ = "Automatic " + OnOff$(human Xor 1) + Case "b" ' back (take back move) + If (human > 0) And (onplayback = 0) And (getwbflag = 0) And (endgame = false) Then + If backok Then + If (WorB = 1) And (move > 0) Then takebackflag = true + If (WorB = 0) And (move > 1) Then takebackflag = true + Else + TempMess$ = "Takeback is off" + End If + End If + Case "B" ' style of trim around squares + If piece_style Then ' exclude funny set (0) + squaretrim = (squaretrim + 1) Mod 4 + TempMess$ = CHRN$(squaretrim + 1) + " of 4" + Else + TempMess$ = "Not this set" + End If + Case "c" ' c for clock, 0 font, 1 7-segment, 2 Nixie + clocktype = (clocktype + 1) Mod 3 + If clocktype = 2 Then TempMess$ = "NIXIE TUBES!" + _Delay .2 + ClearBuffers + Case "C" ' cursor + cursortype = (cursortype + 1) Mod 4 + _MouseShow RTrim$(Mid$("LINK CROSSHAIRTEXT DEFAULT ", cursortype * 9 + 1, 9)) + _MouseMove 1, 1 + _MouseMove mx, my + 'Case "D" ' Dolly Parton (deeper for top 2 or 3 moves) + ' deep = (deep + 1) Mod 3 + ' TempMess$ = "Depth" + Str$(deep) + Case "e" ' current elapsed time + smallclock = smallclock Xor 1 + Case "f" ' piece slide 0off 1slow 2fast + If endgame = false Then + fast = (fast + 1) Mod 3 + If rotate <> 0 Then TempMess$ = "Slide " + Mid$("OFF SLOWFAST", fast * 4 + 1, 4) + End If + Case "F" ' play previous game (chNNNNNN.alg) + If (rflag = false) And (endgame = false) Then PlayFile + Case "g" ' restart plasma + plasma_init = false + Case "G" ' temperature/load/MPS graph scaling + gscale = gscale Xor 1 + TempMess$ = "Scale MPS " + Mid$("currenttop ", gscale * 7 + 1, 7) + Case "h" ' display some shortcuts + TempMess$ = "F2 Set- F3 Set+ F4 Bri- F5 Bri+" + Case "H" ' easier way to move pieces + hover = hover Xor 1 + TempMess$ = "Hover " + OnOff$(hover) + Case "i" ' flip board around + If insetup Then Exit Sub + If human = 2 Then ' 2 players, disable autoflip + 'iflag = iflag Xor 1 + 'TempMess$ = "Auto flip " + OnOff$(iflag) + Else + If onplayback = 0 Then + invert = invert Xor 1 + PlotScreen true + End If + End If + Case "I" ' identify players (correct typos!) + NameAssign + Case "j" ' examine stored FEN/reply + FENshow + Case "J" ' add FEN string & reply to repository + If Len(FENreplyold$) Then + FENcount = FENcount + 1 + (FENcount = 1000) + FEN$(FENcount) = FENold$ + FENreply$(FENcount) = UCase$(FENreplyold$) + FENwrite + End If + t$ = datapath$ + " fen.dat" + Shell _DontWait editcmd$ + t$ + Case "k" ' superspeed toggle (no showtaken, clock, info) + barebones = barebones Xor 1 + ocount = 0 + Buttons 0, 0 + Case "l" ' legend toggle: a-h at bottom, 1-8 along left + If onplayback Or insetup Then Exit Sub + legend = legend Xor 1 + PlotScreen true + Case "m" ' markers, little boxes indicating last move + markers = markers Xor 1 + TempMess$ = "Markers " + OnOff$(markers) + Case "M" ' magnify whatever's at mouse position + showmousepos = showmousepos Xor 1 + 'If showmousepos = 0 Then debug$ = "" + Case "n" ' noise toggle + If (endgame + onplayback + ingetfile) = 0 Then + makenoise = makenoise Xor 1 + LoadSounds + TempMess$ = "Sound " + OnOff$(makenoise) + End If + If (makenoise = 0) And (_SndLen(sfile(1)) > 0) Then _SndStop sfile(1) + Case "N" ' algebraic/descriptive toggle + descriptive = descriptive Xor 1 + Case "p" ' pause (stops clocks) + Pause + Case "P" + autopause = autopause Xor 1 + TempMess$ = "Autopause " + OnOff$(autopause) + Case "q" ' off in non-Dev mode lest user accidentally quit when promoting to Queen + If ingetfile = 0 Then Quit + Case "r" ' resign + If (insetup = false) And (human <> 0) And (endgame = 0) Then abort = 2: msg$ = "Resign" + Case "R" ' development mode (R for Richard) + dev = dev Xor 1 + TempMess$ = "Dev mode " + OnOff$(dev) + ColorSet + Case "s" ' settings: colors, styles, sets, clocks, etc. + If insetup Then Exit Sub + If match Then + TempMess$ = "Unavailable in match" + Exit Sub + End If + If onplayback = false Then Settings + Case "S" ' change set (10 available) + piece_style = (piece_style + 1) Mod 10 + TempMess$ = LTrim$(Str$(piece_style + 1)) + " of 10" + LoadPieces piece_style + lpoints = -1 + 'Case "T" ' time track (debugging) + ' ttflag = ttflag Xor 1 + ' Erase time_used + ' tel! = 0 + Case "&" + cycle = cycle Xor 1 + TempMess$ = "Cycle info " + OnOff$(cycle) + Case Is = "v" ' some silliness, Alfred E. Neuman + If alfred < -1 Then + alfredon = alfredon Xor 1 + TempMess$ = "Alfred " + OnOff$(alfredon) + End If + Case "W" ' enable writing to a R/O playback file + readonly = false + WriteLog false + Case "x" ' play intro music + If rickfile Then Sound 7777, 1 + PlaySound intro + Case "X" ' disable move takeback + backok = false + TempMess$ = "Takeback " + OnOff$(backok) + Case "z" ' sample of all 10 piece sets + If rotate = 0 Then ShowSets + Case "Z" ' show all 112 pictures that can be used as pieces + If rotate = 0 Then ShowFunny + End Select + End If + + try2: + If human = 0 Then ' maybe switch out of automatic play + If i$ = "w" Then human = 1: humanc = 1: invert = 0: TempMess$ = "You are White" + If i$ = "b" Then human = 1: humanc = 0: invert = 1: TempMess$ = "You are Black" + If human Then screensaver = 0 + NameAssign + End If + + fkeys: + If li = 2 Then ' extended key + k = Asc(i$, 2) + If k = 59 Then Help ' F1 + + If (ingetfile = 0) And (k = 60) Or (k = 61) Then + If k = 60 Then ' F2 next set + piece_style = piece_style - 1 + If piece_style < 0 Then piece_style = 9 + End If + + If k = 61 Then ' F3 previous set + piece_style = piece_style + 1 + If piece_style > 9 Then piece_style = 0 + End If + + TempMess$ = LTrim$(Str$(piece_style + 1)) + " of 10" + AboveBoardInfo + DisplayMaster true + LoadPieces piece_style + lpoints = -1 + End If + + If (k = 62) Or (k = 63) Then + wasbri = bri + bri = bri + (k = 62) - (bri = 1) ' F4 brightness down + bri = bri - (k = 63) + (bri = 4) ' F5 brightness up + TempMess$ = "Brightness:" + Str$(bri) + " of 4" + If bri <> wasbri Then + ColorSet + Erase sloaded + allsetsloaded = false + LoadPieces piece_style + lpoints = -1 + End If + End If + + If k = 133 Then rotate = rotate - 1 - (rotate = 0) * 4 ' F11, rotate left + If k = 134 Then rotate = (rotate + 1) Mod 4 ' F12, rotate right + + ud = (k = 81) - (k = 73) ' PgUp/PgDn to up/down + If ud Then ' -1 or 1 + For i = 1 To 10 + svol(i) = Int(svol(i)) + ud ' 0.1, 1 to 10 + If svol(i) < 1 Then svol(i) = .1 ' barely audible + If svol(i) > 10 Then svol(i) = 10 + Next i + PlaySound sfile(1) ' play something to demonstrate volume change + TempMess$ = "Volume" + Str$(svol(10)) + " of 10" ' show new volume + End If + End If + + kend: + 'TimeTrack "KeyScan", 0 +End Sub + +Function Left5$ (t$) + Left5$ = Left$(t$ + Space$(5), 5) +End Function + +Function Left6$ (t$) + Left6$ = Left$(t$ + Space$(6), 6) +End Function + +Sub LoadFont ' currently only Liberati + Dim fsize, tsize, fs2, flf + + f$ = datapath$ + "fonts" + slash + "liberati.ttf" + FileCheck + Restore fontflags + For fsize = 8 To 21 + Read fs2, flf + If fs2 <> fsize Then QuitWithError "loadfont", Str$(fsize) + If flf = 0 Then _Continue + If fsize = 21 Then tsize = 32 Else tsize = fsize + myfont(tsize) = _LoadFont(f$, tsize) + If myfont(tsize) < 1 Then QuitWithError f$, Str$(tsize) + Next fsize + defaultfontsize = 12 + + fontflags: + Data 8,1 + Data 9,1 + Data 10,1 + Data 11,1 + Data 12,1 + Data 13,0 + Data 14,1 + Data 15,0 + Data 16,1 + Data 17,0 + Data 18,1 + Data 19,0 + Data 20,0 + Data 21,1 + +End Sub + +Sub LoadPieces (set As _Byte) + Dim As _Byte c, i, j, k, p + Dim x, y, tscreen, tpath$, f$, t$ + + If sloaded(set) Then Exit Sub + tscreen = _CopyImage(0) + + Select Case set + Case 0 ' funny set - Mel Brooks, Chuck Norris, etc. + For i = 1 To 12 + j = (i - 1) + (i > 6) * 6 + k = i - (i > 6) * 2 + piecef$(k) = RTrim$(Mid$("rook knightbishopqueen king pawn ", j * 6 + 1, 6)) + f$ = datapath$ + "sfunny" + slash + piecef$(k) + LTrim$(Str$(piecefn(k))) + ".jpg" + If pix(0, k) < -1 Then _FreeImage (pix(0, k)) + pix(0, k) = _LoadImage(f$) + BrightnessAdjust 0, k + Next i + Case 1 + For c = 0 To 1 + Restore PiecePatterns ' first set I used - ugly IMO + For p = 1 To 6 ' piece, RNBQKP + Cls , zip + For y = 1 To 43 ' 43 rows + Read t$ + For x = 1 To 48 + If Mid$(t$, x, 1) <> " " Then PSet (x, y + 3), cp(7 - Val(Mid$(t$, x, 1)) - c * 2) + Next x + Next y + i = p + c * 8 + If pix(1, i) < -1 Then _FreeImage (pix(1, i)) + pix(1, i) = _NewImage(48, 48, 32) + _PutImage , 0, pix(1, i), (0, 0)-(49, 49) + BrightnessAdjust set, i + Next p + Next c + Case Else ' sets I found on GitHub + tpath$ = datapath$ + "s" + CHRN$(set) + slash + For i = 1 To 12 + If i < 7 Then t$ = "_b" Else t$ = "_w" + t$ = Mid$("rnbqkprnbqkp", i, 1) + t$ + f$ = tpath$ + t$ + ".png" + j = i - (i > 6) * 2 + If pix(set, j) < -1 Then _FreeImage (pix(set, j)) + pix(set, j) = _LoadImage(f$) + If pix(set, j) >= -1 Then QuitWithError "File", f$ + BrightnessAdjust set, j + Next i + End Select + + _PutImage , tscreen, 0 + _FreeImage tscreen + 'NoChangeUntil = ExtendedTimer + 2 + sloaded(set) = true + + PiecePatterns: ' original set I used - ugly + ' 1 2 3 4 + ' 123456789012345678901234567890123456789012345678 + Data " " + Data " " + Data " " + Data " " + Data " " + Data " " + Data " " + Data " 22111122221111222211112222111122 " + Data " 22111122221111222211112222111122 " + Data " 22111122221111222211112222111122 " + Data " 22111122221111222211112222111122 " + Data " 22111122221111222211112222111122 " + Data " 22111122221111222211112222111122 " + Data " 22111122221111222211112222111122 " + Data " 22111122221111222211111222211112 " + Data " 22111122221111222211112222111122 " + Data " 22211122221111222211112222111222 " + Data " 22112221111222211112221122 " + Data " 21122221111222211112222112 " + Data " 222222222222222222222222 " + Data " 222222222222222222222222 " + Data " 221111111111111111111111111122 " + Data " 221111111111111111111111111122 " + Data " 221111122222222222222221111122 " + Data " 221122222222222222221122 " + Data " 221122222222222222221122 " + Data " 221122222222222222221122 " + Data " 221122222222222222221122 " + Data " 221122222222222222221122 " + Data " 221122222222222222221122 " + Data " 22211222222222222222211222 " + Data " 2211111111111111111111111122 " + Data " 2211111111111111111111111122 " + Data " 2211112222222222222222111122 " + Data " 222111122222222222222221111222 " + Data " 22111111111111111111111111111122 " + Data " 2221111111111111111111111111111222 " + Data " 221111222222222222222222222222111122 " + Data " 221111222222222222222222222222111122 " + Data " 221111111111111111111111111111111122 " + Data " 221111111111111111111111111111111122 " + Data " 222222222222222222222222222222222222 " + Data " 222222222222222222222222222222222222 " + + Data " " + Data " " + Data " " + Data " " + Data " " + Data " " + Data " " + Data " 2222222 " + Data " 22222222 " + Data " 222211221122 " + Data " 22222112211222 " + Data " 221111221122112222 " + Data " 22211112211221122222 " + Data " 2211221122221122111122 " + Data " 222112211222211221111222 " + Data " 22112222222211221122111122 " + Data " 22112222222211221122111122 " + Data " 22211222111112222221122111122 " + Data " 222211221111122222221122111122 " + Data " 2111122222111221122222211221122 " + Data " 22111122222112221122222211221122 " + Data " 221122222222222222112222221122111122 " + Data " 2221122222222222222112222221122111122 " + Data " 22112222222222221122111122221122111122 " + Data " 22112222222222221122111122221122111122 " + Data " 22112222111122222211221122221122111122 " + Data " 22112222111122222211221122221122111122 " + Data " 2221111222222221111221122221122111122 " + Data " 221111222222221111221122221122111122 " + Data " 2222111122111122112222221122111122 " + Data " 2222111122111122112222221122111122 " + Data " 22111122221122221122221122 " + Data " 22111122221122221122221122 " + Data " 22111122221122221122221122 " + Data " 22111122221122221122221122 " + Data " 2222222222222222222222222222 " + Data " 2222222222222222222222222222 " + Data " 22111111111111111111111111111122 " + Data " 2221111111111111111111111111111222 " + Data " 221111111111111111111111111111111122 " + Data " 221111111111111111111111111111111122 " + Data " 2222222222222222222222222222222222 " + Data " 22222222222222222222222222222222 " + + Data " " + Data " " + Data " " + Data " " + Data " " + Data " 22 " + Data " 22 " + Data " 211222 " + Data " 121122 " + Data " 1222211221 " + Data " 21122222112221 " + Data " 122211222221122221 " + Data " 11222211222221122221 " + Data " 1211222211222221122221 " + Data " 1221122221122222112221 " + Data " 1222112222112222211221 " + Data " 1222211222211222221121 " + Data " 1222221122221122221121 " + Data " 12222211222211222221 " + Data " 112222112222112221 " + Data " 211222211222211221 " + Data " 2222112222112222112222 " + Data " 222222112222112222112222 " + Data " 2211111111111111111111111122 " + Data " 2211111111111111111111111122 " + Data " 2222222222222112222222222222 " + Data " 222222222221122222222222 " + Data " 222222221122222222 " + Data " 222222221122222222 " + Data " 2211222222112222221122 " + Data " 2211222222112222221122 " + Data " 2211222222112222221122 " + Data " 221122222221122222221122 " + Data " 22112211111111111111221122 " + Data " 2211222111111111111112221122 " + Data " 221122222222221122222222221122 " + Data " 221122222222221122222222221122 " + Data " 221122222222221122222222221122 " + Data " 221122222222221122222222221122 " + Data " 221111111111111111111111111122 " + Data " 221111111111111111111111111122 " + Data " 22222222222222222222222222 " + Data " 22222222222222222222222222 " + + Data " 22 " + Data " 221122 " + Data " 221122 " + Data " 221111111122112211221111111122 " + Data " 22211111111221122112211111111222 " + Data " 2211221122221122222211112211221122 " + Data " 222112211222211222222111122112211222 " + Data " 22112211221111222211222222112211221122 " + Data " 22112211221111222211222222112211221122 " + Data " 22112222112222221122112222221122221122 " + Data " 22112222112222221122112222221122221122 " + Data " 22112222221122112222221122112222221122 " + Data " 22112222221122112222221122112222221122 " + Data " 22112222222211222222222211222222221122 " + Data " 22112222222211222222222211222222221122 " + Data " 221122222222222222222222222222221222 " + Data " 22112222222222222222222222222211222 " + Data " 222112222222222222222222222112222 " + Data " 2211222222222222222222222211222 " + Data " 221111111111111111111111111122 " + Data " 221111111111111111111111111122 " + Data " 22222222222222222222222222 " + Data " 22222222222222222222222222 " + Data " 2211111111111111111111111111111122 " + Data " 2211111111111111111111111111111122 " + Data " 22221122222222222222112222 " + Data " 22221122222222222222112222 " + Data " 2211221122222211221122 " + Data " 2211221122222211221122 " + Data " 22112222112222221122221122 " + Data " 22112222112222221122221122 " + Data " 22112222112222221122221122 " + Data " 22112222112222221122221122 " + Data " 222222222222222222222222222222 " + Data " 22222222222222222222222222222222 " + Data " 2211111111111111111111111111111122 " + Data " 222111111111111111111111111111111222 " + Data " 22211122221122221122221122221122111222 " + Data " 22211122221122221122221122221122111222 " + Data " 22211111111111111111111111111111111222 " + Data " 22211111111111111111111111111111111222 " + Data " 222222222222222222222222222222222222 " + Data " 2222222222222222222222222222222222 " + + Data " 2222 " + Data " 222211112222 " + Data " 22222111122222 " + Data " 22221122111122112222 " + Data " 2222222221111122222222 " + Data " 22211221111111111112211222 " + Data " 2211212211111111111122211222 " + Data " 22211222221122111122112222211222 " + Data " 2221122222211221111221122222211222 " + Data " 221122222222222211112222222222211222 " + Data " 22211222222222222111122222222222211222 " + Data " 2211222222222111111111111112222222221122 " + Data " 221122222222211111111111111112222222211222 " + Data " 22211222222211222222111122222211222222221122 " + Data " 2221122222221122222221111222222211222222211222 " + Data "222112222222112222222211112222222112222222211222" + Data "222122222222112222222211112222222111222222211222" + Data "221122222222112222222211112222222211222222221122" + Data "221122222222112222222211112222222211222222221122" + Data "221122222222112222222211112222222211222222221122" + Data "221122222222112222222211112222222211222222221122" + Data "221122222222111122222222222222221111222222221122" + Data "221122222222211122222222222222221112222222221122" + Data " 2221122222222111122222222222211112222222211222 " + Data " 22112222222211112222222222221111222222221122 " + Data " 22111122222221111222222222211112222222111122 " + Data " 22111122222222111122222222111122222222111122 " + Data " 222111122222222111111111111222222221111222 " + Data " 2221111222222211111111111122222221111222 " + Data " 22211111111221111111111112211111111222 " + Data " 222111111122111111111111221111111222 " + Data " 222222222222222222222222222222222222 " + Data " 222222222222222222222222222222222222 " + Data " 2211111111111111111111111111111111111122 " + Data " 2211111111111111111111111111111111111122 " + Data " 22111222222222222222222222222222222222211122 " + Data " 22111222222222222222222222222222222222211122 " + Data " 22111222222222222222222222222222222222211122 " + Data " 22111222222222222222222222222222222222211122 " + Data " 222111111111111111111111111111111111111222 " + Data " 2211111111111111111111111111111111111122 " + Data " 22222222222222222222222222222222222222 " + Data " 222222222222222222222222222222222222 " + + Data " " + Data " " + Data " " + Data " " + Data " " + Data " " + Data " " + Data " 22222222 " + Data " 2222222222 " + Data " 221111111122 " + Data " 22211111111222 " + Data " 2211222222221122 " + Data " 2211222222221122 " + Data " 2211222222221122 " + Data " 2211222222221122 " + Data " 221111111122 " + Data " 221111111122 " + Data " 2222222222222222 " + Data " 222222222222222222 " + Data " 22111111111111111122 " + Data " 22111111111111111122 " + Data " 222222222222222222 " + Data " 2222222222222222 " + Data " 221122221122 " + Data " 221122221122 " + Data " 221122221122 " + Data " 221122221122 " + Data " 221122221122 " + Data " 221122221122 " + Data " 2211222222221122 " + Data " 221122222222221122 " + Data " 22112222222222221122 " + Data " 2211222222222222221122 " + Data " 221122222222222222221122 " + Data " 221122222222222222221122 " + Data " 221122222222222222221122 " + Data " 221122222222222222221122 " + Data " 211111111111111111111112 " + Data " 211111111111111111111112 " + Data " 222222222222222222222222 " + Data " 222222222222222222222222 " + Data " " + Data " " +End Sub + +Sub LoadSounds + Dim i, g$, sf$ + + sound_data: ' desc,volume,file + Data " 1 intro ",2,"cf.mp3" + Data " 2 click1 ",2,"pegup.wav" + Data " 3 click2 ",2,"pegdown.wav" + Data " 4 mdone ",3,"blow.wav" + Data " 5 take back ",7,"airhorn.wav" + Data " 6 check ",3,"chord.wav" + Data " 7 checkmate ",3,"tada.wav" + Data " 8 stalemate ",3,"ce.wav" + Data " 9 promotion ",3,"notif.mp3" + Data "10 error ",3,"bad.wav" + Data "11 resign ",3,"ce.wav" + + If soundloaded Then Exit Sub Else soundloaded = true + + If pregame = 0 Then + TempMess$ = "Loading sound..." + AboveBoardInfo + _Display + End If + + Restore sound_data + For i = 1 To 11 ' intro music, mouse clicks, checkmate, etc. + Read g$, svol(i), sf$ ' garbage, volume, filename + If (i = 1) And (no_intro_music = true) Then sf$ = "" + If Len(sf$) Then ' null means I decided to use no sound for this item + f$ = datapath$ + "sounds" + slash$ + sf$ ' sound file, datapath$ = _CWD$ + slash + "chessdat" + slash + FileCheck + sfile(i) = _SndOpen(f$) + If sfile(i) <= 0 Then QuitWithError "Sound file", f$ + End If + Next i + 'NoChangeUntil = ExtendedTimer + 1 +End Sub + +Sub Magnify ' magnifying glass top left, fo verifying shadows (debugging) + Dim x, y, x0, x2, y2, t$ + + x0 = ((rotate = 1) Or (rotate = 3)) * -300 + For y = 0 To 40 + For x = 0 To 40 + x2 = mx + x - 20 + y2 = my + y - 20 + If (x2 > -1) And (y2 > -1) And (x2 < _Width) And (y2 < _Height) Then + c1 = Point(x2, y2) + Line (x0 + x * 4 + 1, y * 4 + 1)-Step(3, 3), c1, BF + End If + Next x + Next y + SetFont 16 + ShadowPrint x0 + 4, 4, Str$(ux) + Str$(uy) + Str$(mx) + Str$(my), white + c1 = Point(mx, my) + t$ = Str$(_Red32(c1)) + Str$(_Green32(c1)) + Str$(_Blue32(c1)) + Str$(_Alpha32(c1)) + ShadowPrint x0 + 4, 24, t$, white +End Sub + +Sub MarkerSave (fc As _Byte, fr As _Byte, tc As _Byte, tr As _Byte) + markerfc = Abs(fc) + markerfr = Abs(fr) + markertc = tc + markertr = tr +End Sub + +Sub MouseIn + Static lx, ly + Dim As _Byte i, sa, zz + Dim tx1, tx2, ty1, ty2, t$ + Dim cb As _Unsigned Long + + 'TimeTrack "MouseIn", 1 + If nbox > 50 Then QuitWithError "MouseIn", "nbox > 50" + If rickfile Then Alarms ' personal feature + + If _Resize Then + fullscreenflag = fullscreenflag Xor 1 + ScreenInit + cursoron = ExtendedTimer + 2 + lostfocus = true + End If + + If _Exit <> 0 Then Quit + + While _WindowHasFocus = 0 + _Delay .25 + lostfocus = true + 'TimeTrack "MouseIn", 0 + DisplayMaster false + Exit Sub + Wend + + If lostfocus Then + ClearBuffers + lostfocus = false + End If + + If _MouseInput Then + If (_MouseButton(1) = b1) Or (_MouseButton(2) = b2) Then + Do While _MouseInput + If _MouseButton(1) <> b1 Then Exit Do + If _MouseButton(2) <> b2 Then Exit Do + Loop + End If + b1 = _MouseButton(1) + b2 = _MouseButton(2) + ux = _MouseX + uy = _MouseY + If usd Then ux = _Width - ux: uy = _Height - uy + End If + + Select Case rotate + Case 0 + mx = ux + my = uy + Case 1 + mx = tlx + uy / _Height * (trx - tlx) + If _FullScreen Then my = 700 - ux Else my = 600 - ux / 1.33 + Case 2 + mx = _Width - ux + my = _Height - uy + Case 3 + mx = trx - uy / _Height * (trx - tlx) + If _FullScreen Then my = ux - 100 Else my = ux / 1.33 + End Select + + If click And (b1 Or b2) Then + If (ExtendedTimer - lastclick) < .2 Then b1 = 0: b2 = 0: Exit Sub + PlaySound click1 + lastclick = ExtendedTimer + End If + If pregame And i$ = Enter$ Then b1 = true + + If b1 Or b2 Or (Abs(mx - lx) > 2) Or (my <> ly) Then + mousemovedat = ExtendedTimer + End If + lx = mx + ly = my + + If fullscreenflag Then sa = 1 Else sa = 5 ' help/min/max/exit not onscreen + + For i = sa To nbox ' start at to number boxes + + If promoting And (InStr("It", mft$(i)) > 0) Then _Continue + + tx1 = mfx1(i) + tx2 = mfx2(i) + ty1 = mfy1(i) + (mfy1(i) = 247) * 24 + ty2 = mfy2(i) - (mfy1(i) = 247) * 16 + + cb = 0 + If (mx >= tx1) And (mx <= tx2) And (my >= ty1) And (my <= ty2) Then + + If mft$(i) = "k" Then + TempMess$ = "Bare bones" + ShowBolt + End If + + If promoting And (InStr("rnbq", LCase$(mft$(i))) > 0) Then Line (tx1, ty1)-(tx2, ty2), white, B + + 'If rickfile Then + ' Line (tx1, ty1)-(tx2, ty2), yellow, B + ' Color yellow + ' SetFont 12 + ' _PrintString (tx1, ty1 - 12), "*" + mft$(i) + "*" + Str$(i) + ' _Display + 'End If + + If mft$(i) = "`" Then ' style + SetFont 9 + t$ = RTrim$(Mid$("PreviousNext ", 1 - (mx > midway) * 8, 8)) + ShadowPrint midway - _PrintWidth(t$) / 2, _Height - 30, t$, white + End If + + If i < 5 Then cb = _RGB32(255, 255, 255) ' higlight help/min/resize/quit + + If (insettings = 0) And (mfy1(i) = 247) Then ' main menu + If clockc = black Then c1 = white Else c1 = clockc + Line (tx1, mfy2(i))-(tx2, mfy2(i)), c1 ' underline where mouse is + End If + + If b1 Or b2 Then ' left or right mouse button + i$ = "" + b1 = false ' reset left + b2 = false ' reset right + Select Case i + Case 1 ' play a Beatles song + Help + Case 2 ' minimize + _ScreenIcon ' invoke a movie star like Audrey Hepburn + Do + _Delay 1 + Loop Until _ScreenIcon = false + _ScreenShow + lostfocus = true + _ScreenClick _DesktopWidth \ 2, _DesktopHeight \ 2 + Case 3 ' maximize + fullscreenflag = Sgn(fullscreenflag) Xor 1 + ScreenInit + Case 4 ' local X for exit + Quit + Case Else ' some word selected + If mft$(i) = "Alg" Then oply = false: descriptive = false + If mft$(i) = "Des" Then oply = false: descriptive = true + If mft$(i) = "hup" Then ' history up + For zz = 1 To 10 + If (shia + move - 48) > 0 Then shia = shia - 1: oply = false + Next zz + End If + If mft$(i) = "hdo" Then shia = shia + 10: oply = false 'history down + If shia > 0 Then shia = 0 + istuff$ = mft$(i) + + If LCase$(Left$(istuff$, 2)) = "sp" Then ' slide speed + fast = Val(Mid$(istuff$, 3, 1)) + End If + + If LCase$(Left$(istuff$, 2)) = "sr" Then ' show on right + showright = Val(Mid$(istuff$, 3, 1)) + dosmallboard = -(showright = 1) + showthinkingf = (showright = 2) + oply = -1 + End If + + If istuff$ = "e" Then + If ingetnames Then + ElseIf onplayback Then + istuff$ = Enter$ + Else + istuff$ = Esc$ + End If + End If + + If usd Then Exit Sub + + If istuff$ = "k" Then + _Source bolt(barebones) + For ty1 = 0 To 30 + For tx1 = 0 To 30 + c1 = Point(tx1, ty1) + 'If (_Green32(c1) < 255) And (c1 <> cc(barebones)) Then ' inverts only bolt + If c1 <> cc(barebones) Then + c1 = _RGB32(255 - _Red32(c1), 255 - _Green32(c1), 255 - _Blue32(c1)) + PSet (boltx1 + tx1, bolty1 + ty1), c1 + End If + Next tx1 + Next ty1 + _Source 0 + DisplayMaster true + _Delay .2 + Exit Sub + End If + + t$ = istuff$ + " " + If (rotate = 0) And ((istuff$ = Enter$) Or (istuff$ = "`") Or (t$ <> UCase$(t$))) Then + For zz = 0 To 1 + For ty1 = mfy1(i) To mfy2(i) + For tx1 = mfx1(i) To mfx2(i) + c1 = Point(tx1, ty1) + c2 = _RGB32(255 - _Red32(c1), 255 - _Green32(c1), 255 - _Blue32(c1)) + If mft$(i) = "`" Then + If c1 <> menubg Then PSet (tx1, ty1), c2 + Else + If (c1 <> menubg) Or (Len(mft$(i)) = 1) Then PSet (tx1, ty1), c2 + End If + Next tx1 + Next ty1 + DisplayMaster true + If zz = 0 Then _Delay .2 + Next zz + End If + If istuff$ = "Graph" Then istuff$ = "G" + End Select + End If + End If + + If i < 5 Then Buttons cb, i + Next i + + DisplayMaster true + 'TimeTrack "MouseIn", 0 +End Sub + +Sub MoveIt (zfc As _Byte, zfr As _Byte, ztc As _Byte, ztr As _Byte) + Dim As _Byte pm, fc, fr, tc, tr + + fc = Abs(zfc) ' from column, negative means castle kingside + fr = Abs(zfr) ' from row, negative means castle queenside + tc = ztc + tr = ztr + pm = b(fc, fr) ' piece at board location (1-12) + p = pm And 7 ' type of piece (1-6) + + If (p = Pawn) And (b(tc, tr) = 0) And (fc <> tc) Then b(tc, fr) = 0 ' en passant + + b(fc, fr) = 0 ' blank old array spot + b(tc, tr) = pm ' move piece in array + + If zfc < 0 Then ' castle kingside + If WorB = 1 Then ' white + fc = 8: fr = 1: tc = 6: tr = 1 ' rook move + Else ' black + fc = 8: fr = 8: tc = 6: tr = 8 ' rook move + End If + b(tc, tr) = Rook + WorB * 8 ' move piece in array + b(fc, fr) = 0 ' blank old array spot + End If + + If zfr < 0 Then ' castle queenside + If WorB = 1 Then ' white + fc = 1: fr = 1: tc = 4: tr = 1 ' rook move + Else ' black + fc = 1: fr = 8: tc = 4: tr = 8 ' rook move + End If + b(tc, tr) = Rook + WorB * 8 ' move piece in array + b(fc, fr) = 0 ' blank old array spot + End If + + If (p = Pawn) And ((tr = 1) Or (tr = 8)) Then ' pawn, row 1 or 8 + If (human = 0) Or ((human = 1) And (WorB <> humanc)) Then ' computer side always promote to Queen + b(tc, tr) = Queen + WorB * 8 + End If + End If +End Sub + +Sub MoveItReal (zfc As _Byte, zfr As _Byte, ztc As _Byte, ztr As _Byte) + Dim mi, x, y + Dim As _Byte i, pm, xs, ys, npass, pass, selected, fc, fr, tc, tr, cap + + fc = Abs(zfc) ' from column, negative means castle kingside + fr = Abs(zfr) ' from row, negative means castle queenside + tc = ztc ' to column + tr = ztr ' to row + pm = b(fc, fr) ' piece at board location (1-12) + p = pm And 7 ' type of piece (1-6) + cap = b(tc, tr) ' piece being captured, if any + If cap > 0 Then ptaken = -cap: ptakent = ExtendedTimer + 12: ptcc = 0 + DescriptiveNotation 0, zfc, zfr, ztc, ztr + If (cap And 7) = King Then QuitWithError "ERROR", "King capture" + If (p = Pawn) And (b(tc, tr) = 0) And (fc <> tc) Then ' en passant + If onplayback = 0 Then PlotPiece fc, fr, tc, tr + b(fc, fr) = 0 ' clear from square + ptaken = -b(tc, fr): ptakent = ExtendedTimer + 12: ptcc = 0 + b(tc, fr) = 0 ' clear captured pawn + b(tc, tr) = Pawn + WorB * 8 ' place pawn at new location + GoTo wrapitup + End If + + npass = 1 ' normal move + cflag = 0 ' flag off + If p = King Then ' castling? + If (zfc < 0) Then npass = 2: cflag = 1 ' yes, kingside + If (zfr < 0) Then npass = 2: cflag = 2 ' yes, queenside + End If + + For pass = 1 To npass + + If cflag = -1 Then ' castle kingside + If WorB = 1 Then ' white + fc = 8: fr = 1: tc = 6: tr = 1 ' rook move + Else ' black + fc = 8: fr = 8: tc = 6: tr = 8 ' rook move + End If + End If + If cflag = -2 Then ' castle queenside + If WorB = 1 Then ' white + fc = 1: fr = 1: tc = 4: tr = 1 ' rook move + Else ' black + fc = 1: fr = 8: tc = 4: tr = 8 ' rook move + End If + End If + If pass = 2 Then pm = Rook + WorB * 8 + + If onplayback = 0 Then + If (p = Pawn) And ((tr = 1) Or (tr = 8)) Then ' pawn, row 1 or 8 + If match Or (human = 0) Or ((human = 1) And (WorB <> humanc)) Or screensaver Then ' computer side always promote to Queen + pm = Queen + WorB * 8 + promote$ = "Q" + Else ' ask human + PlaySound promotion + promoting = true + b(tc, tr) = pm ' move piece in array + b(fc, fr) = 0 ' blank old array spot + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' copy working b() to display board b2() + + Do: _Limit mloop + TempMess$ = "Choose piece" + PlotScreen false + nbox = 4 + chimp = 0 + Center 0, " promote to Q R B N ", true, false + GoSub piece_menu + KeyScan + If Len(i$) = 1 Then selected = InStr("rnbq", LCase$(i$)) + Loop Until selected > 0 + promoting = false + pm = selected + WorB * 8 + End If + promote$ = Mid$("RNBQ", pm And 7, 1) + End If + + If p = King Then Mid$(castle$, WorB * 2 + 1, 2) = "XX" ' no more castling for this side + If p = Rook Then + If WorB Then + If (fc = 1) And (fr = 1) Then Mid$(castle$, 3, 1) = "X" ' white queenside + If (fc = 8) And (fr = 1) Then Mid$(castle$, 4, 1) = "X" ' white kingside + Else + If (fc = 1) And (fr = 8) Then Mid$(castle$, 1, 1) = "X" ' black queenside + If (fc = 8) And (fr = 8) Then Mid$(castle$, 2, 1) = "X" ' black kingside + End If + End If + If (pass = 1) And ((human And (humanc = WorB)) Or (human = 2)) Then ' 2 is two humans + Else + PlotPiece fc, fr, tc, tr + End If + End If + + b(tc, tr) = pm ' move piece in array + b(fc, fr) = 0 ' blank old array spot + cflag = -cflag + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' working b() to display board b2() + Next pass + + wrapitup: + lfc = fc: lfr = fr: ltc = tc: ltr = tr ' save last move for en passant + If (cap > 0) Or (p = Pawn) Then drawcount = 0 Else drawcount = drawcount + WorB + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' working b() to display board b2() + epsq$ = "-" ' for FENmake + If (p = Pawn) And (fc <> tc) And (Abs(fr - tr) > 1) Then epsq$ = alphal$(fc) + CHRN$(fr + Sgn(tr - fr)) + FENmake + TakeBackPush ' save board & castle state + + perpetual = 0 ' check for perpetual + For mi = 1 To FENpcount - 1 + perpetual = perpetual - (FENpartial$ = FENperp$(mi)) + Next mi + Exit Sub + + piece_menu: + xs = 64: ys = xs ' size of pieces shown here + For i = 1 To 4 ' QRBN + p = Val(Mid$("4132", i, 1)) + WorB * 8 + x = xc + (i - 3) * (xs + 2) + y = bly + 30 + _PutImage (x, y)-(x + xs, y + ys), pix(piece_style, p), 0 ' show piece + nbox = nbox + 1 + mft$(nbox) = Mid$("qrbn", i, 1) + mfx1(nbox) = x ' save location so mouse can find it + mfx2(nbox) = x + xs ' + mfy1(nbox) = y ' + mfy2(nbox) = y + ys ' + Next i + Return +End Sub + +Sub MoveBishop (level As _Byte) + Dim As _Byte capture, n, square, tc, tr, tp + Dim score, startscore, tts + + 'TimeTrack "MoveBishop", 1 + + If move < 10 Then startscore = -18 * (b(fc, fr) = o(fc, fr)) ' priority to getting a piece first moved + + Do + tc = fc ' to column + tr = fr ' to row + square = 1 + Do + capture = 0 ' what piece captured + score = startscore + tc = tc - dl(Bishop, n) + dr(Bishop, n) ' column=column-left+right + If (tc < 1) Or (tc > 8) Then Exit Do ' off board + tr = tr - du(Bishop, n) + dd(Bishop, n) ' row=row-up+down + If (tr < 1) Or (tr > 8) Then Exit Do ' off board + tp = b(tc, tr) + If tp = 0 Then ' empty square + score = score - (o(tc, tr) = tp) * rto ' return to origin usually bad + ElseIf WorB = Sgn(tp And 8) Then ' beer buddies + 'protc(level) = protc(level) + value(tp) + Exit Do ' can't move to or past own piece + Else ' opponent piece, possible capture + capture = tp ' capture piece + score = value(capture) ' bishops worth a bit more than knights + 'attackc(level) = attackc(level) + score + If score = 32 Then ' pawn value according to rank + If (tr = 1) Or (tr = 8) Then + score = value(Queen) + Else + tts = (9 - tr) * WorB - tr * (WorB = 0) + score = tts * tts + End If + End If + End If + + If score <> 777 Then ' don't mess with checkmate score + + score = score - (points < -2) * (capture > 0) * 10 ' more than 2 points behind, discount trades + score = score - Sgn((fr - tr) * pawndir) * (move < 12) ' bonus for moving ahead at beginning + score = score - rto * (b(fc, fr) = o(tc, tr)) ' moving back to original square usually bad + + ' moving towards other king + 't1 = (ABS(fc - bkc) + ABS(fr - bkr)) * WorB - (ABS(fc - wkc) + ABS(fr - wkr)) * (WorB = 0) + 't2 = (ABS(tc - bkc) + ABS(tr - bkr)) * WorB - (ABS(tc - wkc) + ABS(tr - wkr)) * (WorB = 0) + 'score = score + (t1 - t2) * 2 + + End If + + AddMove level, score, fc, fr, tc, tr + + If capture Then Exit Do + square = square + 1 + Loop Until square > 7 + n = n + 1 + Loop Until n = 4 + 'TimeTrack "MoveBishop", 0 +End Sub + +Sub MoveKing (level As _Byte) + Dim As _Byte t1, t2, t3, t4, n, tc, tr, dis_to_k, dis_to_p, tp + Dim score, tts + + 'TimeTrack "MoveKing", 1 + + n = -1 + Do + score = (move < 15) * 20 + n = n + 1 + tc = fc - dl(King, n) + dr(King, n) ' column=column-left+right + If (tc < 1) Or (tc > 8) Then _Continue ' off board + tr = fr - du(King, n) + dd(King, n) ' row=row-up+down + If (tr < 1) Or (tr > 8) Then _Continue ' off board + If (WorB = 1) And (Abs(tr - bkr) < 2) And (Abs(tc - bkc) < 2) Then _Continue ' moving too close to opponent king + If (WorB = 0) And (Abs(tr - wkr) < 2) And (Abs(tc - wkc) < 2) Then _Continue ' moving too close to opponent king + tp = b(tc, tr) + If tp = 0 Then ' blank square, will be added + score = score + (move < 16) * 24 ' discourage early King moves + ElseIf WorB = Sgn(tp And 8) Then ' beer buddy + 'protc(level) = protc(level) + value(tp) + _Continue + Else ' opponent piece, possible capture + 'attackc(level) = attackc(level) + value(tp) + score = score + value(tp) ' bishops worth a bit more than knights + If value(tp) = 32 Then ' pawn value according to rank + If (tr = 1) Or (tr = 8) Then + score = value(Queen) + Else + tts = (9 - tr) * WorB - tr * (WorB = 0) + score = tts * tts ' yes, squared + End If + End If + End If + + score = score - ksv(tc, tr) * ((level = 1) And (CanMove(1) = 1)) + + If level = 0 Then + If (CanMove(0) + CanMove(1) < 4) Then + If WorB Then ' white + t1 = Abs(fc - bkc) + Abs(fr - bkr) ' (from column - King column) + (from row - King row) + t2 = Abs(tc - bkc) + Abs(tr - bkr) ' ( to column - King column) + ( to row - King row) + t3 = Abs(fc - bpc) + Abs(fr - bpr) ' - black pawn + t4 = Abs(tc - bpc) + Abs(tr - bpr) + Else ' black + t1 = Abs(fc - wkc) + Abs(fr - wkr) + t2 = Abs(tc - wkc) + Abs(tr - wkr) + t3 = Abs(fc - wpc) + Abs(fr - wpr) + t4 = Abs(tc - wpc) + Abs(tr - wpr) + End If + dis_to_k = t1 - t2 + dis_to_p = t3 - t4 + If (WorB = 0) And (wpc > 0) Then ' black with white pawn + score = score + dis_to_p * 20 + ElseIf (WorB = 1) And (bpc > 0) Then ' white with black pawn + score = score + dis_to_p * 20 + Else ' chase other king often + score = score - dis_to_k * ((CanMove(1) = 2) And (Rnd > .3)) + End If + End If + End If + + AddMove level, score, fc, fr, tc, tr + Loop Until n = 7 + 'TimeTrack "MoveKing", 0 +End Sub + +Sub MoveKnight (level As _Byte) + Dim As _Byte capture, n, tc, tr, tp, t1, t2 + Dim score, startscore, tts + + 'TimeTrack "MoveKnight", 1 + + If move < 10 Then startscore = -18 * (b(fc, fr) = o(fc, fr)) ' priority to getting a piece first moved + + n = -1 + Do + n = n + 1 + capture = 0 ' what piece captured + score = startscore + tc = fc - dl(Knight, n) + dr(Knight, n) ' column=column-left+right + If (tc < 1) Or (tc > 8) Then _Continue ' off board + tr = fr - du(Knight, n) + dd(Knight, n) ' row=row-up+down + If (tr < 1) Or (tr > 8) Then _Continue ' off board + tp = b(tc, tr) + If tp = 0 Then ' empty square + score = score - (o(tc, tr) = tp) * rto ' return to origin is likely bad + score = score + ((move < 10) And (Abs(fc - tc) = 2)) * 500 + ElseIf WorB = Sgn(tp And 8) Then ' beer buddies + 'protc(level) = protc(level) + value(tp) + _Continue ' can't move to or past own piece + Else ' opponent piece, possible capture + capture = tp ' capture piece + score = value(capture) ' bishops worth a bit more than knights + 'attackc(level) = attackc(level) + value(tp) + If score = 32 Then ' pawn value according to rank + If (tr = 1) Or (tr = 8) Then + score = value(Queen) + Else + tts = (9 - tr) * WorB - tr * (WorB = 0) + score = tts * tts + End If + End If + End If + + If score <> 777 Then ' don't mess with checkmate score + score = score - (points < -2) * (capture > 0) * 10 ' more than 2 points behind, discount trades + score = score - Sgn((fr - tr) * pawndir) * (move < 12) ' bonus for moving ahead at beginning + score = score - rto * (b(fc, fr) = o(tc, tr)) ' moving back to original square usually bad + + ' moving towards other king + t1 = (Abs(fc - bkc) + Abs(fr - bkr)) * WorB - (Abs(fc - wkc) + Abs(fr - wkr)) * (WorB = 0) + t2 = (Abs(tc - bkc) + Abs(tr - bkr)) * WorB - (Abs(tc - wkc) + Abs(tr - wkr)) * (WorB = 0) + score = score + (t1 - t2) * 4 + End If + AddMove level, score, fc, fr, tc, tr + Loop Until n = 7 + 'TimeTrack "MoveKnight", 0 +End Sub + +Sub MovePawn (level As _Byte) + Dim As _Byte t1, t2, n, op, square, trysquare, z, tc, tr, tp + Dim score, tts + + 'TimeTrack "MovePawn", 1 + + trysquare = 1 - (fr = 2) * WorB + (fr = 7) * (WorB = 0) ' regular or gambit for black + + Do + For square = 1 To trysquare ' following one path of one move + score = -16 + tc = fc - (n = 1) + (n = 2) ' column + If (tc < 1) Or (tc > 8) Then Exit For ' off board + tr = fr + pawndir * square ' row + If (tr < 1) Or (tr > 8) Then Exit For ' off board + tp = b(tc, tr) + If tp = 0 Then ' blank square + If n > 0 Then Exit For ' disallow pawn diagnonal when no capture + score = score - 14 * ((tc = 5) And (move < 4) And (Rnd > .3)) ' favor king pawn + score = score - 12 * ((tc = 4) And (move < 4) And (Rnd > .5)) ' favor queen pawn + + If (tr = 1) Or (tr = 8) Then + score = score + value(Queen) * 3 ' promotion is a good thing + Else + tts = tr * WorB - (9 - tr) * (WorB = 0) + score = score + tts * tts ' 4, 9, 16, 25, 36 + score = score - (move - 19) * (move > 20) ' encourage pushing pawns in mid or end game + End If + ElseIf WorB = Sgn(tp And 8) Then ' beer buddies + 'protc(level) = protc(level) - (n > 0) * value(tp) + Exit For ' skip checking further + Else ' opponent piece, possible capture + If n = 0 Then Exit For ' not diagonal, no capture + score = value(tp) ' bishops a bit more than knights + 'attackc(level) = attackc(level) + 1 + If score = 32 Then ' pawn value according to rank + tts = (9 - tr) * WorB - tr * (WorB = 0) + score = tts * tts + End If + If ((tr = 1) Or (tr = 8)) And (score <> 777) Then score = score + value(Queen) + End If + + AddMove level, score, fc, fr, tc, tr + Next square + trysquare = 1 ' first pass might have been 2 + n = n + 1 + Loop Until n > 2 + + If level < 2 Then ' cover en passant + 'ant(level) = ant(level) + 1 + op = 14 - WorB * 8 ' opponent pawn + t1 = 4 + WorB ' rank 4 for black, 5 for white + t2 = 2 + WorB * 5 ' rank 2 for black, 7 for white + If fr = t1 Then ' from row = + For z = -1 To 1 Step 2 ' look each side + tc = fc + z ' to column + If (tc > 0) And (tc < 9) Then ' in bounds of board + If b(tc, fr) = op Then ' opposing pawn + + If (tc = lfc) And (t2 = lfr) And (tc = ltc) And (t1 = ltr) Then + AddMove level, 17, fc, fr, tc, fr + pawndir + 'ant(level) = ant(level) + 1 + End If + End If + End If + Next z + End If + End If + 'TimeTrack "MovePawn", 0 +End Sub + +Sub MoveQueen (level As _Byte) + Dim As _Byte capture, n, square, tc, tr, tp, rp, rookc1, rookc2, rookr1, rookr2, ts, ok + Dim score, tts + + 'TimeTrack "MoveQueen", 1 + + If CanMove(WorB) > 3 Then + rp = Rook + WorB * 8 + rookc1 = 0: rookr1 = 0 + rookc2 = 0: rookr2 = 0 + For tr = 1 To 8 + For tc = 1 To 8 + If b(tc, tr) = rp Then + If Not ((tr = fr) And (tc = fc)) Then + If rookc1 = 0 Then + rookc1 = tc + rookr1 = tr + Else + rookc2 = tc + rookr2 = tr + End If + End If + End If + Next tc + Next tr + If WorB Then + If rookr1 = 1 Then rookr1 = 0: rookc1 = 0 + If rookr2 = 1 Then rookr2 = 0: rookc2 = 0 + Else + If rookr1 = 8 Then rookr1 = 0: rookc1 = 0 + If rookr2 = 8 Then rookr2 = 0: rookc2 = 0 + End If + End If + + Do + tc = fc ' to column + tr = fr ' to row + square = 1 + Do + capture = 0 ' what piece captured + score = 0 + tc = tc - dl(Queen, n) + dr(Queen, n) ' column=column-left+right + If (tc < 1) Or (tc > 8) Then Exit Do ' off board + tr = tr - du(Queen, n) + dd(Queen, n) ' row=row-up+down + If (tr < 1) Or (tr > 8) Then Exit Do ' off board + tp = b(tc, tr) + If tp = 0 Then ' empty square + ElseIf WorB = Sgn(tp And 8) Then ' beer buddies + 'protc(level) = protc(level) + value(tp) + Exit Do ' can't move to or past own piece + Else ' opponent piece, possible capture + capture = tp ' capture piece + 'attackc(level) = attackc(level) + value(tp) + score = value(capture) ' bishops worth a bit more than knights + If score = 32 Then ' pawn value according to rank + If (tr = 1) Or (tr = 8) Then + score = value(Queen) + Else + tts = (9 - tr) * WorB - tr * (WorB = 0) + score = tts * tts + End If + End If + End If + + If score <> 777 Then ' don't mess with checkmate score + + score = score - (points < -2) * (capture > 0) * 10 ' more than 2 points behind, discount trades + 'score = score - SGN((fr - tr) * pawndir) * (move < 12) ' bonus for moving ahead at beginning + score = score - rto * (b(fc, fr) = o(tc, tr)) ' moving back to original square usually bad + + ' moving towards other king + 't1 = (ABS(fc - bkc) + ABS(fr - bkr)) * WorB - (ABS(fc - wkc) + ABS(fr - wkr)) * (WorB = 0) + 't2 = (ABS(tc - bkc) + ABS(tr - bkr)) * WorB - (ABS(tc - wkc) + ABS(tr - wkr)) * (WorB = 0) + 'score = score + (t1 - t2) * 2 + + ' bonus for being on the same rank or column as rook + If CanMove(WorB) > 3 Then + ok = false + If tc = rookc1 Then + ok = true + For ts = tr To rookr1 Step Sgn(rookr1 - tr) + If (b(tc, ts) <> 0) And (b(tc, ts) <> rp) Then ok = false + Next ts + End If + If tc = rookc2 Then + ok = true + For ts = tr To rookr2 Step Sgn(rookr2 - tr) + If (b(tc, ts) <> 0) And (b(tc, ts) <> rp) Then ok = false + Next ts + End If + If tr = rookr1 Then + ok = true + For ts = tc To rookc1 Step Sgn(rookc1 - tc) + If (b(ts, tr) <> 0) And (b(ts, tr) <> rp) Then ok = false + Next ts + End If + If tr = rookr2 Then + ok = true + For ts = tc To rookc2 Step Sgn(rookc2 - tc) + If (b(ts, tr) <> 0) And (b(ts, tr) <> rp) Then ok = false + Next ts + End If + If ok And (b(tc, tr) = 0) Then + 'debug$ = debug$ + "q" + alphal$(tc) + CHRN$(tr) + " " + score = score + 10 + End If + End If + End If + + AddMove level, score, fc, fr, tc, tr + + If capture Then Exit Do + square = square + 1 + Loop Until square > 7 + n = n + 1 + Loop Until n = 8 + 'TimeTrack "MoveQueen", 0 +End Sub + +Sub MoveRook (level As _Byte) + Dim As _Byte capture, n, square, tc, tr, rspecial, tp, rp, qp, rookc, rookr, queenc, queenr, ts, ok + Dim score, tts + + 'TimeTrack "MoveRook", 1 + + If CanMove(WorB) > 3 Then + rp = Rook + WorB * 8 + qp = Queen + WorB * 8 + rookc = 0: rookr = 0 + queenc = 0: queenr = 0 + For tr = 1 To 8 + For tc = 1 To 8 + If b(tc, tr) = rp Then + If Not ((tr = fr) And (tc = fc)) Then + rookc = tc + rookr = tr + End If + End If + If b(tc, tr) = qp Then + queenc = tc + queenr = tr + End If + Next tc + Next tr + If WorB Then + If rookr = 1 Then rookr = 0 + If queenr = 1 Then queenr = 0 + Else + If rookr = 8 Then rookr = 0 + If queenr = 8 Then queenr = 0 + End If + End If + + rspecial = (b(fc, fr) = o(fc, fr)) And (move < 16) + + Do + tc = fc ' to column + tr = fr ' to row + square = 1 + Do + capture = 0 ' what piece captured + score = 0 + tc = tc - dl(Rook, n) + dr(Rook, n) ' column=column-left+right + If (tc < 1) Or (tc > 8) Then Exit Do ' off board + tr = tr - du(Rook, n) + dd(Rook, n) ' row=row-up+down + If (tr < 1) Or (tr > 8) Then Exit Do ' off board + tp = b(tc, tr) + If tp = 0 Then ' empty square + ElseIf WorB = Sgn(tp And 8) Then ' beer buddies + 'protc(level) = protc(level) + value(tp) + Exit Do ' can't move to or past own piece + Else ' opponent piece, possible capture + capture = tp ' capture piece + 'attackc(level) = attackc(level) + value(tp) + score = value(capture) ' bishops worth a bit more than knights + If score = 32 Then ' pawn value according to rank + If (tr = 1) Or (tr = 8) Then + score = value(Queen) + Else + tts = (9 - tr) * WorB - tr * (WorB = 0) + score = tts * tts + End If + End If + End If + + If score <> 777 Then ' don't mess with checkmate score + + score = score - (points < -2) * (capture > 0) * 10 ' more than 2 points behind, discount trades + 'score = score - SGN((fr - tr) * pawndir) * (move < 12) ' bonus for moving ahead at beginning + score = score - rto * (b(fc, fr) = o(tc, tr)) ' moving back to original square usually bad + + ' encourage moving towards opponent King + 't1 = (ABS(fc - bkc) + ABS(fr - bkr)) * WorB - (ABS(fc - wkc) + ABS(fr - wkr)) * (WorB = 0) + 't2 = (ABS(tc - bkc) + ABS(tr - bkr)) * WorB - (ABS(tc - wkc) + ABS(tr - wkr)) * (WorB = 0) + 'score = score + (t1 - t2) * 2 + + ' moving rook 1&2 up or 1 sideways early in game rarely good + If rspecial Then score = score + (tr < 4) * 32 * WorB - (tr > 5) * 32 * (WorB = 0) + (Abs(fc - tc) = 1) * 32 + + ' bonus for rook being on the same rank or column as queen or other rook + If CanMove(WorB) > 3 Then + ok = false + If tc = rookc Then + ok = true + For ts = tr To rookr Step Sgn(rookr - tr) + If (b(tc, ts) <> 0) And (b(tc, ts) <> rp) Then ok = false + Next ts + End If + If tr = rookr Then + ok = true + For ts = tc To rookc Step Sgn(rookc - tc) + If (b(ts, tr) <> 0) And (b(ts, tr) <> rp) Then ok = false + Next ts + End If + If tc = queenc Then + ok = true + For ts = tr To queenr Step Sgn(queenr - tr) + If (b(tc, ts) <> 0) And (b(tc, ts) <> qp) Then ok = false + Next ts + End If + If tr = queenr Then + ok = true + For ts = tc To queenc Step Sgn(queenc - tc) + If (b(ts, tr) <> 0) And (b(ts, tr) <> qp) Then ok = false + Next ts + End If + If ok And (b(tc, tr) = 0) Then + 'debug$ = debug$ + "r" + alphal$(tc) + CHRN$(tr) + " " + score = score + 10 + End If + End If + End If + + AddMove level, score, fc, fr, tc, tr + + If capture Then Exit Do + square = square + 1 + Loop Until square > 7 + n = n + 1 + Loop Until n = 4 + 'TimeTrack "MoveRook", 0 +End Sub + +Sub NameAssign + Dim As _Byte i + Dim x1, x2, y1, y2, t$, inputprompt$, fieldcontents$ + + ingetnames = true + PlotScreen false + + If wasplayback Then + PlayerNamePop + lasth = lasthsav + lastc = lastcsav + wasplayback = false + End If + + If (human = lasth) And (humanc = lastc) Then GoTo gotnames + If (human = 1) And (lasth = 1) And (humanc <> lastc) Then + Swap PlayerName$(0), PlayerName$(1) + lastc = humanc + GoTo gotnames + End If + + lasth = human + lastc = humanc + + Select Case human + Case Is = 0 + PlayerName$(0) = "Dodo Zero" + PlayerName$(1) = "Dodo Zero" + Case Is = 1 + If humanc Then + If Len(ComputerName$) Then PlayerName$(1) = ComputerName$ Else PlayerName$(1) = "Human" + PlayerName$(0) = "Dodo Zero" + Else + If Len(ComputerName$) Then PlayerName$(0) = ComputerName$ Else PlayerName$(0) = "Human" + PlayerName$(1) = "Dodo Zero" + End If + Case Is = 2 + If humanc Then + If Len(ComputerName$) Then PlayerName$(1) = ComputerName$ Else PlayerName$(1) = "Human" + PlayerName$(0) = "Human" + Else + If Len(ComputerName$) Then PlayerName$(0) = ComputerName$ Else PlayerName$(0) = "Human" + PlayerName$(1) = "Human" + End If + End Select + + gotnames: + If human > 0 Then + x1 = blx + x2 = brx + y1 = bly + 18 + y2 = _Height - 20 + + For i = 0 To 1 + inputprompt$ = Mid$("WhiteBlack", i * 5 + 1, 5) + " name" + ": " + fieldcontents$ = PlayerName$(1 - i) + nbox = 5 + _PutImage (x1, y1)-(x2, y2), bgi, 0, (x1, y1)-(x2, y2) ' erase clock area + 'Line (x1, y1)-(x2, y2), blue, BF + t$ = GetField$(inputprompt$, 520 + i * 22, 30, 1, fieldcontents$) + PlayerName$(1 - i) = t$ + Next i + End If + + WriteLog true + ingetnames = false +End Sub + +Sub NixieTubeClock (i As _Byte, j As _Byte, nn As _Byte) + Static initflag, img, fx, fy, tx, xq, yq + + If initflag = false Then ' one time initialization + img = _LoadImage(datapath$ + "nixie.jpg") ' 750 * 600 + xq = 148 + yq = 299 + initflag = true + End If + + fx = (nn Mod 5) * xq + 2 ' from x (source image) + fy = Int(nn / 5) * yq + tx = 8 + blx + (j - 1) * 28 + (1 - i) * 184 ' to x (screen) + _PutImage (tx, 518 - pregame * 20)-Step(28, 54), img, 0, (fx, fy)-(fx + xq, fy + yq) +End Sub + +Function OnOff$ (v As _Byte) + OnOff$ = RTrim$(Mid$("OFFON ", v * 3 + 1, 3)) +End Function + +Sub Pause + If inpause Or inhelp Then Exit Sub + inpause = true + Do: _Limit mloop + TempMess$ = "PAUSED" + PlotScreen false + KeyScan + KeepAlive ' signal Minimax, if active, to prevent timeout + Loop Until (i$ = "p") Or b1 Or b2 + TempMess$ = " " + ClearBuffers + inpause = false +End Sub + +Function PieceSize (tp) ' size adjustments for sets + PieceSize = psize + psa(piece_style, -((tp And 7) = Pawn)) +End Function + +Sub PieceSlide (tfc As _Byte, tfr As _Byte, ttc As _Byte, ttr As _Byte) + Static isactive As _Byte + Dim As _Byte lp, zz + Dim x1, x2, y1, y2, tx, ty, z1, tscreen + Dim As Single qq, qx, qy, tdelay + + If isactive Then Exit Sub ' prevent circular calls + + If invert Then + lp = b2(9 - tfc, 9 - tfr) + b2(9 - tfc, 9 - tfr) = 0 + Else + lp = b2(tfc, tfr) + b2(tfc, tfr) = 0 + End If + isactive = true ' plotscreen calls this, and this calls plotscreen + + x1 = tlx + (tfc - 1) * xq + y1 = bly - tfr * yq + x2 = tlx + (ttc - 1) * xq + y2 = bly - ttr * yq + If Abs(x1 - x2) > Abs(y1 - y2) Then qq = Abs(x2 - x1) Else qq = Abs(y2 - y1) + If rotate = 0 Then + If fast = 1 Then qq = qq / 2 Else qq = qq / 8 + Else + If fast = 1 Then qq = qq / 8 Else qq = qq / 16 + End If + If fast = 1 Then tdelay = .02 Else tdelay = .01 + + qx = (x2 - x1) / qq + qy = (y2 - y1) / qq + + zz = PieceSize(lp) + + If fast > 0 Then ' blink & slide for slow or fast, not off + PlotScreen false + If rotate = 0 Then DisplayMaster false + tscreen = _CopyImage(0) + + c1 = 0 + If onplayback And (Left$(m$, 1) = "O") And ((lp And 7) = Rook) Then c1 = 1 + If (((lp And 7) = Rook) And (fc < 0) Or (fr < 0)) Then c1 = 2 + If c1 = 0 Then + For z1 = 1 To 9 ' blink + _PutImage , tscreen, 0 + If z1 Mod 2 Then _PutImage (x1 + zz, y1 + zz)-(x1 + xq - zz, y1 + yq - zz), pix(piece_style, lp) ' pixh are hardware images + 'RainbowButton + If rotate = 0 Then _Display Else DisplayMaster true + _Delay .15 + Next z1 + End If + + For z1 = 1 To Int(qq) ' slide + tx = x1 + z1 * qx + ty = y1 + z1 * qy + 'z2 = zz - Sin(_D2R(z1 / qq * 180)) * 8 ' "hop" + _PutImage , tscreen, 0 + If rotate = 0 Then + _PutImage (tx + zz, ty + zz)-(tx + xq - zz, ty + yq - zz), pixh(piece_style, lp) ' pixh are hardware images + _Display + _Delay tdelay + Else + _PutImage (tx + zz, ty + zz)-(tx + xq - zz, ty + yq - zz), pix(piece_style, lp) + DisplayMaster true + End If + Next z1 + + _FreeImage tscreen + End If + If invert Then b2(9 - ttc, 9 - ttr) = lp Else b2(ttc, ttr) = lp + isactive = false +End Sub + +Sub Plasma (x1, y1, x2, y2, sp As _Byte) Static + Dim As _Byte i, m, m1, n, rf(12) + Dim xxyy, x, y, z + Dim As Single kk, dd, dx, dy, r, g, b, f1, f2, f3, f(5) + Dim As _Unsigned Long c(360) + Dim p(5) As xy + Dim sm As _MEM + Dim so As _Offset + + Type xy + x As Single + y As Single + dx As Single + dy As Single + End Type + + If plasmaint = 0 Then Exit Sub + + 'TimeTrack "Plasma", 1 + + If plasma_init = false Then + xxyy = 16 * xq + For n = 1 To 12 + rf(n) = Rnd * 20 + 20 + Next n + z = 0 + r = Rnd: g = Rnd: b = Rnd + For n = 1 To 5 + For i = 1 To 4 + For m = 0 To 17 + m1 = 17 - m + Select Case i + Case 1: f1 = (m * r) / rf(1): f2 = (m * g) / rf(2): f3 = (m * b) / rf(3) + Case 2: f1 = (m + m1 * r) / rf(4): f2 = (m + m1 * g) / rf(5): f3 = (m + m1 * b) / rf(6) + Case 3: f1 = (m1 + m * r) / rf(7): f2 = (m1 + m * g) / rf(8): f3 = (m1 + m * b) / rf(9) + Case 4: f1 = (m1 * r) / rf(10): f2 = (m1 * g) / rf(11): f3 = (m1 * b) / rf(12) + End Select + c(z) = _RGB32(f1 * 255, f2 * 255, f3 * 255) + z = z + 1 + Next m + Next i + Next n + + For n = 0 To 5 + p(n).x = Rnd * xm + p(n).y = Rnd * ym + p(n).dx = Rnd + p(n).dy = Rnd + If Rnd > .5 Then p(n).dx = -p(n).dx + If Rnd > .5 Then p(n).dy = -p(n).dy + f(n) = Rnd * .08 + Next + plasma_init = true + End If + + For n = 0 To 5 + p(n).x = p(n).x + p(n).dx + If p(n).x > xxyy Or p(n).x < 0 Then p(n).dx = -p(n).dx + p(n).y = p(n).y + p(n).dy + If p(n).y > xxyy Or p(n).y < 0 Then p(n).dy = -p(n).dy + Next + + sm = _MemImage + For y = y1 To y2 Step 2 + inhelp ' dimmer in Help to not obscure text + so = sm.OFFSET + y * _Width * 4 + x1 * 4 + For x = x1 To x2 Step 2 + 'c1 = Point(x, y) + _MemGet sm, so, c1 + If sp Then ' help screen + c1 = (c1 <> boardwhite) + Else ' the board + c1 = ((c1 = boardwhite) * (graphics <> 2) + (c1 = boardblack) * (graphics > 1)) + End If + If c1 Then + dd = 0 + For n = 0 To 5 + dx = x - p(n).x + dy = y - p(n).y + kk = Sqr(dx * dx + dy * dy) + dd = dd + (Sin(kk * f(n)) / 4 + 1) * 64 + Next + _MemPut sm, so, c(dd Mod 360) + 'PSet (x, y), c(dd Mod 360) + End If + so = so + 8 + Next x + Next y + _MemFree sm + + 'TimeTrack "Plasma", 0 +End Sub + +Sub Playagain () + Dim k, t$, validkeys$, waituntil As Double + + onplayback = false + readonly = true ' allows replay (takeback a move or more) without changing "official" game + endgame = true + waituntil = ExtendedTimer + 60 - (rickfile * 50) ' 10 second delay for Frostosaurus, 60 for others + + Do: _Limit mloop + KeepAlive + TempMess$ = msg$ + If match Or (human = 0) Then TempMess$ = TempMess$ + Str$(Int(waituntil - ExtendedTimer)) + PlotScreen false + + If InStr(LCase$(msg$), "res") Then + t$ = " Resume New" + s$ + "game Invert " + validkeys$ = "rn" + Else + t$ = " New" + s$ + "game Back Invert " + If backok Then validkeys$ = "bn" Else validkeys$ = "n" + End If + t$ = t$ + " File" + s$ + "menu " + Center 0, t$, true, false + + validkeys$ = validkeys$ + "f" + KeyScan + If i$ = "" Then i$ = " " + + If asci = 72 Then + For k = 1 To 10 + If (shia + move - 48) > 0 Then shia = shia - 1: oply = false + Next k + End If + + If asci = 80 Then + shia = shia + 10 + oply = false + End If + If shia > 0 Then shia = 0 + + If dev And (i$ = "q") Then Quit + If (i$ = "r") And (InStr(validkeys$, "r") > 0) Then + move = move + (SaveWorB = 1) ' decrement move if Black + noresign = true ' disable resign (to practice checkmate?) + End If + k = InStr(validkeys$, i$) ' Special K, a crappy cereal + + Loop Until k Or ((match Or (human = 0)) And (ExtendedTimer > waituntil)) + + msg$ = "" + If k = 0 Then i$ = "n": ClearTemp ' new game, clear temporary images (capture, small boards) + endgame = false + If i$ = "f" Then PlayFile +End Sub + +Sub PlayerNamePush + PlayerName$(2) = PlayerName$(0) + PlayerName$(3) = PlayerName$(1) +End Sub + +Sub PlayerNamePop + PlayerName$(0) = PlayerName$(2) + PlayerName$(1) = PlayerName$(3) +End Sub + +Sub PlayFile + Dim v$(2), i, j, tf, lt, w, zz, gotline, fc, fr, tc, tr, mp, mc, pt, eloop, nonstop, tscreen + Dim hcount, q1, q2, sfc, sfr, stc, str, fc2, fr2, tc2, tr2, c$, t$, t2$, pbf$ + Dim header$(20), guts$(20), wu As Double + + pgnheader: + Data Event,Site,Date,Round,White,Black,Result + + If onplayback Then Exit Sub ' could lead to impossible move + PlayerNamePush + lasthsav = lasth: lastcsav = lastc + + f$ = "" + GetFileForPlayback + If Len(f$) = 0 Then Exit Sub + + onplayback = true + eloop = false + + pf$ = f$ + pbf$ = f$ + + wakka: ' three cheers for Fozzy Bear + f$ = gamepath$ + pbf$ + ".alg" + FileCheck + pf$ = pbf$ + ClearTemp + WorB = 1 + move = 0 + Erase Moves, mcount, etime, mlog$ + + castle$ = "****" ' flags qkQK (B then W) + cmate = 0 + drawcount = 0 + FENpcount = 0 + hcount = 0 + human = true + noresign = false + perpetual = 0 + + pdate$ = "" + PlayerName$(0) = "" + PlayerName$(1) = "" + + tf = FreeFile + Open f$ For Input As #tf + readheader: + Line Input #tf, t$ + If InStr(t$, "[") Then ' header(s) + hcount = hcount + 1 + If hcount < 21 Then + header$(hcount) = t$ + q1 = InStr(t$, q$) + q2 = 0 + If q1 Then q2 = InStr(q1 + 1, t$, q$) + If (q1 > 0) And (q2 > 0) Then guts$(hcount) = Mid$(t$, q1 + 1, q2 - q1 - 1) + End If + If Not (EOF(tf)) Then GoTo readheader + Else + gotline = 1 + End If + + Restore pgnheader + For i = 1 To 7 + Read t2$ + For j = 1 To hcount + If InStr(UCase$(header$(j)), UCase$(t2$)) Then + If t2$ = "Date" Then pdate$ = guts$(j) + If t2$ = "White" Then PlayerName$(1) = guts$(j) + If t2$ = "Black" Then PlayerName$(0) = guts$(j) + End If + Next j + Next i + + If pdate$ = "" Then pdate$ = fd$ ' use file date when no stored date + + Enter10 = false ' shift-Enter skips 10 moves + invert = false + FENpcount = 0 + msg$ = "" + TempMess$ = "" + nonstop = false + wasreadonly = readonly + + SetupBoard + PlotScreen false + + While Not (EOF(tf)) + If gotline = 0 Then Line Input #tf, t$ + gotline = 0 + If InStr(t$, "[") Then _Continue ' ignore lines with [ + t$ = LTrim$(t$) + " " + lt = Len(t$) + If lt = 0 Then _Continue + t$ = t$ + " " + v$(0) = "": v$(1) = "": v$(2) = "" + w = 0 + ReDim givecheck(2), promotec(2) + + i = InStr(t$, "ep") + If i > 0 Then Mid$(t$, i, 2) = " " + + For i = 1 To lt + lookagain: + c$ = Mid$(t$, i, 1) + pt = InStr("RNBQ", c$) + If pt Then ' promotion + promotec(w) = pt + Else + Select Case c$ + Case "+" ' check or checkmate + If givecheck(w) Then ' seen a + before, must be checkmate + cmate = w + Exit For + End If + givecheck(w) = true + Case "$" ' stalemate + Case " " ' space between move/number, or move/move + w = w - (Len(v$(w)) > 0) + If w > 2 Then Exit For + Case Else + v$(w) = v$(w) + c$ + End Select + End If + Next i + For zz = 1 To 2 + m$ = v$(zz) ' grab move out of 2 move input buffer + If m$ = "" Then readonly = false: GoTo pbdone + If (m$ = "res") Or (m$ = "1-0") Or (m$ = "0-1") Or (m$ = draw$) Or (m$ = "draw") Then + readonly = true + If m$ = "res" Then AddSymbol "res" + If (m$ = draw$) Or (m$ = "draw") Then AddSymbol "draw" + GoTo pbdone + End If + fc = InStr(alphaz$, Left$(m$, 1)) ' from column + fr = Val(Mid$(m$, 2, 1)) ' from row + tc = InStr(alphaz$, Mid$(m$, 3, 1)) + tr = Val(Mid$(m$, 4, 1)) + mp = b(fc, fr) ' moving piece + mc = Sgn(mp And 8) ' moving color 0 black 1 white + mp = mp And 7 ' strip color from piece + If Left$(m$, 3) = "O-O" Then ' might end with ? (comment questionable) + fc = -5: tc = 7: fc2 = 8: tc2 = 6 ' negative "from column" is how I identify kingside castle + If WorB = 1 Then fr = 1: tr = 1: fr2 = 1: tr2 = 1 + If WorB = 0 Then fr = 8: tr = 8:: fr2 = 8: tr2 = 8 + End If + If Left$(m$, 5) = "O-O-O" Then ' might end with ? (comment questionable) + fc = 5: tc = 3: fc2 = 1: tc2 = 4 + If WorB = 1 Then fr = -1: tr = 1: fr2 = 1: tr2 = 1 ' negative "from row" is how I identify queenside castle + If WorB = 0 Then fr = -8: tr = 8: fr2 = 8: tr2 = 8 + End If + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' copy working b() to display board b2() + sfc = fc: sfr = fr: stc = tc: str = tr + PieceSlide Abs(fc), Abs(fr), tc, tr + + If Left$(m$, 1) = "O" Then ' rook part of castling + PieceSlide fc2, fr2, tc2, tr2 + fc = sfc: fr = sfr: tc = stc: tr = str + End If + + AddMove 0, 0, fc, fr, tc, tr ' level score position + Reset_To_Zero + MoveItReal fc, fr, tc, tr + If promotec(zz) > 0 Then + b(tc, tr) = promotec(zz) + WorB * 8 + promote$ = Mid$("RNBQ", promotec(zz), 1) ' for addlog + End If + AddLog + Fking false + WorB = WorB Xor 1 + If givecheck(zz) Then + TempMess$ = "Check!" + AddSymbol "+" + End If + If Right$(m$, 1) = "?" Then AddSymbol "?" + If Right$(m$, 1) = "!" Then AddSymbol "!" + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' copy working b() to display board b2() + MarkerSave fc, fr, tc, tr + If cmate = zz Then + TempMess$ = "Checkmate" + msg$ = "Checkmate" + AddSymbol "+" + readonly = true + GoTo pbdone + End If + Do: _Limit mloop + PlotScreen false + KeyScan + Select Case i$ + Case " " + i$ = Enter$: asci = 13 + Case "l" + eloop = eloop Xor 1 + TempMess$ = "Loop " + OnOff$(eloop) + If eloop Then PlotScreen true + Case "n" + nonstop = nonstop Xor 1 + TempMess$ = "Nonstop " + OnOff$(nonstop) + If nonstop = false Then eloop = false + If nonstop Then PlotScreen true + Case "s" + nonstop = false + eloop = false + readonly = true + GoTo pbdone + End Select + If Enter10 > 0 Then + asci = 13 + Enter10 = Enter10 - 1 + If Enter10 = 0 Then fast = sfast + End If + Loop Until nonstop Or (asci = 13) Or eloop + i$ = "": asci = 0 + Next zz + If (perpetual > 2) Or (drawcount > 49) Then GoTo pbdone + Wend + readonly = false + + pbdone: + check = false + incheck = false + Close #tf + PlotScreen true + If eloop Then + wu = ExtendedTimer + 5 + PlotScreen false + tscreen = _CopyImage(0) + Do: _Limit mloop + If rotate Then _PutImage , tscreen, 0 Else PlotScreen true + KeyScan + Loop Until (ExtendedTimer > wu) Or (Len(i$) > 0) + _FreeImage tscreen + _Delay .1 + If i$ <> "s" Then GoTo wakka + End If + GetWB + If InStr(mlog$(move, 1), "res") Then move = move - 1 + SaveWorB = WorB + promote$ = "" + If wasreadonly Then readonly = true + logfiled$ = LCase$(pf$) + ".alg" + logfile$ = gamepath$ + logfiled$ +End Sub + +Sub PlaySound (sf As _Byte) + If pregame And (sf > 1) Then Exit Sub + If makenoise = 0 Then Exit Sub ' sound turned off or file does not exist + If soundloaded = 0 Then LoadSounds + If sfile(sf) = 0 Then Exit Sub ' sound turned off or file does not exist + If (sf > 1) And (_SndPlaying(sfile(1)) <> 0) Then _SndStop sfile(1) ' stop intro music for any other sound + _SndVol sfile(sf), svol(sf) / 10 ' volume is 0.1 and 1-10 + If (sf > 1) Or (_SndPlaying(sfile(1)) = 0) Then _SndPlay sfile(sf) ' let intro music play without restart for volume adjustments +End Sub + +Sub PlotBoard + Dim As _Byte zc, zr + Dim sfx, sfy, stx, sty + + For zr = 1 To 8 + For zc = 1 To 8 + PlotPiece zc, zr, zc, zr + Next zc + Next zr + + ' last opponent move, little green box in from square, red box in to square + If markers And (pregame = 0) And (insetup = 0) And (markerfc > 0) Then + If invert Then + sfx = tlx + (8 - markerfc) * xq + 4: sfy = bly - (9 - markerfr) * yq + 4 + stx = tlx + (8 - markertc) * xq + 4: sty = bly - (9 - markertr) * yq + 4 + Else + sfx = tlx + (markerfc - 1) * xq + 4: sfy = bly - markerfr * yq + 4 + stx = tlx + (markertc - 1) * xq + 4: sty = bly - markertr * yq + 4 + End If + Line (sfx, sfy)-Step(4, 4), green, BF + Line (stx, sty)-Step(4, 4), red, BF + Line (sfx, sfy)-Step(4, 4), black, B + Line (stx, sty)-Step(4, 4), black, B + End If +End Sub + +Sub PlotPiece (fc As _Byte, fr As _Byte, tc As _Byte, tr As _Byte) + Dim As _Byte lp, tfc, tfr, ttc, ttr, z + Dim tx, ty, ty2 + + tfc = Abs(fc) + tfr = Abs(fr) + ttc = tc + ttr = tr + + lp = b2(tfc, tfr) + + If invert Then ' from black's perspective + tfc = 9 - tfc + tfr = 9 - tfr + ttc = 9 - ttc + ttr = 9 - ttr + End If + + If (cflag < 0) Or ((human <> 2) And (((human = 0) Or (WorB <> humanc)) And ((tfc <> ttc) Or (tfr <> ttr)))) Then + PieceSlide tfc, tfr, ttc, ttr + End If + + tx = tlx + (tfc - 1) * xq + ty = bly - tfr * yq + + If ((tfc + tfr) Mod 2) Then c1 = boardwhite Else c1 = boardblack + Line (tx, ty)-(tx + xq, ty + yq), c1, BF + + If lp Then + z = PieceSize(lp) + ty2 = ty - (piece_style = 6) * 2 + If ((tfc + tfr) Mod 2) And (piece_style <> 9) And (piece_style > 1) Then + _PutImage (tx + xq - z, ty2 + z)-(tx + z, ty2 + yq - z), pix(piece_style, lp), 0 + Else + _PutImage (tx + z, ty2 + z)-(tx + xq - z, ty2 + yq - z), pix(piece_style, lp), 0 + End If + If alfredon And (Rnd > .98) Then _PutImage (tx, ty2)-(tx + xq, ty2 + yq), alfred, 0 + End If + + If squaretrim And (piece_style > 0) Then + For z = 0 To squaretrim - 1 + Line (tx + z, ty + z)-(tx + xq - z, ty + yq - z), black, B + Next z + If squaretrim = 3 Then Line (tx + 1, ty + 1)-(tx + xq - 1, ty + yq - 1), c1, B + End If +End Sub + +Sub PlotScreen (disp As _Byte) + Dim As _Byte i, j, k + Dim t$, x1, x2, y1, y2 + 'dim h, m, s + 'Dim As _Byte sorted ' TimeTrack + + 'TimeTrack "PlotScreen", 1 + + nbox = 0 + chimp = 0 + fullscreenflag = Sgn(_FullScreen) + + 'If rickfile And (bri > 2) And (btoggle = false) Then ' autodim for me 2200 + ' h = Val(Mid$(Time$, 1, 2)) + ' m = Val(Mid$(Time$, 4, 2)) + ' s = Val(Mid$(Time$, 7, 2)) + ' If (h = 22) And (m = 0) And (s < 5) Then + ' bri = 2 + ' ColorSet + ' btoggle = true + ' End If + 'End If + + If insetup Then + 'TimeTrack "PlotScreen", 0 + Exit Sub + End If + + If xmas Then ' alternatng red/green squares + graphics = 3 ' plasma for all squares + If (xmast = 0) Or (xmast < ExtendedTimer) Then + xmasc = xmasc Xor 1 + boardwhite = _RGB32(200, 0, 0) ' red + boardblack = _RGB32(0, 200, 0) ' green + If xmasc Then Swap boardwhite, boardblack ' swap + xmast = ExtendedTimer + .5 ' change colors again in 5 seconds + End If + End If + + Background + AboveBoardInfo ' score, status, time limited messages, stats, Windows buttons + + If pregame Then + j = 0 + For i = 1 To 18 * pregame ' cookie! + k = Val(Mid$("002032023222300032", i, 1)) ' ..-., -.-, ---, ..., - + Line (tlx + j + 2, tly - 2)-Step(k, 0), red * -(k < 3) + j = j + k + 3 + Next i + End If + + PlotBoard ' squares, pieces, markers + If legend And (pregame = 0) Then ShowLegend ' a-h at bottom, 1-8 at left + + If onplayback And (Len(pf$) > 0) Then ' show info on current file + x1 = blx + x2 = brx + y1 = bly + 20 + y2 = _Height - 20 + _PutImage (x1, y1)-(x2, y2), bgi, 0, (x1, y1)-(x2, y2) + SetFont defaultfontsize + t$ = PlayerName$(1) + " / " + PlayerName$(0) + If Len(t$) = 3 Then t$ = "PLAYBACK" + ShadowPrint xc - _PrintWidth(t$) \ 2, 512, t$, white + ShadowPrint xc - _PrintWidth(pdate$) \ 2, 530, pdate$, white + t$ = "Moves:" + Str$(mig) + ShadowPrint xc - _PrintWidth(t$) \ 2, 550, t$, white + Else + If (ingetfile + ingetnames + promoting) = 0 Then Clocks ' big move clocks + End If + + If (pregame = 0) And (ingetfile = 0) Then + ShowTaken true + ShowBolt + InfoOnRight + End If + ptaken = Abs(ptaken) + GraphLoad + Center 0, "", true, false ' instructions at bottom + + 'If ttflag And (tel! > 0) Then ' SUB time tracking + ' + ' sort: + ' sorted = 1 + ' For i = 1 To names - 1 + ' If time_used(i) < time_used(i + 1) Then + ' Swap name$(i), name$(i + 1) + ' Swap time_used(i), time_used(i + 1) + ' Swap active(i), active(i + 1) + ' sorted = 0 + ' End If + ' Next i + ' If sorted = 0 Then GoTo sort + ' + ' _PutImage (0, 0)-(tlx - 1, bly - 12), bgi, 0, (0, 0)-(tlx - 1, bly - 12) + ' _Font 14 + ' Color gray, zip + ' For i = 1 To names + ' Locate i + 3, 2: Print name$(i); + ' Locate i + 3, 16: Print Using "####.####"; (time_used(i) / tel!) * 100; + ' Next i + 'End If + + RainbowButton + + If showmousepos Then Magnify + + 'i = ant(0) + ant(1) + ant(2) + ant(3) + ant(4) + ant(5) + 'If i > 0 Then + ' debug$ = "" + ' For i = 0 To 5 + ' debug$ = debug$ + Str$(ant(i)) + " " + ' Next i + 'End If + + If Len(debug$) Then + SetFont defaultfontsize + Color _RGB32(200, 200, 200), zip + _PrintString (tlx, 10), debug$ + End If + + If disp Then DisplayMaster disp + + 'TimeTrack "PlotScreen", 0 +End Sub + +Sub DisplayMaster (dflag As _Byte) + Static wrotate, trotate + + trotate = rotate + + If fullscreenflag <> 0 Then + If rotate = 0 Then + If (_DesktopWidth = 1366) And (_FullScreen <> 2) Then + fullscreenflag = 2 + ScreenInit + End If + Else + If _FullScreen <> 1 Then + fullscreenflag = 1 + ScreenInit + End If + End If + End If + + If usd Then + RotateBoard 2 + trotate = 2 + ElseIf rotate <> 0 Then + If rotate <> wrotate Then wrotate = rotate: ScreenInit + RotateBoard rotate + End If + + If graphics And (ingetfile = 0) And (inshow = 0) Then + If inhelp Then + Plasma 0, 0, _Width - 1, _Height - 1, 1 + Else + Select Case trotate + Case 0 + Plasma tlx, tly, trx, bly, 0 + Case 1 + If _FullScreen Then + Plasma 218, 0, 664, _Height - 1, 0 + Else + Plasma 158, 0, 753, _Height - 1, 0 + End If + Case 2 + Plasma 236, 118, 602, 564, 0 + Case 3 + If _FullScreen Then + Plasma 134, 0, 584, _Height - 1, 0 + Else + Plasma 48, 0, 642, _Height - 1, 0 + End If + End Select + End If + End If + If dflag <> 0 Then _Display +End Sub + +Sub Quit + Dim i, x1, x2, y1, y2 + ConfigWrite + WriteLog false + If match > 0 Then + ToFrom 0, "en", match ' signal Minimax to terminate + _Delay 1 + End If + Close + + If explosion < -1 Then ' if image loaded + _MouseHide + _MouseMove (mx + 1) Mod _Width, my + x1 = _Width \ 2 - 250: y1 = _Height \ 2 - 250 + x2 = _Width \ 2 + 250: y2 = _Height \ 2 + 250 + For i = 0 To 48 + Cls + _PutImage (x1, y1)-(x2, y2), explosion, 0, (_SHL(i Mod 8, 8), _SHL(i \ 8, 8))-Step(255, 255) + _Display + _Delay .03 + Next i + End If + + System +End Sub + +Sub QuitWithError (desc$, tfile$) + _Dest 0 + Sound 222, 2 + Color _RGB32(200, 200, 200), black + _Font 16 + Cls + _PrintString (20, 20), desc$ + ": " + tfile$ + _Display + Sleep + System +End Sub + +Sub ReadBoard () + Dim r, c, p, c$, tf + 'dim tf$ + + SetupBoard: + Data r,n,b,q,k,b,n,r + Data p,p,p,p,p,p,p,p + Data 0,0,0,0,0,0,0,0 + Data 0,0,0,0,0,0,0,0 + Data 0,0,0,0,0,0,0,0 + Data 0,0,0,0,0,0,0,0 + Data P,P,P,P,P,P,P,P + Data R,N,B,Q,K,B,N,R + + testing: + Data 0,K,0,0,0,0,0,0 + Data 0,0,0,0,0,0,0,0 + Data 0,0,0,Q,0,0,0,0 + Data 0,0,0,0,0,0,0,0 + Data 0,0,0,B,0,N,0,0 + Data 0,0,0,0,0,0,0,0 + Data 0,0,0,0,0,0,0,0 + Data 0,k,0,0,0,0,0,0 + + If testing Then + 'tf$ = "testing.txt" + 'IF _FILEEXISTS(tf$) = 0 THEN QuitWithError tf$, "does not exist" + 'tf = FREEFILE + 'OPEN "testing.txt" FOR INPUT AS #tf + noresign = true + Restore testing + Else + Restore SetupBoard ' initial board position + End If + + For r = 8 To 1 Step -1 ' board setup + For c = 1 To 8 + 'IF testing THEN INPUT #tf, c$ ELSE READ c$ + Read c$ + p = InStr("rnbqkp", LCase$(c$)) ' blank or piece + If p Then p = p - (c$ = UCase$(c$)) * 8 ' add 8 if uppercase (white) + b(c, r) = p ' put piece on board + If testing = 0 Then o(c, r) = p ' original setup + Next + Next + If testing Then Close #tf +End Sub + +Sub Recurse (level As _Byte) ' heart of program + Dim mi, tmps + Dim As _Byte j, lm, s1, s2 + Dim atime As Double + + If (abort > 0) Or (level = masterlevel) Then Exit Sub + + lm = level - 1 + 'best(level) = -9999 + For mi = 1 To Moves(lm) + 'mi(level) = move(lm, mi).mi + j = lm Mod 2 + WorB = SaveWorB * j - (SaveWorB Xor 1) * (j = 0) + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(level), m(level).OFFSET ' store board + MoveIt move(lm, mi).fc, move(lm, mi).fr, move(lm, mi).tc, move(lm, mi).tr + CheckBoard level ' evaluate all possible moves + Recurse level + 1 + TakeBest level, false + _MemCopy m(level), m(level).OFFSET, m(level).SIZE To m(0), m(0).OFFSET ' restore board + move(lm, mi).sc = move(lm, mi).sc + move(level, 1).sc * (move(lm, mi).sc <> 777) + If level = 1 Then + + atime = ExtendedTimer - ClockTime ' time elapsed + tcount = mcount(0) + mcount(1) + mcount(2) + mcount(3) + mcount(4) + mcount(5) + If ocount > 0 Then tmps = (tcount - ocount) / atime + If tmps > 0 Then mps = tmps + 'If rickfile And (mps > 0) Then Print #rickfile, mps ' mps.txt, long term averaging + If mps > top_mps Then top_mps = mps: ForRick ' log best mps + ocount = tcount + + 'If (SaveWorB = 1) And (Abs(move(lm, mi).sc) <> 777) Then + ' move(lm, mi).sc = move(lm, mi).sc + move(lm, mi).os \ 10 + 'End If + + WorB = SaveWorB + MoveIt move(0, mi).fc, move(0, mi).fr, move(0, mi).tc, move(0, mi).tr + WorB = WorB Xor 1 + MoveIt move(1, 1).fc, move(1, 1).fr, move(1, 1).tc, move(1, 1).tr + WorB = WorB Xor 1 + CheckBoard 2 + TakeBest 2, false + MoveIt move(2, 1).fc, move(2, 1).fr, move(2, 1).tc, move(2, 1).tr + WorB = WorB Xor 1 + CheckBoard 3 + TakeBest 3, false + + 'If masterlevel > 4 Then + ' MoveIt move(3, 1).fc, move(3, 1).fr, move(3, 1).tc, move(3, 1).tr + ' WorB = WorB Xor 1 + ' CheckBoard 4 + ' TakeBest 4, false + 'End If + + 'If masterlevel > 5 Then + ' MoveIt move(4, 1).fc, move(4, 1).fr, move(4, 1).tc, move(4, 1).tr + ' WorB = WorB Xor 1 + ' CheckBoard 5 + ' TakeBest 5, false + 'End If + + _MemCopy m(1), m(1).OFFSET, m(1).SIZE To m(0), m(0).OFFSET + + 'If SaveWorB = 0 Then move(lm, mi).sc = move(lm, mi).os - move(1, 1).os + move(2, 1).os - move(3, 1).os + + 'If SaveWorB = 999 Then + ' rspecial = (protc(2) - protc(1) + attackc(2) - attackc(1)) \ 1000 + ' move(0, mi).sc = move(0, mi).sc + rspecial + ' For j = 0 To 3 + ' protc(j) = 0 + ' attackc(j) = 0 + ' Next j + 'End If + + smovest = mi + thinkv(mi) = move(0, mi).sc + think$(mi) = " " + Left5$(ToAlg$(0, mi)) + Left5$(ToAlg$(1, 1)) + Left5$(ToAlg$(2, 1)) + Left5$(ToAlg$(3, 1)) + Rjust$(move(0, mi).sc, 4) + Rjust$(move(1, 1).sc, 4) + Rjust$(move(2, 1).sc, 4) + Rjust$(move(3, 1).sc, 4) + + PlotScreen false + + If markers And showthinkingf Then + + s1 = WorB + s2 = human + WorB = WorB Xor 1 + human = 1 + ShowValid Abs(move(0, mi).fc), Abs(move(0, mi).fr) + WorB = s1 + human = s2 + + Cursor Abs(move(0, mi).fc), 9 - Abs(move(0, mi).fr), 0 + Cursor Abs(move(0, mi).tc), 9 - Abs(move(0, mi).tr), 1 + End If + + If dosmallboard Then SmallBoard mi + + c1 = Moves(0) - (Moves(0) = 0) ' prevent /0 next line + c1 = brx - mi / c1 * (brx - blx) + If lostfocus Then c2 = black Else c2 = _RGB32(255, 255, 255) + Line (blx + 2, ym - 22)-(c1, ym - 22), c2 + KeyScan + If abort Then Exit For + ClockTime = ExtendedTimer + End If + Next mi +End Sub + +Sub RemoveIllegal (level As _Byte) + Dim mi, mj + Dim As _Byte k, count + + If Moves(level) = 0 Then Exit Sub + + For mi = 1 To Moves(level) ' first pass, mark bad + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(8), m(8).OFFSET + MoveIt move(level, mi).fc, move(level, mi).fr, move(level, mi).tc, move(level, mi).tr + + WorB = WorB Xor 1 + CheckBoard 8 + TakeBest 8, false ' level 1, take first of best, repeats ok + WorB = WorB Xor 1 + If Moves(8) > 0 Then + If Abs(move(8, 1).sc) = 777 Then move(level, mi).fc = 99 + For mj = 1 To Moves(8) ' don't rely on the above line, check ALL moves + k = b(move(8, mj).tc, move(8, mj).tr) And 7 + If k = King Then move(level, mi).fc = 99 + Next mj + End If + _MemCopy m(8), m(8).OFFSET, m(8).SIZE To m(0), m(0).OFFSET + Next mi + + mi = 0: count = 0 ' second pass, collapse array onto bad ones + Do + mi = mi + 1 + If (mi + count) > Moves(level) Then Exit Do + woof: + If move(level, mi).fc = 99 Then + For mj = mi To Moves(level) + move(level, mj) = move(level, mj + 1) + If level = 0 Then + If ssb(mj) < -1 Then + _FreeImage ssb(mj) + ssb(mj) = 0 + If ssb(mj + 1) < -1 Then + ssb(mj) = _CopyImage(ssb(mj + 1)) + _FreeImage ssb(mj + 1) + End If + ssb(mj + 1) = 0 + End If + End If + Next mj + count = count + 1 + GoTo woof + End If + Loop + Moves(level) = Moves(level) - count ' fix count +End Sub + +Sub Reset_To_Zero + Fking false ' find kings (did you suspect otherwise?) + WorB = WorB Xor 1 ' reverse who's moving + CheckBoard 1 ' need to know what opponent can do to ensure legal castling + TakeBest 1, false ' move 777 (King capture) to top of list, if it's there + WorB = WorB Xor 1 ' restore playing color + CheckBoard 0 ' determine legal moves + TempMess$ = " " +End Sub + +Function Rjust$ (t, n As _Byte) + If Abs(t) = 777 Then + Rjust$ = " ++" + Else + Rjust$ = Right$(Space$(n) + Str$(t), n) + End If +End Function + +Sub RotateBoard (rot As _Byte) + Dim As _Byte i + Dim w, h, x2, y2, sinr!, cosr!, px(3), py(3) + + If rot = 2 Then ' upsidedown + _PutImage (_Width - 1, _Height - 1)-(0, 0), 0, 0, (0, 0)-(_Width - 1, _Height - 1) + Exit Sub + End If + + If inhelp Then + _PutImage , mscreen, mscreenr + Else + _PutImage , mscreen, mscreenr, (tlx - 1, 0)-(brx + 1, _Height - 1) + End If + + w = _Width(mscreenr) + h = _Height(mscreenr) - 1 + px(0) = -w \ 2: py(0) = -h \ 2 + px(1) = -w \ 2: py(1) = h \ 2 + px(2) = w \ 2: py(2) = h \ 2 + px(3) = w \ 2: py(3) = -h \ 2 + sinr! = Sin(_D2R(-rot * 90)): cosr! = Cos(_D2R(-rot * 90)) + For i = 0 To 3 + x2 = (px(i) * cosr! + sinr! * py(i)) + _Width \ 2 + y2 = (py(i) * cosr! - px(i) * sinr!) + _Height \ 2 + px(i) = x2: py(i) = y2 + Next + + Cls + _MapTriangle (0, 0)-(0, h - 1)-(w - 1, h - 1), mscreenr To(px(0), py(0))-(px(1), py(1))-(px(2), py(2)) + _MapTriangle (0, 0)-(w - 1, 0)-(w - 1, h - 1), mscreenr To(px(0), py(0))-(px(3), py(3))-(px(2), py(2)) +End Sub + +'Sub R_T_C ' Dallas 1307 Real Time Clock +' Dim hh, t$ +' +' t$ = Left$(Time$, 2) +' hh = Val(t$) +' If hh > 12 Then t$ = Right$("0" + LTrim$(Str$(hh - 12)), 2) +' t$ = t$ + Right$(Time$, 6) +' Line (xc - 18, tly - 1)-(xc + 18, tly - 8), zip, BF +' TinyFont t$, xc - 16, 27, clockc +'End Sub + +Sub ScoresOnBoard Static ' nifty-neato diagnostics invoked with \ + Dim mi, p, z, i, j, r, c, x, y, k(6) As _Unsigned Long, waituntil As Double, nu(8, 8) + + k(1) = _RGB32(170, 170, 0) ' rook + k(2) = _RGB32(0, 110, 0) ' knight + k(3) = _RGB32(0, 0, 255) ' bishop + k(4) = _RGB32(255, 255, 255) ' queen + k(5) = _RGB32(80, 0, 80) ' king + k(6) = _RGB32(22, 22, 22) ' pawn + + begin: + Erase nu ' counter for each square, determines "print" row + For p = 1 To 6 + z = Val(Mid$("412356", p, 1)) ' the order *I* want, queen/rook/knight/bishop/king/pawn + For mi = 1 To Moves(0) + c = Abs(move(0, mi).fc) ' column + r = Abs(move(0, mi).fr) ' row + If z <> (b(c, r) And 7) Then _Continue + If mi = 1 Then ' put red box around piece about to move + If invert = 1 Then c = 9 - c: r = 9 - r + x = tlx + (c - 1) * xq + y = bly - r * yq + For j = 1 To 4 + Line (x + j, y + j)-(x + xq - j, y + yq - j), green, B + Next j + End If + c = Abs(move(0, mi).tc) ' column + r = Abs(move(0, mi).tr) ' row + If invert Then c = 9 - c: r = 9 - r + x = tlx + (c - 1) * xq + 2 + y = bly - r * yq + 2 + nu(c, r) * 11 + If mi = 1 Then ' red, make it stand out + Color _RGB32(200, 20, 20), zip + Else + Color k(z), _RGBA(0, 0, 0, 20) + If mi < 4 Then + SetFont 10 + _PrintString (x + xq - 10, y), CHRN$(i) + End If + End If + SetFont 12 + _PrintString (x, y), Mid$("RNBQKP", z, 1) + LTrim$(Str$(move(0, mi).sc - move(0, Moves(0)).sc * 0)) + _PrintString (x, y + 20), Str$(ksv(c, r)) + nu(c, r) = nu(c, r) + 1 + Next mi + Next p + waituntil = ExtendedTimer + 5 + + SetFont defaultfontsize + If dev Then _PrintString (tlx, 10), LTrim$(Str$(CanMove(0))) + Str$(CanMove(1)) + + Do: _Limit 10 + KeyScan + If i$ = Enter$ Then Exit Do + If Len(i$) Then GoTo begin + Loop Until (sob = 0) Or ((sob = 2) And (ExtendedTimer > waituntil)) +End Sub + +Sub ScreenInit + Dim i, scx, scy + + ' Worldwide desktop stats + ' 1920x1080 21.04 + ' 1366x768 20.48 + ' 1536x864 10.05 + ' 1440x900 6.17 + ' 1280x720 5.79 + ' 1600x900 3.68 + + If (NoChangeUntil > 0) And (ExtendedTimer < NoChangeUntil) Then Exit Sub + + xm = 480 + ym = 600 + scx = 800 + scy = 600 + + If mscreen < -1 Then + Screen 0 + _FreeImage mscreen + End If + mscreen = _NewImage(scx, scy, 32) + Screen mscreen + Do: _Limit 10: Loop Until _ScreenExists + + Do + If fullscreenflag > 0 Then + If fullscreenflag = 2 Then + _FullScreen _SquarePixels , _Smooth + Else + _FullScreen _Stretch , _Smooth + End If + Else + _FullScreen _Off + End If + _Delay .2 + Loop Until fullscreenflag = _FullScreen + + While _Resize + _Delay .1 + Wend + + If fullscreenflag = 0 Then + For i = 0 To 4 + _ScreenMove (_DesktopWidth - _Width) \ 2, 25 + _Delay .1 + Next i + End If + + If tlx > 0 Then + If mscreenr < -1 Then _FreeImage mscreenr + If _FullScreen Then i = _Height Else i = _Height * 1.33 + mscreenr = _NewImage((trx - tlx) * 1.64, i) + End If + + If pregame = false Then PlotScreen false + NoChangeUntil = ExtendedTimer + 2 +End Sub + +DefSng A-Z +Sub Serp + Dim i, xinit, ho, tx, ty, a, b, h, sp, ps, tp, x, y, tb + Dim tc As _Unsigned Long, st(10) + GoSub 100 + Exit Sub + + 100: ho = 598: sp = 0: h = ho / 4: x = 2 * h: y = 3 * h: i = 0 + 110: i = i + 1: x = x - h: h = h / 2: y = y + h: If i < 6 Then GoTo 110 + ps = i: GoSub 600 + GoSub 200: a = h: b = -h: GoSub 800 + GoSub 300: a = -h: b = -h: GoSub 800 + GoSub 400: a = -h: b = h: GoSub 800 + GoSub 500: a = h: b = h: GoSub 800 + GoSub 700 + Return + 200: If tp <= 0 Then Return + ps = tp - 1: GoSub 600 + GoSub 200: a = h: b = -h: GoSub 800 + GoSub 300: a = 2 * h: b = 0: GoSub 800 + GoSub 500: a = h: b = h: GoSub 800 + GoSub 200: GoSub 700 + Return + 300: If tp <= 0 Then Return + ps = tp - 1: GoSub 600 + GoSub 300: a = -h: b = -h: GoSub 800 + GoSub 400: a = 0: b = -2 * h: GoSub 800 + GoSub 200: a = h: b = -h: GoSub 800 + GoSub 300: GoSub 700 + Return + 400: If tp <= 0 Then Return + ps = tp - 1: GoSub 600 + GoSub 400: a = -h: b = h: GoSub 800 + GoSub 500: a = -2 * h: b = 0: GoSub 800 + GoSub 300: a = -h: b = -h: GoSub 800 + GoSub 400: GoSub 700 + Return + 500: If tp <= 0 Then Return + ps = tp - 1: GoSub 600 + GoSub 500: a = h: b = h: GoSub 800 + GoSub 200: a = 0: b = 2 * h: GoSub 800 + GoSub 400: a = -h: b = h: GoSub 800 + GoSub 500: GoSub 700 + Return + 600: sp = sp + 1: st(sp) = ps: tp = ps + Return + 700: sp = sp - 1: tp = st(sp) + Return + 800: + tx = 10 + (x + a) * 1.3 + ty = 34 + y + b + tb = 220 * Cos(_D2R(ty / _Height * 90)) + tc = Point(1, 500) + tc = _RGBA(_Red32(tc) \ 2, _Green32(tc) \ 2, _Blue32(tc) \ 1, tb) + If xinit = 0 Then PSet (tx, ty), tc: xinit = 1 + Line -(tx, ty), tc + x = x + a: y = y + b + Return +End Sub + +DefLng A-Z +Sub SetFont (fontsize As _Byte) + If myfont(fontsize) < 1 Then QuitWithError "Font", Str$(fontsize) + _Font myfont(fontsize) +End Sub + +Sub SetScheme + Dim a, c1, c2, c3, ct, ps, g, st, was + + was = piece_style + st = 1 ' single line box for most schemes + + Select Case scheme + Case 0: a = 0: bgc = 2: c1 = 24: c2 = 25: c3 = 5: ct = 1: ps = 9: g = 2 ' gray/dark gray on blue, black font clock, plasma bl sq + Case 1: a = 1: bgc = 2: c1 = 26: c2 = 13: c3 = 4: ct = 1: ps = 8: g = 3: st = 3 ' white/purple on blue, white 7 seg clock, plasma ALL sq + Case 2: a = 2: bgc = 5: c1 = 19: c2 = 20: c3 = 5: ct = 1: ps = 7: g = 3: st = 2 ' cream/brown on white, black 7 seg clock, plasma ALL sq + Case 3: a = 3: bgc = 0: c1 = 26: c2 = 25: c3 = 5: ct = 1: ps = 9: g = 2 ' white/dark gray on red, black 7 segment clock, plasma bl sq + Case 4: a = 0: bgc = 4: c1 = 17: c2 = 20: c3 = 2: ct = 2: ps = 6: g = 3: st = 0 ' yellow/brown with Nixie, plasma all squares, plasma ALL sq + Case 5: a = 1: bgc = 5: c1 = 24: c2 = 30: c3 = 0: ct = 0: ps = 2: g = 0 ' gray/white on white, red font clock, plasma off + Case 6: a = 2: bgc = 4: c1 = 17: c2 = 25: c3 = 4: ct = 0: ps = 4: g = 3 ' flame/dk gray on yellow, white font clock, plasma ALL sq + Case 7: a = 3: bgc = 2: c1 = 10: c2 = 11: c3 = 3: ct = 0: ps = 3: g = 3 ' gunmetal/sky blue on blue, blue font clock, plasma ALL sq + Case 8: a = 0: bgc = 3: c1 = 10: c2 = 14: c3 = 4: ct = 1: ps = 6: g = 1 ' gunmetal/dark purple on cyan, black font clock, plasma wh sq + Case 9: a = 1: bgc = 1: c1 = 26: c2 = 23: c3 = 0: ct = 0: ps = 8: g = 3: st = 3 ' white/green on green, red font clock, plasma ALL sq + Case 10: a = 2: bgc = 0: c1 = 13: c2 = 25: c3 = 5: ct = 1: ps = 8: g = 3: st = 3 'lt pur/dk gray on red,black 7 seg clock, plasma ALL sq + Case 11: a = 3: bgc = 0: c1 = 27: c2 = 25: c3 = 4: ct = 0: ps = 0: g = 3 ' pink/dk gray on red, white font clock, plasma ALL sq + End Select + + colori1 = c1 - 10 + colori2 = c2 - 10 + colori3 = c3 + clocktype = ct + piece_style = ps + graphics = g + squaretrim = st + altbg = a + + ColorSet + If piece_style <> was Then LoadPieces piece_style +End Sub + +Sub Settings Static + Dim i, j, se, wasse, xw, x1, x2, y1, y2, yw, xx0, xx1, yy1, kk, t$, arrows$, shortcut$, mi$(30), se$(30) + Dim z1, z2, mz1, smx, smy, obri, exitn, tscreen, tscreen2, sfontsize, xbox, freeze + Dim As _Unsigned Long twhite, tgray + + If xmas Then ' enough of the red/green blinking squares already! + xmas = false + graphics = true + ColorSet + End If + + If inhelp Or insettings Then Exit Sub + + insettings = true + + istuff$ = " " + tgray = _RGB32(80, 80, 80) + twhite = _RGB32(200, 200, 200) + + exitn = 23 ' + sfontsize = 9 ' larger and the pieces on the home row are obscured + SetFont sfontsize + xw = 16 * _PrintWidth("z") ' x width + z2 = _FontHeight + _FontHeight \ 3 ' line spacing + yw = z2 / 2 * (exitn + 2) ' y width + + x1 = xc - xw ' box left + x2 = xc + xw ' box right + + y1 = _Height \ 2 - yw - 40 ' box top + y2 = _Height \ 2 + yw - 40 ' box bottom + + z1 = y1 ' 1st line y + arrows$ = Chr$(17) + Chr$(16) ' left and right arrow + mz1 = x2 - 4 - _PrintWidth(arrows$) + + mi$(Val("01")) = "White squares:" + mi$(Val("02")) = "Black squares:" + mi$(Val("03")) = " Clock color:" + mi$(Val("04")) = " Background:" + mi$(Val("05")) = " BG Color:" + mi$(Val("06")) = " Clock type:" + mi$(Val("07")) = " Graphics:" + mi$(Val("08")) = " Brightness:" + mi$(Val("09")) = " Chess set:" + mi$(Val("10")) = " Square trim:" + mi$(Val("11")) = " Invert:" + mi$(Val("12")) = " Mouse cursor:" + mi$(Val("13")) = " Legend:" + mi$(Val("14")) = " Logging:" + mi$(Val("15")) = " Markers:" + mi$(Val("16")) = " Move clock:" + mi$(Val("17")) = " Sounds:" + mi$(Val("18")) = " Mouse click:" + mi$(Val("19")) = " Hover move:" + mi$(Val("20")) = " Rotation:" + mi$(Val("21")) = " Board setup:" + mi$(Val("22")) = "File playback:" + mi$(Val("23")) = "Exit" + + For se = 1 To exitn + GoSub curset + Next se + se = 0 + + startover: + + PlotScreen false + Line (x1, y1)-(x2, y2), _RGBA(0, 0, 0, 230), BF ' dim area for menu + 'Line (0, _Height - 19)-(_Width - 1, _Height - 1), black, BF + If _FullScreen Then nbox = 4 Else nbox = 0 + + For i = 1 To exitn + SetFont sfontsize + xx0 = xc + 8 ' just left of the colon + If i < exitn Then + xx1 = xx0 - _PrintWidth(mi$(i)) - 6 ' where description goes + yy1 = z1 + i * z2 + Else ' exit + xx1 = xc - _PrintWidth("Exit") / 2 ' centered + yy1 = y2 - 20 ' lower than general items + End If + + For j = 1 To 2 + nbox = nbox + 1 + mfx1(nbox) = mz1 + (j - 1) * 10 + 1 + mfx2(nbox) = mfx1(nbox) + 10 + mfy1(nbox) = yy1 + mfy2(nbox) = yy1 + 12 + mft$(nbox) = Chr$(0) + Chr$(77 + (j = 1) * 2) ' left or right arrow + Next j + xbox = nbox + chimp = nbox + + Color tgray, zip + _PrintString (xx1, yy1), mi$(i) ' description + Color twhite, zip + _PrintString (xx0, yy1), se$(i) ' setting + Color tgray, zip + _PrintString (mz1, yy1), arrows$ ' arrows + Next i + + If tscreen < -1 Then _FreeImage (tscreen) + tscreen = _CopyImage(0) + If se = 0 Then + PlotScreen false + WindowEffect 0, tscreen, x1, y1, x2, y2 ' 0zoom 1unfold 2random 3fade + se = 1 + End If + + _PutImage , tscreen, 0 + + shortcut$ = " " + If se = 6 Then ' clock type + shortcut$ = "Shortcut : c or t" + ElseIf se = 8 Then ' brightness + shortcut$ = "Shortcut : F4- F5+" + ElseIf se = 9 Then ' set (10 to choose from) + If piece_style Then + shortcut$ = "z to see all sets" + Else + shortcut$ = "Z to see all pictures" + End If + ElseIf (se = 10) And (piece_style = 0) Then ' square trim (4 choices) + shortcut$ = "Inactive for funny set" + ElseIf se = 11 Then ' invert board or pieces for human vs human + shortcut$ = "for Human vs Human play" + ElseIf se = 20 Then ' rotation + shortcut$ = "Shortcut : F11- F12+" + ElseIf se < exitn Then ' mention short key, if any + ' 123456789012345678901 + t$ = Mid$("12354c B Cl men H F ", se, 1) + If t$ <> " " Then shortcut$ = "Shortcut : " + t$ + End If + + SetFont sfontsize + If se < exitn Then + xx1 = xx0 - _PrintWidth(mi$(se)) - 6 ' where description goes + yy1 = z1 + se * z2 + Else ' exit + xx1 = xc - _PrintWidth("Exit") / 2 ' centered + yy1 = y2 - 20 ' lower than general items + End If + Line (x1 + 4, yy1 - 3)-(x2 - 4, yy1 + _FontHeight), tgray, BF + ShadowPrint xx1, yy1, mi$(se), twhite ' description + ShadowPrint xx0, yy1, se$(se), twhite ' setting + ShadowPrint mz1, yy1, arrows$, twhite ' arrows + + _PutImage (blx, bly + 20)-(brx, _Height - 20), bgi, 0, (blx, bly + 20)-(brx, _Height - 20) + If tscreen2 < -1 Then _FreeImage (tscreen2) + tscreen2 = _CopyImage(0) + + Do: _Limit mloop + _PutImage , tscreen2, 0 + i$ = InKey$ + If dev And (i$ = "q") Then Quit + If i$ = "z" Then ShowSets: Exit Do + If i$ = "Z" Then ShowFunny: Exit Do + smx = mx: smy = my + + TempMess$ = shortcut$ + s$ + AboveBoardInfo + GraphLoad + Clocks + nbox = chimp + MouseIn + If Len(istuff$) Then i$ = istuff$: istuff$ = "" + If (b1 Or b2) And (mx > x1) And (mx < x2) And (my > y1) And (my < y2) Then i$ = Enter$ + + If freeze Then + freeze = false + smx = mx + smy = my + End If + + If (mx <> smx) Or (my <> smy) Then + wasse = se + If (mx > x1) And (mx < x2) And (my > y1) And (my < y2) Then ' mouse in box? + se = (my - z1) \ z2 + If se < 1 Then se = 1 + If se > exitn Then se = exitn ' select exit + If se <> wasse Then Exit Do + End If + End If + Loop Until Len(i$) + + If (i$ = "e") Or (i$ = Esc$) Then GoTo done + If i$ = Enter$ Then + If se = exitn Then GoTo done ' Enter on Exit + i$ = Chr$(0) + Chr$(77) ' xlate Enter to right arrow + End If + + If Len(i$) = 2 Then + kk = Asc(i$, 2) + se = se + (kk = 72) - (kk = 80) ' up and down arrow move between menu items + If se < 1 Then se = exitn ' wraparound + If se > exitn Then se = 1 + If (kk = 72) Or (kk = 80) Then GoTo startover + kk = (kk = 75) - (kk = 77) ' left and right change highlighted item + If kk <> 0 Then + Select Case se + Case 1 ' white squares + colori1 = colori1 + kk + If colori1 < 0 Then colori1 = 21 + If colori1 > 21 Then colori1 = 0 + ColorSet + Case 2 ' black squares + colori2 = colori2 + kk + If colori2 < 0 Then colori2 = 21 + If colori2 > 21 Then colori2 = 0 + ColorSet + Case 3 ' clock color + colori3 = colori3 + kk + If colori3 < 0 Then colori3 = 5 + If colori3 > 5 Then colori3 = 0 + ColorSet + Case 4 ' background type + altbg = altbg + kk + If altbg < 0 Then altbg = bgmax + If altbg > bgmax Then altbg = 0 + ColorSet + Case 5 ' background color + bgc = bgc + kk + If bgc < 0 Then bgc = 5 + If bgc > 5 Then bgc = 0 + ColorSet + Case 6 + clocktype = clocktype + kk + If clocktype < 0 Then clocktype = 2 + If clocktype > 2 Then clocktype = 0 + Case 7 ' plasma effect + graphics = graphics + kk ' 0 off, 1 white, 2 black, 3 all squares + If graphics < 0 Then graphics = 3 + If graphics > 3 Then graphics = 0 + plasma_init = false ' generate new parameters + Case 8 ' + obri = bri + bri = bri + kk + If bri < 1 Then bri = 1 + If bri > 4 Then bri = 4 + If bri <> obri Then + ColorSet + Erase sloaded + allsetsloaded = false + LoadPieces piece_style + End If + Case 9 + piece_style = piece_style + kk + If piece_style < 0 Then piece_style = 9 + If piece_style > 9 Then piece_style = 0 + LoadPieces piece_style + lpoints = -1 + Case 10 ' square borders + If piece_style Then ' inactive for set 0 (funny) + squaretrim = squaretrim + kk * Sgn(piece_style) + If squaretrim < 0 Then squaretrim = 3 + If squaretrim > 3 Then squaretrim = 0 + End If + Case 11 ' invert type + binvert = binvert Xor 1 + Case 12 + cursortype = cursortype + kk + If cursortype < 0 Then cursortype = 3 + If cursortype > 3 Then cursortype = 0 + _MouseShow RTrim$(Mid$("LINK CROSSHAIRTEXT DEFAULT ", cursortype * 9 + 1, 9)) + _MouseMove 1, 1 + _MouseMove mx, my + Case 13 ' 1-8 on left, a-h at bottom + legend = legend Xor 1 + Case 14 ' true flag for saving game to disk + logging = logging Xor 1 + Case 15 ' highlight last move + markers = markers Xor 1 + Case 16 ' time of current move + smallclock = smallclock Xor 1 + Case 17 ' sounds + makenoise = makenoise Xor 1 + LoadSounds + If makenoise Then + PlaySound sfile(1) ' play intro music + Else + click = false + If _SndPlaying(sfile(1)) < 0 Then _SndStop sfile(1) ' stop intro music + End If + Case 18 ' = move click + click = click Xor 1 + If (makenoise = 0) And (click = 1) Then + makenoise = true + PlaySound sfile(1) ' play intro music + End If + Case 19 ' move by hovering over square + hover = hover Xor 1 + Case 20 ' rotation + rotate = rotate + kk + If rotate < 0 Then rotate = 3 + If rotate > 3 Then rotate = 0 + freeze = true + Case 21 ' testing, doing a problem, cheating, whatever + If rflag Then ' disallow board setup while computer moving + TempMess$ = "Thinking!" + AboveBoardInfo + DisplayMaster true + _Delay .5 + Else + insettings = false + Setup + redoflag = 1 + GoTo done + End If + Case 22 ' replay of stored game + If rflag Then ' disallow while computer moving + TempMess$ = "Thinking!" + AboveBoardInfo + DisplayMaster true + _Delay .5 + Else + insettings = false + PlotScreen false + PlayFile + ClearBuffers + GoTo done + End If + Case 23 ' exit + GoTo done + End Select + End If + End If + GoSub curset + GoTo startover + + done: + oply = false + chimp = 0 + nbox = 0 + TempMess$ = " " + ClearBuffers + insettings = false + PlotScreen true + Exit Sub + + curset: + Select Case se + Case 1: t$ = ColorDesc$(colori1 + 10) ' white squares color + Case 2: t$ = ColorDesc$(colori2 + 10) ' black squares color + Case 3: t$ = Mid$("Red Green Yellow Blue White Black ", colori3 * 7 + 1, 7) ' clock color + Case 4: t$ = Mid$("HexagonSquaresSierp Shaded Off CheetosF-loops", altbg * 7 + 1, 7) ' background type + Case 5: t$ = Mid$("Red Green Blue Cyan YellowWhite ", bgc * 6 + 1, 6) ' background color + Case 6: t$ = RTrim$(Mid$("Font 7 segment Nixie tube", clocktype * 10 + 1, 10)) ' clock type: 0 font 1 7-seg 2 Nixie + Case 7: t$ = Mid$("OFF W Sq B Sq All sq", graphics * 6 + 1, 6) ' plasma graphics off/white sq/black sq/both + Case 8: t$ = LTrim$(Str$(bri)) + " of 4" ' brightness + Case 9: t$ = LTrim$(Str$(piece_style + 1)) + " of 10" ' set selection 1funny 2ugly 3 best... + Case 10: t$ = Mid$("OFF SingleDoubleFancy ", squaretrim * 6 + 1, 6) ' square trim style + Case 11: t$ = LTrim$(Mid$("ScreenBoard ", binvert * 6 + 1, 6)) ' invert board or pieces for human vs human + Case 12: t$ = RTrim$(Mid$("Link Cross Text Arrow ", cursortype * 6 + 1, 6)) ' cursor type + Case 13: t$ = OnOff(legend) ' a-h at bottom, 1-8 along left side + Case 14: t$ = OnOff(logging) ' save game to disk file chNNNNNN.alg + Case 15: t$ = OnOff(markers) ' highlight last move + Case 16: t$ = OnOff(smallclock) ' elapsed time current move + Case 17: t$ = OnOff(makenoise) ' sound in general + Case 18: t$ = OnOff(click) ' mouse button noise + Case 19: t$ = OnOff(hover) ' move by hovering over square + Case 20: t$ = Mid$("OFF-9018090 ", rotate * 3 + 1, 3) ' vacuum cleaner + Case 21: t$ = "SET" ' create board position + Case 22: t$ = "FILE" ' file playback + Case 23: t$ = "" ' toodaloo + End Select + se$(se) = t$ + Return +End Sub + +Sub Setup + Dim i, j, ps, p, kc, x, y, z, xs, ys, tx, xx, yy, t$, mx1(14), mx2(14), my1(14), my2(14), ic(1) ' + + invert = 0 + xs = 32: ys = xs ' size of pieces shown here + insetup = true ' flag for other SUBs + Do: _Limit 10 + _PutImage , bgi, 0 + GraphLoad + For i = 0 To 1 + WorB = i + Reset_To_Zero + Fking false ' counts up the pieces + ic(i) = incheck + Next i + WorB = 1 + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' working b() to display board b2() + PlotBoard ' squares & contents + If graphics Then Plasma tlx, tly, trx, bly, 0 ' marble effect on board + GoSub piece_menu ' 6 black on top, 6 white on bottom + + Color gray, black + SetFont 12 + t$ = "Place: Click piece then square Clear: Click square" + tx = xc - _PrintWidth(t$) \ 2 + ShadowPrint tx, _Height - _FontHeight * 4, t$, white + kc = -(pcount(0, King) = 1) - (pcount(1, King) = 1) ' enforce one King per side + t$ = " Clear Full" + s$ + "set Random Esc" + s$ + "to" + s$ + "exit " + Center 0, t$, true, false + GoSub selectpiece ' selecting a square clears it + If ps > 0 Then GoSub showmoving ' piece selected, show at mouse cursor + KeyScan + + If b1 Or b2 Then ' mouse button left or right + xx = (mx - tlx + hxq - 1) / xq + yy = (my - tly + hyq - 1) / yq + If (xx > 0) And (xx < 9) And (yy > 0) And (yy < 9) Then ' on the board + b(xx, 9 - yy) = ps ' put piece on board + _Delay .25 ' try to prevent immediately clearing the square + End If + ps = 0 ' clear piece selected + End If + If i$ = "" Then i$ = "*" ' unwise to use instr with null + If InStr("eE", i$) Then i$ = Esc$ ' says (E)sc on screen, translate to Esc + If i$ = "c" Then Erase b + If i$ = "f" Then ReadBoard + If i$ = "r" Then GoSub RandomPosition + If i$ = Esc$ Then ' wants to leave + If kc <> 2 Then ' doesn't have 1 King per side + Line (0, bly + xs + 3)-(_Width - 1, _Height - 20), black, BF + t$ = "One King per side" + _PrintString (cx(t$), _Height - _FontHeight * 4), t$ + PlaySound illegal + DisplayMaster true + _Delay 2 + ElseIf (ic(0) = true) And (ic(1) = true) Then ' both Kings in check + Line (0, bly + xs + 3)-(_Width - 1, _Height - 20), black, BF + t$ = "Both Kings in check" + _PrintString (cx(t$), _Height - _FontHeight * 4), t$ + PlaySound illegal + DisplayMaster true + _Delay 2 + kc = 0 ' King count + End If + End If + Loop Until (i$ = Esc$) And (kc = 2) + + insetup = false + _Delay .2 ' try to prevent user selecting W/B by accident + + castle$ = "****" + check = 0 + incheck = 0 + drawcount = 0 + perpetual = 0 + readonly = true + noresign = true + move = 0 + Erase mlog$ + start = ExtendedTimer + Erase etime + + GetWB + WorB = humanc ' assume it's my move + If (humanc = 0) And ic(1) Then WorB = 1 ' want black, white in check, must be white's move + If (humanc = 1) And ic(0) Then WorB = 0 ' want white, black in check, must be black's move + + SaveWorB = WorB + If WorB = 0 Then ' black to move, put a spacer in the log for white + WorB = 1 + m$ = " " + AddLog + WorB = 0 + End If + nbox = chimp + Exit Sub + + RandomPosition: + Do + Erase b + For i = 0 To 1 + z = i * 8 + For j = 10 To 1 Step -1 + p = Rnd * 5 + 1 + z + If ((p And 7) = King) Or (Rnd > .4) Then p = 0 + If Rnd > .7 Then p = Pawn + z + If j = 1 Then p = King + z + nr: + xx = Rnd * 7 + 1 + yy = Rnd * 7 + 1 + If b(xx, 9 - yy) Then GoTo nr + If (p = Pawn + 0) And (yy > 7) Then p = 0 ' black pawn on rank 8 + If (p = Pawn + 0) And (yy < 2) Then p = 0 ' black pawn on rank 1 + If (p = Pawn + 8) And (yy < 2) Then p = 0 ' white pawn on rank 1 + If (p = Pawn + 8) And (yy > 7) Then p = 0 ' white pawn on rank 8 + b(xx, 9 - yy) = p + Next j + Next i + Fking false + kc = -(pcount(0, King) = 1) - (pcount(1, King) = 1) + If (Abs(wkr - bkr) < 2) And (Abs(wkc - bkc) < 2) Then kc = 0 + Loop Until kc = 2 + Return + + showmoving: + z = PieceSize(ps) ' piece size adjustments + _PutImage (mx - hxq + z, my - hyq + z)-(mx + hxq - z, my + hyq - z), pix(piece_style, ps), 0 + Return + + selectpiece: + For i = 0 To 1 ' black (top), white (bottom) + For j = 1 To 6 ' RNBQKP + p = i * 8 + j ' add 8 for white + If (mx > mx1(p)) And (mx < mx2(p)) And (my > my1(p)) And (my < my2(p)) Then ' mouse on this piece? + Line (mx1(p), my1(p))-(mx2(p), my2(p)), white, B ' box around piece where mouse is + If b1 Or b2 Then _Delay .25: ps = p ' piece selected by mouse button + End If + Next j + Next i + Return + + piece_menu: + For i = tlx + 1 To trx - 1 + j = 200 - Abs((tlx + trx) \ 2 - i) + If j < 0 Then j = 0 + If pcount(0, King) = 1 Then c1 = _RGB32(0, j, 0) Else c1 = _RGB32(j, 0, 0) ' green for ok, red for not + Line (i, 0)-(i, try - 1), c1 + If pcount(1, King) = 1 Then c1 = _RGB32(0, j, 0) Else c1 = _RGB32(j, 0, 0) ' + Line (i, bly + 1)-(i, bly + xs + 2), c1 + Next i + If _FullScreen Then Buttons 0, 0 + For i = 0 To 1 ' black, white + If i Then ' white + y = bly + 2 ' below board + j = points(1) - points(0) + Else ' black + y = 1 ' above board + j = points(0) - points(1) + End If + If pcount(i, King) = 1 Then c1 = green Else c1 = red + Color c1, zip + t$ = LTrim$(Str$(j)) + If ic(i) Then t$ = t$ + ", in check" + + SetFont 10 + ShadowPrint tlx + 8, y + 11, t$, white + + For j = 1 To 6 ' RNBQKP + p = i * 8 + j ' + x = xc + (j - 4) * (xs + 2) + _PutImage (x, y)-(x + xs, y + ys), pix(piece_style, p), 0 ' show piece + mx1(p) = x ' save location so mouse can find it + mx2(p) = x + xs ' + my1(p) = y ' + my2(p) = y + ys ' + Next j + Next i + Return +End Sub + +Sub SetupBoard + ReadBoard + drawcount = 0 + If testing Then move = 20 Else move = 0 + perpetual = 0 +End Sub + +Sub ShowBolt () + Static binit, i + Dim tempimg, f$ + + If insettings Then Exit Sub + + If barebones And (promoting = false) Then + If onplayback Then + boltx1 = blx + 10 + Else + boltx1 = xc - 15 + End If + bolty1 = bly + 30 + Else + boltx1 = tlx - 60 + bolty1 = bly - 102 + End If + boltx2 = boltx1 + 30 + bolty2 = bolty1 + 30 + + If binit = false Then + For i = 0 To 1 + f$ = datapath$ + "lb\lb" + Chr$(48 + i) + ".png" + If _FileExists(f$) = 0 Then QuitWithError "bolt", "fnf " + f$ + tempimg = _LoadImage(f$) + If tempimg >= -1 Then QuitWithError "bolt", "load image" + bolt(i) = _NewImage(31, 31, 32) + _PutImage , tempimg, bolt(i) + _Source bolt(i) + cc(i) = Point(0, 0) + _Source 0 + _FreeImage tempimg + Next i + binit = true + End If + + _ClearColor cc(barebones), bolt(barebones) + _PutImage (boltx1, bolty1)-(boltx2, bolty2), bolt(barebones), 0 +End Sub + +Sub ShadowBox (x1, y1, x2, y2) + Line (x2 + 1, y1)-(x2 + 1, y2 + 1), black ' right side + Line (x1 + 1, y2 + 1)-(x2 + 1, y2 + 1), black ' underneath +End Sub + +Sub ShadowPrint (x, y, t$, tcm As _Unsigned Long) + 'TimeTrack "ShadowPrint", 1 + If tcm <> black Then + Color black, zip + _PrintString (x + 1, y + 1), t$ + _PrintString (x + 2, y + 1), t$ + End If + Color tcm, zip + _PrintString (x, y), t$ + 'TimeTrack "ShadowPrint", 0 +End Sub + +Sub ShowFunny + Dim i, n, ti, xs, xq, yq, x, y, sf, tscreen, p$, t$ + + Cls + _Display + sf = fullscreenflag + inshow = 2 + xm = 1280: ym = 768 ' room for 112 pictures + + tscreen = _NewImage(xm, ym, 32) + Screen tscreen + Do: _Limit 10: Loop Until _ScreenExists + For i = 0 To 4 + _FullScreen _Stretch , _Smooth + Next i + x = (_DesktopWidth - _Width) \ 2 + y = (_DesktopHeight - _Height) \ 2 + For i = 0 To 4 + _ScreenMove x, y + Next i + Cls + Buttons 0, 0 + + xs = 40: x = xs: y = 30: xq = 85: yq = 76 + SetFont 10 + For i = 1 To 6 + p$ = RTrim$(Mid$("rook knightbishopqueen king pawn ", (i - 1) * 6 + 1, 6)) + n = 0 + Do + n = n + 1 + f$ = UCase$(datapath$ + "sfunny" + slash + p$ + LTrim$(Str$(n)) + ".jpg") + If _FileExists(f$) = 0 Then Exit Do + fload: + ti = _LoadImage(f$) + If ti >= -1 Then _Delay .1: GoTo fload ' load fail + _PutImage (x, y)-(x + xq, y + yq), ti, 0 + DisplayMaster true + If i = 2 Then t$ = "N" Else t$ = p$ ' change K to N for knight + t$ = UCase$(Left$(t$, 1)) + Str$(n) + Color _RGBA(0, 0, 0, 255), zip + _PrintString (x, y), t$ ' print in black at top left + Color _RGBA(255, 255, 255, 255), zip + _PrintString (x + xq - _PrintWidth(t$), y), t$ ' print in white at top right + x = x + xq + If (x + xq) > xm Then + x = xs + y = y + yq + If (y + yq) > ym Then GoTo done + End If + Loop + Next i + done: + + SetFont 18 + Color white, black + t$ = "Cycle images in play with spacebar" + SetFont 14 + x = _Width \ 2 - _PrintWidth(t$) \ 2 + 8 + _PrintString (x, _Height - 36), t$ + AnyKey + + Cls + _Display + Screen 0 + _FreeImage tscreen + inshow = false + fullscreenflag = sf + ScreenInit +End Sub + +Sub ShowLegend ' a-h, 1-8 along sides + Dim i, x, z + + SetFont 9 + For i = 1 To 8 + If invert Then z = i Else z = 9 - i ' board inverted (black at bottom) + If (rotate = 1) Or (rotate = 3) Then x = tlx + 3 Else x = tlx - 8 + ShadowPrint x, tly + i * yq - 30, CHRN$(z), boardwhite ' 1 - 8 + ShadowPrint brx - (i - 1) * xq - 25, bly + 4, alphal$(z), boardwhite ' a - h + Next i +End Sub + +Sub ShowPoints ' ahead or behind points shown top left + Dim k, drawblinkf + + If pregame Or promoting Then Exit Sub + If (colori3 = 3) Or (colori3 = 5) Then c1 = white Else c1 = clockc + + k = points(1) - points(0) + If k <> 0 Then + If (human = 0) And (invert = 1) Then k = -k ' computer vs computer + If (human = 1) And (humanc = 0) Then k = -k ' computer vs human + If (human = 2) And (WorB = 0) Then k = -k ' human vs human + TinyFont LTrim$(Str$(k)), tlx + 2, 27, c1 + End If + + If (perpetual > 0) Or (drawcount > 39) Then + If (drawblink = 0) Or (ExtendedTimer > drawblink) Then + drawblink = ExtendedTimer + .25 + drawblinkf = drawblinkf Xor 1 + End If + Else + drawblinkf = 1 + End If + If drawblinkf And (insettings = false) Then TinyFont Str$(perpetual) + ":" + LTrim$(Str$(drawcount)), tlx + 30, 27, c1 +End Sub + +Sub ShowSets + Dim i, j, k, p, x, y, z, sx1, sx2, sy, tscreen, t$, was_style + + If inshow Then Exit Sub + inshow = true + was_style = piece_style + sx1 = 80 + sx2 = 430 + sy = 12 + Cls + nbox = 4 + Buttons 0, 0 + SetFont defaultfontsize + + For piece_style = 0 To 9 + If sloaded(piece_style) = false Then + tscreen = _CopyImage(0) + LoadPieces piece_style + Cls + _PutImage , tscreen, 0 + _FreeImage tscreen + End If + For i = 0 To 1 + t$ = Str$(piece_style + 1) + " " + Mid$("WB", i + 1, 1) + z = 38 - (piece_style > 8) * 10 + If piece_style < 5 Then + x = sx1 - z + y = sy + (piece_style * 2 + i) * yq + yq \ 2 - 4 + Else + x = sx2 - z + y = sy + ((piece_style - 5) * 2 + i) * yq + yq \ 2 - 4 + End If + ShadowPrint x + 4, y, t$, white + For j = 1 To 6 + k = Val(Mid$("541236", j, 1)) + If piece_style < 5 Then + x = sx1 + (j - 1) * xq + y = sy + (piece_style * 2 + i) * yq + Else + x = sx2 + (j - 1) * xq + y = sy + ((piece_style - 5) * 2 + i) * yq + End If + p = k + (1 - i) * 8 + If piece_style Mod 2 Then c1 = boardblack Else c1 = boardwhite + Line (x, y)-(x + xq, y + yq), c1, BF + z = PieceSize(j) + _PutImage (x + z, y + z)-(x + xq - z, y + yq - z), pix(piece_style, p), 0 + If rotate = 0 Then _Display + Next j + If dev Then ' show size adjustments + 'TinyFont Str$(PieceSize(King)), x + xq + 2, y + 20, red + 'TinyFont Str$(PieceSize(Pawn)), x + xq + 2, y + 27, red + Color red + SetFont 12 + _PrintString (x + xq + 6, y + 20), Str$(PieceSize(King)) + _PrintString (x + xq + 6, y + 32), Str$(PieceSize(Pawn)) + End If + Next i + Next piece_style + + AnyKey + + piece_style = was_style + inshow = false +End Sub + +Sub ShowTaken (showit As _Byte) + Static lscreen, tpoints(1), tt + Dim As _Byte np, s, c, i, j, k, p, pob, tc, tr + Dim x, y, z, zx, zy, sx, sy, t, yint, t$, u$, side$, td!, tbri! + + If barebones Or (rotate = 1) Or (rotate = 3) Then Exit Sub + + 'TimeTrack "ShowTaken", 1 + + pob = points(0) + points(1) ' points on board + If ptaken > 0 Then lpoints = -1 ' highlighting last piece moved + If (pob = 78) And (lpoints <> -1) Then GoTo sexit ' no pieces taken + + If pob = lpoints Then + _PutImage (10, tly)-(tlx - 20, 358), lscreen, 0, (10, tly)-(tlx - 20, 358) + GoTo sexit + End If + lpoints = pob + + tbri! = bri * .25 + zx = 34 ' spacing + zy = 36 + sx = tlx - 60 ' start position master + sy = try + 2 + y = sy + + tpoints(0) = 0: tpoints(1) = 0 ' SHOULD become same as points() + + For j = 1 To 5 + k = Val(Mid$("41326", j, 1)) ' QRBNP + x = sx + For i = 0 To 1 ' black, white + p = k + i * 8 ' piece + c = 0 ' count of piece type + For tc = 1 To 8 ' column + For tr = 1 To 8 ' row + c = c - (b(tc, tr) = p) ' + Next tr + Next tc + onboard(p) = c + + c = Val(Mid$("12228", j, 1)) - c ' should be - what is + s = c + t = t + c ' total pieces taken + tpoints(i) = tpoints(i) + value(k) * c \ mult ' to show equal/up/down + If showit = false Then c = 0 + np = 0 + + While c > 0 ' how many of this piece taken + + If ExtendedTimer > ptakent Then ptakent = 0: ptaken = 0 + + For z = 1 To 18 ' shaded circle background + c1 = (20 - z) * 10 + If (c = 1) And (p = ptaken) And (ptcc < c1) Then c2 = ptcc Else c2 = c1 + c1 = c1 * tbri! + c2 = c2 * tbri! + c1 = _RGB32(c1, c2, c2) + Circle (x + zx \ 2 + 0, y + zy \ 2), z, c1 + Circle (x + zx \ 2 + 1, y + zy \ 2), z, c1 + Next z + + If (c = 1) And (p = ptaken) Then ' on highlighted piece + ptcc = ptcc + 2 + onplayback * 2 ' diminish red, twice as fast in playback + If ptcc > 255 Then ptcc = 255 + End If + + z = PieceSize(p) + _PutImage (x + z, y + z)-(x + zx - z, y + zy - z), pix(piece_style, p), 0 + If (piece_style = 0) And (i = 0) Then Line (x, y)-Step(zx, zy), gray, B + x = x - zx - 4 + If k = Pawn Then + np = np + 1 + If (np = 4) And (c > 1) Then x = sx: y = y + zy + 4 + End If + c = c - 1 ' counter + Wend + If (k = Pawn) And (s > 0) Then x = sx: y = y + zy + 4 + Next i + y = y + zy + 4 + Next j + + tt = t + If lscreen < -1 Then _FreeImage lscreen + lscreen = _CopyImage(0) + sexit: + + If showit = false Then GoTo soe + + i = 1 + If (human = 0) And invert Then i = i Xor 1 + If (human = 1) Or match Then i = humanc ' human vs computer + If (human = 2) Then i = WorB ' human vs human + If match Or onplayback Then i = 1 + + If tt = 0 Then ' no pieces have been taken + t$ = "No captures" + Else ' pieces have been taken + side$ = Mid$("BlackWhite", i * 5 + 1, 5) + k = tpoints(1) - tpoints(0) + If i = 0 Then k = -k + If k = 0 Then t$ = "Equal points" + If k < 0 Then t$ = side$ + " up" + Str$(Abs(k)) + " point" + If k > 0 Then t$ = side$ + " down" + Str$(k) + " point" + If Abs(k) > 1 Then t$ = t$ + "s" ' + End If + + SetFont 9 ' size 10 lowercase g cut off! + yint = 13 + x = 24 + y = bry - 9 * yint + + ShadowPrint x, y, t$, white + + t$ = LTrim$(Str$(perpetual)) + " of 3 to perpetual" + If perpetual > 0 Then c1 = red Else c1 = white + ShadowPrint x, y + yint, t$, c1 + + t$ = LTrim$(Str$(drawcount)) + " of 50 to draw" + If drawcount > 39 Then c1 = red Else c1 = white + ShadowPrint x, y + yint * 2, t$, c1 + + td! = Int(tdelay! * 10) / 10 + t$ = LTrim$(Str$(td!)) + "s delay" + ShadowPrint x, y + yint * 3, t$, white + + ShadowPrint x, y + yint * 4, fnum$(top_mps) + " top MPS", white + + u$ = "" + t = mps + If t > 1000 Then t = t / 1000: u$ = "T" + If t > 1000 Then t = t / 1000: u$ = "M" + ShadowPrint x, y + yint * 5, fnum$(t) + u$ + " moves per second", white + + u$ = "" + t = tcount + If t > 1000 Then t = t / 1000: u$ = "T" + If t > 1000 Then t = t / 1000: u$ = "M" + If t > 1000 Then t = t / 1000: u$ = "B" + ShadowPrint x, y + yint * 6, fnum$(t) + u$ + " moves computed", white + + t$ = LCase$(logfiled$) + If onplayback And (Len(pf$) > 0) Then t$ = LCase$(pf$) + " (R/O)" + If Len(t$) = 0 Then t$ = "TBA" + If logging = 0 Then t$ = "OFF" + p = InStr(t$, ".") + If p Then t$ = Left$(t$, p - 1) + t$ = "File: " + t$ + If readonly And (InStr(t$, "R/O") = 0) Then t$ = t$ + " (R/O)" + ShadowPrint x, y + yint * 7, t$, white + + soe: + 'TimeTrack "ShowTaken", 0 +End Sub + +Sub ShowThinking + Dim sorted, mi, j, z, c$, t$, x1, y1, ox, oy + + If wasFEN > 0 Then ' no list to show for a FEN response + SetFont defaultfontsize + Color red, black + _PrintString (580, 240), "Not computed" + _PrintString (580, 260), "FEN entry" + Str$(wasFEN) + Exit Sub + End If + + If (rflag = 0) And (smoves0 > 0) Then ' done thinking and list not sorted + sort: + sorted = true + For mi = 2 To smoves0 ' sort list (bubble) + If thinkv(mi - 1) < thinkv(mi) Then + Swap thinkv(mi - 1), thinkv(mi) + Swap think$(mi - 1), think$(mi) + sorted = false + End If + Next mi + If sorted = false Then GoTo sort + smoves0 = -smoves0 ' method to indicate list is sorted + End If + + SetFont 9 ' small so it'll fit + If rflag Then z = smovest Else z = Abs(smoves0) ' if thinking, show to current "known", else show entire sorted list + For mi = 1 To z + t$ = think$(mi) + + y1 = try + (mi - 1) * 11 + 2 + If mi Mod 2 Then + c1 = _SHL(bri, 4) + Line (trx + 3, y1 - 1)-(_Width - 12, y1 + 9), _RGB32(c1, c1, c1), BF + End If + For j = 1 To Len(t$) + x1 = trx + (j - 1) * 6 + c$ = Mid$(t$, j, 1) + ox = 0: oy = 0 + If c$ = "-" Then ox = 2: oy = -1 + If y1 < (_Height - 30) Then ShadowPrint x1 + ox, y1 + oy, c$, white + Next j + Next mi + + If dev And rflag Then + y1 = try + Moves(0) * 11 + Line (trx + 3, y1)-(_Width - 12, y1), red + End If +End Sub + +Sub ShowValid (tcc As _Byte, trr As _Byte) ' highlight legal squares to move to + Dim mi, zx, zy + Dim As _Byte z, zc, zr + + nvalid = 0 + If (human = 0) Or (-(b(tcc, trr) > 6) <> WorB) Then Exit Sub + + For mi = 1 To Moves(0) + If (tcc = Abs(move(0, mi).fc)) And (trr = Abs(move(0, mi).fr)) Then + nvalid = nvalid + 1 + If markers Then + zc = move(0, mi).tc + zr = move(0, mi).tr + If invert Then zc = 9 - zc: zr = 9 - zr + zx = tlx + (zc - 1) * xq + zy = tly + (8 - zr) * yq + For z = 2 To 4 + Line (zx + z, zy + z)-(zx + xq - z, zy + yq - z), black, B + Next z + 'If dev Then + ' SetFont 12 + ' Color white + ' _PrintString (zx + 4, zy + 7), Str$(mi) + ' cursoron = ExtendedTimer + 60 + 'End If + End If + End If + Next mi +End Sub + +Sub SmallBoard (sa) + Dim As _Byte i, z, p, pp, zc, zr, st, zc1, zr1 + Dim tsa, tx, zx, zy, ty, c$, t$ + + If onplayback Then Exit Sub + + 'TimeTrack "SmallBoard", 1 + st = 90 ' seperation distance between boards + zx = trx + 10 + + _PutImage (trx + 1, try)-(_Width - 1, _Height - 20), bgi, 0, (trx + 1, try)-(_Width - 1, _Height - 20) + _MemCopy m(0), m(0).OFFSET, m(0).SIZE To m(10), m(10).OFFSET ' store board + WorB = SaveWorB + For z = 0 To masterlevel - 1 + + If z > Moves(z) Then Exit For + If z = 0 Then tsa = sa Else tsa = 1 + + zc1 = move(z, tsa).fc + zr1 = move(z, tsa).fr + If b(Abs(zc1), Abs(zr1)) = 0 Then Exit For + + If descriptive Then DescriptiveNotation z, move(z, tsa).fc, move(z, tsa).fr, move(z, tsa).tc, move(z, tsa).tr + MoveIt move(z, tsa).fc, move(z, tsa).fr, move(z, tsa).tc, move(z, tsa).tr + + WorB = WorB Xor 1 + zy = try + z * st + 2 + SetFont 10 ' pieces + For zc = 1 To 8 ' column + For zr = 1 To 8 ' row + If invert Then p = b(9 - zc, 9 - zr) Else p = b(zc, zr) + pp = p And 7 ' + tx = zx + zc * 10 + ty = zy + (8 - zr) * 10 + c1 = 20 + ((zc + zr) Mod 2) * 20 ' intensity + c1 = _RGB32(c1, c1, c1) ' make shade of gray + Line (tx, ty)-Step(9, 9), c1, BF ' square color + If Sgn(p And 8) Then c1 = white Else c1 = red ' piece color + If pp Then ShadowPrint tx + 1, ty, alphap$(pp), c1 ' skip blank squares + Next zr + Next zc + If (SaveWorB + z) Mod 2 Then c1 = white Else c1 = red + tx = trx + 110 + SetFont 12 + If descriptive Then + ShadowPrint tx, zy + 12, desc$, c1 + Else ' algebraic + t$ = ToAlg$(z, tsa) + For i = 1 To Len(t$) ' one character at a time to increase the spacing + c$ = Mid$(t$, i, 1) + ShadowPrint tx, zy + 12, c$, c1 + tx = tx + _PrintWidth(c$) + 1 + Next i + End If + ShadowBox zx + 10, zy, zx + 88, zy + 79 + Next z + _MemCopy m(10), m(10).OFFSET, m(10).SIZE To m(0), m(0).OFFSET ' restore board + + If ssb(sa) < -1 Then _FreeImage ssb(sa) + ssb(sa) = _CopyImage(0) ' a single sideband radio in South Africa + + 'TimeTrack "SmallBoard", 0 + If autopause Then Pause +End Sub + +Sub TakeBackPop + Dim mi ' move index + Dim As _Byte c, r, ply + + For ply = 1 To 2 + For r = 1 To 8 + For c = 1 To 8 + b(c, r) = tb(c, r, 1) + If ((b(c, r) And 7) = Pawn) And ((r = 1) Or (r = 8)) Then b(c, r) = Queen - 8 * (b(c, r) > 8) + Next c + Next r + castle$ = castle$(1) + lfc = lmove(1).fc + lfr = lmove(1).fr + ltc = lmove(1).tc + ltr = lmove(1).tr + + For mi = 0 To tbmax - 1 + castle$(mi) = castle$(mi + 1) + lmove(mi) = lmove(mi + 1) + For r = 1 To 8 + For c = 1 To 8 + tb(c, r, mi) = tb(c, r, mi + 1) + Next c + Next r + Next mi + Next ply + + check = 0 + incheck = 0 + markerfc = 0 + + FENpcount = FENpcount - 2 + If FENpcount < 0 Then FENpcount = 0 + drawcount = drawcount + (drawcount > 0) ' - 1, if > 0 + perpetual = perpetual + (perpetual > 0) ' - 1, if > 0 +End Sub + +Sub TakeBackPush + Dim mi ' move index + Dim As _Byte r, c + + FENpcount = FENpcount + 1 + FENperp$(FENpcount) = FENpartial$ + + For mi = tbmax To 1 Step -1 + castle$(mi) = castle$(mi - 1) ' castling status, 4 chars, BQS BKS WQS WKS + lmove(mi) = lmove(mi - 1) + For r = 1 To 8 ' board + For c = 1 To 8 + tb(c, r, mi) = tb(c, r, mi - 1) + Next c + Next r + Next mi + + castle$(0) = castle$ + lmove(0).fc = lfc ' from column + lmove(0).fr = lfr ' from row + lmove(0).tc = ltc ' to column + lmove(0).tr = ltr ' to row + For r = 1 To 8 ' row + For c = 1 To 8 ' column + tb(c, r, 0) = b(c, r) ' set takeback array + Next c + Next r +End Sub + +Sub TakeBest (tlevel As _Byte, final As _Byte) + Dim mi + Dim As _Byte passes, lookback, sflag + + If Moves(tlevel) < 2 Then Exit Sub + passes = 0 + ReSort: + + Do + sflag = true + For mi = 2 To Moves(tlevel) + If (move(tlevel, mi - 1).sc < move(tlevel, mi).sc) Then + Swap move(tlevel, mi - 1), move(tlevel, mi) + If rflag And (tlevel = 0) Then Swap ssb(mi - 1), ssb(mi) + sflag = false + End If + Next mi + Loop Until sflag + + If final Then ' level 0 wrapup + mi = 0 ' randomly pick a move among those of equal value + Do ' count same scores + mi = mi + 1 + Loop Until (move(tlevel, 1).sc <> move(tlevel, mi + 1).sc) Or (mi = Moves(tlevel)) + + mi = Rnd * (mi - 1) + 1 ' pick one of the same scores + If mi <> 1 Then Swap move(tlevel, 1), move(tlevel, mi) ' if not in first position + + If (Moves(0) > 1) And (passes < 5) And (move > 9) Then + + 'inhibit pawn moves when sufficient power to checkmate + 'p = Limit6(b(ABS(move(0, 1).fc), ABS(move(0, 1).fr))) + 'IF (p = Pawn) AND (ahead > 4) AND (CanMove(0) > 2) AND (RND > .8) THEN + ' SWAP move(0, 1), move(0, 2) + 'END IF + + If points < 0 Then Exit Sub ' allow repeat if losing (go for perpetual) + + ' try to stop repeats + For lookback = 3 To 7 Step 2 + If (move(0, 1).fc = lmove(lookback).fc) And (move(0, 1).fr = lmove(lookback).fr) And (move(0, 1).tc = lmove(lookback).tc) And (move(0, 1).tr = lmove(lookback).tr) Then + move(0, 1).sc = move(0, 2).sc - 1 + passes = passes + 1 + GoTo ReSort + End If + Next lookback + End If + + ' 30% of time, if scores close, take 2nd best move to add variety + 'IF (Moves(0) > 1) AND ((move(0, 2).sc - move(0, 1).sc) < 10) AND (RND > .7) THEN + ' 'IF rickfile THEN SOUND 200, 1 + ' 'debug$ = LTRIM$(STR$(move + 1)) + " " + STR$(move(0, 1).sc) + " " + STR$(move(0, 2).sc) + ' SWAP move(0, 1), move(0, 2) + 'END IF + End If + +End Sub + +'Sub TimeTrack (sub_name$, onofff As _Byte) Static +' Dim As _Byte i +' Dim active$, ztime!, e! +' +' If ttflag = 0 Then ztime! = Timer: Exit Sub +' +' If ztime! = 0 Then ztime! = Timer +' e! = Timer - ztime! +' tel! = tel! + e! +' For i = 1 To names +' If active(i) Then time_used(i) = time_used(i) + e! +' Next i +' +' ztime! = Timer +' +' 'If sub_name$ = active$ Then Exit Sub +' active$ = sub_name$ +' +' For i = 1 To names +' If active$ = name$(i) Then active(i) = onofff: Exit Sub +' Next i +' +' names = names + 1 +' If names > 100 Then QuitWithError "TimeTrack", "names > 100" +' name$(names) = active$ +' active(names) = true +'End Sub + +Sub TinyFont (n$, tx, ty, tk As _Unsigned Long) ' 3 * 5 numbers + Static fontinit As _Byte, sp(14, 4) + Dim d, i, j, n, z, zz, x2, z$ + + 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,1,2 + Data ".",0,0,0,0,2 + Data "-",0,0,3,0,0 + Data ":",0,2,0,2,0 + Data " ",0,0,0,0,0 + + If fontinit = false Then ' initialize - load dont + Restore tinyfontd + For n = 0 To 14 + Read z$ + For i = 0 To 4 + Read z + sp(n, i) = z * 4096 + Next i + Next n + fontinit = true + End If + + For z = 1 To Len(n$) + z$ = Mid$(n$, z, 1) + zz = InStr(",.-: ", z$) + If zz Then d = zz + 9 Else d = Val(z$) + For i = 0 To 4 ' 5 rows + x2 = tx + (z - 1) * 4 + Line (x2, ty + i)-(x2 + 3, ty + i), tk, , sp(d, i) + If tk = black Then _Continue ' skip shadow if color black + For j = 3 To 0 Step -1 ' shadow, find edges + c2 = Point(x2 + j, ty + i) + If c2 = tk Then + PSet (x2 + j + 1, ty + i + 0), _RGB32(8, 8, 8) ' dot on the right + PSet (x2 + j + 1, ty + i + 1), _RGB32(8, 8, 8) ' dot to the right and down + PSet (x2 + j + 0, ty + i + 1), _RGB32(8, 8, 8) ' dot one down + Exit For + End If + Next j + Next i + Next z +End Sub + +Function ToAlg$ (level As _Byte, i) + If (rflag = 0) And (move(level, i).fc < 0) Then + ToAlg = "O-O" + ElseIf (rflag = 0) And (move(level, i).fr < 0) Then + ToAlg = "O-O-O" + Else + ToAlg = alphal$(Abs(move(level, i).fc)) + CHRN$(Abs(move(level, i).fr)) + alphal$(move(level, i).tc) + CHRN$(move(level, i).tr) + End If +End Function + +Sub WindowEffect (effect As _Byte, img, x1, y1, x2, y2) + Dim teffect, zx, zy, tr, tg, tb, p!, loopspeed + 'dim q,i2 + + If rotate <> 0 Then Exit Sub + If effect = -1 Then teffect = (teffect + 1) Mod 4 Else teffect = effect + loopspeed = 30 + + Select Case teffect + Case 0 ' zoom + zx = xc - x1 + zy = yc - y1 + For p! = .1 To 1 Step .1 + _PutImage (xc - zx * p!, yc - zy * p!)-(xc + zx * p!, yc + zy * p!), img, 0, (x1, y1)-(x2, y2) + DisplayMaster true + _Limit loopspeed + Next p! + 'Case 1 ' unfold from left + 'For i2 = x1 To x2 Step 16 + ' _PutImage (x1, y1)-(i2, y2), img, 0, (x1, y1)-(i2, y2) + ' DisplayMaster true + ' _Limit loopspeed + 'Next i2 + 'Case 2 ' random blocks + ' q = 30 + ' For i2 = 0 To 150 + ' zx = x1 + Rnd * (x2 - x1 - q) + ' zy = y1 + Rnd * (y2 - y1 - q) + ' _PutImage (zx, zy)-(zx + q, zy + q), img, 0, (zx, zy)-(zx + q, zy + q) + ' DisplayMaster true + ' _Limit loopspeed + ' Next i2 + Case 3 ' fade in + _Source img + For p! = .1 To .7 Step .03 + For zy = y1 To y2 + For zx = x1 To x2 + c1 = Point(zx, zy) + tr = _Red32(c1) * p! + tg = _Green32(c1) * p! + tb = _Blue32(c1) * p! + PSet (zx, zy), _RGB32(tr, tg, tb) + Next zx + Next zy + DisplayMaster true + _Limit loopspeed + Next p! + _Source 0 + End Select +End Sub + +Sub WriteLog (override) + Dim f, i, t$, y$, m$, d$, f$ + + 'if dev then debug$ = Str$(readonly) + Str$(logging) + Str$(move) + i = readonly: If override Then i = false + If testing Or onplayback Or (i = true) Or (logging = false) Or (move < 3) Then Exit Sub + + If Len(logfiled$) = 0 Then + f = 0 + newf: ' Newfoundland and Labrador + f = f + 1 ' find first unused slot + logfiled$ = "ch" + Right$("000000" + LTrim$(Str$(f)), 6) + ".alg" + logfile$ = gamepath$ + logfiled$ + If _FileExists(logfile$) Then GoTo newf + End If + + f = FreeFile + Open logfile$ For Output As #f + GoSub pheader + For i = 1 To move ' algebraic + Print #f, Rjust$(i, 4); " "; f6$(mlog$(i, 1)); " "; f6$(mlog$(i, 0)) + Next i + Close #f + + If dev = 0 Then + f$ = gamepath$ + Left$(logfiled$, Len(logfiled$) - 4) + ".des" ' save game in descriptive notation + f = FreeFile + Open f$ For Output As #f + GoSub pheader + For i = 1 To move ' descriptive + Print #f, Rjust$(i, 4); " "; f12$(mlog$(i, 3)); " "; f12$(mlog$(i, 2)) + Next i + Close #f + End If + Exit Sub + + pheader: + ' Event,Site,Date,Round,White,Black,Result (such is the PGN standard) + Restore pgnheader + For i = 1 To 7 + Read t$ + Select Case i + Case 1 + t$ = "[" + t$ + " " + q$ + "L" + LTrim$(Str$(masterlevel)) + " D" + LTrim$(Str$(deep)) + q$ + "]" + Case 3 ' Date + y$ = Mid$(Date$, 7, 4) + m$ = Mid$(Date$, 1, 2) + d$ = Mid$(Date$, 4, 2) + d$ = y$ + "." + m$ + "." + d$ + t$ = "[" + t$ + " " + q$ + d$ + q$ + "]" + Case 5 ' White + t$ = "[" + t$ + " " + q$ + PlayerName$(1) + q$ + "]" + Case 6 ' Black + t$ = "[" + t$ + " " + q$ + PlayerName$(0) + q$ + "]" + Case 7 ' Result + If (msg$ = "Checkmate") Or (InStr(LCase$(msg$), "res") > 0) Then + If WorB Then + t$ = "[" + t$ + " " + q$ + "0-1" + q$ + "]" + Else + t$ = "[" + t$ + " " + q$ + "1-0" + q$ + "]" + End If + ElseIf (msg$ = "Draw") Or (msg$ = "Stalemate") Or (msg$ = "Perpetual") Then + t$ = "[" + t$ + " " + q$ + "1/2-1/2" + q$ + "]" + Else + t$ = "[" + t$ + " " + q$ + "" + q$ + "]" + End If + Case Else + t$ = "[" + t$ + " " + q$ + q$ + "]" + End Select + Print #f, t$ + Next i + Return +End Sub + +'$include: 'tf.bas' diff --git a/samples/chess/src/chess.zip b/samples/chess/src/chess.zip new file mode 100644 index 0000000..589796a Binary files /dev/null and b/samples/chess/src/chess.zip differ diff --git a/samples/circle-intersecting-circle/index.md b/samples/circle-intersecting-circle/index.md index 8d612f1..1e1d837 100644 --- a/samples/circle-intersecting-circle/index.md +++ b/samples/circle-intersecting-circle/index.md @@ -18,9 +18,9 @@ Here we present two (equivalent) methods for calculating the intersection points > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "circleintersectcircle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/circle-intersecting-circle/src/circleintersectcircle.bas) -* [RUN "circleintersectcircle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/circle-intersecting-circle/src/circleintersectcircle.bas) -* [PLAY "circleintersectcircle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/circle-intersecting-circle/src/circleintersectcircle.bas) +* [LOAD "circleintersectcircle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/circle-intersecting-circle/src/circleintersectcircle.bas) +* [RUN "circleintersectcircle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/circle-intersecting-circle/src/circleintersectcircle.bas) +* [PLAY "circleintersectcircle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/circle-intersecting-circle/src/circleintersectcircle.bas) ### File(s) diff --git a/samples/circle-intersecting-line/index.md b/samples/circle-intersecting-line/index.md index f4c3335..c4f6a46 100644 --- a/samples/circle-intersecting-line/index.md +++ b/samples/circle-intersecting-line/index.md @@ -18,9 +18,9 @@ This is an interactive (mouse-driven) demo that calculates the intersection of a > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "circle-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/circle-intersecting-line/src/circle-intersect-line.bas) -* [RUN "circle-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/circle-intersecting-line/src/circle-intersect-line.bas) -* [PLAY "circle-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/circle-intersecting-line/src/circle-intersect-line.bas) +* [LOAD "circle-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/circle-intersecting-line/src/circle-intersect-line.bas) +* [RUN "circle-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/circle-intersecting-line/src/circle-intersect-line.bas) +* [PLAY "circle-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/circle-intersecting-line/src/circle-intersect-line.bas) ### File(s) diff --git a/samples/circuits.md b/samples/circuits.md new file mode 100644 index 0000000..fbf0a9f --- /dev/null +++ b/samples/circuits.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: CIRCUITS + +**[Schemat](schemat/index.md)** + +[🐝 Leif J. Burrow](leif-j.-burrow.md) 🔗 [circuits](circuits.md), [schematics](schematics.md) + +# Schemat An old DOS QuickBasic schematic design editor updated for QB64. **What is it good for?... diff --git a/samples/clock.md b/samples/clock.md index 42b27d9..2a3d9fa 100644 --- a/samples/clock.md +++ b/samples/clock.md @@ -7,3 +7,9 @@ [🐝 Folker Fritz](folker-fritz.md) 🔗 [clock](clock.md), [desktop](desktop.md) ' Release: MINI-CLOCK by Folker Fritz ' Version: 1.0 (1999-10-31) ' Status: 100% Freewa... + +**[QB Clock](qb-clock/index.md)** + +[🐝 Alan Zeichick](alan-zeichick.md) 🔗 [clock](clock.md) + +' Analog Clock for QBasic ' by Alan Zeichick copyright (c) 1986, 1992 ' Copyright (C) 1992 DOS Re... diff --git a/samples/cloned-shades/img/screenshot.png b/samples/cloned-shades/img/screenshot.png new file mode 100644 index 0000000..abb07c4 Binary files /dev/null and b/samples/cloned-shades/img/screenshot.png differ diff --git a/samples/cloned-shades/index.md b/samples/cloned-shades/index.md new file mode 100644 index 0000000..1f0a670 --- /dev/null +++ b/samples/cloned-shades/index.md @@ -0,0 +1,25 @@ +[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: CLONED SHADES + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Fellippe Heitor](../fellippe-heitor.md) + +### Description + +```text +A clone of 'Shades' which was originally developed by UOVO. +``` + +### File(s) + +* [shades.bas](src/shades.bas) +* [shades.zip](src/shades.zip) + +🔗 [game](../game.md) + + +Reference: [github.com](https://github.com/FellippeHeitor/Cloned-Shades) diff --git a/samples/cloned-shades/src/shades.bas b/samples/cloned-shades/src/shades.bas new file mode 100644 index 0000000..18f4ab7 --- /dev/null +++ b/samples/cloned-shades/src/shades.bas @@ -0,0 +1,1478 @@ +'Cloned Shades - by @FellippeHeitor - fellippeheitor@gmail.com +' +'(a clone of 'Shades' which was originally developed by +'UOVO - http://www.uovo.dk/ - for iOS) +' +'The goal of this game is to use the arrow keys to choose where +'to lay the next block falling down. If you align 4 blocks of +'the same color shade horizontally, you erase a line. If you +'pile two identical blocks, they will merge to become darker, +'unless they are already the darkest shade available (of 5). +' +'It has a tetris feeling to it, but it's not tetris at all. +' +'The idea is not original, since it's a clone, but I coded it +'from the ground up. +' +'Changes: +'- Beta 1 +' - So far I got the game to work, but I'm running into issues +' trying to show scores on the screen, mainly because I relied +' on POINT to check whether I could move blocks down or not. +' - There's no interface except for the actual gameboard. +' +'- Beta 2 +' - Been discarded. At some point everything was working well but +' I managed to screw it all up, to the point I made the decision +' to go back to beta 1 and start over. I like to mention it here +' because even failure can teach you a lesson, and this one is +' not one to forget. +' +'- Beta 3 +' - Converted all audio files to .OGG for smaller files and faster +' loading. +' - Game window now has an appropriate icon, generated at runtime. +' - Block movement has been coded again, and now it doesn't rely +' on POINT to detect blocks touching each other, but it actually +' evaluates the current Y position. Like it should have been from +' the start, to be honest. +' - Redone the merge animation. Still looks the same, but it had to +' be redone after the new movement routines have been implemented. +' - Added a background image to the game board ("bg.png"), but uses +' a gray background in case it cannot be loaded for some reason. +' - Code is a bit easier to read, after I moved most of the main +' loop code into separate subroutines. +' - SCORES ON THE SCREEN! +' +' - Beta 4 +' - Adaptative resolution when the desktop isn't at least 900px tall. +' - New shades, which are alternated every time a new game is started. +' - Visual intro, mimicking the original game's. +' - Improved game performance by selectively limiting the layering of +' images in SUB UpdateScreen. +' - Added a "danger mode" visual indication, by turning on a TIMER that +' overlays a shade of red over the game play, similar to a security +' alarm. +' - Added a menu to start the game or change setting or leave. +' - Settings are now saved to "shades.dat", and include switches for +' sound and music, as well as a highscore. +' - Added an end screen, that shows the score, number of merges and +' number of lines destroyed during game. +' +' - Beta 5 +' - Fixed game starting with the blocks that were put during the menu +' demonstration. +' - Fixed the 'danger' warning coming back from the previous game. +' - Added an option to select shades (GREEN, ORANGE, BLUE, PINK) or +' to have it AUTOmatically rotate everytime you start the game. +' (thanks to Clippy for suggesting it) +' - Added a confirmation message before clearing highscore. +' - Added a confirmation message before closing the game with ESC. +' - Fixed a bug with page _DEST that caused scores to be put in +' OverlayGraphics page instead of InfoScreen while InDanger +' triggered the ShowAlert sub. +' +' - Beta 6 +' - ESC during the game shows a menu asking user to confirm QUIT or +' RESUME. The previous behaviour (in beta 5) was to quit to main +' menu after ESC was hit twice. Now ESC is interpreted as 'oops, +' I didn't mean to hit ESC'. +' - A new sound for when a line is destroyed ("line.ogg"); "wind.ogg" +' is no longer used/needed. +' - Added a sound to the game over screen ("gameover.ogg"). +' - Fixed menu alignment issues when showing disabled choices. +' - Changed code to selectively NOT do what can't be done in MAC OS X +' (so that now we can compile in MAC OS X, tested in El Capitan). +' - Three lines of code changed to make the code backward compatible +' with QB64 v0.954 (SDL): BackgroundColor goes back to being a shared +' LONG instead of a CONST (since SDL won't allow _RGB32 in a CONST) +' and inside SUB CheckMerge we no longer clear the background using +' a patch from BgImage using _PUTIMAGE with STEP. Turns out the bug +' was in QB64, not in my code. +' +' - Beta 7 +' - Fixed a bug that prevented the end screen to be shown because of +' the InDanger timer still being on. +' - Added three levels of difficulty, which affect gravity. +' - Since speed is different, a new soundtrack was added for faster +' modes ("Crowd_Hammer.ogg" and "Upbeat_Forever.ogg") +' - Added FILL mode (thanks to Pete for the suggestion), in which instead +' of an infinite game your goal is to fill the screen with blocks, +' avoiding merges at all costs, since they make you lose points (which +' is indicated by a "shock.ogg" sound and visual warning. +' - Added a new parameter to FUNCTION Menu, Info(), that holds descriptions +' for menu items. The goal is to be able to show highscores even +' before starting a game. +' - Clicking and dragging emulates keystrokes, allowing basic mouse +' controls (code courtesy of Steve McNeill - Thanks again!) +' +' - Version 1.0 +' - Fixed: Disabling music through settings didn't stop the music. Duh. +' - Fixed: Shock sound during Fill mode sounded weird because it was being +' played inside the animation loop, and not once, before animation. +' - Fixed: BgMusic selection while in Fill mode. +' - Added: If player takes more than 3 seconds to choose a game mode, +' a brief description is shown on the screen. +' - Added: Quick end screen animation. +' - Countdown to game start with "GET READY" on the screen. +' +$ExeIcon:'./shades.ico' +'Game constants ------------------------------------------------------- +'General Use: +Const False = 0 +Const True = Not False + +'Game definitions: +Const BlockWidth = 150 +Const BlockHeight = 64 +Const ZENINCREMENT = 1 +Const NORMALINCREMENT = 5 +Const FLASHINCREMENT = 10 +Const ZENMODE = 1 +Const NORMALMODE = 2 +Const FLASHMODE = 3 +Const FILLMODE = 4 + +'Animations: +Const TopAnimationSteps = 15 +Const MergeSteps = 32 + +'Colors: +Const MaxShades = 4 + +'Menu actions: +Const PLAYGAME = 3 +Const PLAYFILL = 4 +Const SETTINGSMENU = 5 +Const LEAVEGAME = 7 +Const SWITCHSOUND = 1 +Const SWITCHMUSIC = 2 +Const COLORSWITCH = 3 +Const RESETHIGHSCORES = 4 +Const MAINMENU = 5 + +'Misc: +Const FileID = "CLONEDSHADES" + +'Type definitions: ---------------------------------------------------- +Type ColorRGB + R As Long + G As Long + B As Long +End Type + +Type BoardType + State As Long + Shade As Long +End Type + +Type SettingsFile + ID As String * 13 ' CLONEDSHADES + CHR$(# of the latest version/beta with new .dat format) + ColorMode As Long '0 = Automatic, 1 = Green, 2 = Orange, 3 = Blue, 4 = Pink + SoundOn As _Byte + MusicOn As _Byte + HighscoreZEN As Long + HighscoreNORMAL As Long + HighscoreFLASH As Long + HighscoreFILL As Long +End Type + +'Variables ------------------------------------------------------------ +'Variables for game control: +Dim Shared Board(1 To 12, 1 To 4) As BoardType +Dim Shared Shades(1 To 5) As ColorRGB, FadeStep As Long +Dim Shared BlockPos(1 To 4) As Long +Dim Shared BlockRows(1 To 12) As Long, BgImage As Long +Dim Shared i As Long, Increment As Long +Dim Shared CurrentRow As Long, CurrentColumn As Long +Dim Shared BlockPut As _Bit, Y As Long, PrevY As Long +Dim Shared CurrentShade As Long, NextShade As Long +Dim Shared AlignedWithRow As _Bit, InDanger As _Bit +Dim Shared GameOver As _Bit, GameEnded As _Bit +Dim Shared PreviousScore As Long, Score As Long +Dim Shared GlobalShade As Long, DemoMode As _Bit +Dim Shared AlertTimer As Long, TotalMerges As Long +Dim Shared TotalLines As Long, Setting As Long +Dim Shared InGame As _Byte, InitialIncrement As Long +Dim Shared GameMode As _Byte, InWatchOut As _Bit + +'Variables for screen pages: +Dim Shared InfoScreen As Long +Dim Shared OverlayGraphics As Long +Dim Shared GameScreen As Long +Dim Shared MenuTip As Long +Dim Shared MainScreen As Long +Dim Shared UIWidth As Long +Dim Shared UIHeight As Long + +'Variable for sound: +Dim Shared DropSound(1 To 3) As Long, Alarm As Long +Dim Shared LineSound As Long, SplashSound(1 To 4) As Long, Whistle As Long +Dim Shared BgMusic(1 To 4) As Long, GameOverSound As Long +Dim Shared ShockSound As Long + +'Other variables +Dim Shared InMenu As _Bit, QuitGame As _Bit +Dim Shared Settings As SettingsFile +Dim Shared BackgroundColor As Long +Dim SettingChoice As Long + +'Screen initialization: ------------------------------------------------ +'Default window size is 600x800. If the desktop resolution is smaller +'than 900px tall, resize the UI while keeping the aspect ratio. +UIWidth = 600 +UIHeight = 800 +If InStr(_OS$, "WIN") Then + If _Height(_ScreenImage) < 900 Then + UIHeight = _Height(_ScreenImage) - 150 + UIWidth = UIHeight * .75 + End If +End If + +InfoScreen = _NewImage(300, 400, 32) +OverlayGraphics = _NewImage(150, 200, 32) +GameScreen = _NewImage(600, 800, 32) +MainScreen = _NewImage(UIWidth, UIHeight, 32) + +BgImage = _LoadImage("bg.png", 32) +If BgImage < -1 Then _DontBlend BgImage + +BackgroundColor = _RGB32(170, 170, 170) + +Screen MainScreen + +_Title "Cloned Shades" + +If BgImage < -1 Then _PutImage , BgImage, MainScreen + +'Coordinates for block locations in the board: ------------------------ +Restore BlockPositions +For i = 1 To 4 + Read BlockPos(i) +Next i + +Restore RowCoordinates +For i = 1 To 12 + Read BlockRows(i) +Next i + +InDanger = False +GameOver = False +GameEnded = False + +'Read settings from file "shades.dat", if it exists: ------------------ +If _FileExists("shades.dat") Then + Open "shades.dat" For Binary As #1 + Get #1, , Settings + Close #1 +End If + +If Settings.ID <> FileID + Chr$(7) Then + 'Invalid settings file or file doesn't exist: use defaults + Settings.ID = FileID + Chr$(7) + Settings.ColorMode = 0 + Settings.SoundOn = True + Settings.MusicOn = True + Settings.HighscoreZEN = 0 + Settings.HighscoreNORMAL = 0 + Settings.HighscoreFLASH = 0 + Settings.HighscoreFILL = 0 +End If + +'RGB data for shades: -------------------------------------------------- +SelectGlobalShade + +'Since now we already have read the shades' rgb data, +'let's generate the window icon (Windows only): +If InStr(_OS$, "WIN") Then MakeIcon + +PrepareIntro + +'Load sounds: --------------------------------------------------------- +LoadAssets + +Intro + +NextShade = _Ceil(Rnd * 3) 'Randomly chooses a shade for the next block + +AlertTimer = _FreeTimer +On Timer(AlertTimer, .005) ShowAlert +Timer(AlertTimer) Off + +_Dest GameScreen +If BgImage < -1 Then _PutImage , BgImage, GameScreen Else Cls , BackgroundColor +UpdateScreen + +Randomize Timer + +'Main game loop: ------------------------------------------------------ +Do + _KeyClear 'Clears keyboard buffer to avoid unwanted ESCs - Thanks, Steve. + SelectGlobalShade + Erase Board + InitialIncrement = 1 + ReDim Choices(1 To 7) As String + ReDim Info(1 To 7) As String + ReDim Tips(1 To 7) As Long + ReDim Tip(1 To 8) As String + + Choices(1) = "Cloned Shades" + Chr$(0) + Choices(2) = " " + Chr$(0) + Choices(3) = "Classic Mode" + HighestOfHighest = Settings.HighscoreZEN + If Settings.HighscoreNORMAL > HighestOfHighest Then HighestOfHighest = Settings.HighscoreNORMAL + If Settings.HighscoreFLASH > HighestOfHighest Then HighestOfHighest = Settings.HighscoreFLASH + If HighestOfHighest > 0 Then Info(3) = "Best: " + TRIM$(HighestOfHighest) + Tips(3) = _NewImage(320, 130, 32) + _Dest Tips(3) + Line (0, 0)-(319, 129), _RGBA32(255, 255, 255, 235), BF + Line (0, 0)-(319, 129), _RGB32(0, 0, 0), B + Tip(1) = "Your goal in Classic Mode is to make" + Tip(2) = "as many points as you can by merging" + Tip(3) = "same color blocks and by creating" + Tip(4) = "lines of four blocks of the same shade." + Tip(5) = "There are three different skills to" + Tip(6) = "choose from: ZEN, NORMAL and FLASH." + Tip(8) = "Can you believe your eyes?" + For i = 1 To UBound(Tip) + If Len(Tip(i)) Then PrintShadow _Width(Tips(3)) \ 2 - _PrintWidth(Tip(i)) \ 2, (i - 1) * _FontHeight, Tip(i), _RGB32(0, 0, 0) + Next i + _Dest GameScreen + + Choices(4) = "Fill Mode" + If Settings.HighscoreFILL > 0 Then Info(4) = "Best: " + TRIM$(Settings.HighscoreFILL) + Tips(4) = _NewImage(400, 130, 32) + _Dest Tips(4) + Line (0, 0)-(399, 129), _RGBA32(255, 255, 255, 235), BF + Line (0, 0)-(399, 129), _RGB32(0, 0, 0), B + Tip(1) = "In Fill Mode you have to tweak your brain" + Tip(2) = "to do the opposite of what you did in Classic:" + Tip(3) = "now it's time to pile blocks up and avoid" + Tip(4) = "merging them at all costs. If you happen" + Tip(5) = "to forget your goal and end up connecting" + Tip(6) = "them, an electric response is triggered." + Tip(8) = "Do you have what it takes?" + For i = 1 To UBound(Tip) + If Len(Tip(i)) Then PrintShadow _Width(Tips(4)) \ 2 - _PrintWidth(Tip(i)) \ 2, (i - 1) * _FontHeight, Tip(i), _RGB32(0, 0, 0) + Next i + _Dest GameScreen + + Choices(5) = "Settings" + Choices(6) = " " + Chr$(0) + Choices(7) = "Quit" + + If Settings.MusicOn And BgMusic(1) Then _SndVol BgMusic(1), .2: _SndLoop BgMusic(1) + Choice = Menu(3, 7, Choices(), Info(), Tips(), 3) + Select Case Choice + Case PLAYGAME + ReDim Choices(1 To 6) As String + ReDim Info(1 To 6) As String + ReDim Tips(1 To 6) As Long + + Choices(1) = "SKILLS" + Chr$(0) + Choices(2) = "Zen" + If Settings.HighscoreZEN > 0 Then Info(2) = "Best: " + TRIM$(Settings.HighscoreZEN) + Choices(3) = "Normal" + If Settings.HighscoreNORMAL > 0 Then Info(3) = "Best: " + TRIM$(Settings.HighscoreNORMAL) + Choices(4) = "Flash" + If Settings.HighscoreFLASH > 0 Then Info(4) = "Best: " + TRIM$(Settings.HighscoreFLASH) + Choices(5) = " " + Chr$(0) + Choices(6) = "Go back" + + GameMode = 1 'Default = Zen mode + Select Case Menu(2, 6, Choices(), Info(), Tips(), 3) + Case 2: GameMode = ZENMODE: InitialIncrement = ZENINCREMENT + Case 3: GameMode = NORMALMODE: InitialIncrement = NORMALINCREMENT + Case 4: GameMode = FLASHMODE: InitialIncrement = FLASHINCREMENT + Case 6: GameEnded = True + End Select + + Erase Board + Score = 0 + PreviousScore = -1 + TotalMerges = 0 + TotalLines = 0 + NextShade = _Ceil(Rnd * 3) + RedrawBoard + + If Settings.MusicOn And BgMusic(1) Then _SndStop BgMusic(1) + If Not GameEnded Then ShowGetReady 3 + If Settings.MusicOn And BgMusic(GameMode) Then _SndVol BgMusic(GameMode), .3: _SndLoop BgMusic(GameMode) + + InDanger = False + InGame = True + Do While Not GameOver And Not GameEnded + GenerateNewBlock + MoveBlock + CheckDanger + CheckMerge + CheckConnectedLines + Loop + InGame = False + If BgMusic(GameMode) Then _SndStop BgMusic(GameMode) + If BgMusic(4) Then _SndStop BgMusic(4) + If GameOver Then + If Settings.SoundOn And GameOverSound Then _SndPlayCopy GameOverSound + Select Case GameMode + Case ZENMODE: If Settings.HighscoreZEN < Score Then Settings.HighscoreZEN = Score + Case NORMALMODE: If Settings.HighscoreNORMAL < Score Then Settings.HighscoreNORMAL = Score + Case FLASHMODE: If Settings.HighscoreFLASH < Score Then Settings.HighscoreFLASH = Score + End Select + ShowEndScreen + End If + GameOver = False + GameEnded = False + Case PLAYFILL + 'Fill mode is actually just a hack. We play in ZENMODE conditions, but the points are + 'calculated differently. Also, DANGER mode displays a different message/color warning. + GameMode = FILLMODE + InitialIncrement = ZENINCREMENT + + Erase Board + Score = 0 + PreviousScore = -1 + TotalMerges = 0 + TotalLines = 0 + NextShade = _Ceil(Rnd * 3) + RedrawBoard + + If Settings.MusicOn And BgMusic(1) Then _SndStop BgMusic(1) + ShowGetReady 3 + If Settings.MusicOn And BgMusic(ZENMODE) Then _SndVol BgMusic(ZENMODE), .3: _SndLoop BgMusic(ZENMODE) + + InDanger = False + InGame = True + If Settings.MusicOn And BgMusic(ZENMODE) Then + If BgMusic(1) Then _SndStop BgMusic(1) + _SndVol BgMusic(ZENMODE), .3: _SndLoop BgMusic(ZENMODE) + End If + Do While Not GameOver And Not GameEnded + GenerateNewBlock + MoveBlock + CheckDanger + CheckMerge + CheckConnectedLines + Loop + InGame = False + If BgMusic(ZENMODE) Then _SndStop BgMusic(ZENMODE) + If BgMusic(4) Then _SndStop BgMusic(4) + If GameOver Then + If Settings.SoundOn And LineSound Then _SndPlayCopy LineSound + If Settings.HighscoreFILL < Score Then Settings.HighscoreFILL = Score + ShowEndScreen + End If + GameOver = False + GameEnded = False + Case SETTINGSMENU + SettingChoice = 1 + Do + ReDim Choices(1 To 5) As String + ReDim Info(1 To 5) As String + ReDim Tips(1 To 5) As Long + If Settings.SoundOn Then Choices(1) = "Sound: ON" Else Choices(1) = "Sound: OFF" + If Settings.MusicOn Then Choices(2) = "Music: ON" Else Choices(2) = "Music: OFF" + Select Case Settings.ColorMode + Case 0: Choices(3) = "Color: AUTO" + Case 1: Choices(3) = "Color: GREEN" + Case 2: Choices(3) = "Color: ORANGE" + Case 3: Choices(3) = "Color: BLUE" + Case 4: Choices(3) = "Color: PINK" + End Select + Choices(4) = "Reset Highscores" + HighestOfHighest = Settings.HighscoreZEN + If Settings.HighscoreNORMAL > HighestOfHighest Then HighestOfHighest = Settings.HighscoreNORMAL + If Settings.HighscoreFLASH > HighestOfHighest Then HighestOfHighest = Settings.HighscoreFLASH + If Settings.HighscoreFILL > HighestOfHighest Then HighestOfHighest = Settings.HighscoreFILL + If HighestOfHighest = 0 Then Choices(4) = Choices(4) + Chr$(0) + + Info(4) = "Can't be undone." + Choices(5) = "Return" + + SettingChoice = Menu(SettingChoice, 5, Choices(), Info(), Tips(), 3) + Select Case SettingChoice + Case SWITCHSOUND + Settings.SoundOn = Not Settings.SoundOn + Case SWITCHMUSIC + Settings.MusicOn = Not Settings.MusicOn + If Settings.MusicOn Then + If BgMusic(1) Then _SndLoop BgMusic(1) + Else + If BgMusic(1) Then _SndStop BgMusic(1) + End If + Case COLORSWITCH + Settings.ColorMode = Settings.ColorMode + 1 + If Settings.ColorMode > 4 Then Settings.ColorMode = 0 + SelectGlobalShade + Case RESETHIGHSCORES + ReDim Choices(1 To 2) As String + ReDim Info(1 To 2) + ReDim Tips(1 To 2) As Long + Choices(1) = "Reset" + Choices(2) = "Cancel" + If Menu(1, 2, Choices(), Info(), Tips(), 3) = 1 Then + Settings.HighscoreZEN = 0 + Settings.HighscoreNORMAL = 0 + Settings.HighscoreFLASH = 0 + Settings.HighscoreFILL = 0 + SettingChoice = SWITCHSOUND + End If + End Select + Loop Until SettingChoice = MAINMENU + Case LEAVEGAME + QuitGame = True + End Select +Loop Until QuitGame + +On Error GoTo DontSave +Open "shades.dat" For Binary As #1 +Put #1, , Settings +Close #1 + +DontSave: +System + +Greens: +Data 245,245,204 +Data 158,255,102 +Data 107,204,51 +Data 58,153,0 +Data 47,127,0 + +Oranges: +Data 255,193,153 +Data 255,162,102 +Data 255,115,26 +Data 230,89,0 +Data 128,49,0 + +Blues: +Data 204,229,255 +Data 128,190,255 +Data 26,138,255 +Data 0,87,179 +Data 0,50,102 + +Pinks: +Data 255,179,255 +Data 255,128,255 +Data 255,26,255 +Data 179,0,178 +Data 77,0,76 + +BlockPositions: +Data 0,151,302,453 + +RowCoordinates: +Data 735,670,605,540,475,410,345,280,215,150,85,20 + +'SUBs and FUNCTIONs ---------------------------------------------------- + +Sub GenerateNewBlock + Dim LineSize As Long + Dim LineStart As Long + Dim LineEnd As Long + Dim TargetLineStart As Long + Dim TargetLineEnd As Long + Dim LeftSideIncrement As Long + Dim RightSideIncrement As Long + + 'Randomly chooses where the next block will start falling down + CurrentColumn = _Ceil(Rnd * 4) + CurrentShade = NextShade + + 'Randomly chooses the next shade. It is done at this point so + 'that the "next" bar will be displayed correctly across the game screen. + NextShade = _Ceil(Rnd * 3) + + 'Block's Y coordinate starts offscreen + Y = -48: PrevY = Y + + If DemoMode Then Exit Sub + + 'Animate the birth of a new block: + If Whistle And Settings.SoundOn Then + _SndPlayCopy Whistle + End If + + LineSize = 600 + LineStart = 0 + LineEnd = 599 + TargetLineStart = (CurrentColumn * BlockWidth) - BlockWidth + TargetLineEnd = CurrentColumn * BlockWidth + LeftSideIncrement = (TargetLineStart - LineStart) / TopAnimationSteps + RightSideIncrement = (LineEnd - TargetLineEnd) / TopAnimationSteps + + For i = 1 To TopAnimationSteps + _Limit 120 + If BgImage < -1 Then _PutImage (0, 0)-(599, 15), BgImage, GameScreen, (0, 0)-(599, 15) Else Line (0, 0)-(599, 15), BackgroundColor, BF + Line (LineStart, 0)-(LineEnd, 15), Shade&(CurrentShade), BF + LineStart = LineStart + LeftSideIncrement + LineEnd = LineEnd - RightSideIncrement + If InKey$ <> "" Then Exit For + UpdateScreen + Next i + If BgImage < -1 Then _PutImage (0, 0)-(599, 15), BgImage, GameScreen, (0, 0)-(599, 15) Else Line (0, 0)-(599, 15), BackgroundColor, BF +End Sub + +Sub MoveBlock + Dim MX As Long, MY As Long, MB As Long 'Mouse X, Y and Button + + Dim k$ + + FadeStep = 0 + Increment = InitialIncrement + If Not DemoMode Then BlockPut = False + + Do: _Limit 60 + 'Before moving the block using Increment, check if the movement will + 'cause the block to move to another row. If so, check if such move will + 'cause to block to be put down. + If ConvertYtoRow(Y + Increment) <> ConvertYtoRow(Y) And Not AlignedWithRow Then + Y = BlockRows(ConvertYtoRow(Y)) + AlignedWithRow = True + Else + Y = Y + Increment + AlignedWithRow = False + End If + + CurrentRow = ConvertYtoRow(Y) + + If AlignedWithRow Then + If CurrentRow > 1 Then + If Board(CurrentRow - 1, CurrentColumn).State Then BlockPut = True + ElseIf CurrentRow = 1 Then + BlockPut = True + End If + End If + + If BlockPut Then + If GameMode = FILLMODE Then Score = Score + 5 Else Score = Score + 2 + DropSoundI = _Ceil(Rnd * 3) + If DropSound(DropSoundI) And Settings.SoundOn And Not DemoMode Then + _SndPlayCopy DropSound(DropSoundI) + End If + Board(CurrentRow, CurrentColumn).State = True + Board(CurrentRow, CurrentColumn).Shade = CurrentShade + End If + + If Board(12, CurrentColumn).State = True And Board(12, CurrentColumn).Shade <> Board(11, CurrentColumn).Shade Then + GameOver = True + Exit Do + End If + + 'Erase previous block put on screen + If BgImage < -1 Then + _PutImage (BlockPos(CurrentColumn), PrevY)-(BlockPos(CurrentColumn) + BlockWidth, PrevY + Increment), BgImage, GameScreen, (BlockPos(CurrentColumn), PrevY)-(BlockPos(CurrentColumn) + BlockWidth, PrevY + Increment) + Else + Line (BlockPos(CurrentColumn), PrevY)-(BlockPos(CurrentColumn) + BlockWidth, PrevY + Increment), BackgroundColor, BF + End If + PrevY = Y + + 'Show the next shade on the top bar unless in DemoMode + If FadeStep < 255 And Not DemoMode Then + FadeStep = FadeStep + 1 + Line (0, 0)-(599, 15), _RGBA32(Shades(NextShade).R, Shades(NextShade).G, Shades(NextShade).B, FadeStep), BF + End If + + 'Draw the current block + Line (BlockPos(CurrentColumn), Y)-Step(BlockWidth, BlockHeight), Shade&(CurrentShade), BF + + UpdateScreen + + If Not DemoMode And Increment < BlockHeight Then k$ = InKey$ + + 'Emulate arrow keys if mouse was clicked+held+moved on screen + 'Code courtesy of Steve McNeill: + While _MouseInput: Wend + Static OldX, OldY + MX = _MouseX: MY = _MouseY: MB = _MouseButton(1) + + + If MB Then + If Abs(OldX - MX) > 100 Then + If OldX < MX Then k$ = Chr$(0) + Chr$(77) Else k$ = Chr$(0) + Chr$(75) + OldX = MX + End If + If Abs(OldY - MY) > 100 Then + If OldY < MY Then k$ = Chr$(0) + Chr$(80) + OldY = MY + End If + Else + OldX = MX + OldY = MY + End If + + Select Case k$ + Case Chr$(0) + Chr$(80) 'Down arrow + Increment = BlockHeight + Case Chr$(0) + Chr$(75) 'Left arrow + If CurrentColumn > 1 Then + If Board(CurrentRow, CurrentColumn - 1).State = False Then + If BgImage < -1 Then _PutImage (BlockPos(CurrentColumn), Y)-(BlockPos(CurrentColumn) + BlockWidth, Y + BlockHeight), BgImage, GameScreen, (BlockPos(CurrentColumn), Y)-(BlockPos(CurrentColumn) + BlockWidth, Y + BlockHeight) Else Line (BlockPos(CurrentColumn), Y)-(BlockPos(CurrentColumn) + BlockWidth, Y + BlockHeight), BackgroundColor, BF + CurrentColumn = CurrentColumn - 1 + End If + End If + Case Chr$(0) + Chr$(77) 'Right arrow + If CurrentColumn < 4 Then + If Board(CurrentRow, CurrentColumn + 1).State = False Then + If BgImage < -1 Then _PutImage (BlockPos(CurrentColumn), Y)-(BlockPos(CurrentColumn) + BlockWidth, Y + BlockHeight), BgImage, GameScreen, (BlockPos(CurrentColumn), Y)-(BlockPos(CurrentColumn) + BlockWidth, Y + BlockHeight) Else Line (BlockPos(CurrentColumn), Y)-(BlockPos(CurrentColumn) + BlockWidth, Y + BlockHeight), BackgroundColor, BF + CurrentColumn = CurrentColumn + 1 + End If + End If + Case Chr$(27) + If GameMode <> FILLMODE Then + If BgMusic(GameMode) Then _SndStop BgMusic(GameMode) + Else + If BgMusic(ZENMODE) Then _SndStop BgMusic(ZENMODE) + End If + If BgMusic(4) Then _SndStop BgMusic(4) + ReDim Choices(1 To 2) As String + ReDim Info(1 To 2) As String + ReDim Tips(1 To 2) As Long + Choices(1) = "Quit" + Choices(2) = "Resume" + If Menu(1, 2, Choices(), Info(), Tips(), 3) = 1 Then + GameEnded = True + Else + If GameMode <> FILLMODE Then + If Settings.MusicOn And BgMusic(GameMode) And Not InDanger Then _SndLoop BgMusic(GameMode) + If Settings.MusicOn And BgMusic(4) And InDanger Then _SndLoop BgMusic(4) + Else + If Settings.MusicOn And BgMusic(ZENMODE) And Not InDanger Then _SndLoop BgMusic(ZENMODE) + If Settings.MusicOn And BgMusic(4) And InDanger Then _SndLoop BgMusic(4) + End If + End If + RedrawBoard + 'CASE " " + ' GameOver = True + End Select + If DemoMode Then Exit Sub + Loop Until BlockPut Or GameEnded Or GameOver +End Sub + +Sub CheckMerge + 'Check if a block merge will be required: + Dim YStep As Long, AnimationLimit As Long + Dim WatchOutColor As _Bit, PreviousDest As Long + Dim DangerMessage$ + + Merged = False + + AnimationLimit = 60 'Default for NORMALINCREMENT + Select Case InitialIncrement + Case ZENINCREMENT: AnimationLimit = 30 + Case FLASHINCREMENT: AnimationLimit = 90 + End Select + + If BlockPut And CurrentRow > 1 Then + Do + If Board(CurrentRow, CurrentColumn).Shade = Board(CurrentRow - 1, CurrentColumn).Shade Then + 'Change block's color and the one touched to a darker shade, if it's not the darkest yet + If GameMode = FILLMODE Then Score = Score - 5 - CurrentShade * 2 Else Score = Score + CurrentShade * 2 + If Score < 0 Then Score = 0 + If CurrentShade < 5 Then + Merged = True + TotalMerges = TotalMerges + 1 + i = CurrentShade + RStep = (Shades(i).R - Shades(i + 1).R) / MergeSteps + GStep = (Shades(i).G - Shades(i + 1).G) / MergeSteps + BStep = (Shades(i).B - Shades(i + 1).B) / MergeSteps + YStep = (BlockHeight) / MergeSteps + + RToGo = Shades(i).R + GToGo = Shades(i).G + BToGo = Shades(i).B + + ShrinkingHeight = BlockHeight * 2 + + If SplashSound(CurrentShade) And Settings.SoundOn And Not DemoMode And Not GameMode = FILLMODE Then + _SndPlayCopy SplashSound(CurrentShade) + ElseIf Settings.SoundOn And GameMode = FILLMODE Then + If ShockSound Then _SndPlayCopy ShockSound + End If + + For Merge = 0 To MergeSteps: _Limit AnimationLimit + RToGo = RToGo - RStep + GToGo = GToGo - GStep + BToGo = BToGo - BStep + + ShrinkingHeight = ShrinkingHeight - YStep + + If BgImage < -1 Then + _PutImage (BlockPos(CurrentColumn), BlockRows(CurrentRow))-(BlockPos(CurrentColumn) + BlockWidth, BlockRows(CurrentRow) + BlockHeight * 2 + 1), BgImage, GameScreen, (BlockPos(CurrentColumn), BlockRows(CurrentRow))-(BlockPos(CurrentColumn) + BlockWidth, BlockRows(CurrentRow) + BlockHeight * 2 + 1) + Else + Line (BlockPos(CurrentColumn), BlockRows(CurrentRow))-Step(BlockWidth, BlockHeight * 2 + 1), BackgroundColor, BF + End If + + 'Draw the merging blocks: + Line (BlockPos(CurrentColumn), BlockRows(CurrentRow) + (BlockHeight * 2) - ShrinkingHeight - 1)-Step(BlockWidth, ShrinkingHeight + 2), _RGB32(RToGo, GToGo, BToGo), BF + If GameMode = FILLMODE Then + InWatchOut = True + PreviousDest = _Dest + _Dest OverlayGraphics + If WatchOutColor Then Cls , _RGB(255, 255, 0) Else Cls , _RGBA32(0, 0, 0, 100) + WatchOutColor = Not WatchOutColor + DangerMessage$ = "WATCH OUT!" + PrintShadow _Width \ 2 - _PrintWidth(DangerMessage$) \ 2, _Height \ 2 - _FontHeight \ 2, DangerMessage$, _RGB32(255, 255, 255) + _Dest PreviousDest + End If + UpdateScreen + Next Merge + InWatchOut = False + + Board(CurrentRow, CurrentColumn).State = False + Board(CurrentRow - 1, CurrentColumn).Shade = i + 1 + Else + Exit Do + End If + Else + Exit Do + End If + CurrentRow = CurrentRow - 1 + CurrentShade = CurrentShade + 1 + Y = BlockRows(CurrentRow) + PrevY = Y + CheckDanger + Loop Until CurrentRow = 1 Or CurrentShade = 5 + End If + _KeyClear +End Sub + +Sub CheckConnectedLines + 'Check for connected lines with the same shade and + 'compute the new score, besides generating the disappearing + 'animation: + Dim WatchOutColor As _Bit, PreviousDest As Long + Dim DangerMessage$ + + Matched = False + Do + CurrentMatch = CheckMatchingLine% + If CurrentMatch = 0 Then Exit Do + + Matched = True + If GameMode = FILLMODE Then Score = Score - 40 Else Score = Score + 40 + If Score < 0 Then Score = 0 + + MatchLineStart = BlockRows(CurrentMatch) + BlockHeight \ 2 + + If LineSound And Settings.SoundOn And Not DemoMode And Not GameMode = FILLMODE Then + _SndPlayCopy LineSound + ElseIf Settings.SoundOn And GameMode = FILLMODE Then + If ShockSound Then _SndPlayCopy ShockSound + End If + + For i = 1 To BlockHeight \ 2 + _Limit 60 + If BgImage < -1 Then + _PutImage (0, MatchLineStart - i)-(599, MatchLineStart + i), BgImage, GameScreen, (0, MatchLineStart - i)-(599, MatchLineStart + i) + Else + Line (0, MatchLineStart - i)-(599, MatchLineStart + i), BackgroundColor, BF + End If + If GameMode = FILLMODE Then + InWatchOut = True + PreviousDest = _Dest + _Dest OverlayGraphics + If WatchOutColor Then Cls , _RGB(255, 255, 0) Else Cls , _RGBA32(0, 0, 0, 100) + WatchOutColor = Not WatchOutColor + DangerMessage$ = "ARE YOU CRAZY?!" + PrintShadow _Width \ 2 - _PrintWidth(DangerMessage$) \ 2, _Height \ 2 - _FontHeight \ 2, DangerMessage$, _RGB32(255, 255, 255) + _Dest PreviousDest + End If + UpdateScreen + Next i + InWatchOut = False + + DestroyLine CurrentMatch + TotalLines = TotalLines + 1 + RedrawBoard + + DropSoundI = _Ceil(Rnd * 3) + If DropSound(DropSoundI) And Settings.SoundOn And Not DemoMode Then + _SndPlayCopy DropSound(DropSoundI) + End If + If DemoMode Then DemoMode = False + Loop +End Sub + +Function ConvertYtoRow (CurrentY) + 'Returns the row on the board through which the block is currently + 'passing. + + If CurrentY >= -48 And CurrentY <= 20 Then + ConvertYtoRow = 12 + ElseIf CurrentY > 20 And CurrentY <= 85 Then + ConvertYtoRow = 11 + ElseIf CurrentY > 85 And CurrentY <= 150 Then + ConvertYtoRow = 10 + ElseIf CurrentY > 150 And CurrentY <= 215 Then + ConvertYtoRow = 9 + ElseIf CurrentY > 215 And CurrentY <= 280 Then + ConvertYtoRow = 8 + ElseIf CurrentY > 280 And CurrentY <= 345 Then + ConvertYtoRow = 7 + ElseIf CurrentY > 345 And CurrentY <= 410 Then + ConvertYtoRow = 6 + ElseIf CurrentY > 410 And CurrentY <= 475 Then + ConvertYtoRow = 5 + ElseIf CurrentY > 475 And CurrentY <= 540 Then + ConvertYtoRow = 4 + ElseIf CurrentY > 540 And CurrentY <= 605 Then + ConvertYtoRow = 3 + ElseIf CurrentY > 605 And CurrentY <= 670 Then + ConvertYtoRow = 2 + ElseIf CurrentY > 670 And CurrentY <= 735 Then + ConvertYtoRow = 1 + End If +End Function + +Function ConvertXtoCol (CurrentX) + 'Returns the column on the board being currently hovered + + If CurrentX >= BlockPos(1) And CurrentX < BlockPos(2) Then + ConvertXtoCol = 1 + ElseIf CurrentX >= BlockPos(2) And CurrentX < BlockPos(3) Then + ConvertXtoCol = 2 + ElseIf CurrentX >= BlockPos(3) And CurrentX < BlockPos(4) Then + ConvertXtoCol = 3 + ElseIf CurrentX >= BlockPos(4) Then + ConvertXtoCol = 4 + End If +End Function + + +Function Shade& (CurrentShade) + Shade& = _RGB32(Shades(CurrentShade).R, Shades(CurrentShade).G, Shades(CurrentShade).B) +End Function + +Function CheckMatchingLine% + + Dim i As Long + Dim a.s As Long, b.s As Long, c.s As Long, d.s As Long + Dim a As Long, b As Long, c As Long, d As Long + + For i = 1 To 12 + a.s = Board(i, 1).State + b.s = Board(i, 2).State + c.s = Board(i, 3).State + d.s = Board(i, 4).State + + a = Board(i, 1).Shade + b = Board(i, 2).Shade + c = Board(i, 3).Shade + d = Board(i, 4).Shade + + If a.s And b.s And c.s And d.s Then + If a = b And b = c And c = d Then + CheckMatchingLine% = i + Exit Function + End If + End If + + Next i + CheckMatchingLine% = 0 + +End Function + +Sub DestroyLine (LineToDestroy As Long) + + Dim i As Long + Select Case LineToDestroy + Case 1 To 11 + For i = LineToDestroy To 11 + Board(i, 1).State = Board(i + 1, 1).State + Board(i, 2).State = Board(i + 1, 2).State + Board(i, 3).State = Board(i + 1, 3).State + Board(i, 4).State = Board(i + 1, 4).State + + Board(i, 1).Shade = Board(i + 1, 1).Shade + Board(i, 2).Shade = Board(i + 1, 2).Shade + Board(i, 3).Shade = Board(i + 1, 3).Shade + Board(i, 4).Shade = Board(i + 1, 4).Shade + Next i + For i = 1 To 4 + Board(12, i).State = False + Board(12, i).Shade = 0 + Next i + Case 12 + For i = 1 To 4 + Board(12, i).State = False + Board(12, i).Shade = 0 + Next i + End Select + +End Sub + +Sub RedrawBoard + Dim i As Long, CurrentColumn As Long + Dim StartY As Long, EndY As Long + + If BgImage < -1 Then _PutImage , BgImage, GameScreen Else Cls , BackgroundColor + + For i = 1 To 12 + For CurrentColumn = 4 To 1 Step -1 + StartY = BlockRows(i) + EndY = StartY + BlockHeight + + If Board(i, CurrentColumn).State = True Then + Line (BlockPos(CurrentColumn), StartY)-(BlockPos(CurrentColumn) + BlockWidth, EndY), Shade&(Board(i, CurrentColumn).Shade), BF + End If + Next CurrentColumn + Next i + +End Sub + +Sub ShowScore + Dim ScoreString As String + Dim ModeHighScore As Long + + If Score = PreviousScore Then Exit Sub + PreviousScore = Score + + ScoreString = "Score:" + Str$(Score) + + Select Case GameMode + Case ZENMODE: ModeHighScore = Settings.HighscoreZEN + Case NORMALMODE: ModeHighScore = Settings.HighscoreNORMAL + Case FLASHMODE: ModeHighScore = Settings.HighscoreFLASH + Case FILLMODE: ModeHighScore = Settings.HighscoreFILL + End Select + + _Dest InfoScreen + Cls , _RGBA32(0, 0, 0, 0) + + '_FONT 16 + PrintShadow 15, 15, ScoreString, _RGB32(255, 255, 255) + + _Font 8 + If Score < ModeHighScore Then + PrintShadow 15, 32, "Highscore: " + TRIM$(ModeHighScore), _RGB32(255, 255, 255) + ElseIf Score > ModeHighScore And ModeHighScore > 0 Then + PrintShadow 15, 32, "You beat the highscore!", _RGB32(255, 255, 255) + End If + _Font 16 + _Dest GameScreen + +End Sub + +Sub MakeIcon + 'Generates the icon that will be placed on the window title of the game + Dim Icon As Long + Dim PreviousDest As Long + Dim i As Long + Const IconSize = 16 + + Icon = _NewImage(IconSize, IconSize, 32) + PreviousDest = _Dest + _Dest Icon + + For i = 1 To 5 + Line (0, i * (IconSize / 5) - (IconSize / 5))-(IconSize, i * (IconSize / 5)), Shade&(i), BF + Next i + + _Icon Icon + _FreeImage Icon + + _Dest PreviousDest +End Sub + +Sub CheckDanger + 'Checks if any block pile is 11 blocks high, which + 'means danger, which means player needs to think faster, + 'which means we'll make him a little bit more nervous by + 'switching our soothing bg song to a fast paced circus + 'like melody. + If Board(11, 1).State Or Board(11, 2).State Or Board(11, 3).State Or Board(11, 4).State Then + If Settings.SoundOn And Not InDanger And Not DemoMode Then + If Alarm Then _SndPlayCopy Alarm + If Settings.MusicOn Then + If GameMode <> FILLMODE Then + If BgMusic(GameMode) Then _SndStop BgMusic(GameMode) + Else + If BgMusic(ZENMODE) Then _SndStop BgMusic(ZENMODE) + End If + If BgMusic(4) Then _SndLoop BgMusic(4) + End If + Timer(AlertTimer) On + End If + InDanger = True + Else + If Settings.MusicOn And InDanger And Not DemoMode Then + If BgMusic(4) Then _SndStop BgMusic(4) + If GameMode <> FILLMODE Then + If BgMusic(GameMode) Then _SndLoop BgMusic(GameMode) + Else + If BgMusic(ZENMODE) Then _SndLoop BgMusic(ZENMODE) + End If + Timer(AlertTimer) Off + _Dest OverlayGraphics + Cls , _RGBA32(0, 0, 0, 0) + _Dest GameScreen + End If + InDanger = False + End If +End Sub + +Sub LoadAssets + 'Loads sound files at startup. + Dim i As _Byte + + LineSound = _SndOpen("line.ogg", "SYNC") + GameOverSound = _SndOpen("gameover.ogg", "SYNC") + Whistle = _SndOpen("whistle.ogg", "SYNC,VOL") + If Whistle Then _SndVol Whistle, 0.02 + + Alarm = _SndOpen("alarm.ogg", "SYNC") + ShockSound = _SndOpen("shock.ogg", "SYNC") + + For i = 1 To 3 + If Not DropSound(i) Then DropSound(i) = _SndOpen("drop" + TRIM$(i) + ".ogg", "SYNC") + Next i + + For i = 1 To 4 + If Not SplashSound(i) Then SplashSound(i) = _SndOpen("water" + TRIM$(i) + ".ogg", "SYNC") + Next i + + BgMusic(1) = _SndOpen("Water_Prelude.ogg", "SYNC,VOL") + BgMusic(2) = _SndOpen("Crowd_Hammer.ogg", "SYNC,VOL") + BgMusic(3) = _SndOpen("Upbeat_Forever.ogg", "SYNC,VOL") + BgMusic(4) = _SndOpen("quick.ogg", "SYNC,VOL") + If BgMusic(1) Then _SndVol BgMusic(1), .2 + If BgMusic(4) Then _SndVol BgMusic(4), .8 + +End Sub + +Sub UpdateScreen + 'Display the gamescreen, overlay and score layers + If Not DemoMode Then ShowScore + + _PutImage , GameScreen, MainScreen + If InMenu Or InDanger Or InWatchOut Then + _PutImage , OverlayGraphics, MainScreen + If MenuTip Then + _PutImage (_Width(MainScreen) \ 2 - _Width(MenuTip) \ 2, _Height(MainScreen) \ 2 - _Height(MenuTip) \ 2), MenuTip, MainScreen + End If + End If + + If Not InMenu Then _PutImage , InfoScreen, MainScreen + _Display +End Sub + +Sub PrintShadow (x%, y%, Text$, ForeColor&) + 'Shadow: + Color _RGBA32(170, 170, 170, 170), _RGBA32(0, 0, 0, 0) + _PrintString (x% + 1, y% + 1), Text$ + + 'Text: + Color ForeColor&, _RGBA32(0, 0, 0, 0) + _PrintString (x%, y%), Text$ +End Sub + +Sub SelectGlobalShade + If Settings.ColorMode = 0 Then + GlobalShade = (GlobalShade) Mod MaxShades + 1 + Else + GlobalShade = Settings.ColorMode + End If + Select Case GlobalShade + Case 1: Restore Greens + Case 2: Restore Oranges + Case 3: Restore Blues + Case 4: Restore Pinks + End Select + + For i = 1 To 5 + Read Shades(i).R + Read Shades(i).G + Read Shades(i).B + Next i + +End Sub + +Sub PrepareIntro + 'The intro shows the board about to be cleared, + 'which then happens after assets are loaded. The intro + 'is generated using the game engine. + + 'DemoMode prevents sounds to be played + DemoMode = True + + _Dest InfoScreen + _Font 16 + LoadingMessage$ = "Cloned Shades" + PrintShadow _Width \ 2 - _PrintWidth(LoadingMessage$) \ 2, _Height \ 2 - _FontHeight, LoadingMessage$, _RGB32(255, 255, 255) + + _Font 8 + LoadingMessage$ = "loading..." + PrintShadow _Width \ 2 - _PrintWidth(LoadingMessage$) \ 2, _Height \ 2, LoadingMessage$, _RGB32(255, 255, 255) + + _Font 16 + _Dest GameScreen + + 'Setup the board to show an "about to merge" group of blocks + 'which will end up completing a dark line at the bottom. + Board(1, 1).State = True + Board(1, 1).Shade = 5 + Board(1, 2).State = True + Board(1, 2).Shade = 5 + Board(1, 3).State = True + Board(1, 3).Shade = 4 + Board(1, 4).State = True + Board(1, 4).Shade = 5 + Board(2, 3).State = True + Board(2, 3).Shade = 3 + Board(3, 3).State = True + Board(3, 3).Shade = 2 + Board(4, 3).State = True + Board(4, 3).Shade = 2 + + CurrentColumn = 3 + CurrentRow = 4 + CurrentShade = 2 + Y = BlockRows(CurrentRow) + PrevY = Y + BlockPut = True + + RedrawBoard + Board(4, 3).State = False + + UpdateScreen + If InStr(_OS$, "WIN") Then _ScreenMove _Middle +End Sub + +Sub Intro + 'The current board setup must have been prepared using PrepareIntro first. + + 'Use the game engine to show the intro: + CheckMerge + CheckConnectedLines + + 'Clear the "loading..." text + _Dest InfoScreen + Cls , _RGBA32(0, 0, 0, 0) + _Dest GameScreen + +End Sub + +Sub HighLightCol (Col As Long) + + _Dest OverlayGraphics + Cls , _RGBA32(0, 0, 0, 0) + Line (BlockPos(Col), 16)-Step(BlockWidth, _Height(0)), _RGBA32(255, 255, 255, 150), BF + _Dest GameScreen + +End Sub + +Sub ShowAlert + Static FadeLevel + Dim DangerMessage$ + Dim PreviousDest As Long + + If InMenu Or InWatchOut Then Exit Sub + + If FadeLevel > 100 Then FadeLevel = 0 + FadeLevel = FadeLevel + 1 + PreviousDest = _Dest + _Dest OverlayGraphics + If GameMode = FILLMODE Then Cls , _RGBA32(0, 255, 0, FadeLevel) Else Cls , _RGBA32(255, 0, 0, FadeLevel) + If GameMode = FILLMODE Then DangerMessage$ = "BE EXTRA CAREFUL!" Else DangerMessage$ = "DANGER!" + PrintShadow _Width \ 2 - _PrintWidth(DangerMessage$) \ 2, _Height \ 2 - _FontHeight \ 2, DangerMessage$, _RGB32(255, 255, 255) + _Dest PreviousDest +End Sub + +Sub ShowGetReady (CountDown As _Byte) + Dim Message$, i As _Byte, i$, iSnd As _Byte + Dim PreviousDest As Long + + PreviousDest = _Dest + DemoMode = True: InMenu = True + _Dest OverlayGraphics + Message$ = "GET READY" + For i = CountDown To 1 Step -1 + Cls , _RGBA32(255, 255, 255, 200) + PrintShadow _Width \ 2 - _PrintWidth(Message$) \ 2, _Height \ 2 - _FontHeight \ 2, Message$, _RGB32(0, 0, 0) + If i = 1 Then i$ = "GO!" Else i$ = TRIM$(i) + PrintShadow _Width \ 2 - _PrintWidth(i$) \ 2, _Height \ 2 - _FontHeight \ 2 + _FontHeight, i$, Shade&(5) + UpdateScreen + iSnd = _Ceil(Rnd * 3): If DropSound(iSnd) Then _SndPlayCopy DropSound(iSnd) + _Delay .5 + Next i + _Dest PreviousDest + DemoMode = False: InMenu = False +End Sub + +Function Menu (CurrentChoice As _Byte, MaxChoice As _Byte, Choices() As String, Info() As String, Tips() As Long, TipTime As Double) + 'Displays Choices() on the screen and lets the player choose one. + 'Uses OverlayGraphics page to display options. + 'Player must use arrow keys to make a choice then ENTER. + + Dim Choice As _Byte, PreviousChoice As _Byte + Dim ChoiceWasMade As _Bit + Dim k$, i As Long + Dim ChooseColorTimer As Long + Dim ItemShade As Long + Dim ThisItemY As Long + Dim ThisTime As Double, StartTime As Double, TipShown As _Bit + + DemoMode = True + InMenu = True + Choice = CurrentChoice + + If Not InGame Then + ChooseColorTimer = _FreeTimer + On Timer(ChooseColorTimer, 3.5) SelectGlobalShade + Timer(ChooseColorTimer) On + End If + + If Not InGame Then Erase Board: BlockPut = True + + StartTime = Timer + Do + _Limit 30 + + 'Use the game engine while the menu is displayed, except while InGame: + If Not InGame Then + If BlockPut Then + GenerateNewBlock: BlockPut = False + Else + MoveBlock + End If + End If + + GoSub ShowCurrentChoice + ThisTime = Timer + If ThisTime - StartTime >= TipTime And Not TipShown Then + 'TipTime has passed since the user selected the current choice, so + 'if Tips(Choice) contains an image, it is _PUTIMAGEd on the screen. + If Tips(Choice) < -1 Then + MenuTip = Tips(Choice) + TipShown = True + End If + End If + + k$ = InKey$ + Select Case k$ + Case Chr$(0) + Chr$(80) 'Down arrow + Do + Choice = (Choice) Mod MaxChoice + 1 + Loop While Right$(Choices(Choice), 1) = Chr$(0) + StartTime = Timer + TipShown = False + MenuTip = False + Case Chr$(0) + Chr$(72) 'Up arrow + Do + Choice = (Choice + MaxChoice - 2) Mod MaxChoice + 1 + Loop While Right$(Choices(Choice), 1) = Chr$(0) + StartTime = Timer + TipShown = False + MenuTip = False + Case Chr$(13) 'Enter + ChoiceWasMade = True + MenuTip = False + Case Chr$(27) 'ESC + ChoiceWasMade = True + Choice = MaxChoice + End Select + Loop Until ChoiceWasMade + + If Not InGame Then Timer(ChooseColorTimer) Free + InMenu = False + DemoMode = False + _Dest OverlayGraphics + Cls , _RGBA32(255, 255, 255, 100) + _Dest GameScreen + + MenuTip = False + For i = 1 To MaxChoice + If Tips(i) < -1 Then _FreeImage Tips(i) + Next i + + Menu = Choice + Exit Function + + ShowCurrentChoice: + If Choice = PreviousChoice Then Return + _Dest OverlayGraphics + Cls , _RGBA32(255, 255, 255, 100) + + 'Choices ending with CHR$(0) are shown as unavailable/grey. + ThisItemY = (_Height(OverlayGraphics) / 2) - (((_FontHeight * MaxChoice) + _FontHeight) / 2) + For i = 1 To MaxChoice + ThisItemY = ThisItemY + _FontHeight + If i = Choice Then + ItemShade = Shade&(5) + PrintShadow (_Width(OverlayGraphics) \ 2) - (_PrintWidth("> " + Choices(i)) \ 2), ThisItemY, Chr$(16) + Choices(i), ItemShade + Else + If Right$(Choices(i), 1) = Chr$(0) Then + ItemShade = _RGB32(255, 255, 255) + PrintShadow (_Width(OverlayGraphics) \ 2) - (_PrintWidth(Left$(Choices(i), Len(Choices(i)) - 1)) \ 2), ThisItemY, Left$(Choices(i), Len(Choices(i)) - 1), ItemShade + Else + ItemShade = Shade&(4) + PrintShadow (_Width(OverlayGraphics) \ 2) - (_PrintWidth(Choices(i)) \ 2), ThisItemY, Choices(i), ItemShade + End If + End If + If Len(Info(i)) And i = Choice Then + _Font 8 + Color Shade&(5) + _PrintString ((_Width(OverlayGraphics) \ 2) - (_PrintWidth(Info(i)) \ 2), _Height(OverlayGraphics) - 8), Info(i) + _Font 16 + End If + Next i + _Dest GameScreen + UpdateScreen + PreviousChoice = Choice + Return + +End Function + +Sub ShowEndScreen + Dim Message$(1 To 10), k$, i As Long + Dim MessageColor As Long + + If InDanger Then + Timer(AlertTimer) Off + InDanger = False + End If + + _Dest OverlayGraphics + Cls , _RGBA32(255, 255, 255, 150) + + If GameMode = FILLMODE And Score > 0 Then Message$(1) = "YOU WIN!" Else Message$(1) = "GAME OVER" + Message$(3) = "Your score:" + Message$(4) = TRIM$(Score) + Message$(5) = "Merged blocks:" + Message$(6) = TRIM$(TotalMerges) + Message$(7) = "Lines destroyed:" + Message$(8) = TRIM$(TotalLines) + Message$(10) = "Press ENTER..." + + MessageColor = Shade&(5) + For i = 1 To UBound(Message$) + If i > 1 Then _Font 8: MessageColor = _RGB(0, 0, 0) + If i = UBound(Message$) Then _Font 16: MessageColor = Shade&(5) + PrintShadow (_Width(OverlayGraphics) \ 2) - (_PrintWidth(Message$(i)) \ 2), i * 16, Message$(i), MessageColor + Next i + + _Dest MainScreen + + For i = 1 To _Height(MainScreen) / 2 Step BlockHeight / 2 + _Limit 60 + _PutImage , GameScreen + _PutImage (0, _Height(MainScreen) / 2 - i)-(599, _Height(MainScreen) / 2 + i), OverlayGraphics + _Display + Next i + + _PutImage , GameScreen + _PutImage , OverlayGraphics + _Display + _Dest GameScreen + + _KeyClear + k$ = "": While k$ <> Chr$(13): _Limit 30: k$ = InKey$: Wend + +End Sub + +Function TRIM$ (Number) + TRIM$ = LTrim$(RTrim$(Str$(Number))) +End Function + diff --git a/samples/cloned-shades/src/shades.zip b/samples/cloned-shades/src/shades.zip new file mode 100644 index 0000000..ea32ca8 Binary files /dev/null and b/samples/cloned-shades/src/shades.zip differ diff --git a/samples/colliding-ball-simulation/index.md b/samples/colliding-ball-simulation/index.md index 5d56196..f04e2ba 100644 --- a/samples/colliding-ball-simulation/index.md +++ b/samples/colliding-ball-simulation/index.md @@ -18,9 +18,9 @@ Realistic collisions between sphreres in two dimensions. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "ball.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/colliding-ball-simulation/src/ball.bas) -* [RUN "ball.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/colliding-ball-simulation/src/ball.bas) -* [PLAY "ball.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/colliding-ball-simulation/src/ball.bas) +* [LOAD "ball.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/colliding-ball-simulation/src/ball.bas) +* [RUN "ball.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/colliding-ball-simulation/src/ball.bas) +* [PLAY "ball.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/colliding-ball-simulation/src/ball.bas) ### File(s) diff --git a/samples/color-picker.md b/samples/color-picker.md new file mode 100644 index 0000000..47df078 --- /dev/null +++ b/samples/color-picker.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: COLOR PICKER + +**[Colors](colors/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [color picker](color-picker.md), [dos world](dos-world.md) + +' COLORS.BAS ' Copyright (c) 1993 DOS Resource Guide ' Published in Issue #12, November 199... diff --git a/samples/colors/img/screenshot.png b/samples/colors/img/screenshot.png new file mode 100644 index 0000000..7b4bd60 Binary files /dev/null and b/samples/colors/img/screenshot.png differ diff --git a/samples/colors/index.md b/samples/colors/index.md new file mode 100644 index 0000000..8a2fa98 --- /dev/null +++ b/samples/colors/index.md @@ -0,0 +1,136 @@ +[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: COLORS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Hardin Brothers](../hardin-brothers.md) + +### Description + +```text +' COLORS.BAS +' Copyright (c) 1993 DOS Resource Guide +' Published in Issue #12, November 1993, page 69. + +' This program lets you pick foreground +' and background text colors by moving +' a cursor with the arrow keys. +' The program displays the QBasic color numbers, +' the color names, and the ANSI codes that +' will generate those colors. +' You should find this program handy if you are +' customizing your DOS prompt, designing a batch +' file menu screen, or writing a QBasic program. + +' Written by Hardin Brothers + +============================================================================== + +------------ + COLORS.BAS +------------ +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x. + +WHAT COLORS.BAS DOES: +This color-finder program displays the various screen color combinations +available for your use in batch files and prompt commands. Using COLORS.BAS, +you can select the color schemes you prefer and the program will provide the +data you need to create ANSI escape sequences for your use. The program also +provides the color numbers used in QBasic and other programs to specify screen +colors. + +USING COLORS.BAS: +To load the program, type QBASIC COLORS.BAS (using path names if necessary) at +the DOS prompt. Then run the program by selecting the Start option in QBasic's +Run menu, or press Shift-F5. The screen will show you the 128 color +combinations available to you for use in batch files, PROMPT commands, and +QBasic programs. These combinations are made up of 16 foreground colors, +used mainly for text, and 8 background colors. + +Use the cursor keys to move from one color combination to another. As you do, +a window in the lower left corner of the display will show you some sample +text using the currently-selected foreground and background colors. To the +right of the window, you'll see four lines of information. The first two +lines tell you the numbers and names of the selected foreground and background +colors. The third and fourth lines display ANSI escape sequences: The former +shows the sequence necessary to create the selected color combination; the +latter shows the sequence for the same colors, but with blinking text. + +You can use these ANSI sequences in batch files in two ways. First, you can +add them to the PROMPT command, replacing the leading ESC with $E to change +your screen colors at the DOS prompt temporarily or permanently. + +For example, let's say you'd like to change your colors to light green text on +a blue screen. You load COLORS.BAS and move the cursor to the right color +combination. COLORS.BAS tells you that the required escape sequence is +ESC[0;32;44;1m. You then type this command at the DOS PROMPT: + +PROMPT $e[0;32;44;1m$p$g + +The $p$g options give you the familiar C:\> prompt. To make the colors +permanent, you would include this line in your AUTOEXEC.BAT file. + +Second, you can use the escape sequences with the ECHO command to set the +colors for all or part of a batch-file display. When you use the ECHO command, +you must replace the letters ESC with the Escape character, which is the ASCII +code 27. The editor that you use to write batch files probably has a way to +add this special character to the text that it creates. If you use the EDIT +program included with DOS 5.0, 6.0, and 6.2, press Ctrl-P and then the ESC key +to create the Escape character, which will look like a small left-pointing +arrow on your screen. + +For example, imagine that you want to write a small batch file that tells the +user what letter he or she should press to load one of three programs. Each +line will look something like this: + +Press F to load FoxPro + +To get the user's attention, you want the colors to be black text on a gray +background, with the letters in blinking red. You run COLORS.BAS. It tells you +that the escape sequence for black on gray is ESC[0;30;47;1m, and the sequence +for blinking red on gray is ESC[5;31;47;1m. Your batch file, then, might look +like this: + +@ECHO off +CLS +ECHO ESC[2J +ECHO ESC[0;30;47;1mPress ESC[5;31;47;1mF ESC[0;30;47;1mto run FoxProESC[K +ECHO ESC[0;30;47;1mPress ESC[5;31;47;1mQ ESC[0;30;47;1mto run QuattroESC[K +ECHO ESC[0;30;47;1mPress ESC[5;31;47;1mW ESC[0;30;47;1mto run WordPerfectESC[K +ECHO ESC[0;37;40;1m +ECHO. +ECHO. + +Again, remember to substitute the Escape character wherever you see "ESC" in +the batch file listing above. + +No matter how you use the ANSI commands, make sure that you copy the rest of +the line exactly, including the square brackets, and note that some characters +must be lowercase. Also, remember that the lines won't do anything unless you +have ANSI.SYS installed with your CONFIG.SYS file. Assuming that the ANSI.SYS +file is in your C:\DOS directory, the following line must be in CONFIG.SYS: + +DEVICE=C:\DOS\ANSI.SYS + +For further details on COLORS.BAS, see "Color Me QBasic" (DRG #12, November +1993, page 69). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "colors.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/colors/src/colors.bas) +* [RUN "colors.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/colors/src/colors.bas) +* [PLAY "colors.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/colors/src/colors.bas) + +### File(s) + +* [colors.bas](src/colors.bas) + +🔗 [color picker](../color-picker.md), [dos world](../dos-world.md) diff --git a/samples/colors/src/colors.bas b/samples/colors/src/colors.bas new file mode 100644 index 0000000..4a786c3 --- /dev/null +++ b/samples/colors/src/colors.bas @@ -0,0 +1,215 @@ +' COLORS.BAS +' Copyright (c) 1993 DOS Resource Guide +' Published in Issue #12, November 1993, page 69. + +' This program lets you pick foreground +' and background text colors by moving +' a cursor with the arrow keys. +' The program displays the QBasic color numbers, +' the color names, and the ANSI codes that +' will generate those colors. +' You should find this program handy if you are +' customizing your DOS prompt, designing a batch +' file menu screen, or writing a QBasic program. + +' Written by Hardin Brothers + +' This program requires a color adapter and monitor + +DEFINT A-Z + +DECLARE SUB ReadDATA () +DECLARE SUB SetInfo () +DECLARE SUB SetText () +DECLARE SUB MoveCursor (UserKey%) +DECLARE SUB SetCursor () +DECLARE SUB SetScreen () +DECLARE FUNCTION GetAKey% () +DECLARE SUB FlushKBDBuffer () + +CONST KeyEscape = 27 +CONST KeyEnter = 13 +CONST KeyLeft = -75 +CONST KeyRight = -77 +CONST KeyUp = -72 +CONST KeyDown = -80 + +DIM SHARED ForeGround, BackGround +DIM SHARED ANSI(0 TO 7) +DIM SHARED Colors$(0 TO 15) +DIM SHARED MaxName + +AnsiOrder: +' Colors: Black, Blue, Green, Cyan +DATA 0, 4, 2, 6 + +' Colors: Red, Magenta, Brown, White +DATA 1, 5, 3, 7 + +ColorNames: +DATA Black, Blue, Green, Cyan, Red, Magenta +DATA Brown, White +DATA Gray, Light Blue, Light Green, Light Cyan +DATA Light Red, Light Magenta, Yellow +DATA Bright White + +'Top-level outline + +ReadDATA 'Get data into arrays +SetScreen 'Create general display +FlushKBDBuffer 'Make sure no keys are waiting +ForeGround = 0 'Set beginning colors +BackGround = 0 + +DO 'Main program loop + SetCursor 'Place the cursor & info + UserKey = GetAKey 'Wait for keystroke + IF UserKey <> KeyEscape THEN 'Process keystroke + MoveCursor (UserKey) 'Move cursor unless we quit + END IF +LOOP UNTIL UserKey = KeyEscape 'Loop until user ESCapes +CLS 'Clean up before ending +END + +SUB FlushKBDBuffer + DO + A$ = INKEY$ 'Try to get a key + LOOP UNTIL LEN(A$) = 0 'Continue until no more +END SUB ' are waiting + +FUNCTION GetAKey + DO + A$ = INKEY$ 'Loop until key + LOOP UNTIL LEN(A$) > 0 ' is ready + IF LEN(A$) = 1 THEN 'If it's alphanumeric + GetAKey = ASC(A$) ' return its code + ELSE 'For special keys + GetAKey = -1 * ASC(MID$(A$, 2)) + END IF ' return -1 * extended code +END FUNCTION + +SUB MoveCursor (UserKey) + SELECT CASE UserKey 'Base action on key + CASE KeyLeft + ForeGround = ForeGround - 1 + IF ForeGround < 0 THEN + ForeGround = ForeGround + 16 + END IF + CASE KeyRight + ForeGround = ForeGround + 1 + ForeGround = ForeGround MOD 16 + CASE KeyUp + BackGround = BackGround - 1 + IF BackGround < 0 THEN + BackGround = BackGround + 8 + END IF + CASE KeyDown + BackGround = BackGround + 1 + BackGround = BackGround MOD 8 + CASE ELSE + BEEP 'For all unrecognized + END SELECT ' keys -- BEEP error +END SUB + +SUB ReadDATA + RESTORE AnsiOrder 'Read ANSI's color + CLS ' numbers into ANSI + FOR i = 0 TO 7 ' arrau + READ ANSI(i): PRINT ANSI(i) + NEXT i + + RESTORE ColorNames 'Read the color + MaxName = 0 'names into an array + FOR i = 0 TO 15 + READ Colors$(i) + IF LEN(Colors$(i)) > MaxName THEN + MaxName = LEN(Colors$(i)) 'and find longest name + END IF + NEXT i +END SUB + +SUB SetCursor + STATIC OldFG, OldBG + COLOR 7, 0 'Turn off previous cursor + LOCATE OldBG + 5, (OldFG * 5) + 1, 0 + PRINT " "; + LOCATE OldBG + 5, (OldFG * 5) + 5, 0 + PRINT " "; + OldFG = ForeGround 'Turn on new one + OldBG = BackGround + LOCATE BackGround + 5, (ForeGround * 5) + 1, 0 + PRINT CHR$(174); + LOCATE BackGround + 5, (ForeGround * 5) + 5, 0 + PRINT CHR$(175); + + SetText 'Display sample text + SetInfo ' and color info +END SUB + +SUB SetInfo 'Display color info + Format$ = "\" + SPACE$(MaxName) + "\" + ANSI$ = " ANSI Code = ESC[0;##;##\ \" '1 space + Blnk$ = "Blink Code = ESC[0;5;##;##\ \" + FG = ForeGround: BG = BackGround + + COLOR 7, 0 'Color numbers and names + LOCATE 15, 30 + PRINT USING "Foreground Color = ## "; FG; + PRINT USING Format$; "(" + Colors$(FG) + ")"; + + LOCATE 16, 30 + PRINT USING "Background Color = ## "; BG; + PRINT USING Format$; "(" + Colors$(BG) + ")"; + + IF FG < 8 THEN 'ANSI sequences + Tail$ = "m" + ELSE + Tail$ = ";1m" + END IF + + LOCATE 18, 30 + PRINT USING ANSI$; 30 + ANSI(FG MOD 8); 40 + ANSI(BG); Tail$ + LOCATE 19, 30 + PRINT USING Blnk$; 30 + ANSI(FG MOD 8); 40 + ANSI(BG); Tail$ +END SUB + +SUB SetScreen 'Create general display + Title$ = "Text Colors and ANSI Color Codes" + + WIDTH 80, 25 'Set screen size + COLOR 7, 0 + CLS + + PRINT " "; STRING$(78, 205) 'Print title bar + PRINT SPACE$((80 - LEN(Title$)) / 2); + PRINT Title$ + PRINT " "; STRING$(78, 205) + + FOR BG = 0 TO 7 'Display color blockx + FOR FG = 0 TO 15 + LOCATE BG + 5, (FG * 5) + 2, 0 + COLOR FG, BG + PRINT " X "; + NEXT FG + NEXT BG + + COLOR 7, 0 'Print instructions + LOCATE 23, 1 + PRINT "Use arrow keys to move the cursor" + PRINT "Press the Esc key to end the program"; +END SUB + +SUB SetText 'Display sample text + Format$ = "\ \" ' 20 spaces + + COLOR ForeGround, BackGround + LOCATE 15, 2 + PRINT USING Format$; " This is some"; + LOCATE 16, 2 + PRINT USING Format$; " sample text"; + LOCATE 17, 2 + PRINT USING Format$; " in the selected"; + LOCATE 18, 2 + PRINT USING Format$; " colors."; +END SUB + diff --git a/samples/connect-circles/index.md b/samples/connect-circles/index.md index fd7f5cb..941c055 100644 --- a/samples/connect-circles/index.md +++ b/samples/connect-circles/index.md @@ -18,9 +18,9 @@ Created by QB64 community member bplus. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "connectcircles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/connect-circles/src/connectcircles.bas) -* [RUN "connectcircles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/connect-circles/src/connectcircles.bas) -* [PLAY "connectcircles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/connect-circles/src/connectcircles.bas) +* [LOAD "connectcircles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/connect-circles/src/connectcircles.bas) +* [RUN "connectcircles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/connect-circles/src/connectcircles.bas) +* [PLAY "connectcircles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/connect-circles/src/connectcircles.bas) ### File(s) diff --git a/samples/conway.md b/samples/conway.md new file mode 100644 index 0000000..abdd8fc --- /dev/null +++ b/samples/conway.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: CONWAY + +**[Conways Game of Life](conways-game-of-life/index.md)** + +[🐝 Luke](luke.md) 🔗 [automata](automata.md), [conway](conway.md) + +Standard Conway's Game of Life simulation. diff --git a/samples/conways-game-of-life/img/screenshot.png b/samples/conways-game-of-life/img/screenshot.png new file mode 100644 index 0000000..6f25aee Binary files /dev/null and b/samples/conways-game-of-life/img/screenshot.png differ diff --git a/samples/conways-game-of-life/index.md b/samples/conways-game-of-life/index.md new file mode 100644 index 0000000..4d4db5e --- /dev/null +++ b/samples/conways-game-of-life/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: CONWAYS GAME OF LIFE + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Luke](../luke.md) + +### Description + +```text +Standard Conway's Game of Life simulation. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "cgol.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/conways-game-of-life/src/cgol.bas) +* [RUN "cgol.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/conways-game-of-life/src/cgol.bas) +* [PLAY "cgol.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/conways-game-of-life/src/cgol.bas) + +### File(s) + +* [cgol.bas](src/cgol.bas) + +🔗 [automata](../automata.md), [conway](../conway.md) diff --git a/samples/conways-game-of-life/src/cgol.bas b/samples/conways-game-of-life/src/cgol.bas new file mode 100644 index 0000000..6a9008e --- /dev/null +++ b/samples/conways-game-of-life/src/cgol.bas @@ -0,0 +1,124 @@ +DefLng A-Z +Randomize Timer +Screen _NewImage(80, 25, 0) +Dim Shared seed(0 To _Width + 1, 0 To _Height + 1) As _Byte +Dim Shared board(0 To _Width + 1, 0 To _Height + 1) As _Byte +Dim Shared temp(0 To _Width + 1, 0 To _Height + 1) As _Byte + +'Random board layout generator +'FOR y = 1 TO _HEIGHT +' FOR x = 1 TO _WIDTH +' IF RND > 0.6 THEN board(x, y) = 1 +' NEXT x +'NEXT y + +'Manual board layout (comment out this loop to use the above randomizer) +Do + Do While _MouseInput + x = _MouseX + y = _MouseY + If _MouseButton(1) Then + seed(x, y) = 1 + board(x, y) = 1 + Locate y, x + Print Chr$(219); + ElseIf _MouseButton(2) Then + seed(x, y) = 1 + board(x, y) = 0 + Locate y, x + Print " "; + End If + Loop + Select Case InKey$ + Case Chr$(13): Exit Do + Case "l" + Input "File to load: ", ifile$ + If Not _FileExists(ifile$) Then + Print "Not found" + Else + Open ifile$ For Binary As #1 + Get #1, , h& + Get #1, , w& + If h& <> _Height Or w& <> _Width Then + Print "Incompatible size - file is"; w&; "by"; h&; " but window is"; _Height; "by"; _Width; + Else + For y = 1 To _Height + For x = 1 To _Width + Get #1, , seed(x, y) + board(x, y) = seed(x, y) + Next x + Next y + Exit Do + End If + End If + End Select +Loop + +Do + For y = 1 To _Height + For x = 1 To _Width + neighbours = 0 + If board(x - 1, y - 1) Then neighbours = neighbours + 1 + If board(x, y - 1) Then neighbours = neighbours + 1 + If board(x + 1, y - 1) Then neighbours = neighbours + 1 + If board(x - 1, y) Then neighbours = neighbours + 1 + If board(x + 1, y) Then neighbours = neighbours + 1 + If board(x - 1, y + 1) Then neighbours = neighbours + 1 + If board(x, y + 1) Then neighbours = neighbours + 1 + If board(x + 1, y + 1) Then neighbours = neighbours + 1 + If neighbours = 3 Then temp(x, y) = 1 + If neighbours = 2 And board(x, y) Then temp(x, y) = 1 + If neighbours > 3 Or neighbours < 2 Then temp(x, y) = 0 + Next x + Next y + redraw + _Limit 10 + If InKey$ = Chr$(27) Then + Locate 1, 1 + Input "Save original pattern (y/n)? ", c$ + If c$ = "Y" Or c$ = "y" Then Input "File name: ", ofile$ + Input "Save current state (y/n)? ", c$ + If c$ = "Y" Or c$ = "y" Then Input "File name: ", cfile$ + Exit Do + End If +Loop + +If ofile$ <> "" Then + Open ofile$ For Binary As #1 + h& = _Height + w& = _Width + Put #1, , h& + Put #1, , w& + For y = 1 To _Height + For x = 1 To _Width + Put #1, , seed(x, y) + Next x + Next y + Close #1 +End If + +If cfile$ <> "" Then + Open cfile$ For Binary As #1 + h& = _Height + w& = _Width + Put #1, , h& + Put #1, , w& + For y = 1 To _Height + For x = 1 To _Width + Put #1, , board(x, y) + Next x + Next y + Close #1 +End If + +Sub redraw + Cls + For y = 1 To _Height + For x = 1 To _Width + board(x, y) = temp(x, y) + If board(x, y) Then Locate y, x: Print Chr$(219); + Next x + Next y + _Display +End Sub + diff --git a/samples/counter.md b/samples/counter.md new file mode 100644 index 0000000..31d0cf2 --- /dev/null +++ b/samples/counter.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: COUNTER + +**[Binary Counter](binary-counter/index.md)** + +[🐝 rpgfan3233](rpgfan3233.md) 🔗 [binary](binary.md), [counter](counter.md) + +' This program is a 12-bit Binary counter, displayed using a 3x4 grid. ' It was created in the ho... diff --git a/samples/cram/img/screenshot.png b/samples/cram/img/screenshot.png new file mode 100644 index 0000000..7de716b Binary files /dev/null and b/samples/cram/img/screenshot.png differ diff --git a/samples/cram/index.md b/samples/cram/index.md new file mode 100644 index 0000000..336ee9b --- /dev/null +++ b/samples/cram/index.md @@ -0,0 +1,72 @@ +[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: CRAM + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Hardin Brothers](../hardin-brothers.md) + +### Description + +```text +'CRAM! +' by Hardin Brothers +' +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #9, May 1993, page 57 +' +'This program may be run in DOS 5.0's QBasic or +'compiled with QuickBasic 4.0 or later, or with +'Visual Basic for DOS. +' + +============================================================================== + +---------- + CRAM.BAS +---------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, Quick Basic 4.x, or +Microsoft Visual Basic for DOS. + +WHAT CRAM.BAS DOES: +This simple but addictive game challenges you to maneuver an ever-growing worm +inside an ever-shrinking box. Increasing the difficulty level speeds the rate +at which the worm grows. + +USING CRAM.BAS: +To load the program in QBasic, type QBASIC CRAM.BAS (using path names if +necessary) at the DOS prompt. Then run the program by selecting the Start +option in QBasic's Run menu, or press Shift-F5. + +The opening screen displays the game's simple instructions and asks you choose +a difficulty level. If you need to warm up your reflexes, start with the easy +level, level 3, and then work your way up to level 2 and level 1. After you +choose a playing level, the game starts right in. The object is to press any +key to make your worm change direction just before hitting a wall. The more +turns you can make, the higher you will score. Play ends when your worm hits a +wall. + +As written, Cram displays your score (the number of turns you make) at the end +of each game and automatically starts another game. Pressing Esc at any time +brings up a "Press any key to continue" message. Press Esc again to exit the +program and return to the QBasic screen. + +For further details on CRAM.BAS, see "Cram!" (DRG #9, May 1993, page 57). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "cram.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/cram/src/cram.bas) +* [RUN "cram.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/cram/src/cram.bas) +* [PLAY "cram.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/cram/src/cram.bas) + +### File(s) + +* [cram.bas](src/cram.bas) + +🔗 [game](../game.md), [dos world](../dos-world.md) diff --git a/samples/cram/src/cram.bas b/samples/cram/src/cram.bas new file mode 100644 index 0000000..0d7eb0b --- /dev/null +++ b/samples/cram/src/cram.bas @@ -0,0 +1,204 @@ +'CRAM! +' by Hardin Brothers +' +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #9, May 1993, page 57 +' +'This program may be run in DOS 5.0's QBasic or +'compiled with QuickBasic 4.0 or later, or with +'Visual Basic for DOS. +' +DEFINT A-Z +DECLARE SUB Pause () +DECLARE SUB NextColor () +DECLARE SUB Score () +DECLARE SUB Setup () +DECLARE SUB Hello () +DECLARE SUB GoRight () +DECLARE SUB GoDown () +DECLARE SUB GoLeft () +DECLARE SUB GoUp () +CONST FALSE = 0 +CONST TRUE = NOT FALSE +CONST ESC = 27 +CONST Duration = 3 +DIM SHARED TopLimit, LeftLimit, RightLimit, BottomLimit +DIM SHARED Crash, Done, Turns +DIM SHARED DrawChar$, Difficulty, CurColor, Note(4) + DrawChar$ = CHR$(219): CurColor = 1 + Note(1) = 800: Note(2) = 600: Note(3) = 400: Note(4) = 500 +Hello +Done = FALSE +DO + Setup + IF NOT Done THEN + Crash = FALSE + DO + IF NOT Crash AND NOT Done THEN GoRight + IF NOT Crash AND NOT Done THEN GoDown + IF NOT Crash AND NOT Done THEN GoLeft + IF NOT Crash AND NOT Done THEN GoUp + LOOP UNTIL Crash OR Done + END IF + IF NOT Done THEN Score +LOOP UNTIL Done +CLS +END +SUB GoDown + col = RightLimit + row = TopLimit + WHILE INKEY$ <> "": WEND + DO + LOCATE row, col + PRINT DrawChar$; + Pause + row = row + 1 + IF row = BottomLimit THEN Crash = TRUE + k$ = INKEY$ + LOOP WHILE LEN(k$) = 0 AND Crash = FALSE + IF LEN(k$) THEN Done = (ASC(k$) = ESC) + SOUND Note(2), Duration + BottomLimit = row + Turns = Turns + 1 + NextColor +END SUB +SUB GoLeft + col = RightLimit + row = BottomLimit + WHILE INKEY$ <> "": WEND + DO + LOCATE row, col + PRINT DrawChar$; + Pause + col = col - 1 + IF col = LeftLimit THEN Crash = TRUE + k$ = INKEY$ + LOOP WHILE LEN(k$) = 0 AND Crash = FALSE + IF LEN(k$) THEN Done = (ASC(k$) = ESC) + SOUND Note(3), Duration + LeftLimit = col + Turns = Turns + 1 + NextColor +END SUB +SUB GoRight + col = LeftLimit + row = TopLimit + WHILE INKEY$ <> "": WEND + DO + LOCATE row, col + PRINT DrawChar$; + Pause + col = col + 1 + IF col = RightLimit THEN Crash = TRUE + k$ = INKEY$ + LOOP WHILE LEN(k$) = 0 AND Crash = FALSE + IF LEN(k$) THEN Done = (ASC(k$) = ESC) + SOUND Note(1), Duration + RightLimit = col + Turns = Turns + 1 + NextColor +END SUB +SUB GoUp + col = LeftLimit + row = BottomLimit + WHILE INKEY$ <> "": WEND + DO + LOCATE row, col + PRINT DrawChar$; + Pause + row = row - 1 + IF row = TopLimit THEN Crash = TRUE + k$ = INKEY$ + LOOP WHILE LEN(k$) = 0 AND Crash = FALSE + IF LEN(k$) THEN Done = (ASC(k$) = ESC) + SOUND Note(4), Duration + TopLimit = row + Turns = Turns + 1 + NextColor +END SUB +SUB Hello + CLS + PRINT , , "Welcome to Cram" + PRINT + PRINT " To play. simply press a key when the line gets too close" + PRINT "to a wall. The more turns you can make, the higher you will" + PRINT "score. Press at any time to end the game." + PRINT + PRINT , , "Good Luck!" + PRINT : PRINT + DO + INPUT "Difficulty 1 (hard) to 3 (easy) ==> "; Difficulty + LOOP UNTIL Difficulty >= 1 AND Difficulty <= 3 +END SUB +SUB NextColor + CurColor = CurColor + 1 + IF CurColor = 8 THEN CurColor = 9 + IF CurColor > 15 THEN CurColor = 1 + COLOR CurColor +END SUB +SUB Pause + FOR j = 1 TO Difficulty + T! = TIMER + WHILE T! = TIMER: WEND + NEXT j +END SUB +SUB Score + Turns = Turns - 1 + COLOR 7 + LOCATE 12, 30 + IF Turns = 1 THEN + LastWord$ = "turn!" + ELSE + LastWord$ = "turns!" + END IF + PRINT "You made"; Turns; LastWord$ + FOR i = 1 TO 4 + FOR j = 1 TO 4 + SOUND Note(j), Duration + NEXT j + NEXT i + FOR i = 1 TO 10 + Pause + NEXT i +END SUB +SUB Setup + Crash = FALSE + Done = FALSE + Turns = 0 + CLS + NextColor + FOR x = 1 TO 80 + LOCATE 1, x + PRINT DrawChar$; + NEXT x + SOUND Note(1), Duration + NextColor + + FOR y = 1 TO 25 + LOCATE y, 80 + PRINT DrawChar$; + NEXT y + SOUND Note(2), Duration + NextColor + + FOR x = 79 TO 1 STEP -1 + LOCATE 25, x + PRINT DrawChar$; + NEXT x + SOUND Note(3), Duration + NextColor + + FOR y = 24 TO 3 STEP -1 + LOCATE y, 1 + PRINT DrawChar$; + NEXT y + SOUND Note(4), Duration + NextColor + + TopLimit = 3: RightLimit = 80 + BottomLimit = 25: LeftLimit = 1 + + k$ = INKEY$ + IF LEN(k$) THEN Done = (ASC(k$) = ESC) +END SUB + diff --git a/samples/curve-smoother/img/screenshot.png b/samples/curve-smoother/img/screenshot.png new file mode 100644 index 0000000..4376938 Binary files /dev/null and b/samples/curve-smoother/img/screenshot.png differ diff --git a/samples/curve-smoother/index.md b/samples/curve-smoother/index.md new file mode 100644 index 0000000..050ff00 --- /dev/null +++ b/samples/curve-smoother/index.md @@ -0,0 +1,32 @@ +[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: CURVE SMOOTHER + +![screenshot.png](img/screenshot.png) + +### Authors + +[🐝 STxAxTIC](../stxaxtic.md) [🐝 Fellippe Heitor](../fellippe-heitor.md) + +### Description + +```text +This program demonstrates (i) linear interpolation to create a curve between points, (ii) a relaxation algorithm to "smooth over" a curve to remove sharp edges, and (iii) plotting with anti-aliasing. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "curve-smoother.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/curve-smoother/src/curve-smoother.bas) +* [RUN "curve-smoother.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/curve-smoother/src/curve-smoother.bas) +* [PLAY "curve-smoother.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/curve-smoother/src/curve-smoother.bas) + +### File(s) + +* [curve-smoother.bas](src/curve-smoother.bas) + +🔗 [curve](../curve.md), [interpolation](../interpolation.md) + + +Reference: [qb64forum](https://qb64forum.alephc.xyz/index.php?topic=184.0) diff --git a/samples/curve-smoother/src/curve-smoother.bas b/samples/curve-smoother/src/curve-smoother.bas new file mode 100644 index 0000000..0468bf1 --- /dev/null +++ b/samples/curve-smoother/src/curve-smoother.bas @@ -0,0 +1,311 @@ +'_OE + +Do Until _ScreenExists: Loop +_Title "If these curves were smoother they'd steal your wife." + +' Hardware +Screen _NewImage(800, 600, 32) +_ScreenMove (_DesktopWidth \ 2 - _Width \ 2) - 3, (_DesktopHeight \ 2 - _Height \ 2) - 29 + +' Meta +Randomize Timer + +' Data structures +Type Vector + x As Double + y As Double +End Type + +' Object type +Type Object + Elements As Integer + Shade As _Unsigned Long +End Type + +' Object storage +Dim Shared Shape(300) As Object +Dim Shared PointChain(300, 500) As Vector +Dim Shared TempChain(300, 500) As Vector +Dim Shared ShapeCount As Integer +Dim Shared SelectedShape As Integer + +Dim Shared MasterDraw As String + +' Initialize +ShapeCount = 0 + +' Main loop +Do + Locate 1, 1: Print ShapeCount + Call UserInput + Call Graphics + _Limit 120 +Loop + +System + +Sub UserInput + TheReturn = 0 + ' Keyboard input + kk = _KeyHit + Select Case kk + Case 32 + Do: Loop Until _KeyHit + While _MouseInput: Wend + _KeyClear + Call NewMouseShape(7.5, 400, 15) + Cls + Case Asc("e"), Asc("E") + Open "Curves" + LTrim$(RTrim$(Str$(Int(Timer)))) + ".txt" For Output As #1 + Print #1, MasterDraw + Close #1 + End Select + If (kk) Then + _KeyClear + End If +End Sub + +Sub Graphics + Dim k As Integer + Dim x1 As Double + Dim x2 As Double + Dim y1 As Double + Dim y2 As Double + MasterDraw = "" + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, 255), BF + Call cPrintstring(16 * 17, "PRESS SPACE and then drag MOUSE 1 to draw a new shape.") + For k = 1 To ShapeCount + z$ = "c" + Str$(Shape(k).Shade) + " " + For i = 1 To Shape(k).Elements - 1 + x1 = PointChain(k, i).x + y1 = PointChain(k, i).y + x2 = PointChain(k, i + 1).x + y2 = PointChain(k, i + 1).y + Call lineSmooth(x1, y1, x2, y2, Shape(k).Shade) + + '''' + '' Fellippe, this was it ... + 'dr = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2) + 'ang = (180 / 3.1416 * Atn((y2 - y1) / (x2 - x1))) + 'If (x2 < x1) Then + ' ang = 180 + ang + 'End If + 'z$ = z$ + "TA " + Str$(ang - 90) + " U" + Str$(dr) + " " + '''' + Next + ' Make a point to get DRAW started. + 'Call cPset(PointChain(k, 1).x, PointChain(k, 1).y, Shape(k).Shade) + ' Draw replaces CLine. + 'MasterDraw = MasterDraw + z$ + "___" + 'Draw z$ + Next + _Display +End Sub + +Sub NewMouseShape (rawresolution As Double, targetpoints As Integer, smoothiterations As Integer) + ShapeCount = ShapeCount + 1 + numpoints = 0 + xold = 999 ^ 999 + yold = 999 ^ 999 + Do + Do While _MouseInput + x = _MouseX + y = _MouseY + If (x > 0) And (x < _Width) And (y > 0) And (y < _Height) Then + If _MouseButton(1) Then + x = x - (_Width / 2) + y = -y + (_Height / 2) + delta = Sqr((x - xold) ^ 2 + (y - yold) ^ 2) + If (delta > rawresolution) And (numpoints < targetpoints - 1) Then + numpoints = numpoints + 1 + PointChain(ShapeCount, numpoints).x = x + PointChain(ShapeCount, numpoints).y = y + Call cPset(x, y, _RGB(0, 255, 255)) + xold = x + yold = y + End If + End If + End If + Loop + _Display + Loop Until Not _MouseButton(1) And (numpoints > 1) + + Do While (numpoints < targetpoints) + rad2max = -1 + kmax = -1 + For k = 1 To numpoints - 1 + xfac = PointChain(ShapeCount, k).x - PointChain(ShapeCount, k + 1).x + yfac = PointChain(ShapeCount, k).y - PointChain(ShapeCount, k + 1).y + rad2 = xfac ^ 2 + yfac ^ 2 + If rad2 > rad2max Then + kmax = k + rad2max = rad2 + End If + Next + For j = numpoints To kmax + 1 Step -1 + PointChain(ShapeCount, j + 1).x = PointChain(ShapeCount, j).x + PointChain(ShapeCount, j + 1).y = PointChain(ShapeCount, j).y + Next + PointChain(ShapeCount, kmax + 1).x = (1 / 2) * (PointChain(ShapeCount, kmax).x + PointChain(ShapeCount, kmax + 2).x) + PointChain(ShapeCount, kmax + 1).y = (1 / 2) * (PointChain(ShapeCount, kmax).y + PointChain(ShapeCount, kmax + 2).y) + numpoints = numpoints + 1 + Loop + + For j = 1 To smoothiterations + For k = 2 To numpoints - 1 + TempChain(ShapeCount, k).x = (1 / 2) * (PointChain(ShapeCount, k - 1).x + PointChain(ShapeCount, k + 1).x) + TempChain(ShapeCount, k).y = (1 / 2) * (PointChain(ShapeCount, k - 1).y + PointChain(ShapeCount, k + 1).y) + Next + For k = 2 To numpoints - 1 + PointChain(ShapeCount, k).x = TempChain(ShapeCount, k).x + PointChain(ShapeCount, k).y = TempChain(ShapeCount, k).y + Next + Next + + Shape(ShapeCount).Elements = numpoints + Shape(ShapeCount).Shade = _RGB(100 + Int(Rnd * 155), 100 + Int(Rnd * 155), 100 + Int(Rnd * 155)) + SelectedShape = ShapeCount +End Sub + +Sub cPset (x1 As Double, y1 As Double, col As _Unsigned Long) + PSet (_Width / 2 + x1, -y1 + _Height / 2), col +End Sub + +Sub cLine (x1 As Double, y1 As Double, x2 As Double, y2 As Double, col As _Unsigned Long) + Line (_Width / 2 + x1, -y1 + _Height / 2)-(_Width / 2 + x2 - 0, -y2 + _Height / 2 + 0), col +End Sub + +Sub cPrintstring (y, a As String) + _PrintString (_Width / 2 - (Len(a) * 8) / 2, -y + _Height / 2), a +End Sub + +Sub lineSmooth (x0, y0, x1, y1, c As _Unsigned Long) + 'Credit: FellippeHeitor qb64.org (2020) + ' Adapted from https://en.wikipedia.org/w/index.php?title=Xiaolin_Wu%27s_line_algorithm&oldid=852445548 + 'Edit: Correction to alpha channel (2020-11-20) + + Dim plX As Integer, plY As Integer, plI + + Dim steep As _Byte + steep = Abs(y1 - y0) > Abs(x1 - x0) + + If steep Then + Swap x0, y0 + Swap x1, y1 + End If + + If x0 > x1 Then + Swap x0, x1 + Swap y0, y1 + End If + + Dim dx, dy, gradient + dx = x1 - x0 + dy = y1 - y0 + gradient = dy / dx + + If dx = 0 Then + gradient = 1 + End If + + 'handle first endpoint + Dim xend, yend, xgap, xpxl1, ypxl1 + xend = _Round(x0) + yend = y0 + gradient * (xend - x0) + xgap = (1 - ((x0 + .5) - Int(x0 + .5))) + xpxl1 = xend 'this will be used in the main loop + ypxl1 = Int(yend) + If steep Then + plX = ypxl1 + plY = xpxl1 + plI = (1 - (yend - Int(yend))) * xgap + GoSub plot + + plX = ypxl1 + 1 + plY = xpxl1 + plI = (yend - Int(yend)) * xgap + GoSub plot + Else + plX = xpxl1 + plY = ypxl1 + plI = (1 - (yend - Int(yend))) * xgap + GoSub plot + + plX = xpxl1 + plY = ypxl1 + 1 + plI = (yend - Int(yend)) * xgap + GoSub plot + End If + + Dim intery + intery = yend + gradient 'first y-intersection for the main loop + + 'handle second endpoint + Dim xpxl2, ypxl2 + xend = _Round(x1) + yend = y1 + gradient * (xend - x1) + xgap = ((x1 + .5) - Int(x1 + .5)) + xpxl2 = xend 'this will be used in the main loop + ypxl2 = Int(yend) + If steep Then + plX = ypxl2 + plY = xpxl2 + plI = (1 - (yend - Int(yend))) * xgap + GoSub plot + + plX = ypxl2 + 1 + plY = xpxl2 + plI = (yend - Int(yend)) * xgap + GoSub plot + Else + plX = xpxl2 + plY = ypxl2 + plI = (1 - (yend - Int(yend))) * xgap + GoSub plot + + plX = xpxl2 + plY = ypxl2 + 1 + plI = (yend - Int(yend)) * xgap + GoSub plot + End If + + 'main loop + Dim x + If steep Then + For x = xpxl1 + 1 To xpxl2 - 1 + plX = Int(intery) + plY = x + plI = (1 - (intery - Int(intery))) + GoSub plot + + plX = Int(intery) + 1 + plY = x + plI = (intery - Int(intery)) + GoSub plot + + intery = intery + gradient + Next + Else + For x = xpxl1 + 1 To xpxl2 - 1 + plX = x + plY = Int(intery) + plI = (1 - (intery - Int(intery))) + GoSub plot + + plX = x + plY = Int(intery) + 1 + plI = (intery - Int(intery)) + GoSub plot + + intery = intery + gradient + Next + End If + + Exit Sub + + plot: + ' Change to regular PSET for standard coordinate orientation. + Call cPset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c))) + Return +End Sub + diff --git a/samples/curve.md b/samples/curve.md new file mode 100644 index 0000000..e8a5f47 --- /dev/null +++ b/samples/curve.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: CURVE + +**[Curve Smoother](curve-smoother/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [curve](curve.md), [interpolation](interpolation.md) + +This program demonstrates (i) linear interpolation to create a curve between points, (ii) a relax... diff --git a/samples/cyperium.md b/samples/cyperium.md index dec1936..215af02 100644 --- a/samples/cyperium.md +++ b/samples/cyperium.md @@ -2,6 +2,12 @@ ## SAMPLES BY CYPERIUM +**[Plasma Effect](plasma-effect/index.md)** + +[🐝 Cyperium](cyperium.md) 🔗 [graphics](graphics.md), [plasma](plasma.md) + +Use the left mousebutton to draw a line, change color with the right mousebutton, the middle mous... + **[Space64](space64/index.md)** [🐝 Cyperium](cyperium.md) 🔗 [game](game.md), [space shooter](space-shooter.md) diff --git a/samples/danilin.md b/samples/danilin.md new file mode 100644 index 0000000..105cc16 --- /dev/null +++ b/samples/danilin.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 DANILIN + +**[Relief 3D](relief-3d/index.md)** + +[🐝 Danilin](danilin.md) 🔗 [graphics](graphics.md), [isometric](isometric.md) + +Isometric 3D demo. diff --git a/samples/darokin/index.md b/samples/darokin/index.md index fe18660..ad710d4 100644 --- a/samples/darokin/index.md +++ b/samples/darokin/index.md @@ -18,9 +18,9 @@ Created by QB community member darokin. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "darokin.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/darokin/src/darokin.bas) -* [RUN "darokin.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/darokin/src/darokin.bas) -* [PLAY "darokin.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/darokin/src/darokin.bas) +* [LOAD "darokin.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/darokin/src/darokin.bas) +* [RUN "darokin.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/darokin/src/darokin.bas) +* [PLAY "darokin.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/darokin/src/darokin.bas) ### File(s) diff --git a/samples/data-management.md b/samples/data-management.md index 8d8a26f..405b88a 100644 --- a/samples/data-management.md +++ b/samples/data-management.md @@ -8,12 +8,30 @@ Money manager by Microsoft. -**[Phone](phone/index.md)** +**[MS Phone](ms-phone/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) Simple phone directory by Microsoft. +**[Names](names/index.md)** + +[🐝 David Bannon](david-bannon.md) 🔗 [data management](data-management.md), [dos world](dos-world.md) + +' NAMES.BAS by David Bannon ' Copyright (C) 1992 DOS Resource Guide ' Published in Issue #6, N... + +**[Phone](phone/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [data management](data-management.md), [dos world](dos-world.md) + +' ' PHONE.BAS by Hardin Brothers ' Copyright (C) 1992 DOS Resource Guide ' Published in Issue ... + +**[QB-NVentory](qb-nventory/index.md)** + +[🐝 Nathan Thomas](nathan-thomas.md) 🔗 [data management](data-management.md) + +# qbasic-nventory (i)nventory manager written in qbasic! This is a personal software project fro... + **[QCards](qcards/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) diff --git a/samples/dav.md b/samples/dav.md index ac44a5d..0615b88 100644 --- a/samples/dav.md +++ b/samples/dav.md @@ -7,3 +7,9 @@ [🐝 Dav](dav.md) 🔗 [game](game.md), [puzzle](puzzle.md) '================ 'PIPES.BAS v1.0 '================ 'Connect the pipes puzzle game 'Coded by ... + +**[XE Hex Editor](xe-hex-editor/index.md)** + +[🐝 Dav](dav.md) 🔗 [editor](editor.md), [hex](hex.md) + +'============ 'XE.BAS v1.10 '============ 'A simple Binary File (HEX) editor. 'Coded by Dav on AU... diff --git a/samples/david-bannon.md b/samples/david-bannon.md new file mode 100644 index 0000000..d051487 --- /dev/null +++ b/samples/david-bannon.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 DAVID BANNON + +**[Names](names/index.md)** + +[🐝 David Bannon](david-bannon.md) 🔗 [data management](data-management.md), [dos world](dos-world.md) + +' NAMES.BAS by David Bannon ' Copyright (C) 1992 DOS Resource Guide ' Published in Issue #6, N... diff --git a/samples/david-ferrier.md b/samples/david-ferrier.md new file mode 100644 index 0000000..b383b91 --- /dev/null +++ b/samples/david-ferrier.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 DAVID FERRIER + +**[Saver](saver/index.md)** + +[🐝 David Ferrier](david-ferrier.md) 🔗 [screensaver](screensaver.md), [dos world](dos-world.md) + +1 ' SAVER.BAS by David Ferrier 2 ' Copyright (C) 1992 DOS Resource Guide 3 ' Published in Issu... diff --git a/samples/dec-to-frac/img/screenshot.png b/samples/dec-to-frac/img/screenshot.png new file mode 100644 index 0000000..ad6d9b0 Binary files /dev/null and b/samples/dec-to-frac/img/screenshot.png differ diff --git a/samples/dec-to-frac/index.md b/samples/dec-to-frac/index.md new file mode 100644 index 0000000..2ac44ea --- /dev/null +++ b/samples/dec-to-frac/index.md @@ -0,0 +1,63 @@ +[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: DEC TO FRAC + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 A&A De Pasquale](../a&a-de-pasquale.md) + +### Description + +```text +' DEC_FRAC.BAS - Fraction/Decimal conversion functions +' and sample program + +' by Antonio and Alfonso De Pasquale +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #10, July 1993, page 46 + +============================================================================== + +-------------- + DEC_FRAC.BAS +-------------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x. + +WHAT DEC_FRAC.BAS DOES: +This program converts decimals to fractions and fractions to decimals. + +USING DEC_FRAC.BAS: +To load the program in QBasic, type QBASIC DEC_FRAC.BAS (using path names if +necessary) at the DOS prompt. Then run the program by selecting the Start +option in QBasic's Run menu, or press Shift-F5. The screen will clear, then a +menu will ask if you want to convert a decimal to a fraction or a fraction to +a decimal. + +If you select decimal to fraction, you'll then be prompted to enter a number. +Entering .4, for instance, yields the fractional conversion, 2/5. Entering +.125 produces the fractional equivalent, 1/8. + +For fraction to decimal conversions, you enter fractions using the slash. For +example, entering 3/7 gives a decimal answer of .4285714 + +For further details on DEC_FRAC.BAS, see "Fraction Maker" (DRG #10, July 1993, +page 45). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "dec_frac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/dec-to-frac/src/dec_frac.bas) +* [RUN "dec_frac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/dec-to-frac/src/dec_frac.bas) +* [PLAY "dec_frac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/dec-to-frac/src/dec_frac.bas) + +### File(s) + +* [dec_frac.bas](src/dec_frac.bas) + +🔗 [math](../math.md), [dos world](../dos-world.md) diff --git a/samples/dec-to-frac/src/dec_frac.bas b/samples/dec-to-frac/src/dec_frac.bas new file mode 100644 index 0000000..b843e8e --- /dev/null +++ b/samples/dec-to-frac/src/dec_frac.bas @@ -0,0 +1,123 @@ +' DEC_FRAC.BAS - Fraction/Decimal conversion functions +' and sample program + +' by Antonio and Alfonso De Pasquale +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #10, July 1993, page 46 + +DECLARE FUNCTION DecToFrac$ (decimal) +DECLARE FUNCTION FracToDec (fraction$) + +MAIN: +Cls: Locate 1, 25: Print "Fraction/Decimal Converter" +Locate 2, 21: Print "by Antonio and Alfonso De Pasquale" +Locate 3, 1: For x = 1 To 79: Print "=";: Next x +Locate 5, 1: Print "Please select one of the following choices:" +Locate 7, 10: Print "[D]ecimal to Fraction" +Locate 8, 10: Print "[F]raction to Decimal" +Locate 9, 10: Print "[Q]uit Program" + +Do + Locate 11, 1: Print Space$(79) + Locate 11, 1: Input "Please enter your choice (D/F/Q): ", choice$ + choice$ = UCase$(Left$(choice$, 1)) +Loop Until choice$ = "D" Or choice$ = "F" Or choice$ = "Q" + +CONVERT: +Select Case choice$ + Case "Q" + Cls: End + + Case "D" + Locate 13, 1: Print Space$(79) + Locate 13, 1: Input "Please enter a decimal value: ", decimal$ + decimal = Val(decimal$) + If decimal = 0 Or Int(decimal) = decimal Then GoTo CONVERT + fraction$ = DecToFrac$(decimal) + Locate 16, 1: Print "The Decimal "; decimal; " is equal to the fraction; "; fraction$; "" + + Case "F" + Locate 13, 1: Print Space$(79) + Locate 13, 1: Input "Please enter a fractional value: ", fraction$ + fl$ = fraction$: fl$ = fl$ + " ": fl = InStr(1, fl$, "/") + If Val(fraction$) = 0 Or fl = 0 Then GoTo CONVERT + If (Mid$(fl$, fl - 1, 1) = " ") Or (Mid$(fl$, fl + 1, 1) = " ") Then GoTo CONVERT + decimal = FracToDec(fraction$) + Locate 16, 1: Print "The fraction "; fraction$; " is equal to the decimal "; decimal + +End Select + +Locate 19, 1: Print "Press Enter to continue"; +Do: Loop Until InKey$ = Chr$(13) +GoTo MAIN +End + +'********************************************************* +' +' ACTUAL CONVERSION FUNCTIONS BEGIN HERE +' +'********************************************************* + +Function DecToFrac$ (decimal) + + decimal$ = Str$(decimal) + index = InStr(decimal$, ".") + + If index = 1 Then + decimal$ = "0" + decimal$ + index = index + 1 + End If + + whole$ = Left$(decimal$, index - 1) + dec$ = Mid$(decimal$, index, 10) + + If Val(whole$) = 0 Then + whole$ = "" + End If + + dec = Val(dec$) + dec = Int(dec * 1000 + .5) + + num = dec + den = 1000 + + For pass = 0 To 3 + For index = 10 To 1 Step -1 + If (num / index = Int(num / index)) And (den / index) = Int(den / index) Then + num = (num / index) + den = (den / index) + End If + Next index + Next pass + + fraction$ = whole$ + Str$(num) + "/" + Mid$(Str$(den), 2) + DecToFrac$ = fraction$ + +End Function + +Function FracToDec (fraction$) + + decimal = 0 + dp = 0 + + index = InStr(fraction$, Chr$(32)) + + If index = 0 Then + f$ = fraction$ + Else + whole$ = Left$(fraction$, index) + f$ = Mid$(fraction$, index + 1, 10) + End If + + index = InStr(f$, "/") + num = Val(Left$(f$, index - 1)) + den = Val(Mid$(f$, index + 1)) + + dp = num / den + decimal = Abs(Val(whole$)) + dp + If Left$(fraction$, 1) = "-" Then decimal = (-decimal) + If Left$(fraction$, 1) = "-" And decimal > 0 Then decimal = (-decimal) + FracToDec = decimal + +End Function + diff --git a/samples/diamond-pong/img/screenshot.png b/samples/diamond-pong/img/screenshot.png new file mode 100644 index 0000000..6e523c1 Binary files /dev/null and b/samples/diamond-pong/img/screenshot.png differ diff --git a/samples/diamond-pong/index.md b/samples/diamond-pong/index.md new file mode 100644 index 0000000..e432e47 --- /dev/null +++ b/samples/diamond-pong/index.md @@ -0,0 +1,74 @@ +[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: DIAMOND PONG + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 John Wolfskill](../john-wolfskill.md) + +### Description + +```text +' Diamond Pong +' by +' John Wolfskill +' +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #9, May 1993 +' +' Requires IBM PC with CGA, EGA or VGA color monitor +' A joystick is optional (recommended) + +============================================================================== + +----------- + DPONG.BAS +----------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x. A joystick is optional. + +WHAT DPONG.BAS DOES: +The object of this spin-off of the perennial favorite, Pong, is to score as +many points as possible while propelling a bouncing diamond-shaped pong +through goals located at opposite ends of the playing field. + +USING DPONG.BAS: +To load the program in QBasic, type QBASIC DPONG.BAS (using path names if +necessary) at the DOS prompt. Then run the program by selecting the Start +option in QBasic's Run menu, or press Shift-F5. When the program starts, you +are prompted for the type of monitor you use. Press the 1 key for VGA or the 2 +key for CGA or EGA. Next, select the appropriate input device, pressing 1 for +the keyboard and 2 for the joystick. + +When the diamond-shaped pong appears, you have two minutes to rack up points. +Although the games starts out easy, it becomes more difficult as your score +increases: Walls, bumpers, and other impediments spring up to make play more +challenging. Each time you score a point, you are rewarded with 15 seconds of +extra playing time. + +To control the speed of your paddle, press the P key to decrease the speed and +Shift-P to increase it. The S key and Shift-S control the speed of the pong in +similar fashion. If yours is a relatively slow PC (or you're using the +keyboard for input), you may need to adjust the paddle and pong speeds until +the game feels comfortable. + +For further details on DPONG.BAS, see "Diamond Pong" (DRG #9, May 1993, page +53) and "A Games the Thing" (DRG #9, May 1993, page 59). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "dpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/diamond-pong/src/dpong.bas) +* [RUN "dpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/diamond-pong/src/dpong.bas) +* [PLAY "dpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/diamond-pong/src/dpong.bas) + +### File(s) + +* [dpong.bas](src/dpong.bas) + +🔗 [game](../game.md), [pong](../pong.md), [dos world](../dos-world.md) diff --git a/samples/diamond-pong/src/dpong.bas b/samples/diamond-pong/src/dpong.bas new file mode 100644 index 0000000..a35e8b3 --- /dev/null +++ b/samples/diamond-pong/src/dpong.bas @@ -0,0 +1,310 @@ + ' Diamond Pong + ' by + ' John Wolfskill + ' + ' Copyright (C) 1993 DOS Resource Guide + ' Published in Issue #9, May 1993 + ' + ' Requires IBM PC with CGA, EGA or VGA color monitor + ' A joystick is optional (recommended) + ' + ' -- Program Initialization -- + DEFINT A-Z + GOSUB PROMPT + INPUT "Select color monitor: <1> VGA <2> CGA, EGA Monitor"; VGA + GOSUB PROMPT + INPUT "Input device is <1> Keyboard <2> Joystick"; IDEV + + IF IDEV = 2 THEN + CX = 30: CY = 30 ' default joystick calibration values + GOSUB PROMPT + INPUT "Do you want to calibrate the joystick (Y/N)"; YN$ + IF UCASE$(YN$) = "Y" THEN GOSUB CALIBRATE + END IF + + DIM PONG(1000) ' array to hold pong + DIM PADDLE(1000) ' array to hold paddle + '--- Paddle movement strings --- + L$ = CHR$(0) + CHR$(75): R$ = CHR$(0) + CHR$(77) + U$ = CHR$(0) + CHR$(72): D$ = CHR$(0) + CHR$(80) + DL$ = CHR$(0) + CHR$(79): UR$ = CHR$(0) + CHR$(73) + DR$ = CHR$(0) + CHR$(81): UL$ = CHR$(0) + CHR$(71) + ' -- Data for pong diamond -- + DATA 60,60,66,66,60,72,54,66 + CLICKS = 240 ' 240 seconds. Initial time allocation + PINCR = 4 ' default paddle speed (1-20) + TINC = 3 ' default pong speed (1-20) + IF VGA = 1 THEN SCREEN 13 ELSE SCREEN 1 ' set video mode + '-- Set up playfield -- + WX = 20 ' left edge of pong table + WY = 20 ' top edge pong table + WX1 = 300 ' right edge of pong table + WY1 = 180 ' bottom edge of pong table + MIDY = 20 + (WY1 - WY) / 2 ' middle top (x) of pong table + MIDX = 20 + (WX1 - WX) / 2 ' middle top (y) of pong table + START! = TIMER ' reset game timer + '----- +DO + CLS + BS = INT(((50 - 20) + 1) * RND + 20) ' random bumper size + GOSUB DRAWTABLE ' draw the pong table + '-- Setup the pong -- + REDIM X(4), Y(4) ' arrays hold pong hotspots + RESTORE ' reset data pointer + + FOR J = 1 TO 4 + READ X(J) ' store the default pong hotspots + READ Y(J) + NEXT + + PSET (X(1), Y(1)), 1 ' set the pong position + DRAW "F6G6H6E6BD2P14,1" ' draw it + GET (X(4), Y(1))-(X(2), Y(3)), PONG ' snapshot the pong + LINE (X(4), Y(1))-(X(2), Y(3)), 0, BF ' then erase it + X = X(4): Y = Y(1) ' set inital pong position + CDEEP = (Y(3) - Y(1)) + 1 ' pong depth + CWIDE = (X(2) - X(4)) + 1 ' pong width + '-- Setup the paddle -- + PADX = 160: PADY = 100 ' initial paddle position + GOSUB MAKEPAD ' draw the paddle + GOSUB DISPLAY ' print parmeters + PINGX = TINC: PINGY = TINC ' initial pong movement + ' ------ Main processing loop ------- +DO + X$ = INKEY$ + + IF LEN(X$) THEN + IF LEN(X$) = 2 THEN GOSUB MOVEPADDLE ' check keyboard + IF X$ = "P" THEN IF PINCR < 20 THEN PINCR = PINCR + 1 ' faster paddle + IF X$ = "p" THEN IF PINCR > 1 THEN PINCR = PINCR - 1 ' slower paddle + IF X$ = "S" THEN IF TINC < 20 THEN TINC = TINC + 1 ' faster pong + IF X$ = "s" THEN IF TINC > 1 THEN TINC = TINC - 1 ' slower pong + GOSUB DISPLAY + END IF + + IF X(2) > WX1 OR X(4) < WX THEN 'check for a goal + IF Y(1) > MIDY - 15 AND Y(3) < MIDY + 15 THEN + SCORE = SCORE + 1 ' increment score + START! = START! + 10 ' add bonus 10 secs as reward + SOUND 200, 1: SOUND 400, 1 ' make a happy sound!! + SOUND 600, 1: SOUND 800, 1 ' + EXIT DO + END IF + END IF + + GOSUB MOVEPONG ' move the pong + GOSUB COLLIDE ' check for collision + CURTIME! = TIMER ' get current time + ETIME! = CURTIME! - START! ' subtract to get elapsed time + IF ETIME! > 240 THEN EXITGAME = 1: EXIT DO ' time's up + LOCATE 25, 31: PRINT "TIME:"; 240 - INT(ETIME!); + LOOP + + IF EXITGAME THEN + EXITGAME = 0 + CLS : LOCATE 12, 17: PRINT "GAME OVER" + LOCATE 13, 13: PRINT "Final score "; SCORE; + LOCATE 14, 12: INPUT " Play again (Y/N)"; YN$ + IF UCASE$(YN$) = "N" THEN EXIT DO + SCORE = 0: CLICKS = 240: START! = TIMER ' reset values for new game + END IF + +LOOP +'---- End the game -- +CLS : END +'--------- +MOVEPONG: + SEED = INT(((5 - (-5)) + 1) * RND(1) + (-5)) ' random bounce angle seed + + IF X < WX THEN ' pong hit left wall + X(4) = WX: X(3) = WX + 6 ' reset pong hotspots + X(2) = WX + 12: X(1) = WX + 6 + X = WX ' reset pong coordinates + PINGX = TINC: SOUND 1000, 1 ' make it bounce away + PINGY = TINC + SEED ' SEED creates pseudo-random bounce + END IF + + IF X + CWIDE > WX1 THEN 'pong hit right wall + X(4) = WX1 - 12: X(3) = WX1 - 6 ' reset pong hotspots + X(2) = WX1: X(1) = WX1 - 6 + X = WX1 - CWIDE ' reset pong x coordinate + PINGX = -TINC: SOUND 1000, 1 ' make it bounce away + PINGY = -TINC - SEED ' SEED creates pseudo-random bounce + END IF + + IF Y < WY THEN ' pong hit top wall + Y(4) = WY + 6: Y(3) = WY + 12 ' reset pong hotspots + Y(2) = WY + 6: Y(1) = WY + Y = WY ' and pong y coordinate + PINGY = TINC: SOUND 1000, 1 ' make it bounce away + PINGX = -TINC + SEED ' SEED creates psuedo-random bounce + END IF + + IF Y + CDEEP > WY1 THEN ' pong hit bottom wall + Y(4) = WY1 - 6: Y(3) = WY1 ' reset hotspots + Y(2) = WY1 - 6: Y(1) = WY1 - 12 + Y = WY1 - CDEEP ' and pong y coordinate + PINGY = -TINC: SOUND 1000, 1 ' make it bounce away + PINGX = TINC - SEED ' SEED creates puedo-random bonce + END IF + + FOR J = 1 TO 4 ' update all hotspot coordinates + X(J) = X(J) + PINGX + Y(J) = Y(J) + PINGY + NEXT + + PUT (X, Y), PONG, XOR ' print the pong + + + IF IDEV = 2 THEN ' if joystick in use + AA = STICK(0): BB = STICK(1) ' get x,y coordinates + DG = 0 ' set the activity flag + IF AA < CX - 8 AND BB > CY - 8 THEN X$ = DL$: DG = 1' move down and left + IF AA > CX + 8 AND BB < CY - 8 THEN X$ = UR$: DG = 1' move up and right + IF AA > CX + 8 AND BB > CY + 8 THEN X$ = DR$: DG = 1' move down and right + IF AA < CX - 8 AND BB < CY - 8 THEN X$ = UL$: DG = 1' move up and left + + IF DG = 0 THEN + IF AA < CX - 8 THEN X$ = L$: DG = 1 ' move left + IF AA > CX + 8 THEN X$ = R$: DG = 1 ' move right + IF BB < CY - 8 THEN X$ = U$: DG = 1 ' move up + IF BB > CY + 8 THEN X$ = D$: DG = 1 ' move down + END IF + + IF DG THEN GOSUB MOVEPADDLE ' move the paddle + ELSE + GOSUB SWAIT ' if no joystick, a small time delay + END IF + + PUT (X, Y), PONG, XOR ' erase the pong + IF HIT THEN HIT = 0: TINC = TTINC ' reset pong accelerator flag + + IF IDEV = 2 THEN ' if joystick installed + GOSUB MOVEPADDLE ' move the paddle + ELSE + GOSUB SWAIT ' create a small time delay + END IF + + X = X + PINGX ' move x coordinate of pong + Y = Y + PINGY ' move y coordinate of pong + RETURN +'--- Print paddle/pong speed and score -- +DISPLAY: + LOCATE 25, 1: PRINT "SCORE:"; : PRINT USING "##"; SCORE; + LOCATE 25, 11: PRINT "PD:"; : PRINT USING "##"; TINC; + LOCATE 25, 21: PRINT "

AD:"; : PRINT USING "##"; PINCR; + RETURN +'-- Print the paddle -- +PP: + PUT (PADX, PADY), PADDLE, XOR ' print the paddle + RETURN +'-- Check paddle bounds and erase it -- +PP1: + IF PADY + PDEEP > WY1 THEN PADY = WY1 - PDEEP ' keep paddle in bounds + IF PADY < WY THEN PADY = WY + IF PADX + PWIDE > WX1 THEN PADX = WX1 - PWIDE + IF PADX < WX THEN PADX = WX + PUT (PADX, PADY), PADDLE, XOR ' erase the paddle + RETURN +'-- Move the paddle -- +MOVEPADDLE: + GOSUB PP + IF X$ = D$ THEN PADY = PADY + PINCR: PADY1 = PADY1 + PINCR + IF X$ = U$ THEN PADY = PADY - PINCR: PADY1 = PADY1 - PINCR + IF X$ = L$ THEN PADX = PADX - PINCR: PADX1 = PADX1 - PINCR + IF X$ = R$ THEN PADX = PADX + PINCR: PADX1 = PADX1 + PINCR + IF X$ = UR$ THEN PADX = PADX + PINCR: PADY = PADY - PINCR + IF X$ = UL$ THEN PADX = PADX - PINCR: PADY = PADY - PINCR + IF X$ = DR$ THEN PADX = PADX + PINCR: PADY = PADY + PINCR + IF X$ = DL$ THEN PADX = PADX - PINCR: PADY = PADY + PINCR + GOSUB PP1 + RETURN +'-- Draw the playing field -- +DRAWTABLE: + LINE (WX - 1, WY - 1)-(WX1 + 1, WY1 + 1), 2, B ' draw the playfield + LINE (WX1 + 1, MIDY - 15)-(WX1 + 1, MIDY + 15), 0, B ' right goal + LINE (WX - 1, MIDY - 15)-(WX - 1, MIDY + 15), 0, B ' left goal + + IF SCORE > 1 THEN + LINE (MIDX - 3, WY)-(MIDX + 3, WY + (BS)), 3, BF ' top bumper + LINE (MIDX - 4, WY + (BS))-(MIDX + 4, WY + (BS)), 3, B ' top bumper rail + END IF + + IF SCORE > 2 THEN + LINE (MIDX - 16, WY1)-(MIDX - 10, WY1 - (BS)), 3, BF ' btm bumper + LINE (MIDX - 17, WY1 - (BS))-(MIDX - 9, WY1 - (BS)), 3, B ' btm bumper rail + END IF + + IF SCORE > 3 THEN + CIRCLE (MIDX + 50, MIDY - 20), 10, 3 'left round bumper + PAINT (MIDX + 50, MIDY - 20), 3, 3 + END IF + + IF SCORE > 4 THEN + CIRCLE (MIDX - 50, MIDY + 20), 10, 3 ' right round bumper + PAINT (MIDX - 50, MIDY + 20), 3, 3 + END IF + + IF SCORE > 8 THEN + LINE (WX1 - 32, MIDY - 5)-(WX1 - 22, MIDY + 5), 3, BF ' right goal block + END IF + + IF SCORE > 10 THEN + LINE (WX + 32, MIDY - 5)-(WX + 22, MIDY + 5), 3, BF ' left goal block + END IF + + RETURN + +'-- Create a short time delay to control XOR flashing -- +SWAIT: + T! = TIMER: WHILE T! = TIMER: WEND: RETURN +'--- Check for a collision between color 3 objects and the pong -- +COLLIDE: + SIDE = 0 ' reset collision flag + + FOR J = 1 TO 4 + IF POINT(X(J), Y(J)) = 3 THEN ' is the pixel under hotspot color 3 ? + SIDE = J ' collision on this side! + SOUND 2000, 1 ' sound the collision alert + EXIT FOR ' abandon ship + END IF + NEXT + + IF SIDE THEN + TTINC = TINC ' save the old pong speed + TINC = INT(((12 - 5) + 1) * RND(1) + 5) ' random pong accelerator + HIT = 1 ' set the accelerator flag + END IF + + IF SIDE = 1 THEN PINGX = 0: PINGY = TINC ' collison top side + IF SIDE = 2 THEN PINGX = -TINC: PINGY = 0 ' collision right side + IF SIDE = 3 THEN PINGX = 0: PINGY = -TINC ' collsion bottom side + IF SIDE = 4 THEN PINGX = TINC: PINGY = 0 ' collsion left side + RETURN +'-- Create the paddle -- +MAKEPAD: + PADX1 = PADX + 4: PADY1 = PADY + 18 ' paddle coordinates + PWIDE = (PADX1 - PADX) + 1 ' paddle width + PDEEP = (PADY1 - PADY) + 1 ' paddle depth + LINE (PADX, PADY)-(PADX1, PADY1), 3, BF ' create the paddle + GET (PADX, PADY)-(PADX1, PADY1), PADDLE ' snapshot the paddle + LINE (PADX, PADY)-(PADX1, PADY1), 0, BF ' then erase it + PUT (PADX, PADY), PADDLE, XOR ' place it on the screen + RETURN +'---- Erase the screen -- +PROMPT: + CLS : LOCATE 12, 12 ' prepare to display the prompt + RETURN +'-- Calibrate the joystick -- +CALIBRATE: + GOSUB PROMPT + PRINT "Please center the joystick lever. Press "; + DO + X$ = INKEY$ + IF X$ = CHR$(13) THEN + CX = STICK(0): CY = STICK(1) ' read joystick centerline values + RETURN + END IF + LOOP + + diff --git a/samples/didris/img/screenshot.png b/samples/didris/img/screenshot.png new file mode 100644 index 0000000..8a3d41c Binary files /dev/null and b/samples/didris/img/screenshot.png differ diff --git a/samples/didris/index.md b/samples/didris/index.md new file mode 100644 index 0000000..298b5aa --- /dev/null +++ b/samples/didris/index.md @@ -0,0 +1,33 @@ +[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: DIDRIS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Dietmar Moritz](../dietmar-moritz.md) + +### Description + +```text +'________________________This_is_the_unbelievable +'________ÜÜÜ___ÜÜ_________ÜÜÜ____________ÜÜ +'_______Û___Û_ßÜÜß_______Û___Û__________ßÜÜß_________________________Ü__Ü +'_______Û___Û__ÜÜ________Û___Û__ÜÜÜ_ÜÜ___ÜÜ____ÜÜÜÜ________________Üß_Üß__Ü +'__Üßßßß____Û_Û__Û__Üßßßß____Û_Û___ß__Û_Û__Û_Üß____ßÜ__________ÜÜ_ÜÜ____Üß +'_Û_________Û_Û__Û_Û_________Û_Û___Üßß__Û__Û_ßÜ__ßÜÜß_________ÛÜ_ÛÜ_Û +'_Û_________Û_Û__Û_Û_________Û_Û__Û_____Û__Û_ÜßßÜ__ßÜ__Üßßßßßß____ßß +'_ßÜ________Û_Û__Û_ßÜ________Û_Û__Û_____Û__Û_ßÜ____Üß__Û______________ÜßßÜ +'___ßßßßßßßß___ßß____ßßßßßßßß___ßß_______ßß____ßßßß_____ßßßßßÛ______Ü___Üß +'______________________________________ver_2.2_______________ßÜÜÜÜÜß__Ü__Û +'__________________________________by_Dietmar_Moritz_________Û_________ßß +'____________________________________________________________ßÜÜÜÜÜÜ +``` + +### File(s) + +* [didris.bas](src/didris.bas) +* [didris.zip](src/didris.zip) + +🔗 [game](../game.md), [tetris](../tetris.md) diff --git a/samples/didris/src/didris.bas b/samples/didris/src/didris.bas new file mode 100644 index 0000000..62ad01d --- /dev/null +++ b/samples/didris/src/didris.bas @@ -0,0 +1,2614 @@ +' This is the unbelievable +' +' +' +' +' +' +' +' +' ver 2.2 +' by Dietmar Moritz +' +' +' I started this program in summer '97 and finished November '98. +' +' I've done this with Quick Basic 4.5, but you can also run it under QBasic! +' I still have some good ideas for this game, but I wanted to write a game +' which I can compile in only one EXE-File, so I shortened the source code. +' Maybe I will write a new, much more bigger DIDRIS for Quick Basic 4.5 only! +' --------------------------------------------------------------------------- +' Please do NOT run this program under Windows!!! +' It's not as fast as in good old DOS!!! +' I also recommend Quick Basic 4.5!!! +' --------------------------------------------------------------------------- +' Please read the READ ME!!! +' --------------------------------------------------------------------------- +' If you want to e-mail me: didi@forfree.at +' or: didi_op@hotmail.com +' --------------------------------------------------------------------------- +' Have fun!!! :-) + +' a740g: QB64 changes +' - Replaced Play(x) on/off with Timer(2) on/off (seems to work mostly). There are some sideeffects. :( +' - Added delays wherever animations are too fast +' - Using QB64 defined _pi + +$Resize:Smooth +_FullScreen _SquarePixels , _Smooth + +Dim Shared bst(1 To 41, 1 To 10, 1 To 10) +Dim Shared buch(1 To 5, 1 To 19, 1 To 19) As Integer + +Dim Shared bomb As Integer +Dim Shared nextbomb As Integer + +Dim Shared hf1(1 To 14, 2 To 14) As Integer +Dim Shared hf2(1 To 14, 2 To 14) As Integer +Dim Shared helion As Integer +Dim Shared blowheli As Integer +Dim Shared helix As Integer +Dim Shared heliy As Integer +Dim Shared helilt +Dim Shared rotor As Integer + +Dim Shared leiter(1 To 14, 1 To 14) As Integer + +Dim Shared tropfen(1 To 14, 1 To 14) As Integer + +Dim Shared boom(1 To 14, 1 To 14) As Integer + +Dim Shared para(1 To 14, 1 To 14) As Integer +Dim Shared paraon + +Dim Shared maxfeld(1 To 14, 1 To 28) As Integer +Dim Shared bc As Integer +Dim Shared maxframe As Integer +Dim Shared maxstill As Integer + +Const linienpunkte = 15 + +Const maxacid = 100 +Const acidplus = 4 +Dim Shared acid As Integer +Dim Shared showallacid As Integer + +Const belegt% = 1 +Const Frei% = 0 +Const maxlinie = 4 + +Const fb = 12 +Const fh = 23 +Const bg = 14 + +Dim Shared maxposx As Integer +Dim Shared maxposy As Integer +Dim Shared maxlt + +Dim Shared feld%(-1 To fb + 3, -1 To fh + 2) +Dim Shared farb%(-1 To fb + 3, -1 To fh + 2) +Dim Shared blockx%(4) +Dim Shared blocky%(4) + +Const Musikanzahl = 3 +Dim Shared Musiklaenge(Musikanzahl) As Integer +Dim Shared Musik$(50, Musikanzahl) +Dim Shared Musikstueck% +Dim Shared musi% +Dim Shared nomusik + +Dim Shared punkte As Integer +Dim Shared Linienweg As Integer +Dim Shared Level As Integer + +Dim Shared nstr% + +Dim Shared endeundaus + +Dim Shared hoho%(4) + +Dim Shared already As Integer + +Dim Shared yn(1 To 4) As Integer +For I = 1 To 4 + yn(I) = 1 +Next I + +getsprites + +init +init.ffont + + +Randomize Timer + +Do + + Screen 12 + + Cls + If already = 0 Then + Intro + Cls + Titel + Cls + End If + + menu + main + + Palette + Color + clear.var + already = 1 +Loop + +keine: +h = 1 +Resume Next + + + +hinter: +If musi% < Musiklaenge(Musikstueck%) Then + musi% = musi% + 1 +Else + musi% = 1: + m% = Musikstueck% + Do + Musikstueck% = Int(Rnd * (Musikanzahl)) + 1 + Loop Until Musikstueck% <> m% + Play "mb p1" +End If +Play "mb" + Musik$(musi%, Musikstueck%) +Return + +'Fallschirm +Data ,,,,2,2,1,1,2,2,,,, +Data ,,2,2,1,2,2,2,2,1,2,2,, +Data 1,2,2,2,2,1,2,2,1,2,2,2,2,1 +Data 2,1,2,2,,,,,,2,2,2,1,2 +Data 2,2,1,7,,,,,,,7,1,2,2 +Data 7,,,7,,,,,,,7,,,7 +Data ,7,,,7,,,,,7,,,7, +Data ,7,,,7,,,,,7,,,7, +Data ,,7,,,7,,,7,,,7,, +Data ,,7,,,7,,,7,,,7,, +Data ,,,7,,7,,,7,,7,,, +Data ,,,7,,,7,7,,,7,,, +Data ,,,,7,,7,7,,7,,,, +Data ,,,,7,,7,7,,7,,,, + +'Explosion +Data 4,,,,,,4,4,,,,,4,4 +Data 4,4,,,,4,4,4,4,,,4,4,4 +Data 4,4,4,,,4,12,12,4,4,4,4,4,4 +Data 4,4,4,4,4,4,12,12,12,12,12,12,4, +Data ,4,4,12,12,12,12,12,14,14,12,12,4, +Data ,,4,12,14,14,14,14,14,14,14,12,4,4 +Data ,4,4,12,12,14,14,14,14,12,12,12,12,4 +Data ,4,12,12,14,14,14,14,14,14,12,12,4,4 +Data 4,4,12,12,12,14,14,14,14,14,12,4,4, +Data 4,12,12,12,14,14,12,12,14,14,12,4,, +Data 4,4,4,12,12,12,12,12,12,12,12,4,, +Data ,,4,12,12,4,4,4,4,12,12,4,4, +Data ,4,4,12,4,4,,,4,4,4,4,4,4 +Data ,4,4,4,4,,,,,4,,,4,4 + +'Tropfen +Data ,,,,,,1,,,,,,, +Data ,,,,,,1,1,,,,,, +Data ,,,,,,1,1,1,,,,, +Data ,,,,,,1,2,1,,,,, +Data ,,,,,1,1,2,1,1,,,, +Data ,,,,,1,2,2,2,1,,,, +Data ,,,,1,1,2,10,2,1,1,,, +Data ,,,1,1,2,2,10,2,2,1,,, +Data ,,1,1,2,2,3,10,10,2,1,1,, +Data ,,1,2,2,3,10,10,10,2,2,1,, +Data ,,1,2,2,10,10,10,10,2,2,1,, +Data ,,1,1,2,2,10,10,2,2,1,,, +Data ,,,1,1,2,2,2,2,1,1,,, +Data ,,,,1,1,1,1,1,1,,,, + +'Leiter +Data ,6,,,,,,,,,,6,, +Data ,6,,,,,,,,,6,6,, +Data 6,7,6,6,6,6,6,6,6,6,7,,, +Data 6,6,,,,,,,,,6,6,, +Data ,6,,,,,,,,,,6,, +Data ,7,6,6,6,6,6,6,6,6,6,7,, +Data ,6,,,,,,,,,,6,, +Data ,6,,,,,,,,,,6,, +Data ,6,,,,,,,,,,6,, +Data 6,7,6,6,6,6,6,6,6,6,6,7,, +Data 6,,,,,,,,,,6,,, +Data 6,,,,,,,,,,6,,, +Data 6,7,6,6,6,6,6,6,6,6,7,6,, +Data ,6,,,,,,,,,,6,, + +'max +Data ,,,,,8,8,8,8,,,,, +Data ,,,,8,8,8,8,8,8,,,, +Data ,,,,,12,9,9,12,,,,, +Data ,,,,,12,12,12,12,,,,, +Data ,,,,,,12,12,,,,,, +Data ,,,,2,2,2,8,7,2,,,, +Data ,,,8,2,8,2,2,2,2,7,,, +Data ,,2,7,,7,8,2,2,,8,2,, +Data ,,13,,,2,2,7,8,,,13,, +Data ,,,,,8,2,2,2,,,,, +Data ,,,,,7,2,8,2,,,,, +Data ,,,,8,2,,,7,2,,,, +Data ,,,,7,2,,,2,8,,,, +Data ,,,6,6,6,,,6,6,6,,, + +Data ,,,,,8,8,8,8,,,,, +Data ,,,,8,8,8,8,8,8,,,, +Data ,,,,,12,9,9,12,,,,, +Data ,,13,,,12,12,12,12,,,13,, +Data ,,2,7,,,12,12,,,8,2,, +Data ,,,8,2,2,2,8,7,2,7,,, +Data ,,,8,2,8,2,2,2,2,,,, +Data ,,,,,7,8,2,2,,,,, +Data ,,,,,2,2,7,8,,,,, +Data ,,,,,8,2,2,2,,,,, +Data ,,,,,7,2,8,2,,,,, +Data ,,,,8,2,,,7,2,,,, +Data ,,,,7,2,,,2,8,,,, +Data ,,,6,6,6,,,6,6,6,,, + +'heli +Data ,,,,,,,,,,,,,,,15,15,,,,,,,,,,, +Data ,,,,,,,,,,,,,,4,4,4,4,4,4,4,4,,,,,, +Data 2,4,,,,,,,,,,,4,4,4,4,4,4,4,4,4,4,1,1,,,, +Data 4,4,7,,,,,,,,,,4,4,4,4,4,,,,4,4,1,1,1,,, +Data 4,7,7,7,,,,,,,,4,4,4,4,4,4,,,,4,4,4,1,1,1,, +Data 7,7,8,7,7,,,,,,,4,4,4,4,4,4,,,,4,4,4,1,1,1,, +Data 4,7,7,7,4,4,4,4,4,4,4,4,4,4,4,4,4,,,,,4,4,4,1,1,, +Data 4,4,7,4,4,4,4,4,4,4,4,4,4,4,4,4,4,,,,,4,4,4,4,4,, +Data ,,,,,,,,,,,4,4,4,4,4,4,,,,,4,4,8,8,8,8,8 +Data ,,,,,,,,,,,,4,4,4,4,4,4,4,4,4,4,4,4,4,4,, +Data ,,,,,,,,,,,,,4,4,4,4,4,4,4,4,4,4,4,4,,, +Data ,,,,,,,,,,,,,,,4,,,,,,,4,,,,8, +Data ,,,,,,,,,,,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8, + +'Font +Data 1,1,1,1,,,1,,,1,,1,1,1,,,1,,,1,1,1,1,1,,,1,1,1,,1,,,,,1,,,,,1,,,,1,,1,1,1, +Data 1,1,1,1,,,1,,,1,,1,,,1,,1,,,1,1,1,1,1,,1,1,1,1,1,1,,,,,1,1,1,1,,1,,,,,1,1,1,1,1 +Data 1,,,,1,1,1,,,1,1,,1,,1,1,,,1,1,1,,,,1,,1,1,1,,1,,,,1,1,,,,1,1,,,,1,,1,1,1, +Data 1,1,1,1,,1,,,,1,1,1,1,1,,1,,,,,1,,,,,,1,1,1,,1,,,,1,1,,1,,1,1,,,1,1,,1,1,1,1 +Data 1,1,1,1,,1,,,,1,1,1,1,1,,1,,,1,,1,,,,1,,1,1,1,1,1,,,,,,1,1,1,,,,,,1,1,1,1,1, +Data 1,1,1,1,1,,,1,,,,,1,,,,,1,,,,,1,,,1,,,,1,1,,,,1,1,,,,1,1,,,,1,,1,1,1, +Data 1,,,,1,,1,,1,,,,1,,,,,1,,,,,1,,,,1,1,1,,1,,,1,1,1,,1,,1,1,1,,,1,,1,1,1, +Data ,,1,,,,1,1,,,,,1,,,,,1,,,,1,1,1,,,1,1,1,,1,,,,1,,,1,1,,,1,,,,1,1,1,1,1 +Data 1,1,1,1,,,,,,1,,1,1,1,,,,,,1,1,1,1,1,,,,,1,,,,1,1,,,1,,1,,1,1,1,1,1,,,,1, +Data 1,1,1,1,,1,,,,,1,1,1,1,,,,,,1,1,1,1,1,,,1,1,1,,1,,,,,1,1,1,1,,1,,,,1,,1,1,1, +Data 1,1,1,1,1,,,,,1,,,,1,,,,1,,,,,1,,,,1,1,1,,1,,,,1,,1,1,1,,1,,,,1,,1,1,1, +Data ,1,1,1,,1,,,,1,,1,1,1,1,,,,,1,,1,1,1,,,,,,,,1,,,,,,,,,,1,,,,,,,, +Data ,,,,,,,,,,1,1,1,1,,,,,,,,,,, + +'READY +Data 7,3,13,,3,,12,,3,,12,,3,,11,,5,,10,,5,,10,,5,,9,,7,,9,5,2,,x,,2,,7,6,3,,6,,9,,6,,9,,6,,9,,5,,11,,4,,11,,4,,11,,4,,11,,2,2,13,2,2,10,6,,10,2,4,,12,,3,,13,,2, +Data 13,,2,,x,,,,x,,,,x,,,,x,,,,x,,,,x,,,,x,,,,x,,,,13,2,,,13,,2,,12,,3,,10,2,4,,9,,5,,11,5,3,12,4,,12,,3,,2,10,4,,,,x,,,,x,,,,x,,,,x,,,,x,,2,8 +Data 6,,10,,5,,2,8,6,,,,x,,,,x,,,,x,,,,x,,,,x,,2,10,4,,12,,,2,x,,3,7,9,,7,2,7,,9,,6,,10,,5,,10,,5,,10,,5,,10,,5,,9,,6,,7,2,7,,4,3,9,,3,,12,,3,,12,,4,,11,,5, +Data 10,,6,,9,,7,,8,,8,,7,,9,,4,2,11,4,3,,9,,5,,,,7,,,,4,,2,,5,,2,,5,,,,5,,,,6,,2,,3,,2,,7,,,,3,,,,8,,2,,,,2,,9,,2,,2,,11,,3,,13,,,,x,,,,x,,,,x,,,,x,,,,x,,,,x,,,,x,,,,x,,,,7,7,3,7 + +Data "T240l8n38n39n40l4n48l8n40l4n48l8n40l4n48p64p64l8n48n50" +Data "l8n51n52n48n50l4n52l8n47l4n50l3n48l8n38n39" +Data "l8n40l4n48l8n40l4n48l8n40l4n48p64p64l8n45n43n42l8n45" +Data "l8n48l4n52l8n50l8n48l8n45l3n50l8n38n39n40l4n48" +Data "l8n40l4n48l8n40l4n48p64p64l8n48n50n51n52n48n50" +Data "l4n52l8n47l4n50n48p64l8n48n50n52n48n50l4n52" +Data "l8n48n50n48n52n48l8n50l4n52l8n48n50n48" +Data "l8n52n48n50l4n52l8n47l4n50l4n48p64l8n40l8n41l8n42" +Data "l4n43l8n45l4n43l8n40l8n41l8n42l4n43l8n45l4n43l8n52" +Data "l8n48l8n43l8n45l8n47l8n48l8n50l8n52l8n50l8n48l8n50" +Data "l4n43p64l8n43l8n40l8n41l4n43l8n45l4n43l8n40l8n41l8n42" +Data "l4n43l8n45l8n43p64l8n43l8n45l8n46l8n47l8n47p64l4n47l8n45" +Data "l8n42l8n38l4n43" +Data "MUSIKENDE" + +Data "T110l6n35l16n36l3n38l16n35l8n33l16n35l2n31l6n35l16n35" +Data "l6n33l16n31l3n28l16n28l6n35l16n35l2n33l6n35l16n36l3n38" +Data "l16n35l8n33l16n35l2n31l6n35l16n35l6n33l16n31l3n28l16n28" +Data "l6n35l16n35l2n33l6n35l16n36l3n38l16n35l8n33l16n35l2n31" +Data "l6n35l16n35l6n33l16n31l3n28l16n28l6n35l16n35l2n33l6n35" +Data "l16n36l3n38l16n35l8n33l16n35l2n31l6n35l16n35l6n33l16n31" +Data "l3n28l16n28l6n35l16n35l2n33p64p64l5n38l5n38l5n38l6n38l16n40" +Data "l6n33l16n33l6n33l16n33l2n33l6n33l16n33l6n33l16n33l2n33" +Data "l6n31l16n31l6n31l16n31l2n31l5n38l5n38l5n38l6n38l16n40" +Data "l6n33l16n33l6n33l16n33l2n33l6n33l16n33l6n33l16n33l2n33" +Data "l6n31l16n31l6n31l16n31l2n31" +Data "MUSIKENDE" + +Data "T220MSl3n40l8n40l4n43l4n47l4n46n46l2n42l4n33l4n33" +Data "l4n33n33n35n35l2n35l3n40l8n40l4n43l4n47l4n49" +Data "l4n49n46n49n51n48n43n45l2n47l8n47n45" +Data "l8n43n42l2n40l4n31l7n43l8n47l4n52n52n51n54" +Data "l2n52l4n31l8n43l8n47l4n52l4n52n51n54l2n52l8n47" +Data "l8n45n43n42l3n40l8n40l4n43n47n46n46l2n42" +Data "l4n33n33n33n33n35n35l2n35l3n40l8n40l4n43" +Data "l4n47n49n49n46n49n51n48n43n45l2n47l8n47n45n43n42l2n40" +Data "l4n31l7n43l8n47l4n52n52n51n54l2n52l4n31l8n43" +Data "l8n47l4n52n52n51n54l2n52l8n47n45n43n42" +Data "MUSIKENDE" + +Sub acidrain + maxar = fb + Dim ar(maxar) As Integer + Dim armax(maxar) As Integer + For x% = 1 To fb + For y% = 1 To fh - 1 + If feld%(x%, y%) = belegt% Then Exit For + Next y% + armax(x%) = y% + If feld%(x%, y%) = belegt% Then + feld%(x%, y%) = Frei% + farb%(x%, y%) = 0 + End If + Next x% + For I% = 1 To maxar + ar(I%) = Int(Rnd * (3)) - 3 + Next I% + Do + For I% = 1 To maxar + If ar(I%) < armax(I%) Then + ar(I%) = ar(I%) + 1 + kastl I%, ar(I%), 33 + End If + Next I% + t = Timer + Do + Loop Until Timer >= t + .15 + For I% = 1 To maxar + kastl I%, ar(I%), 0 + Next I% + chk = 0 + For I% = 1 To maxar + If ar(I%) >= armax(I%) Then chk = chk + 1 + Next I% + If chk = maxar Then Exit Do + Loop + nichtganzalles + If yn(4) = 1 Then + acid = 0 + show.acidometer + End If +End Sub + +Sub alles + + For x% = -480 To 640 Step 20 + For I% = 0 To 2 + Line (x% + I%, 0)-(x% + 480 + I%, 480), 8 + Line (x% - I%, 0)-(x% + 480 - I%, 480), 7 + Line (x% - I% + 480, 0)-(x% - I%, 480), 7 + Line (x% + 480 + I%, 0)-(x% + I%, 480), 8 + Next I% + Next x% + + Line (320 + 1 - fb * bg / 2, 240 + 1 - fh * bg / 2 + bg)-(321 - 1 + fb * bg / 2, 240 - 1 + fh * bg / 2 + 1 + bg), 0, BF + + x1% = ((320 - fb * bg / 2) + ((-4) * bg) + 1) + y1% = ((240 - fh * bg / 2) + ((1) * bg) + 1) + x2% = ((320 - fb * bg / 2 - 1) + ((-1) * bg) + 1) + y2% = ((240 - fh * bg / 2) + (5) * bg) + Line (x1%, y1%)-(x2%, y2%), 0, BF + Line (x1% - 1, y1% - 1)-(x2% + 1, y2% + 1), 2, B + + Color 8 + u = 10 + + Draw "c1 bm190,70 u40 r 20 F30 d10 l30 u10 r13 h17 l3 d27 l13" + Paint (191, 68), 2, 1 + Draw "c1 bm250,70 u40 r13 d40 l13" + Paint (253, 68), 2, 1 + Draw "c1 bm275,70 u40 r 20 F30 d10 l30 u10 r13 h17 l3 d27 l13" + Paint (277, 68), 2, 1 + Draw "c1 bm335,70 u40 r22" + Line -Step(20, 15), 1 + Line -Step(-16, 10), 1 + Draw "f15 l13 h12 u7" + Line -Step(9, -6), 1 + Line -Step(-8, -5), 1 + Draw "l4 d30 l12" + Paint (337, 68), 2, 1 + Draw "c1 bm385,70 u40 r13 d40 l13" + Paint (387, 68), 2, 1 + Draw "c1 bm410,70 u10 r23 e5 l27 u15 e10 r30 d10 l23 g5 r27 d15 g10 l30" + Paint (413, 68), 2, 1 + + Tasten + Punktezahl + nichtganzalles + + If yn(4) = 1 Then + Color 11 + Locate 26, 10: Print "Acid-O-Meter" + showallacid = 1 + show.acidometer + showallacid = 0 + End If + + If yn(3) = 1 Then + Line (220, 440)-(420, 470), 0, BF + Line (220, 440)-(420, 470), 15, B + show.font2 "BODY-COUNT:", 2, 0, 1, 235, 448 + show.bodycount + End If + +End Sub + +Sub ausis + 'TODO + Timer Off + If Play(1) <> 0 Then Beep + + showpoints + showhiscore + + endeundaus = 1 +End Sub + +Sub ausss + show.verynicegraphic + + Screen 0 + Color 1, 4 + Print "Freeware by Dietmar Moritz" + Print + Color 2, 0 + Print "Thanks for playing" + Color 15, 0 + Print + Print " / / / / / /" + Print " _/ _/ __/ /__/" + Print " // // / /_//_/" + Print " // //" + Print " // // // //_/" + Print " / / // ///" + Print " /___/ /_/ /____/ /_/ /_/ /_/ /____/ "; + Color 3 + Print " v2.2" + Print Spc(67); "(22.11.98)" + Color 8, 0 + For y% = 2 To 25 + For x% = 1 To 80 + If Screen(y%, x%) = 179 Then Locate y%, x%: Print "" + If Screen(y%, x%) = Asc("/") Then Locate y%, x%: Print "/" + If Screen(y%, x%) = Asc("_") Then Locate y%, x%: Print "_" + Next x% + Next y% + End +End Sub + +Sub clear.var + + bomb = 0 + nextbomb = 0 + + helion = 0 + blowheli = 0 + helix = 0 + heliy = 0 + helilt = 0 + rotor = 0 + bc = 0 + maxframe = 0 + maxstill = 0 + + acid = 0 + showallacid = 0 + + maxposx = 0 + maxposy = 0 + maxlt = 0 + + For x% = -1 To fb + 3 + For y% = -1 To fh + 2 + feld%(x%, y%) = 0 + farb%(x%, y%) = 0 + Next y% + Next x% + + punkte = 0 + Linienweg = 0 + Level = 0 + + nstr% = 0 + + endeundaus = 0 +End Sub + +Sub drehen (struktur%) + Select Case struktur% + Case 1 + If (blockx%(2) + 1 = blockx%(1)) And (feld%(blockx%(1) + 1, blocky%(1)) <> belegt%) Then + blockx%(3) = blockx%(3) - 1: blocky%(3) = blocky%(2) + blockx%(2) = blockx%(4): blocky%(2) = blocky%(4) + blockx%(4) = blockx%(1) + 1: blocky%(4) = blocky%(1) + HE = 1 + End If + If (blockx%(4) + 1 = blockx%(1)) And (feld%(blockx%(1), blocky%(1) - 1) <> belegt%) Then + blockx%(3) = blockx%(2): blocky%(3) = blocky%(2) + blockx%(2) = blockx%(4): blocky%(2) = blocky%(4) + blockx%(4) = blockx%(1): blocky%(4) = blocky%(1) - 1 + End If + If (blockx%(1) + 1 = blockx%(2)) And (feld%(blockx%(1) - 1, blocky%(1)) <> belegt%) Then + blockx%(3) = blockx%(2): blocky%(3) = blocky%(2) + blockx%(2) = blockx%(4): blocky%(2) = blocky%(4) + blockx%(4) = blockx%(1) - 1: blocky%(4) = blocky%(1) + End If + If (HE <> 1) And (blockx%(3) + 1 = blockx%(1)) And (feld%(blockx%(1), blocky%(1) + 1) <> belegt%) Then + blockx%(3) = blockx%(2): blocky%(3) = blocky%(2) + blockx%(2) = blockx%(4): blocky%(2) = blocky%(4) + blockx%(4) = blockx%(1): blocky%(4) = blocky%(1) + 1 + End If + Case 3 + If (blocky%(3) + 1 = blocky%(1)) And (feld%(blockx%(1), blocky%(4)) <> belegt%) And (feld%(blockx%(1) - 1, blocky%(4)) <> belegt%) Then + blockx%(4) = blockx%(1) + blockx%(3) = blockx%(1) - 1: blocky%(3) = blocky%(4) + HE = 1 + End If + If (HE <> 1) And (blocky%(3) - 1 = blocky%(1)) And (feld%(blockx%(1), blocky%(2) - 1) <> belegt%) And (feld%(blockx%(2), blocky%(4)) <> belegt%) Then + blockx%(4) = blockx%(2) + blockx%(3) = blockx%(1): blocky%(3) = blocky%(1) - 1 + End If + Case 4 + If (blocky%(3) + 1 = blocky%(1)) And (feld%(blockx%(2), blocky%(4)) <> belegt%) And (feld%(blockx%(2) + 1, blocky%(4)) <> belegt%) Then + blockx%(4) = blockx%(2) + blockx%(3) = blockx%(2) + 1: blocky%(3) = blocky%(4) + HE = 1 + End If + If (HE <> 1) And (blocky%(3) - 1 = blocky%(1)) And (feld%(blockx%(2), blocky%(2) - 1) <> belegt%) And (feld%(blockx%(1), blocky%(4)) <> belegt%) Then + blockx%(4) = blockx%(1) + blockx%(3) = blockx%(2): blocky%(3) = blocky%(1) - 1 + End If + Case 5 + If (blocky%(2) + 1 = blocky%(1)) And (feld%(blockx%(3), blocky%(1)) <> belegt%) And (feld%(blockx%(3), blocky%(1) + 1) <> belegt%) And (feld%(blockx%(1) - 1, blocky%(1)) <> belegt%) Then + blockx%(2) = blockx%(3): blocky%(2) = blocky%(1) + blocky%(3) = blocky%(4) + blockx%(4) = blockx%(4) - 1: blocky%(4) = blocky%(1) + HE = 1 + End If + If (HE <> 1) And (blockx%(2) - 1 = blockx%(1)) And (feld%(blockx%(1), blocky%(3)) <> belegt%) And (feld%(blockx%(4), blocky%(3)) <> belegt%) And (feld%(blockx%(1), blocky%(1) - 1) <> belegt%) Then + blockx%(2) = blockx%(1): blocky%(2) = blocky%(3) + blockx%(3) = blockx%(4) + blockx%(4) = blockx%(1): blocky%(4) = blocky%(1) - 1 + HE = 1 + End If + If (HE <> 1) And (blocky%(2) - 1 = blocky%(1)) And (feld%(blockx%(3), blocky%(1)) <> belegt%) And (feld%(blockx%(2) + 1, blocky%(1)) <> belegt%) And (feld%(blockx%(3), blocky%(4)) <> belegt%) Then + blockx%(2) = blockx%(3): blocky%(2) = blocky%(1) + blocky%(3) = blocky%(4) + blockx%(4) = blockx%(4) + 1: blocky%(4) = blocky%(1) + HE = 1 + End If + If (HE <> 1) And (blockx%(2) + 1 = blockx%(1)) And (feld%(blockx%(1), blocky%(3)) <> belegt%) And (feld%(blockx%(4), blocky%(3)) <> belegt%) And (feld%(blockx%(1), blocky%(1) + 1) <> belegt%) Then + blockx%(2) = blockx%(1): blocky%(2) = blocky%(3) + blockx%(3) = blockx%(4) + blockx%(4) = blockx%(1): blocky%(4) = blocky%(1) + 1 + HE = 1 + End If + Case 6 + If (blocky%(2) + 1 = blocky%(1)) And (feld%(blockx%(3), blocky%(1)) <> belegt%) And (feld%(blockx%(3), blocky%(4)) <> belegt%) And (feld%(blockx%(1) + 1, blocky%(1)) <> belegt%) Then + blockx%(2) = blockx%(3) + 2: blocky%(2) = blocky%(1) + blockx%(3) = blockx%(2) + blockx%(4) = blockx%(4) - 1: blocky%(4) = blocky%(1) + HE = 1 + End If + If (HE <> 1) And (blockx%(2) - 1 = blockx%(1)) And (feld%(blockx%(1), blocky%(3)) <> belegt%) And (feld%(blockx%(3), blocky%(2) + 1) <> belegt%) And (feld%(blockx%(1), blocky%(1) + 1) <> belegt%) Then + blockx%(2) = blockx%(1): blocky%(2) = blocky%(1) + 1 + blocky%(3) = blocky%(2) + blockx%(4) = blockx%(1): blocky%(4) = blocky%(1) - 1 + HE = 1 + End If + If (HE <> 1) And (blocky%(2) - 1 = blocky%(1)) And (feld%(blockx%(3), blocky%(1)) <> belegt%) And (feld%(blockx%(2) - 1, blocky%(1)) <> belegt%) And (feld%(blockx%(2) - 1, blocky%(2)) <> belegt%) Then + blockx%(2) = blockx%(2) - 1: blocky%(2) = blocky%(1) + blockx%(3) = blockx%(2) + blockx%(4) = blockx%(4) + 1: blocky%(4) = blocky%(1) + HE = 1 + End If + If (HE <> 1) And (blockx%(2) + 1 = blockx%(1)) And (feld%(blockx%(1), blocky%(3)) <> belegt%) And (feld%(blockx%(2), blocky%(2) - 1) <> belegt%) And (feld%(blockx%(1), blocky%(1) - 1) <> belegt%) Then + blockx%(2) = blockx%(1): blocky%(2) = blocky%(2) - 1 + blocky%(3) = blocky%(2) + blockx%(4) = blockx%(1): blocky%(4) = blocky%(1) + 1 + HE = 1 + End If + Case 7 + If (blocky%(2) + 1 = blocky%(1)) And (feld%(blockx%(1) - 1, blocky%(1)) <> belegt%) And (feld%(blockx%(1) + 1, blocky%(1)) <> belegt%) And (feld%(blockx%(1) + 2, blocky%(1)) <> belegt%) Then + For I% = 2 To 4 + blocky%(I%) = blocky%(1) + Next I% + blockx%(2) = blockx%(1) - 1 + blockx%(3) = blockx%(1) + 1 + blockx%(4) = blockx%(1) + 2 + HE = 1 + End If + If (HE <> 1) And (blockx%(2) + 1 = blockx%(1)) And (feld%(blockx%(1), blocky%(1) - 1) <> belegt%) And (feld%(blockx%(1), blocky%(1) + 1) <> belegt%) And (feld%(blockx%(1), blocky%(1) + 2) <> belegt%) Then + For I% = 2 To 4 + blockx%(I%) = blockx%(1) + Next I% + blocky%(2) = blocky%(1) - 1 + blocky%(3) = blocky%(1) + 1 + blocky%(4) = blocky%(1) + 2 + End If + End Select +End Sub + +Function fax (x, z, zx, zz) + fax = (zx * z - zz * x) / (z - zz) +End Function + +Function fay (y, z, zy, zz) + fay = (zy * z - zz * y) / (z - zz) +End Function + +Sub fire (x%, y%) + Do + If InKey$ <> "" Then Exit Do + ax% = x% + ay% = y% + select.case oldi%, ax%, ay% + If Point(ax%, ay%) <> 10 Then + For I% = 1 To 9 + ax% = x% + ay% = y% + select.case I%, ax%, ay% + If I% = 9 Then Exit Do + If Point(ax%, ay%) = 10 Then Exit For + Next I% + Else + I% = oldi% + End If + + oldi% = I% + x% = ax% + y% = ay% + PSet (x%, y%), 4 + For w = 0 To 2 * _Pi Step .8 + For I% = 1 To 4 + If Point(x% + Sin(w) * I%, y% + Cos(w) * I%) = 0 Then + PSet (x% + Sin(w) * I%, y% + Cos(w) * I%), 4 + End If + Next I% + Next w + Select Case Int(Rnd * (1)) + Case 0: Color 0 + End Select + If InKey$ <> "" Then Exit Do + PSet (x%, y%) + For w = 0 To 2 * _Pi Step .8 + For I% = 1 To 4 + If Point(x% + Sin(w) * I%, y% + Cos(w) * I%) = 4 Then + PSet (x% + Sin(w) * I%, y% + Cos(w) * I%), 0 + End If + Next I% + Next w + _Limit 60 + Loop + Line (265, 200)-Step(120, 50), 0, BF +End Sub + +Sub getsprites + For I% = 1 To 6 + For y% = 1 To 14 + For x% = 1 To 14 + Read a + Select Case I% + Case 1: If a = 2 Then a = 15 + para(x%, y%) = a + Case 2: boom(x%, y%) = a + Case 3: tropfen(x%, y%) = a + Case 4: leiter(x%, y%) = a + Case 5: If a = 2 Then a = 10 + maxfeld(x%, y%) = a + Case 6: If a = 2 Then a = 10 + maxfeld(x%, y% + 14) = a + End Select + Next x% + Next y% + Next I% + + For y% = 2 To 14 + For x% = 1 To 28 + Read a + If a = 4 Then a = Int(Rnd * (2)) * 8 + 2 + If x% < 15 Then + hf1(x%, y%) = a + Else + hf2(x% - 14, y%) = a + End If + Next x% + Next y% +End Sub + +Sub gettaste (z$, posit%, max) + Do + z$ = InKey$ + Loop Until z$ <> "" + Select Case Right$(z$, 1) + Case "8", "H": If posit% > 1 Then posit% = posit% - 1 + Case "2", "P": If posit% < max Then posit% = posit% + 1 + End Select +End Sub + +Sub grey + setgrey 1, 4 + setgrey 2, 24 + setgrey 3, 28 + setgrey 4, 12 + setgrey 5, 17 + setgrey 6, 24 + setgrey 7, 41 + setgrey 8, 20 + setgrey 9, 25 + setgrey 10, 45 + setgrey 11, 49 + setgrey 12, 33 + setgrey 13, 37 + setgrey 14, 57 + setgrey 15, 62 +End Sub + +Sub heli + show.heli 0 + + I% = Int(Rnd * (9)) - 1 + ii% = Int(Rnd * (9)) - 1 + + If I% >= 2 Then + If maxposx <= helix Then + I% = -1 + Else + I% = 1 + End If + If maxposx = helix + 1 Then I% = 0 + End If + + If ii% >= 2 Then + If maxposy > heliy Then + ii% = 1 + Else + ii% = -1 + End If + If maxposy = heliy - 1 Then ii% = 0 + End If + + + chk1% = 1 + chk2% = 1 + + For u% = 1 To 4 + If blockx%(u%) = helix + I% And blocky%(u%) = heliy Then chk1% = 0 + If blockx%(u%) = helix + I% + 1 And blocky%(u%) = heliy Then chk1% = 0 + If blockx%(u%) = helix And blocky%(u%) = heliy + ii% Then chk2% = 0 + If blockx%(u%) = helix + 1 And blocky%(u%) = heliy + ii% Then chk2% = 0 + Next u% + + If feld%(helix + I%, heliy) = Frei% And chk1% And feld%(helix + I% + 1, heliy) = Frei% Then + helix = helix + I% + End If + + If feld%(helix, heliy + ii%) = Frei% And chk2% And feld%(helix + 1, heliy + ii%) = Frei% Then + heliy = heliy + ii% + End If + + + If helix = 0 Then maxposx = 2 + If helix + 1 >= fb + 1 Then helix = fb - 1 + + If heliy = 0 Then heliy = 1 + If heliy = fh Then heliy = fh - 1 + + helilt = Timer + show.heli 1 + + If helix + 1 = maxposx And heliy + 1 = maxposy Then heligetsmax +End Sub + +Sub heligetsmax + x1% = ((320 - fb * bg / 2) + ((helix) * bg) + 1) + y1% = ((240 - fh * bg / 2) + ((heliy + 1) * bg) + 1) + + For u% = 1 To 4 + kastl blockx%(u%), blocky%(u%), 0 + Next u% + + kastl maxposx, maxposy, 0 + maxframe = 2 + kastl maxposx, maxposy, 55 + + For y% = 1 To 14 + For x% = 1 To 14 + If leiter(x%, y%) > 0 Then PSet (x% + x1% - 1, y% + y1% - 1), leiter(x%, y%) + Next x% + Next y% + + t = Timer + Do + Loop Until Timer >= t + 2 + + kastl helix + 1, heliy + 1, 0 + For y% = 1 To 14 + For x% = 1 To 14 + If leiter(x%, y%) > 0 Then PSet (x% + x1% - 1, y% + y1% - 1), leiter(x%, y%) + Next x% + Next y% + + t = Timer + Do + Loop Until Timer >= t + 1 + + kastl maxposx, maxposy, 0 + + Do + + t = Timer + Do + Loop Until Timer >= t + .2 + + show.heli 0 + heliy = heliy - 1 + If heliy = 0 Then helion = 0: bc = bc - 1: nichtganzalles: killmax: Exit Do + show.heli 1 + + Loop + + punkte = punkte - 100 + If punkte < 0 Then punkte = 0 + Punktezahl +End Sub + +Sub init + + For I% = 2 To 5 + GoSub ini + Next I% + + For I% = 14 To 21 + GoSub ini + Next I% + + I% = 25 + GoSub ini + + For I% = 30 To 41 + GoSub ini + Next I% + + Exit Sub + + ini: + + For y% = 1 To 5 + For x% = 1 To 5 + Read a + bst(I%, x%, y%) = a + Next x% + Next y% + Return + +End Sub + +Sub init.ffont + I% = 1 + x% = 1 + y% = 1 + u% = 1 + a = 1 + + Do + Read aa$ + + If aa$ = "x" Then aa$ = "14" + If aa$ = "" Then aa$ = "1" + + If a Then + a = 0 + Else + a = 1 + End If + + num = Val(aa$) + + For k = u% To (u% + num - 1) + x% = x% + 1 + If x% = 19 Then x% = 2: y% = y% + 1 + If y% = 20 Then y% = 1: I% = I% + 1: x% = 2 + + buch(I%, x%, y%) = a + + Next k + + u% = k + + If k >= 1616 Then Exit Do + + Loop + + + For I% = 1 To 5 + buch(I%, 19, 19) = 1 + buch(I%, 1, 19) = 1 + Next I% + +End Sub + +Sub Intro + If InKey$ = Chr$(27) Then Exit Sub + Sleep 1 + Dim d(5) As String + Dim I(5) As String + Dim dx(1) As Single + Dim dy(1) As Single + Dim ix(1) As Single + Dim iy(1) As Single + dx(0) = 1 + dy(0) = 1 + dx(1) = 80 - 6 + dy(1) = 1 + ix(0) = 1 + iy(0) = 23 + ix(1) = 80 - 4 + iy(1) = 23 + d(0) = "DDDDDD" + d(1) = "DD DD" + d(2) = "DD DD" + d(3) = "DD DD" + d(4) = "DD DD" + d(5) = "DDDDDD" + I(0) = "IIII" + I(1) = " II" + I(2) = " II" + I(3) = " II" + I(4) = " II" + I(5) = "IIII" + Do + Color 0 + For u% = 0 To 5 + Locate Int(dy(0)) + u%, Int(dx(0)): Print d(u%) + Locate Int(dy(1)) + u%, Int(dx(1)): Print d(u%) + Locate Int(iy(0)) + u%, Int(ix(0)): Print I(u%) + Locate Int(iy(1)) + u%, Int(ix(1)): Print I(u%) + Next u% + If dy(0) < 12 Then dy(0) = dy(0) + 1: dx(0) = dx(0) + 2 + If iy(0) > 12 Then iy(0) = iy(0) - 1: ix(0) = ix(0) + 3 + If dy(1) < 12 Then dy(1) = dy(1) + 1: dx(1) = dx(1) - 2.75 + If iy(1) > 12 Then iy(1) = iy(1) - 1: ix(1) = ix(1) - 2 + Color 15 + For u% = 0 To 5 + Locate Int(dy(0)) + u%, Int(dx(0)): Print d(u%) + Locate Int(dy(1)) + u%, Int(dx(1)): Print d(u%) + Locate Int(iy(0)) + u%, Int(ix(0)): Print I(u%) + Locate Int(iy(1)) + u%, Int(ix(1)): Print I(u%) + Next u% + t = Timer + Do + If InKey$ = Chr$(27) Then Exit Sub + Loop Until Timer >= t + .08 + Loop Until iy(1) = 12 + setpal 14, 0, 0, 0 + Color 14 + + Line (171, 172)-Step(43, 0) + Line (171, 172)-Step(0, 100) + Line -Step(43, 0) + r = 20 + Circle (214, 192), 20, , 0, _Pi / 2 + Circle (214, 252), 20, , _Pi * 3 / 2, 0 + Line (234, 192)-Step(0, 60) + + Line (193, 192)-Step(12, 0) + Line (193, 192)-Step(0, 61) + Line -Step(12, 0) + Circle (205, 200), 8, , 0, _Pi / 2 + Circle (205, 245), 8, , _Pi * 3 / 2.1, 0 + Line (213, 200)-Step(0, 45) + + If InKey$ = Chr$(27) Then Exit Sub + + Line (331, 172)-Step(43, 0) + Line (331, 172)-Step(0, 100) + Line -Step(43, 0) + Circle (374, 192), 20, , 0, _Pi / 2 + Circle (374, 252), 20, , _Pi * 3 / 2, 0 + Line (394, 192)-Step(0, 60) + + Line (353, 192)-Step(12, 0) + Line (353, 192)-Step(0, 61) + Line -Step(12, 0) + Circle (365, 200), 8, , 0, _Pi / 2 + Circle (365, 245), 8, , _Pi * 3 / 2.1, 0 + Line (373, 200)-Step(0, 45) + + If InKey$ = Chr$(27) Then Exit Sub + + Line (261, 172)-Step(37, 0) + Line (261, 172)-Step(0, 19) + Line (298, 172)-Step(0, 19) + Line (261, 191)-Step(7, 0) + Line (298, 191)-Step(-7, 0) + Line (268, 191)-Step(0, 62) + Line (291, 191)-Step(0, 62) + Line (268, 253)-Step(-7, 0) + Line (291, 253)-Step(7, 0) + Line (261, 253)-Step(0, 19) + Line (298, 253)-Step(0, 19) + Line -Step(-37, 0) + + If InKey$ = Chr$(27) Then Exit Sub + + Line (421, 172)-Step(37, 0) + Line (421, 172)-Step(0, 19) + Line (458, 172)-Step(0, 19) + Line (421, 191)-Step(7, 0) + Line (458, 191)-Step(-7, 0) + Line (428, 191)-Step(0, 62) + Line (451, 191)-Step(0, 62) + Line (428, 253)-Step(-7, 0) + Line (451, 253)-Step(7, 0) + Line (421, 253)-Step(0, 19) + Line (458, 253)-Step(0, 19) + Line -Step(-37, 0) + + t = Timer + Do + If InKey$ = Chr$(27) Then Exit Sub + Loop Until Timer >= t + 2 + + For w = 0 To _Pi / 2 Step .05 + setpal 14, Abs(Sin(w) * 63), Abs(Sin(w) * 63), 0 + Wait &H3DA, 8 + If InKey$ = Chr$(27) Then Exit Sub + Next w + + t = Timer + Do + If InKey$ = Chr$(27) Then Exit Sub + Loop Until Timer >= t + 1 + + For w = 0 To _Pi / 2 Step .1 + If InKey$ = Chr$(27) Then Exit Sub + setpal 0, Abs(Sin(w) * 63), Abs(Sin(w) * 63), Abs(Sin(w) * 63) + Wait &H3DA, 8 + Next w + + t = Timer + Do + If InKey$ = Chr$(27) Then Exit Sub + Loop Until Timer >= t + .3 + + setpal 2, 0, 63 / 2, 0 + Paint (173, 173), 2, 14 + Paint (333, 173), 2, 14 + Paint (263, 173), 2, 14 + Paint (423, 173), 2, 14 + setpal 0, 0, 0, 0 + + t = Timer + Do + If InKey$ = Chr$(27) Then Exit Sub + Loop Until Timer >= t + 1 + setpal 1, 0, 0, 0 + + Color 0 + Locate 23, 36: Print "PRESENTS" + + Color 1 + + show.font "PRESENTS", 4, 0, 1, 220, 360 + + w = 1.0472 + h = 0 + t = Timer + Do + w = w + .04 + setpal 14, Abs(Sin(w) * 63), Abs(Sin(w) * 63), 0 + setpal 2, 0, Abs(Cos(w) * 63), 0 + Wait &H3DA, 8 + If w > 8 And h < 50 Then + If h Mod 5 = 0 Then Print + h = h + 1 + End If + If w >= _Pi * 2 * 2 Then + setpal 1, 0, 0, Abs(Sin(w / 3) * 50) + 13 + Else + setpal 5, 0, 0, Abs(Sin(w / 3) * 50) + 13 + End If + _Limit 60 + Loop Until InKey$ <> "" Or Timer >= t + 15 + + For ii% = 0 To 20 + For y% = 50 To 400 Step 20 + For x% = 170 To 500 Step 20 + Line (x% + ii%, y%)-(x%, y% + ii%), 0 + Line (x% - ii% + 20, y% + 20)-(x% + 20, y% - ii% + 20), 0 + Next x% + Next y% + Wait &H3DA, 8 + Next ii% + +End Sub + +Sub kastl (kastlx%, kastly%, farbe%) + + If farbe% = 7 Then farbe% = 8 + If farbe% >= 9 And farbe% <= 15 Then farbe% = farbe% - 8 + + farbe2% = farbe% + 8 + If farbe% = 8 Then: farbe2% = 7 + + If farbe% > 0 And farbe% <> 55 Then + If maxposx = kastlx% And maxposy = kastly% Then + killmax + End If + End If + + If helion And farbe% > 0 Then + If (helix = kastlx% And heliy = kastly%) Or (helix + 1 = kastlx% And heliy = kastly%) Then + killheli + End If + End If + + If kastly% > 0 Then + x1% = ((320 - fb * bg / 2) + ((kastlx% - 1) * bg) + 1) + y1% = ((240 - fh * bg / 2) + ((kastly%) * bg) + 1) + + x2% = ((320 - fb * bg / 2 - 1) + ((kastlx%) * bg) + 1) + y2% = ((240 - fh * bg / 2) + (kastly% + 1) * bg) + + If farbe% = 0 Then + + Line (x1%, y1%)-(x2%, y2%), farbe%, BF + Else + + If farbe% = 20 Then + Circle (x1% + bg / 2 - .5, y2% - bg / 3), bg / 3, 8, _Pi, 0 + Line (x1% + bg / 6, y2% - bg / 3)-Step(0, -bg / 3), 8 + Line (x2% - bg / 6 + 1, y2% - bg / 3)-Step(0, -bg / 3), 8 + Line -Step(-bg * 2 / 3, 0), 8 + Line (x1% + bg / 2 - .5, y1%)-Step(0, bg / 5), 8 + Line (x1% + bg / 6, y1%)-(x2% - bg / 6 + 1, y1%), 8 + Paint (x1% + bg / 2, y1% + bg / 2), 4, 8 + Circle (x1% + bg / 2 - .5, y2% - bg / 3), bg / 3.5, 12, 3 * _Pi / 2 + .3, 2 * _Pi + Else + + If farbe% = 44 Then + For y% = 1 To 14 + For x% = 1 To 14 + If boom(x%, y%) > 0 Then PSet (x% + x1% - 1, y% + y1% - 1), boom(x%, y%) + Next x% + Next y% + + Else + + If farbe% = 33 Then + For y% = 1 To 14 + For x% = 1 To 14 + PSet (x% + x1% - 1, y% + y1% - 1), tropfen(x%, y%) + Next x% + Next y% + + Else + + If farbe% = 55 Then + + If maxframe = 1 Then + For y% = 1 To 14 + For x% = 1 To 14 + If maxfeld(x%, y%) > 0 Then PSet (x% + x1% - 1, y% + y1% - 1), maxfeld(x%, y%) + Next x% + Next y% + + Else + + For y% = 1 To 14 + For x% = 1 To 14 + If maxfeld(x%, y% + 14) > 0 Then PSet (x% + x1% - 1, y% + y1% - 1), maxfeld(x%, y% + 14) + Next x% + Next y% + + If paraon And feld%(maxposx, maxposy - 1) = Frei% And maxposy > 1 Then + For y% = 1 To 14 + For x% = 1 To 14 + If para(x%, y%) > 0 Then PSet (x% + x1% - 1, y% + y1% - 15), para(x%, y%) + Next x% + Next y% + End If + + + End If + + Else + + in% = bg / 5 + + Line (x1%, y1%)-(x2%, y2%), farbe%, BF + Line (x1% + in%, y1% + in%)-(x2% - in%, y2% - in%), farbe2%, BF + Line (x1%, y1%)-(x1% + in%, y1% + in%), farbe2% + Line (x2%, y2%)-(x2% - in%, y2% - in%), farbe2% + Line (x2%, y1%)-(x2% - in%, y1% + in%), farbe2% + Line (x1%, y2%)-(x1% + in%, y2% - in%), farbe2% + End If + End If + End If + End If + End If + End If + +End Sub + +Sub killheli + + helion = 0 + kastl helix, heliy, 44 + kastl helix + 1, heliy, 44 + + blowheli = 1 +End Sub + +Sub killmax + kastl maxposx, maxposy, 0 + If paraon Then kastl maxposx, maxposy - 1, 0 + + If maxposx >= fb / 2 Then + maxposx = maxposx - 5 + Else + maxposx = maxposx + 5 + End If + + maxposy = 1 + + bc = bc + 1 + punkte = punkte + 2 + show.bodycount + Punktezahl + paraon = 1 +End Sub + +Sub main + Screen 12 + Palette + Color + + If yn(1) = 2 Then + nomusik = 1 + Else + nomusik = 0 + End If + + If yn(3) = 1 Then + maxposx = Int(fb / 2) + maxposy = fh + maxlt = Timer + Else + maxposx = 0 + maxposy = 0 + End If + + + + verzug = .35 + verzugplus = .025 + + 'Level = 1 + + + Def Seg = 64 + Poke 23, 32 + Def Seg + + For I% = 0 To fh + 1 + feld%(0, I%) = belegt% + feld%(fb + 1, I%) = belegt% + Next I% + + For I% = 0 To fb + feld%(I%, fh + 1) = belegt% + Next I% + + + alles + + nstr% = Int(Rnd * (7)) + 1 + + show.ffont "DCABE", 10, 273, 220 + z$ = Input$(1) + fire 273, 220 + 19 + + Musikladen + + ' a740g: 2 seconds seems to be working ok + On Timer(2) GoSub hinter + Timer On + + nextbomb = Int(Rnd * (30)) + 8 + + helix = Int(fb / 2) + + Do + + If yn(2) = 1 Then nextbomb = nextbomb - 1 + + struktur% = nstr% + nstr% = Int(Rnd * (7)) + 1 + If nextbomb = 0 Then nstr% = 99: nextbomb = Int(Rnd * (30)) + 8 + strukturstart nstr% + If endeundaus = 1 Then Exit Sub + nextes + + If struktur% = 99 Then bomb = 1 + strukturstart struktur% + If endeundaus = 1 Then Exit Sub + farbe% = Int(Rnd * (15)) + 1 + If bomb Then farbe% = 20 + + + Do + show.stone farbe% + t = Timer + Do + + a$ = InKey$ + + + If a$ <> "" Then + show.stone 0 + If a$ <> "" Then woswasi = 0 + Select Case a$ + Case Chr$(0) + "K", "4" + k% = 0 + For i1% = 1 To 4 + If feld%(blockx%(i1%) - 1, blocky%(i1%)) <> belegt% Then k% = k% + 1 + Next i1% + If k% = 4 Then + For i2% = 1 To 4 + blockx%(i2%) = blockx%(i2%) - 1 + Next i2% + End If + Case Chr$(0) + "M", "6" + k% = 0 + For i3% = 1 To 4 + If feld%(blockx%(i3%) + 1, blocky%(i3%)) <> belegt% Then k% = k% + 1 + Next i3% + If k% = 4 Then + For i4% = 1 To 4 + blockx%(i4%) = blockx%(i4%) + 1 + Next i4% + End If + Case Chr$(0) + "P", "5": t = t - 1 + Case Chr$(0) + "D": Screen 0 + ' TODO + Timer Off + Print "C:\DOS>" + Do + Locate 1, 8, 1 + Loop While InKey$ = "" + Screen 12 + alles + 'PLAY ON + Case Chr$(0) + Chr$(133): Screen 0 + ' TODO + Timer Off + Shell + Screen 12 + alles + 'PLAY ON + Case "s", "S" + Timer Off + Case "m", "M" + Timer On + Case Chr$(13), Chr$(0) + "H", "8", "+": drehen struktur% + Case Chr$(27): ausis: If endeundaus = 1 Then Exit Sub + Case "P", "p": grey: a$ = Input$(1): Palette + Case Chr$(0) + Chr$(59) + ' TODO + Timer Off + show.helpscreen + alles + Case "1", "2", "3", "4", "5", "6", "7", "8", "9" + If Val(a$) <= Musikanzahl Then + musi% = 0 + Musikstueck% = Val(a$) + End If + Case "0": woswasi = verzug - .01 + Case " ": If acid >= maxacid Then acidrain + Case "t": End + End Select + + show.stone farbe% + End If + meanwhile + + + Loop Until Timer >= t + verzug - woswasi + + check% = 0 + For m% = 1 To 4 + If feld%(blockx%(m%), blocky%(m%) + 1) = belegt% Then check% = 1: Exit For + Next m% + + If check% = 1 Then Exit Do + + show.stone 0 + For i6% = 1 To 4 + blocky%(i6%) = blocky%(i6%) + 1 + Next i6% + + Loop + + woswasi = 0 + + If yn(4) = 1 Then + If acid <= maxacid Then acid = acid + acidplus + show.acidometer + punkte = punkte + 1 + Punktezahl + End If + + check% = 0 + For i7% = 1 To 4 + farb%(blockx%(i7%), blocky%(i7%)) = farbe% + feld%(blockx%(i7%), blocky%(i7%)) = belegt% + Next i7% + + reichweite = Int(Rnd * (3)) + 1 'Bombe knallt auf + + If bomb Then + bomb = 0 + For y% = -reichweite + blocky%(1) To reichweite + blocky%(1) + For x% = -reichweite + blockx%(1) To reichweite + blockx%(1) + If x% > 0 And x% <= fb And y% <= fh Then + feld%(x%, y%) = Frei% + farb%(x%, y%) = 0 + kastl x%, y%, 44 + End If + Next x% + Next y% + + t = Timer + Do + Loop Until Timer >= t + .3 + + For y% = -reichweite + blocky%(1) To reichweite + blocky%(1) + For x% = -reichweite + blockx%(1) To reichweite + blockx%(1) + If x% > 0 And x% <= fb And y% <= fh Then + kastl x%, y%, 0 + End If + Next x% + Next y% + + End If + + For I% = 1 To 4 + hoho%(I%) = 0 + Next I% + j% = 0 + + For y% = 1 To fh + For x% = 1 To fb + If feld%(x%, y%) = Frei% Then Exit For + If x% = fb Then + + For I% = 1 To fb + kastl I%, y%, 0 + Next I% + j% = j% + 1 + hoho%(j%) = y% + End If + Next x% + Next y% + + If j% > 0 Then + tim = Timer: Do: Loop Until Timer >= tim + .1 + + For l% = 1 To j% + For I% = 1 To fb + kastl I%, hoho%(l%), 15 + Next I% + Next l% + + tim = Timer: Do: Loop Until Timer >= tim + .5 + + + + For l% = 1 To j% + For iy% = hoho%(l%) To 2 Step -1 + For ix% = 1 To fb + feld%(ix%, iy%) = feld%(ix%, iy% - 1) + farb%(ix%, iy%) = farb%(ix%, iy% - 1) + Next ix% + Next iy% + Next l% + + check% = j% + Linienweg = Linienweg + j% + + punkte = punkte + linienpunkte * j% + + + If Int(Linienweg / 10) <> Int((Linienweg - j%) / 10) Then + Level = Level + 1 + verzug = verzug - verzugplus + End If + + nichtganzalles + + End If + + + If check% > 0 Then + punkte = punkte + (check% - 1) * (linienpunkte / 4 * 3) + Punktezahl + End If + + _Limit 60 + Loop + +End Sub + +Sub meanwhile + + If Timer >= helilt + .2 And yn(3) = 1 Then + + If helion Then + heli + Else + If Int(Rnd * (40)) = 5 And blowheli = 0 Then + helion = 1 + heliy = 1 + If heliy <= 1 Then heliy = 1 + show.heli 1 + + helilt = Timer + Else + helilt = Timer + + End If + End If + + End If + + If Timer >= maxlt + .1 And yn(3) = 1 Then + + If paraon Then kastl maxposx, maxposy - 1, farb%(maxposx, maxposy - 1) + kastl maxposx, maxposy, farb%(maxposx, maxposy) + + I% = Int(Rnd * (3)) - 1 + If I% = 0 Then m = maxstill + + chk1% = 1 + chk2% = 1 + chk3% = 1 + + For u% = 1 To 4 + If blockx%(u%) = maxposx And blocky%(u%) = maxposy + 1 Then chk1% = 0 + If blockx%(u%) = maxposx + I% And blocky%(u%) = maxposy Then chk2% = 0 + If blockx%(u%) = maxposx + I% And blocky%(u%) = maxposy - 1 Then chk3% = 0 + Next u% + + If feld%(maxposx, maxposy + 1) = Frei% And chk1% Then + maxposy = maxposy + 1 + maxframe = 2 + maxstill = 0 + If feld%(maxposx, maxposy + 1) = Frei% And feld%(maxposx, maxposy + 2) = Frei% And maxposy < fh Then paraon = 1 + Else + + paraon = 0 + maxframe = 1 + + If feld%(maxposx + I%, maxposy) = Frei% And chk2% Then + maxposx = maxposx + I% + maxstill = 0 + Else + If feld%(maxposx + I%, maxposy - 1) = Frei% And chk3% Then + maxposx = maxposx + I% + maxposy = maxposy - 1 + maxstill = 0 + Else + maxstill = maxstill + 1 + End If + End If + + End If + + If maxposx = 0 Then maxposx = 2 + If maxposx = fb + 1 Then maxposx = fb - 1 + + If maxstill > 15 Then + If maxframe = 1 Then + maxframe = 2 + Else + maxframe = 1 + End If + maxstill = 15 + End If + + If I% = 0 Then maxstill = m + + kastl maxposx, maxposy, 55 + maxlt = Timer + End If + + If blowheli > 0 Then + kastl helix, heliy, 44 + kastl helix + 1, heliy, 44 + blowheli = blowheli + 1 + End If + + If blowheli = 200 Then + blowheli = 0 + chk1% = 1 + chk2% = 1 + + If chk1% Then kastl helix, heliy, farb%(helix, heliy) + If chk2% Then kastl helix + 1, heliy, farb%(helix + 1, heliy) + + helix = Int(Rnd * (fb - 1)) + 1 + If helix >= (fb / 2) Then + helix = 1 + Else + helix = fb - 1 + End If + End If +End Sub + +Sub menu + Dim s$(5) + + posit% = 1 + + show.menu + + s$(1) = " START " + s$(2) = " SETUP " + s$(3) = " READ ME " + s$(4) = " HIGHSCORE " + s$(5) = " END " + + Do + Color 5, 0 + For I% = 1 To 5 + Locate 16 + I%, 33: Print " "; s$(I%); " " + Next I% + + Color 11, 9 + + Locate 16 + posit%, 33: Print "["; s$(posit%); "]" + + gettaste z$, posit%, 5 + Select Case z$ + Case Chr$(13), " ", "5" + Select Case posit% + Case 1: Exit Sub + Case 2: setup + Case 3: show.helpscreen: show.menu + Case 4: score = 0: Screen 12: showhiscore: show.menu + Case 5: ausss + End Select + Case Chr$(27): ausss + End Select + Loop +End Sub + + +Sub Musikladen + If already = 0 Then + For I% = 1 To Musikanzahl + + x% = 0 + Do + x% = x% + 1 + Read a$ + Musik$(x%, I%) = a$ + If Musik$(x%, I%) = "MUSIKENDE" Then Exit Do + Loop + Musiklaenge(I%) = x% - 1 + Next I% + End If + + Musikstueck% = Int(Rnd * (Musikanzahl)) + 1 + musi% = 1 + If nomusik = 0 Then Play "mb" + Musik$(musi%, Musikstueck%) +End Sub + + +Sub nextes + For y% = 1 To 4 + For x% = 0 To 2 + kastl x% - 3, y%, 0 + kastl x% - 3, y%, 9 + Next x% + Next y% + + If nstr% = 99 Then + kastl blockx%(1) - fb / 2 - 3, 2, 20 + Else + + For I% = 1 To 4 + kastl blockx%(I%) - fb / 2 - 3, blocky%(I%), 10 + Next I% + + End If +End Sub + +Sub nichtganzalles + For I% = 0 To maxlinie - 1 + Line (320 - I% - fb * bg / 2, 240 - I% - fh * bg / 2 + bg)-(321 + I% + fb * bg / 2, 240 + I% + fh * bg / 2 + 1 + bg), Int(Rnd * (15)) + 1, B + Next I% + + For x% = 1 To fb + For y% = 1 To fh + kastl x%, y%, farb%(x%, y%) + Next y% + Next x% + + If yn(4) = 1 Then + show.acidometer + End If +End Sub + +Sub Punktezahl + Locate 10, 10: Color 2: Print "Points.."; + Color 9: Print Str$(punkte) + Locate 12, 10: Color 14: Print "Lines..."; + Color 11: Print Linienweg + Locate 14, 10: Color 4: Print "LEVEL..."; + Color 8: Print Level +End Sub + +Sub select.case (I%, ax%, ay%) + Select Case I% + Case 1: ax% = ax% + 1 + Case 2: ax% = ax% - 1 + Case 3: ay% = ay% + 1 + Case 4: ay% = ay% - 1 + Case 5: ax% = ax% - 1: ay% = ay% + 1 + Case 6: ax% = ax% + 1: ay% = ay% - 1 + Case 7: ax% = ax% - 1: ay% = ay% - 1 + Case 8: ax% = ax% + 1: ay% = ay% + 1 + End Select +End Sub + +Sub setgrey (nr, value) + setpal nr, value, value, value +End Sub + +Sub setpal (nr, r, g, B) + Out &H3C8, nr + Out &H3C9, r + Out &H3C9, g + Out &H3C9, B +End Sub + +Sub setup + + Color 5, 0 + For I% = 1 To 5 + Locate 16 + I%, 33: Print " " + Next I% + + max = 4 + + Dim p(1 To max, 2) As String + + p(1, 0) = " MUSIC " + p(2, 0) = " BOMBS " + p(3, 0) = " ARMY " + p(4, 0) = " ACIDRAIN " + + p(1, 1) = "YES" + p(2, 1) = " OF COURSE" + p(3, 1) = " WAY COOL" + p(4, 1) = " YEP" + + p(1, 2) = " NO" + p(2, 2) = "BETTER NOT" + p(3, 2) = "NO CHANCE" + p(4, 2) = "NOPE" + + positi% = 1 + + Do + + For I% = 1 To max + Color 5, 0 + Locate 16 + I%, 29: Print " "; p(I%, 0); " " + If yn(I%) = 1 Then Color 2, 0 Else Color 4, 0 + Locate 16 + I%, 51 - Len(p(I%, yn(I%))): Print " "; p(I%, yn(I%)); " " + Next I% + + Color 5, 0 + Locate 18 + max, 37: Print " BACK " + + Color 11, 9 + If positi% = max + 1 Then + Locate 18 + max, 37: Print "[ BACK ]" + Else + Locate 16 + positi%, 29: Print "["; p(positi%, 0); "]" + End If + + gettaste z$, positi%, max + 1 + Select Case z$ + Case Chr$(13), " ", "5" + If positi% = max + 1 Then + Exit Do + Else + yn(positi%) = yn(positi%) + 1 + If yn(positi%) = 3 Then yn(positi%) = 1 + End If + Case Chr$(27): Exit Do + End Select + Loop + + For I% = 1 To max + Color 0, 0 + Locate 16 + I%, 29: Print " "; p(I%, 0); " " + Locate 16 + I%, 51 - Len(p(I%, yn(I%))): Print " "; p(I%, yn(I%)); " " + Next I% + + Locate 18 + max, 37: Print " BACK " +End Sub + +Sub show.acidometer + x1% = ((320 - fb * bg / 2) + ((-3) * bg) + 1) + x2% = ((320 - fb * bg / 2 - 1) + ((-1) * bg) + 1) + y2% = ((240 - fh * bg / 2) + (fh + 1) * bg) + y1% = y2% - maxacid + + + If acid <= maxacid Or showallacid Then + + Line (x1% - 1, y1% - 1)-(x2% + 1, y2% + 1), 4, B + Line (x1% - 2, y1% - 2)-(x2% + 2, y2% + 2), 4, B + + If acid = 0 Or showallacid Then Line (x1%, y1%)-(x2%, y2%), 0, BF + If acid > 0 And acid <= maxacid Then + Line (x1%, y2% - acid + 1)-(x2%, y2% - acid + 1 + acidplus), 1, BF + End If + + If showallacid Then + If acid < maxacid Then + Line (x1%, y2%)-(x2%, y2% - acid + 1), 1, BF + Else + Line (x1%, y2%)-(x2%, y1%), 1, BF + End If + End If + + If acid = maxacid Or (acid > maxacid And showallacid) Then + Line (x1% - 1, y1% - 1)-(x2% + 1, y2% + 1), 2, B + Line (x1% - 2, y1% - 2)-(x2% + 2, y2% + 2), 2, B + End If + + End If + + + +End Sub + +Sub show.bodycount + show.font2 Str$(bc), 2, 0, 2, 360, 448 +End Sub + +Sub show.ffont (word$, fa, ax, ay) + + For I% = 1 To Len(word$) + a$ = Mid$(word$, I%, 1) + nr% = Asc(a$) - 64 + + If nr% > 0 And nr% < 27 Then + For y% = 1 To 19 + For x% = 1 To 19 + If buch(nr%, x%, y%) = 1 Then + PSet (x% + ax + (I% - 1) * 19, y% + ay), fa + End If + Next x% + Next y% + End If + + Next I% + +End Sub + +Sub show.font (word$, scale, bgc, fgc, xa, ya) + For I% = 1 To Len(word$) + nr = Asc(UCase$(Mid$(word$, I%, 1))) - 64 + If nr >= 1 And nr <= 26 Then + + For y% = 1 To 5 + For x% = 1 To 5 + + ax = ((I% - 1) * scale * 6 + (x% - 1) * scale + xa) + ay = ((y% - 1) * scale * 3 / 2 + ya) + + If bst(nr, x%, y%) Then + col = fgc + Else + col = bgc + End If + Line (ax, ay)-Step(scale / 4, scale * 3 / 8), col, BF + Next x% + Next y% + + End If + Next I% +End Sub + +Sub show.font2 (word$, scale, bgc, fgc, xa, ya) + + For I% = 1 To Len(word$) + nr = Asc(UCase$(Mid$(word$, I%, 1))) - 64 + + If Val((Mid$(word$, I%, 1))) > 0 Then + nr = Val((Mid$(word$, I%, 1))) + 30 + End If + + If Mid$(word$, I%, 1) = "0" Then nr = 30 + If Mid$(word$, I%, 1) = ":" Then nr = 40 + If Mid$(word$, I%, 1) = "-" Then nr = 41 + + If nr >= 1 And nr <= 41 Then + For y% = 1 To 5 + For x% = 1 To 5 + + ax = ((I% - 1) * scale * 6 + (x% - 1) * scale + xa) + ay = ((y% - 1) * scale * 3 / 2 + ya) + + If bst(nr, x%, y%) Then + col = fgc + Else + col = bgc + End If + Line (ax, ay)-Step(scale * 2 / 3, scale), col, BF + Next x% + Next y% + + End If + Next I% +End Sub + +Sub show.heli (farbe%) + If farbe% Then + x1% = ((320 - fb * bg / 2) + ((helix - 1) * bg) + 1) + y1% = ((240 - fh * bg / 2) + ((heliy) * bg) + 1) + + For y% = 2 To 14 + For x% = 1 To 14 + If hf1(x%, y%) > 0 Then + PSet (x% + x1% - 1, y% + y1% - 1), hf1(x%, y%) + End If + If hf2(x%, y%) > 0 Then + PSet (x% + x1% + 13, y% + y1% - 1), hf2(x%, y%) + End If + Next x% + Next y% + + If rotor Then + Line (x1% + 3, y1%)-Step(12, 0), 8 + Line -Step(12, 0), 7 + rotor = 0 + Else + Line (x1% + 3, y1%)-Step(12, 0), 7 + Line -Step(12, 0), 8 + rotor = 1 + End If + + + Else + kastl helix, heliy, farb%(helix, heliy) + kastl helix + 1, heliy, farb%(helix + 1, heliy) + End If +End Sub + +Sub show.helpscreen + Screen 13 + + Color 1 + For I = 1 To 255 + setpal I, 0, 0, 0 + Next I + + Locate 3, 1 + Print "Try to catch the soldier who's jumping" + Print + Print " around before the AH-64D Apache gets " + Print + Print Space$(14) + "him!!!!!!!" + Locate 11, 2 + Print "If the ACID-O-METER is full press the" + Print + Print " SPACE BAR to activate an acidrain" + Print + Print " which will eat away the highest stones." + Locate 19, 1 + Print "Sometimes you can control a falling bomb" + Print + Print " with which you can destroy some stones." + Locate 24, 1 + + GoSub action + + setpal 1, 0, 0, 0 + Color 1 + + u$ = "" + For I% = 1 To 9 + u$ = u$ + " " + Chr$(1) + " " + Chr$(2) + Next I% + u$ = u$ + " " + Chr$(1) + + Print + Print u$ + Print + Print " If you think that this program is not" + Print + Print " so bad, then please please please" + Print + Print " write a postcard or a letter to me!!" + Print + Print " I would be very happy! :-)" + Print + Print u$ + Print: Print + Print " ͻ" + Print " Dietmar MORITZ " + Print " Ungargasse 43 " + Print " 7350 Oberpullendorf " + Print " A U S T R I A " + Print " E U R O P E " + Print " ͼ" + + GoSub action + Screen 12 + Exit Sub + + action: + For y% = 0 To 200 + For x% = 0 To 320 + If Point(x%, y%) <> 0 Then + c = Sqr((x% - 160) ^ 2 + (y% - 100) ^ 2) + PSet (x%, y%), c + End If + Next x% + Next y% + + Do + w = w + .01 + For u = 1 To 255 + I = u / 35 + r = Abs(Sin(w + I + 4 * _Pi / 3) ^ 2 * 63) + g = Abs(Sin(w + I + 2 * _Pi / 3) ^ 2 * 63) + B = Abs(Sin(w + I) ^ 2 * 63) + setpal u, r, g, B + Next u + _Limit 60 + Loop Until InKey$ <> "" + Return + + Screen 12 +End Sub + +Sub show.menu + Screen 0 + Cls + + Locate 3, 13 + Color 1 + Print " t h e u n b e l i e v a b l e Ŀ" + + Print + + Color 2, 0 + + Locate 5, 15: Print " " + Locate 6, 15: Print " " + Locate 7, 15: Print " " + Locate 8, 15: Print " " + Color 2, 0 + Locate 9, 15: Print " " + Locate 10, 15: Print " " + Locate 11, 15: Print " " + Locate 12, 15: Print " " + Print: Color 1, 0 + Print Spc(12); " " + +End Sub + +Sub show.stone (farbe%) + For I% = 1 To 4 + kastl blockx%(I%), blocky%(I%), farbe% + farb%(blockx%(I%), blocky%(I%)) = farbe% + Next I% +End Sub + +Sub show.verynicegraphic + + Screen 13 + + fa = 14 + ast = 5 + smooth = 70 + v = .01 + + Dim w As Double + w = 1 + For u = 0 To 255 + I = u / 81 + r = Abs(Sin(w + I + 4 * _Pi / 3) * 63) + g = Abs(Sin(w + I + 2 * _Pi / 3) * 63) + B = Abs(Sin(w + I) * 63) + + setpal u, r, g, B + + Next u + Color 1 + Locate 15, 8: Print "Programming:" + Locate 16, 20: Print "Dietmar Moritz" + Locate 18, 8: Print "Testing:" + Locate 19, 20: Print "Dietmar Moritz" + Locate 21, 8: Print "Graphics:" + Locate 22, 20: Print "Dietmar Moritz" + + Draw "c251" + Color 251 + + Draw "bm20,80 u40 r 20 F30 d10 l30 u10 r13 h17 l3 d27 l13" + Paint (23, 78), 252, 251 + + Draw "c251 bm80,80 u40 r13 d40 l13" + Paint (83, 78), 252, 251 + + Draw "c251 bm105,80 u40 r 20 F30 d10 l30 u10 r13 h17 l3 d27 l13" + Paint (108, 78), 252, 251 + + Draw "c251 bm165,80 u40 r22" + Line -Step(20, 15), 251 + Line -Step(-16, 10), 251 + Draw "f15 l13 h12 u7" + Line -Step(9, -6), 251 + Line -Step(-8, -5), 251 + Draw "l4 d30 l12" + Paint (167, 78), 252, 251 + + Draw "c251 bm215,80 u40 r13 d40 l13" + Paint (220, 78), 252, 251 + + Draw "c251 bm240,80 u10 r23 e5 l27 u15 e10 r30 d10 l23 g5 r27 d15 g10 l30" + Paint (243, 78), 252, 251 + + + For y% = 0 To 200 + For x% = 0 To 160 + a = Sqr(((x% - 160)) ^ 2 + (y% - 100) ^ 2) + + If x% <> 160 Then + w = Atn((y% - 100) / (x% - 160)) + Else + w = Atn((y% - 100) / (.1)) + End If + + c = Sin(a / fa) ^ 2 * smooth + (w * ast) * 81.5 + c = c Mod 256 + + If InKey$ = Chr$(27) Then Screen 12: Exit Sub + + Select Case Point(x%, y%) + Case 251: PSet (x%, y%), c + 128 + Case 252: PSet (x%, y%), c + 80 + Case 1: PSet (x%, y%), c + 50 + Case Else: PSet (x%, y%), c + End Select + + If x% < 160 Then + Select Case Point(320 - x%, 200 - y%) + Case 251: PSet (320 - x%, 200 - y%), c + 128 + Case 252: PSet (320 - x%, 200 - y%), c + 80 + Case 1: PSet (320 - x%, 200 - y%), c + 50 + Case Else: PSet (320 - x%, 200 - y%), c + End Select + End If + + Next x% + Next y% + + w = 1 + Do + w = w + v + For u = 0 To 255 + I = u / 81 + r = Abs(Sin(w + I + 4 * _Pi / 3) * 63) + g = Abs(Sin(w + I + 2 * _Pi / 3) * 63) + B = Abs(Sin(w + I) * 63) + setpal u, r, g, B + Next u + _Limit 60 + Loop Until InKey$ <> "" + + Screen 12 +End Sub + +Sub showhiscore + Palette + Dim n$(10) + Dim s(10) + Cls + + score = punkte + + On Error GoTo keine + + Open "I", #1, "didris.hsc" + + If h = 0 Then + + For I% = 1 To 10 + If EOF(1) Then GoTo weiter + Input #1, n$(I%) + Input #1, s(I%) + Next I% + End If + + weiter: + Close #1 + + Color 6 + setpal 6, 10, 43, 63 + For I% = 1 To 10 + If score > s(I%) Then + Locate 10, 30: Input "Name: ", name$ + If Len(name$) > 12 Then name$ = Left$(name$, 12) + If name$ = "" Then name$ = "anonymous" + For u% = 9 To I% Step -1 + n$(u% + 1) = n$(u%) + s(u% + 1) = s(u%) + Next u% + n$(I%) = name$ + s(I%) = score + position% = I% + Exit For + End If + Next I% + + Cls + + For I = 0 To 15 + setpal I, 0, 0, 0 + Next I + + For x% = 0 To 82 + For y% = 0 To 82 + c = Int(Rnd * (5)) + 1 + PSet (x%, y%), c + Next y% + Next x% + + For x% = 0 To 80 + For y% = 0 To 80 + c = Point(x%, y%) + Point(x% + 1, y%) + Point(x%, y% + 1) + Point(x% - 1, y%) + Point(x%, y% - 1) + PSet (x%, y%), c / 5 + Next y% + Next x% + + Dim hh(2000) As Integer + Get (1, 1)-(80, 80), hh() + + For y% = 0 To 480 Step 80 + For x% = 0 To 640 Step 80 + Put (x%, y%), hh(), PSet + Next x% + Next y% + + ax = 177 + ay = 50 + bx = 390 + Int(Len(Str$(s(1))) / 2) * 9 * 2 + by = 430 + + Line (ax, ay)-(bx, by), 0, BF + Line (ax, ay)-(bx, by), 7, B + + setpal 0, 20, 20, 20 + setpal 1, 0, 0, 20 + setpal 2, 0, 0, 31 + setpal 3, 0, 0, 42 + setpal 4, 0, 0, 53 + setpal 5, 0, 0, 63 + setpal 7, 20, 20, 20 + setpal 8, 22, 22, 22 + setpal 9, 18, 18, 18 + setpal 10, 16, 16, 16 + setpal 11, 24, 24, 24 + setpal 12, 10, 10, 10 + setpal 13, 5, 5, 5 + setpal 15, 0, 0, 0 + + Color 7 + + Line (171, 44)-(bx + 6, 44) + Line -(bx, ay) + Line (171, 44)-(171, 436) + Line -(ax, by) + Paint (175, ay), 11, 7 + Line (ax, ay)-(171, 44) + + Line (171, 436)-(bx + 6, 436) + Line -(bx + 6, 44) + Paint (bx + 2, by), 12, 7 + Line (bx + 6, 436)-(bx, by), 13 + + Line (171, 44)-(bx + 6, 436), 15, B + + Color 6 + setpal 6, 10, 43, 63 + For I% = 1 To 10 + Locate I% * 2 + 6, 30 + If s(I%) > 0 Then + Print n$(I%), s(I%) + End If + Next I% + + Locate 5, 25 + Int(Len(Str$(s(1))) / 2) + Color 1: Print "-"; + Color 2: Print "="; + Color 3: Print " H I "; + Color 4: Print "G H "; + Color 5: Print "S "; + Color 4: Print "C O "; + Color 3: Print "R E "; + Color 2: Print "="; + Color 1: Print "-"; + + If position% > 0 Then + Locate position% * 2 + 6, 30 + Color 14 + Print name$, punkte + End If + + For I% = 1 To 100 + x% = Int(Rnd * (bx - ax)) + ax + y% = Int(Rnd * (by - ay)) + ay + c% = Int(Rnd * (5)) + 8 + For u% = 1 To 20 + x% = Int(Rnd * (3)) + x% - 1 + y% = Int(Rnd * (3)) + y% - 1 + If Point(x%, y%) = 0 Then PSet (x%, y%), c% + Next u% + Next I% + + Open "O", #1, "didris.hsc" + For I% = 1 To 10 + Print #1, n$(I%) + Print #1, s(I%) + Next I% + Close #1 + + Do + x = x + .01 + c1 = Abs(Int(Sin(x) * 63)) + c2 = Abs(Int(Sin(x + 2 * _Pi / 3) * 63)) + c3 = Abs(Int(Sin(x + 4 * _Pi / 3) * 63)) + setpal 14, c1, c2, c3 + Wait &H3DA, 8 + Loop Until InKey$ <> "" + +End Sub + +Sub showpoints + For I% = 2 To 0 Step -1 + Line (320 - (130 + I% * 10), 240 - (50 + I% * 10))-(320 + (130 + I% * 10), 190 + (50 + I% * 10)), I% + 11, BF + Line (320 - 120, 240 - 40)-(320 + 120, 190 + 40), 0, BF + Next I% + Color 14 + Locate 14, 40 - Int((7 + Len(Str$(punkte))) / 2) + Print "SCORE: " + Str$(punkte) + + Do + x = x + .009 + c1 = Abs(Int(Sin(x) * 63)) + c2 = Abs(Int(Sin(x + 2 * _Pi / 3) * 63)) * 256 + c3 = Abs(Int(Sin(x + 4 * _Pi / 3) * 63)) * 256 ^ 2 + Palette 11, c1 + c2 + Palette 12, c1 + c3 + Palette 13, c2 + c3 + Palette 14, c1 + c2 + c3 + Loop Until InKey$ = Chr$(13) +End Sub + +Sub strukturstart (struktur%) + Select Case struktur% + Case 1 + blockx%(1) = Int(fb / 2) + 1 + blocky%(1) = 2 + blockx%(2) = blockx%(1) + blocky%(2) = 1 + blockx%(3) = blockx%(1) - 1 + blocky%(3) = 2 + blockx%(4) = blockx%(1) + 1 + blocky%(4) = 2 + Case 2 + blockx%(1) = Int(fb / 2) + blocky%(1) = 1 + blockx%(2) = blockx%(1) + blocky%(2) = 2 + blockx%(3) = blockx%(1) + 1 + blocky%(3) = 1 + blockx%(4) = blockx%(1) + 1 + blocky%(4) = 2 + Case 3 + blockx%(1) = Int(fb / 2) + 1 + blocky%(1) = 1 + blockx%(2) = blockx%(1) + 1 + blocky%(2) = 1 + blockx%(3) = blockx%(1) - 1 + blocky%(3) = 2 + blockx%(4) = blockx%(1) + blocky%(4) = 2 + Case 4 + blockx%(1) = Int(fb / 2) + blocky%(1) = 1 + blockx%(2) = blockx%(1) + 1 + blocky%(2) = 1 + blockx%(3) = blockx%(2) + 1 + blocky%(3) = 2 + blockx%(4) = blockx%(2) + blocky%(4) = 2 + Case 5 + blockx%(1) = Int(fb / 2) + blocky%(1) = 2 + blockx%(2) = blockx%(1) + blocky%(2) = 1 + blockx%(3) = blockx%(1) + 1 + blocky%(3) = 1 + blockx%(4) = blockx%(1) + blocky%(4) = 3 + Case 6 + blockx%(1) = Int(fb / 2) + 1 + blocky%(1) = 2 + blockx%(2) = blockx%(1) + blocky%(2) = 1 + blockx%(3) = blockx%(1) - 1 + blocky%(3) = 1 + blockx%(4) = blockx%(1) + blocky%(4) = 3 + Case 7 + blockx%(1) = Int(fb / 2) + 1 + blocky%(1) = 2 + blockx%(2) = blockx%(1) + blocky%(2) = 1 + blockx%(3) = blockx%(1) + blocky%(3) = 3 + blockx%(4) = blockx%(1) + blocky%(4) = 4 + Case 99 + blockx%(1) = Int(fb / 2) + 1 + blocky%(1) = 1 + blockx%(2) = blockx%(1) + blocky%(2) = 1 + blockx%(3) = blockx%(1) + blocky%(3) = 1 + blockx%(4) = blockx%(1) + blocky%(4) = 1 + End Select + + For I% = 1 To 4 + If feld%(blockx%(I%), blocky%(I%)) = belegt% Then + farb% = Int(Rnd * (15)) + 1 + For i2% = 1 To 4 + kastl blockx%(i2%), blocky%(i2%), farb% + Next i2% + ausis + Exit Sub + End If + Next I% +End Sub + +Sub Tasten + Dim a$(15) + a$(1) = "Left......... Left " + a$(2) = "Right........ Right " + a$(3) = "Rotate....... Up / Enter" + a$(4) = "Drop......... Down / 0 " + a$(5) = "Acidrain..... Space bar " + a$(7) = "Music on/off. m / s" + a$(8) = "Music #1..... 1 " + a$(9) = "Music #2..... 2 " + a$(10) = "Music #3..... 3 " + a$(12) = "Info......... F1 " + a$(13) = "Pause........ p " + a$(14) = "Boss Key..... F10" + a$(15) = "End.......... ESC" + + + If yn(1) = 2 Then + For I% = 7 To 10 + a$(I%) = a$(I% + 5) + a$(I% + 5) = "" + Next I% + End If + + If yn(4) = 2 Then + For I% = 5 To 14 + a$(I%) = a$(I% + 1) + a$(15) = "" + Next I% + End If + + For I% = 1 To 15 + For x% = 1 To Len(a$(I%)) Step 2 + Locate 7 + I%, 54 + x%: Color Int(Rnd * (15)) + 1: Print Mid$(a$(I%), x%, 2) + Next x% + Next I% +End Sub + +Sub Titel + Palette + a$ = "DIDI's" + B$ = "DIDRIS" + c$ = "1 9 9 8" + + zx = 320 + zy = 240 + zz = 60 + h = 5 + f = 5 + ff = 0 + fff = 100 + + For ii% = 1 To 3 + Select Case ii% + Case 1: xx$ = a$ + Case 2: xx$ = B$ + Case 3: xx$ = c$ + End Select + Locate 1, 1: Print xx$ + " " + For y% = 1 To 15 + For I% = 1 To Len(xx$) * 8 + If Point(I%, y%) > 0 Then + farb% = Int(Rnd * (15)) + 1 + Line (fax(320 - Len(xx$) * 20 + I% * 40 / 8, 0, zx, zz), fay(y% * f - ff + ii% * fff, 0, zy, zz))-(fax(320 - Len(xx$) * 20 + I% * 40 / 8, h, zx, zz), fay(y% * f - ff + ii% * fff, h, zy, zz)), farb% + End If + Next I% + Next y% + Next ii% + Locate 1, 1: Print " " + t = Timer + Do + x = x + .01 + c1 = Abs(Int(Sin(x) * 63)) + c2 = Abs(Int(Sin(x + 2 * _Pi / 3) * 63)) * 256 + c3 = Abs(Int(Sin(x + 4 * _Pi / 3) * 63)) * 256 ^ 2 + c4 = Abs(Int(Cos(x) * 63)) + c5 = Abs(Int(Cos(x + 2 * _Pi / 3) * 63)) * 256 + c6 = Abs(Int(Cos(x + 4 * _Pi / 3) * 63)) * 256 ^ 2 + Palette 7, c4 + c5 + Palette 8, c4 + c6 + Palette 9, c5 + c6 + Palette 10, c4 + c5 + c6 + Palette 11, c1 + c2 + Palette 12, c1 + c3 + Palette 13, c2 + c3 + Palette 14, c1 + c2 + c3 + z$ = InKey$ + _Limit 60 + Loop Until z$ <> "" Or Timer >= t + 15 + If UCase$(z$) = "M" Then yn(1) = 2 + + Dim verz(3000) + + fa = 40 + fa2 = 2 + t = Timer + Do + x = Int(Rnd * (530 - fa)) + 100 + y = Int(Rnd * (370 - fa)) + 70 + Get (x, y)-(x + fa, y + fa), verz() + Put (x, y + fa2), verz(), PSet + z$ = InKey$ + Wait &H3DA, 8 + Loop Until z$ <> "" Or Timer >= t + 20 + + If UCase$(z$) = "M" Then yn(1) = 2 + + Palette +End Sub + diff --git a/samples/didris/src/didris.zip b/samples/didris/src/didris.zip new file mode 100644 index 0000000..58e6ca9 Binary files /dev/null and b/samples/didris/src/didris.zip differ diff --git a/samples/dietmar-moritz.md b/samples/dietmar-moritz.md new file mode 100644 index 0000000..e180db1 --- /dev/null +++ b/samples/dietmar-moritz.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 DIETMAR MORITZ + +**[Didris](didris/index.md)** + +[🐝 Dietmar Moritz](dietmar-moritz.md) 🔗 [game](game.md), [tetris](tetris.md) + +'________________________This_is_the_unbelievable '________ÜÜÜ___ÜÜ_________ÜÜÜ____________ÜÜ '__... diff --git a/samples/dos-world.md b/samples/dos-world.md new file mode 100644 index 0000000..2cb9b52 --- /dev/null +++ b/samples/dos-world.md @@ -0,0 +1,87 @@ +[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: DOS WORLD + +**[Bar Demo](bar-demo/index.md)** + +[🐝 Douglas Park](douglas-park.md) 🔗 [tui](tui.md), [dos world](dos-world.md) + +' BARDEMO.BAS ' by Douglas Park ' Copyright (C) 1995 DOS World Magazine ' Published in Issue #19,... + +**[Calc](calc/index.md)** + +[🐝 William Loughner](william-loughner.md) 🔗 [calculator](calculator.md), [dos world](dos-world.md) + +' CALC.BAS ' by William Loughner ' Copyright (c) 1994 DOS Resource Guide ' Published i... + +**[Calendar](calendar/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [calendar](calendar.md), [pdf](pdf.md), [dos world](dos-world.md) + +' Antonio & Alfonso De Pasquale ' Copyright (C) 1993 DOS Resource Guide ' Published in Issue #8, ... + +**[Colors](colors/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [color picker](color-picker.md), [dos world](dos-world.md) + +' COLORS.BAS ' Copyright (c) 1993 DOS Resource Guide ' Published in Issue #12, November 199... + +**[Cram](cram/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [game](game.md), [dos world](dos-world.md) + +'CRAM! ' by Hardin Brothers ' ' Copyright (C) 1993 DOS Resource Guide ' Published in Issue ... + +**[Dec to Frac](dec-to-frac/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [math](math.md), [dos world](dos-world.md) + +' DEC_FRAC.BAS - Fraction/Decimal conversion functions ' and sample program ' b... + +**[Diamond Pong](diamond-pong/index.md)** + +[🐝 John Wolfskill](john-wolfskill.md) 🔗 [game](game.md), [pong](pong.md), [dos world](dos-world.md) + +' Diamond Pong ' by ' John Wol... + +**[Hangman](hangman/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [game](game.md), [hangman](hangman.md), [dos world](dos-world.md) + +' HANGMAN.BAS by Antonio & Alfonso De Pasquale ' Copyright (C) 1993, 1994 DOS Resource Guide ' ... + +**[Letter Blast](letter-blast/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [game](game.md), [letter](letter.md), [dos world](dos-world.md) + +' LETBLAST.BAS - Shoot the falling letters! ' by Antonio & Alfonso De Pasquale ' ' Copyr... + +**[Loan Amortization](loan-amortization/index.md)** + +[🐝 Alan Zeichick](alan-zeichick.md) 🔗 [finance](finance.md), [dos world](dos-world.md) + +' Loan amortization program ' Alan Zeichick, March 16, 1993 ' Copyright (c) 1993 DOS Resource Gui... + +**[Measure](measure/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [measure](measure.md), [dos world](dos-world.md) + +' MEASURE.BAS - A program for performing measurement conversions ' by Antonio & Alfonso De P... + +**[Names](names/index.md)** + +[🐝 David Bannon](david-bannon.md) 🔗 [data management](data-management.md), [dos world](dos-world.md) + +' NAMES.BAS by David Bannon ' Copyright (C) 1992 DOS Resource Guide ' Published in Issue #6, N... + +**[Phone](phone/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [data management](data-management.md), [dos world](dos-world.md) + +' ' PHONE.BAS by Hardin Brothers ' Copyright (C) 1992 DOS Resource Guide ' Published in Issue ... + +**[Saver](saver/index.md)** + +[🐝 David Ferrier](david-ferrier.md) 🔗 [screensaver](screensaver.md), [dos world](dos-world.md) + +1 ' SAVER.BAS by David Ferrier 2 ' Copyright (C) 1992 DOS Resource Guide 3 ' Published in Issu... diff --git a/samples/double-pendulum/img/screenshot.png b/samples/double-pendulum/img/screenshot.png new file mode 100644 index 0000000..cdb10a2 Binary files /dev/null and b/samples/double-pendulum/img/screenshot.png differ diff --git a/samples/double-pendulum/index.md b/samples/double-pendulum/index.md new file mode 100644 index 0000000..8b20106 --- /dev/null +++ b/samples/double-pendulum/index.md @@ -0,0 +1,25 @@ +[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: DOUBLE PENDULUM + +![screenshot.png](img/screenshot.png) + +### Description + +```text +Simulated double pendulum with damping. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "double-pendulum.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/double-pendulum/src/double-pendulum.bas) +* [RUN "double-pendulum.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/double-pendulum/src/double-pendulum.bas) +* [PLAY "double-pendulum.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/double-pendulum/src/double-pendulum.bas) + +### File(s) + +* [double-pendulum.bas](src/double-pendulum.bas) + +🔗 [physics](../physics.md), [pendulum](../pendulum.md) diff --git a/samples/double-pendulum/src/double-pendulum.bas b/samples/double-pendulum/src/double-pendulum.bas new file mode 100644 index 0000000..f133013 --- /dev/null +++ b/samples/double-pendulum/src/double-pendulum.bas @@ -0,0 +1,164 @@ +DefDbl A-Z: DefInt I-J, N +n = 5: nn = 0 +Dim x(n), xx(n), f(n), c(4, n) +nextone: +Screen 0: Cls +_FullScreen +' option here to get the x-scale NOT magnified as in popular modern monitors +GoSub graphics +GoSub startup + +agn: +Cls +Line (0, -a)-(0, a), 8 +ph = -a * Cos(w * x(5)) +Circle (0, ph), .025, 12: Paint (0, ph), 12 +X1 = Sin(xx(1)) +X2 = -Cos(xx(1)) + ph +X3 = Sin(xx(1)) + Sin(xx(3)) +X4 = -Cos(xx(1)) - Cos(xx(3)) + ph +Line (0, ph)-(X1, X2), 12 +Circle (X1, X2), .05, 9: Paint (X1, X2), 9 +Line (X1, X2)-(X3, X4), 12 +Circle (X3, X4), .05, 9: Paint (X3, X4), 9 +_Delay .001 +GoSub Runge +t = t + h +Locate 21, 6: Print CSng(t) +a$ = InKey$: If a$ = "" Then GoTo agn Else GoTo nextone + +Equations: +Q = x(3) - x(1) +c = Cos(Q) +s = Sin(Q) +P = c * s +D = 1# - m * c ^ 2# +g = (1# + a * w ^ 2# * Cos(w * x(5))) +g1 = g * Sin(x(1)) +g3 = g * Sin(x(3)) +x22 = x(2) ^ 2# +x42 = x(4) ^ 2# +f(1) = x(2) +f(2) = -k * x(2) + (m * (x42 * s + x22 * P + g3 * c) - g1) / D +f(3) = x(4) +f(4) = -k * x(4) + (-x22 * s - m * x42 * P - g3 + g1 * c) / D +f(5) = 1# +Locate 7, 5: Print x(1) +Locate 8, 5: Print x(2) +Locate 9, 5: Print x(3) +Locate 10, 5: Print x(4) +Locate 11, 5: Print x(5) +_Display +Return + +Runge: +For i = 1 To n: x(i) = xx(i): Next +GoSub Equations +For i = 1 To n: c(1, i) = h * f(i): Next +For i = 1 To n: x(i) = xx(i) + c(1, i) / 2#: Next +GoSub Equations +For i = 1 To n: c(2, i) = h * f(i): Next +For i = 1 To n: x(i) = xx(i) + c(2, i) / 2#: Next +GoSub Equations +For i = 1 To n: c(3, i) = h * f(i): Next +For i = 1 To n: x(i) = xx(i) + c(3, i): Next +GoSub Equations +For i = 1 To n: c(4, i) = h * f(i): Next +For i = 1 To n + xx(i) = xx(i) + (c(1, i) + 2# * c(2, i) + 2# * c(3, i) + c(4, i)) / 6# +Next +Return + +graphics: +Cls: Screen 9 +Paint (1, 1), 9 +View (220, 17)-(595, 330), 0, 14 +Window (-3.6, -2.4)-(3.6, 2.8) +Locate 21, 2: Print "Time" +Return + +startup: +k = .1#: m = .1#: xx(2) = 0: xx(4) = 0 +'nn = 2 +Select Case nn + + Case O + k = .05#: m = .1#: xx(2) = 0: xx(4) = 0: xx(1) = .4: xx(3) = -.2 + Print "viscous damping k=0.05" + Case 1 + k = 0#: m = .1#: xx(2) = 0: xx(4) = 0: xx(1) = 0: xx(3) = 3.1428 + Locate 5, 2 + Print " no viscous damping " + Case 2 + a = .2: w = 10: xx(1) = 3.1: xx(3) = 1 'stable yet semi-hanging + Locate 3, 1 + Print "stable yet top-hanging" + Case 3 + a = .1: w = 3.696#: xx(1) = .01: xx(3) = .01: m = .5# 'fast mode + Locate 3, 1 + Print " fast-pump mode " + Case 4 + a = .1: w = 1.55#: xx(1) = .01: xx(3) = .01: m = .5#: k = .03# 'slow mode + Locate 3, 1 + Print " slow-pump mode " + Case 5 + a = .1: w = 1.55#: xx(1) = .1: xx(3) = .2: m = .5# 'k=.1 too much for slow + Locate 3, 1 + Print " damping k=0.1 is too " + Locate 4, 1 + Print " much for slow mode " + Case 6 + a = .1: w = 2: xx(1) = .32: xx(3) = .32 'goes to down-hanging + Locate 4, 1 + Print " goes to down-hanging " + Case 7 + a = .1: w = 2: xx(1) = 1: xx(3) = -1 'stable fast swing + Locate 3, 2 + Print " stable fast swing " + Case 8 + a = .25: w = 2: xx(1) = 1.5: xx(3) = -1.5 'stable fast swing + Locate 3, 2 + Print " stable fast swing " + Case 9 + a = .25#: w = 2#: xx(1) = 1: xx(3) = -1: x(2) = 5: x(4) = 5: k = .05 'whirling + Locate 3, 2 + Print " whirling dervrish " + Case 10 + m = .5#: k = .2#: xx(1) = 2.5: xx(3) = 1.9: a = .1: w = 25 'a<.3;w>1.85/a + Locate 3, 2 + Print " Indian Rope Trick! " + Case 11 + m = .5#: k = .2#: xx(1) = 2.6: xx(3) = -3.1: a = .1: w = 25 'a<.3;w>1.85/a + Locate 3, 3 + Print " teeter-totter " + Case 12 + m = .5#: k = .2#: xx(1) = 3.1: xx(3) = 3.2: a = .04: w = 25 'collapse 1 + Locate 3, 4 + Print " surprise! " + Case 13 + m = .5#: k = .2#: xx(1) = 3.1: xx(3) = 3.2: a = .15#: w = 25 'collapse 2 + Locate 3, 2 + Print " this IS demo 13! " + Case 14 + m = .5#: k = .2#: xx(1) = 3.05#: xx(3) = 3.25#: a = .11#: w = 25 'a<.3;w>1.85/a + Case Is > 15 + Screen 0: Cls: Print "Only maths and physics types live in a LINEAR delusion" + Print " where you can uncook eggs and correct errors!": End +End Select +If nn > 1 Then + Locate 5, 4 + Print " damping k=";: Print Using "#.##"; k +Else + Locate 3, 3 + Print " A double pendulum" + Locate 4, 3 + Print " swinging with " +End If +Locate 25, 1: Print "press any key for next demo"; +'IF nn < 0 THEN LOCATE 12, 2: INPUT "a,w"; a, w +t = 0#: xx(5) = 0# +'IF nn > 0 THEN LOCATE 14, 2: INPUT "ang1,ang2"; xx(1), xx(3) +h = .005# +nn = nn + 1 +Return + diff --git a/samples/douglas-park.md b/samples/douglas-park.md new file mode 100644 index 0000000..78d9efe --- /dev/null +++ b/samples/douglas-park.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 DOUGLAS PARK + +**[Bar Demo](bar-demo/index.md)** + +[🐝 Douglas Park](douglas-park.md) 🔗 [tui](tui.md), [dos world](dos-world.md) + +' BARDEMO.BAS ' by Douglas Park ' Copyright (C) 1995 DOS World Magazine ' Published in Issue #19,... diff --git a/samples/draw.md b/samples/draw.md new file mode 100644 index 0000000..0d4cc68 --- /dev/null +++ b/samples/draw.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: DRAW + +**[Lucid Drawing](lucid-drawing/index.md)** + +[🐝 Lucid](lucid.md) 🔗 [2d](2d.md), [draw](draw.md) + +Drawing program by Lucid. diff --git a/samples/drawing.md b/samples/drawing.md index ca8d25e..6228b26 100644 --- a/samples/drawing.md +++ b/samples/drawing.md @@ -8,6 +8,12 @@ A Graphics/Animation utility by Bob Seguin. NOTE: This game requires graphics files created by a... +**[Kaleidoscope Doodler](kaleidoscope-doodler/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [art](art.md), [drawing](drawing.md) + +Left-click to draw, right click or middle click to clear screen, escape to quit. + **[QBAscii](qbascii/index.md)** [🐝 Jeremy Munn](jeremy-munn.md) 🔗 [drawing](drawing.md), [ascii](ascii.md) diff --git a/samples/dropping-balls/index.md b/samples/dropping-balls/index.md index f56240d..3234c05 100644 --- a/samples/dropping-balls/index.md +++ b/samples/dropping-balls/index.md @@ -18,9 +18,9 @@ Dropping Balls an attempt to build a pile by adjusting drop rate, elasticity, an > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "droppingballs.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/dropping-balls/src/droppingballs.bas) -* [RUN "droppingballs.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/dropping-balls/src/droppingballs.bas) -* [PLAY "droppingballs.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/dropping-balls/src/droppingballs.bas) +* [LOAD "droppingballs.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/dropping-balls/src/droppingballs.bas) +* [RUN "droppingballs.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/dropping-balls/src/droppingballs.bas) +* [PLAY "droppingballs.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/dropping-balls/src/droppingballs.bas) ### File(s) diff --git a/samples/editor.md b/samples/editor.md new file mode 100644 index 0000000..15435c6 --- /dev/null +++ b/samples/editor.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: EDITOR + +**[XE Hex Editor](xe-hex-editor/index.md)** + +[🐝 Dav](dav.md) 🔗 [editor](editor.md), [hex](hex.md) + +'============ 'XE.BAS v1.10 '============ 'A simple Binary File (HEX) editor. 'Coded by Dav on AU... diff --git a/samples/eliza.md b/samples/eliza.md new file mode 100644 index 0000000..b4ea851 --- /dev/null +++ b/samples/eliza.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: ELIZA + +**[Eliza](eliza/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [ai](ai.md), [eliza](eliza.md) + +The original chatbot, Eliza. diff --git a/samples/eliza/img/screenshot.png b/samples/eliza/img/screenshot.png new file mode 100644 index 0000000..5bdc57b Binary files /dev/null and b/samples/eliza/img/screenshot.png differ diff --git a/samples/eliza/index.md b/samples/eliza/index.md new file mode 100644 index 0000000..1531128 --- /dev/null +++ b/samples/eliza/index.md @@ -0,0 +1,19 @@ +[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: ELIZA + +![screenshot.png](img/screenshot.png) + +### Description + +```text +The original chatbot, Eliza. +``` + +### File(s) + +* [eliza.bas](src/eliza.bas) +* [eliza.zip](src/eliza.zip) +* [p36-weizenabaum.pdf](src/p36-weizenabaum.pdf) + +🔗 [ai](../ai.md), [eliza](../eliza.md) diff --git a/samples/eliza/src/eliza.bas b/samples/eliza/src/eliza.bas new file mode 100644 index 0000000..83c24dd --- /dev/null +++ b/samples/eliza/src/eliza.bas @@ -0,0 +1,249 @@ +' Modified 2021 by wfbarnes for QB64 compiler. + +'1 KEY OFF: CLS +'4 CLS +'5 PRINT TAB(16) + "**************************" +'10 PRINT TAB(26) + "ELIZA" +'20 PRINT TAB(20) + "CREATIVE COMPUTING" +'30 PRINT TAB(18) + "MORRISTOWN, NEW JERSEY": PRINT +'40 PRINT TAB(19) + "ADAPTED FOR IBM PC BY" +'50 PRINT TAB(20) + "PATRICIA DANIELSON AND PAUL HASHFIELD" +'52 PRINT TAB(21) + "BE SURE THAT THE CAPS LOCK IS ON" +'53 PRINT: PRINT TAB(16) + "PLEASE DON'T USE COMMAS OR PERIODS IN YOUR INPUTS": PRINT +'55 PRINT TAB(16) + "*************************" +'60 PRINT: PRINT: PRINT +'80 REM*****INITIALIZATION********** +100 Dim Shared S(36), R(36), N(36) +105 Dim Shared KEYWORD$(36), WORDIN$(7), WORDOUT$(7), REPLIES$(112) +Dim Shared N1, N2, N3 +Dim L, X +110 N1 = 36: N2 = 14: N3 = 112 +112 For X = 1 To N1: Read KEYWORD$(X): Next X +114 For X = 1 To N2 / 2: Read WORDIN$(X): Read WORDOUT$(X): Next X +116 For X = 1 To N3: Read REPLIES$(X): Next X +130 For X = 1 To N1 + 140 Read S(X), L: R(X) = S(X): N(X) = S(X) + L - 1 +150 Next X +'160 PRINT "HI! I'M ELIZA. WHAT'S YOUR PROBLEM?" + +1000 Rem ******************************* +1010 Rem *****PROGRAM DATA FOLLOWS****** +1020 Rem ******************************* +1030 Rem *********KEYWORDS************** +1049 Rem ******************************* +1050 Data "CAN YOU ","CAN I ","YOU ARE ","YOU'RE ","I DON'T ","I FEEL " +1060 Data "WHY DON'T YOU ","WHY CAN'T I ","ARE YOU ","I CAN'T ","I AM ","I'M " +1070 Data "YOU ","I WANT ","WHAT ","HOW ","WHO ","WHERE ","WHEN ","WHY " +1080 Data "NAME ","CAUSE ","SORRY ","DREAM ","HELLO ","HI ","MAYBE " +1090 Data "NO","YOUR ","ALWAYS ","THINK ","ALIKE ","YES ","FRIEND " +1100 Data "COMPUTER","NOKEYFOUND" +1200 Rem ********************************* +1210 Rem ***STRING DATA FOR CONJUGATIONS** +1220 Rem ********************************* +1230 Data " ARE "," AM "," WERE "," WAS "," YOU "," I "," YOUR"," MY " +1235 Data " I'VE "," YOU'VE "," I'M "," YOU'RE " +1240 Data " ME "," YOU " +1300 Rem ****************************** +1310 Rem *********REPLIES************** +1320 Rem ****************************** +1330 Data "DON'T YOU BELIEVE THAT I CAN*" +1340 Data "PERHAPS YOU WOULD LIKE TO BE LIKE ME*" +1350 Data "YOU WANT ME TO BE ABLE TO*" +1360 Data "PERHAPS YOU DON'T WANT TO*" +1365 Data "DO YOU WANT TO BE ABLE TO*" +1370 Data "WHAT MAKES YOU THINK I AM*" +1380 Data "DOES IT PLEASE YOU TO BELIEVE I AM*" +1390 Data "PERHAPS YOU WOULD LIKE TO BE*" +1400 Data "DO YOU SOMETIMES WISH YOU WERE*" +1410 Data "DON'T YOU REALLY*" +1420 Data "WHY DON'T YOU*" +1430 Data "DO YOU WISH TO BE ABLE TO*" +1440 Data "DOES THAT TROUBLE YOU*" +1450 Data "DO YOU OFTEN FEEL*" +1460 Data "DO YOU OFTEN FEEL*" +1470 Data "DO YOU ENJOY FEELING*" +1480 Data "DO YOU REALLY BELIEVE I DON'T*" +1490 Data "PERHAPS IN GOOD TIME I WILL*" +1500 Data "DO YOU WANT ME TO*" +1510 Data "DO YOU THINK YOU SHOULD BE ABLE TO*" +1520 Data "WHY CAN'T YOU*" +1530 Data "WHY ARE YOU INTERESTED IN WHETHER OR NOT I AM*" +1540 Data "WOULD YOU PREFER IF I WERE NOT*" +1550 Data "PERHAPS IN YOUR FANTASIES I AM*" +1560 Data "HOW DO YOU KNOW YOU CAN'T*" +1570 Data "HAVE YOU TRIED?" +1580 Data "PERHAPS YOU CAN NOW*" +1590 Data "DID YOU COME TO ME BECAUSE YOU ARE*" +1600 Data "HOW LONG HAVE YOU BEEN*" +1610 Data "DO YOU BELIEVE IT IS NORMAL TO BE*" +1620 Data "DO YOU ENJOY BEING*" +1630 Data "WE WERE DISCUSSING YOU--NOT ME." +1640 Data "OH, I*" +1650 Data "YOU'RE NOT REALLY TALKING ABOUT ME, ARE YOU?" +1660 Data "WHAT WOULD IT MEAN TO YOU IF YOU GOT*" +1670 Data "WHY DO YOU WANT*" +1680 Data "SUPPOSE YOU SOON GOT*" +1690 Data "WHAT IF YOU NEVER GOT*" +1700 Data "I SOMETIMES ALSO WANT*" +1710 Data "WHY DO YOU ASK?" +1720 Data "DOES THAT QUESTION INTEREST YOU?" +1730 Data "WHAT ANSWER WOULD PLEASE YOU THE MOST?" +1740 Data "WHAT DO YOU THINK?" +1750 Data "ARE SUCH QUESTIONS ON YOUR MIND OFTEN?" +1760 Data "WHAT IS IT THAT YOU REALLY WANT TO KNOW?" +1770 Data "HAVE YOU ASKED ANYONE ELSE?" +1780 Data "HAVE YOU ASKED SUCH QUESTIONS BEFORE?" +1790 Data "WHAT ELSE COMES TO MIND WHEN YOU ASK THAT?" +1800 Data "NAMES DON'T INTEREST ME." +1810 Data "I DON'T CARE ABOUT NAMES --PLEASE GO ON." +1820 Data "IS THAT THE REAL REASON?" +1830 Data "DON'T ANY OTHER REASONS COME TO MIND?" +1840 Data "DOES THAT REASON EXPLAIN ANYTHING ELSE?" +1850 Data "WHAT OTHER REASONS MIGHT THERE BE?" +1860 Data "PLEASE DON'T APOLOGIZE!" +1870 Data "APOLOGIES ARE NOT NECESSARY." +1880 Data "WHAT FEELINGS DO YOU HAVE WHEN YOU APOLOGIZE?" +1890 Data "DON'T BE SO DEFENSIVE!" +1900 Data "WHAT DOES THAT DREAM SUGGEST TO YOU?" +1910 Data "DO YOU DREAM OFTEN?" +1920 Data "WHAT PERSONS APPEAR IN YOUR DREAMS?" +1930 Data "ARE YOU DISTURBED BY YOUR DREAMS?" +1940 Data "HOW DO YOU DO ...PLEASE STATE YOUR PROBLEM." +1950 Data "YOU DON'T SEEM QUITE CERTAIN." +1960 Data "WHY THE UNCERTAIN TONE?" +1970 Data "CAN'T YOU BE MORE POSITIVE?" +1980 Data "YOU AREN'T SURE?" +1990 Data "DON'T YOU KNOW?" +2000 Data "ARE YOU SAYING NO JUST TO BE NEGATIVE?" +2010 Data "YOU ARE BEING A BIT NEGATIVE." +2020 Data "WHY NOT?" +2030 Data "ARE YOU SURE?" +2040 Data "WHY NO?" +2050 Data "WHY ARE YOU CONCERNED ABOUT MY*" +2060 Data "WHAT ABOUT YOUR OWN*" +2070 Data "CAN YOU THINK OF A SPECIFIC EXAMPLE?" +2080 Data "WHEN?" +2090 Data "WHAT ARE YOU THINKING OF?" +2100 Data "REALLY, ALWAYS?" +2110 Data "DO YOU REALLY THINK SO?" +2120 Data "BUT YOU ARE NOT SURE YOU*" +2130 Data "DO YOU DOUBT YOU*" +2140 Data "IN WHAT WAY?" +2150 Data "WHAT RESEMBLANCE DO YOU SEE?" +2160 Data "WHAT DOES THE SIMILARITY SUGGEST TO YOU?" +2170 Data "WHAT OTHER CONNECTIONS DO YOU SEE?" +2180 Data "COULD THERE REALLY BE SOME CONNECTION?" +2190 Data "HOW?" +2200 Data "YOU SEEM QUITE POSITIVE." +2210 Data "ARE YOU SURE?" +2220 Data "I SEE." +2230 Data "I UNDERSTAND." +2240 Data "WHY DO YOU BRING UP THE TOPIC OF FRIENDS?" +2250 Data "DO YOUR FRIENDS WORRY YOU?" +2260 Data "DO YOUR FRIENDS PICK ON YOU?" +2270 Data "ARE YOU SURE YOU HAVE ANY FRIENDS?" +2280 Data "DO YOU IMPOSE ON YOUR FRIENDS?" +2290 Data "PERHAPS YOUR LOVE FOR FRIENDS WORRIES YOU." +2300 Data "DO COMPUTERS WORRY YOU?" +2310 Data "ARE YOU TALKING ABOUT ME IN PARTICULAR?" +2320 Data "ARE YOU FRIGHTENED BY MACHINES?" +2330 Data "WHY DO YOU MENTION COMPUTERS?" +2340 Data "WHAT DO YOU THINK MACHINES HAVE TO DO WITH YOUR PROBLEM?" +2350 Data "DON'T YOU THINK COMPUTERS CAN HELP PEOPLE?" +2360 Data "WHAT IS IT ABOUT MACHINES THAT WORRIES YOU?" +2370 Data "SAY, DO YOU HAVE ANY PSYCHOLOGICAL PROBLEMS?" +2380 Data "WHAT DOES THAT SUGGEST TO YOU?" +2390 Data "I SEE." +2400 Data "I'M NOT SURE I UNDERSTAND YOU FULLY." +2410 Data "COME COME ELUCIDATE YOUR THOUGHTS." +2420 Data "CAN YOU ELABORATE ON THAT?" +2430 Data "THAT IS QUITE INTERESTING." +2500 Rem ************************* +2510 Rem *****DATA FOR FINDING RIGHT REPLIES +2520 Rem ************************* +2530 Data 1,3,4,2,6,4,6,4,10,4,14,3,17,3,20,2,22,3,25,3 +2540 Data 28,4,28,4,32,3,35,5,40,9,40,9,40,9,40,9,40,9,40,9 +2550 Data 49,2,51,4,55,4,59,4,63,1,63,1,64,5,69,5,74,2,76,4 +2560 Data 80,3,83,7,90,3,93,6,99,7,106,6 + +''''' + +Do + Input i$ + Print Eliza$(i$) +Loop Until LCase$(i$) = "exit" + +''''' + +Function Eliza$ (TheStringIn As String) Static + Dim TheReturn As String + Dim K As Integer + Dim L As Integer + Dim X As Integer + Dim C As String + Dim I As String + Dim F As String + Dim P As String + 170 Rem *********************************** + 180 Rem *******USER INPUT SECTION********** + 190 Rem *********************************** + 200 I = UCase$(TheStringIn) 'INPUT I$ + 201 I = " " + I + " " + 210 Rem GET RID OF APOSTROPHES + 220 For L = 1 To Len(I) + 230 'REM IF MID$(I$,L,1)="'"THEN I$=LEFT$(I$,L-1)+RIGHT$(I$,LEN(I$)-L):GOTO 230 + 240 If L + 4 > Len(I) Then 250 + 241 If Mid$(I, L, 4) <> "SHUT" Then 250 + 242 TheReturn = "O.K. IF YOU FEEL THAT WAY I'LL SHUT UP...." + 243 GoTo ElizaFuncExit 'END + 250 Next L + 255 If I = P Then TheReturn = "PLEASE DON'T REPEAT YOURSELF!": GoTo ElizaFuncExit + 260 Rem *********************************** + 270 Rem ********FIND KEYWORD IN I$********* + 280 Rem *********************************** + 300 For K = 1 To N1 + 320 For L = 1 To Len(I) - Len(KEYWORD$(K)) + 1 + 340 If Mid$(I, L, Len(KEYWORD$(K))) <> KEYWORD$(K) Then 350 + 341 If K <> 13 Then 349 + 342 If Mid$(I, L, Len(KEYWORD$(29))) = KEYWORD$(29) Then K = 29 + 349 F = KEYWORD$(K): GoTo 390 + 350 Next L + 360 Next K + 370 K = 36: GoTo 570: Rem WE DIDN'T FIND ANY KEYWORDS + 380 Rem ****************************************** + 390 Rem **TAKE PART OF STRING AND CONJUGATE IT**** + 400 Rem **USING THE LIST OF STRINGS TO BE SWAPPED* + 410 Rem ****************************************** + 430 C = " " + Right$(I, Len(I) - Len(F) - L + 1) + " " + 440 For X = 1 To N2 / 2 + 460 For L = 1 To Len(C) + 470 If L + Len(WORDIN$(X)) > Len(C) Then 510 + 480 If Mid$(C, L, Len(WORDIN$(X))) <> WORDIN$(X) Then 510 + 490 C = Left$(C, L - 1) + WORDOUT$(X) + Right$(C, Len(C) - L - Len(WORDIN$(X)) + 1) + 495 L = L + Len(WORDOUT$(X)) + 500 GoTo 540 + 510 If L + Len(WORDOUT$(X)) > Len(C) Then 540 + 520 If Mid$(C, L, Len(WORDOUT$(X))) <> WORDOUT$(X) Then 540 + 530 C = Left$(C, L - 1) + WORDIN$(X) + Right$(C, Len(C) - L - Len(WORDOUT$(X)) + 1) + 535 L = L + Len(WORDIN$(X)) + 540 Next L + 550 Next X + 555 If Mid$(C, 2, 1) = " " Then C = Right$(C, Len(C) - 1): Rem ONLY 1 SPACE + 556 For L = 1 To Len(C) + 557 If Mid$(C, L, 1) = "!" Then C = Left$(C, L - 1) + Right$(C, Len(C) - L): GoTo 557 + 558 Next L + 560 Rem ********************************************** + 570 Rem **NOW USING THE KEYWORD NUMBER (K) GET REPLY** + 580 Rem ********************************************** + 600 F = REPLIES$(R(K)) + 610 R(K) = R(K) + 1: If R(K) > N(K) Then R(K) = S(K) + 620 If Right$(F, 1) <> "*" Then TheReturn = F: P = I: GoTo ElizaFuncExit + 625 If C <> " " Then 630 + 626 TheReturn = "YOU WILL HAVE TO ELABORATE MORE FOR ME TO HELP YOU" + 627 GoTo ElizaFuncExit + 630 TheReturn = Left$(F, Len(F) - 1) + C + 640 P = I: GoTo ElizaFuncExit + ElizaFuncExit: + Eliza$ = TheReturn + 'GOTO 170 +End Function diff --git a/samples/eliza/src/eliza.zip b/samples/eliza/src/eliza.zip new file mode 100644 index 0000000..c9df7d3 Binary files /dev/null and b/samples/eliza/src/eliza.zip differ diff --git a/samples/eliza/src/p36-weizenabaum.pdf b/samples/eliza/src/p36-weizenabaum.pdf new file mode 100644 index 0000000..c41c7c4 Binary files /dev/null and b/samples/eliza/src/p36-weizenabaum.pdf differ diff --git a/samples/ellipse-intersecting-line/index.md b/samples/ellipse-intersecting-line/index.md index c5e0b60..d629f6c 100644 --- a/samples/ellipse-intersecting-line/index.md +++ b/samples/ellipse-intersecting-line/index.md @@ -18,9 +18,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "ellipse-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/ellipse-intersecting-line/src/ellipse-intersect-line.bas) -* [RUN "ellipse-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/ellipse-intersecting-line/src/ellipse-intersect-line.bas) -* [PLAY "ellipse-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/ellipse-intersecting-line/src/ellipse-intersect-line.bas) +* [LOAD "ellipse-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/ellipse-intersecting-line/src/ellipse-intersect-line.bas) +* [RUN "ellipse-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/ellipse-intersecting-line/src/ellipse-intersect-line.bas) +* [PLAY "ellipse-intersect-line.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/ellipse-intersecting-line/src/ellipse-intersect-line.bas) ### File(s) diff --git a/samples/fellippe-heitor.md b/samples/fellippe-heitor.md index c417016..7b95b7f 100644 --- a/samples/fellippe-heitor.md +++ b/samples/fellippe-heitor.md @@ -20,6 +20,24 @@ A Breakout clone with DXBall aspirations. Can't Contain Me is a game developed in QB64. The pieces are trying to escape your screen and th... +**[Cloned Shades](cloned-shades/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md) + +A clone of 'Shades' which was originally developed by UOVO. + +**[Curve Smoother](curve-smoother/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [curve](curve.md), [interpolation](interpolation.md) + +This program demonstrates (i) linear interpolation to create a curve between points, (ii) a relax... + +**[Frostbite](frostbite/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [frostbite](frostbite.md) + +A clone of Frostbite for the Atari 2600, originally designed by Steve Cartwright and published by... + **[LightsOn](lightson/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [lights](lights.md) @@ -61,3 +79,9 @@ Fly across the universe on a quest for survival against alien enemy forces. Made [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [tic tac toe rings](tic-tac-toe-rings.md) Tic Tac Toe Rings by Fellippe Heitor. + +**[TUI](tui/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [interface](interface.md), [tui](tui.md) + +Text User Interface for QB64 projects diff --git a/samples/fibonacci-variations/index.md b/samples/fibonacci-variations/index.md index 9ce33f6..c137547 100644 --- a/samples/fibonacci-variations/index.md +++ b/samples/fibonacci-variations/index.md @@ -23,7 +23,7 @@ The Fibonacci sequence is "seeded" with the golden ratio, but what if we change ![ss2.png](img/ss2.png) -🔗 [fibonacci](../fibonacci.md) +🔗 [fibonacci](../fibonacci.md), [spiral](../spiral.md) Reference: [qb64forum](https://qb64forum.alephc.xyz/index.php?topic=3370.0) diff --git a/samples/fibonacci.md b/samples/fibonacci.md index c9ef8c1..e44d248 100644 --- a/samples/fibonacci.md +++ b/samples/fibonacci.md @@ -4,6 +4,6 @@ **[Fibonacci Variations](fibonacci-variations/index.md)** -[🐝 STxAxTIC](stxaxtic.md) 🔗 [fibonacci](fibonacci.md) +[🐝 STxAxTIC](stxaxtic.md) 🔗 [fibonacci](fibonacci.md), [spiral](spiral.md) The Fibonacci sequence is "seeded" with the golden ratio, but what if we change that? diff --git a/samples/filled-circles-and-ellipses/index.md b/samples/filled-circles-and-ellipses/index.md index 5cc2d8b..cdea46b 100644 --- a/samples/filled-circles-and-ellipses/index.md +++ b/samples/filled-circles-and-ellipses/index.md @@ -24,9 +24,9 @@ These works have been optimized for speed and respect for alpha transparency. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "ellipses.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/filled-circles-and-ellipses/src/ellipses.bas) -* [RUN "ellipses.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/filled-circles-and-ellipses/src/ellipses.bas) -* [PLAY "ellipses.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/filled-circles-and-ellipses/src/ellipses.bas) +* [LOAD "ellipses.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/filled-circles-and-ellipses/src/ellipses.bas) +* [RUN "ellipses.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/filled-circles-and-ellipses/src/ellipses.bas) +* [PLAY "ellipses.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/filled-circles-and-ellipses/src/ellipses.bas) ### File(s) diff --git a/samples/finance.md b/samples/finance.md new file mode 100644 index 0000000..e0937c3 --- /dev/null +++ b/samples/finance.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: FINANCE + +**[Loan Amortization](loan-amortization/index.md)** + +[🐝 Alan Zeichick](alan-zeichick.md) 🔗 [finance](finance.md), [dos world](dos-world.md) + +' Loan amortization program ' Alan Zeichick, March 16, 1993 ' Copyright (c) 1993 DOS Resource Gui... diff --git a/samples/fire-13/img/screenshot.png b/samples/fire-13/img/screenshot.png new file mode 100644 index 0000000..0825f77 Binary files /dev/null and b/samples/fire-13/img/screenshot.png differ diff --git a/samples/fire-13/index.md b/samples/fire-13/index.md new file mode 100644 index 0000000..cb9317b --- /dev/null +++ b/samples/fire-13/index.md @@ -0,0 +1,25 @@ +[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: FIRE 13 + +![screenshot.png](img/screenshot.png) + +### Description + +```text +Fire dominates the lower screen. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "fire.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/fire-13/src/fire.bas) +* [RUN "fire.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/fire-13/src/fire.bas) +* [PLAY "fire.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/fire-13/src/fire.bas) + +### File(s) + +* [fire.bas](src/fire.bas) + +🔗 [fire](../fire.md), [graphics](../graphics.md) diff --git a/samples/fire-13/src/fire.bas b/samples/fire-13/src/fire.bas new file mode 100644 index 0000000..dff7eb0 --- /dev/null +++ b/samples/fire-13/src/fire.bas @@ -0,0 +1,124 @@ +$NoPrefix +DefLng A-Z +$Resize:Smooth + +Screen 13 +FullScreen SquarePixels , Smooth + +Randomize Timer + +Dim Shared Buffer%(32001) +Buffer%(0) = 320 * 8 +Buffer%(1) = 200 + +b = 0 +g = 0 +For a = 150 To 100 Step -1 + r = a / 5 + set_pal a, b, g, r +Next + +For a = 100 To 0 Step -1 + g = g - 1 + b = b - 1 + r = r - 1 + set_pal a, b, g, r +Next + +g = 0 +For a = 150 To 255 Step 1 + + b = 0 + g = g + 1 + r = a / 5 + If (g > 62) Then + g = 62 + End If + set_pal a, b, g, r +Next + +Do + l = l + 1 + fire + update_screen + + If (l > 1) Then + If b = 0 Then + a = a + 1 + End If + If b = 1 Then + a = a - 1 + End If + set_random_pixels a, 255 + If (a < 50) Then + b = 0 + End If + If (a > 200) Then + b = 1 + End If + l = 0 + End If + +Loop Until InKey$ <> "" + +System 0 + + +Sub fire + For y = 200 To 1 Step -1 + For x = 1 To 320 Step 1 + med_col = 0 + med_col = med_col + get_pixel(x - 1, y + 1) + med_col = med_col + get_pixel(x + 1, y + 1) + med_col = med_col + get_pixel(x, y + 1) + med_col = med_col + get_pixel(x, y) + med_col = med_col + Rnd * 3 + med_col = med_col / 4.04 + set_pixel x, y, med_col + Next + Next +End Sub + +Sub set_random_pixels (nr, col) + row = 201 + For x = 1 To 320 + set_pixel x, row, 0 + Next + For a = 0 To nr + x = Rnd * 320 + set_pixel x, row, col + set_pixel x + 1, row, col + set_pixel x - 1, row, col + Next +End Sub + +Sub update_screen + Put (0, 0), Buffer%(), PSet +End Sub + +Sub set_pixel (x%, y%, col%) + Def Seg = VarSeg(Buffer%(32001)) + Poke 320& * y% + x% + 4, col% + Def Seg +End Sub + +Function get_pixel (x%, y%) + Def Seg = VarSeg(Buffer%(32001)) + get_pixel = Peek(320& * y% + x% + 4) + Def Seg +End Function + +Sub set_pal (p, b, g, r) + b = CInt(b) + g = CInt(g) + r = CInt(r) + + If (b > 62) Then b = 62 + If (g > 62) Then g = 62 + If (r > 62) Then r = 62 + If (b < 0) Then b = 0 + If (g < 0) Then g = 0 + If (r < 0) Then r = 0 + Palette p, 65536 * b + 256 * g + r +End Sub + diff --git a/samples/fire-demo/img/firedemo.png b/samples/fire-demo/img/firedemo.png new file mode 100644 index 0000000..9f9fb30 Binary files /dev/null and b/samples/fire-demo/img/firedemo.png differ diff --git a/samples/fire-demo/index.md b/samples/fire-demo/index.md new file mode 100644 index 0000000..dc0f1bb --- /dev/null +++ b/samples/fire-demo/index.md @@ -0,0 +1,31 @@ +[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: FIRE DEMO + +![firedemo.png](img/firedemo.png) + +### Author + +[🐝 harixxx](../harixxx.md) + +### Description + +```text +_Title "FIRE Demo v1.0" +'-----| by harixxx +'-----| 6-16-2010 +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "firedemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/fire-demo/src/firedemo.bas) +* [RUN "firedemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/fire-demo/src/firedemo.bas) +* [PLAY "firedemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/fire-demo/src/firedemo.bas) + +### File(s) + +* [firedemo.bas](src/firedemo.bas) + +🔗 [graphics](../graphics.md), [fire](../fire.md) diff --git a/samples/fire-demo/src/firedemo.bas b/samples/fire-demo/src/firedemo.bas new file mode 100644 index 0000000..7e92d5b --- /dev/null +++ b/samples/fire-demo/src/firedemo.bas @@ -0,0 +1,66 @@ +_Title "FIRE Demo v1.0" +'-----| by harixxx +'-----| 6-16-2010 + +Const mx = 108 +Const my = 44 +Const sx = 3 +Const sy = 6 +Const ms$ = "QB64 : FIRE Demo v1.0 - Created by harixxx" + +sc = -mx +lt = Len(ms$) * 8 +Dim ct(lt, 14), fl(mx, my) + +Screen _NewImage(640, 240, 256), , 1, 0 + +Print ms$ +For i = 0 To lt - 1 + For j = 0 To 13 + If Point(i, j) > 0 Then + ct(i, j) = 64 + ct(i, j + 1) = -64 + ct(i + 1, j + 1) = -64 + End If +Next j, i + +Screen _NewImage(320, 240, 256), , 1, 0 +For i = 0 To 63 + SetPal i, i, 0, 0 + SetPal i + 64, 63, i, 0 + SetPal i + 128, 63, 63, i +Next + +'_FULLSCREEN +_Limit 10 +Do + ReDim fm(mx, my) + sc = sc + .5 + If sc > lt Then sc = -mx + For x = 0 To mx + For y = 0 To 14 + cx = Int(x + sc) + If cx >= 0 And cx <= lt Then fm(x, y + 16) = ct(cx, y) + Next y, x + For x = 1 To mx - 1 + fl(x, my) = Rnd * 2250 - 1000 + For y = my - 1 To 0 Step -1 + fl(x, y) = (fl(x - 1, y) + fl(x, y + 1) + fl(x + 1, y + 1)) \ 3 - 4 + c = fl(x, y) + c = (c - 2) * -(c < 64) + c * -(c > 63) + fm(x, y) + c = 191 * -(c > 191) + c * -(c < 192) + If y < my - 4 Then Line (x * sx - sx, y * sy)-Step(sx, sy), c * -(c > 0), BF + Next y, x + _Delay .03 + PCopy 1, 0 +Loop Until InKey$ > "" +Sleep +System + +Sub SetPal (n, r, g, b) + Out 968, n + Out 969, r + Out 969, g + Out 969, b +END SUB + diff --git a/samples/fire.md b/samples/fire.md index 37c33fb..9c32976 100644 --- a/samples/fire.md +++ b/samples/fire.md @@ -2,8 +2,14 @@ ## SAMPLES: FIRE -**[Fire](fire/index.md)** +**[Fire 13](fire-13/index.md)** [🐝 *missing*](author-missing.md) 🔗 [fire](fire.md), [graphics](graphics.md) Fire dominates the lower screen. + +**[Fire Demo](fire-demo/index.md)** + +[🐝 harixxx](harixxx.md) 🔗 [graphics](graphics.md), [fire](fire.md) + +_Title "FIRE Demo v1.0" '-----| by harixxx '-----| 6-16-2010 diff --git a/samples/flappy-bird.md b/samples/flappy-bird.md new file mode 100644 index 0000000..2b2f7ee --- /dev/null +++ b/samples/flappy-bird.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: FLAPPY BIRD + +**[Flappy Bird](flappy-bird/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [flappy bird](flappy-bird.md) + +' ----------------------------------------------- ' QB64 FlappyBird Clone by Terry Ritchie 02/28/... diff --git a/samples/flappy-bird/img/screenshot.png b/samples/flappy-bird/img/screenshot.png new file mode 100644 index 0000000..15a8d52 Binary files /dev/null and b/samples/flappy-bird/img/screenshot.png differ diff --git a/samples/flappy-bird/index.md b/samples/flappy-bird/index.md new file mode 100644 index 0000000..93c6e3b --- /dev/null +++ b/samples/flappy-bird/index.md @@ -0,0 +1,31 @@ +[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: FLAPPY BIRD + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Terry Ritchie](../terry-ritchie.md) + +### Description + +```text +' ----------------------------------------------- +' QB64 FlappyBird Clone by Terry Ritchie 02/28/14 +' +' This program was created to accompany the QB64 +' Game Programming course located at: +' http://www.qb64sourcecode.com +' +' You may not sell or distribute this game! It +' was made for instructional purposes only. +' ----------------------------------------------- +``` + +### File(s) + +* [fbird.bas](src/fbird.bas) +* [fbird.zip](src/fbird.zip) + +🔗 [game](../game.md), [flappy bird](../flappy-bird.md) diff --git a/samples/flappy-bird/src/fbird.bas b/samples/flappy-bird/src/fbird.bas new file mode 100644 index 0000000..988f6dd --- /dev/null +++ b/samples/flappy-bird/src/fbird.bas @@ -0,0 +1,783 @@ +' ----------------------------------------------- +' QB64 FlappyBird Clone by Terry Ritchie 02/28/14 +' +' This program was created to accompany the QB64 +' Game Programming course located at: +' http://www.qb64sourcecode.com +' +' You may not sell or distribute this game! It +' was made for instructional purposes only. +' ----------------------------------------------- + +'-------------------------------- +'- Variable declaration section - +'-------------------------------- + +CONST FALSE = 0 ' boolean: truth 0 +CONST TRUE = NOT FALSE ' boolean: truth -1 +CONST LARGE = 0 ' large numbers +CONST SMALL = 1 ' small numbers (not used in current version of game) +CONST GOLD = 0 ' gold medal +CONST SILVER = 1 ' silver medal +CONST LIGHT = 0 ' light colored gold/silver medal +CONST DARK = 1 ' dark colored gold/silver medal + +TYPE PARALLAX ' parallax scenery settings + image AS LONG ' scene image + x AS INTEGER ' scene image x location + y AS INTEGER ' scene image y location + frame AS INTEGER ' current parallax frame + fmax AS INTEGER ' maximum parallax frames allowed +END TYPE + +TYPE INFLIGHT ' flappy bird inflight characterisitcs + y AS SINGLE ' flappy bird y location + yvel AS SINGLE ' flappy bird y velocity + flap AS INTEGER ' wing flap position + flapframe AS INTEGER ' wing flap frame counter + angle AS INTEGER ' angle of flappy bird +END TYPE + +TYPE PIPE ' pipe characteristics + x AS INTEGER ' pipe x location + y AS INTEGER ' pipe y location +END TYPE + +DIM Pipes(3) AS PIPE ' define 3 moving sets of pipes +DIM Pipe&(1) ' pipe images 0=top 1=bottom +DIM PipeImage& ' all three pipes drawn image +DIM Birdie AS INFLIGHT ' bird flight characteristics +DIM Scenery(4) AS PARALLAX ' define 4 moving scenes in parallax +DIM Fbird&(8, 3) ' flapping bird images +DIM Num&(9, 1) ' big and small numeral images +DIM Plaque& ' medal/score plaque +DIM FlappyBird& ' Flappy Bird title image +DIM GameOver& ' Game Over image +DIM GetReady& ' Get Ready image +DIM Medal&(1, 1) ' gold/silver medal images +DIM Finger& ' tap finger image +DIM ScoreButton& ' score button image +DIM ShareButton& ' share button image +DIM StartButton& ' start button image +DIM OKButton& ' OK button image +DIM RateButton& ' RATE button image +DIM MenuButton& ' MENU button image +DIM PlayButton& ' PLAY [|>] button image +DIM PauseButton& ' PAUSE [||] button image +DIM HazardBar& ' Hazard bar parallax image +DIM Clouds& ' Clouds parallax image +DIM City& ' Cityscape parallax image +DIM Bushes& ' Bushes parallax image +DIM New& ' red NEW image +DIM Clean& ' clean playing screen image +DIM HitBird% ' boolean: TRUE if bird hits something +DIM HighScore% ' high score +DIM Score% ' current score +DIM Paused% ' boolean: TRUE if game paused +DIM Ding& ' ding sound +DIM Flap& ' flapping sound +DIM Smack& ' bird smack sound +DIM Latch% ' boolean: TRUE if mouse button held down +DIM WinX% ' stops player from exiting program at will + +'------------------------ +'- Main Program Section - +'------------------------ + +SCREEN _NEWIMAGE(432, 768, 32) ' create 432x768 game screen +_TITLE "FlappyBird" ' give window a title +CLS ' clear the screen +_SCREENMOVE _MIDDLE ' move window to center of desktop +WinX% = _EXIT ' program will handle all window close requests +LOADASSETS ' set/load game graphics/sounds/settings +Birdie.flap = 1 ' set initial wing position of bird +DO ' BEGIN MAIN GAME LOOP + _LIMIT 60 ' 60 frames per second + UPDATESCENERY ' update parallaxing scenery + _PUTIMAGE (40, 265), FlappyBird& ' place game title on screen + _PUTIMAGE (350, 265), Fbird&(2, FLAPTHEBIRD%) ' place flapping bird on screen + IF BUTTON%(64, 535, StartButton&) THEN PLAYGAME ' if start button pressed play game + IF BUTTON%(248, 535, ScoreButton&) THEN SHOWSCORE ' if score button pressed show scores + IF BUTTON%(248, 480, RateButton&) THEN RATEGAME ' if rate button pressed bring up browser + _DISPLAY ' update screen with changes +LOOP UNTIL _KEYDOWN(27) OR _EXIT ' END MAIN GAME LOOP when ESC pressed or window closed +CLEANUP ' clean the computer's RAM before leaving +SYSTEM ' return to Windows desktop + +'------------------------------------- +'- Subroutines and Functions section - +'------------------------------------- + +'---------------------------------------------------------------------------------------------------------------------- + +FUNCTION FLAPTHEBIRD% () + +'* +'* Returns the next index value used in Fbird&() to animate the bird's +'* flapping wings. +'* + +SHARED Birdie AS INFLIGHT + +Birdie.flapframe = Birdie.flapframe + 1 ' increment frame counter +IF Birdie.flapframe = 4 THEN ' hit limit? + Birdie.flapframe = 0 ' yes, reset frame counter + Birdie.flap = Birdie.flap + 1 ' increment flap counter + IF Birdie.flap = 4 THEN Birdie.flap = 1 ' reset flap counter when limit hit +END IF +FLAPTHEBIRD% = Birdie.flap ' return next index value + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB MOVEPIPES () + +'* +'* Creates and moves the pipe images across the screen. +'* + +SHARED Pipes() AS PIPE, Pipe&(), PipeImage&, Paused%, Score%, Ding& + +DIM p% ' counter indicating which pipe being worked on + +_DEST PipeImage& ' work on this image +CLS , _RGBA32(0, 0, 0, 0) ' clear image with transparent black +_DEST 0 ' back to work on screen +DO ' BEGIN PIPE LOOP + p% = p% + 1 ' increment pipe counter + IF NOT Paused% THEN ' is game paused? + Pipes(p%).x = Pipes(p%).x - 3 ' no, move pipe to the left + IF Pipes(p%).x < -250 THEN ' hit lower limit? + Pipes(p%).x = 500 ' yes, move pipe all the way right + Pipes(p%).y = -(INT(RND(1) * 384) + 12) ' generate random pipe height position + END IF + IF Pipes(p%).x = 101 THEN ' is pipe crossing bird location? + _SNDPLAY Ding& ' play ding sound + Score% = Score% + 1 ' increment player score + END IF + END IF + IF Pipes(p%).x > -78 AND Pipes(p%).x < 432 THEN ' is pipe currently seen on screen? + _PUTIMAGE (Pipes(p%).x, Pipes(p%).y), Pipe&(0), PipeImage& ' place top pipe + _PUTIMAGE (Pipes(p%).x, Pipes(p%).y + 576), Pipe&(1), PipeImage& ' place bottom pipe + END IF +LOOP UNTIL p% = 3 ' END PIPE LOOP when all pipes moved +_PUTIMAGE (0, 0), PipeImage& ' place pipe image on screen + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB FLYBIRDIE () + +'* +'* Controls the flight of bird on screen. +'* + +SHARED Birdie AS INFLIGHT, Fbird&(), Paused%, Flap&, HitBird%, Latch%, Smack& + +DIM b% ' boolean: TRUE if left mouse button pressed +DIM Angle% ' angle of bird in flight + +IF NOT Paused% THEN ' is game paused? + WHILE _MOUSEINPUT: WEND ' no, get latest mouse information + b% = _MOUSEBUTTON(1) ' get left mouse button status + IF NOT b% THEN Latch% = FALSE ' release latch if button let go + IF NOT HitBird% THEN ' has bird hit something? + IF NOT Latch% THEN ' no, has left button been release? + IF b% THEN ' yes, was left button pressed? + Birdie.yvel = -8 ' yes, reset bird y velocity + _SNDPLAY Flap& ' play flap sound + Latch% = TRUE ' remember mouse button pressed + END IF + END IF + END IF + Birdie.yvel = Birdie.yvel + .5 ' bleed off some bird y velocity + Birdie.y = Birdie.y + Birdie.yvel ' add velocity to bird's y direction + IF NOT HitBird% THEN ' has bird hit something? + IF Birdie.y < -6 OR Birdie.y > 549 THEN ' no, has bird hit top/bottom of screen? + HitBird% = TRUE ' yes, remeber bird hit something + _SNDPLAY Smack& ' play smack sound + END IF + END IF + IF Birdie.yvel < 0 THEN ' is bird heading upward? + Birdie.angle = 1 ' yes, set angle of bird accordingly + ELSE + Angle% = INT(Birdie.yvel * .5) + 1 ' calculate angle according to bird velocity + IF Angle% > 8 THEN Angle% = 8 ' keep angle within limits + Birdie.angle = Angle% ' set bird angle + END IF +END IF +_PUTIMAGE (100, Birdie.y), Fbird&(Birdie.angle, FLAPTHEBIRD%) ' place bird on screen + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB UPDATESCORE () + +'* +'* Displays player's score on screen. +'* + +SHARED Num&(), Score% + +DIM s$ ' score in string format +DIM w% ' width of score string +DIM x% ' x location of score digits +DIM p% ' position counter + +s$ = LTRIM$(RTRIM$(STR$(Score%))) ' convert score to string +w% = LEN(s$) * 23 ' calculate width of score +x% = (432 - w%) \ 2 ' calculate x position of score +FOR p% = 1 TO LEN(s$) ' cycle through each position in score string + _PUTIMAGE (x%, 100), Num&(ASC(MID$(s$, p%, 1)) - 48, LARGE) ' place score digit on screen + x% = x% + 23 ' move to next digit position +NEXT p% + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB READY () + +'* +'* displays instructions to the player and waits for player to start game. +'* + +SHARED Fbird&(), Finger&, GetReady& + +DIM b% ' boolean: TRUE if left mouse button pressed + +DO ' BEGIN READY LOOP + _LIMIT 60 ' 60 frames per second + UPDATESCENERY ' move parallax scenery + _PUTIMAGE (180, 350), Finger& ' place finger instructions on screen + _PUTIMAGE (85, 225), GetReady& ' place get ready image on screen + _PUTIMAGE (100, 375), Fbird&(2, FLAPTHEBIRD%) ' place bird on screen + UPDATESCORE ' place score on screen + _DISPLAY ' update screen with changes + WHILE _MOUSEINPUT: WEND ' get latest mouse information + b% = _MOUSEBUTTON(1) ' get status of left mouse button + IF _EXIT THEN CLEANUP: SYSTEM ' leave game if user closes game window +LOOP UNTIL b% ' END READY LOOP when left button pressed +_DELAY .2 ' slight delay to allow mouse button release + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB PLAYGAME () + +'* +'* Allows player to play the game. +'* + +SHARED Pipes() AS PIPE, Birdie AS INFLIGHT, PauseButton&, PlayButton&, Paused%, HitBird%, Score% + +RANDOMIZE TIMER ' seed random number generator +Score% = 0 ' reset player score +Birdie.y = 0 ' reset bird y location +Birdie.yvel = 0 ' reset bird y velocity +Birdie.flap = 1 ' reset bird wing flap index +Pipes(1).x = 500 ' reset position of first pipe +Pipes(2).x = 749 ' reset position of second pipe +Pipes(3).x = 998 ' reset position of third pipe +Pipes(1).y = -(INT(RND(1) * 384) + 12) ' calculate random y position of pipe 1 +Pipes(2).y = -(INT(RND(1) * 384) + 12) ' calculate random y position of pipe 2 +Pipes(3).y = -(INT(RND(1) * 384) + 12) ' calculate random y position of pipe 3 +READY ' display instructions to player +DO ' BEGIN GAME PLAY LOOP + _LIMIT 60 ' 60 frames per second + UPDATESCENERY ' move parallax scenery + MOVEPIPES ' move pipes + UPDATESCORE ' display player score + FLYBIRDIE ' move and display bird + CHECKFORHIT ' check for bird hits + IF NOT Paused% THEN ' is game paused? + IF BUTTON%(30, 100, PauseButton&) THEN ' no, was pause button pressed? + Paused% = TRUE ' yes, place game in pause state + END IF + ELSE ' no, game is not paused + IF BUTTON%(30, 100, PlayButton&) THEN ' was play button pressed? + Paused% = FALSE ' yes, take game out of pause state + END IF + END IF + _DISPLAY ' update screen with changes + IF _EXIT THEN CLEANUP: SYSTEM ' leave game if user closes game window +LOOP UNTIL HitBird% ' END GAME PLAY LOOP if bird hits something +DO ' BEGIN BIRD DROPPING LOOP + _LIMIT 60 ' 60 frames per second + Paused% = TRUE ' place game in paused state + UPDATESCENERY ' draw parallax scenery + MOVEPIPES ' draw pipes + Paused% = FALSE ' take game out of pause state + FLYBIRDIE ' move bird on screen + _DISPLAY ' update screen with changes + IF _EXIT THEN CLEANUP: SYSTEM ' leave game if user closes game window +LOOP UNTIL Birdie.y >= 546 ' END BIRD DROPPING LOOP when bird hits ground +SHOWSCORE ' display player's score plaque +HitBird% = FALSE ' reset bird hit indicator + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB CHECKFORHIT () + +'* +'* Detects if bird hits a pipe. +'* + +SHARED Pipes() AS PIPE, Birdie AS INFLIGHT, HitBird%, Smack& + +DIM p% ' pipe counter + +FOR p% = 1 TO 3 ' cycle through all pipe positions + IF Pipes(p%).x <= 153 AND Pipes(p%).x >= 22 THEN ' is pipe in bird territory? + IF BOXCOLLISION(105, Birdie.y + 6, 43, 41, Pipes(p%).x, Pipes(p%).y, 78, 432) THEN ' collision? + HitBird% = TRUE ' yes, remember bird hit pipe + END IF + IF BOXCOLLISION(105, Birdie.y + 6, 43, 41, Pipes(p%).x, Pipes(p%).y + 576, 78, 432) THEN ' collision? + HitBird% = TRUE ' yes, remember bird hit pipe + END IF + END IF +NEXT p% +IF HitBird% THEN _SNDPLAY Smack& ' play smack sound if bird hit pipe + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB RATEGAME () + +'* +'* Allows player to rate game. +'* + +SHELL "http://www.qb64.net/forum/index.php?topic=11706.0" ' go to QB64 web site forum area for flappy bird + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB SHOWSCORE () + +'* +'* Display's current and high scores on score plaque +'* + +SHARED Fbird&(), Num&(), Medal&(), FlappyBird&, GameOver&, Plaque&, OKButton&, ShareButton& +SHARED HitBird%, HighScore%, Score%, New& + +DIM Ok% ' boolean: TRUE if OK button pressed +DIM Scores%(1) ' current and high scores +DIM sc% ' current score being drawn +DIM x% ' x location of score digits +DIM p% ' digit position counter +DIM ShowNew% ' boolean: TRUE if score is a new high score +DIM s$ ' score in string format + +IF Score% > HighScore% THEN ' is this a new high score? + OPEN "fbird.sco" FOR OUTPUT AS #1 ' yes, open score file + PRINT #1, Score% ' save new high score + CLOSE #1 ' close score file + HighScore% = Score% ' remember new high score + ShowNew% = TRUE ' remember this is a new high score +END IF +Scores%(0) = Score% ' place score in array +Scores%(1) = HighScore% ' place high score in array +Ok% = FALSE ' reset OK button status indicator +DO ' BEGIN SCORE LOOP + _LIMIT 60 ' 60 frames per second + IF HitBird% THEN ' did bird hit something? + _PUTIMAGE (75, 200), GameOver& ' yes, place game over image on screen + ELSE ' no, bird did not hit anything + UPDATESCENERY ' move parallax scenery + _PUTIMAGE (40, 200), FlappyBird& ' place flappy bird title on screen + _PUTIMAGE (350, 200), Fbird&(2, FLAPTHEBIRD%) ' place flapping bird on screen + END IF + _PUTIMAGE (46, 295), Plaque& ' place plaque on screen + SELECT CASE HighScore% ' what is range of high score? + CASE 25 TO 49 ' from 25 to 49 + _PUTIMAGE (85, 360), Medal&(SILVER, LIGHT) ' display a light silver medal + CASE 50 TO 99 ' from 50 to 99 + _PUTIMAGE (85, 360), Medal&(SILVER, DARK) ' display a dark silver medal + CASE 100 TO 199 ' from 100 to 199 + _PUTIMAGE (85, 360), Medal&(GOLD, LIGHT) ' display a light gold medal + CASE IS > 199 ' from 200 and beyond + _PUTIMAGE (85, 360), Medal&(GOLD, DARK) ' display a dark gold medal + END SELECT + FOR sc% = 0 TO 1 ' cycle through both scores + s$ = LTRIM$(RTRIM$(STR$(Scores%(sc%)))) ' convert score to string + x% = 354 - LEN(s$) * 23 ' calculate position of score digit + FOR p% = 1 TO LEN(s$) ' cycle through score string + _PUTIMAGE (x%, 346 + sc% * 64), Num&(ASC(MID$(s$, p%, 1)) - 48, LARGE) ' place digit on plaque + x% = x% + 23 ' increment digit position + NEXT p% + NEXT sc% + IF ShowNew% THEN _PUTIMAGE (250, 382), New& ' display red new image if new high score + IF BUTTON%(64, 535, OKButton&) THEN Ok% = TRUE ' remember if OK button was pressed + IF BUTTON%(248, 535, ShareButton&) THEN ' was share button pressed? + SHAREPROGRAM ' yes, share program with others + UPDATESCENERY ' draw parallax scenery + MOVEPIPES ' draw pipes + END IF + _DISPLAY ' update screen with changes + IF _EXIT THEN CLEANUP: SYSTEM ' leave game if user closes game window +LOOP UNTIL Ok% ' END SCORE LOOP when OK button pressed + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB SHAREPROGRAM () + +'* +'* Allows player to share program with others +'* + +SHARED Fbird&(), FlappyBird&, OKButton& + +DIM Message& ' composed message to player's friend(s) +DIM Ok% ' boolean: TRUE if OK button pressed + +Message& = _NEWIMAGE(339, 174, 32) ' create image to hold message to player +_CLIPBOARD$ = "I just discovered a great game! You can download it here: http:\\www.qb64sourcecode.com\fbird.exe" +_PRINTMODE _KEEPBACKGROUND ' printed text will save background +LINE (58, 307)-(372, 453), _RGB32(219, 218, 150), BF ' clear plaque image +COLOR _RGB32(210, 170, 79) ' compose message to player on plaque +_PRINTSTRING (66, 316), "The following message has been copied" +COLOR _RGB32(82, 55, 71) +_PRINTSTRING (65, 315), "The following message has been copied" +COLOR _RGB32(210, 170, 79) +_PRINTSTRING (66, 331), "to your computer's clipboard:" +COLOR _RGB32(82, 55, 71) +_PRINTSTRING (65, 330), "to your computer's clipboard:" +COLOR _RGB32(210, 170, 79) +_PRINTSTRING (66, 351), "'I just discovered a great game! You" +COLOR _RGB32(82, 55, 71) +_PRINTSTRING (65, 350), "'I just discovered a great game! You" +COLOR _RGB32(210, 170, 79) +_PRINTSTRING (66, 366), "can download it here:" +COLOR _RGB32(82, 55, 71) +_PRINTSTRING (65, 365), "can download it here:" +COLOR _RGB32(210, 170, 79) +_PRINTSTRING (66, 381), "www.qb64sourcecode.com\fbird.exe'" +COLOR _RGB32(82, 55, 71) +_PRINTSTRING (65, 380), "www.qb64sourcecode.com\fbird.exe'" +COLOR _RGB32(210, 170, 79) +_PRINTSTRING (66, 401), "Create an email for your friends and" +COLOR _RGB32(82, 55, 71) +_PRINTSTRING (65, 400), "Create an email for your friends and" +COLOR _RGB32(210, 170, 79) +_PRINTSTRING (66, 416), "paste this message into it! Go ahead," +COLOR _RGB32(82, 55, 71) +_PRINTSTRING (65, 415), "paste this message into it! Go ahead," +COLOR _RGB32(210, 170, 79) +_PRINTSTRING (66, 431), "do it now before you change your mind!" +COLOR _RGB32(82, 55, 71) +_PRINTSTRING (65, 430), "do it now before you change your mind!" +_PUTIMAGE , _DEST, Message&, (46, 295)-(384, 468) ' place message in image +DO ' BEGIN SHARE LOOP + _LIMIT 60 ' 60 frames per second + UPDATESCENERY ' move parallax scenery + _PUTIMAGE (40, 200), FlappyBird& ' place flappy bird title on screen + _PUTIMAGE (350, 200), Fbird&(2, FLAPTHEBIRD%) ' place flapping bird on screen + _PUTIMAGE (46, 295), Message& ' place message on plaque + IF BUTTON%(156, 535, OKButton&) THEN Ok% = TRUE ' remeber if OK button pressed + _DISPLAY ' update screen with changes + IF _EXIT THEN CLEANUP: SYSTEM ' leave game if user closes game window +LOOP UNTIL Ok% ' END SHRE LOOP when OK button pressed +_FREEIMAGE Message& ' message image no longer needed + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +FUNCTION BUTTON% (xpos%, ypos%, Image&) + +'* +'* Creates a button on the screen the player can click with the mouse button. +'* +'* xpos% - x coordinate position of button on screen +'* ypos% - y coordinate position of button on screen +'* Image& - button image +'* +'* Returns: boolean: TRUE if button pressed +'* FALSE if button not pressed +'* + +DIM x% ' current mouse x coordinate +DIM y% ' current mouse y coordinate +DIM b% ' boolean: TRUE if left mouse button pressed + +_PUTIMAGE (xpos%, ypos%), Image& ' place button image on the screen +WHILE _MOUSEINPUT: WEND ' get latest mouse information +x% = _MOUSEX ' get current mouse x coordinate +y% = _MOUSEY ' get current mouse y coordinate +b% = _MOUSEBUTTON(1) +IF b% THEN ' is left mouse button pressed? + IF x% >= xpos% THEN ' yes, is mouse x within lower limit of button? + IF x% <= xpos% + _WIDTH(Image&) THEN ' yes, is mouse x within upper limit of button? + IF y% >= ypos% THEN ' yes, is mouse y within lower limit of button? + IF y% <= ypos% + _HEIGHT(Image&) THEN ' yes, is mouse y within upper limit of button? + BUTTON% = TRUE ' yes, remember that button was clicked on + _DELAY .2 ' slight delay to allow button to release + END IF + END IF + END IF + END IF +END IF + +END FUNCTION + +'---------------------------------------------------------------------------------------------------------------------- + +SUB UPDATESCENERY () + +'* +'* Updates the moving parallax scenery +'* + +SHARED Scenery() AS PARALLAX, Clean&, HazardBar&, Paused% + +DIM c% ' scenery index indicator + +_PUTIMAGE , Clean& ' clear screen with clean image +DO ' BEGIN SCENERY LOOP + c% = c% + 1 ' increment index value + IF NOT Paused% THEN ' is game in paused state? + Scenery(c%).frame = Scenery(c%).frame + 1 ' no, update frame counter of current scenery + IF Scenery(c%).frame = Scenery(c%).fmax THEN ' frame counter hit limit? + Scenery(c%).frame = 0 ' yes, reset frame counter + Scenery(c%).x = Scenery(c%).x - 1 ' move scenery 1 pixel to left + IF Scenery(c%).x = -432 THEN ' scenery hit lower limit? + Scenery(c%).x = 0 ' yes, reset scenery to start position + END IF + END IF + END IF + _PUTIMAGE (Scenery(c%).x, Scenery(c%).y), Scenery(c%).image ' place current scenery on screen +LOOP UNTIL c% = 3 ' END SCENERY LOOP when all scenery updated +IF NOT Paused% THEN ' is game in paused state? + Scenery(4).x = Scenery(4).x - 3 ' no, move hazard bar 3 pixels to left + IF Scenery(4).x = -21 THEN Scenery(4).x = 0 ' reset to start position if lower limit hit +END IF +_PUTIMAGE (Scenery(4).x, Scenery(4).y), HazardBar& ' place hazard bar on screen + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +SUB LOADASSETS () + +'* +'* Loads game graphics, sounds and initial settings. +'* + +SHARED Scenery() AS PARALLAX, Birdie AS INFLIGHT, Pipes() AS PIPE, Pipe&(), Fbird&() +SHARED Num&(), Medal&(), Plaque&, FlappyBird&, GameOver&, GetReady&, Finger& +SHARED ScoreButton&, ShareButton&, StartButton&, OKButton&, RateButton&, MenuButton& +SHARED PlayButton&, PauseButton&, HazardBar&, Clouds&, City&, Bushes&, New&, Clean& +SHARED HighScore%, PipeImage&, Ding&, Flap&, Smack& + +DIM Sheet& ' sprite sheet image +DIM x% ' generic counter +DIM y% ' generic counter +DIM PipeTop& ' temporary top of pipe image +DIM PipeTube& ' temporary pipe tube image + +Ding& = _SNDOPEN("fbding.ogg", "VOL,SYNC") ' load game sounds +Flap& = _SNDOPEN("fbflap.ogg", "VOL,SYNC") +Smack& = _SNDOPEN("fbsmack.ogg", "VOL,SYNC") +Sheet& = _LOADIMAGE("fbsheet.png", 32) ' load sprite sheet +FOR y% = 0 TO 2 ' cycle through bird image rows + FOR x% = 0 TO 7 ' cycle through bird image columns + Fbird&(x% + 1, y% + 1) = _NEWIMAGE(53, 53, 32) ' create image holder then get image + _PUTIMAGE , Sheet&, Fbird&(x% + 1, y% + 1), (x% * 53, y% * 53)-(x% * 53 + 52, y% * 53 + 52) + NEXT x% +NEXT y% +FOR x% = 0 TO 9 ' cycle trough 9 numeral images + Num&(x%, 0) = _NEWIMAGE(21, 30, 32) ' create image holder for big + Num&(x%, 1) = _NEWIMAGE(18, 21, 32) ' create image holder for small + _PUTIMAGE , Sheet&, Num&(x%, 0), (x% * 21, 159)-(x% * 21 + 20, 188) ' get images + _PUTIMAGE , Sheet&, Num&(x%, 1), (x% * 18 + 210, 159)-(x% * 18 + 227, 179) +NEXT x% +Plaque& = _NEWIMAGE(339, 174, 32) ' define remaining image sizes +FlappyBird& = _NEWIMAGE(288, 66, 32) +GameOver& = _NEWIMAGE(282, 57, 32) +GetReady& = _NEWIMAGE(261, 66, 32) +PipeTop& = _NEWIMAGE(78, 36, 32) +PipeTube& = _NEWIMAGE(78, 36, 32) +Pipe&(0) = _NEWIMAGE(78, 432, 32) +Pipe&(1) = _NEWIMAGE(78, 432, 32) +PipeImage& = _NEWIMAGE(432, 596, 32) +Medal&(0, 0) = _NEWIMAGE(66, 66, 32) +Medal&(0, 1) = _NEWIMAGE(66, 66, 32) +Medal&(1, 0) = _NEWIMAGE(66, 66, 32) +Medal&(1, 1) = _NEWIMAGE(66, 66, 32) +Finger& = _NEWIMAGE(117, 147, 32) +ScoreButton& = _NEWIMAGE(120, 42, 32) +ShareButton& = _NEWIMAGE(120, 42, 32) +StartButton& = _NEWIMAGE(120, 42, 32) +OKButton& = _NEWIMAGE(120, 42, 32) +RateButton& = _NEWIMAGE(120, 42, 32) +MenuButton& = _NEWIMAGE(120, 42, 32) +PlayButton& = _NEWIMAGE(39, 42, 32) +PauseButton& = _NEWIMAGE(39, 42, 32) +HazardBar& = _NEWIMAGE(462, 24, 32) +Clouds& = _NEWIMAGE(864, 120, 32) +City& = _NEWIMAGE(864, 57, 32) +Bushes& = _NEWIMAGE(864, 27, 32) +New& = _NEWIMAGE(48, 21, 32) +_PUTIMAGE , Sheet&, Plaque&, (0, 189)-(338, 362) ' grab images from sprite sheet +_PUTIMAGE , Sheet&, FlappyBird&, (0, 363)-(287, 428) +_PUTIMAGE , Sheet&, GameOver&, (588, 246)-(869, 302) +_PUTIMAGE , Sheet&, GetReady&, (588, 303)-(847, 368) +_PUTIMAGE , Sheet&, Medal&(0, 0), (339, 327)-(404, 392) +_PUTIMAGE , Sheet&, Medal&(0, 1), (405, 327)-(470, 392) +_PUTIMAGE , Sheet&, Medal&(1, 0), (339, 261)-(404, 326) +_PUTIMAGE , Sheet&, Medal&(1, 1), (405, 261)-(470, 326) +_PUTIMAGE , Sheet&, Finger&, (471, 246)-(587, 392) +_PUTIMAGE , Sheet&, ScoreButton&, (288, 417)-(407, 458) +_PUTIMAGE , Sheet&, ShareButton&, (408, 417)-(527, 458) +_PUTIMAGE , Sheet&, StartButton&, (528, 417)-(647, 458) +_PUTIMAGE , Sheet&, OKButton&, (424, 204)-(543, 245) +_PUTIMAGE , Sheet&, RateButton&, (544, 204)-(663, 245) +_PUTIMAGE , Sheet&, MenuButton&, (664, 204)-(783, 245) +_PUTIMAGE , Sheet&, PlayButton&, (784, 204)-(822, 245) +_PUTIMAGE , Sheet&, PauseButton&, (823, 204)-(861, 245) +_PUTIMAGE , Sheet&, HazardBar&, (288, 393)-(749, 416) +_PUTIMAGE (0, 0)-(431, 119), Sheet&, Clouds&, (424, 0)-(855, 119) +_PUTIMAGE (432, 0)-(863, 119), Sheet&, Clouds&, (424, 0)-(855, 119) +_PUTIMAGE (0, 0)-(431, 56), Sheet&, City&, (424, 120)-(855, 176) +_PUTIMAGE (432, 0)-(863, 56), Sheet&, City&, (424, 120)-(855, 176) +_PUTIMAGE (0, 0)-(431, 26), Sheet&, Bushes&, (424, 177)-(855, 203) +_PUTIMAGE (432, 0)-(863, 26), Sheet&, Bushes&, (424, 177)-(855, 203) +_PUTIMAGE , Sheet&, New&, (289, 363)-(336, 383) +_PUTIMAGE , Sheet&, PipeTop&, (339, 189)-(416, 224) +_PUTIMAGE , Sheet&, PipeTube&, (339, 225)-(416, 260) +_PUTIMAGE (0, 431)-(77, 395), PipeTop&, Pipe&(0) ' create bottom of upper tube image +_PUTIMAGE (0, 0), PipeTop&, Pipe&(1) ' create top of lower tube image +FOR y% = 0 TO 395 STEP 36 ' cycle through tube body of pipes + _PUTIMAGE (0, y% + 35)-(77, y%), PipeTube&, Pipe&(0) ' draw tube on upper pipe image + _PUTIMAGE (0, 36 + y%), PipeTube&, Pipe&(1) ' draw tube on lower pipe image +NEXT y% +_FREEIMAGE PipeTop& ' temporary image no longer needed +_FREEIMAGE PipeTube& ' temporary image no longer needed +_FREEIMAGE Sheet& ' sprite sheet no longer needed +Clean& = _NEWIMAGE(432, 768, 32) ' create clean image holder +_DEST Clean& ' work on clean image +CLS , _RGB32(84, 192, 201) ' clear image with sky blue color +LINE (0, 620)-(431, 767), _RGB32(219, 218, 150), BF ' create brown ground portion of image +LINE (0, 577)-(431, 595), _RGB32(100, 224, 117), BF ' create green grass portion of image +_DEST 0 ' back to work on screen +Scenery(1).image = Clouds& ' set scenery parallax information +Scenery(1).y = 457 +Scenery(1).fmax = 8 +Scenery(2).image = City& +Scenery(2).y = 510 +Scenery(2).fmax = 4 +Scenery(3).image = Bushes& +Scenery(3).y = 550 +Scenery(3).fmax = 2 +Scenery(4).image = HazardBar& +Scenery(4).y = 596 +IF _FILEEXISTS("fbird.sco") THEN ' does high score file exist? + OPEN "fbird.sco" FOR INPUT AS #1 ' yes, open high score file + INPUT #1, HighScore% ' get high score from file + CLOSE #1 ' close high score file +END IF + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + +FUNCTION BOXCOLLISION% (Box1X%, Box1Y%, Box1Width%, Box1Height%, Box2X%, Box2Y%, Box2Width%, Box2Height%) + +'** +'** Detects if two bounding box areas are in collision +'** +'** INPUT : Box1X% - upper left corner X location of bounding box 1 +'** Box1Y% - upper left corner Y location of bounding box 1 +'** Box1Width% - the width of bounding box 1 +'** Box1Height% - the height of bounding box 1 +'** Box2X% - upper left corner X location of bounding box 2 +'** Box2Y% - upper left corner Y location of bounding box 2 +'** Box2Width% - the width of bounding box 2 +'** Box2Height% - the height of bounding box 2 +'** +'** OUTPUT: BOXCOLLISION - 0 (FALSE) for no collision, -1 (TRUE) for collision +'** + +IF Box1X% <= Box2X% + Box2Width% - 1 THEN ' is box1 x within lower limit of box2 x? + IF Box1X% + Box1Width% - 1 >= Box2X% THEN ' yes, is box1 x within upper limit of box2 x? + IF Box1Y% <= Box2Y% + Box2Height% - 1 THEN ' yes, is box1 y within lower limit of box2 y? + IF Box1Y% + Box1Height% - 1 >= Box2Y% THEN ' yes, is box1 y within upper limit of box2 y? + BOXCOLLISION% = TRUE ' yes, then a collision occured, return result + END IF + END IF + END IF +END IF + +END FUNCTION + +'---------------------------------------------------------------------------------------------------------------------- + +SUB CLEANUP () + +'* +'* Removes all game assets from the computer's RAM. +'* + +SHARED Fbird&(), Pipe&(), Num&(), Medal&(), Plaque&, FlappyBird&, GameOver&, GetReady& +SHARED Finger&, ScoreButton&, ShareButton&, StartButton&, OKButton&, RateButton& +SHARED MenuButton&, PlayButton&, PauseButton&, HazardBar&, Clouds&, City&, Bushes& +SHARED New&, Clean&, PipeImage&, Ding&, Flap&, Smack& + +DIM x% ' generic counter +DIM y% ' generic counter + +_SNDCLOSE Ding& ' remove game sounds from RAM +_SNDCLOSE Flap& +_SNDCLOSE Smack& +FOR y% = 0 TO 2 ' cycle through bird image rows + FOR x% = 0 TO 7 ' cycle through bird image columns + _FREEIMAGE Fbird&(x% + 1, y% + 1) ' remove bird image from RAM + NEXT x% +NEXT y% +FOR x% = 0 TO 9 ' cycle trough 9 numeral images + _FREEIMAGE Num&(x%, 0) ' remove large numeral image from RAM + _FREEIMAGE Num&(x%, 1) ' remove small numeral image from RAM +NEXT x% +_FREEIMAGE Plaque& ' remove all remaining images from RAM +_FREEIMAGE FlappyBird& +_FREEIMAGE GameOver& +_FREEIMAGE GetReady& +_FREEIMAGE Pipe&(0) +_FREEIMAGE Pipe&(1) +_FREEIMAGE PipeImage& +_FREEIMAGE Medal&(0, 0) +_FREEIMAGE Medal&(0, 1) +_FREEIMAGE Medal&(1, 0) +_FREEIMAGE Medal&(1, 1) +_FREEIMAGE Finger& +_FREEIMAGE ScoreButton& +_FREEIMAGE ShareButton& +_FREEIMAGE StartButton& +_FREEIMAGE OKButton& +_FREEIMAGE RateButton& +_FREEIMAGE MenuButton& +_FREEIMAGE PlayButton& +_FREEIMAGE PauseButton& +_FREEIMAGE HazardBar& +_FREEIMAGE Clouds& +_FREEIMAGE City& +_FREEIMAGE Bushes& +_FREEIMAGE New& +_FREEIMAGE Clean& + +END SUB + +'---------------------------------------------------------------------------------------------------------------------- + diff --git a/samples/flappy-bird/src/fbird.zip b/samples/flappy-bird/src/fbird.zip new file mode 100644 index 0000000..ad075bd Binary files /dev/null and b/samples/flappy-bird/src/fbird.zip differ diff --git a/samples/floormaper/index.md b/samples/floormaper/index.md index 0d75c23..c1f8439 100644 --- a/samples/floormaper/index.md +++ b/samples/floormaper/index.md @@ -20,9 +20,9 @@ for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003 > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "flrmp.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/floormaper/src/flrmp.bas) -* [RUN "flrmp.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/floormaper/src/flrmp.bas) -* [PLAY "flrmp.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/floormaper/src/flrmp.bas) +* [LOAD "flrmp.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/floormaper/src/flrmp.bas) +* [RUN "flrmp.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/floormaper/src/flrmp.bas) +* [PLAY "flrmp.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/floormaper/src/flrmp.bas) ### File(s) diff --git a/samples/four-player-pong/index.md b/samples/four-player-pong/index.md index e0dcacc..8a0a460 100644 --- a/samples/four-player-pong/index.md +++ b/samples/four-player-pong/index.md @@ -18,9 +18,9 @@ Four-player pong game. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "fourpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/four-player-pong/src/fourpong.bas) -* [RUN "fourpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/four-player-pong/src/fourpong.bas) -* [PLAY "fourpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/four-player-pong/src/fourpong.bas) +* [LOAD "fourpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/four-player-pong/src/fourpong.bas) +* [RUN "fourpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/four-player-pong/src/fourpong.bas) +* [PLAY "fourpong.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/four-player-pong/src/fourpong.bas) ### File(s) diff --git a/samples/fractal-fern/index.md b/samples/fractal-fern/index.md index 12f00f4..7da8cf7 100644 --- a/samples/fractal-fern/index.md +++ b/samples/fractal-fern/index.md @@ -14,9 +14,9 @@ The legendary fractal fern. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "frac3.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/fractal-fern/src/frac3.bas) -* [RUN "frac3.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/fractal-fern/src/frac3.bas) -* [PLAY "frac3.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/fractal-fern/src/frac3.bas) +* [LOAD "frac3.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/fractal-fern/src/frac3.bas) +* [RUN "frac3.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/fractal-fern/src/frac3.bas) +* [PLAY "frac3.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/fractal-fern/src/frac3.bas) ### File(s) diff --git a/samples/fractal.md b/samples/fractal.md index 8921458..8ddc1a2 100644 --- a/samples/fractal.md +++ b/samples/fractal.md @@ -44,9 +44,15 @@ Mandelbrot animator. public domain, uses qb64's 2d prototype +**[Mandelbrot Spiral](mandelbrot-spiral/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) + +Mandelbrot spiral by qbguy. + **[Mandelbrot Zoomer](mandelbrot-zoomer/index.md)** -[🐝 *missing*](author-missing.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) +[🐝 Tor Myklebust](tor-myklebust.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) 'QBDEMO (C) 2002 Tor Myklebust 'The fractal zoomer should run at 60FPS on a 500MHz machine. I d... diff --git a/samples/fractal/index.md b/samples/fractal/index.md index 22196a0..1cceeb2 100644 --- a/samples/fractal/index.md +++ b/samples/fractal/index.md @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "fractal.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/fractal/src/fractal.bas) -* [RUN "fractal.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/fractal/src/fractal.bas) -* [PLAY "fractal.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/fractal/src/fractal.bas) +* [LOAD "fractal.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/fractal/src/fractal.bas) +* [RUN "fractal.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/fractal/src/fractal.bas) +* [PLAY "fractal.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/fractal/src/fractal.bas) ### File(s) diff --git a/samples/frogger.md b/samples/frogger.md new file mode 100644 index 0000000..d6f49cb --- /dev/null +++ b/samples/frogger.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: FROGGER + +**[Frogger](frogger/index.md)** + +[🐝 Matt Bross](matt-bross.md) 🔗 [game](game.md), [frogger](frogger.md) + +Frogger game by Matt Bross. diff --git a/samples/frogger/img/screenshot.png b/samples/frogger/img/screenshot.png new file mode 100644 index 0000000..e2d24b3 Binary files /dev/null and b/samples/frogger/img/screenshot.png differ diff --git a/samples/frogger/index.md b/samples/frogger/index.md new file mode 100644 index 0000000..900f584 --- /dev/null +++ b/samples/frogger/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: FROGGER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Matt Bross](../matt-bross.md) + +### Description + +```text +Frogger game by Matt Bross. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "frog.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/frogger/src/frog.bas) +* [RUN "frog.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/frogger/src/frog.bas) +* [PLAY "frog.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/frogger/src/frog.bas) + +### File(s) + +* [frog.bas](src/frog.bas) + +🔗 [game](../game.md), [frogger](../frogger.md) diff --git a/samples/frogger/src/frog.bas b/samples/frogger/src/frog.bas new file mode 100644 index 0000000..e1a5375 --- /dev/null +++ b/samples/frogger/src/frog.bas @@ -0,0 +1,701 @@ +'RETRO.BAS by Matt Bross, 1997 +'HOMEPAGE - http://www.GeoCities.Com/SoHo/7067/ +'EMAIL - oh_bother@GeoCities.Com +DefInt A-Z + +Type ScoreType + SCORE As Long + PERSON As String * 3 +End Type + +Dim Shared HISCORE(9) As ScoreType + +Screen 7: Cls +Randomize Timer + Val(Date$) + Rnd +'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%INTRO AND GAME%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +FrogINTRO +ShowHiScore +'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%BEGIN DATA%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +FroggerGraphics: +'frog +Data 9,9,0,-32612,0,-32612,20,-32578,0,-32598,0,-32513,0,-32513,-32567,-32513 +Data 0,54,8,62,0,54,0,127,0,127,28,127,0,99,34,-32541,0,-32575,-32575,-32575 +Data 0,0 +'car1 +Data 9,9,-32513,-32513,-32513,0,-32575,-32575,-32513,0,-32575,-32575,-32541,0 +Data 0,0,-32541,0,0,128,-32513,128,0,0,-32513,0,0,0,-32578,0,0,0,28,65,-32578 +Data -32578,-32578,0 +'car2 +Data 9,9,-32513,-32513,-32513,0,-32513,-32575,-32575,0,-32541,-32575,-32575,0 +Data -32541,0,0,0,255,-32768,-32768,-32768,-32513,0,0,0,-32578,0,0,0,28,0,0 +Data 65,-32578,-32578,-32578,0 +'log1 +Data 9,9,-32640,-32513,127,-32640,0,-32513,-32513,64,0,-32513,-32513,64,0 +Data -32513,-32513,64,0,-32513,-32513,64,0,-32513,-32513,64,0,-32513,-32513 +Data 64,0,-32513,-32513,64,-32640,-32513,127,-32640 +'lily +Data 9,9,-32547,-32513,0,-32513,-32632,127,0,127,0,-32513,0,-32513,8,-32513,0 +Data -32521,-32632,-32513,0,119,-32567,-32513,0,-32586,-32575,255,0,255 +Data -32541,127,0,93,-32513,-32513,0,-32541 +'water +Data 9,9,-32513,-32513,0,-32513,-32513,219,0,219,-32513,146,0,146,-32513,73,0 +Data 73,-32513,-32513,0,-32513,-32513,219,0,219,-32513,146,0,146,-32513,73,0 +Data 73,-32513,-32513,0,-32513 +'road +Data 9,9,-32513,-32513,-32513,0,-32513,-32513,-32513,0,-32513,-32513,-32513,0 +Data -32513,-32513,-32513,0,-32513,-32513,-32513,127,-32513,-32513,-32513,0 +Data -32513,-32513,-32513,0,-32513,-32513,-32513,0,-32513,-32513,-32513,0 +'exit1 +Data 9,9,-32513,0,0,-32513,-32513,127,127,-32640,-32576,64,64,-32577,-32576 +Data 64,64,-32577,-32576,64,64,-32577,-32576,64,64,-32577,-32576,64,64,-32577 +Data -32576,64,64,-32577,-32576,64,64,-32577 +FroggerIntroPalette: +Data 1,0,7,2,8,7,4,5,7,7,10,10,10,8,7,15 +FroggerIntroGraphics: +'title1 +Data 57,87,0,0,48,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-3976,0,0,0,0,0,0,0,0,0 +Data 0,0,0,0,0,0,-3841,0,0,0,-24576,0,0,0,0,0,0,0,0,0,0,0,-1793,0,0,0,-16369 +Data 0,0,0,0,0,0,0,0,0,0,768,-1793,0,0,0,-3969,0,0,0,0,0,0,0,0,0,0,7936 +Data -1793,0,0,256,28927,0,0,0,0,0,0,0,0,0,0,16128,-1793,0,0,3840,28784 +Data 0,0,0,0,0,0,0,8192,0,0,32512,-3841,0,0,1536,-8159,0,0,0,0,0,0,0,-8192 +Data 0,0,-256,-3841,0,0,2048,-8189,0,0,0,0,0,0,0,-8190,0,0,-253,-7937,0 +Data 0,20224,-16361,0,0,0,0,0,0,0,-16363,0,0,-249,-16129,0,0,-26623,-32513 +Data 0,0,0,0,0,0,0,-32705,0,0,-241,-16129,0,0,-20477,127,0,0,0,0,0,0,0 +Data 63,0,0,-481,15615,0,0,8199,-16322,0,0,0,0,0,0,0,30,0,0,-225,1023,128 +Data 0,16399,-994,0,0,0,0,0,0,0,30,0,0,-225,1790,96,0,16399,-2019,0,0,0 +Data 0,0,0,0,28,0,0,-193,1276,32,0,16399,-1765,192,0,0,0,0,0,0,24,0,0,-129 +Data 1272,32,0,24604,-1225,0,0,0,0,0,0,0,48,0,0,-129,1272,16,0,12344,-1673 +Data 192,0,0,0,0,0,0,112,0,0,-1,-31503,16,0,2096,31470,96,0,0,0,0,0,0,224 +Data 0,256,-1,29935,16,0,26466,2496,160,0,0,0,0,0,768,192,0,768,-1,7904 +Data 8,0,-10265,0,192,0,0,0,0,0,1536,0,0,1792,-1,608,8,256,-8977,128,112 +Data 0,0,0,0,0,1024,0,0,3840,-257,832,8,768,-15889,128,144,0,0,0,0,0,0 +Data 0,0,7936,-769,64,232,1792,-27665,128,0,0,0,0,0,0,0,0,0,16128,-257 +Data 64,56,3840,4591,128,0,0,0,0,0,0,0,0,0,16128,-1537,64,16,7936,32495 +Data 128,0,0,0,0,0,0,0,0,0,32512,-1537,64,16,7936,32494,128,0,0,0,0,0,0 +Data 0,0,0,-256,-1537,192,16,16128,-308,0,0,0,0,0,0,0,0,0,0,-255,-769,192 +Data 16,32256,32732,0,0,0,0,0,0,0,0,0,0,-255,-1281,128,16,31744,-232,0 +Data 0,0,0,0,0,0,0,0,0,-255,-1793,128,16,32256,-200,0,0,0,0,0,0,0,0,0,0 +Data -255,-513,192,32,-512,-208,0,0,0,0,0,0,0,0,0,0,-255,-3329,192,32,-512 +Data -208,0,0,0,0,0,0,0,0,0,0,-205,-8449,64,32,-512,-14,128,0,0,0,0,0,0 +Data 0,0,0,-197,-769,96,64,-8704,-14,160,0,0,0,32,0,0,0,0,0,-217,-3841 +Data 48,64,-9191,-14,208,0,0,0,16,0,0,0,0,0,-221,-11777,40,128,-8931,-10 +Data 248,0,0,256,40,0,0,0,0,0,-221,-513,52,128,-9955,-10,220,0,0,256,20 +Data 0,0,0,0,0,-205,-16385,-73,0,-9443,-9,236,0,0,768,164,0,0,0,0,0,-185 +Data -4865,19548,0,-27847,-17,-3857,0,0,0,76,0,0,0,0,0,-185,-3329,-391 +Data 0,-18631,-49,-1801,0,0,512,112,0,0,0,0,0,-153,255,-16404,128,-18631 +Data -33,-1805,0,0,0,224,0,0,0,0,0,-185,16639,32566,240,-18629,-97,-2079 +Data 0,0,0,32,0,0,0,0,0,-185,8446,-221,254,14139,-65,15808,224,0,0,0,0 +Data 0,0,0,0,-185,254,-224,235,28475,-65,2016,92,0,0,32,0,0,0,0,0,-153 +Data 254,3904,-32519,20283,-65,128,254,0,0,0,0,0,0,0,0,-185,24820,128,-32514 +Data 32571,-1,0,1,0,0,0,0,0,0,0,0,-185,205,128,-32765,-197,-1,0,0,0,0,0 +Data 0,0,0,0,0,-185,192,128,0,-197,-1,0,0,0,0,0,0,0,0,0,0,-121,6608,0,0 +Data -133,-257,0,0,0,6144,0,0,0,0,0,0,-121,5504,0,0,-133,-257,0,0,0,5120 +Data 0,0,0,0,0,0,-121,-4672,0,0,-133,-257,0,0,0,-5120,0,0,0,0,0,0,-313 +Data -17024,0,0,-133,-257,0,0,0,-17408,0,0,0,0,0,0,-1401,-9340,0,0,-133 +Data -769,0,0,0,-10236,0,0,0,0,0,0,-1401,-17729,0,0,-133,-769,0,0,0,-18241 +Data 0,0,0,0,0,0,-377,-2823,0,0,-135,-1793,0,0,0,-3847,0,0,0,0,0,0,-9329 +Data -19233,0,0,-143,-1793,0,0,768,-20257,0,0,0,0,0,0,-3509,-1793,0,0,-207 +Data -3841,0,0,512,-3841,0,0,0,0,0,0,-31919,-28469,0,0,-224,-7937,0,0,768 +Data -32565,0,0,0,0,0,0,-30383,-7970,0,0,32544,255,0,0,2304,222,0,0,0,0 +Data 0,0,865,87,0,0,-256,252,0,0,768,84,0,0,0,0,0,0,-6656,188,0,0,7936 +Data 248,0,0,1536,184,0,0,0,0,0,0,8960,248,0,0,7936,240,0,0,768,240,0,0 +Data 0,0,0,0,13056,248,0,0,3840,240,0,0,768,240,0,0,0,0,0,0,4352,248,0 +Data 0,3840,240,0,0,256,240,0,0,0,0,0,0,7168,248,0,0,3840,240,0,0,3072 +Data 240,0,0,0,0,0,0,7680,124,0,0,3840,248,0,0,3584,120,0,0,0,0,0,0,7936 +Data 28,0,0,3840,248,0,0,3840,24,0,0,0,0,0,0,32512,140,0,0,1792,248,0,0 +Data 0,8,0,0,0,0,0,0,-253,228,0,0,16128,248,0,0,0,0,0,0,0,0,0,0,-241,244 +Data 0,0,-255,248,0,0,0,0,0,0,0,0,0,0,-225,252,0,0,-241,240,0,0,0,0,0,0 +Data 0,0,0,0,-193,248,0,0,-993,0,0,0,0,0,0,0,0,0,0,0,-385,0,0,0,56,0,0 +Data 0,0,0,0,0,0,0,0,0,-8000,0,0,0,63,0,0,0,0,0,0,0,0,0,0,0,30832,0,0,0 +Data -32753,0,0,0,0,0,0,0,0,0,0,0,-14577,-8057,0,0,14336,0,0,0,0,0,0,0 +Data 0,0,0,0,16128,-3969,0,0,0,-8057,0,0,0,-8185,0,0,0,0,0,0,0,-7937,0 +Data 0,0,8,0,0,0,8,0,0,0,0,0,0,0,-1921,0,0,0,-16345,0,0,0,-16345,0,0,0 +Data 0,0,0,0,-385,0,0,0,14352,0,0,0,14352,0,0,0,0,0,0,0,31800,0,0,0,0,0 +Data 0,0,0,0,0,0,0,0,0,0,24,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,28,0,0,0,0,0 +Data 0,0,0,0,0,0,0,0,0,0,12,0,0,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,0,0,0,0 +'title2 +Data 54,81,0,0,48,0,0,0,0,0,0,0,0,0,0,0,0,0,48,0,0,0,0,0,0,0,0,0,0,0,0 +Data 0,-7951,0,0,0,0,0,0,0,0,0,0,0,0,0,-7951,0,0,2048,0,0,0,8192,0,0,0 +Data 0,0,256,-24322,0,0,0,0,0,0,16385,0,0,0,0,0,256,-7937,0,0,2816,64,0 +Data 0,8192,0,0,0,0,0,256,-3842,0,0,0,64,0,0,1,0,0,0,0,0,256,-7945,0,0 +Data 2,32,0,0,24,0,0,0,0,0,16128,-3841,0,0,-19455,80,0,0,0,0,0,0,0,0,16128 +Data -3841,0,0,-7671,32,0,0,16384,0,0,0,32,0,32512,-24322,0,0,16514,240 +Data 0,0,1,0,0,0,0,0,-256,24829,0,0,-32766,176,0,0,16386,0,0,0,0,0,-249 +Data -24321,0,2304,-24824,0,0,1280,16384,0,0,5376,0,0,-243,16607,0,0,-8440 +Data 0,0,4098,-20448,0,0,2560,0,0,-225,-7937,0,512,-256,16,0,4100,2048 +Data 0,0,7424,0,0,-489,2047,192,1024,-16640,48,0,8456,-16384,0,0,7680,0 +Data 0,-193,1258,64,1792,4352,184,0,16384,16396,128,0,0,0,0,-129,16626 +Data 64,1792,2304,-24574,0,8192,-12028,0,0,0,0,0,-4225,-23324,32,3584,5120 +Data 16386,0,4144,-6133,160,0,0,0,0,30079,1093,32,15872,2576,184,0,-21888 +Data 16529,96,0,0,0,768,-1,-19272,48,20736,25856,74,0,1024,-32750,0,0,0 +Data 0,1792,-1,7792,16,-3326,-32262,16512,0,256,352,160,0,0,0,3840,-257 +Data 688,16,-2298,-7447,233,0,512,0,224,0,0,0,7936,-1,864,208,-221,-31520 +Data 92,0,2048,80,32,0,0,0,16128,-1,16,112,-2289,-23836,-32618,0,0,10240 +Data 0,0,0,0,32512,-1,144,32,-1265,1484,20490,4096,0,5376,0,0,0,0,-256 +Data -257,80,32,-1177,735,180,0,0,2560,128,0,0,0,-255,-257,80,544,-3105 +Data 9375,80,0,0,0,0,0,0,0,-255,-1,48,32,1407,-13793,16,0,80,8192,0,0,0 +Data 0,-255,-257,32,32,1791,20751,16,0,8192,128,0,0,0,0,-255,-257,32,0 +Data 3807,21020,12448,0,256,2176,0,0,0,0,-255,-1,184,8192,3775,16522,4184 +Data 0,0,0,0,0,0,0,-253,-257,88,64,7799,-23024,-28644,48,256,-32768,40 +Data 0,0,0,-214,-1,140,5184,3819,25408,8208,1,0,1040,16,0,0,0,-201,-257 +Data 6,2176,17486,22612,4272,0,256,2720,96,0,0,0,-253,-1,37,-31616,3754 +Data -29744,16627,112,384,81,0,0,0,0,-221,-1,16038,-11264,-12224,22980 +Data 1089,8,0,-32768,0,0,-31232,0,-201,-1,21499,2048,-3864,9312,1156,512 +Data 0,26656,0,0,-29952,0,-217,-257,-16409,-16256,-12208,6608,1032,56,256 +Data 16385,8,0,1536,0,-187,-769,-10466,-22416,6200,-26368,2052,18,768,10842 +Data 132,0,1537,0,-16537,-2817,27299,-25604,20737,21568,16,16384,2816,1448 +Data 0,0,0,0,-185,-7425,8002,-18200,-13559,9608,0,0,5376,8408,20,0,0,0 +Data -185,-7937,946,-28420,20997,68,4,40,6912,-22280,0,0,0,0,32611,-3841 +Data 2,-31744,-17919,15626,-22384,-32752,1280,17728,64,0,0,0,-189,25342 +Data 4,-18432,-11115,23191,49,4,2561,-30048,40,0,0,0,-189,255,4,-20480 +Data -5380,-30556,4181,4,22785,81,0,0,0,0,-189,-32514,200,-28672,22751 +Data 12309,-22452,44,27137,-24058,0,0,0,0,-189,253,168,-31744,-19974,17799 +Data 17476,48,28674,0,0,0,-32768,0,-61,2046,104,0,12663,-27328,2050,29 +Data -18432,-30718,128,0,0,0,-637,1524,216,1280,-23813,9386,29,152,20489 +Data 1,20,0,0,0,-893,-3628,208,1024,16637,10254,1,569,43,10752,160,0,144 +Data 0,-893,-6149,96,19456,16637,4104,12312,657,4108,128,4,0,8352,0,-53 +Data 32495,160,1024,21757,149,0,56,5124,64,0,0,72,0,-4729,-2101,192,24576 +Data 9470,8238,0,152,9744,0,0,0,209,0,-860,11791,64,20736,4350,-32555,0 +Data 266,1248,0,0,0,40,0,25516,29223,128,20736,-9807,165,0,3584,10241,0 +Data 0,0,80,0,-860,11791,64,21248,4096,-32560,0,17160,480,0,0,2048,32,0 +Data -4857,-2101,192,0,1106,32,0,-24424,10768,0,0,512,16400,0,-30654,-3897 +Data 0,0,11552,12,0,-30961,533,0,0,512,16,0,20032,24609,0,2560,3584,176 +Data 0,16901,9232,0,0,256,64,0,1536,-24519,0,3328,1032,16,0,-24574,18450 +Data 0,0,2048,160,0,1024,-4036,0,1280,544,12,0,4864,1,0,0,3072,48,0,1536 +Data 28734,0,1280,16457,128,0,-24568,2049,0,0,512,0,0,3840,4349,0,1280 +Data 176,104,0,16384,-32766,0,0,3328,0,0,16128,-12033,0,1280,16708,32,0 +Data -32766,0,0,0,0,0,0,-256,-3841,0,1280,-8183,0,0,512,0,0,0,0,0,0,-256 +Data -16129,0,768,12367,32,0,0,72,0,0,0,0,0,-253,248,0,1024,770,80,0,0 +Data 0,0,0,0,0,0,3590,0,0,2048,-10240,8,0,-3839,-32734,0,0,0,0,0,-30965 +Data 3264,0,1024,8232,144,0,21000,16,0,0,0,0,0,29456,-264,0,0,1420,0,0 +Data 16,2,0,0,0,0,0,800,-4065,0,0,-24528,0,0,544,2112,0,0,0,0,0,64,-16889 +Data 0,-24576,2048,0,0,0,20480,0,0,0,0,0,128,-2801,128,16384,0,16384,0 +Data 128,2560,0,0,256,128,0,0,-29949,0,0,1024,64,0,0,8192,0,0,0,8,0,0,-16383 +Data 0,0,0,16,0,0,0,0,0,0,0,0,0,-16384,0,0,256,0,0,0,0,0,0,0,0,0,0,-16384 +Data 0,0,0,0,0,0,0,0,0,0,0,0,0,-32767,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0 +Data 0,0,0,-32768,0,0,0,0,0,0,3,0,0,0,0,0,0,0,0,0,0,0,0 +'title3 +Data 55,82,0,0,48,0,0,0,0,0,0,32,0,0,0,0,0,0,16,0,0,0,0,0,0,32,0,0,0,0 +Data 0,0,96,0,0,0,0,0,0,64,0,0,0,0,0,0,64,0,0,0,0,0,0,32,0,0,0,0,0,0,-7952 +Data 0,0,0,16,0,0,65,0,0,0,0,0,0,16465,0,0,16384,0,0,0,-32608,0,0,0,0,0 +Data 0,-7951,0,0,8192,16,0,0,81,0,0,0,0,0,256,16483,0,0,16384,0,0,0,-32638 +Data 0,0,0,0,0,256,-32605,0,0,256,0,0,0,16448,0,0,0,0,0,768,16597,0,0,768 +Data 0,0,512,-32520,0,0,0,0,0,768,16633,0,0,2304,0,0,256,-32554,0,0,0,0 +Data 0,768,85,0,0,0,192,0,0,234,0,0,0,0,0,512,-16134,0,0,-1536,0,0,256 +Data 5,0,0,0,0,0,256,21,0,0,8452,0,0,2560,-32546,0,0,0,0,0,11776,-16129 +Data 0,0,-16374,0,0,5376,0,0,0,0,0,0,-6400,16639,0,0,8,128,0,-4096,16384 +Data 0,0,0,0,0,-16637,254,0,256,256,128,0,24576,16384,0,0,0,0,0,-235,-16132 +Data 0,8192,2816,0,0,523,160,0,0,0,0,0,-5607,-3345,128,3072,18184,1,0,5890 +Data 12344,0,0,0,0,0,-233,-18945,0,0,26112,-16246,0,10,16408,0,0,0,0,0 +Data -193,-21254,192,0,256,67,0,-2781,4190,0,0,0,0,0,22301,16630,64,256 +Data 512,-32624,0,-21978,10413,0,0,0,0,0,-4113,24818,32,-30976,512,-12261 +Data 0,21784,-16307,0,0,0,0,256,-2057,20708,32,514,6656,16552,0,-21992 +Data 165,0,0,0,0,3840,-1026,-29779,32,15878,16512,112,0,17729,1844,0,0 +Data 0,0,14080,30167,1916,160,22279,-32162,16400,14336,-24408,3176,32,0 +Data 0,0,-1280,-1025,584,192,-18425,18088,176,12288,21829,1952,128,0,0 +Data 0,7937,30719,1476,576,21543,-30638,-32688,-16384,-22102,3856,0,0,0 +Data 0,-22016,-5,144,64,-22134,-9542,248,21761,17748,32,0,0,1024,0,22273 +Data 32725,1092,64,-11245,24645,8272,-22528,-21974,146,0,0,2048,0,-255 +Data -1,230,96,21763,-20090,4344,0,20736,72,0,0,0,0,-255,30079,226,32,-24053 +Data 13665,84,2,-30200,520,112,0,0,0,-2034,-18310,1015,2256,1,128,80,1537 +Data 17541,-32504,48,322,7,0,-1785,22524,1016,3104,512,2128,4208,1616,-24575 +Data 6927,224,262,8,128,-201,-1281,-15880,-32632,0,1280,8,76,0,4354,8,0 +Data 5,32,-29,-3585,3042,2200,0,1024,8388,22,512,14617,24,0,14,0,-57,-1 +Data -3075,4348,0,0,128,172,0,-13310,12,4,16,80,-2105,-2049,-4916,10342 +Data -32768,0,4112,10450,2048,-24013,138,128,128,224,-2073,-1,-6408,4346 +Data 0,0,1144,2156,0,-7929,0,0,64,128,-191,-1,29904,-24388,0,10240,8441 +Data 22,0,28679,66,0,32,0,-18653,16351,2946,5290,0,17408,4112,2120,96,-6863 +Data 228,64,2248,0,32515,22527,5120,11264,0,512,13921,18,2048,-29143,192 +Data 128,-11104,0,-8397,-5633,-28152,7296,0,20484,14944,64,512,3079,64 +Data 32,-24560,0,7937,-11777,1025,1024,8224,256,22211,-16334,3840,7423 +Data 0,192,32,0,-253,-1409,6314,2048,160,-24319,32290,16404,1152,-13068 +Data 0,-32768,2144,0,-255,-2561,20492,3072,64,1281,31777,8208,2816,-29450 +Data 0,0,100,64,-1455,-22481,-22491,1536,4330,12112,-21936,5465,1984,1269 +Data 0,-32767,160,0,-2799,-19121,-32523,2640,20727,264,2600,2052,25248 +Data 265,244,8192,-2928,0,-504,31,-32544,29962,-8136,-26609,0,17666,12048 +Data 133,6,0,208,0,-2814,2143,-16169,14336,16469,4207,2048,10887,20384 +Data 25,0,0,9872,0,-1270,2192,-32745,256,-11927,12300,64,5252,-9170,-32676 +Data 0,0,-32733,0,29957,528,13,512,-20076,28799,128,11144,-31154,128,0 +Data 0,256,0,14495,-30559,40,0,1,-32202,0,-15668,16734,84,0,0,8,0,4373 +Data -6909,112,8704,-6078,28,0,-21112,1556,142,0,0,16385,0,11818,8216,248 +Data 1024,-15615,14,0,-3949,-28416,12,0,1024,0,0,18224,5320,96,512,1924 +Data 232,0,30881,816,152,0,0,0,0,11818,-20196,252,1024,-7360,78,0,-28271 +Data 4356,12,0,0,0,0,5397,-6369,242,-24064,12352,-30712,0,-20711,4684,6 +Data 0,0,0,0,2624,-129,224,-28672,0,0,0,15616,16516,0,0,0,0,0,1344,29695 +Data 192,-32768,42,0,0,5120,-17366,128,0,0,0,0,2816,-1281,160,0,0,4096 +Data 0,5120,1280,192,0,0,0,0,1280,5616,0,0,3072,-32760,0,2560,-2302,96 +Data 0,0,0,0,2816,-13316,224,0,0,0,0,1536,13507,0,0,0,0,0,5376,-2161,32 +Data 0,4104,-32768,0,4096,2176,96,0,0,0,0,24576,-2032,128,0,784,16384,0 +Data 16384,1792,0,0,0,0,0,-16384,29696,224,0,0,3,0,0,19456,96,0,0,16,0 +Data 1,2816,32,0,0,0,0,1,1024,0,0,0,0,0,2,768,0,0,0,12,0,2,0,0,0,0,0,0 +Data 4,1536,0,512,0,0,0,4,0,0,0,0,0,0,24,1024,0,8192,0,8,0,8,512,0,0,0 +Data 0,0,32,3072,0,2048,0,0,0,32,0,0,0,0,0,0,64,4096,0,16384,0,44,0,0,0 +Data 0,0,0,0,0,0,6144,0,0,0,0,0,0,0,0,0,0,0,0,128,12288,0,0,0,0,0,128,8192 +Data 0,0,0,0,0,0,12288,0,0,0,0,0,0,0,0,0,0,0,0,0,24576,0,0,0,128,0,0,8192 +Data 0,0,0,0,0,0,-16384,0,0,0,0,0,0,0,0,0,0,0,0,0,16384,0,0,0,0,0,0,-32768 +Data 0,0,0,0,0,0,-32767,0,0,0,0,0,0,1,0,0,0,0,0,0,1,0,0,0,128,0,0,0,0,0 +Data 0,0,0,0,3,0,0,0,0,0,0,0,0,0,0,0,0,0,4,0,0,2048,0,0,0,2,0,0,0,0,0 +'title4 +Data 55,82,0,0,0,0,0,16384,0,0,0,48,0,0,0,0,0,0,0,0,0,0,0,0,0,64,0,0,0 +Data 0,0,0,0,0,0,0,0,0,0,96,0,0,0,0,0,0,0,0,0,0,0,0,0,96,0,0,0,0,0,0,0 +Data 0,0,0,0,0,0,96,0,0,0,0,0,0,0,0,0,0,0,0,0,64,0,0,0,0,0,0,0,0,0,0,0 +Data 0,256,-16157,0,0,0,0,0,0,0,0,0,0,128,0,256,16483,0,0,0,0,0,0,0,0,0 +Data 0,0,0,256,-16157,0,0,0,0,0,0,0,0,0,0,0,0,256,-16191,0,0,0,0,0,0,0 +Data 0,0,0,0,0,256,-16157,0,0,0,0,0,0,0,0,0,0,0,0,768,71,0,0,0,0,0,0,0 +Data 0,0,0,0,0,768,-32569,0,0,0,0,0,0,0,0,0,1282,0,0,1280,-32552,0,0,0 +Data 0,0,0,0,0,0,1280,0,0,1792,-32518,0,0,0,0,0,0,0,0,0,-31488,0,0,1792 +Data 114,0,0,0,0,0,0,0,0,0,2560,0,0,3840,245,0,0,0,0,0,0,0,0,0,2048,0,0 +Data 1280,213,0,0,0,0,0,0,0,0,0,3072,0,0,1792,243,0,0,0,0,0,0,0,0,0,32 +Data 0,0,21760,84,0,0,0,0,0,0,0,0,0,-4859,0,0,-2044,-32766,0,0,0,0,0,3840 +Data 252,0,0,400,0,0,16413,-32512,0,0,0,0,0,-256,252,0,1280,0,128,0,0,1792 +Data 128,0,0,0,0,-32753,-16185,0,4096,10,0,0,29984,12480,64,0,0,0,0,-30708 +Data -8057,0,28928,12288,2,0,-254,6216,64,0,0,0,0,5237,4124,0,2048,768 +Data 136,3328,-1273,24828,192,0,0,0,-32000,-21821,2723,0,4,3072,21,-26624 +Data -8385,-6061,128,0,0,0,1536,1,-10432,0,16568,6696,-32768,16641,-10305 +Data -3868,0,0,0,0,15872,10794,514,0,513,4,209,-32767,-1027,11517,128,0 +Data 0,0,-16384,2305,513,0,62,2562,208,257,-769,245,0,0,0,0,-9213,10784 +Data -32736,96,0,256,2,8960,-1,-22274,0,0,0,0,-1018,3652,-16383,2272,2 +Data 2048,0,257,-1,9462,0,0,0,0,-32754,0,-8191,256,32001,-2187,-4050,512 +Data -30078,8329,0,124,136,0,-28643,64,13326,8440,257,-32536,171,518,5888 +Data 11008,0,-16788,28928,64,25121,32512,-8180,17568,256,1024,23747,26 +Data -32768,-15612,2,-355,-3328,28,17125,-18688,-16242,12,-30720,27136 +Data -7444,22,2184,-13206,16,30653,4416,19,-1342,-8193,20367,62,4,2128 +Data 0,63,20480,8,192,-20351,29729,191,-1088,28667,4095,2076,1028,8256 +Data 25120,55,16384,32,128,29200,3219,223,-1086,28667,3054,8240,1108,0 +Data -14832,20495,0,1025,8,29216,4243,235,-3327,-2561,-31105,8256,-24572 +Data 24,2603,86,6816,640,100,6152,256,212,9249,-4081,-3329,3104,8208,7432 +Data 1089,2096,2080,16413,714,-8509,16631,188,1041,-4081,-8462,1120,-32760 +Data 18952,-32535,4272,2176,-14270,532,32483,1527,16,9248,-4081,-20225 +Data 7520,4120,1801,5195,128,2320,1031,642,-4669,8438,176,-7935,-4081,20605 +Data -22824,16400,-17401,1583,16,1792,-32708,32,-20466,760,80,528,3,24847 +Data 794,-15360,2305,-32688,-116,312,19481,4,0,-7938,128,264,1,-7734,4866 +Data 3712,2112,2096,32708,240,11784,0,0,13759,0,12,33,15904,4096,11777 +Data 32583,241,-349,1488,12320,0,0,-32584,8,12289,1,5760,-13824,1536,32558 +Data 240,-240,-22800,6144,0,0,81,0,28675,3585,15488,10240,16384,3552,0 +Data -12416,-24386,-16270,0,0,17,32,32257,2304,26752,2560,808,20619,132 +Data -31852,-22028,4111,0,0,84,0,-6400,898,-1918,1280,9232,19475,0,2218 +Data 857,33,0,512,236,0,5376,716,-32665,-10240,58,-32654,32,4,-32197,24 +Data 0,0,16385,0,3584,16255,-7937,-32768,16,-32684,0,316,-30323,72,0,0 +Data 0,0,256,-24769,-32577,0,-32768,4,64,24,26688,64,0,0,0,0,0,-1,254,-32768 +Data 1,-32508,192,48,0,8,0,0,0,0,0,-241,222,0,-12288,8192,0,48,0,0,0,0 +Data 0,0,0,-1025,254,-32768,0,0,0,48,1024,8,0,0,0,0,256,-26817,-32579,0 +Data 16384,40,64,280,20528,66,0,0,0,0,0,0,0,0,0,156,0,192,128,120,0,0,0 +Data 0,0,0,0,0,-32768,0,0,256,0,16,0,0,0,0,0,0,0,0,0,0,0,1664,0,48,0,0 +Data 0,0,0,0,0,0,0,0,0,3200,0,16,0,0,0,0,0,0,0,0,0,0,0,4096,0,96,0,0,0 +Data 0,0,0,0,0,0,0,0,8192,0,64,0,0,0,0,0,0,0,0,0,0,0,-16384,0,192,0,0,0 +Data 0,0,0,0,0,0,0,0,-32767,256,128,0,0,0,0,0,0,0,0,0,0,0,2,256,128,0,0 +Data 0,0,0,0,0,0,0,0,0,4,768,0,0,0,0,0,0,0,0,0,0,0,0,24,1536,0,0,0,0,0 +Data 0,0,0,0,0,0,0,16,1024,0,0,0,0,0,0,0,0,0,0,0,0,32,3072,0,0,0,0,0,64 +Data 0,0,0,0,0,0,64,1024,0,0,0,0,0,0,0,0,0,0,0,0,0,6144,0,0,0,0,0,0,0,0 +Data 0,0,0,0,128,4096,0,0,0,0,0,0,0,0,0,0,0,0,0,12288,0,0,0,0,0,0,0,0,0 +Data 0,0,0,0,24576,0,0,0,0,0,0,0,0,0,0,0,0,0,24576,0,0,0,0,0,0,0,0,0,0 +Data 0,0,0,-16384,0,0,0,0,0,0,0,0,0,0,0,0,0,-32767,0,0,0,0,0,0,0,0,0,0 +Data 0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,3,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0 +Data 0,0,0,0 +'title5 +Data 57,22,0,-241,248,0,0,0,0,0,0,0,0,0,0,0,0,0,768,240,-8185,0,0,-241 +Data 248,0,0,0,0,0,0,0,0,0,15360,0,7680,0,768,-1,-7937,0,0,0,0,0,0,0,0 +Data 0,-16383,0,256,192,16128,-1,-257,0,0,0,0,0,0,0,0,0,6,0,0,48,-255,-1 +Data -1,192,-512,0,0,0,0,0,0,0,24,0,0,12,-249,-1,-1,240,-32255,0,0,0,31744 +Data 0,0,0,32,0,0,2,-241,-1,-1,252,6673,0,15360,0,-7168,0,0,0,64,0,0,1 +Data -225,-1,-1,254,-17631,-12289,-6145,248,17408,0,6144,0,64,0,0,1,-225 +Data -1,-1,254,-16864,30860,18992,136,16640,-30861,-18993,112,128,0,0,-32768 +Data -193,-1,-1,255,-19136,-19677,-25754,40,18432,19676,25753,208,128,0 +Data 0,-32768,-193,-1,-1,255,-31424,-22714,-19634,72,30720,22712,19633 +Data 176,128,0,0,-32768,-193,-1,-1,255,-17088,-20619,-28834,120,16384,20616 +Data 28833,128,128,0,0,-32768,-193,-1,-1,255,-19647,11895,-17572,96,16384 +Data -11896,17571,128,64,0,0,1,-225,-1,-1,254,4641,28728,-14752,32,-7936 +Data -28729,14751,192,64,0,0,1,-225,-1,-1,252,-3295,-8209,-130,226,0,0 +Data 129,0,32,0,0,2,-249,-1,-1,240,24,7424,-32646,12,0,0,129,0,24,0,0,12 +Data -255,-1,-1,192,6,5888,-32658,48,0,2048,145,0,6,0,0,48,16128,-1,-257 +Data 0,-16383,6144,-32271,192,0,1792,14,0,-16383,0,256,192,768,-1,-7937 +Data 0,15360,3840,7839,0,0,0,0,0,15360,0,7680,0,0,-241,248,0,768,240,-8185 +Data 0,0,0,0,0,768,240,-8185,0,0,0,0,0,0,-241,248,0,0,0,0,0,0,-241,248 +Data 0,0,0,0,0,0,0,0,0,0,0,0,0 + +Sub BYE + Screen 0, 0, 0, 0: Width 80, 25: Cls + Print "FROGGER! Written in *QB*. Matt Bross, 1997" + Print "HOMEPAGE - http://www.GeoCities.Com/SoHo/7067/" + Print "EMAIL - oh_bother@GeoCities.Com" + End +End Sub + +Sub DELAY (SEC!) + For V = 0 To SEC! * 70: Wait &H3DA, 8: Wait &H3DA, 8, 8: Next +End Sub + +Sub Frogger (TLIVES, ODIF, OT, OD!) + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%GRAPHICS ARRAYS%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + Rem $DYNAMIC + Dim FROG(37), car1(37), car2(37), log1(37), lily(37), water(37), road(37) + Dim exit1(37): Restore FroggerGraphics + For i = 0 To 37: Read FROG(i): Next: For i = 0 To 37: Read car1(i): Next + For i = 0 To 37: Read car2(i): Next: For i = 0 To 37: Read log1(i): Next + For i = 0 To 37: Read lily(i): Next: For i = 0 To 37: Read water(i): Next + For i = 0 To 37: Read road(i): Next: For i = 0 To 37: Read exit1(i): Next + '%%%%%%%%%%%%%%%%%%%%%%%%%%%INFORMATION ARRAYS%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + Dim FrogLev(23, 15) + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%VARIABLES%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + NewGame: LIVES = TLIVES: SCORE = 0: DIF = ODIF: D! = OD! + '%%%%%%%%%%%%%%%%%%%%%%%%%%LOAD HIGH SCORE TABLE%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + Open "hiscore.dat" For Binary As #1 + 'FOR i = 0 TO 9: GET #1, , HISCORE(i): NEXT + Close + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%LOAD LEVEL%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + NextLev: Cls + For Y = 0 To 15: For X = 0 To 23 + Select Case Y + Case 0: If Int(Rnd * DIF) = 0 Then FrogLev(X, Y) = 8 Else FrogLev(X, Y) = 9 + Case 1 TO 6: FrogLev(X, Y) = 6 + If Int(Rnd * DIF) = 0 Then + If Y And 1 Then FrogLev(X, Y) = 4 Else FrogLev(X, Y) = 5 + End If + Case 8 TO 14: FrogLev(X, Y) = 7 + If Int(Rnd * (100 - DIF)) = 0 Then + If Y And 1 Then FrogLev(X, Y) = 2 Else FrogLev(X, Y) = 3 + End If + End Select + Next: Next + + For Y = 0 To 6 + FY = -1: FX = -1: EX = -1 + For X = 0 To 23 + If FrogLev(X, Y) = 4 And Y And 1 Then FY = 0 + If FrogLev(X, Y) = 5 Then FX = 0 + If FrogLev(X, Y) = 8 Then EX = 0 + Next + If Y And 1 Then + If FY = -1 Then FrogLev(Int(Rnd * 23), Y) = 4 + Else + If FX = -1 And Y <> 0 Then + If Y = 3 Or Y = 6 Then EX = 11 Else EX = 0 + FrogLev(Int(Rnd * 11) + EX, Y) = 5 + End If + End If + If EX = -1 And Y = 0 Then FrogLev(Int(Rnd * 11), Y) = 8 + Next + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%RESTART POINT%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ReStart: FX = 11: FY = 15: SEC = OT: ForStep = DIF: SideStep = DIF \ 2 + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%DRAW LEVEL%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + For Y = 0 To 15: For X = 0 To 23 + EX = X * 9 + 50: EY = Y * 9 + 20 + Select Case FrogLev(X, Y) + Case 2: Put (EX, EY), car1(), PSet + Case 3: Put (EX, EY), car2(), PSet + Case 4: Put (EX, EY), log1(), PSet + Case 5: Put (EX, EY), lily(), PSet + Case 6: Put (EX, EY), water(), PSet + Case 7: Put (EX, EY), road(), PSet + Case 8: Put (EX, EY), exit1(), PSet + Case Else: Line (EX, EY)-(EX + 8, EY + 8), 0, BF + End Select + Next: Next + Locate 2, 14: Print Space$(12) + Line (0, 178)-(45, 186), 0, BF + If LIVES > 5 Then SLIVES = 5 Else SLIVES = LIVES + For X = 0 To SLIVES - 1: Put (X * 9, 178), FROG(), PSet: Next + Locate 22, 1: Print "LIVES": Locate 1, 16: Print "FROGGER!" + Locate 22, 9: Print "SCORE": Locate 23, 9: Print SCORE + Locate 22, 16: Print "TIME": Locate 23, 16: Print SEC + Locate 22, 23: Print "LEVEL": Locate 23, 23: Print DIF + Locate 22, 31: Print "HISCORE": Locate 23, 31: Print HISCORE(0).SCORE + Put (149, 155), FROG(), PSet: If LIVES <= 0 Then GoTo LOSE + Do: Loop Until InKey$ <> "" + T& = Timer Mod 86400: Do: Loop Until Timer >= T&: T& = Timer + '------------------------>BEGIN MAIN LOOP OF FROGGER GAME<------------------- + Def Seg = 0 + Do + '**********************************GET KEY*********************************** + + + 'a = INP(&H60): WHILE LEN(INKEY$): WEND + 'SELECT CASE a + ' CASE &H48: OFX = FX: OFY = FY: FY = FY - 1 + 'SCORE = SCORE + ForStep: KeyPress = -1 + ' CASE &H50: OFX = FX: OFY = FY: FY = FY + 1 + 'KeyPress = -1 + ' CASE &H4B: OFX = FX: OFY = FY: FX = FX - 1 + 'SCORE = SCORE + SideStep: KeyPress = -1 + ' CASE &H4D: OFX = FX: OFY = FY: FX = FX + 1 + 'SCORE = SCORE + SideStep: KeyPress = -1 + ' CASE &H1: GOSUB ABORTGAME + ' CASE ELSE: KeyPress = 0 + 'END SELECT + + a$ = InKey$ + 'a = INP(&H60): WHILE LEN(INKEY$): WEND + Select Case a$ + Case "8": OFX = FX: OFY = FY: FY = FY - 1 + SCORE = SCORE + ForStep: KeyPress = -1 + Case "2": OFX = FX: OFY = FY: FY = FY + 1 + KeyPress = -1 + Case "4": OFX = FX: OFY = FY: FX = FX - 1 + SCORE = SCORE + SideStep: KeyPress = -1 + Case "6": OFX = FX: OFY = FY: FX = FX + 1 + SCORE = SCORE + SideStep: KeyPress = -1 + Case "q": GoSub ABORTGAME + Case Else: KeyPress = 0 + End Select + + + '********************************MOVE FROG*********************************** + If KeyPress Then + Locate 23, 9: Print SCORE: Sound 500, .5 + '*************************CHECK BOUNDS OF THE FROG*************************** + If FX < 0 Then FX = 0 + If FX > 23 Then FX = 23 + If FY < 0 Then FY = 0 + If FY > 15 Then FY = 15 + End If + '********************************DRAW FROG*********************************** + If KeyPress Or FY < 7 Then Put (FX * 9 + 50, FY * 9 + 20), FROG(), PSet + '******************************ERASE OLD CELL******************************** + If FX <> OFX Or FY <> OFY Then + EX = OFX * 9 + 50: EY = OFY * 9 + 20 + Select Case FrogLev(OFX, OFY) + Case 2: Put (EX, EY), car1(), PSet + Case 3: Put (EX, EY), car2(), PSet + Case 4: Put (EX, EY), log1(), PSet + Case 5: Put (EX, EY), lily(), PSet + Case 6: Put (EX, EY), water(), PSet + Case 7: Put (EX, EY), road(), PSet + Case 8: Put (EX, EY), exit1(), PSet + Case Else: Line (EX, EY)-(EX + 8, EY + 8), 0, BF + End Select + End If + + Do: newtimer! = Timer: Loop While newtimer! = lasttimer! + lasttimer! = newtimer! + + Do: newtimer! = Timer: Loop While newtimer! = lasttimer! + lasttimer! = newtimer! + + + '*****************************CHECK FOR BONUSES****************************** + If FrogLev(FX, FY) = 8 Then GoTo WIN + If SCORE And SCORE Mod (100 * DIF + 1) = 0 Then GoSub LIFEUP + '***************************CHECK IF YOU ARE DEAD**************************** + Select Case FrogLev(FX, FY) + Case 2, 3, 6, 9: GoTo DIE + End Select + If T& <> Fix(Timer) Then T& = Timer: SEC = SEC - 1: Locate 23, 16: Print SEC + If SEC <= 0 Then GoTo DIE + '******************************MOVE OBSTICALES******************************* + BACK = 23: FORTH = 0 + For Y = 1 To 14: For X = BACK To FORTH Step Sgn(FORTH - BACK) + Select Case FrogLev(X, Y) + Case 2 + If X = 0 Then C2 = 23 Else C2 = X - 1 + Swap FrogLev(X, Y), FrogLev(C2, Y) + Put (C2 * 9 + 50, Y * 9 + 20), car1(), PSet + If FrogLev(X, Y) <> 2 Then Put (X * 9 + 50, Y * 9 + 20), road(), PSet + Case 3 + If X = 23 Then C2 = 0 Else C2 = X + 1 + Swap FrogLev(X, Y), FrogLev(C2, Y) + Put (C2 * 9 + 50, Y * 9 + 20), car2(), PSet + If FrogLev(X, Y) <> 3 Then Put (X * 9 + 50, Y * 9 + 20), road(), PSet + Case 4 + Select Case Y + Case 1, 5 + If X = 23 Then C2 = 0 Else C2 = X + 1 + If FY = Y And FX = X Then OFX = FX: OFY = FY: FX = (FX + 1) Mod 23 + Swap FrogLev(X, Y), FrogLev(C2, Y) + Put (C2 * 9 + 50, Y * 9 + 20), log1(), PSet + If FrogLev(X, Y) <> 4 Then Put (X * 9 + 50, Y * 9 + 20), water(), PSet + Case 3 + If X = 0 Then C2 = 23 Else C2 = X - 1 + If FY = Y And FX = X Then OFX = FX: OFY = FY: FX = FX - 1 + Swap FrogLev(X, Y), FrogLev(C2, Y) + Put (C2 * 9 + 50, Y * 9 + 20), log1(), PSet + If FrogLev(X, Y) <> 4 Then Put (X * 9 + 50, Y * 9 + 20), water(), PSet + End Select + End Select + Next + If Y > 7 Then Swap BACK, FORTH Else If Y And 1 Then Swap BACK, FORTH + Next + Sound 100, .1 + + 'DELAY D! + + Loop + '--------------------->END MAIN LOOP OF FROGGER GAME<------------------------ + DIE: Sound 500, 5: Sound 200, 3: Sound 100, 2 + LIVES = LIVES - 1: GoTo ReStart + + WIN: Put ((OFX + 1) * 9 + 50, OFY * 9 + 20), log1(), PSet + Locate 2, 14: Print "LEVEL PASSED": DIF = DIF + 1: GoTo NextLev + + LOSE: For X = 0 To 500 Step 40: Sound 2000 + X, 1: Next + Sound 200, 4: Sound 100, 2 + Locate 2, 15: Print "GAME OVER!" + While Len(InKey$): Wend: DELAY 1 + If SCORE > HISCORE Then NewHiScore SCORE + Locate 1, 1: Print Space$(40) + Print Space$(40) + Locate 2, 15: Print "PLAY AGAIN?" + promt: a$ = Input$(1) + Select Case a$ + Case "Y", "y": GoTo NewGame + Case "N", "n": Def Seg: Exit Sub + Case Else: GoTo promt + End Select + + ABORTGAME: Locate 2, 12: Print "ABORT GAME?(Y/N)": a$ = Input$(1) + Select Case a$ + Case "Y", "y": Locate 2, 12: Print Space$(16): GoTo LOSE + Case "N", "n": Locate 2, 12: Print Space$(16): Return + Case Else: GoTo ABORTGAME + End Select + + LIFEUP: Sound 3000, .9: Sound 3000, .2: Sound 4000, .1 + SCORE = SCORE + DIF: LIVES = LIVES + 1 + If LIVES > 5 Then SLIVES = 4 Else SLIVES = LIVES - 1 + Put (SLIVES * 9, 178), FROG(), PSet: Return + +End Sub + +Rem $STATIC +Sub FrogINTRO + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%LOAD TITLE IMAGES%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + Cls: For X = 0 To 15: Palette X, 0: Next + ReDim title1(1393), title2(1135), title3(1149), title4(1149), title5(353) + Restore FroggerIntroGraphics + For i = 0 To 1393: Read title1(i): Next + For i = 0 To 1135: Read title2(i): Next + For i = 0 To 1149: Read title3(i): Next + For i = 0 To 1149: Read title4(i): Next + For i = 0 To 353: Read title5(i): Next + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%SET PALETTE%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + Restore FroggerIntroPalette + For X = 0 To 15: Read i: Palette X, i: Next + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%SHOW MORPHING TITLE%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + Put (131, 60), title1(), PSet + DELAY 1: Line (131, Y)-(188, 144), 0, BF + Put (131, 60), title2(), PSet + DELAY .05: Line (131, 60)-(188, 144), 0, BF + Put (131, 60), title3(), PSet + DELAY .05: Line (131, 60)-(188, 144), 0, BF + Put (131, 60), title4(), PSet + DELAY .05: Line (131, 60)-(188, 144), 0, BF + Put (131, 88), title5(), PSet + Erase title1, title2, title3, title4, title5 + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%SET STAR PALETTE%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + DELAY 1: Palette 0, 0: Palette 3, 8: Palette 5, 7: Palette 8, 15 + Locate 16, 11: Print "PRESS SPACE TO START" + '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%STAR INIT%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + nstar = 100 + ReDim starX(nstar), starY(nstar), starZ(nstar), OSX(nstar), OSY(nstar) + For X = 0 To nstar + starX(X) = Int(Rnd * 320) - 160 + starY(X) = Int(Rnd * 200) - 100 + starZ(X) = Int(Rnd * 150) + Next + '%%%%%%%%%%%%%%%%%%%%%%%%%%REAL(!) 3D STAR SCROLLER%%%%%%%%%%%%%%%%%%%%%%%%%% + Def Seg = 0 + Do + For X = 0 To nstar + Select Case Point(OSX(X), OSY(X)) + Case 3, 5, 8: PSet (OSX(X), OSY(X)), 0 + End Select + If starZ(X) <= 0 Then + starX(X) = Int(Rnd * 320) - 160 + starY(X) = Int(Rnd * 200) - 100 + starZ(X) = Int(Rnd * 150) + Else + SX = 50 * starX(X) \ starZ(X) + 160 + SY = 50 * starY(X) \ starZ(X) + 100 + c = starZ(X) \ 50 + Select Case c + Case 0: c = 8 + Case 1: c = 5 + Case 2: c = 3 + End Select + If Point(SX, SY) = 0 Then PSet (SX, SY), c + OSX(X) = SX: OSY(X) = SY + starZ(X) = starZ(X) - 1 + End If + Next + Select Case Inp(&H60) + Case &H39: Exit Do + Case &H10: If SPECIAL = 0 Then SPECIAL = 1 + Case &H30: If SPECIAL = 1 Then SPECIAL = 2 + End Select + Loop + Palette: Def Seg + OptScn SPECIAL +End Sub + +Sub NewHiScore (SCORE) + i = 9: Do: i = i - 1: If i = 0 Then Exit Do + If SCORE > HISCORE(i).SCORE Then Exit Do + Loop + + Locate 1, 1: Print "YOU HAVE A NEW HIGH SCORE" + Input "PLEASE GIVE 3 OR LESS INITIALS: ", NAME$ + HISCORE(i).PERSON = NAME$: HISCORE(i).SCORE = SCORE + Open "hiscore.dat" For Binary As #1 + For i = 0 To 9 + ' PUT #1, , HISCORE(i) + Next + Close #1 +End Sub + +Sub OptScn (SPECIAL) + + Cls: LIVES = 5: DIF = 0: D = 0: OT = 40: choose = 1 + If SPECIAL = 2 Then + Do + Color 15 + Locate 1, 1: Print "OPTIONS SCREEN: PRESS ENTER TO EXIT" + If choose = 1 Then Color 4 Else Color 15 + Locate 2, 1: Print "LIVES: "; LIVES + If choose = 2 Then Color 4 Else Color 15 + Locate 3, 1: Print "DIFFICULTY: "; DIF + If choose = 3 Then Color 4 Else Color 15 + Locate 4, 1: Print "TIME: "; OT + If choose = 4 Then Color 4 Else Color 15 + Locate 5, 1: Print "DELAY: "; D / 10; " " + Do: a$ = InKey$: Loop Until a$ <> "" + Select Case a$ + Case Chr$(13): Exit Do + Case Chr$(0) + "K" + Select Case choose + Case 1: LIVES = LIVES - 1 + Case 2: DIF = DIF - 1 + Case 3: OT = OT - 1 + Case 4: D = D - 1 + End Select + Case Chr$(0) + "H" + If choose = 0 Then choose = 4 Else choose = choose - 1 + Case Chr$(0) + "P" + If choose = 4 Then choose = 0 Else choose = choose + 1 + Case Chr$(0) + "M" + Select Case choose + Case 1: LIVES = LIVES + 1 + Case 2: DIF = DIF + 1 + Case 3: OT = OT + 1 + Case 4: D = D + 1 + End Select + End Select + Loop + End If + + Color 15 + Frogger LIVES, DIF, OT, D / 10 +End Sub + +Sub ShowHiScore + Cls + Locate 1, 14: Print "HIGH SCORES": Print + For i = 0 To 9 + a$ = Str$(i + 1): If i < 9 Then a$ = a$ + " " + a$ = a$ + Str$(HISCORE(i).SCORE) + b$ = HISCORE(i).PERSON + Locate i + 3, 7: Print a$, b$ + Next + Sleep + BYE +End Sub + diff --git a/samples/frostbite.md b/samples/frostbite.md new file mode 100644 index 0000000..3f6efaa --- /dev/null +++ b/samples/frostbite.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: FROSTBITE + +**[Frostbite](frostbite/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [frostbite](frostbite.md) + +A clone of Frostbite for the Atari 2600, originally designed by Steve Cartwright and published by... diff --git a/samples/frostbite/img/screenshot.png b/samples/frostbite/img/screenshot.png new file mode 100644 index 0000000..d513615 Binary files /dev/null and b/samples/frostbite/img/screenshot.png differ diff --git a/samples/frostbite/index.md b/samples/frostbite/index.md new file mode 100644 index 0000000..1b4874d --- /dev/null +++ b/samples/frostbite/index.md @@ -0,0 +1,25 @@ +[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: FROSTBITE + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Fellippe Heitor](../fellippe-heitor.md) + +### Description + +```text +A clone of Frostbite for the Atari 2600, originally designed by Steve Cartwright and published by Activision in 1983. Written in QB64. +``` + +### File(s) + +* [frostbite.bas](src/frostbite.bas) +* [frostbite.zip](src/frostbite.zip) + +🔗 [game](../game.md), [frostbite](../frostbite.md) + + +Reference: [github.com](https://github.com/FellippeHeitor/frostbite) diff --git a/samples/frostbite/src/frostbite.bas b/samples/frostbite/src/frostbite.bas new file mode 100644 index 0000000..86670f6 --- /dev/null +++ b/samples/frostbite/src/frostbite.bas @@ -0,0 +1,3220 @@ +'Frosbite Tribute +'A clone of Frostbite for the Atari 2600, originally designed +'by Steve Cartwright and published by Activision in 1983. +' +'Fellippe Heitor / @FellippeHeitor / fellippeheitor@gmail.com +' +' - Beta 1: (November 30th, 2015) +' - Screen layout, with aurora and logo on the bottom. +' - Ripped hero sprites from youtube gameplays. +' - Can move around, jump up and down. Still walks on +' water, though. +' +' - Beta 2: (December 1st, 2015) +' - Primitive ice blocks are around, and our hero moves +' along with them. +' - Blocks are mirrored on the other side when they go +' offscreen. However, until they are reset on screen, +' the mirrored blocks aren't "seen" by the code, yet. +' - Very basic detection of landing safely, to see if +' the hero will drown. +' - Drowning/losing lives. +' - Scores for ice blocks the hero steps on. +' +' - Beta 3: (December 2nd, 2015) +' - Ripped audio effects. Not required for gameplay, though. +' - Added a .MirroredPosition variable to IceRows, which +' now allows the hero to step on any ice block he sees +' fit. +' - When temperature reaches 0 degrees, hero loses a life by +' freezing to death. +' - Moved drawing routines to subprocedures, to make reading +' easier. +' +' - Beta 4: (December 3rd 2015) +' - More code beautification. +' - Spritesheet no longer necessary; sprites are now created +' on the fly with pixel data READ from DATA statements +' (I decided to do so after seeing some code from TrialAndTerror). +' - WE NOW HAVE AN IGLOO!! With every ice block the Hero steps on +' a new block is placed on his brand new igloo. After the igloo +' is finished (that's when the door is placed = 16 ice blocks) +' the Hero must enter the igloo to end the level. +' - You can use SPACEBAR to change ice blocks direction, however +' that'll cost you a piece of your igloo. +' - Upon entering the igloo, the level is complete. Scores are then +' calculated. New sound effects are used for that. +' +' - Beta 5: (December 8th, 2015) +' - Fixed: Temperature timer wasn't reset after setting a new level. +' - Added: Different block types: DOUBLEBLOCK and MOVINGBLOCK, which can +' be seen from level 2 onward. +' - Improved aurora simulation, to better mimick the original game. +' - Ice blocks now look more like in the original game. +' - Creatures (fish, birds, crabs and clams) came to life and the +' hero must now avoid them, except for fish. Fish are good. +' +' - Beta 6 (July 24th, 2016) +' - Fixed a bug that caused the hero to have infinite lives (thanks +' to Luke for pointing that out). +' - Hero earns an extra life every 5,000 points. Lives don't go +' past a total of 9, for reasons of ATARI. :-) +' - Fixed: Ice row widths were being wrongly calculated for DOUBLEBLOCK +' and MOVINGBLOCK. +' - There is now a day and a night. When the night falls and the Hero +' finishes building a block, there'll be the flickering of a light +' source coming from inside the igloo. +' - Sound files have been embedded into the code, so that they are +' saved to disk every time the game is run. No more having to +' download separate files (code adapted from Dav's Qbasic Site, +' as seen here: http://www.qbasicnews.com/dav/files/basfile.bas) +' - Aquatic creatures now actually enter the water. +' +'Intended: +' - Fix random level features after level 9 (must be randomized only +' after a new level is set. +' - Fix bad guys inverting ice row direction when the hero is almost +' falling off (which makes it take much longer for death) +' - Add a bear. +' - Add CRABs and CLAMs +' - Make creatures faster than ice rows. +' - Add crabs/clams paused movement +' - Make constant speed increase. +' +$Resize:Smooth + +$Let INTERNALBUILD = FALSE + +'Game constants: -------------------------------------------------------------- +Const True = -1 +Const False = Not True + +'Block types +Const SINGLEBLOCK = 1 +Const DOUBLEBLOCK = 2 +Const MOVINGBLOCK = 3 + +'Directions +Const MOVINGLEFT = -1 +Const MOVINGRIGHT = 1 +Const STOPPED = 0 + +'Actions +Const WALKING = 1 +Const JUMPINGUP = 2 +Const JUMPINGDOWN = 3 +Const FREEZING = 4 +Const DROWNING = 5 +Const ENTERINGIGLOO = 6 +Const EATINGFISH = 7 + +'Light conditions/Palette selection +Const DAY = 1 +Const NIGHT = 2 + +Const GROUND = 1 +Const SKY = 2 +Const BEAR = 3 + +'Creatures +Const BIRD = 1 +Const FISH = 2 +Const CRAB = 4 +Const CLAM = 8 + +'Colors +Const UnsteppedBlockColor = _RGB32(208, 208, 208) +Const SteppedBlockColor = _RGB32(73, 134, 213) +Const IglooBlockColor = _RGB32(136, 136, 136) +Const LightInsideColor = _RGB32(217, 134, 69) + +'Misc: +Const GAMESTART = -1 +Const NEXTLEVEL = 0 + +Const ONEUPGOAL = 5000 + +Const FIRST = 48 +Const SECOND = 12 +Const THIRD = 3 + +Const HeroStartRow = 95 +Const HeroHeight = 36 +Const HeroWidth = 30 +Const DoorX = 276 +Const MaxSpaceBetween = 15 + +Const InitialTemperature = 45 + +'Type definitions: ------------------------------------------------------------ +Type RowInfo + Position As Integer + MirroredPosition As Integer + Direction As Integer + State As _Byte ' True when row has been stepped on +End Type + +Type CreaturesInfo + Species As Integer + X As Integer + Y As Single + Direction As Integer + Number As Integer + Spacing As Integer + RowWidth As Integer + State As _Byte 'Indicates fish in row (11) or fish eaten (00) as in &B110011 = fish, no fish, fish + Frame As _Byte +End Type + +Type HeroInfo + CurrentRow As Integer + X As Integer + Y As Integer + Direction As Integer + Face As Integer + Action As Integer + Grabbed As _Byte + Frame As _Byte +End Type + +Type LevelInfo + Speed As Single + BlockType As _Byte + CreaturesAllowed As _Byte +End Type + +'Game variables: -------------------------------------------------------------- +Dim Shared ActualLevel As Integer +Dim Shared AnimationStep As Integer +Dim Shared Aurora(1 To 7) As Long +Dim Shared AuroraH As Integer +Dim Shared IceRows(1 To 4) As Integer +Dim Shared Creatures(1 To 4) As CreaturesInfo +Dim Shared CreatureSprite As Long +Dim Shared CreatureWidth(1 To 8) As Integer +Dim Shared CreditsBarH As Integer +Dim Shared CreditsIMG As Long, CreditY As Integer +Dim Shared FishPoints As Integer +Dim Shared FishSprites(1 To 2) As Long +Dim Shared FramesTimer As Integer +Dim Shared GameBG As Long +Dim Shared GameOver As _Bit +Dim Shared GameScreen As Long +Dim Shared GroundH As Integer +Dim Shared Hero As HeroInfo +Dim Shared HeroFreezingSprite As Long +Dim Shared HeroSprites(1 To 4) As Long +Dim Shared BirdSprites(1 To 2) As Long +Dim Shared IceRow(1 To 4) As RowInfo +Dim Shared IglooPieces As Integer +Dim Shared InGame As _Byte +Dim Shared JustLanded As _Bit +Dim Shared LevelComplete As _Bit +Dim Shared Lives As Integer +Dim Shared MainScreen As Long +Dim Shared MaxLevelCreatures As Integer +Dim Shared NextGoal As Long +Dim Shared NewLevelSet As Single +Dim Shared PointsInThisLevel As Integer +Dim Shared RestoreRowsTimer As Single +Dim Shared RowWidth As Single +Dim Shared Safe As Single +Dim Shared SceneryPalette(1 To 2, 1 To 3) As Long +Dim Shared Score As Long +Dim Shared SkyH As Integer +Dim Shared SpaceBetween As Single +Dim Shared Temperature As Integer +Dim Shared TempTimer As Integer +Dim Shared TimeOfDay As Integer +Dim Shared ThisAurora As Long +Dim Shared ThisLevel As Integer +Dim Shared ThisRowColor As Long +Dim Shared UserWantsToQuit As _Byte +Dim Shared WaterH As Integer + +ReDim Shared Levels(0) As LevelInfo +ReDim Shared ThisLevelCreatures(0) As Integer + +Dim i As Long + +'Variables to hold sounds: +Dim Shared JumpSound As Long +Dim Shared BlockSound As Long +Dim Shared DrowningSound As Long +Dim Shared IglooBlockCountSound As Long +Dim Shared ScoreCountSound As Long +Dim Shared CollectFishSound As Long + +'For testing/debugging purposes +$If INTERNALBUILD = TRUE Then + DIM SHARED Frames AS _UNSIGNED LONG + DIM SHARED RunStart AS DOUBLE + RunStart = TIMER +$End If + +'Game setup: ------------------------------------------------------------------ +RestoreData +SetLevel GAMESTART +ScreenSetup +LoadAssets +SpritesSetup +SetTimers +NewLevelSet = 0 + +'Main game loop: -------------------------------------------------------------- +Do + CalculateScores + NewLevelPause + ComposeScenery + DrawIgloo + MoveIceBlocks + MoveCreatures + MoveHero + CheckLanding + CheckCreatures + + UpdateScreen + + If LevelComplete And IglooPieces > 0 Then _Delay .108 + If LevelComplete And IglooPieces = 0 And Temperature > 0 Then _Delay .05 + + ReadKeyboard + If Not LevelComplete Then _Delay .03 +Loop Until UserWantsToQuit +System + +'Game data: ------------------------------------------------------------------- +AuroraPaletteDATA: +Data 207,199,87 +Data 208,161,62 +Data 199,141,54 +Data 210,95,110 +Data 183,101,193 +Data 157,111,224 +Data 120,116,237 + +SceneryPaletteDATA: 'Ground, sky and bear +Data 192,192,192,74,74,74 +Data 23,68,185,0,36,149 +Data 111,111,111,214,214,214 + +IceRowsDATA: +Data 134,173,212,251 + +CreaturesDATA: +Data 30,30,30,30 + +LevelsDATA: +Data 4 +Data 1,1,1 +Data 1,2,3 +Data 1,3,7 +Data 1.5,3,15 + +HeroPalette: +'Total colors, color values (_UNSIGNED LONG) +Data 5,0,4289225241,4291259443,4287072135,4288845861 + +Hero1: +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 111122222222222111111111111111 +Data 111122222222222111111111111111 +Data 111122222222222222211111111111 +Data 111122222222222222211111111111 +Data 222222222222222222211111111111 +Data 222222222222222222211111111111 +Data 222222222222222222222222221111 +Data 222222222222222222222222221111 +Data 222222222222222222222222221111 +Data 222222222222222222222222221111 +Data 222222222222222222222222221111 +Data 111133333333333333333311111111 +Data 111133333333333333333311111111 +Data 111133333333333333333333331111 +Data 111133333333333333333333331111 +Data 111111113333333333333311111111 +Data 111111113333333333333311111111 +Data 111144444444444444444411111111 +Data 111144444444444444444411111111 +Data 111144411114444444444444441111 +Data 111144411114444444444444441111 +Data 111144411114444444444444441111 +Data 111144411111111444444444441111 +Data 111144444441111444444444441111 +Data 111144444441111111144444441111 +Data 111144444444444111144444441111 +Data 111144444444444111144444441111 +Data 111144444444444444444444441111 +Data 111111115555555111155555551111 +Data 111111115555555111155555551111 +Data 111111115555555111155555551111 +Data 111111115555555111155555551111 +Data 555555555555555555555555555555 +Data 555555555555555555555555555555 + +Hero2: +Data 111122222222222111111111111111 +Data 111122222222222111111111111111 +Data 111122222222222222111111111111 +Data 111122222222222222111111111111 +Data 222222222222222222111111111111 +Data 222222222222222222111111111111 +Data 222222222222222222222222221111 +Data 222222222222222222222222221111 +Data 222222222222222222222222221111 +Data 222222222222222222222222221111 +Data 222222222222222222222222221111 +Data 111133333333333333333311111111 +Data 111133333333333333333311111111 +Data 111133333333333333333333331111 +Data 111133333333333333333333331111 +Data 111111133333333333333311111111 +Data 111111133333333333333311111111 +Data 111144444444444444444411111111 +Data 111144444444444444444411111111 +Data 111144411114444444444444441111 +Data 111144411114444444444444441111 +Data 111144411111111444444444441111 +Data 111144411111111444444444441111 +Data 111144444444441111444444441111 +Data 111144444444441111444444441111 +Data 111144444444444444444444441111 +Data 111144444444444444444444441111 +Data 111144444444444444444444441111 +Data 111111111115555555555511111111 +Data 111111111115555555555511111111 +Data 111111111115555555555511111111 +Data 111111111115555555555511111111 +Data 111111111115555555555511111111 +Data 111111111115555555555511111111 +Data 555555555555555555555555555555 +Data 555555555555555555555555555555 + +Hero3: +Data 111112222222222211111111111111 +Data 111112222222222211111111111111 +Data 111112222222222222221111111111 +Data 111112222222222222221111111111 +Data 122222222222222222221111111111 +Data 122222222222222222221111111111 +Data 122222222222222222222222222111 +Data 122222222222222222222222222111 +Data 122222222222222222222222222111 +Data 122222222222222222222222222111 +Data 133333333333333333333333333111 +Data 133333333333333333333333333111 +Data 111113333333333333333333333111 +Data 111113333333333333333333111111 +Data 111111113333333333333333111111 +Data 111114444444444444444444111111 +Data 111114444444444444444444111111 +Data 111114444111444444444444444411 +Data 111114444111444444444444444411 +Data 111114444111111111111111444411 +Data 111114444111111111111111444411 +Data 111114444444444444444444444411 +Data 111114444444444444444444444411 +Data 111114444444444444444444444411 +Data 111114444444444444444444444411 +Data 111111111111555551115555111111 +Data 111115555555555555555555555511 +Data 111115555555555555555555555511 +Data 111115555555555555555555555511 +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 + +Hero4: +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 111111111111222222111111111111 +Data 111111111222222222222111111111 +Data 111111111222222222222111111111 +Data 111111111222222222222111111111 +Data 111111111222222222222111111111 +Data 111111111222222222222111111111 +Data 111222222222222222222222221111 +Data 111222222222222222222222221111 +Data 111222222222222222222222221111 +Data 111222222222222222222222221111 +Data 111222222222222222222222221111 +Data 111111333333333333333331111111 +Data 111111333333333333333331111111 +Data 111111333333333333333331111111 +Data 111111333333333333333331111111 +Data 111111333333111113333331111111 +Data 111111333333111113333331111111 +Data 111111333333333333333334441111 +Data 111111111444444444444114441111 +Data 111114444444444444444114441111 +Data 111444444444111444444114441111 +Data 111444444444111444444444441111 +Data 111444444444444444444444441111 +Data 111444444444444444444444441111 +Data 111444111444444444444444441111 +Data 111444111444111444444441111111 +Data 111444111444111444444441111111 +Data 111444111444444444444441111111 +Data 111111111555555555555111111111 +Data 111111111555555555555111111111 +Data 111111111555555555555111111111 +Data 111111111555111115555111111111 +Data 111555555555555555555555551111 +Data 111555555555555555555555551111 + +BirdPalette: +Data 2,0,4286877948 + +Bird1: +Data 111111111111111111111111111111 +Data 111111111111111111111122211111 +Data 111111111111111111111122211111 +Data 111111111111111111222222222211 +Data 111111111111111111222222222211 +Data 122222222222222222222211111111 +Data 122222222222222222222211111111 +Data 111122222222222222111111111111 +Data 111111122222222222111111111111 +Data 111111122222221111111111111111 +Data 111122222222221111111111111111 +Data 111122222221111111111111111111 +Data 122222222221111111111111111111 +Data 122222221111111111111111111111 +Data 122222221111111111111111111111 + +Bird2: +Data 111111111111111111111111111111 +Data 122222222222111111112222111111 +Data 122222222222111111112222111111 +Data 111111111222222211112222222211 +Data 111111111222222211112222222211 +Data 111111111222222211112222222211 +Data 122222222222222222222222111111 +Data 122222222222222222222222111111 +Data 111112222222222222221111111111 +Data 111112222222222222221111111111 +Data 111112222222222222221111111111 +Data 111111111222222211111111111111 +Data 111111111222222211111111111111 +Data 111112222111111111111111111111 +Data 111112222111111111111111111111 + +FishPalette: +Data 2,0,4285518447 + +Fish1: +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 122221111122222222221111111111 +Data 122221111122222222221111111111 +Data 122222221111122222222221111111 +Data 122222222222222222222222221111 +Data 111122222222222222221122221111 +Data 111111112222222222222222221111 +Data 111111112222222222222222221111 +Data 111111112222222222222222221111 +Data 111122222222222222222221111111 +Data 122222222222222222222222221111 +Data 122222221111122222222222221111 +Data 122221111122222222221111111111 +Data 122221111122222222221111111111 + +Fish2: +Data 111111111111111111111111111111 +Data 111111111111111111111111111111 +Data 111111111111122222111111111111 +Data 111111111111122222111111111111 +Data 222222211122222222222211111111 +Data 222222222222222222222222211111 +Data 222222222222222222111222211111 +Data 111111222222222222222222211111 +Data 111111222222222222222222211111 +Data 111111222222222222222222211111 +Data 222222222222222222222222211111 +Data 222222222222222222222222211111 +Data 222222211122222222222211111111 +Data 111111111111122222111111111111 +Data 111111111111122222111111111111 + +'------------------------------------------------------------------------------ +'Subprocedures start here: +'------------------------------------------------------------------------------ +Sub NewLevelPause + If InGame Then Exit Sub + If NewLevelSet <> 0 Then + If Timer - NewLevelSet > 1 Then + InGame = True + Timer(TempTimer) On + NewLevelSet = 0 + End If + End If +End Sub + +'------------------------------------------------------------------------------ +Sub ComposeScenery + Static TemperatureBlink As Integer + + 'Game layers: Background, Aurora, Credits (bottom line) + _PutImage , GameBG, GameScreen + _PutImage (0, SkyH - AuroraH / 2), ThisAurora, GameScreen + _PutImage (0, _Height(GameScreen) - CreditsBarH), CreditsIMG, GameScreen, (0, CreditY)-Step(_Width(CreditsIMG), CreditsBarH) + + 'Score, temperature and lives: + Color _RGB32(126, 148, 254), _RGBA32(0, 0, 0, 0) + _PrintString (72 - (Len(TRIM$(Score)) * _FontWidth), 2), TRIM$(Score) + + Select Case Temperature + Case 1 TO 5 + TemperatureBlink = TemperatureBlink + 1 + Select Case TemperatureBlink + Case 7 TO 14 + If Not LevelComplete And Not GameOver Then + Color _RGBA32(0, 0, 0, 0), _RGBA32(0, 0, 0, 0) + End If + Case 15 + TemperatureBlink = 0 + End Select + Case Else + TemperatureBlink = 0 + End Select + _PrintString (40 - (Len(TRIM$(Temperature)) * _FontWidth), 14), TRIM$(Temperature) + Chr$(248) + + If Lives > 0 Then _PrintString (72 - (Len(TRIM$(Lives)) * _FontWidth), 14), TRIM$(Lives) + + '$IF INTERNALBUILD = TRUE THEN + ' 'Variable watch on screen, for debugging purposes: + ' COLOR _RGB32(0, 0, 0), _RGBA32(255, 255, 255, 200) + ' i = 0 + ' crd$ = "Frames=" + TRIM$(Frames) + " FPS=" + TRIM$(_CEIL(Frames / (TIMER - RunStart))): _PRINTSTRING (_WIDTH - (LEN(crd$) * _FONTWIDTH), i), crd$ + + ' i = i + 8 + ' crd$ = "ThisLevel=" + TRIM$(ThisLevel): _PRINTSTRING (_WIDTH - (LEN(crd$) * _FONTWIDTH), i), crd$ + + ' i = i + 8 + ' crd$ = "ActualLevel=" + TRIM$(ActualLevel): _PRINTSTRING (_WIDTH - (LEN(crd$) * _FONTWIDTH), i), crd$ + + ' i = i + 8 + ' crd$ = "PointsInThisLevel=" + TRIM$(PointsInThisLevel): _PRINTSTRING (_WIDTH - (LEN(crd$) * _FONTWIDTH), i), crd$ + + ' 'FOR j = 1 TO 4 + ' ' i = i + 8 + ' ' crd$ = "Creatures(" + TRIM$(j) + ").species=" + TRIM$(Creatures(j).Species): _PRINTSTRING (_WIDTH - (LEN(crd$) * _FONTWIDTH), i), crd$ + ' 'NEXT j + '$END IF + +End Sub + +'------------------------------------------------------------------------------ +Sub DrawIgloo + Dim IglooBlink As _Bit + Dim IglooDoorColor As _Unsigned Long + + If IglooPieces = 0 Then Exit Sub + + Select EveryCase IglooPieces + Case Is > 0 + Line (232, 57)-Step(32, -9), IglooBlockColor, BF + Case Is > 1 + Line (264, 57)-Step(32, -9), IglooBlockColor, BF + Case Is > 2 + Line (296, 57)-Step(32, -9), IglooBlockColor, BF + Case Is > 3 + Line (328, 57)-Step(32, -9), IglooBlockColor, BF + Case Is > 4 + Line (328, 48)-Step(32, -9), IglooBlockColor, BF + Case Is > 5 + Line (296, 48)-Step(32, -9), IglooBlockColor, BF + Case Is > 6 + Line (264, 48)-Step(32, -9), IglooBlockColor, BF + Case Is > 7 + Line (232, 48)-Step(32, -9), IglooBlockColor, BF + Case Is > 8 + Line (232, 39)-Step(32, -9), IglooBlockColor, BF + Case Is > 9 + Line (264, 39)-Step(32, -9), IglooBlockColor, BF + Case Is > 10 + Line (296, 39)-Step(32, -9), IglooBlockColor, BF + Case Is > 11 + Line (328, 39)-Step(32, -9), IglooBlockColor, BF + Case Is > 12 + Line (248, 31)-Step(49, -9), IglooBlockColor, BF + Case Is > 13 + Line (297, 31)-Step(49, -9), IglooBlockColor, BF + Case Is > 14 + Line (265, 25)-Step(65, -9), IglooBlockColor, BF + Case Is > 15 + IglooDoorColor = _RGB32(0, 0, 0) + If TimeOfDay = NIGHT Then + Randomize Timer + IglooBlink = _Ceil(Rnd * 2) - 2 + If IglooBlink Then + IglooDoorColor = LightInsideColor + End If + End If + Line (276, 57)-Step(35, -16), IglooDoorColor, BF + Line (281, 43)-Step(25, -5), IglooDoorColor, BF + End Select +End Sub + +'------------------------------------------------------------------------------ +Sub MoveIceBlocks + Dim i As Integer + Dim j As Integer + Dim x As Integer + Dim x.m As Integer + Dim BlockLines As Integer + + 'Ice blocks: + For i = 1 To 4 + If Not IceRow(i).State Then ThisRowColor = UnsteppedBlockColor Else ThisRowColor = SteppedBlockColor + + If InGame And Hero.Action <> DROWNING And Hero.Action <> FREEZING And Hero.Action <> EATINGFISH And Not LevelComplete Then + IceRow(i).Position = IceRow(i).Position + Levels(PointsInThisLevel).Speed * IceRow(i).Direction + If IceRow(i).Direction = MOVINGRIGHT Then + If IceRow(i).Position >= _Width(GameScreen) Then + IceRow(i).Position = 0 + IceRow(i).MirroredPosition = 0 + End If + End If + If IceRow(i).Direction = MOVINGLEFT Then + If IceRow(i).Position < -RowWidth Then + IceRow(i).Position = _Width(GameScreen) - 1 - RowWidth + IceRow(i).MirroredPosition = 0 + End If + End If + End If + + x = IceRow(i).Position + + Select Case Levels(ActualLevel).BlockType + Case SINGLEBLOCK + 'Draw normal blocks + For j = -8 To 8 + BlockLines = j + _Ceil(Rnd(j) * 6) + Line (x + BlockLines, IceRows(i) - j)-Step(HeroWidth * 2, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 3.5, IceRows(i) - j)-Step(HeroWidth * 2, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 7, IceRows(i) - j)-Step(HeroWidth * 2, 0), ThisRowColor + Next j + + If IceRow(i).Direction = MOVINGLEFT Then + If IceRow(i).Position < 0 Then + IceRow(i).MirroredPosition = _Width(GameScreen) + IceRow(i).Position + End If + Else + If IceRow(i).Position + HeroWidth * 7 + HeroWidth * 2 > _Width(GameScreen) Then + IceRow(i).MirroredPosition = -_Width(GameScreen) + IceRow(i).Position + End If + End If + + 'Draw mirrored blocks + If IceRow(i).MirroredPosition Then + x = IceRow(i).MirroredPosition + For j = -8 To 8 + BlockLines = j + _Ceil(Rnd(j) * 6) + Line (x + BlockLines, IceRows(i) - j)-Step(HeroWidth * 2, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 3.5, IceRows(i) - j)-Step(HeroWidth * 2, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 7, IceRows(i) - j)-Step(HeroWidth * 2, 0), ThisRowColor + Next j + End If + Case DOUBLEBLOCK + 'Draw normal blocks + For j = -8 To 8 + BlockLines = j + _Ceil(Rnd(j) * 6) + Line (x + BlockLines, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 1.5, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 3, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 4.5, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 6, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 7.5, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Next j + + If IceRow(i).Direction = MOVINGLEFT Then + If IceRow(i).Position < 0 Then + IceRow(i).MirroredPosition = _Width(GameScreen) + IceRow(i).Position + End If + Else + If IceRow(i).Position + HeroWidth * 7 + HeroWidth * 2 > _Width(GameScreen) Then + IceRow(i).MirroredPosition = -_Width(GameScreen) + IceRow(i).Position + End If + End If + + 'Draw mirrored blocks + If IceRow(i).MirroredPosition Then + x = IceRow(i).MirroredPosition + For j = -8 To 8 + BlockLines = j + _Ceil(Rnd(j) * 6) + Line (x + BlockLines, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 1.5, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 3, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 4.5, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 6, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 7.5, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Next j + End If + Case MOVINGBLOCK + 'Draw normal blocks + For j = -8 To 8 + BlockLines = j + _Ceil(Rnd(j) * 6) + Line (x + BlockLines + SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 1.5 - SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 3 + SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 4.5 - SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 6 + SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 7.5 - SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Next j + + If IceRow(i).Direction = MOVINGLEFT Then + If IceRow(i).Position < 0 Then + IceRow(i).MirroredPosition = _Width(GameScreen) + IceRow(i).Position + End If + Else + If IceRow(i).Position + HeroWidth * 7 + HeroWidth * 2 > _Width(GameScreen) Then + IceRow(i).MirroredPosition = -_Width(GameScreen) + IceRow(i).Position + End If + End If + + 'Draw mirrored blocks + If IceRow(i).MirroredPosition Then + x = IceRow(i).MirroredPosition + For j = -8 To 8 + BlockLines = j + _Ceil(Rnd(j) * 6) + Line (x + BlockLines + SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 1.5 - SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 3 + SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 4.5 - SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 6 + SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Line (x + BlockLines + HeroWidth * 7.5 - SpaceBetween, IceRows(i) - j)-Step(HeroWidth, 0), ThisRowColor + Next j + End If + End Select + Next i +End Sub + +'------------------------------------------------------------------------------ +Sub MoveCreatures + Dim i As Integer + Dim X As Integer + Static Floating As Single + Static FloatStep As Single + + If Not InGame Then Exit Sub + + If FloatStep = 0 Then FloatStep = .1 + + 'Four rows of creatures: + For i = 1 To 4 + If Hero.Action <> DROWNING And Hero.Action <> FREEZING And Hero.Action <> EATINGFISH And Not LevelComplete Then + If Hero.Grabbed And i = Hero.CurrentRow Then + If Creatures(i).Direction = MOVINGRIGHT Then + If Creatures(i).X < _Width(GameScreen) - CreatureWidth(Creatures(i).Species) Then + Creatures(i).X = Creatures(i).X + (Levels(PointsInThisLevel).Speed * Creatures(i).Direction) + Creatures(i).Direction + End If + ElseIf Creatures(i).Direction = MOVINGLEFT Then + If Creatures(i).X > 0 Then + Creatures(i).X = Creatures(i).X + (Levels(PointsInThisLevel).Speed * Creatures(i).Direction) + Creatures(i).Direction + End If + End If + Else + Creatures(i).X = Creatures(i).X + (Levels(PointsInThisLevel).Speed * Creatures(i).Direction) + Creatures(i).Direction + End If + + Floating = Floating + FloatStep + If Floating > HeroHeight / 4 Then FloatStep = -.1 + If Floating <= 0 Then FloatStep = .1 + + 'Birds fly linearly. Other creatures are in water, and so they float: + If Creatures(i).Species <> BIRD Then Creatures(i).Y = Creatures(i).Y + FloatStep + + 'Once the creature row leaves screen, it is reset: + If Creatures(i).Direction = MOVINGRIGHT Then + If Creatures(i).X >= _Width(GameScreen) Then + Creatures(i).Species = 0 + End If + End If + If Creatures(i).Direction = MOVINGLEFT Then + If Creatures(i).X < -Creatures(i).RowWidth Then + Creatures(i).Species = 0 + End If + End If + End If + + 'if a creature has not yet been set (or just been cleared) for this row, + 'we'll generate a new one: + If Creatures(i).Species = 0 Then MakeCreature i + + X = Creatures(i).X + + 'IF X < -Creatures(i).RowWidth THEN EXIT SUB + + Select Case Creatures(i).Species + Case BIRD: CreatureSprite = BirdSprites(Creatures(i).Frame) + Case FISH: CreatureSprite = FishSprites(Creatures(i).Frame) + Case CRAB: CreatureSprite = 0: text$ = "CRAB" + Case CLAM: CreatureSprite = 0: text$ = "CLAM" + End Select + + 'First creature in row is always drawn at the same position: + If Creatures(i).State And FIRST Then + If CreatureSprite < -1 Then + If Creatures(i).Direction = MOVINGRIGHT Then + _PutImage (X, Creatures(i).Y), CreatureSprite, GameScreen, (0, IIF(Creatures(i).Species <> BIRD, -Floating, 0))-Step(_Width(CreatureSprite), _Height(CreatureSprite)) + Else + _PutImage (X + CreatureWidth(Creatures(i).Species), Creatures(i).Y)-Step(-CreatureWidth(Creatures(i).Species) - 1, _Height(CreatureSprite) - 1), CreatureSprite, GameScreen, (0, IIF(Creatures(i).Species <> BIRD, -Floating, 0))-Step(_Width(CreatureSprite), _Height(CreatureSprite)) + End If + Else + Line (X, Creatures(i).Y)-Step(CreatureWidth(Creatures(i).Species), 8), _RGB32(255, 0, 0), BF + _PrintString (X, Creatures(i).Y), text$ + End If + End If + + 'Second creature in row (position will be affected by Creatures().Spacing): + If Creatures(i).Number > 1 And (Creatures(i).State And SECOND) Then + If CreatureSprite < -1 Then + If Creatures(i).Direction = MOVINGRIGHT Then + _PutImage (X + CreatureWidth(Creatures(i).Species) + Creatures(i).Spacing, Creatures(i).Y), CreatureSprite, GameScreen, (0, IIF(Creatures(i).Species <> BIRD, -Floating, 0))-Step(_Width(CreatureSprite), _Height(CreatureSprite)) + Else + _PutImage (X + CreatureWidth(Creatures(i).Species) + Creatures(i).Spacing + CreatureWidth(Creatures(i).Species), Creatures(i).Y)-Step(-CreatureWidth(Creatures(i).Species) - 1, _Height(CreatureSprite) - 1), CreatureSprite, GameScreen, (0, IIF(Creatures(i).Species <> BIRD, -Floating, 0))-Step(_Width(CreatureSprite), _Height(CreatureSprite)) + End If + Else + Line (X + CreatureWidth(Creatures(i).Species) + Creatures(i).Spacing, Creatures(i).Y)-Step(CreatureWidth(Creatures(i).Species), 8), _RGB32(255, 0, 0), BF + _PrintString (X + CreatureWidth(Creatures(i).Species) + Creatures(i).Spacing, Creatures(i).Y), text$ + End If + End If + + 'Third creature in row (always at the same spot) + If Creatures(i).Number = 3 And (Creatures(i).State And THIRD) Then + If CreatureSprite < -1 Then + If Creatures(i).Direction = MOVINGRIGHT Then + _PutImage (X + CreatureWidth(Creatures(i).Species) * 2 + Creatures(i).Spacing * 2, Creatures(i).Y), CreatureSprite, GameScreen, (0, IIF(Creatures(i).Species <> BIRD, -Floating, 0))-Step(_Width(CreatureSprite), _Height(CreatureSprite)) + Else + _PutImage (X + CreatureWidth(Creatures(i).Species) * 2 + Creatures(i).Spacing * 2 + CreatureWidth(Creatures(i).Species), Creatures(i).Y)-Step(-CreatureWidth(Creatures(i).Species) - 1, _Height(CreatureSprite) - 1), CreatureSprite, GameScreen, (0, IIF(Creatures(i).Species <> BIRD, -Floating, 0))-Step(_Width(CreatureSprite), _Height(CreatureSprite)) + End If + Else + Line (X + CreatureWidth(Creatures(i).Species) * 2 + Creatures(i).Spacing * 2, Creatures(i).Y)-Step(CreatureWidth(Creatures(i).Species), 8), _RGB32(255, 0, 0), BF + _PrintString (X + CreatureWidth(Creatures(i).Species) * 2 + Creatures(i).Spacing * 2, Creatures(i).Y), text$ + End If + End If + Next i +End Sub + +'------------------------------------------------------------------------------ +Sub MakeCreature (RowNumber) + 'Randomly selects a new creature from the current level's array + Dim NewCreature As Integer + + Randomize Timer + NewCreature = _Ceil(Rnd * MaxLevelCreatures) + Creatures(RowNumber).Species = ThisLevelCreatures(NewCreature) + + Do + Creatures(RowNumber).Direction = Int(Rnd * 3) - 1 + Loop While Creatures(RowNumber).Direction = 0 + + If ActualLevel <= 2 Then + Creatures(RowNumber).Number = ActualLevel + Else + Creatures(RowNumber).Number = _Ceil(Rnd * 3) + End If + + Select Case Creatures(RowNumber).Number + Case 2: Creatures(RowNumber).Spacing = HeroWidth * 2.5 + Case 3: Creatures(RowNumber).Spacing = HeroWidth * 1 + End Select + + Creatures(RowNumber).RowWidth = (Creatures(RowNumber).Spacing + CreatureWidth(Creatures(RowNumber).Species) * Creatures(RowNumber).Number) + + Select Case Creatures(RowNumber).Direction + Case MOVINGRIGHT + Creatures(RowNumber).X = -Creatures(RowNumber).RowWidth - _Ceil(Rnd * 100) + Case MOVINGLEFT + Creatures(RowNumber).X = _Width(GameScreen) + _Ceil(Rnd * 100) + End Select + + If Creatures(RowNumber).Species = BIRD Then + Creatures(RowNumber).Y = IceRows(RowNumber) - HeroHeight + 6 + Else + Creatures(RowNumber).Y = IceRows(RowNumber) - HeroHeight + 6 + End If + + 'Make all creatures in row visible: + Creatures(RowNumber).State = 0 Xor FIRST Xor SECOND Xor THIRD + Creatures(RowNumber).Frame = 1 +End Sub + +'------------------------------------------------------------------------------ +Sub MoveHero + 'Hero: + If InGame Then + + If Not Hero.Grabbed Then + Hero.X = Hero.X + Hero.Direction * 3 + If Hero.CurrentRow > 0 And (Hero.Action = STOPPED Or Hero.Action = WALKING) Then + Hero.X = Hero.X + IceRow(Hero.CurrentRow).Direction * Levels(PointsInThisLevel).Speed + End If + Else + If (Hero.Action = STOPPED Or Hero.Action = WALKING) And Hero.Action <> EATINGFISH Then + Hero.X = Hero.X + Creatures(Hero.CurrentRow).Direction * Levels(PointsInThisLevel).Speed + Creatures(Hero.CurrentRow).Direction + End If + End If + + 'Hero can't go past a certain point to the left of the screen if WALKING. + 'However, if he jumps from an ice block, he can stand there: + 'IF Hero.CurrentRow = 0 AND Hero.Action = WALKING AND Hero.Direction = MOVINGLEFT THEN + ' IF Hero.X > HeroWidth + 3 THEN + ' Hero.X = Hero.X + Hero.Direction * 3 + ' END IF + 'ELSEIF Hero.CurrentRow = 0 AND Hero.Action = WALKING AND Hero.Direction = MOVINGRIGHT THEN + 'ELSEIF Hero.Action = JUMPINGUP OR Hero.Action = JUMPINGDOWN THEN + 'END IF + + Select Case Hero.Action + Case JUMPINGUP + If Hero.CurrentRow = 0 Then Hero.Action = WALKING Else AnimationStep = AnimationStep + 1 + Select Case AnimationStep + Case 1 TO 6 + Hero.Y = Hero.Y - 8 + Hero.Frame = 3 + Case 10 TO 12 + Hero.Y = Hero.Y + 3 + Hero.Frame = 1 + Case 13 + Hero.CurrentRow = Hero.CurrentRow - 1 + JustLanded = True + Hero.Action = STOPPED: Hero.Direction = Hero.Action + End Select + Case JUMPINGDOWN + If Hero.CurrentRow = 4 Then Hero.Action = WALKING Else AnimationStep = AnimationStep + 1 + Select Case AnimationStep + Case 1 TO 3 + Hero.Y = Hero.Y - 3 + Hero.Frame = 3 + Case 7 TO 12 + Hero.Y = Hero.Y + 8 + Hero.Frame = 1 + Case 13 + Hero.CurrentRow = Hero.CurrentRow + 1 + JustLanded = True + Hero.Action = STOPPED: Hero.Direction = Hero.Action + End Select + Case ENTERINGIGLOO + AnimationStep = AnimationStep + 1 + Select Case AnimationStep + Case 1 TO 6 + Hero.Y = Hero.Y - 8 + Hero.Frame = 3 + _PutImage (Hero.X, Hero.Y - HeroHeight + AnimationStep)-Step(HeroWidth, HeroHeight - AnimationStep), HeroSprites(Hero.Frame), GameScreen, (0, 0 + AnimationStep * 6)-(HeroWidth, HeroHeight) + Case 20 + LevelComplete = True + End Select + Case DROWNING + AnimationStep = AnimationStep + 1 + Select Case AnimationStep + Case 1 TO 5, 11 TO 15, 21 TO 25, 30 TO 35 + _PutImage (Hero.X, Hero.Y - HeroHeight + AnimationStep)-Step(HeroWidth, HeroHeight - AnimationStep), HeroSprites(Hero.Frame), GameScreen, (0, 0)-(HeroWidth, HeroHeight - AnimationStep) + Case 6 TO 10, 16 TO 20, 26 TO 29 + _PutImage (Hero.X + HeroWidth, Hero.Y - HeroHeight + AnimationStep)-Step(-HeroWidth, HeroHeight - AnimationStep), HeroSprites(Hero.Frame), GameScreen, (0, 0)-(HeroWidth, HeroHeight - AnimationStep) + Case 36 + If Lives <= -1 Then + GameOver = True + InGame = False + Else + Timer(TempTimer) On + SetLevel ThisLevel + End If + End Select + Case FREEZING + AnimationStep = AnimationStep + 1 + 'Recolor the hero sprite to show it's freezing + _Dest HeroFreezingSprite + For i = 0 To _Width(HeroFreezingSprite) - 1 + If AnimationStep >= _Height(HeroFreezingSprite) Then Exit For + If Point(i, AnimationStep) <> _RGBA32(0, 0, 0, 0) Then + PSet (i, AnimationStep), _RGB32(0, 150 - AnimationStep * 3, 219 + AnimationStep) + End If + Next i + _Dest GameScreen + Select Case AnimationStep + Case 1 TO 5, 11 TO 39 + _PutImage (Hero.X, Hero.Y - HeroHeight)-Step(HeroWidth - 1, HeroHeight - 1), HeroFreezingSprite, GameScreen + Case 6 TO 10 + _PutImage (Hero.X + HeroWidth, Hero.Y - HeroHeight)-Step(-HeroWidth - 1, HeroHeight - 1), HeroFreezingSprite, GameScreen + Case 40 + _FreeImage HeroFreezingSprite + If Lives <= -1 Then + GameOver = True + InGame = False + Else + Temperature = InitialTemperature + Timer(TempTimer) On + SetLevel ThisLevel + End If + End Select + Case EATINGFISH + If FishPoints Then + Score = Score + 50 + FishPoints = FishPoints - 50 + Else + Hero.Action = STOPPED + End If + Case STOPPED + Hero.Frame = 1 + End Select + + If Hero.X + HeroWidth > _Width Then Hero.X = _Width - HeroWidth + If Hero.X < 0 Then Hero.X = 0 + End If + + Select Case Hero.Face + Case MOVINGRIGHT + _PutImage (Hero.X, Hero.Y - HeroHeight), HeroSprites(Hero.Frame), GameScreen + Case MOVINGLEFT + _PutImage (Hero.X + HeroWidth, Hero.Y - HeroHeight)-Step(-HeroWidth - 1, HeroHeight - 1), HeroSprites(Hero.Frame), GameScreen + End Select +End Sub + +'------------------------------------------------------------------------------ +Sub CheckLanding + 'Check to see if the hero landed safely: + Dim i As Integer + Dim X As Integer + Dim m.X As Integer + + If Hero.CurrentRow > 0 And (Hero.Action = STOPPED Or Hero.Action = WALKING) Then + Safe = False + X = IceRow(Hero.CurrentRow).Position + m.X = IceRow(Hero.CurrentRow).MirroredPosition + Select Case Levels(ActualLevel).BlockType + Case SINGLEBLOCK + If Hero.X + HeroWidth > X And Hero.X < X + HeroWidth * 2 Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X And Hero.X < m.X + HeroWidth * 2 Then + Safe = True + ElseIf Hero.X + HeroWidth > X + HeroWidth * 3.5 And Hero.X < X + HeroWidth * 3.5 + HeroWidth * 2 Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X + HeroWidth * 3.5 And Hero.X < m.X + HeroWidth * 3.5 + HeroWidth * 2 Then + Safe = True + ElseIf Hero.X + HeroWidth > X + HeroWidth * 7 And Hero.X < X + HeroWidth * 7 + HeroWidth * 2 Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X + HeroWidth * 7 And Hero.X < m.X + HeroWidth * 7 + HeroWidth * 2 Then + Safe = True + End If + Case DOUBLEBLOCK + If Hero.X + HeroWidth > X And Hero.X < X + RowWidth Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X And Hero.X < m.X + RowWidth Then + Safe = True + End If + Case MOVINGBLOCK + If Hero.X + HeroWidth > X + BlockLines + SpaceBetween And Hero.X < X + BlockLines + SpaceBetween + HeroWidth Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X + BlockLines + SpaceBetween And Hero.X < m.X + BlockLines + SpaceBetween + HeroWidth Then + Safe = True + ElseIf Hero.X + HeroWidth > X + BlockLines + HeroWidth * 1.5 - SpaceBetween And Hero.X < X + BlockLines + HeroWidth * 1.5 - SpaceBetween + HeroWidth Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X + BlockLines + HeroWidth * 1.5 - SpaceBetween And Hero.X < m.X + BlockLines + HeroWidth * 1.5 - SpaceBetween + HeroWidth Then + Safe = True + ElseIf Hero.X + HeroWidth > X + BlockLines + HeroWidth * 3 + SpaceBetween And Hero.X < X + BlockLines + HeroWidth * 3 + SpaceBetween + HeroWidth Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X + BlockLines + HeroWidth * 3 + SpaceBetween And Hero.X < m.X + BlockLines + HeroWidth * 3 + SpaceBetween + HeroWidth Then + Safe = True + ElseIf Hero.X + HeroWidth > X + BlockLines + HeroWidth * 4.5 - SpaceBetween And Hero.X < X + BlockLines + HeroWidth * 4.5 - SpaceBetween + HeroWidth Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X + BlockLines + HeroWidth * 4.5 - SpaceBetween And Hero.X < m.X + BlockLines + HeroWidth * 4.5 - SpaceBetween + HeroWidth Then + Safe = True + ElseIf Hero.X + HeroWidth > X + BlockLines + HeroWidth * 6 + SpaceBetween And Hero.X < X + BlockLines + HeroWidth * 6 + SpaceBetween + HeroWidth Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X + BlockLines + HeroWidth * 6 + SpaceBetween And Hero.X < m.X + BlockLines + HeroWidth * 6 + SpaceBetween + HeroWidth Then + Safe = True + ElseIf Hero.X + HeroWidth > X + BlockLines + HeroWidth * 7.5 - SpaceBetween And Hero.X < X + BlockLines + HeroWidth * 7.5 - SpaceBetween + HeroWidth Then + Safe = True + ElseIf m.X And Hero.X + HeroWidth > m.X + BlockLines + HeroWidth * 7.5 - SpaceBetween And Hero.X < m.X + BlockLines + HeroWidth * 7.5 - SpaceBetween + HeroWidth Then + Safe = True + End If + End Select + If Safe Then + Safe = False + If IceRow(Hero.CurrentRow).State = False And JustLanded Then + JustLanded = False + If BlockSound Then _SndPlayCopy BlockSound + If IglooPieces < 16 Then IglooPieces = IglooPieces + 1 + IceRow(Hero.CurrentRow).State = True + RestoreRowsTimer = Timer + Score = Score + PointsInThisLevel * 10 + End If + Else + If Hero.Action <> DROWNING Then + If DrowningSound Then _SndPlayCopy DrowningSound + Timer(TempTimer) Off + Hero.Frame = 4 + Hero.Action = DROWNING + Hero.Face = STOPPED + Hero.Direction = STOPPED + Lives = Lives - 1 + AnimationStep = 0 + End If + End If + End If +End Sub + +'------------------------------------------------------------------------------ +Sub CheckCreatures + Dim i As Integer + Dim j As Integer + Dim X As Integer + Dim Touched As _Bit + Dim WhichCreature As _Byte + Dim EvalCreatures(1 To 3) As Integer + + If Hero.Grabbed Or Hero.CurrentRow = 0 Or (Hero.Action = JUMPINGUP Or Hero.Action = JUMPINGDOWN Or Hero.Action = DROWNING Or Hero.Action = FREEZING) Then Exit Sub + i = Hero.CurrentRow + + If Creatures(i).Species = 0 Then Exit Sub + + X = Creatures(i).X + + EvalCreatures(1) = Creatures(i).X + EvalCreatures(2) = X + CreatureWidth(Creatures(i).Species) + Creatures(i).Spacing + EvalCreatures(3) = X + CreatureWidth(Creatures(i).Species) * 2 + Creatures(i).Spacing * 2 + + 'Check for first creature in row, left to right: + If (Creatures(i).State And FIRST) And Hero.X + HeroWidth > EvalCreatures(1) And Hero.X < EvalCreatures(1) + CreatureWidth(Creatures(i).Species) Then + Touched = True + WhichCreature = FIRST + End If + + 'Check for second creature in row, left to right: + If Creatures(i).Number > 1 Then + If (Creatures(i).State And SECOND) And Hero.X + HeroWidth > EvalCreatures(2) And Hero.X < EvalCreatures(2) + CreatureWidth(Creatures(i).Species) Then + Touched = True + WhichCreature = SECOND + End If + End If + + 'Check for second creature in row, left to right: + If Creatures(i).Number = 3 Then + If (Creatures(i).State And THIRD) And Hero.X + HeroWidth > EvalCreatures(3) And Hero.X < EvalCreatures(3) + CreatureWidth(Creatures(i).Species) Then + Touched = True + WhichCreature = THIRD + End If + End If + + If Touched Then + If Creatures(i).Species = FISH Then + Creatures(i).State = Creatures(i).State Xor WhichCreature + If Hero.Action <> EATINGFISH Then + If CollectFishSound Then _SndPlayCopy CollectFishSound + Hero.Frame = 1 + Hero.Action = EATINGFISH + Hero.Direction = STOPPED + AnimationStep = 0 + FishPoints = 200 + End If + Else + Hero.Grabbed = True + If IceRow(i).Direction = Creatures(i).Direction Then + InvertCurrentIceRow + End If + End If + End If +End Sub + +'------------------------------------------------------------------------------ +Sub UpdateScreen + _PutImage , GameScreen, MainScreen + _Display + $If INTERNALBUILD Then + Frames = Frames + 1 + $End If +End Sub + +'------------------------------------------------------------------------------ +Sub ReadKeyboard + Dim k As Integer + + k = _KeyHit + Select Case k + Case Asc("s"), Asc("S") + $If INTERNALBUILD = TRUE Then + LevelComplete = True + $End If + Case 27 + UserWantsToQuit = True + Case 13 + If Not InGame Then + If GameOver Then + SetLevel GAMESTART + Else + NewLevelSet = 0 + Timer(TempTimer) On + InGame = True + End If + GameOver = False + End If + Case 32 + If Not Hero.Grabbed And Hero.CurrentRow > 0 And (Hero.Action = STOPPED Or Hero.Action = WALKING) And InGame Then + If IglooPieces > 0 Then + If IglooPieces < 16 Then IglooPieces = IglooPieces - 1 + If BlockSound Then _SndPlayCopy BlockSound + InvertCurrentIceRow + End If + End If + End Select + + 'Check if a movement must be processed: + If Not InGame Or Hero.Action = DROWNING Or Hero.Action = FREEZING Or Hero.Action = ENTERINGIGLOO Or Hero.Action = EATINGFISH Then Exit Sub + + If Hero.Action = WALKING Then Hero.Action = STOPPED: Hero.Direction = Hero.Action + + 'Is the left arrow key down? + If _KeyDown(19200) Then Hero.Direction = MOVINGLEFT: Hero.Face = Hero.Direction: If Hero.Action = STOPPED Then Hero.Action = WALKING + + 'Is the right arrow key down? + If _KeyDown(19712) Then Hero.Direction = MOVINGRIGHT: Hero.Face = Hero.Direction: If Hero.Action = STOPPED Then Hero.Action = WALKING + + 'If the hero has been grabbed by a creature, no jumps are allowed. + If Hero.Grabbed Then Exit Sub + + 'If the hero is already jumping, we have to wait for him to land: + If Hero.Action <> STOPPED And Hero.Action <> WALKING Then Exit Sub + + 'Is the up arrow key down? + If _KeyDown(18432) Then + If Hero.CurrentRow > 0 Then + Hero.Action = JUMPINGUP + AnimationStep = 0 + If JumpSound Then _SndPlayCopy JumpSound + ElseIf Hero.CurrentRow = 0 And IglooPieces = 16 Then + 'The igloo has been finished. If the hero is standing under the door, + 'we'll let him in: + If Hero.X + HeroWidth > DoorX + 5 And Hero.X < DoorX + 17 Then + If JumpSound Then _SndPlayCopy JumpSound + Timer(TempTimer) Off + Hero.Action = ENTERINGIGLOO + Hero.Direction = STOPPED + Hero.Face = STOPPED + Hero.X = DoorX + AnimationStep = 0 + End If + End If + End If + + 'Is the down arrow key down? + If _KeyDown(20480) Then + If Hero.CurrentRow < 4 Then + Hero.Action = JUMPINGDOWN + AnimationStep = 0 + If JumpSound Then _SndPlayCopy JumpSound + End If + End If +End Sub + +'------------------------------------------------------------------------------ +Sub DecreaseTemperature + Temperature = Temperature - 1 + If Temperature = 0 Then + If DrowningSound Then _SndPlayCopy DrowningSound + Timer(TempTimer) Off + HeroFreezingSprite = _CopyImage(HeroSprites(4)) + _Source HeroFreezingSprite + Hero.Action = FREEZING + Hero.Face = STOPPED + Hero.Direction = STOPPED + Lives = Lives - 1 + AnimationStep = 0 + End If +End Sub + +'------------------------------------------------------------------------------ +Function TRIM$ (Value) + TRIM$ = LTrim$(RTrim$(Str$(Value))) +End Function + +'------------------------------------------------------------------------------ +Sub UpdateFrames + Dim PrevDest As Long + Dim i As _Byte + Dim AuroraLineColor As _Unsigned Long + Static AuroraCount As Integer + Static CreditCount As Integer + Static CreditUpdate As Integer + Static BlockCount As Single + + AuroraCount = AuroraCount + 1 + If AuroraCount > 3 Then + Randomize Timer + AuroraCount = 0 + PrevDest = _Dest + _Dest ThisAurora + For i = 1 To AuroraH Step 2 + Select Case i + Case 1 TO AuroraH / 3 + AuroraLineColor = Aurora(_Ceil(Rnd * 3)) + Case AuroraH / 3 + 1 TO (AuroraH / 3) + (AuroraH / 4) + AuroraLineColor = Aurora(_Ceil(Rnd * 3) + 3) + Case Else + AuroraLineColor = Aurora(_Ceil(Rnd * 2) + 5) + End Select + Line (0, 0)-Step(_Width(ThisAurora), AuroraH - i), AuroraLineColor, BF 'Aurora + Next i + _Dest PrevDest + End If + + If Not InGame Then + CreditUpdate = CreditUpdate + 1 + If CreditUpdate > 1 Then + CreditUpdate = 0 + Select Case CreditY + Case -2 + CreditCount = CreditCount + 1 + If CreditCount > 10 Then + CreditCount = 0 + CreditY = CreditY + 1 + End If + Case -1 TO 16 + CreditY = CreditY + 1 + Case 17 + CreditCount = CreditCount + 1 + If CreditCount > 15 Then + CreditCount = 0 + CreditY = -2 + End If + End Select + End If + Else + CreditY = 17 + End If + + If Hero.Action = WALKING And InGame Then + If Hero.Frame = 1 Then Hero.Frame = 2 Else Hero.Frame = 1 + End If + + If InGame And Not LevelComplete And (Hero.Action <> DROWNING And Hero.Action <> FREEZING And Hero.Action <> EATINGFISH) Then + For i = 1 To 4 + If Creatures(i).Frame = 1 Then Creatures(i).Frame = 2 Else Creatures(i).Frame = 1 + Next i + End If + + If IceRow(1).State And IceRow(2).State And IceRow(3).State And IceRow(4).State And IglooPieces < 16 Then + If Not LevelComplete Then + If Timer - RestoreRowsTimer > .3 Then + For i = 1 To 4 + IceRow(i).State = False + Next i + End If + End If + End If + + If InGame And Levels(ActualLevel).BlockType = MOVINGBLOCK And (Hero.Action <> DROWNING And Hero.Action <> FREEZING And Hero.Action <> EATINGFISH) And Not LevelComplete Then + BlockCount = BlockCount + .5 + If BlockCount > MaxSpaceBetween Then BlockCount = -MaxSpaceBetween + Select Case BlockCount + Case -MaxSpaceBetween TO -1 + SpaceBetween = Abs(BlockCount + 1) + Case 0 TO MaxSpaceBetween + SpaceBetween = BlockCount + End Select + End If +End Sub + +'------------------------------------------------------------------------------ +Sub SetLevel (TargetLevel) + Dim CreatureCheck As Integer + + Select Case TargetLevel + Case GAMESTART + LevelComplete = False + ThisLevel = 1 + TimeOfDay = DAY + Lives = 3 + Score = 0 + Temperature = InitialTemperature + IglooPieces = 0 + NextGoal = ONEUPGOAL + Case NEXTLEVEL + LevelComplete = False + ThisLevel = ThisLevel + 1 + Temperature = InitialTemperature + + If (ThisLevel - 1) Mod 4 = 0 Then + If TimeOfDay = DAY Then TimeOfDay = NIGHT Else TimeOfDay = DAY + DrawScenery + End If + End Select + + 'Set hero's initial position and state: + Hero.CurrentRow = 0 + Hero.X = 100 + Hero.Y = HeroStartRow + Hero.Direction = STOPPED + Hero.Face = MOVINGRIGHT + Hero.Action = STOPPED + Hero.Frame = 1 + Hero.Grabbed = False + + 'Levels only have defined conditions up to level 9. After that, conditions are random. + ActualLevel = ThisLevel + PointsInThisLevel = ThisLevel + If ThisLevel > UBound(Levels) Then + Randomize Timer + ActualLevel = _Ceil(Rnd * UBound(Levels)) + PointsInThisLevel = UBound(Levels) + End If + + 'Erase existing creatures and fills an array with the ones allowed: + Erase Creatures + MaxLevelCreatures = 0 + CreatureCheck = 1 + Do + If Levels(ActualLevel).CreaturesAllowed And CreatureCheck Then + MaxLevelCreatures = MaxLevelCreatures + 1 + ReDim _Preserve ThisLevelCreatures(1 To MaxLevelCreatures) + ThisLevelCreatures(MaxLevelCreatures) = CreatureCheck + End If + CreatureCheck = CreatureCheck * 2 + If CreatureCheck > CLAM Then Exit Do + Loop + + 'Set ice rows initial position and direction: + IceRow(1).Position = 90 + IceRow(1).Direction = MOVINGLEFT + IceRow(2).Position = 10 + IceRow(2).Direction = MOVINGRIGHT + IceRow(3).Position = 90 + IceRow(3).Direction = MOVINGLEFT + IceRow(4).Position = 10 + IceRow(4).Direction = MOVINGRIGHT + + For I = 1 To 4 + IceRow(I).MirroredPosition = 0 + IceRow(I).State = False + Next I + + Select Case Levels(ActualLevel).BlockType + Case SINGLEBLOCK: RowWidth = HeroWidth * 9 + Case DOUBLEBLOCK, MOVINGBLOCK: RowWidth = HeroWidth * 8.5 + End Select + + NewLevelSet = Timer + InGame = False +End Sub + +'------------------------------------------------------------------------------ +Sub LoadAssets + 'Saves sound files to disk, then loads them with _SNDOPEN: + 'jump.ogg + A$ = "" + A$ = A$ + "?MfIC1P00000000000P7[00000000PDQ:^L0N4PM_9WHY=7000002@4[0000" + A$ = A$ + "000004W00000000^1ldIW=50000000000000N\20040000`L`]TnB\cooooo" + A$ = A$ + "ooooooooooooooooA>PM_9WHY=g:0000HU6LXibCbM68\UVHFmVLRUfLPT48" + A$ = A$ + "b0C>Zi9YVciL66WhXLPVCJ>QcYPLPRA1N>98Lm" + A$ = A$ + "VYCjX>ZSjX>:d2]@;d2]B[4CaD]ESiJ_6d5OciL>" + A$ = A$ + "WciL>WciL>Wc98d@F500P00048T1I@642Q@85BQD8VRYH:W2bP8J2]VcgL>>XIiPV:5K>M`9BeVWTKZ" + A$ = A$ + "H^iL>WciLbVcI<>WciL::WIaPV9dJ>Wc9aPVU2JV@[iL>WW4KN@[Y:]VciL6" + A$ = A$ + "WcY36WAHL>WcY9]V7TJfH]iL>W5dJJ>ZiBaVciLRD^i9eV;EK>WciL>WciL>" + A$ = A$ + "WciL>WZGLjL`i4>WciLRJ_iJiV@GL>WciC6W^gL2QciL>WciL>WciL>WciL2" + A$ = A$ + "2=TE100@0001QQ=66gYPPdWS6865QHJ8Cj1M?j`TP63bY@Z7=jXA:UjP@9E6" + A$ = A$ + "WD:M22=TE100P00042QD85BQD85BQD85BQD86RQH86bYL:W2ZP:YBZX::Sb\" + A$ = A$ + "<;cb\<;cb\<[3k\>[3k`@<43a@[d:aB=EKeH=F[iN>W[iPdJUF[eJ]BYD:UB" + A$ = A$ + "YD:8d@F500P00048T1I@6TAQD85BQH8VbYL:W2ZP:P@3IE000800800000?9" + A$ = A$ + "?7A7A7A7A7A7A7A7A7A7?7?7A9A9A9A9A;C;C=C?EAEEGIGKIMIMKOKQMQMM" + A$ = A$ + "OOMOOOMSOMQQUUUUUUUUUUUUUUUUUUUUUUP@3IE0002000P@842QD85BQD8U" + A$ = A$ + "RaH<7ciP>9D212=TE100P00P00000LDLDLLTLTLTT\T\TdTd\d\ldldld4m4" + A$ = A$ + "555===E5M5M5e=]5U=U=M=M=U=MEUE]MUU]]U]e]mUU]mmmmmmmmmmmmmmmm" + A$ = A$ + "mmmee12=TE10P400P>B>B:B:B:B>>>>BBB0Q6bZ00@600@00PRRSRSSSSTTT" + A$ = A$ + "TTUTVTWUWUXVYVYWYWZX:@XQ\:00040040000000PRVRWRYRWRXRWSXSXTXU" + A$ = A$ + "YUXVZV[X\Y\[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[;@" + A$ = A$ + "XQ\:00T000dAbAbAbABABABAbAb18d@F500b000200L:G>@B2BB`C3PSU5llPW6<=1hHI1??Xi1CC00" + A$ = A$ + "00000000000@bC3NN`c3VV0TdlPW7llPY900000000000008ii1??hi1CC0B" + A$ = A$ + "NN`c3NN`d40000000000000l<=QY94=QZ90?CCHJ2CCHZ200000000000000" + A$ = A$ + "000000000000000P000P1L0002`4:3DXQ\R00RC00LhX89100PSTTU5000:B" + A$ = A$ + "BFF000HIIii100PTUUW70000000000000000000000000000000000000000" + A$ = A$ + "00000000000000000000000000000000000000000000008000H0700P005J8[40P@2007>>FFNNRRRR" + A$ = A$ + "VVVVZZLL\\ll4555==EEMMihHIii9:::JJZZjjbbBCccCDDDddDEee5JJNNR" + A$ = A$ + "RRRVVZZ^^@CCDddddDEEEee5JJNRVVVVZZZZ^^`cCDddddDEeeee58:JJJJZ" + A$ = A$ + "Zjjjj245====EEMMMM1RRRVVVZZ^^^^0CCCCEEEGGGII0VVZZZZ^^bb0DEEE" + A$ = A$ + "MMMUUU1XZZZjjjj:;3`eeeEfEFFF60^^^^bbbb2000>`10080SP>9SZ\8\AC" + A$ = A$ + "h2?0DXQ\R00R2000<6VBaD:3S9Q@:4JH<94BQ@VDBYB:UZP@ZDBUB54BUBZD" + A$ = A$ + "bXD;UJYD54BUBZDZP@ZDBUB100H7h00PMP525J8[40Pl0002SAYHWc9A8URaL>WCZDWD:IYDbH>WciLBYTaL>WciTBYciL>W3" + A$ = A$ + ":UBYdiL>WC:UB94jL>WD:UBWciL>100@5h0004P=:bVC`81EXQ\B00B500YXa2\@3IU00T100@H<" + A$ = A$ + "8T2Q@8U1Q@:42QD:529000H0700P00@" + A$ = A$ + "IAHSc`:9MFQS6LQ6b:108T000`H@863jT@YT:YD52aH>XDBUFZUR]:4RaP@Y" + A$ = A$ + "TB]F\5S5?Wc1QB:UJYH:f:N>WC:YD[5SaH\FL]@8UBYF;fR]H\9KQ@:UB]F<" + A$ = A$ + "6[eHcXD]DZeRaH<6[aRBiBYD[5KaH\FS5QbVK]F<6[eJ]FC:U?gBaF]FSaJ]" + A$ = A$ + "V<:SB6SaJ]6[eJ]8D:U<6CaD\F[eJB8<6O?6SaJG000e3>00D9H4d9IDU5Q=J2Gh1P2=TE20@^" + A$ = A$ + "10022YD<6SiL>WciL>W3BA:6caL>W32Q@842Q@:2aH842Q@84:QB:UbH>Wc1Q@84:UBYDBYDWciP@842QBYD:UB:UjL>742Q@XD" + A$ = A$ + ":UBYDBYD842Q@842UBYD:UB:UBY@842QBXD:UBYDBYD:52Q@8D:UBYD:UB:U" + A$ = A$ + "BY@842QBYD:UBYDBYD:52U@YD:UBYD:UB:UBYD:4:UBYD:UBYDBYD:UBUBYD" + A$ = A$ + ":UBYD:UB:UBYDZD:UBYD:UBYDBYD:UBUBYD:UBYD:UB:UBYD:U:UBYD:UBYD" + A$ = A$ + "BYD:UBYDYD:UBYD:UB:UBYD:U:UBYD:UBYDBYD:UBYDYD:UBYD:UB:UBYD:U" + A$ = A$ + "BYBYD:UBYD:000j0700P0UCU@7S1000PP00`0A8c48@1@16830P3@81Y00X`2QKh9N3?QK`9XCAUj01000000N00h1008I3P8R8JVSS>l" + A$ = A$ + "h3@2ATA8Y4C>151000000\30h300895P8R8JVSS>lh3@2ATA8Y4C>1U000@0" + A$ = A$ + "4000000@04028P0000000@0000028ldIW=504@1:00000000N\20080000`c" + A$ = A$ + "PYlJId5C:mOMoSeoQmoKooeocl_7oGaobl_Ao_1K=QHaN=fBHg1LUc2V" + A$ = A$ + "N1H^\52d<1TnKX9j@]mEEKdaom?OiLWnAeOMCmfbK7GFf_`n?i_VOdLoKNSo" + A$ = A$ + "M_iSmYlgi=7NmgcloBegcn]n1GWmOaW]dU00`[[6000gYc7GK0CTQ`9NG>O<" + A$ = A$ + "]1LG9" + A$ = A$ + "UA55dZVn?VOC4e:RRZ>_Zi204Y@\1X01RJHDF8XZ:P>iXMd9X34[8HE5S>9^?n0=PE46[0J1<=1IeQEeYXA" + A$ = A$ + "7H;P3QMFHM;4E53eZFeB4040iI=[RE\43\dJVPX:RJYe]d9LR" + A$ = A$ + "XCMHSPA`XXA1K1001@AW::Z8R10ZmWR9`:ZXA[PH@0401EMZe008XZ3E@<80" + A$ = A$ + "080JdQ>4005]J\51000413FWJ]0FA[8Z2R100@<08:J`ZRASF1a06E03REeYFE00<802HJ=[RQZ0PH5[I=1E4D@D@YY=LHRa9_Ujni[PE_" + A$ = A$ + "BiKm?dWCjO00000b5@07F@ZVC7a;8EC18B2;RMj;`YCDFP9000JC008SVJA0" + A$ = A$ + "0D1\eRZX2:8D6A904025P;7AhC5D@Yh`A@F`202@@aZJ@[>DA0\H[XESF5E1oE:2A:14@]CD4CA]UH=3A" + A$ = A$ + "@Xg:aW5@000]JeX4@0YC[AE010aP5EMR6@00@0aJ\641140`P>Ee8808aeU9" + A$ = A$ + "92280FDeYXTVTGB[d9HMC314E00NJ3]" + A$ = A$ + "@an[`KnM@cBRm`lAL\3jd6JQRmGQglkPVU4kQiShH7do10000H?E;HQ5@@TR" + A$ = A$ + "[if6A:`2F0A=08B2F`V02Tb4000e00P8EKI00ZQJX026fJedZXVZX2000;O6" + A$ = A$ + "F`U2660F:8R;1?F6:U?On\PQ3hJZ6F1\:ReDa4e@4EEe2C3;Ea6\I4=JdX8H" + A$ = A$ + "3P=:QMheE1\0Kd21EA<\`21XQlkc2V;C@D\Z5Fa6110RmgKZE10@@DD[XFG3" + A$ = A$ + "R1000\F]jDEE400@A5\`jZEDE1000;F0[ZeBC54@11ajFAA;820PHabTQfR0" + A$ = A$ + "VZY=IYU2PBbU1j?Z9A20RXJMZg:eCM2bTSfB3;8b5" + A$ = A$ + "L048`nn2f9bDf5VGP0>MWn2Lj000`H]ZH54eJ4;6E]ZeH53R8643E55dZH4<02ZP:" + A$ = A$ + "XRE4KdV=AEA@4001;]V=J1Z8XHZ008:P2FgV=]RQ2X0ZHHMKbj6RFiWo[08P" + A$ = A$ + "PYHCfPP806Fg:V8X2TcR4PZXR1RE\6FJRRZXAW:H4K0jPR002V:FJSFeZFcj" + A$ = A$ + "RX0:00@3>J@1@@]`Z6fXQeF4`PJ0PJHY06ZQ=HQ?U8X:\PE\P1D4MJM5@000" + A$ = A$ + "0H@mbZFH:X88R2FJmK[Q1151A@A]d:fXeDVG?9WfP=9:R:000`AX0hSAj" + A$ = A$ + "NZ]ceU@j3oJg[mL`b`H33]l^7Jh\N9TN=n_VN]W35WeO000BUA6aYLj?cQS;" + A$ = A$ + "gCUhgb5P8WKiRUc;\P1R<5ARU2aK2000PR00P84UX6\jnNN6LE@4a6a6[XXH" + A$ = A$ + ":4?Aia``Bicb5P7A0K>3V:RQ5R8HH9FE1?CIeB;0A555\H5E=JeX:F8DPTAAAa6`ZX0R8P]ZZF]Zf0008FA[6]:F<08:ZZVfTHElimDA" + A$ = A$ + "4=Jd8R8F\07c?<]9[<6D5440<08XXZX:J]>EeJ300PPXX:FJ=[HYZ:880H\X" + A$ = A$ + "ZAEa200P8::J43000D\Z5f@_=B]^@00T1[ZZEE50C\ZHCVZZZHJQYQc3dTDO" + A$ = A$ + "i8HSYD_0X0PP5FJQeEeP>EeZJ320100FEC40EEmRa0bIB00P=]H0@0[EAa1g" + A$ = A$ + "oZLOeY03RXfXQE05D@@`06AAYJEA4L1004_Fd820NH3]1eag^hIoG7EOg7;I" + A$ = A$ + "6g`6JSZSoMecU_>ZUo^?Fb\Ho10000hD2`I@OXLL@FDKm69P`dY000dRKZYB" + A$ = A$ + "e00@\W00b:eTT;L@;`A@6PGH\]14\`d70A408bZ4SX0;0000]00000J=KTJP" + A$ = A$ + "8V8XVR8VXRRQ:HJHE]a4DA54UT:028D10D\::00P:00063:0X2HH[]fIJ022" + A$ = A$ + "8fX6V6PX2:F4[V000F\g6C01000004D[a:Z0PPJGlAR2lP8lY2@XL9Q`?e_@" + A$ = A$ + "L<9XY1li`Ji4F4d_gAWVBLDSm24;1Q1@=b01Q2^_<=kAWXH56P3RU2G\004@" + A$ = A$ + "LEEDD5564:\2UEJI2A@`G<>\0P@1@hb9C@HPMJ10V:A>oUckCb^:=Id0000H" + A$ = A$ + "QL1km6Dh10080>7Hm1^J02V0c]60NI3A`T6_TiWeKo4k:oY`X?9^\\Q8@AS?" + A$ = A$ + "DmMih_JOU?56m5hQo00000L>0hD000cY000D4=000QF80007;08DWR47300e" + A$ = A$ + "2hH08Eo20hH0:[4001;<102K099A00D=0000PF00000eF>B5<0343Y008HB3R50PFj>X20P6SAe0008eK;00000000RF7" + A$ = A$ + "00@Bo=502;P@nYLH94n<8d2H@`l4VU`5PeB3]DMbih7==EAZYF@9@15@;T8Z" + A$ = A$ + "A0142\480EDQ460JSf4IaX@DL>CF8[45=41@1[?AR8?2500" + A$ = A$ + "@:>6f_^N7^lY9EJB1_P>^QWQU000@11P1003;QQ9OP\0D0000h40H`00nH41" + A$ = A$ + "RZF?`dmjd?eXC_V^;3LH\Q0AE[7XiNIjWJD?f^V^T9Tn70000PYS30eD5XML" + A$ = A$ + "PXVj=0K[EA0RZ=XZe:28NEAT^2I@10002PH]F00" + A$ = A$ + "04kZ4E5XZFZ]X001L?dE1@000000T@c`AB>b4:GR0DFQ8RbU3hChAib@@[P>]4I]RHAXa^EGBPVl;L9872fBXXdC5jIN07070LW0D1100000100<]bX\UR25PgFA\N>?oY_;5gIn2=" + A$ = A$ + "ATdFA\N>?oY_;=W1d5FP9eUD;eS@KP]`W4@X0CV9<9000\6E=H53B4_aRA`4=ZJ=HEE51<5[Z" + A$ = A$ + "[X60TDehPE0I3<`bO0c0B@JS5J5]RRa=`30^5LIC5P" + A$ = A$ + "U3>006P208G[aV]H4aT4`@YgOC" + A$ = A$ + "]W2L`3@j1`64PUBF1IfJ375`E]H;06400B_Djb<6J104T@\i\P]bB<00nF6?" + A$ = A$ + "K7[Ig1U@`F7k`F6gffGcY3B2F37`86KRGln>eYj4254:8TP4@Bh>610000fK" + A$ = A$ + "HH_=HKLVfJeZmAF]gdJFJJ;\AeV\Uff`jfPUZe\5FJMKbdZfPYYE\DcjX4;d" + A$ = A$ + "I]RF5DeHE=UFAUkBgnj^L7;Q44B@81QEPMgE[6^6QBa2;\`>`>`^;?900F<" + A$ = A$ + "ebDbET98VPh9`CIL[0`3OkfSBTAQ45R000PSFKgXFRN0Tm9K8;00P`27" + A$ = A$ + "iIa83000`kV0%%%0" + RestoreFile A$, "jump.ogg" + + 'block.ogg + A$ = "" + A$ = A$ + "?MfIC1P00000000000@N^00000000`PlEPH0N4PM_9WHY=7000002@4[0000" + A$ = A$ + "000004W00000000^1ldIW=50000000000000ii20040000@DEnC\B\cooooo" + A$ = A$ + "ooooooooooooooooA>PM_9WHY=g:0000HU6LXibCbM68\UVHFmVLRUfLPT48" + A$ = A$ + "b0C>Zi9YVciL66WhXLPVCJ>QcYPLPRA1N>98Lm" + A$ = A$ + "VYCjX>ZSjX>:d2]@;d2]B[4CaD]ESiJ_6d5OciL>" + A$ = A$ + "WciL>WciL>Wc98d@F500P00048T1I@642Q@85BQD8VRYH:W2bP8J2]VcgL>>XIiPV:5K>M`9BeVWTKZ" + A$ = A$ + "H^iL>WciLbVcI<>WciL::WIaPV9dJ>Wc9aPVU2JV@[iL>WW4KN@[Y:]VciL6" + A$ = A$ + "WcY36WAHL>WcY9]V7TJfH]iL>W5dJJ>ZiBaVciLRD^i9eV;EK>WciL>WciL>" + A$ = A$ + "WciL>WZGLjL`i4>WciLRJ_iJiV@GL>WciC6W^gL2QciL>WciL>WciL>WciL2" + A$ = A$ + "2=TE100@0001QQ=66gYPPdWS6865QHJ8Cj1M?j`TP63bY@Z7=jXA:UjP@9E6" + A$ = A$ + "WD:M22=TE100P00042QD85BQD85BQD85BQD86RQH86bYL:W2ZP:YBZX::Sb\" + A$ = A$ + "<;cb\<;cb\<[3k\>[3k`@<43a@[d:aB=EKeH=F[iN>W[iPdJUF[eJ]BYD:UB" + A$ = A$ + "YD:8d@F500P00048T1I@6TAQD85BQH8VbYL:W2ZP:P@3IE000800800000?9" + A$ = A$ + "?7A7A7A7A7A7A7A7A7A7?7?7A9A9A9A9A;C;C=C?EAEEGIGKIMIMKOKQMQMM" + A$ = A$ + "OOMOOOMSOMQQUUUUUUUUUUUUUUUUUUUUUUP@3IE0002000P@842QD85BQD8U" + A$ = A$ + "RaH<7ciP>9D212=TE100P00P00000LDLDLLTLTLTT\T\TdTd\d\ldldld4m4" + A$ = A$ + "555===E5M5M5e=]5U=U=M=M=U=MEUE]MUU]]U]e]mUU]mmmmmmmmmmmmmmmm" + A$ = A$ + "mmmee12=TE10P400P>B>B:B:B:B>>>>BBB0Q6bZ00@600@00PRRSRSSSSTTT" + A$ = A$ + "TTUTVTWUWUXVYVYWYWZX:@XQ\:00040040000000PRVRWRYRWRXRWSXSXTXU" + A$ = A$ + "YUXVZV[X\Y\[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[;@" + A$ = A$ + "XQ\:00T000dAbAbAbABABABAbAb18d@F500b000200L:G>@B2BB`C3PSU5llPW6<=1hHI1??Xi1CC00" + A$ = A$ + "00000000000@bC3NN`c3VV0TdlPW7llPY900000000000008ii1??hi1CC0B" + A$ = A$ + "NN`c3NN`d40000000000000l<=QY94=QZ90?CCHJ2CCHZ200000000000000" + A$ = A$ + "000000000000000P000P1L0002`4:3DXQ\R00RC00LhX89100PSTTU5000:B" + A$ = A$ + "BFF000HIIii100PTUUW70000000000000000000000000000000000000000" + A$ = A$ + "00000000000000000000000000000000000000000000008000H0700P005J8[40P@2007>>FFNNRRRR" + A$ = A$ + "VVVVZZLL\\ll4555==EEMMihHIii9:::JJZZjjbbBCccCDDDddDEee5JJNNR" + A$ = A$ + "RRRVVZZ^^@CCDddddDEEEee5JJNRVVVVZZZZ^^`cCDddddDEeeee58:JJJJZ" + A$ = A$ + "Zjjjj245====EEMMMM1RRRVVVZZ^^^^0CCCCEEEGGGII0VVZZZZ^^bb0DEEE" + A$ = A$ + "MMMUUU1XZZZjjjj:;3`eeeEfEFFF60^^^^bbbb2000>`10080SP>9SZ\8\AC" + A$ = A$ + "h2?0DXQ\R00R2000<6VBaD:3S9Q@:4JH<94BQ@VDBYB:UZP@ZDBUB54BUBZD" + A$ = A$ + "bXD;UJYD54BUBZDZP@ZDBUB100H7h00PMP525J8[40Pl0002SAYHWc9A8URaL>WCZDWD:IYDbH>WciLBYTaL>WciTBYciL>W3" + A$ = A$ + ":UBYdiL>WC:UB94jL>WD:UBWciL>100@5h0004P=:bVC`81EXQ\B00B500YXa2\@3IU00T100@H<" + A$ = A$ + "8T2Q@8U1Q@:42QD:529000H0700P00@" + A$ = A$ + "IAHSc`:9MFQS6LQ6b:108T000`H@863jT@YT:YD52aH>XDBUFZUR]:4RaP@Y" + A$ = A$ + "TB]F\5S5?Wc1QB:UJYH:f:N>WC:YD[5SaH\FL]@8UBYF;fR]H\9KQ@:UB]F<" + A$ = A$ + "6[eHcXD]DZeRaH<6[aRBiBYD[5KaH\FS5QbVK]F<6[eJ]FC:U?gBaF]FSaJ]" + A$ = A$ + "V<:SB6SaJ]6[eJ]8D:U<6CaD\F[eJB8<6O?6SaJG000e3>00D9H4d9IDU5Q=J2Gh1P2=TE20@^" + A$ = A$ + "10022YD<6SiL>WciL>W3BA:6caL>W32Q@842Q@:2aH842Q@84:QB:UbH>Wc1Q@84:UBYDBYDWciP@842QBYD:UB:UjL>742Q@XD" + A$ = A$ + ":UBYDBYD842Q@842UBYD:UB:UBY@842QBXD:UBYDBYD:52Q@8D:UBYD:UB:U" + A$ = A$ + "BY@842QBYD:UBYDBYD:52U@YD:UBYD:UB:UBYD:4:UBYD:UBYDBYD:UBUBYD" + A$ = A$ + ":UBYD:UB:UBYDZD:UBYD:UBYDBYD:UBUBYD:UBYD:UB:UBYD:U:UBYD:UBYD" + A$ = A$ + "BYD:UBYDYD:UBYD:UB:UBYD:U:UBYD:UBYDBYD:UBYDYD:UBYD:UB:UBYD:U" + A$ = A$ + "BYBYD:UBYD:000j0700P0UCU@7S1000PP00`0A8c48@1@16830P3@81Y00X`2QKh9N3?QK`9XCAUj01000000N00h1008I3P8R8JVSS>l" + A$ = A$ + "h3@2ATA8Y4C>151000000\30h300895P8R8JVSS>lh3@2ATA8Y4C>1U000@0" + A$ = A$ + "4000000@04028P0000000@0000028ldIW=504LI;00000000ii20080000@L" + A$ = A$ + "JCSSJl_=oCeodm?ND7??Lh`A1]J]X1DeYZR6aAmnhY[mglWA\FMZC" + A$ = A$ + "]JE[^5HogS0RY=JJ3fPUf<6Z^XE5100eic3CJWQAZ@aD45aWLl;JT3R62FV" + A$ = A$ + "V93k=cLF@FXUFe2\A100JL3c8eUI4fPN`8mhSKH6Y^3H3CTb4Z" + A$ = A$ + "DPZ1l?C;5H_S=\`CjBKEFXKnTS6H=8222P0OR\\ifL`W`G@LKFbTB7Uf2B[]" + A$ = A$ + ">_Xi[iV9mBEPTG=lM[R>[GdObHl82AaFj<3IlANCT_2iGbc2bA?0HL^OULV7" + A$ = A$ + "4hbY<\JGf5j]In4A:ndMo6i4RXNTm3Y5]`P>XbOMi=DEK2h0jP:oem^^T4A:UQLXO6" + A$ = A$ + "\W:7L`17LTH>`>86a<1@h0000<611;R8HDSA\edFKEk<\a`DaZJaZF" + A$ = A$ + "5ejRXPe=]dd23[KQ=XFPUVFJ5C3e2<@AS8F01AD4iX?J=WcE>XECT31^c`UD" + A$ = A$ + "R499]NE>fJL@N:M;7WB4>@aPaP6D\82;J5GfaCFgVMEOe" + A$ = A$ + "[8Y5O9aJ=d?aW`_S_^dW`>b>X9:WC`5OH4_ehGNjCUSVZI1?G??C00G_4j^?" + A$ = A$ + "MHgY\1Z@4JeTWX2]\Uf;gOA<0ZREED4AA\ZFd82Fh@WnK6A;iT`?j@aZm1hOJCJF[Mc5O5OhJ[VaU@GI" + A$ = A$ + "kQ\DjF95@C^VlK7]kF^Da^>:Oge2;57[[jhGgFXSZ8_ZSB2EVF08iDnFb9Qe" + A$ = A$ + ";]7;k@ZbkjEUk=XEAEAD5151A=FIk>UbeM7=0h_=" + A$ = A$ + "dR9STR1D1S\km]QFH9KoiHAcgeLbKlFGRPQfeY];eVKQoLnWfZTZ\RjZ@lbbl\`Gf]BKVVoaISD;WIc^]" + A$ = A$ + "G[b^Co5FSXAEaFA05@D9mMjfWkn^10P7g@5W;@1X26YG>^Q:>GP2@5MbkOFkf5Ue8LM@SYEUQ<4[" + A$ = A$ + "DO5BbZhlOGDn];82?BhD4=ia9dL=XbO`O500fBUHYhP3>h0a4c" + A$ = A$ + "4k0C0CIbOi[nfGG[[]4RCj7Tj\=Aci" + A$ = A$ + "AD[MKI_VAiATOT8CHGS7YW_0Imk7LU31baSPS:8cmT_Mbj\n1<>;bAKc:mMm" + A$ = A$ + "J;K7eZ\lAh[kfjMKO_UJkjgcBg>nXoV7hbJ5MWEnDfFSAaZPR1<5]RbNZO7=" + A$ = A$ + "0hW=Tgh2D0ZPAj1Of@NS;@1X26Y7lg00P41K>b17LM`1aAL4?U[3DDVd1V[H" + A$ = A$ + "000X000C\a`ZQXFLEad@4Q17>4Qi`C4nPQ;7>LDC<]VJ5[JQUFABA]R>@EEA" + A$ = A$ + "7H5=jD7ZFQ[K;cT_2d:88HaHE5YQDB9i:kkJKEGC^DT0mF:H20;0@PMKFmOO" + A$ = A$ + "[D_=7e9E^]_XI1HZ\8^[\R^2F8WNGJYX8gbDehUiQY`J7K=DET2\0j0[MlE00HK`D]e9]JS@3UIJWh4000d0004RH4ZAFg:JVg80`QUa:P@74:AP=aU4PL8B8GfZLPV@9T4P\S^3RlH4fF01cP\84B" + A$ = A$ + "jPRbb:04Jb@2FhOWMhHLEed\KLYD97WF::]f=^^;Kf" + A$ = A$ + "]UciWCK=?oZWfS4ic:<6;10;fP=:085RdGjn8fXeZh\URO300<]A_5fNm2@[03aYV=bF^Yi>PYaAa" + A$ = A$ + "1Q1Q1[J_8oB6AAEF`Xe5gdFaBRH5E5EmFB91bBabi00YcUACbmd\DL@X<3dd" + A$ = A$ + "c7hGlnX4\_k^k6cZlVJ>g5N?<_`bKnXMKZf0e`kb5c@AUW6B`>=gG[T?VN:H" + A$ = A$ + "]I]=I]IQUVGIIQ6h2O]U[1?AAa4AZ]8@DaiW;C4M00nG6GODGhY3BH1jbhiEo2AhP466n:00\_faBO" + A$ = A$ + "[f`R\@ej6N9000:900C0cI<6@YD:hXYUJagXAbdfU3OYajcFmGQEJKEbXUK:" + A$ = A$ + "A_iU=Bde=ec[\?MjR@o_<7C<<7j]XP2Bh>SYHm`[fg@o@KP^LMeo<4[m5E=lDV]^<6" + A$ = A$ + "NkX7gk\^Mc[DUg;MgEb6Xo>SBWH:6:iM?ZdlO?;S\Wkl" + A$ = A$ + "<1FolIolQOOn6YEJC166IQVS1:KKS>D[ZJ^DB::000HHMK`jFdfWA[J8I8SFZfJFX=" + A$ = A$ + "abb8757MWEFYc:[\7bhXkl\?kNTS\VCFidk:;nko=SX9goA?MU<]U1[h[k[2" + A$ = A$ + "00Zlnj]RBIYNA[mi]7B;[9C=eDC5]gEG=5SY^oS?FLU2lacK?0<000" + A$ = A$ + "0@FGaAFcckcK?IUE20PM_9WHY=g:0000HU6LXibCbM68\UVHFmVLRUfLPT48" + A$ = A$ + "b0C>Zi9YVciL66WhXLPVCJ>QcYPLPRA1N>98Lm" + A$ = A$ + "VYCjX>ZSjX>:d2]@;d2]B[4CaD]ESiJ_6d5OciL>" + A$ = A$ + "WciL>WciL>Wc98d@F500P00048T1I@642Q@85BQD8VRYH:W2bP8J2]VcgL>>XIiPV:5K>M`9BeVWTKZ" + A$ = A$ + "H^iL>WciLbVcI<>WciL::WIaPV9dJ>Wc9aPVU2JV@[iL>WW4KN@[Y:]VciL6" + A$ = A$ + "WcY36WAHL>WcY9]V7TJfH]iL>W5dJJ>ZiBaVciLRD^i9eV;EK>WciL>WciL>" + A$ = A$ + "WciL>WZGLjL`i4>WciLRJ_iJiV@GL>WciC6W^gL2QciL>WciL>WciL>WciL2" + A$ = A$ + "2=TE100@0001QQ=66gYPPdWS6865QHJ8Cj1M?j`TP63bY@Z7=jXA:UjP@9E6" + A$ = A$ + "WD:M22=TE100P00042QD85BQD85BQD85BQD86RQH86bYL:W2ZP:YBZX::Sb\" + A$ = A$ + "<;cb\<;cb\<[3k\>[3k`@<43a@[d:aB=EKeH=F[iN>W[iPdJUF[eJ]BYD:UB" + A$ = A$ + "YD:8d@F500P00048T1I@6TAQD85BQH8VbYL:W2ZP:P@3IE000800800000?9" + A$ = A$ + "?7A7A7A7A7A7A7A7A7A7?7?7A9A9A9A9A;C;C=C?EAEEGIGKIMIMKOKQMQMM" + A$ = A$ + "OOMOOOMSOMQQUUUUUUUUUUUUUUUUUUUUUUP@3IE0002000P@842QD85BQD8U" + A$ = A$ + "RaH<7ciP>9D212=TE100P00P00000LDLDLLTLTLTT\T\TdTd\d\ldldld4m4" + A$ = A$ + "555===E5M5M5e=]5U=U=M=M=U=MEUE]MUU]]U]e]mUU]mmmmmmmmmmmmmmmm" + A$ = A$ + "mmmee12=TE10P400P>B>B:B:B:B>>>>BBB0Q6bZ00@600@00PRRSRSSSSTTT" + A$ = A$ + "TTUTVTWUWUXVYVYWYWZX:@XQ\:00040040000000PRVRWRYRWRXRWSXSXTXU" + A$ = A$ + "YUXVZV[X\Y\[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[;@" + A$ = A$ + "XQ\:00T000dAbAbAbABABABAbAb18d@F500b000200L:G>@B2BB`C3PSU5llPW6<=1hHI1??Xi1CC00" + A$ = A$ + "00000000000@bC3NN`c3VV0TdlPW7llPY900000000000008ii1??hi1CC0B" + A$ = A$ + "NN`c3NN`d40000000000000l<=QY94=QZ90?CCHJ2CCHZ200000000000000" + A$ = A$ + "000000000000000P000P1L0002`4:3DXQ\R00RC00LhX89100PSTTU5000:B" + A$ = A$ + "BFF000HIIii100PTUUW70000000000000000000000000000000000000000" + A$ = A$ + "00000000000000000000000000000000000000000000008000H0700P005J8[40P@2007>>FFNNRRRR" + A$ = A$ + "VVVVZZLL\\ll4555==EEMMihHIii9:::JJZZjjbbBCccCDDDddDEee5JJNNR" + A$ = A$ + "RRRVVZZ^^@CCDddddDEEEee5JJNRVVVVZZZZ^^`cCDddddDEeeee58:JJJJZ" + A$ = A$ + "Zjjjj245====EEMMMM1RRRVVVZZ^^^^0CCCCEEEGGGII0VVZZZZ^^bb0DEEE" + A$ = A$ + "MMMUUU1XZZZjjjj:;3`eeeEfEFFF60^^^^bbbb2000>`10080SP>9SZ\8\AC" + A$ = A$ + "h2?0DXQ\R00R2000<6VBaD:3S9Q@:4JH<94BQ@VDBYB:UZP@ZDBUB54BUBZD" + A$ = A$ + "bXD;UJYD54BUBZDZP@ZDBUB100H7h00PMP525J8[40Pl0002SAYHWc9A8URaL>WCZDWD:IYDbH>WciLBYTaL>WciTBYciL>W3" + A$ = A$ + ":UBYdiL>WC:UB94jL>WD:UBWciL>100@5h0004P=:bVC`81EXQ\B00B500YXa2\@3IU00T100@H<" + A$ = A$ + "8T2Q@8U1Q@:42QD:529000H0700P00@" + A$ = A$ + "IAHSc`:9MFQS6LQ6b:108T000`H@863jT@YT:YD52aH>XDBUFZUR]:4RaP@Y" + A$ = A$ + "TB]F\5S5?Wc1QB:UJYH:f:N>WC:YD[5SaH\FL]@8UBYF;fR]H\9KQ@:UB]F<" + A$ = A$ + "6[eHcXD]DZeRaH<6[aRBiBYD[5KaH\FS5QbVK]F<6[eJ]FC:U?gBaF]FSaJ]" + A$ = A$ + "V<:SB6SaJ]6[eJ]8D:U<6CaD\F[eJB8<6O?6SaJG000e3>00D9H4d9IDU5Q=J2Gh1P2=TE20@^" + A$ = A$ + "10022YD<6SiL>WciL>W3BA:6caL>W32Q@842Q@:2aH842Q@84:QB:UbH>Wc1Q@84:UBYDBYDWciP@842QBYD:UB:UjL>742Q@XD" + A$ = A$ + ":UBYDBYD842Q@842UBYD:UB:UBY@842QBXD:UBYDBYD:52Q@8D:UBYD:UB:U" + A$ = A$ + "BY@842QBYD:UBYDBYD:52U@YD:UBYD:UB:UBYD:4:UBYD:UBYDBYD:UBUBYD" + A$ = A$ + ":UBYD:UB:UBYDZD:UBYD:UBYDBYD:UBUBYD:UBYD:UB:UBYD:U:UBYD:UBYD" + A$ = A$ + "BYD:UBYDYD:UBYD:UB:UBYD:U:UBYD:UBYDBYD:UBYDYD:UBYD:UB:UBYD:U" + A$ = A$ + "BYBYD:UBYD:000j0700P0UCU@7S1000PP00`0A8c48@1@16830P3@81Y00X`2QKh9N3?QK`9XCAUj01000000N00h1008I3P8R8JVSS>l" + A$ = A$ + "h3@2ATA8Y4C>151000000\30h300895P8R8JVSS>lh3@2ATA8Y4C>1U000@0" + A$ = A$ + "4000000@04028P0000000@0000028ldIW=5000<:00000000Hk20080000`@" + A$ = A$ + "?:JSJ@4B7MeD>mOTo7honmO2oCho7noAo[eoom?PLU`X34P:<_ZRb:X3j8TS" + A$ = A$ + "c30QIL90d80F_<:\S91P6I0XB5N>jK>^j=NJ" + A$ = A$ + "dGYCAojgKbP^Uh9nNabf?0C9V?0HcH<0XQ0`Hfb_NnmCCl;^bC^CdO?OcoUbmB2A`ggQ2LdKG<^" + A$ = A$ + "6d@AjYFdNPH0AcRRF[Zf@V=Z\" + A$ = A$ + "7ZaVZ200dG?MF9kWa\:3]\?Oj\BfG3IEFJiImVEb8H9B0K30@]6[:ZH1R8Sa" + A$ = A$ + "LA@AdZeR2:XZ5AAaHA[jnJYH[a2H:XCN@4=ZJEaFZ6FJSZQ>5000JK3A4^bV" + A$ = A$ + "XEl`Y]JGbLACLK3A4^bVXEl`Y]JGbLACl?008SZEAMZFKTEbd78SbJU0e=1X" + A$ = A$ + "4\_WZcPTmmcP5R2\YmmLafgcC5QiLOCL7000]69@T0eJ`HD[JDS0PX6S886S" + A$ = A$ + ":Z5[00PaJE@4EDkdP08HH=00@\94EDAa6=5C3KfjHR]40A5eJ6V202Fc:Z088Fa4d120" + A$ = A$ + "8H008_H900HSV0ZXRE]^Q20HYe5E04a60<]I14[YRR::F5100MJa0PZZRR2X" + A$ = A$ + "HQQR=JYQnI040610035edFJ1R9FP00R=P0XRJ=3E00eJ680PYe=DajZ5FdY>" + A$ = A$ + "5;0P>D10@\V20P1Z00P:fjD7aQ00H00@EaRFA7PHEa06E]200j400`j002FH" + A$ = A$ + "H2VFC4\VH:0PYUF100C[KQ20XED@<0:j@EdY5f4RZ0000hU=TTcTB;B?60PRUF700eJF0FJ5;0]::00X3E00`J600Pe0003[" + A$ = A$ + "PP=HZld080LP><00JDD10`JX00Z5F1003[J2VfT8H5E10`j600P>E10@dJ00" + A$ = A$ + "\F0MX][0800P1PJS2H]00PZ500dY10@aJ10@[61`V0\^800H3V00HJ=300<]" + A$ = A$ + "1401E\6RQQ=2R200:hS=TSc4EKB[>U;SU\;JP7K87W9ZfTFM:G6;IGd0o700" + A$ = A$ + "00P?PXXFP8Z91D61\OPDkP];FK:ggMj45HCG14\WcKk>mD8K00\e0E@5`:" + A$ = A$ + "00RJR0HHS2X0088YdhC10ShLhC8004N2aU`U?T6G80G:;2fP5Z8f2K4DCK@1" + A$ = A$ + "0a2KQU00HcFH00:f\90200F310000\2J]A00E]I3005K900H=;D00aZf8HH;" + A$ = A$ + "\:HHCF200fBD04\1300ad:F100C;<0KdFHQPa02=0T30[JC600HY=202:F3a" + A$ = A$ + "`VE10`JZ2" + A$ = A$ + "0XVF10@<\V9HH3V2FJ=A0@`J:0k0HZ200ZZHdY64<<00H3:jD;HA100]80PR" + A$ = A$ + "e=104aJV00P=SRE\9C1KBE00aV=10``6<100K0100[YZ9hU=8oYf0XJe8QXPXX>Y8RR8M8E2h87L`1F<7" + A$ = A$ + "LP5SHVWR1000[X0XHA4@@]F[A=64[XF0[KcZE\ZE<1;\1;<]`PX35SXZHAA0" + A$ = A$ + "[ePAEa8F1;Qka?A1bR2@\5SRF5[Ha^Wd24`@@D[K2HD9oJ`k4FQ0PXaR61A4" + A$ = A$ + "E029GNA9iP?eR>e2R00FLRJMOMQ130P2XAS424?HFVLM24bmnDF=:6i4\JY5" + A$ = A$ + ">hD41PNi;08D\>b0oWB>?m2Q@MGV" + A$ = A$ + "9Jc>>8eLLBP02FD1[E;REaH`R60A][FJn=\=7hO=Tg:VbV000=PXCM2R1003`900ZH8HCF3a`@50``J:0:V" + A$ = A$ + "F310aB;1H7d;0hI=d:dU^XYm:biZ?33TLTcJXEX;MACkETcEO668i8o70000" + A$ = A$ + "PO000D914Qmk185H9=X7kGBSU3j3@d2Xgn563k4_]UCHLKgYWbf600020Z04" + A$ = A$ + "D2T0D040H4SX08Z:HaNE00aNDD5\700e`010`6KE\ad>``2F\c4E\2Z1:XP=" + A$ = A$ + "RZf;0026:0PJe2Xf10HeN45AD;Li`00RDLT0\0P8^HRcQ8\X22^L4P50PADa" + A$ = A$ + "i`104`A0Q9@\ZE<4eF800F5K00`jFc200000@dYX00PPe105KD00DKd00@`6" + A$ = A$ + "4" + A$ = A$ + "302J10`D0[K8P6800<1<\AE1C00[E104[310@]620HE4A\95\d:0PReE00\^" + A$ = A$ + "00U:8jVe1P0006P30@`:XR=KcPF5500MXA504aj00RYe10@S1=P10hY=Tdb]" + A$ = A$ + "`VPilUQ97dd6BJiFHC`Lnb`T3jW:P\\^e0b\\8RjA:S0>@2^4PM1R[iDLATc" + A$ = A$ + "iTCedALZL`Q5\i0000\80Ra8Z0ZAEA@5\ZJAEeddD=\8RZZY]VfYR98F\J?0" + A$ = A$ + "2RMZJEKf24a`@\5Feddd005e6D00[R108REA]ZJ]VlFS4YDBMSQQQQQQ:HHc" + A$ = A$ + "PHZH0ADd20H=:R0HA[=0PF1AA;XX00PRFKS]eY0@]_elMXFc`D5E104FQ020" + A$ = A$ + "PPQZZE]9@@503j`P]A[54A4A7R10dXC\ZF=H[30\Ee00PXC308:60`:2:jd0" + A$ = A$ + "RQPOfnE7mL7@e`:2hCPXU\V9P200:@j=002PYQeD4]0PP6[JKn_=" + A$ = A$ + "3WJ8^gJ0nH33i:1A1nKNIFYLR7KH8G98:`Oc;c:UClce1XfJR0Z200g]AO<8" + A$ = A$ + "4fF`IP9VR;afgbiidA4kXDURS4GKY0000D1\ZeH]:XFDT40\cZ2P=6f1:H[=" + A$ = A$ + "fZ8Z1Z16ZEEA<00Ca``ddN4A2615D0:Q;335D8Y=Z0RZFJQ00JD1@0=8F0E5" + A$ = A$ + "\`6D3C;0DAc8PXA0@\E03RE1@@d00XXH\>0E;0\28n1`2A1@A4CeJLVm4HL>" + A$ = A$ + "PP58f8FA=\@544C;<00e6AAA`V@01;\RUHJSRXZE7808j000M:ZR5dXaR1D3" + A$ = A$ + "4[JSR:202P3f2MZE@a00R64;6]0PH=:00R=R>EAES2H0MPH1@[1>=TERXC11" + A$ = A$ + "00P40A47_X1Q2F604=Z0PH]P>04=00J0CO5ZF0@D05=P0>101h`ReXa2f0P2" + A$ = A$ + "`:P3C50D[RZFc0aJ8:P56VR::Z>E@\H5[20X3;JA3RH0P=00nG3]\ZA:3:l^" + A$ = A$ + "MIM4dLToJXUE=BI@Qg];[SPVSlO00000NGC0bb041FYm;B;>38b?0XGZ^`2G" + A$ = A$ + "Pa^Clnf>A^_URSbgC10005P<044E40\Z0XHE5@\Vf206fJW:H5e`Z96ZMXf9" + A$ = A$ + "0PJ[10XfJ1K]0HXF1@`>ERb:RTL90P8X=I504\1[20HE;40@]>:0Ze50000@S>00[C=00Zj40@A70" + A$ = A$ + "0FX:6fP:VFA00aJ:0XfX00PF00<00`?0Ze50`2C;1<1Kf20@=\140DK40`JX" + A$ = A$ + "00FAaVa2<@Q90R1aoc`V0[208VF754\6:0HSR00Z=9R5f2CDKFD0dR20XPF0" + A$ = A$ + "0[90PRQ8FcZPQ0080P102:R=[ZH90PP2PPe@00[30ZJJ55KFA`Z00FE10dP1" + A$ = A$ + "0[10@e2JA1[`001`1REd1RX20X100[300ajX0HYU6HHCZHQH20R=Z08Z=H0P" + A$ = A$ + "ZFJ108jd8Jd9f20P2hO=dFY4;=YZo6G>aQDc9j[Qf:UHY9Emghb9>TJ>Ao10" + A$ = A$ + "000h>@P4`n2;m0G;FK\W6@:f56HOWhmmLRk50" + A$ = A$ + "aN\C0D33[:0VfJ3Z=fQQJWPmRYJA<10\c4DD\PYmZ5DeN350aNEaD0;2R5AA" + A$ = A$ + "\70:O>4@YRcU`10P8452c`A@9i:800A4eZ00f\10P=ISZ2P5F10@Y10@]10D" + A$ = A$ + "\A300;]>:0FHQ20FHE`:6:H=005[20ZJD0XM;`10;E`2C;10aVD10CKf250e" + A$ = A$ + "6\RJHSfXR]404`6D0@]A04\RU:0HHQRE]52RU0X0;3L5FHSRJQ008F110[;2" + A$ = A$ + "0H5;E0`dj2FG=`2a40`VE50a6@0@Ed00F[RP=YPQ0080`O10@\3>@=i;6O]jVABD\`>>N_U" + A$ = A$ + "TW1R4:3[6UTki>ZRXXAD100cWZX5]6[JU0P?f@EUD4D=JdQAWR0H[C10\60`0C0`d0C[K==7400PX00ZJ1@dYF0@WF1@a" + A$ = A$ + "V5DK1Xf00XR>005MP08FE10\@aF2I456:1[YVH:0PQH20FG0D<]R0PJJ5<]`" + A$ = A$ + ":RH=50dQ20X130FE003AaB[c10000L06FC130@a4;]`6`050ed20@A<0RZ>105E`j400P7f@E[BPVCD;Lii7iO" + A$ = A$ + ">AQ=DeZ4Xi4e2GNnAnWCdO00000N3ES2@I1TC:M0H]OI0afIP5A[18OgAkK;" + A$ = A$ + "@PlLRcgLj4i6000:P@2BbB@2TPZReH1D[JA0\ADed>CaFk0`2:0HeD==<0e`" + A$ = A$ + "DaF30@]7`N00K=DAEEECC``20HADAicQ@8\@80`b2Y4@:ai0ATP?5P5LY4`2" + A$ = A$ + "K@50\1103;D05KYZ000XH;10<\V02f40P5F30edZ6H=40`:20HX:FJSTA20]4d" + A$ = A$ + "ZXPe20FE10\>@0DED00C[:H3:HM00MH0@dH0``40`B0[CC00mVULH3]EKAU9kZ@jUWC_I9o300DYBm:" + A$ = A$ + "[68EKj=bX^BXB2iTBC7BeMRb2T:000D0:01@EeRE5<" + A$ = A$ + "HaPZ6[53H4A@AEKa6\e@5a>0C0`ZJ00F]8=n<02@i2606247dYX0PXZ53XXJ" + A$ = A$ + "04A5=ZJ]FHW10QRiOA4MRZR00X18[Pk[0F72:jdF[00R630Z:0P]0Hd:R6EM" + A$ = A$ + "bQ=E9`60\00F3RQ=S8F20FHY28R>D10[30@<\43[[HQ5:0R>=0X130F30Da@" + A$ = A$ + "=\djl9F:MFR_LHO\3`?G3XJE8ZT00PcJa" + A$ = A$ + "PYS8f17L`1a4;EY@\34CHP9V9NV2000`J@5[eH1;RX0P445[V6P=fKEDA=TR" + A$ = A$ + "ShB91?F0`:5;35j0dZE`jDAE\260dJ0S8F\P]X3AESZX:F2H2l04d0jDW:8:" + A$ = A$ + "VOjZhX>YhH:C8V?=]Pem:EgE9R000D:M`Zm`5aU4L\c3G5E@DjI8l;7IW0cP" + A$ = A$ + "TEIIlDM\X806A@[Z8M`I`ACfHMnSnl=Z\FlCfISXj2>9V]^:?S3NVI`ZF@[=:0XRPHaJ444A5;8Z:2:" + A$ = A$ + "J`08o=C0nI3I:RHT5cZ7aEWYVeV3lI3I:RHT5cZ7aEWYVeV3lWJP\B=PjTZg" + A$ = A$ + "\RZ94E;aKAF5D9P8G3bd8Qd`Rlmie0BK;\HPm]DLdL:PSbim=W:000D[Pa8Z" + A$ = A$ + ":H`:ZP:R5`J50`8FD0R" + A$ = A$ + "H5C0`J08H=4Kbj6]60[2000P20XA1``614e:F10`ZP=1F30`ZV08j@50dQ0?" + A$ = A$ + "0P;0@0HQEE5``J0PHM\dd2\RH0DeR1d10P610D4dYjg9080j@" + A$ = A$ + "WJ1]00J=0:Z60d10XXeR>EAAa0H]0P6005104a:JE13@0008P6ES=4mPX1d0" + A$ = A$ + "0RF@76AS10M20:R1@<00<0[]W0@BP=PX:0RY90RH90Ze40\`dDEK@<\V:P:F" + A$ = A$ + "g0XXA50d10PRPZ6D<0POf@QR8ifTMfEnbIZIgLR?KX@ATLKb>k:Oia?" + A$ = A$ + "G1RbJAXV810PGbJ;P<2`1d2bcgMde08O1kKYBPI^0C74Kjd5g100PX2ZEEa:" + A$ = A$ + "FE\VXR08QRa00F3PJ1Ce`dNC`NA1<5K`6;08VfSRXL5EDaT440NL52DHE;`F" + A$ = A$ + "RQY=H10FR50RY=H0P5H2J43000Zj40\6H=KQea2;00[50\60D3;0@]d2`6ad" + A$ = A$ + ":60H:F08Ze<0`@=1`D5eV]2UP000H38Xa0VF30e2;0@]>@3ZF720FA3PPe40" + A$ = A$ + "4C;1@a0;]UXV20iQO206ZZfX=P5FX8PYE55@]10`2[X0P=8H;4aJH@@A780j" + A$ = A$ + "00@E50;:X3]j<<30oEdYF4a0XZ:0P>005530j0S>@3605=0P6<0ZZ0P88FCA" + A$ = A$ + "50:010\AAW6<0f20X30@A0oY2TA=P:QRjTAT@49^40>R85`AlDEY0000SE4" + A$ = A$ + "@]F1aJ5A<8F44SJ@DedFe4A4eN;ZJZVFC4;]`0CAEEE;8UN2Q^IS:::jDa80" + A$ = A$ + "hLFYUPH86ZYE]VHP2[@o60=2fF`om@CEdQ0HK\1" + A$ = A$ + "@dP0FeRa@gY>;`G6nDLN[b7oJ;_82o4SoMWLOG;g^h420ifkOioLYA5f<" + A$ = A$ + "9nfF6Cj>P`BC<@d0SZ[h_eVVeRF=GnFdeiKRaPeQReQ6De10:F50[" + A$ = A$ + "88PH=50[00=hb@]5F8H9:PeE54EM2P6oZkQnTg>7Xg" + A$ = A$ + "6>bCTl\UIWOem@ObKW3dW0::;1ED?eDZJ0A5XhEUBXB2IQLOV_W_?9blY0Yb" + A$ = A$ + "A4V><5HVCTC000HD1E53Pe:2PE\F`JE44<61SH4D`Pa8fPJCF10[S50Ze]60" + A$ = A$ + "R=P0RH9FgV5\22:fX2000J50d0j@Ae:20:Z0Fd90XZC0DDDE3[QQe1@\1E0\" + A$ = A$ + "V0PQY90F2fX=:HY206000P00F[H1F7aBD`dB1@a:0HJ51D\>HH=dWUm@QidP6\5@3H00`Pe9H3P:\2h4nCgmDP" + A$ = A$ + "F0@e0H005@d0200408H]R]0PXa0RX2PRZ1@7R8j45a0FD0`j00dH0`43KB53" + A$ = A$ + "58P101E]^e`:20RF36M:0XZZ00J1E000nI3mZ`TB;SNOjbiMT3`I3mZ`TB;S" + A$ = A$ + "NOjbiMT3`g00@oN9QiMeBXF@F6211kR[mMRF9`N^0Ki2hX9QYSV24DA5;:Z2XXFaREe6K1`dZ88RYJH13C0\JH00P1HZHa0@2" + A$ = A$ + ":1\2:Y0\04QhAiJCV0HYU2PHQRe\1\@D0\`208h17JCK@<4C0<=@01C@aBC1" + A$ = A$ + "0[SZF3\60V660H51@E[;0H5`653a@1010P1MP5F2PJSX0Fg4[JMaB[90:F10" + A$ = A$ + "5MH`XC0@4e2KDa@1@50ZA\RR>A10D]20FH20FG1`JA7HEA10E=0P>00EE0`2" + A$ = A$ + "4K@A4001>@1Dd1:R1SZ2DHndPXC\>4K50D513j@00E0@1DeP800P0J]PR1@5" + A$ = A$ + "R>h7@dZJMREE0@e20R20X5041[C\0005PPEdY]20XZ:0Xa08j405D55MR>50" + A$ = A$ + "\>504=8PXJ04=X3Ae:2@07F[28X30@aH@DDEA300NI3I1`TU?9ekU?Lh?\3Q" + A$ = A$ + ":K8;0V\l9YN_lQ3oQM8dg00Pf\RHR9V9VHRIa8f1a00008" + A$ = A$ + "1B:f[H_Y8F4K\XHJHE2:0;52@1[hl4P@\d0[IQE5E\0;=<]^ZESHAED4[P6\" + A$ = A$ + "Ha_=\a1BVYYEm;?la1i" + A$ = A$ + "4o300RZAPX:4eh=RJCX:5YPPdI1FffFHa2g<@B@bE^22Kki>Jj81L`11LD:>" + A$ = A$ + "h8W:0000989[RJE@]ZEADaJ`ZH\HEaH<6A51A\J:PHA14K=1@]PH76F05K01" + A$ = A$ + "\00HJJA]PYH0:fX8RHJ2ZHa4D\0ZRED0k]RbQ2:4@8625R893GA\0F3000FJ" + A$ = A$ + "80FJ:fPE]dD40d20j0`R>E@ajRYQE`J0P>D1@W60MXB2PG2`VE@`:V:0F3K`" + A$ = A$ + "`D<003000\80fRFC[H:60HE04[Y0HMC@ajRHQE]>00=J1@;2PQY2P5RYe4Y3" + A$ = A$ + "400400AWZP0PF3P63PF3PF15MH=Hh>SFXJ0D`jD@0`00@@S:80X27VWiU:?7" + A$ = A$ + "A?_PX1ZZ^2203R6410S0DQN`XC4K0Ae0650a605@3=100Y?YH17=NINgLc]?" + A$ = A$ + "0A[:PA1@DE1@1\6DKnKl_Ko_ao" + A$ = A$ + "3moDo3fo9lo>oSdoLHoo@mO@o3`och_=\ZPcHZXU3`Z3K4TSlK3[:hmmm]mM1VC2C7=5HVbL;5000H051S" + A$ = A$ + "X8F;Z=f962H?6:HE\Ga>503kE\8VfJH[RP5CC15[0XfX]dJ:HE3[HJC6FXF2" + A$ = A$ + "ZHMC5D;\000]000@Q9;8V_lMG:@30XE50=60\03K2330450X0e2\^J=\62HR" + A$ = A$ + "50Re]4@]`JPP=H8f\EaV=1DKd00[9:PUF80ZUH=[ZV80Z:000H0@;fV0C1@<" + A$ = A$ + "=1`J2PHE;1`jPUF3[Q2HQE1`B31@\40ADCKD4??0@0054d9R:0JD0@W20j@0" + A$ = A$ + "@A5MXH]:0HM0PRF3P>0`FDeXP00P1M280XJ><_4H=RR>]Xe0X50[10[:0RAd" + A$ = A$ + "H<000hi@d1H0D00[105EK0MRZZ2j01453PF1@43PPXEe600104dQAD0m=004QU9gF`L;5W^3Yb178fA>@0a2@\3RAl<50000b0BZQ]" + A$ = A$ + "R5C<=5eR:Rm070:E4A94FZ@LXB8=Ea6]562Pe\ZE]^QZE1\::8R8Z0ZPZZJ:" + A$ = A$ + "Z=;86kMnK_:f0J@[>5A:60X8PAE54A30P2ZjD40@J1_@<" + A$ = A$ + "D3[S1:XZQfn_]5gAdjd5]MGcJh3B8J100`f=KPda6@?72EcS_38o=?7[N@9;6g\H1=0000C66X;P<FcBZg;?D]L>Co000e2EP\J`;I=@DX88]0W^S4Hj87=G`" + A$ = A$ + "E>eDiXLR100081Y\@@\2R1DSEE`H53ZeXRA@Q0`bU:05\lXDF1U2e" + A$ = A$ + "2[K2H9286:P:6FH=;A4Da4N[F0Fa6E35`D<@bmlPWdWbTPO0D40[R>e:ZD94" + A$ = A$ + "0@4[Z3d80F[H15aHAE5@d9F7Re8PAC4gEG4Q]>4`00001T?eJ;0XJ`R2PXH0" + A$ = A$ + "A\XC[e2PF10=2P]44<0[[R08m05a00631j0J@QaRE1@[=:F1:" + A$ = A$ + "2=610Kd060\P61@[0" + A$ = A$ + "PF:k9dB_P8;AF9ZCUb[Q9VafIBTB3<8:HaVSVKY50DK=0`2F=AA1`@@4eF;P]dZ6PJ3f48" + A$ = A$ + "FaFHS0HE[I1PY=P0F10aZVFJ;]R8:PY000H=0PFD0dZ0PF@S]Z08J=8XEJ28" + A$ = A$ + "F30;\DE4aB0dQEdYE43P6h6R:C5M8860000010EDeQ>D4SAE;PEe0X6F0HJE" + A$ = A$ + "\^URe5`RFE`R>1@E4`:RHM22@0:XPR>D]0P604[28J=P6aX3dX2P>00=0XX2" + A$ = A$ + "P:FWB<080PAd9Hce=4@hSP2IlB>H=[J:Z::Jd:JEADA55K4aJ]6]XX2PZ000PAdX8a]f2I5DO2WY]F8alOm:N3Y:M" + A$ = A$ + "_GICZ2LQ8:M70[5@A4D15QN@7fZ:XE@AD`2@fL9coeob91RLUSKNm0ZGRRAL" + A$ = A$ + "RoW@02Q@;[J]\@Yg6E6dLh4P4hc8UgkTmg[;ZRUGjcb1RM85RM4QiD<0000P=fK15?QI^C5000P4TZHSEDKa>4<]A5\30DE44C[HX>0:;3QU`" + A$ = A$ + "A:a4E0a4aZF54KbjFc2[KJ;Aa`6=Aaj08FAAA;Zj@3J145E0d2HA1@A;0j4@" + A$ = A$ + "\ZXaZ0l;LA<`:ZR6S0P10040DM]>Em20J0`Z0f2PF@7P6H7LXh1Ykk4608`Y" + A$ = A$ + "ZZ:28R:PF0D;4@=]@]1a235@722:6`F0`Y@HTHR9000D0\:F[E4E" + A$ = A$ + "a>[ZJA]RRH[PYZR:HJe8PMfHR6cn@dJ30RPPR0P2HDaJ5KB65aH];<0gFcOR50K10K=h^490i`@oP0C5T" + A$ = A$ + "?O7NJ6Tb18fJE\20:0X1@@S1[EAm6MjhaACAD0<5eJ0:NM39@YXj44mYL4j=" + A$ = A$ + "VDg@2D:Z>1AO:7QNS9_Pb2D6IeJDIOjPHYb1RM`1RMPH7HR9<:6c4W:70000" + A$ = A$ + "06E444aH5ED[JY=X8f\E1C[I3Z8f2a6aJfB3`4K@4<\^R8FA5DA\DSXPP820" + A$ = A$ + "082H5AWFSP5WHI>M^E:ME5c@>ZG2370Zj4=Z6@a`I]fco[X2f1;WWFLF1Li4" + A$ = A$ + "JT6VeUOKV3F`k5`4118ok]`C8Td_`G4jUHX5@0fl3I4Dd8TLm?B4@[:VdCVL" + A$ = A$ + "YNo=CNo?NeL1<@`@[d\7IVC7o]nWAdJ?0_;IN[>Nd0DDMT@\PF4A0\h^J=Ph" + A$ = A$ + "n3hH_Pc6k?10NK3A:nd=;bBk7jSCL>WXf6RDlYKFTUf?d7WhL>AO3004`n65" + A$ = A$ + "QJD1DQ1f==\`A;H;W8gbWcDi8RM4QaY34Vc=700008Q@9a6EDA4\HSmP5K\3" + A$ = A$ + "D`J=F5DE5101k<<1e6\X660VF1<<1X0@4NDF`WE0Q5CDaeQ8ZPA00hNF1GP5" + A$ = A$ + "AeF0D=PF5@]0`@`V0SAI=PQJJCHH0HX0F;PE14K]8Z6@aPXaPHJ2H:R=[VV0" + A$ = A$ + "=9M8fPEaZ0ZH1Pe0`:0Pe`V43[0XE4@E40M08ZF[>450<00020VHM410]0f2" + A$ = A$ + "HE50]ZR>A;0RF0d2H0@3j`6100000@4[A\8AU?7J>nCOL8PR086`FdF01hk`" + A$ = A$ + "T9DL`C4=H51\Z0X:T8FQ0Pe22PP1D1@50DAkd8>6?@jJPP6aF0D04aP8ZPE4" + A$ = A$ + "E5A30F3Pe0820VHM5D0400010E5]gfXaW@>JJ5PWf@NbDP51Qb;E=N=7Pd6b" + A$ = A$ + "CV2\88DNYZa[i0l=00TC?3iUYET4cI:KC1VC7i87URSLP`X3>@lL;E00004@" + A$ = A$ + "X9YMPEk]A4e>A" + A$ = A$ + "@;0Z20082PRR6d:Z0:H0=0F[0X8F3J50550EE0A5@aXC]FmLbZ4`@<\58V0F" + A$ = A$ + "X0R2PZ505dRe2H51@;0X2XH5=Zf0:[A1]J4<8:6\61@;0XAaJEE1\60d28H0" + A$ = A$ + "aF7H3H000404dFf8IDPF04=R>@;07<=E2@WPZ1000`WME050@3Pe:PE4E5A;" + A$ = A$ + "0R2o6miJ30008P>03dAXX15m?FR7D9R>PG<2CRI>B=c5XAhPSLPhDa4c>86a4c4c\3>h0" + A$ = A$ + "0000`H5`J`H]XRH=K9ZY=Z6VZE]2VVFE]9K`B[J=adB[JJQUVFJHX666V2P5" + A$ = A$ + "ReeH0430061@[FE=F@0?gXNOonj\O81IO\;0PF^@j_Z7406555;0P68A3>9k" + A$ = A$ + "`g>PSOLG4ANF04<8J@EDPme`TW?0;inVLgF_XJFdi8cnel=lo5;0]XdoJCS7" + A$ = A$ + "@gM0eUU_^;ng:6PTDh`OjeRkRZIPJKA_=4BjR`\H[TNI_`G" + A$ = A$ + ">AO3006;mL8P<9^Vkc5\=M8EYb1aL`QDLP`0a>JV200001@A@4\31K\H3H_=" + A$ = A$ + "ZJ_0Fa2HJWH[JJQ2`5236^R95P02:8f\e]1aZf2;A5[KE@UY0>0a25KQHZP1" + A$ = A$ + ":P60[2HA4`0Z28R1d0X8fX:R220000RJJJCX5@dY1=H@[0XXXA\F0;:0V:8R" + A$ = A$ + "2RQHMeM770FRUFcD4`D14]0R6@dH=:ZX0R60[28Z02XCK3000lD:blTLl?8o;co2l?8" + A$ = A$ + "o;cnoCboKl_9o7`oOlo7oO@oocPOg@8>6g\XXeNiHNXe>0Lg@8>6g\XXeNiH" + A$ = A$ + "NXe>0l6RBb\XXNDVB2SG:CeZ4T4R;7bCUHcIZBedAYT:1L`124c17AH4000:" + A$ = A$ + "H@@=RE045k\J7He@<`Z82RJ:fB5\ZP]`V`B@142RYR=;6:8V0o" + A$ = A$ + "0E5E]20600004E]V:28J\PR1DNNQ^ji=40CAe5K]" + A$ = A$ + "dUbUNJ>1i=40CAe5K]dUbUNJ>1gdf>m6;QeQ4\4GY:OjdgLdhPH>hPH>@" + A$ = A$ + "HV:7UW2000DDeRmPJHHWMF<]7e@DE\HJ:XRXf8P53[PJW=R8F`V]dZFe:fT0" + A$ = A$ + "R=HED5D0F@EA\9e@0e4@`PZ1D5d::>NdT`PX8j@E10100@0D1;]9d1PZ5@A5" + A$ = A$ + "SF1\E@[P:8Z6DA0\4`@`6d>2020e0[KQQ1PJ0PF`F1\RXXnHZ02FSP100" + A$ = A$ + "0000MRP1d0XJ`R64d1J8j:nUU@H2]k[0DWHSR9A" + A$ = A$ + "7RkBLAH2fd60H@FIJ^ZDgfe1Q`80o03J`2P=P2PXJ0EdRX0:N61OJ100<06E" + A$ = A$ + "M02PF3R63X5SUZQeE3AA\`45]28H05d18\80nM3AXH4R9V6UG:LPEk0`M3AX" + A$ = A$ + "H4R9V6UG:LPEk0`;X0AVeY8;\;`d17L`A`>`34`i;JDW@OWRRF" + A$ = A$ + "EED\8H@DJo2FneX`667BVhiRlo\@F@Wg^WkSZ`Tb]nXECd2G^E82V\h]]eQN" + A$ = A$ + "Y9>Ze41i@=b>geB47Nlgn[KViW083oAVaL;>B[oE300XKioS6>EcXZX8laW]" + A$ = A$ + "kFkn4d2XH41DE4VA:0P_g@8XT8FLKWN@8Dk0dN3QPBRHa]Mj1Q@]3@G`d_W3" + A$ = A$ + "`2aE^3>T?CIj`D=0H00@1<`64e01=64MJ@E;8RF=J@;P632" + A$ = A$ + "ZPE1@AdQ10HYeP8P0P=PF0AEED\117Jd4]>Q100Re:F043XRAePH[5d28ZPH" + A$ = A$ + "3fPL?P100@0]6Q:?VV__7ASMl]6DdD2??2ge@<86`08X91`RLf4==IFY^]f6" + A$ = A$ + "a500?FYK_jlmO7AS7HE141]:8@aQeJ43X2X:\0g30hi=4a:adFleMn5>WC@N" + A$ = A$ + "3A\B<]5OMWOQci4l=00X_QdM6S1HgTlLRLKO:fh0QY34c>h8WNZ0000" + A$ = A$ + "0BE9HWMf1H3R531eR5[RQJ5A]g@``F5<\1Dk\XfI;20@i:^0D8\HL4P[@lPF" + A$ = A$ + "00032ZFc:H2H80:P80:XZeJ5SF11[0HZ2PUR=eZH9P8Z]D\@1;=41\:XH0Ze" + A$ = A$ + "4K2A;FdY=F3P=86HME0@0004@5aJFP50J1DD4=8J01`02VWWFWh`H4bWN10g?2_l]nY>\:AkOP10@=>H<5RH]X2HE14" + A$ = A$ + "55<5@@]6X004LPFEA0K50KoB4W=0nM314ahR57Sb35F2k0`M314ahR57Sb35" + A$ = A$ + "F2k0`=Q8jCJ=\k`00005A=<<4CA]eD0ed`@aZ" + A$ = A$ + "M6RQmfZZE[K3ZYQeA]D]0`jRHPURHQJHEKD]@@50DlRRmmRL6o9344`OF4BLTZNMYBi`D@VfI56n_7E" + A$ = A$ + ";4=_5VKGUF:YYRDm0`oH>G:JToJ1:bbPLOR00PjATZ865;O3;CMi\:>lOIlk" + A$ = A$ + "e:CR9YNRc_foN6g_Ddlmf`YT]9Yl6`d]^IEi^VW2;B:MeO2`IA0O7Tj8l4nj" + A$ = A$ + "C0PWg@B@;]cRSgMOP187Ql6B2JYMFLl^k3<0i8l2ATDZJ=5BgcH9UBaRQbnVF:j3A1aBD<5K@5Xh@dQA5S:HE1\:PReXZ0H4dH9>K:@4mP@:Oabm" + A$ = A$ + "JDTh`Qk100`FdR0PQ7R6Eo=nNN]U7X5<000002Ja0F@0aHA0K]lh8@Q@EW90" + A$ = A$ + "0V>Acjajb60@0G8QPR4]S?O0:020fJ@4:UCdQ86" + A$ = A$ + "4]HDE5`B5\RH=`:PJYPHE`6TCTCRLV:a8f17L`1R5Si9QA000XPA\" + A$ = A$ + "XZRAa8RQEk=DaF[PYmPYQ5`REC430C``:F5\Z=:ZY=JXRUF70@4`ddd6=J97:DPE1EaXA5@0XAjf2EHdH0ED4E1\FaHY0H5@`dFHH0`LH3XVP:2HQ" + A$ = A$ + "2:H@7X3E5E3J@@30J1455MJ30AajHX8Z9H:PA1D]eYA1d2XR8X0PZe:H0100" + A$ = A$ + "Q]B=7Th0" + A$ = A$ + "a>RHaV461000X6[E=H44300F\G`F[F4e`F;HSEC4\7\eD@0\0H;6HE1a2C`B" + A$ = A$ + ";\1K`ZR0V008H1=R>\ElTHXiokBR^XY0082XXFG@1@;PR0RAdg9;S61\:PRZ" + A$ = A$ + "6=2TPcj0[2XH@;Pe0FAdHA;8ZZPZ0RH0AdJ101[E4S]28ZlTg;[@S0R:P8PE" + A$ = A$ + "EK20PH=R806@10E@\eP5bL`01=ZR1400Pl[QhW4::jOlHB0PX540000:5\P6" + A$ = A$ + "CiaY?0=9l900@LV_^MRWXU9Da8O60000`X=\n;SSokP[Ohm=TRmADCLLkQc`<0f1Yn6Ban8Z9>^m`IH60kPd5h@ZL`1RM@<78VHR5SIa8VhD960000\gR1F1edFk=a6534Kd4C3Kbd`Jf" + A$ = A$ + "TQHSV6FZZED;<\D@\@EC\9[HJHH:P208RAdXASEDQjbiJQD_dZH7A[FThR`0" + A$ = A$ + "]c_kD?OU4A3F0=6`:2`cBV:88g7;boL8YkjABXc97OIbe`YUYUK71RTA9_J0" + A$ = A$ + "751DIEhD8TfnLY7BXiHMXT<0KFR=T8oWSD[dRe@N2ak?928`;@ZTYRbMD;]m" + A$ = A$ + "AP5KR7j]5lfXNR3`1;NAd=bYh?1X9>OS<_o32K\5@\" + A$ = A$ + "3>h0CL:>:UD10008@X2\a4E\1D[RY]F\1:5li3>DAiaB8BS@]V=JE`jF1<\:" + A$ = A$ + "8FXRJQQe]^H98V00X0VRE\1a2@e0FE0aP=ZR1d2X105@=`643@400@1\d`V]" + A$ = A$ + "41\TY3EdB:ZL@C@EAE;0000R1A5MXJ@d2:H<2XA4]J5@d0F54KXN[10PC=AU" + A$ = A$ + "4mT;o:Y;K?0fk8m86Ue:oTLVfC000jbdhaA:^7eSEEo:b00`dV6Eb47=9HP>" + A$ = A$ + "Vf0@@L4>05J2M3]EcNB1\jc>9lb533X0P06dJ@QE1JN0:PH[CE51DD1[8HE1" + A$ = A$ + "\eXH6m@\eJ3XJ4aT9M00NN39a]X[9>Nj3DfCi=T4gR^VhhY?@I?MCHWDJ5FG" + A$ = A$ + "1ThdMTCgAC7=WC1BU34c>`4c2TBZ000P2F@5k\aNa2F<15\E4eN3KEe@5CeN" + A$ = A$ + "DK]3Dk4e`FCED[JHCZ1P100V0VHH366PX45UT>_@lQP2[XX30`6003@43[YV" + A$ = A$ + "XHYWn@XD=:iA51dXJ04000`XA[80:Pe8P>1[XXXEE>Z[Pa08000PA;80:P51d2F4]XEF^ng>d:0800008J5" + A$ = A$ + "aPH8i\:^o@@CE4Tb101I=cD97OTaXEU10h@801QJAR`Qe;?0ilfAhMPW3=FE" + A$ = A$ + "61VM7U:7=MT3>h0a>@\3JkZ?SJAL0:F7H0400KX@QHE=80200PXMcTSALFBU37`O>10@BjGCVZVS^2e_gOM?S1@R" + A$ = A$ + "eUiP;@B]c]b[R?<00QBA5Q3NoRm5AoW2W^Ljf@A^=9A6Th@0J[_3X]cFP[3K" + A$ = A$ + "c0^QfHJQ2:<4bHgYW:79FZL`1RM@`RAb1000X22FQaH]C_E@2nAhBS" + A$ = A$ + "V@21QBES411L02hmIE]KikP6SQ30FA2L`N[mC7F?0QSlaG@<51K11E5=R:n8" + A$ = A$ + "[7ElS:00NN31PDZfRQ]76YH>1i=40BYJ;6fNHTRi4l658cJb888ad;]0H;U=" + A$ = A$ + "7LT3LZ4SH7H78<8VHRA\0cD000P:XF;ReXF;8fKR=fXZMH5K]H_YMVfZ6f88" + A$ = A$ + "X00R6dXZ55MXRRX5A@5;=a6\@03C@D1=6DEDE\8864148\Z0R:XHZ\KB<0P[DjmRK\gkRkJ`F;0" + A$ = A$ + "000kEB@h3NYnYKWh920^CXB55UYBZ88N76`fLTcl1kEU`74`_YTH1Q\[F>6b" + A$ = A$ + "KL10@UBYDMJ478TA0FmQ`7\_=C7\e2000006MJ1SRA43J0[EADe2X1@A0501" + A$ = A$ + "=f00?MfIC101jQ?00000000f^00060000h^PXMg4o?co1l?6og`oT@oo5l_7" + A$ = A$ + "okaoohk=4P;9V=:VFe6@aLVgK80GB8@Z8NV:7L`QI:000@5\65E\RJE\6ZRPY=FD@]gdNKQPJ;5E\IC5K" + A$ = A$ + "6edBK0K6;AE10@1<<<\^U:HJ0GDbgGU3bL@leC040ReYR0J0AaP60E1EE0aP" + A$ = A$ + "2PH0;j41<4\;MR=X5SFaXC3J4E]j0@[0J=X2H5[CD140038RXCK`:0J0[88J" + A$ = A$ + "AWX5@3H51D8NJ1000\e:0:64E@1`:XeY@76S:J100002M3];Y7emMTaTih?<" + A$ = A$ + "@0]6141D0[8PFdR:P24B0oF0nEBh@7=@1]80Z06`06]8000008J=6C6=eN5I" + A$ = A$ + "8eg@8=5]FTTLI2kPdUa>]IgY;FZ4c1f1RC5a>@lQ?=Ai07I;ehMS4d^J[f>" + A$ = A$ + "mnQLeElZn;bY8?1M6GD5TZC68BT^T\1`DciDACVPSbD7E" + A$ = A$ + "ZLjdYOo3f[ofKM>i;Z;8W?i034Rb^BMO4B9S:cQk?Fj8b?" + A$ = A$ + "c>_[k2[B0C]8W>62654[ESP5D]<9ZMI0_@1BeCFPR5[E20HKC07U:7i0a>hPH>hP3Ri0Q17V>b1000PPaZ6eJ" + A$ = A$ + "ESHc>[A\151SP5RK[000PXCD=X2FE@d2R" + A$ = A$ + "6=H=DeQ6m^:0P0\F;2X8P2@ADZkA]d4>k0Hn0=jiaiORNZahZ:00hTL`Y?hm" + A$ = A$ + "oaQcT9Z:@Bii7E7]P?4Z`3002UP42B]Gi\d`Bn=0P?6Z3?YC47PiW70bRXE0" + A$ = A$ + "bH`D6000SXC:E>8@ZBEZL85796C000" + A$ = A$ + "04`P5e:FA\63adV4\ZY5H=3\UFH=E\Ze5a2[RHH9RJSFH=a0a@105@DdXEE5" + A$ = A$ + "D=X54]gCB6505@DdQHSA00`HKM:4L@XVZ65<65@5S:H;j4000P_cHYJa:?>e" + A$ = A$ + "ZY?LHiN_6PXA\1E3Z6AI`:J]:P2HQ00004\g0" + A$ = A$ + "3K<<`NKDCk]XF]c@]HW9fJS=VfIedZ=:RZ0P:8ZE\VRE]0\Z1ZYE@AdXC[2Z" + A$ = A$ + "6DE150]R:fH1\1D1KMJA010038ZXaQ?LX@[XAaPZPHSPA\XAE40000\XAE1@" + A$ = A$ + "aP2X:2:8J554D153J04dI0H[5A`R086]0JD54153X0X08R60<08WJ`2X2P:6" + A$ = A$ + "=:ZZ0J0SP1B:@7nP_CLCNPH04]800" + A$ = A$ + "00H4]011CRo3619TB0PHY\KGko4Mj>hhI2<6Y?72Bfc00:Q6=ZX_YO5DRV;5" + A$ = A$ + "102YNZNLjmJ0NP3IdHJe14Mi5A<63L8S6C[>PX;_8Rah=V]724[]D=5ShY3R" + A$ = A$ + "iP34c>`GnJET?=_V;I1i31PV[McOE>gh?i_iYL^m>L\m5lCNh1SEJVOAKkN" + A$ = A$ + "kV\HYE;klKJU2aL1D5PkjMh4F^AIY`UcXe>[1he=TPXTI\0NiYUcIZ^Q44U<" + A$ = A$ + "S5`;?YL>3_9c2YjX\Pb0QF[c`@\=W2T:78hP;0000S" + A$ = A$ + "AADD<:RRQmfSEk=4K\gN<@\RMHWYE4KE\Ja6E7:P0082FA\9a2@=0;E`2@1d" + A$ = A$ + "XZ0R0f8R1AdX08002PRZX132H1D0aJ15@A0E@04AW:2dH3R1A0E_[RQ>T9kd004Rl@LNBBol1FF6hNRdT:" + A$ = A$ + "ITBmRP@f?0LK3678]l4LPobiL;An2TiPhd0Po^kl^OAA57472`D>8@HQR=`A" + A$ = A$ + "C104oiLX?T_eggQ\Q0QAPS30nN3Q`BFe44lQWQH?]g@8XTE\PTGNJai4m2U1" + A$ = A$ + "UI=B:bC[aBoIN>aRg73ak4RM52F600@4" + A$ = A$ + "D`jH8X:X0XJ@[E4=PQPX3XiPJ>JD?X2hPB2;@@jcN0P2W8=96]X8EfZD0:1YJGOjSF1L00H8`P5@T=^RVZ0ZE>" + A$ = A$ + "H4PTRS=428P5@@[8000<5Q=XPRHZ^DEd:P5J1<0fJ000nR3=^DRf4Tlb26S;" + A$ = A$ + ">dh:9Z98iU5<6^2\1KYBl>RHa?LK[EUZBVHNj2000k]c><4;RmREA5K]HP=H" + A$ = A$ + "YYHM[[fPJ;D[[FH5[JRUVFA\R5:FgBeVd:820Hg8XXC53F1AD1E9MkW<9XBn" + A$ = A$ + "f0g0B14h@3BhUGFE=RAHJFbmHCB=Ok58N>Hhl]?N_nS:0P]1mZRPH@E4[7DEdRNK70;HFA" + A$ = A$ + "0FE:nN6WRSUUO=0;PWgchLJ\9le@Rl3PkN1Haf3K]SZ]=\jZQ5\EJ1100PEk" + A$ = A$ + "1K5a`Fa>kALd>3;9H9>KdhSLD4ED3ED<\^e<=]Re]RYJ5[[a0:Z:6\B95QAF" + A$ = A$ + "HQ3RCLD\`bI1FFhP`0SL@X`bRBFFhP`Pa1Q2;F0\RZNe@DE<00]5Q1QR:]00" + A$ = A$ + ";S23:<`X`0S\\;TGLWFVdA:00la9bFSX7aK5;FG6T1X9gc3`agglalcEN]Z" + A$ = A$ + "2:V6TU1_HA9[20jKL4A;0h2m4500@aA6E00PEiU`830P<:FP\<\ii^Y175;\" + A$ = A$ + "\0IA8Y60%%%0" + RestoreFile A$, "drowning.ogg" + + 'iglooblock.ogg + A$ = "" + A$ = A$ + "?MfIC1P00000000000@X]00000000TW_AJI0N4PM_9WHY=7000002@4[0000" + A$ = A$ + "000004W00000000^1ldIW=50000000000000Qf20040000``^4bmB\cooooo" + A$ = A$ + "ooooooooooooooooA>PM_9WHY=g:0000HU6LXibCbM68\UVHFmVLRUfLPT48" + A$ = A$ + "b0C>Zi9YVciL66WhXLPVCJ>QcYPLPRA1N>98Lm" + A$ = A$ + "VYCjX>ZSjX>:d2]@;d2]B[4CaD]ESiJ_6d5OciL>" + A$ = A$ + "WciL>WciL>Wc98d@F500P00048T1I@642Q@85BQD8VRYH:W2bP8J2]VcgL>>XIiPV:5K>M`9BeVWTKZ" + A$ = A$ + "H^iL>WciLbVcI<>WciL::WIaPV9dJ>Wc9aPVU2JV@[iL>WW4KN@[Y:]VciL6" + A$ = A$ + "WcY36WAHL>WcY9]V7TJfH]iL>W5dJJ>ZiBaVciLRD^i9eV;EK>WciL>WciL>" + A$ = A$ + "WciL>WZGLjL`i4>WciLRJ_iJiV@GL>WciC6W^gL2QciL>WciL>WciL>WciL2" + A$ = A$ + "2=TE100@0001QQ=66gYPPdWS6865QHJ8Cj1M?j`TP63bY@Z7=jXA:UjP@9E6" + A$ = A$ + "WD:M22=TE100P00042QD85BQD85BQD85BQD86RQH86bYL:W2ZP:YBZX::Sb\" + A$ = A$ + "<;cb\<;cb\<[3k\>[3k`@<43a@[d:aB=EKeH=F[iN>W[iPdJUF[eJ]BYD:UB" + A$ = A$ + "YD:8d@F500P00048T1I@6TAQD85BQH8VbYL:W2ZP:P@3IE000800800000?9" + A$ = A$ + "?7A7A7A7A7A7A7A7A7A7?7?7A9A9A9A9A;C;C=C?EAEEGIGKIMIMKOKQMQMM" + A$ = A$ + "OOMOOOMSOMQQUUUUUUUUUUUUUUUUUUUUUUP@3IE0002000P@842QD85BQD8U" + A$ = A$ + "RaH<7ciP>9D212=TE100P00P00000LDLDLLTLTLTT\T\TdTd\d\ldldld4m4" + A$ = A$ + "555===E5M5M5e=]5U=U=M=M=U=MEUE]MUU]]U]e]mUU]mmmmmmmmmmmmmmmm" + A$ = A$ + "mmmee12=TE10P400P>B>B:B:B:B>>>>BBB0Q6bZ00@600@00PRRSRSSSSTTT" + A$ = A$ + "TTUTVTWUWUXVYVYWYWZX:@XQ\:00040040000000PRVRWRYRWRXRWSXSXTXU" + A$ = A$ + "YUXVZV[X\Y\[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[;@" + A$ = A$ + "XQ\:00T000dAbAbAbABABABAbAb18d@F500b000200L:G>@B2BB`C3PSU5llPW6<=1hHI1??Xi1CC00" + A$ = A$ + "00000000000@bC3NN`c3VV0TdlPW7llPY900000000000008ii1??hi1CC0B" + A$ = A$ + "NN`c3NN`d40000000000000l<=QY94=QZ90?CCHJ2CCHZ200000000000000" + A$ = A$ + "000000000000000P000P1L0002`4:3DXQ\R00RC00LhX89100PSTTU5000:B" + A$ = A$ + "BFF000HIIii100PTUUW70000000000000000000000000000000000000000" + A$ = A$ + "00000000000000000000000000000000000000000000008000H0700P005J8[40P@2007>>FFNNRRRR" + A$ = A$ + "VVVVZZLL\\ll4555==EEMMihHIii9:::JJZZjjbbBCccCDDDddDEee5JJNNR" + A$ = A$ + "RRRVVZZ^^@CCDddddDEEEee5JJNRVVVVZZZZ^^`cCDddddDEeeee58:JJJJZ" + A$ = A$ + "Zjjjj245====EEMMMM1RRRVVVZZ^^^^0CCCCEEEGGGII0VVZZZZ^^bb0DEEE" + A$ = A$ + "MMMUUU1XZZZjjjj:;3`eeeEfEFFF60^^^^bbbb2000>`10080SP>9SZ\8\AC" + A$ = A$ + "h2?0DXQ\R00R2000<6VBaD:3S9Q@:4JH<94BQ@VDBYB:UZP@ZDBUB54BUBZD" + A$ = A$ + "bXD;UJYD54BUBZDZP@ZDBUB100H7h00PMP525J8[40Pl0002SAYHWc9A8URaL>WCZDWD:IYDbH>WciLBYTaL>WciTBYciL>W3" + A$ = A$ + ":UBYdiL>WC:UB94jL>WD:UBWciL>100@5h0004P=:bVC`81EXQ\B00B500YXa2\@3IU00T100@H<" + A$ = A$ + "8T2Q@8U1Q@:42QD:529000H0700P00@" + A$ = A$ + "IAHSc`:9MFQS6LQ6b:108T000`H@863jT@YT:YD52aH>XDBUFZUR]:4RaP@Y" + A$ = A$ + "TB]F\5S5?Wc1QB:UJYH:f:N>WC:YD[5SaH\FL]@8UBYF;fR]H\9KQ@:UB]F<" + A$ = A$ + "6[eHcXD]DZeRaH<6[aRBiBYD[5KaH\FS5QbVK]F<6[eJ]FC:U?gBaF]FSaJ]" + A$ = A$ + "V<:SB6SaJ]6[eJ]8D:U<6CaD\F[eJB8<6O?6SaJG000e3>00D9H4d9IDU5Q=J2Gh1P2=TE20@^" + A$ = A$ + "10022YD<6SiL>WciL>W3BA:6caL>W32Q@842Q@:2aH842Q@84:QB:UbH>Wc1Q@84:UBYDBYDWciP@842QBYD:UB:UjL>742Q@XD" + A$ = A$ + ":UBYDBYD842Q@842UBYD:UB:UBY@842QBXD:UBYDBYD:52Q@8D:UBYD:UB:U" + A$ = A$ + "BY@842QBYD:UBYDBYD:52U@YD:UBYD:UB:UBYD:4:UBYD:UBYDBYD:UBUBYD" + A$ = A$ + ":UBYD:UB:UBYDZD:UBYD:UBYDBYD:UBUBYD:UBYD:UB:UBYD:U:UBYD:UBYD" + A$ = A$ + "BYD:UBYDYD:UBYD:UB:UBYD:U:UBYD:UBYDBYD:UBYDYD:UBYD:UB:UBYD:U" + A$ = A$ + "BYBYD:UBYD:000j0700P0UCU@7S1000PP00`0A8c48@1@16830P3@81Y00X`2QKh9N3?QK`9XCAUj01000000N00h1008I3P8R8JVSS>l" + A$ = A$ + "h3@2ATA8Y4C>151000000\30h300895P8R8JVSS>lh3@2ATA8Y4C>1U000@0" + A$ = A$ + "4000000@04028P0000000@0000028ldIW=504X8500000000Qf20080000P4" + A$ = A$ + ";]HhA`dAmlS?`>:DEP<^L@OLPMDXZ0ILm]^eVR88" + A$ = A$ + "H2b5X10VXeXXRE]R6d^fkmjADdXA`FDD4E]J]lW_AlIaO3Jn<@PR224cm<=TZ2;VFmg>m" + A$ = A$ + "<=TZ2;VFL0e=ZV46\T13]0@cRZRATKYZ8P>1;Z8H]NOVZPX1Q`DDeeeLW]>4" + A$ = A$ + "DFDX;`Qod\P>;9\kLMh?=;XcB2k>GO08?1n6?D4:lT9[Ea2`JHn91@R0eY0Q^aPQJZ41ZC12MS13eD7802V0" + A$ = A$ + "6`@;0TZ0Y4T33[`l8n;5MXA5]6D454SASOJg^\A5mh;AEK[PA;[0hnTgbJ" + A$ = A$ + "R82QPSL]=0@D3ZeHE4KEE]Zg[?>DdXXAD@aZJeZZJ3:R6AA:DK]FL8J4=R2R" + A$ = A$ + "m_XRH=3K`2MXP0Pne`0>OHIjoGC=f?halW;;@i@oJH0G61@Dg4FHdR4O100hhPJ0:S2g60]1^U0HKS790" + A$ = A$ + "00eF=8:Pa]503C00000EDa``FC3CaD\E100000005;6S002PG5" + A$ = A$ + "KE3D9QN6VR2000002M001D_Ja=1D00000<U08SS108[=B\`eWFhH4XBej93`a0X<;P<[" + A$ = A$ + "]`]1@?PK90f070fUX0FkkW1T4f61@Hc:1Q5A^;^_`147\0K000X500dTf400" + A$ = A$ + ">:>260eHE;28H`J5D15AA0D\P5;000PHHW]800XFE<2@b47SVJMDM000RH4a" + A$ = A$ + "H]000HE5DSA\:28000PPJX:0000X00000PHWQ=R0H?000HJWmfI7000PEa@1" + A$ = A$ + "000A\H0R92f:0000R551000000k\edT8=b>C000TD4F62O:QB1XD:O^2c8=a" + A$ = A$ + "Y4:G2h32O<9:h`2K20000l08H;\1;M000000`d6\=000FJE[Y0000PE\ID03" + A$ = A$ + "0XE[>B00\D\60PP]@=16\9;E0000`ZRe000DCKf@1000000adF::Ze\R0000" + A$ = A$ + "PE]AK00001Kb0000;R^dJ0PO6A2XO^MFjogF8g[UG;JPl@J3AHgX=`]402l80008[=8bm;8`>Q5Q5QU`W]0;<``N<008_Q8_1;FP=000L3800A" + A$ = A$ + "AF:00=SH`REDS8FE5Db6DeJ50000ZZF]BRlV0X7`nE2PX06Gj1\_AT4F49QEn2F`n4000]<0P<]PZZeZRa:FA48" + A$ = A$ + "YFS5A\ZaXZ82X08X:DR0:HDAD0410aJ51EEaN31Ea>015A<4A]G]7A051aF\" + A$ = A$ + "0ZZfJX2He>C4@100[8000XH;P80000:R80RE3a0eFD000P8XHP``bB9Ygf0K_Y=4cNZL@\DBA0R5PhDHa8V`0a<;V" + A$ = A$ + "H>R1000HSMfKE4e`ZQ5;HSY9fR]F`Fk<]J_mZmf\5FHSFCE;<5D1C[HE3\d2" + A$ = A$ + "eBK`6]0C3D10@<:JE\5^Je`LEJ0n^;:7@hJL[o4?YiGKVe:f:fJdY6K5SX\n" + A$ = A$ + "=HAEa86A[6Efb?\5I9ci38ZJDA`h4N3P7G^:8@VJhJLk7008^bC@ESZ86AE4EQLM1b^90%%%0" + RestoreFile A$, "iglooblock.ogg" + + 'scorecount.ogg + A$ = "" + A$ = A$ + "?MfIC1P00000000000Pm]000000008h>V@A0N4PM_9WHY=7000002@4[0000" + A$ = A$ + "000004W00000000^1ldIW=50000000000000fg2004000009ooA4B\cooooo" + A$ = A$ + "ooooooooooooooooA>PM_9WHY=g:0000HU6LXibCbM68\UVHFmVLRUfLPT48" + A$ = A$ + "b0C>Zi9YVciL66WhXLPVCJ>QcYPLPRA1N>98Lm" + A$ = A$ + "VYCjX>ZSjX>:d2]@;d2]B[4CaD]ESiJ_6d5OciL>" + A$ = A$ + "WciL>WciL>Wc98d@F500P00048T1I@642Q@85BQD8VRYH:W2bP8J2]VcgL>>XIiPV:5K>M`9BeVWTKZ" + A$ = A$ + "H^iL>WciLbVcI<>WciL::WIaPV9dJ>Wc9aPVU2JV@[iL>WW4KN@[Y:]VciL6" + A$ = A$ + "WcY36WAHL>WcY9]V7TJfH]iL>W5dJJ>ZiBaVciLRD^i9eV;EK>WciL>WciL>" + A$ = A$ + "WciL>WZGLjL`i4>WciLRJ_iJiV@GL>WciC6W^gL2QciL>WciL>WciL>WciL2" + A$ = A$ + "2=TE100@0001QQ=66gYPPdWS6865QHJ8Cj1M?j`TP63bY@Z7=jXA:UjP@9E6" + A$ = A$ + "WD:M22=TE100P00042QD85BQD85BQD85BQD86RQH86bYL:W2ZP:YBZX::Sb\" + A$ = A$ + "<;cb\<;cb\<[3k\>[3k`@<43a@[d:aB=EKeH=F[iN>W[iPdJUF[eJ]BYD:UB" + A$ = A$ + "YD:8d@F500P00048T1I@6TAQD85BQH8VbYL:W2ZP:P@3IE000800800000?9" + A$ = A$ + "?7A7A7A7A7A7A7A7A7A7?7?7A9A9A9A9A;C;C=C?EAEEGIGKIMIMKOKQMQMM" + A$ = A$ + "OOMOOOMSOMQQUUUUUUUUUUUUUUUUUUUUUUP@3IE0002000P@842QD85BQD8U" + A$ = A$ + "RaH<7ciP>9D212=TE100P00P00000LDLDLLTLTLTT\T\TdTd\d\ldldld4m4" + A$ = A$ + "555===E5M5M5e=]5U=U=M=M=U=MEUE]MUU]]U]e]mUU]mmmmmmmmmmmmmmmm" + A$ = A$ + "mmmee12=TE10P400P>B>B:B:B:B>>>>BBB0Q6bZ00@600@00PRRSRSSSSTTT" + A$ = A$ + "TTUTVTWUWUXVYVYWYWZX:@XQ\:00040040000000PRVRWRYRWRXRWSXSXTXU" + A$ = A$ + "YUXVZV[X\Y\[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[;@" + A$ = A$ + "XQ\:00T000dAbAbAbABABABAbAb18d@F500b000200L:G>@B2BB`C3PSU5llPW6<=1hHI1??Xi1CC00" + A$ = A$ + "00000000000@bC3NN`c3VV0TdlPW7llPY900000000000008ii1??hi1CC0B" + A$ = A$ + "NN`c3NN`d40000000000000l<=QY94=QZ90?CCHJ2CCHZ200000000000000" + A$ = A$ + "000000000000000P000P1L0002`4:3DXQ\R00RC00LhX89100PSTTU5000:B" + A$ = A$ + "BFF000HIIii100PTUUW70000000000000000000000000000000000000000" + A$ = A$ + "00000000000000000000000000000000000000000000008000H0700P005J8[40P@2007>>FFNNRRRR" + A$ = A$ + "VVVVZZLL\\ll4555==EEMMihHIii9:::JJZZjjbbBCccCDDDddDEee5JJNNR" + A$ = A$ + "RRRVVZZ^^@CCDddddDEEEee5JJNRVVVVZZZZ^^`cCDddddDEeeee58:JJJJZ" + A$ = A$ + "Zjjjj245====EEMMMM1RRRVVVZZ^^^^0CCCCEEEGGGII0VVZZZZ^^bb0DEEE" + A$ = A$ + "MMMUUU1XZZZjjjj:;3`eeeEfEFFF60^^^^bbbb2000>`10080SP>9SZ\8\AC" + A$ = A$ + "h2?0DXQ\R00R2000<6VBaD:3S9Q@:4JH<94BQ@VDBYB:UZP@ZDBUB54BUBZD" + A$ = A$ + "bXD;UJYD54BUBZDZP@ZDBUB100H7h00PMP525J8[40Pl0002SAYHWc9A8URaL>WCZDWD:IYDbH>WciLBYTaL>WciTBYciL>W3" + A$ = A$ + ":UBYdiL>WC:UB94jL>WD:UBWciL>100@5h0004P=:bVC`81EXQ\B00B500YXa2\@3IU00T100@H<" + A$ = A$ + "8T2Q@8U1Q@:42QD:529000H0700P00@" + A$ = A$ + "IAHSc`:9MFQS6LQ6b:108T000`H@863jT@YT:YD52aH>XDBUFZUR]:4RaP@Y" + A$ = A$ + "TB]F\5S5?Wc1QB:UJYH:f:N>WC:YD[5SaH\FL]@8UBYF;fR]H\9KQ@:UB]F<" + A$ = A$ + "6[eHcXD]DZeRaH<6[aRBiBYD[5KaH\FS5QbVK]F<6[eJ]FC:U?gBaF]FSaJ]" + A$ = A$ + "V<:SB6SaJ]6[eJ]8D:U<6CaD\F[eJB8<6O?6SaJG000e3>00D9H4d9IDU5Q=J2Gh1P2=TE20@^" + A$ = A$ + "10022YD<6SiL>WciL>W3BA:6caL>W32Q@842Q@:2aH842Q@84:QB:UbH>Wc1Q@84:UBYDBYDWciP@842QBYD:UB:UjL>742Q@XD" + A$ = A$ + ":UBYDBYD842Q@842UBYD:UB:UBY@842QBXD:UBYDBYD:52Q@8D:UBYD:UB:U" + A$ = A$ + "BY@842QBYD:UBYDBYD:52U@YD:UBYD:UB:UBYD:4:UBYD:UBYDBYD:UBUBYD" + A$ = A$ + ":UBYD:UB:UBYDZD:UBYD:UBYDBYD:UBUBYD:UBYD:UB:UBYD:U:UBYD:UBYD" + A$ = A$ + "BYD:UBYDYD:UBYD:UB:UBYD:U:UBYD:UBYDBYD:UBYDYD:UBYD:UB:UBYD:U" + A$ = A$ + "BYBYD:UBYD:000j0700P0UCU@7S1000PP00`0A8c48@1@16830P3@81Y00X`2QKh9N3?QK`9XCAUj01000000N00h1008I3P8R8JVSS>l" + A$ = A$ + "h3@2ATA8Y4C>151000000\30h300895P8R8JVSS>lh3@2ATA8Y4C>1U000@0" + A$ = A$ + "4000000@04028P0000000@0000028ldIW=504@@200000000fg200800000:" + A$ = A$ + "[k0g80UDogdoil?6Lf_RLf8`?9>5?AKWm[8W=2lCRCaCdfII]R8@`1;T[900" + A$ = A$ + "a:X6SPJZH=[8_kc:JdX8RPZ:2ZJE=R8JdQ\`OfZJE=NQ[TPY]dFJYY2PYe]^" + A$ = A$ + "Un11nc3d86m@A?Ka1W0oi1J4SNXXW]hPc;0;[9=JCJ20J205Ka`414Q?EH>L" + A$ = A$ + "X6ZXXfBAS5\HAWFS5;8FEW:PX6VRe]U6R20Z=gI[FWZR100[K;U0JM3S5^V;" + A$ = A$ + "\@c7?mkgA?UbGXn4[^Qa2Gc5FXiSWnmkXWBi;DORm=00dZod;SeG200>@d00" + A$ = A$ + "04C\hf000a8J000a8n;100@H3d;53W1fFP80@BTAIMZN000@]" + A$ = A$ + "A:3B2b`ZYYQQQ]Z5E5CK<<0T]000Z008;008Z008;10P:ZQYH5[F\1@1AaDD" + A$ = A$ + ";6fJ:PJDaHD`R1S8FPb:8" + A$ = A$ + "Ja:6]:XXRZJRh`7EMJFeB^?MgK@9P`5\Ba3LHYDbggUb>TFZVE[NKnf?JIAU" + A$ = A$ + "d346:HiAh82OQhc14WVN\[FaVMVX0C:5n9@BBDCe2A\0X:ZRMFDA01A40[H5Kb2;\V8FXVZUFeB[ZP65DD@A\" + A$ = A$ + "P5[RZFDEAE5EE\[IgM6Zc@URQ7Z9ZYHJ=[H;]@=k\UeRSLN3MJHf`R]O]k\cFF;>bk>M78BR5;5" + A$ = A$ + "V8IN1P`091Y245`dN1imWolW550E<]`ZFcjFaBSWli?oi?3K^e]V;leWo\X2P:VFa" + A$ = A$ + "jfT=K3F:Omi?3TcgNKYOoi?3li?300F\RZ6]J:YF[eZ0OmIKf2D3;]`B;<=<" + A$ = A$ + "5EDImFgjF1n\;R@MaB\cooooo" + A$ = A$ + "ooooooooooooooooA>PM_9WHY=g:0000HU6LXibCbM68\UVHFmVLRUfLPT48" + A$ = A$ + "b0C>Zi9YVciL66WhXLPVCJ>QcYPLPRA1N>98Lm" + A$ = A$ + "VYCjX>ZSjX>:d2]@;d2]B[4CaD]ESiJ_6d5OciL>" + A$ = A$ + "WciL>WciL>Wc98d@F500P00048T1I@642Q@85BQD8VRYH:W2bP8J2]VcgL>>XIiPV:5K>M`9BeVWTKZ" + A$ = A$ + "H^iL>WciLbVcI<>WciL::WIaPV9dJ>Wc9aPVU2JV@[iL>WW4KN@[Y:]VciL6" + A$ = A$ + "WcY36WAHL>WcY9]V7TJfH]iL>W5dJJ>ZiBaVciLRD^i9eV;EK>WciL>WciL>" + A$ = A$ + "WciL>WZGLjL`i4>WciLRJ_iJiV@GL>WciC6W^gL2QciL>WciL>WciL>WciL2" + A$ = A$ + "2=TE100@0001QQ=66gYPPdWS6865QHJ8Cj1M?j`TP63bY@Z7=jXA:UjP@9E6" + A$ = A$ + "WD:M22=TE100P00042QD85BQD85BQD85BQD86RQH86bYL:W2ZP:YBZX::Sb\" + A$ = A$ + "<;cb\<;cb\<[3k\>[3k`@<43a@[d:aB=EKeH=F[iN>W[iPdJUF[eJ]BYD:UB" + A$ = A$ + "YD:8d@F500P00048T1I@6TAQD85BQH8VbYL:W2ZP:P@3IE000800800000?9" + A$ = A$ + "?7A7A7A7A7A7A7A7A7A7?7?7A9A9A9A9A;C;C=C?EAEEGIGKIMIMKOKQMQMM" + A$ = A$ + "OOMOOOMSOMQQUUUUUUUUUUUUUUUUUUUUUUP@3IE0002000P@842QD85BQD8U" + A$ = A$ + "RaH<7ciP>9D212=TE100P00P00000LDLDLLTLTLTT\T\TdTd\d\ldldld4m4" + A$ = A$ + "555===E5M5M5e=]5U=U=M=M=U=MEUE]MUU]]U]e]mUU]mmmmmmmmmmmmmmmm" + A$ = A$ + "mmmee12=TE10P400P>B>B:B:B:B>>>>BBB0Q6bZ00@600@00PRRSRSSSSTTT" + A$ = A$ + "TTUTVTWUWUXVYVYWYWZX:@XQ\:00040040000000PRVRWRYRWRXRWSXSXTXU" + A$ = A$ + "YUXVZV[X\Y\[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[;@" + A$ = A$ + "XQ\:00T000dAbAbAbABABABAbAb18d@F500b000200L:G>@B2BB`C3PSU5llPW6<=1hHI1??Xi1CC00" + A$ = A$ + "00000000000@bC3NN`c3VV0TdlPW7llPY900000000000008ii1??hi1CC0B" + A$ = A$ + "NN`c3NN`d40000000000000l<=QY94=QZ90?CCHJ2CCHZ200000000000000" + A$ = A$ + "000000000000000P000P1L0002`4:3DXQ\R00RC00LhX89100PSTTU5000:B" + A$ = A$ + "BFF000HIIii100PTUUW70000000000000000000000000000000000000000" + A$ = A$ + "00000000000000000000000000000000000000000000008000H0700P005J8[40P@2007>>FFNNRRRR" + A$ = A$ + "VVVVZZLL\\ll4555==EEMMihHIii9:::JJZZjjbbBCccCDDDddDEee5JJNNR" + A$ = A$ + "RRRVVZZ^^@CCDddddDEEEee5JJNRVVVVZZZZ^^`cCDddddDEeeee58:JJJJZ" + A$ = A$ + "Zjjjj245====EEMMMM1RRRVVVZZ^^^^0CCCCEEEGGGII0VVZZZZ^^bb0DEEE" + A$ = A$ + "MMMUUU1XZZZjjjj:;3`eeeEfEFFF60^^^^bbbb2000>`10080SP>9SZ\8\AC" + A$ = A$ + "h2?0DXQ\R00R2000<6VBaD:3S9Q@:4JH<94BQ@VDBYB:UZP@ZDBUB54BUBZD" + A$ = A$ + "bXD;UJYD54BUBZDZP@ZDBUB100H7h00PMP525J8[40Pl0002SAYHWc9A8URaL>WCZDWD:IYDbH>WciLBYTaL>WciTBYciL>W3" + A$ = A$ + ":UBYdiL>WC:UB94jL>WD:UBWciL>100@5h0004P=:bVC`81EXQ\B00B500YXa2\@3IU00T100@H<" + A$ = A$ + "8T2Q@8U1Q@:42QD:529000H0700P00@" + A$ = A$ + "IAHSc`:9MFQS6LQ6b:108T000`H@863jT@YT:YD52aH>XDBUFZUR]:4RaP@Y" + A$ = A$ + "TB]F\5S5?Wc1QB:UJYH:f:N>WC:YD[5SaH\FL]@8UBYF;fR]H\9KQ@:UB]F<" + A$ = A$ + "6[eHcXD]DZeRaH<6[aRBiBYD[5KaH\FS5QbVK]F<6[eJ]FC:U?gBaF]FSaJ]" + A$ = A$ + "V<:SB6SaJ]6[eJ]8D:U<6CaD\F[eJB8<6O?6SaJG000e3>00D9H4d9IDU5Q=J2Gh1P2=TE20@^" + A$ = A$ + "10022YD<6SiL>WciL>W3BA:6caL>W32Q@842Q@:2aH842Q@84:QB:UbH>Wc1Q@84:UBYDBYDWciP@842QBYD:UB:UjL>742Q@XD" + A$ = A$ + ":UBYDBYD842Q@842UBYD:UB:UBY@842QBXD:UBYDBYD:52Q@8D:UBYD:UB:U" + A$ = A$ + "BY@842QBYD:UBYDBYD:52U@YD:UBYD:UB:UBYD:4:UBYD:UBYDBYD:UBUBYD" + A$ = A$ + ":UBYD:UB:UBYDZD:UBYD:UBYDBYD:UBUBYD:UBYD:UB:UBYD:U:UBYD:UBYD" + A$ = A$ + "BYD:UBYDYD:UBYD:UB:UBYD:U:UBYD:UBYDBYD:UBYDYD:UBYD:UB:UBYD:U" + A$ = A$ + "BYBYD:UBYD:000j0700P0UCU@7S1000PP00`0A8c48@1@16830P3@81Y00X`2QKh9N3?QK`9XCAUj01000000N00h1008I3P8R8JVSS>l" + A$ = A$ + "h3@2ATA8Y4C>151000000\30h300895P8R8JVSS>lh3@2ATA8Y4C>1U000@0" + A$ = A$ + "4000000@04028P0000000@0000028ldIW=5000d;000000004a20080000@e" + A$ = A$ + "4ACCK\eECm_MocdofloAo[aoImoGoWboQmoLokeoFA?5KX?[XjmonOGE^lX;mD\8NUJ^=mV5" + A$ = A$ + "OlJadRUO^GQioEJC^9W_og11KT3_njV5alNe^ll\800m1TI104`Vn0BZ0We8" + A$ = A$ + "Pfdj3PM550DCPT5PC8HiChK\G]XRVD]0e0]V;Q4h9`a;MLT2gML6DoegEmkEe[GM]O^o[N[S" + A$ = A$ + "[cl9@knXKi7bGc^OBfmGJlR4@MA91X_I4fBeLM4Alb26S_=4TB58434\JRgO" + A$ = A$ + "00000NA@B8JGh6KW?K[_]NO7AhFGK@I000e83A6]AQ40`b?C0^W[9ZXB@h0fM>GO" + A$ = A$ + ":ZXKe060@\8FJ=3A9400JEUaJdD500PV7?A=5UZ200h5L@\]T008[0SlJX10" + A$ = A$ + "PT:HUT``@00@^U9C76>0`IF=20_D@C1cJhDDMIED95UMhDYe<=D2bF\>@Y@8Q\g`BcX191BB24" + A$ = A$ + "meRXe^Y00^V=i;bf200d<`R5396`5he1g500@2i:6gT509QBdhH:6eO_]@`R@\BJFZEAeHA@01DDeXE14A4P1\23" + A$ = A$ + "2eAQ1Qmk\CJ@T4[XZg2" + A$ = A$ + "HFlTTC]RaNN;308XA9;cBf1d00DAQJ50hb[4f[``HV:=@4APV4jT6BJXGUc6PV^7PfASPh1>CdZ:eKO@QB\aR" + A$ = A$ + ";5M?;>0100MiLDh;B?EI[<;bA>b2040XZ2gZ:P@8Q`:>`2@404\P100P67R2a=H@038E1150;0XZ1\LI1H4G:QhcW[" + A$ = A$ + "^lJEj7\0D7UB10Q0800iFVEE]5fTQR0000FAWJdZC;2000PXZH;RZF3000PX" + A$ = A$ + ":h2MX1000LeE:H@[F4008LE2E?0k>aPR61`0F\026\FST80G6hl54GU0hK0_" + A$ = A$ + ">000E]F``J`Z000D`Fn50n\6I3000F[:b]60PP0<]e0000HEDd\BS10000H4" + A$ = A$ + "[cN0Pb@Q>dQ>[Y1`000XSeX=L0H`VEE1A000X=6aJF0D0400P:jH8G0F[Z1E" + A$ = A$ + "E000@`R5\R>:00000TBaE:30HOB8m00HT1CD0000hPHQ1EMG20H1G\061dGG" + A$ = A$ + "F100A\H10Ql1Bc78K<1?@Hl0ISakN`<0dkL_82`9>h" + A$ = A$ + "PCLRSV3a;4V\21UTIJ1L100P]fHJJE<=`>3C;F]HHSH3PE\7E]Hed>3;FD\c" + A$ = A$ + "NK``4e4E\XHMXE7jDdYZ>eZZB8680Q6" + A$ = A$ + "V@56H10`fJiKci2000Y8QBT=0TDQB`000R5]R>A;fH0040S:ZSFEE3P8PaH0" + A$ = A$ + "4AdX09108SG^=;YR4fPEHPe8`fE5g=0hfnK4AAAd<2EPT8b1F60023ch=8m;" + A$ = A$ + "daHIXP600<>39430lPl820PN[`;F0:;k:ek1fbAYj0\P8MZCJ7iXY;0000" + A$ = A$ + "0A;PfJ>4FcG<:RPE@X88:6Z]1WfP78@4H20R:0G2QUQUQ`E@9=[H2Z0:jDSZ" + A$ = A$ + "REeXF[BMFXU000>02RE]9[ZFc6\@D0<0002JeQ=R6510000aB[XVRXF>6C50" + A$ = A$ + "00aFDdYN\E@0fT0005JE`8H;:jE00P0SRF101GA[90PSb:hDbf80T9@3\SK4" + A$ = A$ + "3PeXR000gKIadH0000lRA0Ge0000PXXAA64^e00ffR`:5dXXcZ]100ReKWe\D22700`0e`V6X100000B=j^Vk>W]T^Vk>W]TQe2637i87U200000Z2F\ReH5SPH5aHZZ" + A$ = A$ + "QJ13410100@3VFU8Ca4Q1DF:;;[h41TPS4Fa6\`2[HHQ5RQ0VXAB5Amm<0H5" + A$ = A$ + "E5EaJ5=N1`d`B3;5C[;fP128f;GC<]ZH=11000\RZR1Se:J404004;F2RLP50000XXSHTAW4C3e10`[FVH[J20>0Xg1000H0@A" + A$ = A$ + "cPAFP:hPBVI5K;R000000=ZT9KKQO300SEEd4Q000008_\8;Z:J010000@F6" + A$ = A$ + "_^X2804;60KUZ00@T;=PEEd58P04PD5o[A7PP028FoR2028f:J0HJHPog`Rf" + A$ = A$ + "7[Lb9@kJKZB>QncHAkSENi4XM]=EaHhMAEI88U5A=51\hdCU3>8F:CWNS:BT" + A$ = A$ + "823ZTfeM8>000@=HDaJE1S1A\HWQEC[2FDa>eFk`JVHE<]1;]1[S=JMKdB;A" + A$ = A$ + "mVDg4[X:ZP8JdXA@]9bVlMW8eo69I=ZOEI3Yno?Anj40HYK:TEO:TE0EE]ZZ" + A$ = A$ + "HaRaY;Q8JDdQXH<02000886]VFgdBUB0D0f4i[FLCP000`=Hk=K2\]]W;^LddA28BHQ5FH2C14@0jl" + A$ = A$ + "90004SE55AaX6aX=200\:RPVJJJ@RUTfE[F^Na@0EAD4U;Q7X\D`0F>4n<44" + A$ = A$ + "D4DA\Ze\Z8VJ]PZA4A`2610``ZFcBAD4=:P060000<\^=HE4E=\0[KE5@405" + A$ = A$ + "14<:jDS:26<]^Y8Z2:28h5g2FD3[IQP000LT780:XE;000FA[0230=9H]ZR2" + A$ = A$ + "6<2FC9P0PEdQ6\8@PZ6]2Ab8XCMJ1;RZ>D5`2HK`JEEdPKdZIY10_m0PH5[i" + A$ = A$ + "V6RIf30F0X141[J;1C14@Nh1@1ed6]9;0D0P108PHV5HKJ400[XE7F[FS=00" + A$ = A$ + "9DdZH];RR0HKPCAE0ACE<28Pb\802[FI00o7Yi6:0^TXiWWRUNm1BL>27]" + A$ = A$ + "E;`0007<1@LU8\0I[[;G7[R4FHA2;^BIMM0000k<<]g63@E5A\aNe00P]6f;" + A$ = A$ + "fK_Z:ZZ:8X4BC414PQ1DFnl5T?Ge2[H3IYE\@4De4C9MCRef4e2e0KF\01@1" + A$ = A$ + "0A;0\I55@=0@k87HA2H<0@:6[E7J:1WQ1Q180`X022026HM;4180SYd<3Yk=d" + A$ = A$ + "ZI=HaR530?>IBg26^E]aPGQ0E\9C]EDD8?@g02:8bJe^64XOL>9" + A$ = A$ + "P:ZX9ZXP=XFEeP8PED@@@@D93FGSP00004Ke:\6F5541A1\aH57HIE0:SHSF" + A$ = A$ + "a:H72XZJ@F8;[HZ619@T4mC\kRO1[45KOP85KiFR`ISY`jbU2CT^;0000R5[H=61[" + A$ = A$ + "J\6[JSPMV2R=fZHHa>5A<]a`6[RX:89VfTUV:FcZRUFA7>PMH9DnQ0Z0ZmifUASBSj1D\W7Rjka:]\M6]RPR30P\09E" + A$ = A$ + "054Da>Ke:6XIK4=Ef68AA9K[UUF8:2X0300@Y:IW5c2\EGGK1[9Fe2Hc_V:K" + A$ = A$ + "]c:fdXcf00A4E7oI1hS=D`cl]Ve=ONUX[8ngaSRi4`;400\WBZb9fY;^B4KChD]LS`BVRWHWnJZ0000IDKA@0HcFSB\0<@4e@" + A$ = A$ + "dY6SPXA\1R200`0R]R>eHRXP9Z=ZFc01SONHbE9B068F3KfBD55<" + A$ = A$ + "H4Ej:G3?\JYQ=H102000b1F:67BY00X8:6VfLY1HgeVmMG488X2YFH3R200:" + A$ = A$ + "JED5100CB[:XZT9K4304;eXZHg69100`;M8H5[YVHJHYQRXl@A0X0001`ZFG" + A$ = A$ + "7XA]PA0010D@;adJZYe3f300@7\RF5[>jB7A[80:06T6V<8n5F@?" + A$ = A$ + "8:`\L\CP=8DPfb>1\1A18cFh0jAD0V5L80T_`700000af\B3SePeT08;B005" + A$ = A$ + "<`RQH_R98PFDARcKV0^V0RPZ@`6k]86X0RPYID[]a;0XTa=[FSgEC00@;Hh5" + A$ = A$ + "C_3id:P0XPHA2aL1@4@A=Tha2PRJX2:VF\g0A55A54Uj<<;F=E@0@1XQ0Z98" + A$ = A$ + "2X0`QS^j5VE7^4amA4S33O]j45MX`JeZ:JdA]eY>]R6=RFE]82H@=D3C\^=H" + A$ = A$ + "QEA54`PT`Q@@DFYYY9SDD134KYE\1;a4T2KT5`@ZgE5W5PPXFXEa2PQ9BM8O" + A$ = A$ + ":<`208Q1kLhlUO9818SE5H`bb2I`1>JH010FhB[g:601`0`PU210H00`PZ=V" + A$ = A$ + "44`0`2XQED0HS=Z82P200TnRca=D1\:f0QQ_;3O[;>nKj8>oA]5A:T2YR6I724:jc`?7OKN7igbk7OOn>2Z2P8Z:HYH;4444;581" + A$ = A$ + ">4Q4J@[5B4<23Pk0`0Fc5UAm1j4`7RKJJ5Kb`jfXJPR@0@2`0<82C00e[7P34MF865@_dA4]b0<9" + A$ = A$ + "Ba8J1V=52CaM\`Q44hdMThJBH2000CK=MR8VRECe>3k@0AaH4A`H@@A14e03" + A$ = A$ + "K]c@4la\GL5405405EECaD``>DadB=;J6k<\Ha`@<]VJ53\RUF1;]R]d2K6S" + A$ = A$ + "ZEeR:65D45@P1;KRUQZ4GgFJ03X3A[a008RR6=j@SR8Rd^;J@]NgMBfY5I_J" + A$ = A$ + "=C]e[15E=Fa:6<664Qd100228F_F=JEDaUF[F]JEEmoB?40C\g6]EKB1ED`\" + A$ = A$ + "JGW00`j9Q]X:6AESZR540008@DDdQ6MHH=KbjfB;\ZE\d@1070`L6ViZQ::H" + A$ = A$ + ":FejIA[UI[IoOOc000H0\XZA[VB0\WH:f2\:ZR202RP00fZZJeI5EKSU:eFa" + A$ = A$ + "800X8jdH0haE\hMc^:_eE1X>32X6778X\BV`;DHSfZn40Y8Z]2^45@kNY`W1dC@RF0mF0m" + A$ = A$ + "Qf9030005E4\9E\6aPJD4[X6D4[E=2P2fH[mVFEE4A@9KAe62VB4]@ZQZ9Vb" + A$ = A$ + "Te4A@Q6H@=Z:ZX02ZJ8fI[]VF0@@E1;F]5SHZX2RZRP9V26fIGYVQ0APXPH3" + A$ = A$ + "fPY=JY5f2\Ze=\`2eZ2Z65AE[eXPZZA>fB4J5@\]0G:BfF@825SU2U5PKIY@" + A$ = A$ + "lQXI_W0F@aHdX]`IPE^4UX\QBZNe_7`^W^>c0\Yn2PPPRJDZlSQ44DWj83" + A$ = A$ + "@98QOB;0V9R0@6g`4\0J000HW5e>\cFe6[Z=FEK\RQXfQ=fKE@5@D459@2dB" + A$ = A$ + "=;5[:RUeFD[A=FUTIed0E014@PXRA?cabRYe\dd6\dBKQUFJCFJJCFJY=HJY" + A$ = A$ + "=IJYQE=]`B[JHMC3[RX8:68SMFIJ;R8XFJMKfFJ;]^Y:B8:YDiSdJDXN;da6gdPXZ" + A$ = A$ + "3MZ3]:F\04?o5803R8;SR:R8:VHJ1fPFAPXJVl@f^91`T220ZJ\^e\Z5VRR2" + A$ = A$ + "h08bJa0h0OBM2XZZHTEK`FHCfPETf^RO;giaK;4`6@A[6]R1:ki0@Bl4hNi5" + A$ = A$ + "ZV0=M109:DaPUUaHQdA`89XZ2R8XVFJm<5AD[A\J[KULFJF00RZMFB`ZMHR8AZ1AH5K`" + A$ = A$ + "d65[IJYHXV66FZ:JDeZXaJA7F5ALS::Re:J<65E[3MRR5SR=2namg7mkgOF@" + A$ = A$ + "\H7_Hi5kX5O7;?`\PA:d1Hj5d_of`402C?Q]6[EC9:JUJE1`e]DV;:C^j=Fa" + A$ = A$ + "[A]LIZUf9b>RJbUEJii9GQTHU5Xa:7S\S0;IWJE4KYa202AXg0Jil1;YY2h9" + A$ = A$ + "1`=DBIl6T1I8H546QAPUa;^;aa=L3`IWS7odFW:FWeI13lQ9Kkc^HOiP5N0U" + A$ = A$ + "U3Q;h@h:YHBl]O?Wi5QC\WK?Ab;D[1PgUaOf>n]F2nZjhUFP^NY5a\iXQ0JEW88PB811PT0B000004<]@\I3[IEC[PE5;DEePFAAe:X:R:MG" + A$ = A$ + "O7=EiMF3Ze:JASE[5E4W:fJD]^FUj]E`B6I;29bNIEnndoFSZ2JePfZX:R:U" + A$ = A$ + "AM\Z4eY:A5VERUmR56I;FGDX2dgMdTl" + A$ = A$ + "24;000^mJgN000P_a3000P;:00>1%%00" + RestoreFile A$, "fish.ogg" + + + JumpSound = _SndOpen("jump.ogg", "SYNC") + BlockSound = _SndOpen("block.ogg", "SYNC") + DrowningSound = _SndOpen("drowning.ogg", "SYNC") + IglooBlockCountSound = _SndOpen("iglooblock.ogg", "SYNC") + ScoreCountSound = _SndOpen("scorecount.ogg", "SYNC") + CollectFishSound = _SndOpen("fish.ogg", "SYNC") +End Sub + +'------------------------------------------------------------------------------ +Sub ScreenSetup + GameScreen = _NewImage(400, 300, 32) + GameBG = _NewImage(400, 300, 32) + MainScreen = _NewImage(800, 600, 32) + Screen MainScreen + + _Title "Frostbite Tribute" + + $If WIN Then + _ScreenMove _Middle + $End If + + GroundH = _Height(GameScreen) / 3 '1/3 of the GameScreen + WaterH = (_Height(GameScreen) / 3) * 2 '2/3 of the GameScreen + SkyH = GroundH / 3 '1/3 of GroundH + CreditsBarH = _Height(GameScreen) / 15 '1/15 of the GameScreen + AuroraH = SkyH / 2 + + DrawScenery + + ThisAurora = _NewImage(_Width(GameScreen), AuroraH, 32) + + CreditsIMG = _NewImage(_Width(GameScreen), 40, 32) + _Dest CreditsIMG + _Font 16 + Color _RGB32(255, 255, 255), _RGBA32(0, 0, 0, 0) + _PrintString (10, 0), "Copyleft 2016, Fellippe Heitor. ENTER to start." + For I = 22 To 31 + Line (0, I)-(20, I), Aurora(I Mod 7 + 1) + Next I + _PrintString (20, 20), "Frostbite Tribute" + CreditY = -2 + + _Dest GameScreen + _Font 8 + +End Sub + +'------------------------------------------------------------------------------ +Sub RestoreData + Dim MaxLevels As Integer + Dim r As Integer, g As Integer, b As Integer + Dim i As Integer + + Restore AuroraPaletteDATA + For i = 1 To 7 + Read r, g, b + Aurora(i) = _RGB32(r, g, b) + Next i + + Restore SceneryPaletteDATA + For i = 1 To 3 + Read r, g, b + SceneryPalette(DAY, i) = _RGB32(r, g, b) + + Read r, g, b + SceneryPalette(NIGHT, i) = _RGB32(r, g, b) + Next i + + Restore IceRowsDATA + For i = 1 To 4 + Read IceRows(i) + Next i + + Restore LevelsDATA + Read MaxLevels + ReDim Levels(1 To MaxLevels) As LevelInfo + + For i = 1 To MaxLevels + Read Levels(i).Speed + Read Levels(i).BlockType + Read Levels(i).CreaturesAllowed + Next i + + Restore CreaturesDATA + Read CreatureWidth(FISH) + Read CreatureWidth(BIRD) + Read CreatureWidth(CRAB) + Read CreatureWidth(CLAM) +End Sub + +'------------------------------------------------------------------------------ +Sub SpritesSetup + 'Generates sprites from pixel DATA: + Dim ColorIndex As Integer + Dim ColorsInPalette As Integer + ReDim SpritePalette(0) As _Unsigned Long + Dim i As Integer + + 'Hero + For i = 1 To 4 + HeroSprites(i) = _NewImage(30, 36, 32) + Next i + Restore HeroPalette + Read ColorsInPalette + ReDim SpritePalette(1 To ColorsInPalette) As _Unsigned Long + For i = 1 To ColorsInPalette + Read SpritePalette(i) + Next i + + Restore Hero1: LoadSprite HeroSprites(1), 30, 36, SpritePalette() + Restore Hero2: LoadSprite HeroSprites(2), 30, 36, SpritePalette() + Restore Hero3: LoadSprite HeroSprites(3), 30, 36, SpritePalette() + Restore Hero4: LoadSprite HeroSprites(4), 30, 36, SpritePalette() + + _Icon HeroSprites(1) + + 'Bird + For i = 1 To 2 + BirdSprites(i) = _NewImage(30, 15, 32) + Next i + + Restore BirdPalette + Read ColorsInPalette + ReDim SpritePalette(1 To ColorsInPalette) As _Unsigned Long + For i = 1 To ColorsInPalette + Read SpritePalette(i) + Next i + + Restore Bird1: LoadSprite BirdSprites(1), 30, 15, SpritePalette() + Restore Bird2: LoadSprite BirdSprites(2), 30, 15, SpritePalette() + + + 'Fish + For i = 1 To 2 + FishSprites(i) = _NewImage(30, 15, 32) + Next i + + Restore FishPalette + Read ColorsInPalette + ReDim SpritePalette(1 To ColorsInPalette) As _Unsigned Long + For i = 1 To ColorsInPalette + Read SpritePalette(i) + Next i + + Restore Fish1: LoadSprite FishSprites(1), 30, 15, SpritePalette() + Restore Fish2: LoadSprite FishSprites(2), 30, 15, SpritePalette() +End Sub + +'------------------------------------------------------------------------------ +Sub LoadSprite (ImageHandle As Long, ImageWidth As Integer, ImageHeight As Integer, SpritePalette() As Long) + 'Loads a sprite from DATA fields. You must use RESTORE appropriately before calling this SUB. + Dim i As Integer + Dim DataLine As String + Dim Pixel As Integer + Dim PrevDest As Long + + PrevDest = _Dest + _Dest ImageHandle + + For i = 0 To ImageHeight - 1 + Read DataLine + For Pixel = 0 To ImageWidth - 1 + PSet (Pixel, i), SpritePalette(Val(Mid$(DataLine, Pixel + 1, 1))) + Next Pixel + Next i + + _Dest PrevDest +End Sub + +'------------------------------------------------------------------------------ +Sub SetTimers + TempTimer = _FreeTimer + On Timer(TempTimer, 1) DecreaseTemperature + + FramesTimer = _FreeTimer + On Timer(FramesTimer, .1) UpdateFrames + Timer(FramesTimer) On +End Sub + +'------------------------------------------------------------------------------ +Sub CalculateScores + '- Displays the end of game animation ("unbuilds" the igloo + 'and sums total points) AND + '- Checks for 1-up goals (every 5,000 points). + + If LevelComplete Then + 'Calculate points for each igloo block + If IglooPieces > 0 Then + If IglooBlockCountSound Then _SndPlayCopy IglooBlockCountSound + Score = Score + (PointsInThisLevel * 10) + IglooPieces = IglooPieces - 1 + End If + + 'Calculate points for each degree remaining + If IglooPieces = 0 And Temperature > 0 Then + If ScoreCountSound Then _SndPlayCopy ScoreCountSound + Score = Score + (10 * PointsInThisLevel) + Temperature = Temperature - 1 + End If + + If IglooPieces = 0 And Temperature = 0 Then SetLevel NEXTLEVEL + End If + + If Score > NextGoal Then + NextGoal = NextGoal + ONEUPGOAL + If Lives < 9 Then Lives = Lives + 1 + End If +End Sub + +Sub InvertCurrentIceRow + If IceRow(Hero.CurrentRow).Direction = MOVINGRIGHT Then + IceRow(Hero.CurrentRow).Direction = MOVINGLEFT + If IceRow(Hero.CurrentRow).MirroredPosition Then Swap IceRow(Hero.CurrentRow).Position, IceRow(Hero.CurrentRow).MirroredPosition + Else + IceRow(Hero.CurrentRow).Direction = MOVINGRIGHT + If IceRow(Hero.CurrentRow).MirroredPosition Then Swap IceRow(Hero.CurrentRow).Position, IceRow(Hero.CurrentRow).MirroredPosition + End If +End Sub + +Sub DrawScenery + Dim PrevDest As Long + + PrevDest = _Dest + _Dest GameBG + Line (0, 0)-Step(_Width, GroundH), SceneryPalette(TimeOfDay, GROUND), BF ' Ground/ice + Line (0, 0)-Step(_Width, SkyH), SceneryPalette(TimeOfDay, SKY), BF ' Sky + Line (0, GroundH - 2)-Step(_Width, 3), _RGB32(0, 0, 0), BF ' Black separator + Line (0, GroundH + 2)-Step(_Width, WaterH), _RGB32(0, 27, 141), BF ' Water + Line (0, _Height - CreditsBarH)-Step(_Width, CreditsBarH), _RGB32(0, 0, 0), BF ' Credits bar + + _Dest PrevDest +End Sub + +Sub RestoreFile (A$, FileName$) + For i& = 1 To Len(A$) Step 4: B$ = Mid$(A$, i&, 4) + If InStr(1, B$, "%") Then + For C% = 1 To Len(B$): F$ = Mid$(B$, C%, 1) + If F$ <> "%" Then C$ = C$ + F$ + Next: B$ = C$ + End If: For t% = Len(B$) To 1 Step -1 + B& = B& * 64 + Asc(Mid$(B$, t%)) - 48 + Next: X$ = "": For t% = 1 To Len(B$) - 1 + X$ = X$ + Chr$(B& And 255): B& = B& \ 256 + Next: btemp$ = btemp$ + X$: Next + BASFILE$ = btemp$ + + f% = FreeFile + Open FileName$ For Output As #f% + Print #f%, BASFILE$; + Close #f% +End Sub + +Function IIF (Condition, IfTrue, IfFalse) + If Condition Then IIF = IfTrue Else IIF = IfFalse +End Function + diff --git a/samples/frostbite/src/frostbite.zip b/samples/frostbite/src/frostbite.zip new file mode 100644 index 0000000..4b5a109 Binary files /dev/null and b/samples/frostbite/src/frostbite.zip differ diff --git a/samples/future-blocks/img/screenshot.png b/samples/future-blocks/img/screenshot.png new file mode 100644 index 0000000..76bf337 Binary files /dev/null and b/samples/future-blocks/img/screenshot.png differ diff --git a/samples/future-blocks/index.md b/samples/future-blocks/index.md new file mode 100644 index 0000000..4445587 --- /dev/null +++ b/samples/future-blocks/index.md @@ -0,0 +1,32 @@ +[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: FUTURE BLOCKS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Michael Fogleman](../michael-fogleman.md) + +### Description + +```text +Tetris clone by Michael Fogleman. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "tetris-futureblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/future-blocks/src/tetris-futureblocks.bas) +* [RUN "tetris-futureblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/future-blocks/src/tetris-futureblocks.bas) +* [PLAY "tetris-futureblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/future-blocks/src/tetris-futureblocks.bas) + +### File(s) + +* [tetris-futureblocks.bas](src/tetris-futureblocks.bas) + +🔗 [game](../game.md), [tetris](../tetris.md) + + +Reference: [github.com](https://github.com/fogleman/FutureBlocks) diff --git a/samples/future-blocks/src/tetris-futureblocks.bas b/samples/future-blocks/src/tetris-futureblocks.bas new file mode 100644 index 0000000..6d55b6b --- /dev/null +++ b/samples/future-blocks/src/tetris-futureblocks.bas @@ -0,0 +1,2014 @@ +'----------------------------------------------------------------------------------------------------- +'Future Blocks - By Michael Fogleman +'https://github.com/fogleman/FutureBlocks +'Start Date : April 20, 2000 +'Finish Date: April 24, 2000 +'----------------------------------------------------------------------------------------------------- + +'----------------------------------------------------------------------------------------------------- +' 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 +' 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 "Future Blocks" +'----------------------------------------------------------------------------------------------------- + +'Start: +Common Shared FieldWidth%, FieldHeight%, BlockSize%, XOffset%, YOffset%, Occupied%() +Common Shared PieceData%(), CurrentColor%(), Text%(), PieceList%(), competen% +Common Shared CurrentPiece%, PieceX%, PieceY%, PieceR%, PieceC%, Grid%, CMN% +Common Shared OldPiece%, OldX%, OldY%, OldR%, GameOver%, Overlap%, Debug% +Common Shared NumComplete%, hint%, CPlay%, DestX%, DestY%, DestR%, usery%, pal%() +Common Shared LineWeight As Single, GapWeight As Single, HeightWeight As Single, ink$, NextC%, SideWeight As Single +Common Shared DispWidth%, DispHeight%, DispX%, DispY%, XShift%, messyheight% +Common Shared Lines%, Score&, GameTime As Long, StartTime As Double, PieceTime As Double, AirTime As Double, Compete% +Common Shared gap%, shadow%, Lines2%, Score2&, GameTime2 As Long, NextPiece%, Pieces&, Pieces2& +Common Shared YourLines%, YourScore&, lastmove% + +Dim PieceData%(17, 3, 6) +Dim Text%(39, 34) +Dim PieceList%(999) +Dim pal%(50) +ReadData +ReadText + +Cls +Screen 12 +AllowFullScreen SquarePixels , Smooth + +GetPal +TitleScreen +Grid% = 0 +Debug% = 0 +LineWeight = 3 +GapWeight = 4 +HeightWeight = 1 +SideWeight = 1 +FieldWidth% = 12 +FieldHeight% = 24 +BlockSize% = 16 +competen% = 50 + +DoneComp: +Do + Compete% = 0 + Menu + GameOver% = 0 + Cls + Randomize Timer + NextPiece% = Rnd * 6 + 1 + NextC% = Rnd * 6 + 1 + GameTime2 = -1 + Lines2% = -1 + Pieces2& = -1 + Score2& = -1 + Pieces& = 0 + Lines% = 0 + Score& = 0 + DispHeight% = 440 + DispWidth% = 147 + DispY% = (480 - DispHeight%) / 2 + DispX% = 640 - DispY% - DispWidth% + XShift% = 320 - (DispX% / 2) + XOffset% = ((BlockSize% + 2) * FieldWidth%) / 2 + YOffset% = ((BlockSize% + 2) * FieldHeight%) / 2 + If Compete% = 1 Then GoTo CompetitionMode + gap% = 6: shadow% = 2 + DrawField + Dim CurrentColor%(FieldWidth%, FieldHeight%) + Dim Occupied%(FieldWidth%, FieldHeight%) + If messyheight% > 0 Then PreOccupy messyheight% + NewPiece + StartTime = Timer + MainLoop + GameOverScreen + Erase Occupied%, CurrentColor% +Loop + +CompetitionMode: +Dim As Integer n +hint% = 0 +CMN% = 0 +n% = 0 +Do + PieceList%(n%) = Rnd * 6 + 1 + n% = n% + 1 +Loop While n% < 1000 +CPlay% = 0 +gap% = 6: shadow% = 2 +DrawField +Dim CurrentColor%(FieldWidth%, FieldHeight%) +Dim Occupied%(FieldWidth%, FieldHeight%) +If messyheight% > 0 Then PreOccupy messyheight% +NewPiece +StartTime = Timer +MainLoop +GameOverScreen +YourLines% = Lines% +YourScore& = Score& +Erase Occupied%, CurrentColor% + +CMN% = 0 +GameOver% = 0 +Cls +Randomize Timer +GameTime2 = -1 +Lines2% = -1 +Pieces2& = -1 +Score2& = -1 +Pieces& = 0 +Lines% = 0 +Score& = 0 +gap% = 6: shadow% = 2 +CPlay% = 1 +DrawField +Dim CurrentColor%(FieldWidth%, FieldHeight%) +Dim Occupied%(FieldWidth%, FieldHeight%) +If messyheight% > 0 Then PreOccupy messyheight% +NewPiece +StartTime = Timer +MainLoop +GameOverScreen +Erase Occupied%, CurrentColor% +CompeteScreen +GoTo DoneComp + +Piece1: +Data 2,3 +Data 1,0 +Data 1,1 +Data 0,1 +Data 3,2 +Data 0,1,1 +Data 1,1,0 +Data 2,3 +Data 1,0 +Data 1,1 +Data 0,1 +Data 3,2 +Data 0,1,1 +Data 1,1,0 +Piece2: +Data 2,3 +Data 0,1 +Data 1,1 +Data 1,0 +Data 3,2 +Data 1,1,0 +Data 0,1,1 +Data 2,3 +Data 0,1 +Data 1,1 +Data 1,0 +Data 3,2 +Data 1,1,0 +Data 0,1,1 +Piece3: +Data 2,2 +Data 1,1 +Data 1,1 +Data 2,2 +Data 1,1 +Data 1,1 +Data 2,2 +Data 1,1 +Data 1,1 +Data 2,2 +Data 1,1 +Data 1,1 +Piece4: +Data 1,4 +Data 1 +Data 1 +Data 1 +Data 1 +Data 4,1 +Data 1,1,1,1 +Data 1,4 +Data 1 +Data 1 +Data 1 +Data 1 +Data 4,1 +Data 1,1,1,1 +Piece5: +Data 2,3 +Data 1,0 +Data 1,0 +Data 1,1 +Data 3,2 +Data 1,1,1 +Data 1,0,0 +Data 2,3 +Data 1,1 +Data 0,1 +Data 0,1 +Data 3,2 +Data 0,0,1 +Data 1,1,1 +Piece6: +Data 2,3 +Data 0,1 +Data 0,1 +Data 1,1 +Data 3,2 +Data 1,0,0 +Data 1,1,1 +Data 2,3 +Data 1,1 +Data 1,0 +Data 1,0 +Data 3,2 +Data 1,1,1 +Data 0,0,1 +Piece7: +Data 3,2 +Data 0,1,0 +Data 1,1,1 +Data 2,3 +Data 1,0 +Data 1,1 +Data 1,0 +Data 3,2 +Data 1,1,1 +Data 0,1,0 +Data 2,3 +Data 0,1 +Data 1,1 +Data 0,1 + +Text: +Data 0,0,1,0,0 +Data 0,1,0,1,0 +Data 1,0,0,0,1 +Data 1,1,1,1,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 + +Data 1,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,1,1,1,0 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 1,1,1,0,0 +Data 1,0,0,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,1,0 +Data 1,1,1,0,0 + +Data 1,1,1,1,1 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,1,1,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,1,1,1,1 + +Data 1,1,1,1,1 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,1,1,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,1,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,1,1,1,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 + +Data 1,1,1,1,1 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 1,1,1,1,1 + +Data 1,1,1,1,1 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 1,1,0,0,0 + +Data 1,0,0,0,1 +Data 1,0,0,1,0 +Data 1,0,1,0,0 +Data 1,1,0,0,0 +Data 1,0,1,0,0 +Data 1,0,0,1,0 +Data 1,0,0,0,1 + +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,1,1,1,1 + +Data 1,0,0,0,1 +Data 1,1,0,1,1 +Data 1,0,1,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 + +Data 1,0,0,0,1 +Data 1,1,0,0,1 +Data 1,1,0,0,1 +Data 1,0,1,0,1 +Data 1,0,1,0,1 +Data 1,0,0,1,1 +Data 1,0,0,0,1 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 1,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,1,1,1,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 +Data 1,0,0,0,0 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,1,0,1 +Data 1,0,0,1,1 +Data 0,1,1,1,0 + +Data 1,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,1,1,1,0 +Data 1,0,1,0,0 +Data 1,0,0,1,0 +Data 1,0,0,0,1 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,0 +Data 0,1,1,1,0 +Data 0,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 1,1,1,1,1 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 + +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,0,1,0 +Data 0,0,1,0,0 + +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,1,0,1 +Data 1,1,0,1,1 +Data 1,0,0,0,1 + +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,0,1,0 +Data 0,0,1,0,0 +Data 0,1,0,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 + +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,0,1,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 + +Data 1,1,1,1,1 +Data 0,0,0,0,1 +Data 0,0,0,1,0 +Data 0,0,1,0,0 +Data 0,1,0,0,0 +Data 1,0,0,0,0 +Data 1,1,1,1,1 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,1,0,0,1 +Data 1,0,1,0,1 +Data 1,0,0,1,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 0,0,1,0,0 +Data 0,1,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,1,1,1,0 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 0,0,0,0,1 +Data 0,0,0,1,0 +Data 0,0,1,0,0 +Data 0,1,0,0,0 +Data 1,1,1,1,1 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 0,0,0,0,1 +Data 0,0,1,1,0 +Data 0,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 0,0,0,0,1 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 1,1,1,1,1 +Data 0,0,0,0,1 +Data 0,0,0,0,1 +Data 0,0,0,0,1 + +Data 1,1,1,1,1 +Data 1,0,0,0,0 +Data 1,1,1,1,0 +Data 0,0,0,0,1 +Data 0,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,0 +Data 1,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 1,1,1,1,1 +Data 0,0,0,0,1 +Data 0,0,0,0,1 +Data 0,0,0,1,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 0,1,1,1,0 +Data 1,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,1 +Data 0,0,0,0,1 +Data 1,0,0,0,1 +Data 0,1,1,1,0 + +Data 1,0,0,0,0 +Data 0,1,0,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,1,0,0,0 +Data 1,0,0,0,0 + +Data 0,0,0,0,0 +Data 0,0,0,0,0 +Data 0,0,0,0,0 +Data 0,0,0,0,0 +Data 0,0,0,0,0 +Data 0,0,0,0,0 +Data 1,0,0,0,0 + +Data 0,0,0,0,0 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 1,1,1,1,1 +Data 0,0,1,0,0 +Data 0,0,1,0,0 +Data 0,0,0,0,0 + +Data 0,0,0,0,0 +Data 0,0,0,0,0 +Data 0,0,0,0,0 +Data 1,1,1,1,1 +Data 0,0,0,0,0 +Data 0,0,0,0,0 +Data 0,0,0,0,0 + +Sub BlueColors + Dim As Integer r, g, b, n + + r% = pal%(3) + g% = pal%(4) + b% = pal%(5) + n% = 0 + Do + Colors n%, r%, g%, b% + n% = n% + 1 + Loop While n% < 16 +End Sub + +Sub CheckComplete + Dim As Integer c(FieldHeight%), x, y, f, o, n, xn, yn + + x% = 1: y% = 1: f% = 0 + Do + o% = Occupied%(x%, y%) + If x% = FieldWidth% And o% > 0 Then + If Debug% = 1 Then Locate f% + 18, 1: Print "LINE"; y%; "COMPLETE" + Lines% = Lines% + 1 + c%(f%) = y%: f% = f% + 1: x% = 0: y% = y% + 1 + End If + x% = x% + 1 + If o% = 0 Then x% = 1: y% = y% + 1 + Loop While y% <= FieldHeight% + If f% = 0 Then Exit Sub + + If AirTime > 4 Then AirTime = 4 + Score& = Score& + f% * 100 * (5 - AirTime) + n% = 0 + Do + GoSub Shift + n% = n% + 1 + Loop While n% < f% + Exit Sub + Shift: + y% = c%(n%) + xn% = 1: yn% = y% + Do While yn% > 1 + Occupied%(xn%, yn%) = Occupied%(xn%, yn% - 1) + xn% = xn% + 1 + If xn% > FieldWidth% Then xn% = 1: yn% = yn% - 1 + Loop + RefreshField + Return + +End Sub + +Sub CheckFinalMove + ink$ = InKey$ + If ink$ = Chr$(0) + "K" Then + MoveLeft + lastmove% = 1 + End If + If ink$ = Chr$(0) + "M" Then + MoveRight + lastmove% = 1 + End If + If ink$ = Chr$(0) + "H" Then + RotatePiece + lastmove% = 1 + End If + Exit Sub +End Sub + +Sub CheckOverlap + Dim As Integer xn(3), yn(3), s, xn, yn, xs, ys, maxn, n, c + + s% = 0 + xn% = PieceX%: yn% = PieceY% + xs% = PieceData%(0, PieceR%, CurrentPiece% - 1) + ys% = PieceData%(1, PieceR%, CurrentPiece% - 1) + maxn% = xs% * ys% + n% = 0 + Do + c% = PieceData%(n% + 2, PieceR%, CurrentPiece% - 1) + If c% = 0 Then + Else + xn%(s%) = xn%: yn%(s%) = yn% + s% = s% + 1 + End If + xn% = xn% + 1 + If xn% - PieceX% >= xs% Then xn% = PieceX%: yn% = yn% + 1 + n% = n% + 1 + Loop While n% < maxn% + + 'Make Sure Piece Is In Bounds. + 'If not, return -1. + n% = 0 + Overlap% = 0 + Do + If xn%(n%) > FieldWidth% Then Overlap% = -1: Exit Sub + If yn%(n%) > FieldHeight% Then Overlap% = -1: Exit Sub + If xn%(n%) < 1 Then Overlap% = -1: Exit Sub + If yn%(n%) < 1 Then Overlap% = -1: Exit Sub + n% = n% + 1 + Loop While n% < 4 + + 'Check If This Location Would Overlap Another Piece. + n% = 0 + Overlap% = 0 + Do + If Occupied%(xn%(n%), yn%(n%)) = 0 Then + Else + Overlap% = Overlap% + 1 + End If + n% = n% + 1 + Loop While n% < 4 +End Sub + +'This sub checks if the piece has landed on anything. +Sub CheckTouch + Dim As Integer xSize, ySize, MaxY, xn, yn, maxn, n, c, e, lmtime + + 'First, Check if piece has hit the bottom of the field. + xSize% = PieceData%(0, PieceR%, CurrentPiece% - 1) + ySize% = PieceData%(1, PieceR%, CurrentPiece% - 1) + MaxY% = PieceY% + ySize% + If MaxY% = FieldHeight% + 1 Then GoTo StopPiece + + 'See if it has hit another piece. + 'Find Base Points + Dim BaseX%(3), BaseY%(3) '4 is highest poss. number of base points. + BaseX%(0) = PieceX% + If xSize% > 1 Then BaseX%(1) = PieceX% + 1 + If xSize% > 2 Then BaseX%(2) = PieceX% + 2 + If xSize% > 3 Then BaseX%(3) = PieceX% + 3 + + xn% = PieceX%: yn% = PieceY% + maxn% = xSize% * ySize% + n% = 0 + Do + c% = PieceData%(n% + 2, PieceR%, CurrentPiece% - 1) + If c% = 0 Then + Else + e% = xn% - PieceX% + BaseY%(e%) = yn% + End If + xn% = xn% + 1 + If xn% - PieceX% >= xSize% Then xn% = PieceX%: yn% = yn% + 1 + n% = n% + 1 + Loop While n% < maxn% + + n% = 0 + Do + If BaseX%(n%) = 0 Then + Else + If BaseY%(n%) > 0 Then + If Occupied%(BaseX%(n%), BaseY%(n%) + 1) > 0 Then + If BaseY%(n%) < 2 Then GameOver% = 1: Exit Sub + GoTo StopPiece + End If + End If + End If + n% = n% + 1 + Loop While n% < 4 + + Exit Sub + StopPiece: + If CPlay% = 0 Then + lmtime = Timer + Do + lastmove% = 0 + CheckFinalMove + Loop While Timer - lmtime < .5 And lastmove% = 0 + End If + AirTime = Timer - PieceTime + If AirTime > 7 Then AirTime = 7 + Score& = Score& + (8 - AirTime) * 5 + StoreOccupy + RefreshField + CheckComplete + NewPiece +End Sub + +Sub Colors (c As Integer, r As Integer, g As Integer, b As Integer) + Out &H3C8, c% + Out &H3C9, r% + Out &H3C9, g% + Out &H3C9, b% +End Sub + +Sub CompComplete + Dim As Integer x, y, f, o + + x% = 1: y% = 1: f% = 0 + Do + o% = Occupied%(x%, y%) + If x% = FieldWidth% And o% > 0 Then + f% = f% + 1: x% = 0: y% = y% + 1 + End If + x% = x% + 1 + If o% = 0 Then x% = 1: y% = y% + 1 + Loop While y% <= FieldHeight% + NumComplete% = f% +End Sub + +Sub CompeteScreen + Dim As Integer size, x, y, sx, c + Dim sc As String + + BlueColors + Line (0, 0)-(640, 480), 1, BF + gap% = 4: shadow% = 2 + DrawText 85, 25, "Competition Mode", 7, 4, 2 + size% = 6 + x% = 40: y% = 80 + sx% = x%: c% = 7 + Do + Line (x% + 1 + shadow%, y% + 1 + shadow%)-(x% + size% + 1 + shadow%, y% + size% + 1 + shadow%), 0, BF + Line (x% + 1, y% + 1)-(x% + size% - 1, y% + size% - 1), c%, BF + Line (x%, y%)-(x% + size%, y%), 15 + Line (x%, y%)-(x%, y% + size%), 15 + Line (x% + size%, y%)-(x% + size%, y% + size%), 8 + Line (x%, y% + size%)-(x% + size%, y% + size%), 8 + x% = x% + size% + 1 + Loop While x% < 600 + gap% = 2: shadow% = 1 + DrawText 15, 460, "Future Software", 7, 1, 2 + DrawText 395, 460, "By Michael Fogleman", 7, 1, 2 + gap% = 4: shadow% = 1 + DrawText 80, 400, "PRESS ANY KEY TO CONTINUE", 7, 2, 2 + gap% = 4: shadow% = 2 + DrawText 80, 110, "YOU", 7, 4, 2 + DrawText 510, 110, "ME", 7, 4, 2 + DrawText 245, 150, "SCORE", 7, 4, 2 + DrawText 245, 270, "LINES", 7, 4, 2 + + DrawText 5, 200, Str$(YourScore&), 7, 4, 2 + DrawText 5, 320, Str$(YourLines%), 7, 4, 2 + + sc$ = Str$(Score&) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText 280, 200, sc$, 7, 4, 2 + + sc$ = Str$(Lines%) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText 280, 320, sc$, 7, 4, 2 + RestoreColors + + Do + ink$ = InKey$ + Loop While ink$ = "" + +End Sub + +'This is the brain! Computer plays tetris. +Sub ComputerPlay (nDisplay As Integer) + Dim sTime As Double + Dim As Integer xSize, ySize, PrevX, PrevY, PrevR, gaps, maxeval, mineval + Dim As Integer n, xn, r, n1, n2, yn, maxn, bn, c, e, en + + 'First, find all possible placement positions. + sTime = Timer + xSize% = PieceData%(0, PieceR%, CurrentPiece% - 1) + ySize% = PieceData%(1, PieceR%, CurrentPiece% - 1) + PrevX% = PieceX% + PrevY% = PieceY% + PrevR% = PieceR% + 'Dim picks%(100) + Dim BaseX%(3), BaseY%(3) + Dim PossibleX%(100) + Dim PossibleY%(100) + Dim PossibleR%(100) + Dim Evaluation%(100) + GoSub NegEval + 'X and R are the controlled variables, find Y for each combination. + n% = 0 + xn% = 1 + Do + r% = 0 + Do + GoSub GetY + PossibleX%(n%) = xn% + PossibleY%(n%) = PieceY% + PossibleR%(n%) = r% + n% = n% + 1 + r% = r% + 1 + Loop While r% < 4 + xn% = xn% + 1 + Loop While xn% < FieldWidth% + 2 + + 'Now, evaluate each position. This is the tough part. + 'Copy the occupied array, so we can see if any moves complete a line. + Dim TempOccupied%(FieldWidth%, FieldHeight%) + n1% = 0: n2% = 0 + Do + TempOccupied%(n1%, n2%) = Occupied%(n1%, n2%) + n1% = n1% + 1 + If n1% > FieldWidth% Then n1% = 0: n2% = n2% + 1 + Loop While n2% <= FieldHeight% + + 'Put each possible position/rotation in. Check for complete line. + n% = 0 + Do + PieceX% = PossibleX%(n%) + PieceY% = PossibleY%(n%) + PieceR% = PossibleR%(n%) + If PieceY% > 0 Then + 'LOCATE 1, 40: PRINT PieceX%; PieceY%; PieceR%; n% + Evaluation%(n%) = PieceY% * HeightWeight + StoreOccupy + CompComplete + Evaluation%(n%) = Evaluation%(n%) + NumComplete% * LineWeight + GoSub RestoreArray + End If + n% = n% + 1 + Loop While n% < 101 + + 'Check if next to any pieces. + n% = 0 + Do + PieceX% = PossibleX%(n%) + PieceY% = PossibleY%(n%) + PieceR% = PossibleR%(n%) + xSize% = PieceData%(0, PieceR%, CurrentPiece% - 1) + ySize% = PieceData%(1, PieceR%, CurrentPiece% - 1) + Do + If PieceX% - 1 > 0 And PieceX% - 1 <= FieldWidth% And PieceY% > 0 And PieceY% <= FieldHeight% Then + 'DrawBlock PieceX% - 1, PieceY%, -1 + If Occupied%(PieceX% - 1, PieceY%) > 0 Then + Evaluation%(n%) = Evaluation%(n%) + SideWeight + End If + End If + If PieceX% + xSize% > 0 And PieceX% + xSize% <= FieldWidth% And PieceY% > 0 And PieceY% <= FieldHeight% Then + 'DrawBlock PieceX% - 1, PieceY%, -1 + If Occupied%(PieceX% + xSize%, PieceY%) > 0 Then + Evaluation%(n%) = Evaluation%(n%) + SideWeight + End If + End If + PieceY% = PieceY% + 1 + Loop While PieceY% - PossibleY%(n%) < ySize% + n% = n% + 1 + Loop While n% < 101 + + + 'Check For Gaps Under Piece. + 'This is similar to CheckTouch Sub. + n% = 0 + Do + PieceX% = PossibleX%(n%) + PieceY% = PossibleY%(n%) + PieceR% = PossibleR%(n%) + If PieceY% > 0 Then + xSize% = PieceData%(0, PieceR%, CurrentPiece% - 1) + ySize% = PieceData%(1, PieceR%, CurrentPiece% - 1) + BaseX%(0) = 0: BaseX%(1) = 0: BaseX%(2) = 0: BaseX%(3) = 0 + BaseY%(0) = 0: BaseY%(1) = 0: BaseY%(2) = 0: BaseY%(3) = 0 + BaseX%(0) = PieceX% + If xSize% > 1 Then BaseX%(1) = PieceX% + 1 + If xSize% > 2 Then BaseX%(2) = PieceX% + 2 + If xSize% > 3 Then BaseX%(3) = PieceX% + 3 + xn% = PieceX%: yn% = PieceY% + maxn% = xSize% * ySize% + bn% = 0 + Do + c% = PieceData%(bn% + 2, PieceR%, CurrentPiece% - 1) + If c% = 0 Then + Else + e% = xn% - PieceX% + BaseY%(e%) = yn% + End If + xn% = xn% + 1 + If xn% - PieceX% >= xSize% Then xn% = PieceX%: yn% = yn% + 1 + bn% = bn% + 1 + Loop While bn% < maxn% + + gaps% = 0 + bn% = 0 + Do + If BaseX%(bn%) = 0 Then + Else + If BaseY%(bn%) > 0 And BaseY%(bn%) < FieldHeight% Then + If Occupied%(BaseX%(bn%), BaseY%(bn%) + 1) = 0 Then + gaps% = gaps% + 1 + End If + End If + End If + bn% = bn% + 1 + Loop While bn% < 4 + Evaluation%(n%) = Evaluation%(n%) - gaps% * GapWeight + End If + n% = n% + 1 + Loop While n% < 101 + + 'Find Max/Min Evaluation. + n% = 0 + maxeval% = -1000 + mineval% = 1000 + Do + If Evaluation%(n%) < mineval% Then mineval% = Evaluation%(n%) + If Evaluation%(n%) > maxeval% Then + maxeval% = Evaluation%(n%) + End If + n% = n% + 1 + Loop While n% < 101 + + Do + n% = Rnd * 100 + Loop While Evaluation%(n%) < maxeval% Or PossibleX%(n%) = 0 Or PossibleY%(n%) = 0 + PieceX% = PossibleX%(n%) + PieceY% = PossibleY%(n%) + PieceR% = PossibleR%(n%) + If nDisplay% = 1 Then + DrawPiece PieceX%, PieceY%, CurrentPiece%, PieceR%, -1 + End If + 'LOCATE 13, 73: PRINT USING "#####"; Evaluation%(n%) + + 'Rid of unnecessary rotation. + If CurrentPiece% = 1 Or CurrentPiece% = 2 Or CurrentPiece% = 4 Then + If PieceR% = 3 Then PieceR% = 1 + If PieceR% = 2 Then PieceR% = 0 + End If + If CurrentPiece% = 3 Then PieceR% = 0 + + 'n% = 0 + 'DO + PieceX% = PossibleX%(n%) + PieceY% = PossibleY%(n%) + PieceR% = PossibleR%(n%) + xSize% = PieceData%(0, PieceR%, CurrentPiece% - 1) + ySize% = PieceData%(1, PieceR%, CurrentPiece% - 1) + Do + If PieceX% - 1 > 0 And PieceX% - 1 <= FieldWidth% And PieceY% > 0 And PieceY% <= FieldHeight% Then + 'DrawBlock PieceX% - 1, PieceY%, -1 + If Occupied%(PieceX% - 1, PieceY%) > 0 Then + Evaluation%(n%) = Evaluation%(n%) + SideWeight + End If + End If + If PieceX% + xSize% > 0 And PieceX% + xSize% <= FieldWidth% And PieceY% > 0 And PieceY% <= FieldHeight% Then + 'DrawBlock PieceX% + XSize%, PieceY%, -1 + If Occupied%(PieceX% + xSize%, PieceY%) > 0 Then + Evaluation%(n%) = Evaluation%(n%) + SideWeight + End If + End If + PieceY% = PieceY% + 1 + Loop While PieceY% - PossibleY%(n%) < ySize% + 'n% = n% + 1 + 'LOOP WHILE n% < 101 + + + DestX% = PieceX% + DestY% = PieceY% + DestR% = PieceR% + + PieceX% = PrevX% + PieceY% = PrevY% + PieceR% = PrevR% + Exit Sub + + GetY: + yn% = 1 + PieceX% = xn% + PieceY% = yn% + PieceR% = r% + CheckOverlap + If Overlap% = 0 Then + Else + PieceY% = 0 + Return + End If + Do + PieceY% = PieceY% + 1 + CheckOverlap + Loop While Overlap% = 0 + PieceY% = PieceY% - 1 + Return + RestoreArray: + n1% = 0: n2% = 0 + Do + Occupied%(n1%, n2%) = TempOccupied%(n1%, n2%) + n1% = n1% + 1 + If n1% > FieldWidth% Then n1% = 0: n2% = n2% + 1 + Loop While n2% <= FieldHeight% + Return + NegEval: + en% = 0 + Do + Evaluation%(en%) = -100 + en% = en% + 1 + Loop While en% < 101 + Return +End Sub + +Sub DebugDisplay + Locate 1, 1 + Print "Debugging" + Print " Information" + Print + Print "X :"; PieceX% + Print "Y :"; PieceY% + Print "Piece :"; CurrentPiece% + Print "Rotation:"; PieceR% + Print + Print "Field Width :"; FieldWidth% + Print "Field Height:"; FieldHeight% + Print + Print "Field Coordinates:" + Print " X1:"; 320 - XOffset% + Print " Y1:"; 240 - YOffset% + Print " X2:"; 320 + XOffset% + Print " Y2:"; 240 + YOffset% +End Sub + +Sub DrawBlock (xn As Integer, yn As Integer, c As Integer) + Dim As Integer x, y + + If xn% < 1 Or yn% < 1 Then Exit Sub + If CurrentColor%(xn%, yn%) = c% Then Exit Sub + CurrentColor%(xn%, yn%) = c% + If xn% > FieldWidth% Or yn% > FieldHeight% Then Exit Sub + x% = 320 - XOffset% + 1 + (xn% - 1) * (BlockSize% + 2) - XShift% + y% = 240 - YOffset% + 1 + (yn% - 1) * (BlockSize% + 2) + 'IF c% > -1 THEN LINE (x%, y%)-(x% + BlockSize%, y% + BlockSize%), c%, BF + If c% = 0 Then Line (x%, y%)-(x% + BlockSize%, y% + BlockSize%), c%, BF + If c% > 0 Then + Line (x% + 1, y% + 1)-(x% + BlockSize% - 1, y% + BlockSize% - 1), c%, BF + Line (x%, y%)-(x% + BlockSize%, y%), 15 + Line (x%, y%)-(x%, y% + BlockSize%), 15 + Line (x% + BlockSize%, y%)-(x% + BlockSize%, y% + BlockSize%), 8 + Line (x%, y% + BlockSize%)-(x% + BlockSize%, y% + BlockSize%), 8 + End If + If c% = -1 Then Line (x%, y%)-(x% + BlockSize%, y% + BlockSize%), 15, B +End Sub + +Sub DrawBlock2 (x As Integer, y As Integer, c As Integer) + If c% = 0 Then Line (x%, y%)-(x% + 16, y% + 16), c%, BF + If c% > 0 Then + Line (x% + 1, y% + 1)-(x% + 16 - 1, y% + 16 - 1), c%, BF + Line (x%, y%)-(x% + 16, y%), 15 + Line (x%, y%)-(x%, y% + 16), 15 + Line (x% + 16, y%)-(x% + 16, y% + 16), 8 + Line (x%, y% + 16)-(x% + 16, y% + 16), 8 + End If + If c% = -1 Then Line (x%, y%)-(x% + 16, y% + 16), 15, B +End Sub + +Sub DrawField + Dim As Integer size, x, y, sx, c, x1, y1, x2, y2 + + BlueColors + size% = 67 + x% = -1 * size% / 2: y% = -1 * size% / 2 + sx% = x% + c% = Rnd * 4 + If c% = 4 Then c% = 7 + Do + Line (x% + 1, y% + 1)-(x% + size% - 1, y% + size% - 1), c%, BF + Line (x%, y%)-(x% + size%, y%), 15 + Line (x%, y%)-(x%, y% + size%), 15 + Line (x% + size%, y%)-(x% + size%, y% + size%), 8 + Line (x%, y% + size%)-(x% + size%, y% + size%), 8 + x% = x% + size% + 2 + If x% > 640 Then x% = sx%: y% = y% + size% + 2 + Loop While y% < 480 + + Line (320 - XOffset% - XShift% - 4, 240 - YOffset% - 4)-(320 + XOffset% - XShift% + 4, 240 + YOffset% + 4), 0, BF + Line (320 - XOffset% - XShift% - 4, 240 - YOffset% - 4)-(320 + XOffset% - XShift% + 4, 240 + YOffset% + 4), 15, B + Line (320 - XOffset% - XShift% - 2, 240 - YOffset% - 2)-(320 + XOffset% - XShift% + 2, 240 + YOffset% + 2), 7, B + Line (DispX% - 4, DispY% - 4)-(DispX% + DispWidth% + 4, DispY% + DispHeight% + 4), 0, BF + Line (DispX% - 2, DispY% - 2)-(DispX% + DispWidth% + 2, DispY% + DispHeight% + 2), 7, B + Line (DispX% - 4, DispY% - 4)-(DispX% + DispWidth% + 4, DispY% + DispHeight% + 4), 15, B + 'LOCATE 3, 61: PRINT "Score:" + 'LOCATE 4, 69: PRINT USING "#########"; 0 + 'LOCATE 6, 61: PRINT "Lines Cleared:" + 'LOCATE 7, 73: PRINT USING "#####"; 0 + 'LOCATE 9, 61: PRINT "Game Time:" + 'LOCATE 10, 73: PRINT USING "#####"; 0 + 'LOCATE 12, 61: PRINT "Evaluation:" + + gap% = 2: shadow% = 1 + DrawText DispX% + 7, 25, "SCORE", 7, 1, 2 + DrawText DispX% + 7, 95, "LINES", 7, 1, 2 + DrawText DispX% + 7, 165, "TIME", 7, 1, 2 + DrawText DispX% + 7, 355, "NEXT PIECE", 7, 1, 2 + DrawText DispX% + 7, 237, "PIECES", 7, 1, 2 + + If Grid% = 1 Then + x1% = 320 - XOffset%: y1% = 240 - YOffset% + x2% = 320 + XOffset%: y2% = 240 + YOffset% + Do + Line (x1%, y1%)-(x1%, y2%), 8 + x1% = x1% + BlockSize% + 2 + Loop While x1% < x2% + + x1% = 320 - XOffset%: y1% = 240 - YOffset% + x2% = 320 + XOffset%: y2% = 240 + YOffset% + Do + Line (x1%, y1%)-(x2%, y1%), 8 + y1% = y1% + BlockSize% + 2 + Loop While y1% < y2% + End If + RestoreColors +End Sub + +Sub DrawLetter (x As Integer, y As Integer, letter As Integer, c As Integer, size As Integer, typ As Integer) + Dim As Integer sx, sy, xn, yn, n, d + + sx% = x%: sy% = y% + xn% = 0: yn% = 0 + n% = 0 + Do + d% = Text%(letter%, n%) + If d% = 1 Then + If typ% = 0 Then + Line (x% + 1, y% + 1)-(x% + size% - 1, y% + size% - 1), c%, BF + Line (x%, y%)-(x% + size%, y%), 15 + Line (x%, y%)-(x%, y% + size%), 15 + Line (x% + size%, y%)-(x% + size%, y% + size%), 8 + Line (x%, y% + size%)-(x% + size%, y% + size%), 8 + End If + If typ% = 1 Then + Line (x%, y%)-(x% + size%, y% + size%), c%, BF + End If + If typ% = 2 Then + Line (x% + 1 + shadow%, y% + 1 + shadow%)-(x% + size% + 1 + shadow%, y% + size% + 1 + shadow%), 0, BF + Line (x% + 1, y% + 1)-(x% + size% - 1, y% + size% - 1), c%, BF + Line (x%, y%)-(x% + size%, y%), 15 + Line (x%, y%)-(x%, y% + size%), 15 + Line (x% + size%, y%)-(x% + size%, y% + size%), 8 + Line (x%, y% + size%)-(x% + size%, y% + size%), 8 + End If + End If + n% = n% + 1 + xn% = xn% + 1 + x% = x% + size% + 1 + If xn% > 4 Then xn% = 0: x% = sx%: y% = y% + size% + 1 + Loop While n% < 35 +End Sub + +Sub DrawPiece (xn As Integer, yn As Integer, piece As Integer, r As Integer, col As Integer) + Dim As Integer x, y, Xs, Ys, n, c, dc + + x% = xn%: y% = yn% + Xs% = PieceData%(0, r%, piece% - 1) + Ys% = PieceData%(1, r%, piece% - 1) + n% = 0 + Do + c% = PieceData%(n% + 2, r%, piece% - 1) + dc% = 0 + If c% = 0 Then Else dc% = 1 + If dc% = 1 Then DrawBlock xn%, yn%, col% + xn% = xn% + 1 + If xn% - x% >= Xs% Then xn% = x%: yn% = yn% + 1 + n% = n% + 1 + Loop While yn% < y% + Ys% +End Sub + +Sub DrawPiece2 (px As Integer, py As Integer, piece As Integer, col As Integer) + Dim As Integer x, y, xn, yn, Xs, Ys, n, c, dc + + x% = px%: y% = py% + xn% = 0: yn% = 0 + Xs% = PieceData%(0, 1, piece% - 1) + Ys% = PieceData%(1, 1, piece% - 1) + n% = 0 + Do + c% = PieceData%(n% + 2, 1, piece% - 1) + dc% = 0 + If c% = 0 Then Else dc% = 1 + If dc% = 1 Then DrawBlock2 x%, y%, col% + x% = x% + 18 'BlockSize% + 2 + xn% = xn% + 1 + If xn% >= Xs% Then xn% = 0: x% = px%: y% = y% + 18: yn% = yn% + 1 + n% = n% + 1 + Loop While yn% < Ys% +End Sub + +Sub DrawText (x As Integer, y As Integer, txt As String, c As Integer, size As Integer, typ As Integer) + Dim As Integer sx, sy, n, t + Dim s As String + + txt$ = UCase$(txt$) + sx% = x%: sy% = y% + n% = 1 + Do + s = Mid$(txt$, n%, 1) + t% = Asc(s) + If t% = 32 Then GoTo Skip + If t% = 41 Then t% = 36 + If t% = 46 Then t% = 37 + If t% = 43 Then t% = 38 + If t% = 45 Then t% = 39 + If t% > 64 And t% < 91 Then + t% = t% - 65 + End If + If t% > 47 And t% < 58 Then + t% = t% - 22 + End If + DrawLetter x%, y%, t%, c%, size%, typ% + Skip: + y% = sy% + x% = x% + (size% + 1) * 5 + gap% + n% = n% + 1 + Loop While n% < Len(txt$) + 1 +End Sub + +Sub GameOverScreen + Dim As Integer gap, size, x, y, sx, c + Dim sc As String + + BlueColors + Line (0, 0)-(640, 480), 1, BF + gap% = 6: shadow% = 3 + DrawText 135, 20, "Game Over", 7, 6, 2 + size% = 6 + x% = 40: y% = 80 + sx% = x%: c% = 7 + Do + Line (x% + 1 + shadow%, y% + 1 + shadow%)-(x% + size% + 1 + shadow%, y% + size% + 1 + shadow%), 0, BF + Line (x% + 1, y% + 1)-(x% + size% - 1, y% + size% - 1), c%, BF + Line (x%, y%)-(x% + size%, y%), 15 + Line (x%, y%)-(x%, y% + size%), 15 + Line (x% + size%, y%)-(x% + size%, y% + size%), 8 + Line (x%, y% + size%)-(x% + size%, y% + size%), 8 + x% = x% + size% + 1 + Loop While x% < 600 + gap% = 2: shadow% = 1 + DrawText 15, 460, "Future Software", 7, 1, 2 + DrawText 395, 460, "By Michael Fogleman", 7, 1, 2 + gap% = 4: shadow% = 1 + DrawText 80, 400, "PRESS ANY KEY TO CONTINUE", 7, 2, 2 + + gap% = 4: shadow% = 2 + DrawText 65, 120, "Score", 7, 4, 2 + DrawText 65, 180, "Lines", 7, 4, 2 + DrawText 65, 240, "Time", 7, 4, 2 + DrawText 65, 300, "Pieces", 7, 4, 2 + + sc$ = Str$(Score&) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText 265, 120, sc$, 7, 4, 2 + + sc$ = Str$(Lines%) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText 265, 180, sc$, 7, 4, 2 + + sc$ = Str$(GameTime) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText 265, 240, sc$, 7, 4, 2 + + sc$ = Str$(Pieces&) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText 265, 300, sc$, 7, 4, 2 + RestoreColors + + Do + ink$ = InKey$ + Loop While ink$ = "" + +End Sub + +Sub GetPal + Dim As Integer n, c, rr, gg, bb + + n% = 0: c% = 0 + Do + Out &H3C6, &HFF + Out &H3C7, c% + rr% = Inp(&H3C9) + gg% = Inp(&H3C9) + bb% = Inp(&H3C9) + pal%(n%) = rr% + pal%(n% + 1) = gg% + pal%(n% + 2) = bb% + n% = n% + 3: c% = c% + 1 + Loop While c% < 16 +End Sub + +Sub InfoDisplay + Dim sc As String + + 'LOCATE 4, 69: PRINT USING "#########"; Score& + 'LOCATE 7, 73: PRINT USING "#####"; Lines% + 'LOCATE 10, 73: PRINT USING "#####"; GameTime& + gap% = 2: shadow% = 1 + + If Score& = Score2& Then + Else + Line (DispX% + 5, 44)-(DispX% + DispWidth% - 2, 62), 0, BF + sc$ = Str$(Score&) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText DispX% + 9, 45, sc$, 7, 1, 2 + Score2& = Score& + End If + + If Lines% = Lines2% Then + Else + Line (DispX% + 5, 114)-(DispX% + DispWidth% - 2, 132), 0, BF + sc$ = Str$(Lines%) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText DispX% + 9, 115, sc$, 7, 1, 2 + Lines2% = Lines% + End If + + If GameTime = GameTime2 Then + Else + Line (DispX% + 5, 184)-(DispX% + DispWidth% - 2, 202), 0, BF + sc$ = Str$(GameTime) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText DispX% + 9, 185, sc$, 7, 1, 2 + GameTime2 = GameTime + End If + + If Pieces& = Pieces2& Then + Else + Line (DispX% + 5, 254)-(DispX% + DispWidth% - 2, 272), 0, BF + sc$ = Str$(Pieces&) + Do While Len(sc$) < 11 + sc$ = " " + sc$ + Loop + DrawText DispX% + 9, 255, sc$, 7, 1, 2 + Pieces2& = Pieces& + End If + +End Sub + +Sub MainLoop + Dim As Integer CPlay, x, y, p, r, c, cmove, a + Dim PauseTime As Double, sTime As Double, cTime As Double + Dim k As String + + OldPiece% = 1 + Do + + If CPlay% = 0 Then PauseTime = .225 Else PauseTime = 0 + sTime = Timer + Do + + x% = OldX%: y% = OldY%: p% = OldPiece%: r% = OldR% + 'Delay .01 + + GameTime = Timer - StartTime + InfoDisplay + + Wait 986, 8 + DrawPiece x%, y%, p%, r%, 0 + x% = PieceX%: y% = PieceY%: p% = CurrentPiece%: r% = PieceR%: c% = PieceC% + DrawPiece x%, y%, p%, r%, c% + If Debug% = 1 Then DebugDisplay + CheckTouch + If GameOver% = 1 Then Exit Sub + OldX% = PieceX%: OldY% = PieceY%: OldPiece% = CurrentPiece%: OldR% = PieceR% + + Do + ink$ = InKey$ + If ink$ = Chr$(27) Then GameOver% = 1 + cmove% = 0 + If CPlay% = 1 Then + If Timer - cTime > -1 Then + If cmove% = 0 Then + If PieceR% = DestR% Then + Else + 'RotatePiece + ink$ = Chr$(0) + "H" + cmove% = 1 + cTime = Timer + End If + End If + If PieceX% < DestX% And cmove% = 0 Then + 'MoveRight + ink$ = Chr$(0) + "M" + cmove% = 1 + cTime = Timer + End If + If PieceX% > DestX% And cmove% = 0 Then + 'MoveLeft + ink$ = Chr$(0) + "K" + cmove% = 1 + cTime = Timer + End If + End If + End If + Loop While Timer - sTime < PauseTime And ink$ = "" + + usery% = 0 + If ink$ = Chr$(0) + "P" Then + PieceY% = PieceY% + 1 + usery% = 1 + End If + If ink$ = Chr$(0) + "K" Then + MoveLeft + End If + If ink$ = Chr$(0) + "M" Then + MoveRight + End If + If ink$ = Chr$(0) + "H" Then + RotatePiece + End If + For a = 1 To 15 + k = InKey$ + Next + Loop While Timer - sTime < PauseTime + If Compete% = 1 Then + If CMN% > competen% Then Exit Sub + End If + If usery% = 0 Then PieceY% = PieceY% + 1 + Loop +End Sub + +Sub Menu + Dim As Integer size, x, y, sx, c + + lblMenu: + BlueColors + Line (0, 0)-(640, 480), 1, BF + gap% = 6: shadow% = 3 + DrawText 55, 20, "Future Blocks", 7, 6, 2 + gap% = 4: shadow% = 2 + DrawText 65, 110, "1.Normal Game Mode", 7, 3, 2 + DrawText 65, 160, "2.Hint Mode", 7, 3, 2 + DrawText 65, 210, "3.Computer Mode", 7, 3, 2 + DrawText 65, 260, "4.Competition Mode", 7, 3, 2 + DrawText 65, 310, "5.Options", 7, 3, 2 + DrawText 65, 360, "6.Exit", 7, 3, 2 + gap% = 2: shadow% = 1 + DrawText 15, 460, "Future Software", 7, 1, 2 + DrawText 395, 460, "By Michael Fogleman", 7, 1, 2 + + size% = 6 + x% = 40: y% = 80 + sx% = x%: c% = 7 + Do + Line (x% + 1 + shadow%, y% + 1 + shadow%)-(x% + size% + 1 + shadow%, y% + size% + 1 + shadow%), 0, BF + Line (x% + 1, y% + 1)-(x% + size% - 1, y% + size% - 1), c%, BF + Line (x%, y%)-(x% + size%, y%), 15 + Line (x%, y%)-(x%, y% + size%), 15 + Line (x% + size%, y%)-(x% + size%, y% + size%), 8 + Line (x%, y% + size%)-(x% + size%, y% + size%), 8 + x% = x% + size% + 1 + Loop While x% < 600 + RestoreColors + BadKey: + Do + ink$ = InKey$ + Loop While ink$ = "" + If ink$ = "1" Then hint% = 0: CPlay% = 0: Exit Sub + If ink$ = "2" Then hint% = 1: CPlay% = 0: Exit Sub + If ink$ = "3" Then hint% = 0: CPlay% = 1: Exit Sub + If ink$ = "4" Then GoTo Compete + If ink$ = "5" Then GoTo Options + If ink$ = "6" Then Cls: System 0 + GoTo BadKey + + Compete: + BlueColors + Line (0, 0)-(640, 480), 1, BF + Compete% = 1 + GoSub Header + gap% = 4: shadow% = 2 + DrawText 85, 115, "Competition Mode", 7, 4, 2 + DrawText 230, 180, "Play to", 7, 3, 2 + DrawText 265, 220, Str$(competen%), 7, 3, 2 + DrawText 240, 260, "Blocks", 7, 3, 2 + GoSub InfoHeader + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + competen% = competen% + 1 + Line (260, 218)-(400, 255), 1, BF + DrawText 265, 220, Str$(competen%), 7, 3, 2 + End If + If ink$ = "-" Then + competen% = competen% - 1 + Line (260, 218)-(400, 255), 1, BF + DrawText 265, 220, Str$(competen%), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + Exit Sub + + Options: + BlueColors + GoSub Header + gap% = 4: shadow% = 2 + DrawText 65, 100, "1.PreStack", 7, 3, 2 + DrawText 465, 100, Str$(messyheight%), 7, 3, 2 + DrawText 65, 140, "2.Field Width", 7, 3, 2 + DrawText 465, 140, Str$(FieldWidth%), 7, 3, 2 + DrawText 65, 180, "3.Field Height", 7, 3, 2 + DrawText 465, 180, Str$(FieldHeight%), 7, 3, 2 + DrawText 65, 220, "4.Block Size", 7, 3, 2 + DrawText 465, 220, Str$(BlockSize%), 7, 3, 2 + DrawText 65, 260, "5.Line Weight", 7, 3, 2 + DrawText 465, 260, Str$(LineWeight), 7, 3, 2 + DrawText 65, 300, "6.Gap Weight", 7, 3, 2 + DrawText 465, 300, Str$(GapWeight), 7, 3, 2 + DrawText 65, 340, "7.Stack Weight", 7, 3, 2 + DrawText 465, 340, Str$(HeightWeight), 7, 3, 2 + DrawText 65, 380, "8.Side Weight", 7, 3, 2 + DrawText 465, 380, Str$(SideWeight), 7, 3, 2 + DrawText 65, 420, "9.Menu", 7, 3, 2 + gap% = 2: shadow% = 1 + DrawText 15, 460, "Future Software", 7, 1, 2 + DrawText 395, 460, "By Michael Fogleman", 7, 1, 2 + RestoreColors + BadKey2: + Do + ink$ = InKey$ + Loop While ink$ = "" + If ink$ = "9" Then GoTo lblMenu + If ink$ = "1" Then + BlueColors + GoSub Header + GoSub InfoHeader + gap% = 4: shadow% = 2 + DrawText 65, 200, "PreStack", 7, 3, 2 + DrawText 465, 200, Str$(messyheight%), 7, 3, 2 + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + messyheight% = messyheight% + 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(messyheight%), 7, 3, 2 + End If + If ink$ = "-" Then + messyheight% = messyheight% - 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(messyheight%), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + GoTo Options + End If + + If ink$ = "2" Then + BlueColors + GoSub Header + GoSub InfoHeader + gap% = 4: shadow% = 2 + DrawText 65, 200, "Field Width", 7, 3, 2 + DrawText 465, 200, Str$(FieldWidth%), 7, 3, 2 + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + FieldWidth% = FieldWidth% + 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(FieldWidth%), 7, 3, 2 + End If + If ink$ = "-" Then + FieldWidth% = FieldWidth% - 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(FieldWidth%), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + GoTo Options + End If + + If ink$ = "3" Then + BlueColors + GoSub Header + GoSub InfoHeader + gap% = 4: shadow% = 2 + DrawText 65, 200, "Field Height", 7, 3, 2 + DrawText 465, 200, Str$(FieldHeight%), 7, 3, 2 + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + FieldHeight% = FieldHeight% + 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(FieldHeight%), 7, 3, 2 + End If + If ink$ = "-" Then + FieldHeight% = FieldHeight% - 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(FieldHeight%), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + GoTo Options + End If + + If ink$ = "4" Then + BlueColors + GoSub Header + GoSub InfoHeader + gap% = 4: shadow% = 2 + DrawText 65, 200, "Block Size", 7, 3, 2 + DrawText 465, 200, Str$(BlockSize%), 7, 3, 2 + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + BlockSize% = BlockSize% + 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(BlockSize%), 7, 3, 2 + End If + If ink$ = "-" Then + BlockSize% = BlockSize% - 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(BlockSize%), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + GoTo Options + End If + + If ink$ = "5" Then + BlueColors + GoSub Header + GoSub InfoHeader + gap% = 4: shadow% = 2 + DrawText 65, 200, "Line Weight", 7, 3, 2 + DrawText 465, 200, Str$(LineWeight), 7, 3, 2 + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + LineWeight = LineWeight + 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(LineWeight), 7, 3, 2 + End If + If ink$ = "-" Then + LineWeight = LineWeight - 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(LineWeight), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + GoTo Options + End If + + If ink$ = "6" Then + BlueColors + GoSub Header + GoSub InfoHeader + gap% = 4: shadow% = 2 + DrawText 65, 200, "Gap Weight", 7, 3, 2 + DrawText 465, 200, Str$(GapWeight), 7, 3, 2 + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + GapWeight = GapWeight + 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(GapWeight), 7, 3, 2 + End If + If ink$ = "-" Then + GapWeight = GapWeight - 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(GapWeight), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + GoTo Options + End If + + If ink$ = "7" Then + BlueColors + GoSub Header + GoSub InfoHeader + gap% = 4: shadow% = 2 + DrawText 65, 200, "Stack Weight", 7, 3, 2 + DrawText 465, 200, Str$(HeightWeight), 7, 3, 2 + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + HeightWeight = HeightWeight + 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(HeightWeight), 7, 3, 2 + End If + If ink$ = "-" Then + HeightWeight = HeightWeight - 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(HeightWeight), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + GoTo Options + End If + + If ink$ = "8" Then + BlueColors + GoSub Header + GoSub InfoHeader + gap% = 4: shadow% = 2 + DrawText 65, 200, "Side Weight", 7, 3, 2 + DrawText 465, 200, Str$(SideWeight), 7, 3, 2 + RestoreColors + Do + ink$ = InKey$ + If ink$ = "+" Then + SideWeight = SideWeight + 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(SideWeight), 7, 3, 2 + End If + If ink$ = "-" Then + SideWeight = SideWeight - 1 + Line (460, 190)-(639, 230), 1, BF + DrawText 465, 200, Str$(SideWeight), 7, 3, 2 + End If + Loop While Not ink$ = Chr$(27) + GoTo Options + End If + GoTo BadKey2 + + InfoHeader: + gap% = 4: shadow% = 2 + DrawText 115, 360, "Use + and - To Change", 7, 2, 2 + DrawText 135, 390, "Press ESC When Done", 7, 2, 2 + gap% = 2: shadow% = 1 + DrawText 15, 460, "Future Software", 7, 1, 2 + DrawText 395, 460, "By Michael Fogleman", 7, 1, 2 + Return + Header: + Line (0, 0)-(640, 480), 1, BF + gap% = 6: shadow% = 3 '2 + DrawText 55, 20, "Future Blocks", 7, 6, 2 + size% = 6 + x% = 40: y% = 80 + sx% = x%: c% = 7 + Do + Line (x% + 1 + shadow%, y% + 1 + shadow%)-(x% + size% + 1 + shadow%, y% + size% + 1 + shadow%), 0, BF + Line (x% + 1, y% + 1)-(x% + size% - 1, y% + size% - 1), c%, BF + Line (x%, y%)-(x% + size%, y%), 15 + Line (x%, y%)-(x%, y% + size%), 15 + Line (x% + size%, y%)-(x% + size%, y% + size%), 8 + Line (x%, y% + size%)-(x% + size%, y% + size%), 8 + x% = x% + size% + 1 + Loop While x% < 600 + Return +End Sub + +Sub MoveLeft + Dim As Integer PrevX + + PrevX% = PieceX% + If PieceX% > 1 Then PieceX% = PieceX% - 1 + Overlap% = 0 + CheckOverlap + If Overlap% = 0 Then Else PieceX% = PrevX% +End Sub + +Sub MoveRight + Dim As Integer PrevX, XSize + + PrevX% = PieceX% + XSize% = PieceData%(0, PieceR%, CurrentPiece% - 1) + If PieceX% <= FieldWidth% - XSize% Then PieceX% = PieceX% + 1 + Overlap% = 0 + CheckOverlap + If Overlap% = 0 Then Else PieceX% = PrevX% +End Sub + +Sub NewPiece + Dim As Integer XSize, YSize, Xs + + Pieces& = Pieces& + 1 + If Compete% = 0 Then CurrentPiece% = NextPiece% + If Compete% = 1 Then CurrentPiece% = PieceList%(CMN%): CMN% = CMN% + 1 + BadPiece: + If Compete% = 0 Then + NextPiece% = Rnd * 100 + 1 + If NextPiece% > 7 Then GoTo BadPiece + End If + If Compete% = 1 Then + NextPiece% = PieceList%(CMN%) + End If + PieceX% = FieldWidth% / 2 + PieceR% = 0 + XSize% = PieceData%(0, PieceR%, CurrentPiece% - 1) + YSize% = PieceData%(1, PieceR%, CurrentPiece% - 1) + PieceY% = -1 * YSize% + PieceC% = NextC% + BadColor: + NextC% = Rnd * 13 + 1 + If NextC% = 8 Then GoTo BadColor + ComputerPlay 0 + If hint% = 1 Then ComputerPlay 1 + Line (DispX% + 7, 383)-(DispX% + DispWidth% - 7, 385 + 16 * 4.5), 0, BF + Xs% = PieceData%(0, 1, NextPiece% - 1) + 1 + DrawPiece2 DispX% + DispWidth% / 2 - BlockSize% * Xs% / 2, 385, NextPiece%, NextC% + PieceTime = Timer +End Sub + +Sub PreOccupy (nHeight As Integer) + Dim As Integer xn, yn, a, c + + xn% = 1: yn% = FieldHeight% - nHeight + 1 + Do + a% = Rnd + BCol: + c% = Rnd * 13 + 1 + If c% = 8 Then GoTo BCol + If a% = 1 Then Occupied%(xn%, yn%) = c% + xn% = xn% + 1 + If xn% > FieldWidth% Then xn% = 1: yn% = yn% + 1 + Loop While yn% <= FieldHeight% + RefreshField +End Sub + +Sub ReadData + Dim As Integer piece, r, Xs, Ys, b, n + + Restore Piece1 + piece% = 0 + Do + r% = 0 + Do + Read Xs%, Ys% + PieceData%(0, r%, piece%) = Xs% + PieceData%(1, r%, piece%) = Ys% + b% = Xs% * Ys% + n% = 0 + Do + Read PieceData%(n% + 2, r%, piece%) + n% = n% + 1 + Loop While n% < b% + r% = r% + 1 + Loop While r% < 4 + piece% = piece% + 1 + Loop While piece% < 7 +End Sub + +Sub ReadText + Dim As Integer letter, n + + Restore Text + letter% = 0 + Do + n% = 0 + Do + Read Text%(letter%, n%) + n% = n% + 1 + Loop While n% < 35 + letter% = letter% + 1 + Loop While letter% < 40 +End Sub + +Sub RefreshField + Dim As Integer xn, yn + + xn% = 1: yn% = 1 + Do + DrawBlock xn%, yn%, Occupied%(xn%, yn%) + xn% = xn% + 1 + If xn% > FieldWidth% Then xn% = 1: yn% = yn% + 1 + Loop While yn% < FieldHeight% + 1 +End Sub + +Sub RestoreColors + Dim As Integer n, c, r, g, b + + n% = 0: c% = 0 + Do + r% = pal%(n%) + g% = pal%(n% + 1) + b% = pal%(n% + 2) + Colors c%, r%, g%, b% + n% = n% + 3 + c% = c% + 1 + Loop While c% < 16 +End Sub + +Sub RotatePiece + Dim As Integer PrevR, PrevX, PrevY + + PrevR% = PieceR% + PrevX% = PieceX% + PrevY% = PieceY% + + usery% = 1 + PieceR% = PieceR% + 1 + If PieceR% > 3 Then PieceR% = 0 + Overlap% = 0 + CheckOverlap + If Overlap% = 0 Then Exit Sub + + PieceX% = PieceX% - 1 + Overlap% = 0 + CheckOverlap + If Overlap% = 0 Then Exit Sub + PieceX% = PieceX% - 1 + Overlap% = 0 + CheckOverlap + If Overlap% = 0 Then Exit Sub + usery% = 0 + PieceR% = PrevR% + PieceX% = PrevX% +End Sub + +Sub StoreOccupy + Dim As Integer xn, yn, Xs, Ys, maxn, n, c + + xn% = PieceX%: yn% = PieceY% + Xs% = PieceData%(0, PieceR%, CurrentPiece% - 1) + Ys% = PieceData%(1, PieceR%, CurrentPiece% - 1) + maxn% = Xs% * Ys% + n% = 0 + Do + c% = PieceData%(n% + 2, PieceR%, CurrentPiece% - 1) + If c% = 0 Then + Else + If xn% > 0 And yn% > 0 And xn% <= FieldWidth% And yn% <= FieldHeight% Then + Occupied%(xn%, yn%) = PieceC% + End If + End If + xn% = xn% + 1 + If xn% - PieceX% >= Xs% Then xn% = PieceX%: yn% = yn% + 1 + n% = n% + 1 + Loop While n% < maxn% +End Sub + +Sub TitleScreen + Dim As Integer a + Dim k As String + + BlueColors + Line (0, 0)-(640, 480), 1, BF + gap% = 10: shadow% = 3 + DrawText 50, 50, "FUTURE", 2, 14, 2 + DrawText 100, 200, "BLOCKS", 2, 14, 2 + gap% = 4: shadow% = 2 + DrawText 45, 340, "BY MICHAEL FOGLEMAN", 9, 4, 2 + RestoreColors + Delay 2 + gap% = 4: shadow% = 1 + DrawText 80, 440, "PRESS ANY KEY TO CONTINUE", 7, 2, 2 + For a = 1 To 15 + k = InKey$ + Next + Do + Loop While InKey$ = "" +End Sub + diff --git a/samples/galleon.md b/samples/galleon.md new file mode 100644 index 0000000..567439f --- /dev/null +++ b/samples/galleon.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 GALLEON + +**[MyCraft](mycraft/index.md)** + +[🐝 Galleon](galleon.md) 🔗 [game](game.md), [minecraft](minecraft.md) + +Progress toward a Minecraft clone. diff --git a/samples/game.md b/samples/game.md index a3e2d59..43d3f59 100644 --- a/samples/game.md +++ b/samples/game.md @@ -20,12 +20,36 @@ A 2D platformer game by Tsiplacov Sergey This is a game of weapons and destruction that relies upon the properties of physics as well as y... +**[Bad Box Revenge](bad-box-revenge/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [bad boxes](bad-boxes.md) + +'** '** Revenge of the Bad Boxes! V1.0 '** '** by Terry Ritchie 02/11/13 '** + +**[Bad Boxes](bad-boxes/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [bad boxes](bad-boxes.md) + +'** '** Program Name: Bad Boxes '** Version : 1.0 '** Author : Terry Ritchie '** Date ... + +**[Beatdown](beatdown/index.md)** + +[🐝 Brian Murphy](brian-murphy.md) 🔗 [game](game.md), [legacy](legacy.md) + +' Beat Down ' 1998 MicroTrip ' ... + **[Blockout](blockout/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [breakout](breakout.md) A Breakout clone with DXBall aspirations. +**[Breakout](breakout/index.md)** + +[🐝 kinem](kinem.md) 🔗 [game](game.md), [breakout](breakout.md) + +Breakout game. + **[Cant Contain Me](cant-contain-me/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md) @@ -38,24 +62,114 @@ Can't Contain Me is a game developed in QB64. The pieces are trying to escape y A turn-based artillery game by Microsoft. +**[Chess](chess/index.md)** + +[🐝 Richard Frost](richard-frost.md) 🔗 [game](game.md), [chess](chess.md) + +Eccentric chess implementation by Richard Frost. + +**[Cloned Shades](cloned-shades/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md) + +A clone of 'Shades' which was originally developed by UOVO. + +**[Cram](cram/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [game](game.md), [dos world](dos-world.md) + +'CRAM! ' by Hardin Brothers ' ' Copyright (C) 1993 DOS Resource Guide ' Published in Issue ... + +**[Diamond Pong](diamond-pong/index.md)** + +[🐝 John Wolfskill](john-wolfskill.md) 🔗 [game](game.md), [pong](pong.md), [dos world](dos-world.md) + +' Diamond Pong ' by ' John Wol... + +**[Didris](didris/index.md)** + +[🐝 Dietmar Moritz](dietmar-moritz.md) 🔗 [game](game.md), [tetris](tetris.md) + +'________________________This_is_the_unbelievable '________ÜÜÜ___ÜÜ_________ÜÜÜ____________ÜÜ '__... + **[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... +**[Flappy Bird](flappy-bird/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [flappy bird](flappy-bird.md) + +' ----------------------------------------------- ' QB64 FlappyBird Clone by Terry Ritchie 02/28/... + **[Four Player Pong](four-player-pong/index.md)** [🐝 Matthew](matthew.md) 🔗 [game](game.md), [pong](pong.md) Four-player pong game. +**[Frogger](frogger/index.md)** + +[🐝 Matt Bross](matt-bross.md) 🔗 [game](game.md), [frogger](frogger.md) + +Frogger game by Matt Bross. + +**[Frostbite](frostbite/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [frostbite](frostbite.md) + +A clone of Frostbite for the Atari 2600, originally designed by Steve Cartwright and published by... + +**[Future Blocks](future-blocks/index.md)** + +[🐝 Michael Fogleman](michael-fogleman.md) 🔗 [game](game.md), [tetris](tetris.md) + +Tetris clone by Michael Fogleman. + +**[Ghost Wizard](ghost-wizard/index.md)** + +[🐝 Zack Johnson](zack-johnson.md) 🔗 [game](game.md), [roguelike](roguelike.md) + +' ' Ghost Wizard ' Zack Johnson ' 7DRL 2019 (Mar 2 - Mar 7) ' + +**[Gorillas](gorillas/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [artillery](artillery.md) + +Gorilla-based artillery game by Microsoft. + +**[Hangman](hangman/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [game](game.md), [hangman](hangman.md), [dos world](dos-world.md) + +' HANGMAN.BAS by Antonio & Alfonso De Pasquale ' Copyright (C) 1993, 1994 DOS Resource Guide ' ... + **[Helicopter Rescue](helicopter-rescue/index.md)** [🐝 TrialAndTerror](trialandterror.md) 🔗 [game](game.md), [3d](3d.md), [flight](flight.md) ================================================================================= H E L ... +**[Hunter](hunter/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [maze](maze.md) + +Maze hunter game by Microsoft. + +**[Hunters Revenge](hunters-revenge/index.md)** + +[🐝 Ashish Kushwaha](ashish-kushwaha.md) 🔗 [game](game.md), [shooter](shooter.md) + +# Hunter-Revenge A shooting game created in QB64 + +**[Letter Blast](letter-blast/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [game](game.md), [letter](letter.md), [dos world](dos-world.md) + +' LETBLAST.BAS - Shoot the falling letters! ' by Antonio & Alfonso De Pasquale ' ' Copyr... + **[LightsOn](lightson/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [lights](lights.md) @@ -74,6 +188,12 @@ Four-player pong game. Lunar Lander based on a 1974 program running on a DEC PDP/11 with GT40 vector display terminal at... +**[MyCraft](mycraft/index.md)** + +[🐝 Galleon](galleon.md) 🔗 [game](game.md), [minecraft](minecraft.md) + +Progress toward a Minecraft clone. + **[Nibbles](nibbles/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [snake](snake.md) @@ -98,6 +218,12 @@ My attempt at creating something drawing inspiration from Fire Rides by Voodoo. # Platform What does a 2D platform game take? Made with QB64. +**[QB Tank Commander](qb-tank-commander/index.md)** + +[🐝 Matthew River Knight](matthew-river-knight.md) 🔗 [game](game.md), [tank](tank.md) + +'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ' ' ±± ±... + **[QBlocks](qblocks/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [tetris](tetris.md) @@ -152,6 +278,12 @@ Snake clone by Bob Seguin. Reversi game by Microsoft. +**[Robo Raider](robo-raider/index.md)** + +[🐝 Kevin](kevin.md) 🔗 [game](game.md) + +****RoboRaider**** ****README.TXT**** Robo Raider is ... + **[Set Fire to Rain](set-fire-to-rain/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [zen](zen.md) @@ -188,12 +320,24 @@ Snake clone by pcluddite. Fly across the universe on a quest for survival against alien enemy forces. Made with QB64. +**[Super Mario Jump](super-mario-jump/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [mario](mario.md) + +Super Mario Jump! + **[Tic Tac Toe](tic-tac-toe/index.md)** [🐝 Paul Meyer](paul-meyer.md) 🔗 [game](game.md), [tic tac toe](tic-tac-toe.md) Tic tac toe game by Paul Meyer. +**[Tic Tac Toe 3D](tic-tac-toe-3d/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [game](game.md), [tic tac toe](tic-tac-toe.md) + +The goal is to get four in a row while preventing the computer from doing the same. Move by click... + **[Tic Tac Toe Rings](tic-tac-toe-rings/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [tic tac toe rings](tic-tac-toe-rings.md) diff --git a/samples/geometry.md b/samples/geometry.md index 87dbb17..2f6e765 100644 --- a/samples/geometry.md +++ b/samples/geometry.md @@ -20,6 +20,12 @@ This is an interactive (mouse-driven) demo that calculates the intersection of a ... all I could think is "why stop at circles when you can do ellipses?" +**[Lines Intersecting](lines-intersecting/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [geometry](geometry.md), [intersections](intersections.md) + +Line segments intersecting. + **[Torus Demo](torus-demo/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [geometry](geometry.md), [torus](torus.md) diff --git a/samples/ghost-wizard/img/screenshot.png b/samples/ghost-wizard/img/screenshot.png new file mode 100644 index 0000000..054c8d4 Binary files /dev/null and b/samples/ghost-wizard/img/screenshot.png differ diff --git a/samples/ghost-wizard/index.md b/samples/ghost-wizard/index.md new file mode 100644 index 0000000..1509ede --- /dev/null +++ b/samples/ghost-wizard/index.md @@ -0,0 +1,33 @@ +[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: GHOST WIZARD + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Zack Johnson](../zack-johnson.md) + +### Description + +```text +' +' Ghost Wizard +' Zack Johnson +' 7DRL 2019 (Mar 2 - Mar 7) +' +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "ghostwiz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/ghost-wizard/src/ghostwiz.bas) +* [RUN "ghostwiz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/ghost-wizard/src/ghostwiz.bas) +* [PLAY "ghostwiz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/ghost-wizard/src/ghostwiz.bas) + +### File(s) + +* [ghostwiz.bas](src/ghostwiz.bas) + +🔗 [game](../game.md), [roguelike](../roguelike.md) diff --git a/samples/ghost-wizard/src/ghostwiz.bas b/samples/ghost-wizard/src/ghostwiz.bas new file mode 100644 index 0000000..2d17aef --- /dev/null +++ b/samples/ghost-wizard/src/ghostwiz.bas @@ -0,0 +1,3036 @@ +' +' Ghost Wizard +' Zack Johnson +' 7DRL 2019 (Mar 2 - Mar 7) +' + +Screen _NewImage(480, 320, 32) +_Font 8 +_FullScreen _SquarePixels +Randomize Timer + + +Dim Shared level(300, 300, 3) ' the contents of the level +Dim Shared groundcolor~&(300, 300, 3) ' the color of the ground +Dim Shared seed(300, 300, 3) ' for randomizing various display things +Dim Shared secretstairs(300, 300, 3) ' for revealed staircases +Dim Shared playerx, playery, playerdepth +Dim Shared playerhp, playermp, playerscore +Dim Shared exiting +Dim Shared messages$(7) +Dim Shared spells(9) +Dim Shared feelings(10) +Dim Shared soulattacks ' for tracking Sorrow unlock +Dim Shared currentspell +Dim Shared spellnames$(20) +Dim Shared spellcosts(20) +Dim Shared frame +Dim Shared defaultgroundcolor~&(5) +Dim Shared enemyupdated(31, 31) +Dim Shared groundcolors~&(30) +Dim Shared debugmovement +Dim Shared pitymana +Dim Shared permadeath, difficulty +Dim Shared gameover +Dim Shared lastmove ' for continuous movement + +' ======================================================= BEGIN MAIN LOOP + +top: + +Call titlescreen + +startgame: +Cls + +Call updateui +Call initialize + +Call buildworld +Call updateui + +mainloop: + +Call displayworld +Call playerinput + +If exiting Then + Color _RGB(255, 255, 255), 0 + System +End If +If gameover Then GoTo top +GoTo mainloop + +' ======================================================= END MAIN LOOP + +Sub updateui + ' display messages + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + For lop = 1 To 60 + For lopp = 34 To 40 + Call blankspace(lopp, lop) + Next lopp + Next lop + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + For lop = 1 To 7 + Locate 33 + lop, 1 + Print messages$(lop); + Next lop + 'display status area + For lop = 34 To 60 + For lopp = 1 To 33 + Call blankspace(lopp, lop) + Next lopp + Next lop + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Locate 2, 40 + Print "Coherence: "; + Color _RGB(255, 0, 0) + Locate 2, 51 + Print Str$(playerhp); + Locate 3, 40 + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Print "Influence: "; + Locate 3, 51 + Color _RGB(0, 0, 255) + Print Str$(playermp); + If playermp > balancevar(11) + 30 Then feelings(8) = 1 ' Contentment unlock + Locate 4, 40 + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Print "Knowledge: "; + Locate 4, 51 + Color _RGB(0, 255, 0) + Print Str$(playerscore) + "%"; + Locate 6, 40 + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Print "Spells:" + Color _RGB(155, 155, 155), _RGB(0, 0, 0) + Locate 7, 35 + Print "#1-9 to select" + Locate 8, 35 + Print "Arrow keys to cast" + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Locate 9, 35 + Print "0 to scry (5 Inf)" + For lop = 1 To 9 + If spells(lop) > 0 Then + Locate 10 + lop, 37 + If currentspell = lop Then Color _RGB(255, 255, 255), _RGB(150, 150, 255) + If currentspell <> lop Then Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Print Str$(lop) + ". " + spellnames$(spells(lop)) + " (" + LTrim$(Str$(spellcosts(spells(lop)))) + " Inf) "; + End If + Next lop + + Color _RGB(100, 100, 100), _RGB(0, 0, 0) + If playerscore >= 0 Then line1$ = "I don't know who I am." + If playerscore >= 10 Then line1$ = "I'm a ghost." + If playerscore >= 20 Then line1$ = "I was a wizard." + If playerscore >= 30 Then line1$ = "I'm a ghost wizard." + + line2$ = "" + If playerscore >= 40 Then line2$ = "I don't know where I am." + If playerscore >= 50 Then line2$ = "This wasn't my home." + If playerscore >= 60 Then line2$ = "I have to leave." + If playerscore >= 70 Then line2$ = "Something keeps me here." + + line3$ = "" + If playerscore >= 80 Then line3$ = "It's... a stone." + If playerscore >= 90 Then line3$ = "A monument." + If playerscore >= 100 Then line3$ = "A statue. Of who I was." + + line4$ = "" + If playerscore >= 100 Then + west = 0: north = 0: south = 0: east = 0 + If playerx < 145 Then east = 1 + If playerx > 155 Then west = 1 + If playery < 145 Then south = 1 + If playery > 155 Then north = 1 + If east = 1 Then line4$ = "It's to the east." + If west = 1 Then line4$ = "It's to the west." + If north = 1 Then line4$ = "It's to the north." + If south = 1 Then line4$ = "It's to the south." + If east = 1 And north = 1 Then line4$ = "It's to the northeast." + If east = 1 And south = 1 Then line4$ = "It's to the southeast." + If west = 1 And north = 1 Then line4$ = "It's to the northwest." + If west = 1 And south = 1 Then line4$ = "It's to the southwest." + If (north + south + east + west = 0) Then line4$ = "I know what to do." + End If + Locate 29, 35 + Print line1$ + Locate 30, 35 + Print line2$ + Locate 31, 35 + Print line3$ + Locate 32, 35 + Print line4$ + + ' emotion memories + showemotions = 0 + For lop = 1 To 9 + If feelings(lop) = 1 Then showemotions = 1 + Next lop + If showemotions Then + Color _RGB(100, 100, 100), _RGB(0, 0, 0) + Locate 21, 35 + Print "I remember" + If feelings(1) Then + Color _RGB(60, 60, 60) + Locate 23, 52 + Print "Fear" + End If + If feelings(2) Then + Color _RGB(255, 60, 60) + Locate 24, 36 + Print "Anger" + End If + If feelings(3) Then + Color _RGB(255, 60, 255) + Locate 25, 51 + Print "Shame" + End If + If feelings(4) Then + Color _RGB(255, 0, 255) + Locate 26, 36 + Print "Disgust" + End If + If feelings(5) Then + Color _RGB(90, 90, 255) + Locate 26, 47 + Print "Gratitude" + End If + If feelings(6) Then + Color _RGB(30, 30, 255) + Locate 25, 36 + Print "Melancholy" + End If + If feelings(7) Then + Color _RGB(255, 255, 0) + Locate 24, 48 + Print "Surprise" + End If + If feelings(8) Then + Color _RGB(60, 255, 60) + Locate 23, 36 + Print "Contentment" + End If + End If + + +End Sub + +Sub playerinput + exiting = 0 + lastrefresh = Timer + + Do + contdelay = 0 + k$ = "" + k$ = InKey$ + If k$ = Chr$(0) + Chr$(72) Then k$ = "uparrow" + If k$ = Chr$(0) + Chr$(80) Then k$ = "downarrow" + If k$ = Chr$(0) + Chr$(75) Then k$ = "leftarrow" + If k$ = Chr$(0) + Chr$(77) Then k$ = "rightarrow" + If k$ = Chr$(27) Then k$ = "escape" + ' some day, experiment with this for smooth continuous movement + 'IF _KEYDOWN(87) OR _KEYDOWN(119) THEN ' continuous movement + ' k$ = "w" + '_KEYCLEAR + 'END IF + + If Timer > lastrefresh + .25 Then + Call displayworld + lastrefresh = Timer + Call advanceframe + End If + Loop Until k$ <> "" + k$ = LCase$(k$) + Select Case k$ + Case "w" + Call moveplayer("up") + Case "a" + Call moveplayer("left") + Case "s" + Call moveplayer("down") + Case "d" + Call moveplayer("right") + Case "1" + Call switchspell(1) + Case "2" + Call switchspell(2) + Case "3" + Call switchspell(3) + Case "4" + Call switchspell(4) + Case "5" + Call switchspell(5) + Case "6" + Call switchspell(6) + Case "7" + Call switchspell(7) + Case "8" + Call switchspell(8) + Case "9" + Call switchspell(9) + Case "0" + Call scry + Case "uparrow" + Call castspell("up") + Case "downarrow" + Call castspell("down") + Case "leftarrow" + Call castspell("left") + Case "rightarrow" + Call castspell("right") + + Case "escape" + Color _RGB(255, 0, 0), _RGB(255, 0, 0) + For lop = 7 To 27 + For lopp = 16 To 18 + Locate lopp, lop + Print Chr$(219) + Next lopp + Next lop + Locate 17, 9 + Color _RGB(255, 255, 255), _RGB(255, 0, 0) + Print "Really quit? Y/N" + g$ = "" + While g$ = "" + g$ = InKey$ + Wend + If UCase$(g$) = "Y" Then exiting = 1 + Call blankspace(17, 17) + Call displayworld + Case "x" + exiting = 1 + ' CASE "k" + ' playerscore = playerscore + 10 + Call updateui + ' CASE "v" 'debug + ' playerhp = 100 + ' playermp = 30 + ' FOR lop = 1 TO 9 + ' spells(lop) = lop + ' NEXT lop + ' CASE "z" + ' playerdepth = playerdepth + 1 + ' CALL displayworld + ' CASE "i" + ' playerhp = 1 + ' CALL updateui + ' CASE "p" + ' IF debugmovement = 0 THEN debugmovement = 1 ELSE debugmovement = 0 + ' IF debugmovement = 1 THEN CALL message("debug movement ON") ELSE CALL message("debug movement OFF") + End Select + _KeyClear + +End Sub + +Sub scry + If (playermp < 5) Then + Call message("Your influence is too weak.") + Else + playermp = playermp - 5 + Call message("The veil is parted.") + For lop = -15 To 15 + For lopp = -15 To 15 + If (lopp <> 0 Or lop <> 0) Then ' skip the center space + purp = 150 + Int(Rnd * 100) + Call blankspace(17 + lopp, 17 + lop) + Locate 17 + lopp, 17 + lop, 0 + If secretstairs(playerx + lop, playery + lopp, playerdepth) = 1 Then + Color _RGB(255, 255, 255), _RGB(purp, 0, purp) + Print "!" + Else + Color _RGB(purp, 0, purp) + Print Chr$(219) + End If + End If + Next lopp + Next lop + _Delay 2 + End If +End Sub + +Sub displayworld ' update the entire world display + + bl$ = Chr$(219) ' draw the frame + For lop = 1 To 33 + Color _RGB(255, 255, 255), 0 + Locate lop, 1: Print bl$; + Locate lop, 33: Print bl$; + Locate 1, lop: Print bl$; + Locate 33, lop: Print bl$; + Next lop + ' draw the area surrounding the player + For lop = -15 To 15 + For lopp = -15 To 15 + If (lopp <> 0 Or lop <> 0) Then ' skip the center space + Call blankspace(17 + lopp, 17 + lop) + Locate 17 + lopp, 17 + lop, 0 + Call drawspace(playerx + lop, playery + lopp) + End If + Next lopp + Next lop + + ' draw player + Color _RGBA(255, 255, 255, 128), groundcolor~&(playerx, playery, playerdepth) + Locate 17, 17: Print Chr$(2); +End Sub + +Sub drawspace (x, y) + contents = level(x, y, playerdepth) + myseed = seed(x, y, playerdepth) + stage = (frame + myseed) Mod 20 ' for animated elements + mygroundcolor~& = groundcolor~&(x, y, playerdepth) + + fg~& = _RGB(255, 255, 255) ' default fg to white + bg~& = groundcolor~&(x, y, playerdepth) ' default bg to ground color + char = 65 ' default to a... capital A + Select Case contents + Case 0 + char = 32 + fg~& = _RGB(196, 139, 0) + If myseed = 25 Then ' desert texture 1 + char = 176 + fg~& = _RGB(204, 202, 68) + End If + If myseed = 26 Then ' desert texture 2 + char = 177 + fg~& = _RGB(204, 202, 68) + End If + If myseed = 61 Then ' obsidian texture 1 + char = 176 + fg~& = _RGB(35, 35, 35) + End If + If myseed = 62 Then ' obsidian texture 1 + char = 177 + fg~& = _RGB(35, 35, 35) + End If + If myseed > 80 Then ' ice + If myseed = 81 Then char = 47 + fg~& = _RGB(200, 200, 255) + bg~& = _RGB(100, 255, 255) + End If + If myseed > 50 And myseed < 60 Then ' road + bg~& = _RGB(126, 81, 9) + If myseed = 51 Then ' bridge + char = 205 + fg~& = _RGB(126, 81, 9) + bg~& = _RGB(110, 44, 0) + ElseIf myseed > 54 Then ' dirt on road + fg~& = _RGB(156, 100, 12) + char = 176 + End If + End If + Case 1 + char = 65 + Case 2 ' coherence gem + fg~& = _RGB(255, 0, 0) + If frame / 2 = Int(frame / 2) Then char = 15 Else char = 42 + Case 3 ' influence gem + fg~& = _RGB(0, 0, 255) + If frame / 2 = Int(frame / 2) Then char = 42 Else char = 15 + Case 4 ' spell scroll + bg~& = _RGB(255, 255, 255) + fg~& = _RGB(Int(Rnd * 255) + 1, Int(Rnd * 255) + 1, Int(Rnd * 255) + 1) + char = 156 + If stage > 4 Then char = 155 + If stage > 9 Then char = 231 + If stage > 14 Then char = 251 + Case 5 ' stairs down + bg~& = _RGB(0, 0, 0) + fg~& = _RGB(255, 255, 255) + char = 62 + Case 6 ' stairs up + fg~& = _RGB(255, 255, 255) + char = 60 + Case 7 ' memory fragment + fg~& = _RGB(Int(Rnd * 255) + 1, Int(Rnd * 255) + 1, Int(Rnd * 255) + 1) + char = 21 + Case 8 ' knowledge gem + fg~& = _RGB(0, 255, 0) + If frame / 2 = Int(frame / 2) Then char = 42 Else char = 15 + Case 9 ' influence mote + char = 250 + fg~& = _RGB(0, 0, 255) + Case 10 ' tree + If myseed Mod 3 = 1 Then char = 5 + If myseed Mod 3 = 2 Then char = 6 + If myseed Mod 3 = 0 Then char = 24 + fg~& = _RGB(33, 60 + (myseed * 2), 33) + Case 11 ' stump + fg~& = _RGB(160, 160, 160) + char = 227 + Case 12 ' cactus + If myseed Mod 3 = 1 Then char = 181 + If myseed Mod 3 = 2 Then char = 216 + If myseed Mod 3 = 0 Then char = 195 + fg~& = _RGB(66, 90 + (myseed * 5), 66) + Case 50 + bg~& = _RGB(93, 109, 126) + fg~& = _RGB(103, 119, 136) + If myseed Mod 4 = 1 Then char = 177 Else char = 32 + If mygroundcolor~& = groundcolors~&(1) Then ' lighter rocks in the desert + bg~& = _RGB(123, 139, 156) + fg~& = _RGB(133, 149, 136) + + End If + If myseed = 0 Then + char = 219 + fg~& = _RGB(255, 255, 255) + End If + Case 51 ' wood wall + bg~& = _RGB(90, 24, 0) + fg~& = _RGB(120, 54, 30) + char = 186 + Case 52 ' gravestone + char = 241 + bg~& = _RGB(200, 200, 200) + fg~& = _RGB(255, 255, 255) + Case 90 ' amphora/pot/urn + char = 127 + fg~& = _RGB(200, 200, 200) + If mygroundcolor~& = groundcolors~&(1) Then + char = 232 + fg~& = _RGB(184, 134, 11) + End If + If mygroundcolor~& = groundcolors~&(5) Then ' inside house + char = 235 + fg~& = _RGB(153, 102, 51) + End If + + If mygroundcolor~& = groundcolors~&(6) Then + char = 240 + fg~& = _RGB(200, 200, 200) + End If + Case 100 ' scorpion + If stage Mod 4 = 0 Then fg~& = _RGB(150, 150, 150) + If stage Mod 4 = 1 Then fg~& = _RGB(180, 180, 180) + If stage Mod 4 = 2 Then fg~& = _RGB(200, 200, 200) + If stage Mod 4 = 3 Then fg~& = _RGB(180, 180, 180) + char = 157 + Case 101 ' lost soul + If stage Mod 4 = 0 Then fg~& = _RGB(150, 150, 150) + If stage Mod 4 = 1 Then fg~& = _RGB(180, 180, 180) + If stage Mod 4 = 2 Then fg~& = _RGB(200, 200, 200) + If stage Mod 4 = 3 Then fg~& = _RGB(180, 180, 180) + char = 1 + Case 102 ' snake + If stage Mod 4 = 0 Then fg~& = _RGB(150, 150, 150) + If stage Mod 4 = 1 Then fg~& = _RGB(180, 180, 180) + If stage Mod 4 = 2 Then fg~& = _RGB(200, 200, 200) + If stage Mod 4 = 3 Then fg~& = _RGB(180, 180, 180) + char = 115 + Case 103 ' will o the wisp + fg~& = _RGB(255, 255, 0) + If stage Mod 3 = 0 Then char = 136 + If stage Mod 3 = 1 Then char = 137 + If stage Mod 3 = 2 Then char = 138 + Case 104 ' rage soul + fg~& = _RGB(255, 0, 0) + If stage Mod 3 = 0 Then char = 147 + If stage Mod 3 = 1 Then char = 148 + If stage Mod 3 = 2 Then char = 149 + Case 105 ' spider + If stage Mod 4 = 0 Then fg~& = _RGB(100, 100, 100) + If stage Mod 4 = 1 Then fg~& = _RGB(120, 120, 120) + If stage Mod 4 = 2 Then fg~& = _RGB(150, 150, 150) + If stage Mod 4 = 3 Then fg~& = _RGB(120, 120, 120) + char = 15 + Case 106 ' fungus + bg~& = _RGB(255, 0, 255) + fg~& = _RGB(255, 255, 0) + If stage Mod 3 = 0 Then char = 248 + If stage Mod 3 = 1 Then char = 249 + If stage Mod 3 = 2 Then char = 58 + Case 800 ' endgame statue + fg~& = _RGB(200, 200, 200) + char = 2 + Case 998 ' water + fg~& = _RGB(128, 128, 255) + char = 32 + If stage >= 15 Then char = 126 + If stage >= 17 Then char = 247 + Case 997 ' lava + fg~& = _RGB(255, 255, 0) + bg~& = _RGB(255, 102, 0) + char = 32 + If stage >= 15 Then char = 126 + If stage >= 17 Then char = 247 + Case 999 ' Void Space (twinkles) + char = 32 + fg~& = _RGB((((x + y) Mod 20) * 12), (((x + y) Mod 20) * 12), 255) + If stage = 1 Then char = 249 + If stage = 2 Then char = 43 + If stage = 3 Then char = 42 + 'IF myseed < 15 THEN char = 32 ' make them sparse + 'char = myseed + 64 + stage + End Select + Color fg~&, bg~& + Print Chr$(char); +End Sub + +Sub blankspace (col, row) + Locate col, row, 0 + Color _RGB(0, 0, 0) + Print Chr$(219); +End Sub + +Sub switchspell (which) + If spells(which) > 0 Then + currentspell = which + End If + If spells(which) = 0 Then + message ("The memory of that spell is unavailable to you.") + End If + Call updateui + +End Sub + +Sub castspell (dir$) + If playermp < spellcosts(currentspell) Then + Call message("You lack the influence to cast that spell.") + GoTo spellfail + End If + If currentspell = 0 Then GoTo spellfail + playermp = playermp - spellcosts(currentspell) + Select Case dir$ + Case "up" + adjx = playerx + adjy = playery - 1 + screenx = 17 + screeny = 16 + xdir = 0 + ydir = -1 + Case "down" + adjx = playerx + adjy = playery + 1 + screenx = 17 + screeny = 18 + xdir = 0 + ydir = 1 + Case "left" + adjx = playerx - 1 + adjy = playery + screenx = 16 + screeny = 17 + xdir = -1 + ydir = 0 + Case "right" + adjx = playerx + 1 + adjy = playery + screenx = 18 + screeny = 17 + xdir = 1 + ydir = 0 + End Select + + ' blade + If currentspell = 1 Then + Call showslashsquare(screenx, screeny, adjx, adjy) + Call slashsquare(screenx, screeny, adjx, adjy) + End If + If currentspell = 2 Then ' throwing dagger + For lop = 1 To 5 + test = level(playerx + (xdir * lop), playery + (ydir * lop), playerdepth) + If test = 0 Then + Call showarrowsquare(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Else + Call showplinksquare(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Call plinksquare(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Exit For + End If + Next lop + End If + If currentspell = 3 Then ' candle + Call showburnsquare(17 + xdir, 17 + ydir, playerx + xdir, playery + ydir) + Call burnsquare(17 + xdir, 17 + ydir, playerx + xdir, playery + ydir) + Call showburnsquare(17 + xdir * 2, 17 + ydir * 2, playerx + xdir * 2, playery + ydir * 2) + Call burnsquare(17 + xdir * 2, 17 + ydir * 2, playerx + xdir * 2, playery + ydir * 2) + End If + If currentspell = 4 Then ' fireball + For lop = 1 To 5 + test = level(playerx + (xdir * lop), playery + (ydir * lop), playerdepth) + If test = 0 And lop < 5 Then + Call showfireballsquare(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Else + Call showburnblast(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Call burnblast(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Exit For + End If + Next lop + End If + + If currentspell = 5 Then + Call showhammersquare(screenx, screeny, adjx, adjy) + Call hammersquare(screenx, screeny, adjx, adjy) + End If + + If currentspell = 6 Then ' bomb + For lop = 1 To 5 + test = level(playerx + (xdir * lop), playery + (ydir * lop), playerdepth) + If test = 0 And lop < 5 Then + Call showbombsquare(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Else + Call showbombblast(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Call bombblast(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Exit For + End If + Next lop + End If + + If currentspell = 7 Then ' holy water + Call showspritzsquare(17 + xdir, 17 + ydir, playerx + xdir, playery + ydir) + Call spritzsquare(17 + xdir, 17 + ydir, playerx + xdir, playery + ydir) + Call showspritzsquare(17 + xdir * 2, 17 + ydir * 2, playerx + xdir * 2, playery + ydir * 2) + Call spritzsquare(17 + xdir * 2, 17 + ydir * 2, playerx + xdir * 2, playery + ydir * 2) + Call showspritzsquare(17 + xdir * 3, 17 + ydir * 3, playerx + xdir * 3, playery + ydir * 3) + Call spritzsquare(17 + xdir * 3, 17 + ydir * 3, playerx + xdir * 3, playery + ydir * 3) + End If + + If currentspell = 8 Then ' acid blast + Call showacidblast(17 + (xdir * 3), 17 + (ydir * 3), playerx + (xdir * 3), playery + (ydir * 3)) + Call acidblast(17 + (xdir * 3), 17 + (ydir * 3), playerx + (xdir * 3), playery + (ydir * 3)) + End If + + If currentspell = 9 Then ' ice beam + For lop = 1 To 5 + Call showiceballsquare(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Call freezesquare(17 + (xdir * lop), 17 + (ydir * lop), playerx + (xdir * lop), playery + (ydir * lop)) + Next lop + End If + Call updateui + Call displayworld + Call moveenemies + spellfail: + +End Sub + +Sub showarrowsquare (screenx, screeny, levelx, levely) ' cosmetic + Locate screeny, screenx + Color _RGB(150, 50, 0), groundcolor~&(levelx, levely, playerdepth) + Print Chr$(250); + _Delay .09 + Call displayworld +End Sub + +Sub showfireballsquare (screenx, screeny, levelx, levely) ' also cosmetic + Locate screeny, screenx + Color _RGB(255, 0, 0), groundcolor~&(levelx, levely, playerdepth) + Print "*"; + _Delay .10 + Call displayworld +End Sub + +Sub showiceballsquare (screenx, screeny, levelx, levely) ' also cosmetic + Locate screeny, screenx + Color _RGB(200, 255, 255), groundcolor~&(levelx, levely, playerdepth) + Print "*"; + _Delay .10 + Call displayworld +End Sub + + +Sub showbombsquare (screenx, screeny, levelx, levely) ' also cosmetic + Locate screeny, screenx + Color _RGB(255, 0, 0), groundcolor~&(levelx, levely, playerdepth) + Print Chr$(235); + _Delay .15 + Call displayworld +End Sub + +Sub showspritzsquare (screenx, screeny, levelx, levely) ' also cosmetic + Locate screeny, screenx + Color _RGB(0, 0, 200), groundcolor~&(levelx, levely, playerdepth) + Print Chr$(176); + _Delay .10 + Call displayworld +End Sub + + +Sub showburnsquare (screenx, screeny, levelx, levely) ' also cosmetic + Color _RGB(255, 0, 0), groundcolor~&(levelx, levely, playerdepth) + For lop = 1 To 5 + Locate screeny, screenx + Select Case Int(Rnd * 4) + Case 0: Print Chr$(200) + Case 1: Print Chr$(201) + Case 2: Print Chr$(187) + Case 3: Print Chr$(188) + End Select + _Delay .05 + Next lop +End Sub + +Sub showbombblast (screenx, screeny, levelx, levely) ' also cosmetic + For glop = 1 To 3 + For lop = -2 To 2 + For lopp = -2 To 2 + If (Abs(lop) + Abs(lopp) <= 3) Then + Color _RGB(255, 255, 255), _RGB(200, 200, 200) + Locate screeny + lop, screenx + lopp + Select Case glop + Case 1: Print Chr$(178) + Case 2: Print Chr$(177) + Case 3: Print Chr$(176) + End Select + End If + Next lopp + Next lop + _Delay .1 + Next glop +End Sub + +Sub showacidblast (screenx, screeny, levelx, levely) ' also cosmetic + For glop = 1 To 3 + For lop = -2 To 2 + For lopp = -2 To 2 + If (Abs(lop) + Abs(lopp) <= 3) Then + Color _RGB(0, 255, 0), groundcolor~&(levelx + lop, levely + lopp, playerdepth) + Locate screeny + lop, screenx + lopp + Select Case glop + Case 1: Print Chr$(176) + Case 2: Print Chr$(177) + Case 3: Print Chr$(176) + End Select + End If + Next lopp + Next lop + _Delay .1 + Next glop +End Sub + + +Sub showburnblast (screenx, screeny, levelx, levely) ' also cosmetic + For glop = 1 To 5 + For lop = -2 To 2 + For lopp = -2 To 2 + If (Abs(lop) + Abs(lopp) <= 2) Then + Color _RGB(255, 0, 0), groundcolor~&(levelx + lop, levely + lopp, playerdepth) + Locate screeny + lop, screenx + lopp + Select Case Int(Rnd * 4) + Case 0: Print Chr$(200) + Case 1: Print Chr$(201) + Case 2: Print Chr$(187) + Case 3: Print Chr$(188) + End Select + End If + Next lopp + Next lop + _Delay .05 + Next glop +End Sub + +Sub burnblast (screenx, screeny, levelx, levely) ' also cosmetic + For lop = -2 To 2 + For lopp = -2 To 2 + If (Abs(lop) + Abs(lopp) <= 2) Then + Call burnsquare(screenx + lop, screeny + lopp, levelx + lop, levely + lopp) + End If + Next lopp + Next lop +End Sub + +Sub bombblast (screenx, screeny, levelx, levely) ' also cosmetic + For lop = -2 To 2 + For lopp = -2 To 2 + If (Abs(lop) + Abs(lopp) <= 3) Then + Call hammersquare(screenx + lop, screeny + lopp, levelx + lop, levely + lopp) + End If + Next lopp + Next lop +End Sub + +Sub acidblast (screenx, screeny, levelx, levely) ' also cosmetic + For lop = -2 To 2 + For lopp = -2 To 2 + If (Abs(lop) + Abs(lopp) <= 3) Then + Call acidsquare(screenx + lop, screeny + lopp, levelx + lop, levely + lopp) + End If + Next lopp + Next lop +End Sub + + +Sub showhammersquare (screenx, screeny, levelx, levely) ' also cosmetic + Locate screeny, screenx + Color _RGB(128, 128, 128), groundcolor~&(levelx, levely, playerdepth) + Print "+"; + _Delay .15 + Locate screeny, screenx + Print "*"; + _Delay .15 +End Sub + +Sub showslashsquare (screenx, screeny, levelx, levely) ' also cosmetic + Locate screeny, screenx + Color _RGB(228, 228, 228), groundcolor~&(levelx, levely, playerdepth) + Print "/"; + _Delay .15 + Locate screeny, screenx + Print "\"; + _Delay .15 +End Sub + +Sub showplinksquare (screenx, screeny, levelx, levely) ' also cosmetic + Locate screeny, screenx + Color _RGB(150, 50, 0), groundcolor~&(levelx, levely, playerdepth) + Print "*"; + _Delay .15 +End Sub + + + +Sub plinksquare (screenx, screeny, levelx, levely) + target = level(levelx, levely, playerdepth) + Select Case target + Case 10, 11, 12 + Call message("Thwick!") + Case 50, 51, 52 + Call message("Thunk!") + Case 90 + Call bustamphora(levelx, levely, playerdepth) + Case 100 + Call message("The scorpion spirit whiffs out of existence.") + level(levelx, levely, playerdepth) = 0 + Case 101 + Call message("The lost soul becomes enraged.") + level(levelx, levely, playerdepth) = 104 + Case 102 + Call message("The echo serpent is rent.") + level(levelx, levely, playerdepth) = 0 + Case 103 + Call message("The wisp is too quick.") + Case 104 + Call message("The rage soul utters a final scream.") + level(levelx, levely, playerdepth) = 0 + Case 105 + Call message("The spider-shadow vanishes into the stone.") + level(levelx, levely, playerdepth) = 0 + Case 106 + Call message("The psychic fungus is unperturbed.") + Case 800 + Call message("You can do better than that.") + Case Else + End Select +End Sub + + + +Sub slashsquare (screenx, screeny, levelx, levely) + target = level(levelx, levely, playerdepth) + Select Case target + Case 10 + Call message("You reduce the tree to a withered stump.") + level(levelx, levely, playerdepth) = 11 + Case 11 + If secretstairs(levelx, levely, playerdepth) = 1 Then + level(levelx, levely, playerdepth) = 5 + Call message("This tree had deep, secret roots.") + Else + Call message("You destroy the stump.") + level(levelx, levely, playerdepth) = 0 + End If + Case 12 + Call message("The cactus succumbs to the blade.") + level(levelx, levely, playerdepth) = 0 + Case 50 + Call message("Not sharp enough to cut that.") + Case 51 + Call message("That would take all day.") + Case 52 + Call message("Sparks fly as the blade hits the stone.") + Case 90 + Call bustamphora(levelx, levely, playerdepth) + Case 100 + Call message("You sever the scorpion spirit's tether.") + level(levelx, levely, playerdepth) = 0 + Case 101 + Call message("The lost soul becomes enraged.") + level(levelx, levely, playerdepth) = 104 + Case 102 + Call message("The echo serpent is split.") + level(levelx, levely, playerdepth) = 0 + Case 103 + If Int(Rnd * 2) = 1 Then + Call message("The wisp's light is extinguished.") + level(levelx, levely, playerdepth) = 0 + Else + Call message("The wisp evades the blade.") + End If + Case 104 + Call message("The rage soul is calmed.") + level(levelx, levely, playerdepth) = 0 + Case 105 + Call message("The spider-shadow leaves itself behind.") + level(levelx, levely, playerdepth) = 0 + Case 106 + Call message("The psychic fungus immediately refills the void your blade created.") + Case 800 + Call message("You can do better than that.") + Case Else + End Select +End Sub + +Sub hammersquare (screenx, screeny, levelx, levely) + target = level(levelx, levely, playerdepth) + Select Case target + Case 10 + Call message("The tree only shudders defiantly.") + Case 11 + Call message("The stump only becomes harder.") + Case 12 + Call message("The cactus, its grip on the ground tenuous, falls.") + level(levelx, levely, playerdepth) = 0 + Case 50 + If secretstairs(levelx, levely, playerdepth) = 1 Then + level(levelx, levely, playerdepth) = 5 + Call message("The stone had its secrets.") + Else + Call message("The void within the stone is revealed.") + level(levelx, levely, playerdepth) = 0 + End If + Case 51 + Call message("The wall becomes a floor.") + level(levelx, levely, playerdepth) = 0 + Case 52 + If secretstairs(levelx, levely, playerdepth) = 1 Then + level(levelx, levely, playerdepth) = 5 + Call message("It was even deeper than you feared.") + Else + Call message("Reverence is a memory you lack.") + level(levelx, levely, playerdepth) = 0 + End If + feelings(3) = 1 ' Shame unlock + Case 90 + Call bustamphora(levelx, levely, playerdepth) + Case 100 + Call message("The scorpion flattens, dissipates.") + level(levelx, levely, playerdepth) = 0 + Case 101 + Call message("The lost soul becomes enraged.") + level(levelx, levely, playerdepth) = 104 + Case 102 + Call message("The echo serpent uncoils.") + level(levelx, levely, playerdepth) = 0 + Case 103 + If Int(Rnd * 2) = 1 Then + Call message("The wisp's light is snuffed out.") + level(levelx, levely, playerdepth) = 0 + Else + Call message("The wisp evades the hammer.") + End If + Case 104 + Call message("The rage soul is calmed.") + level(levelx, levely, playerdepth) = 0 + Case 105 + Call message("The shadow spider is made even thinner.") + level(levelx, levely, playerdepth) = 0 + Case 106 + Call message("The psychic fungus bounces back.") + Case 800 + If (playerscore >= 100) Then + + Call winscreen + Else + Call message("You cannot destroy yourself until you know yourself.") + End If + Case Else + If levelx = playerx And levely = playery Then + Call message("The impact shakes you.") + Call damageplayer(3, 0) + End If + End Select +End Sub + + +Sub burnsquare (screenx, screeny, levelx, levely) + target = level(levelx, levely, playerdepth) + Select Case target + Case 10 + Call message("The tree becomes coal, then ash.") + level(levelx, levely, playerdepth) = 0 + groundcolor~&(levelx, levely, playerdepth) = groundcolors~&(2) + Case 11 + Call message("The stump becomes ash.") + level(levelx, levely, playerdepth) = 0 + groundcolor~&(levelx, levely, playerdepth) = groundcolors~&(2) + Case 12 + Call message("The cactus wanted water but you gave it fire.") + level(levelx, levely, playerdepth) = 0 + groundcolor~&(levelx, levely, playerdepth) = groundcolors~&(2) + Case 50 + Call message("The stone has seen worse fire than yours.") + Case 51 + Call message("The wall becomes window, then door, then nothing.") + level(levelx, levely, playerdepth) = 0 + groundcolor~&(levelx, levely, playerdepth) = groundcolors~&(2) + Case 90 + Call message("What a waste.") + level(levelx, levely, playerdepth) = 0 + Case 100 + Call message("The scorpion spirit boils away to nothing.") + level(levelx, levely, playerdepth) = 0 + Case 101 + Call message("The lost soul becomes inflamed.") + level(levelx, levely, playerdepth) = 104 + Case 102 + Call message("The echo serpent dissipates.") + level(levelx, levely, playerdepth) = 0 + Case 103 + Call message("The wisp is illuminated.") + level(levelx, levely, playerdepth) = 0 + Case 104 + Call message("The rage soul boils over.") + feelings(2) = 1 ' Anger unlock + level(levelx, levely, playerdepth) = 0 + Case 105 + Call message("The light was stronger than the shadow.") + level(levelx, levely, playerdepth) = 0 + Case 106 + Call message("The fungus screams within you as it burns.") + level(levelx, levely, playerdepth) = 0 + Call damageplayer(1, 0) + Case 800 + Call message("It feels good, but it is ineffective.") + 'this was too powerful + 'CASE 998 + ' CALL message("The water sublimates.") + ' level(levelx, levely, playerdepth) = 0 + ' groundcolor~&(levelx, levely, playerdepth) = defaultgroundcolor~&(playerdepth) + Case Else + If levelx = playerx And levely = playery Then + Call message("The flames dance within you.") + Call damageplayer(3, 0) + End If + End Select + Call displayworld +End Sub + +Sub spritzsquare (screenx, screeny, levelx, levely) + target = level(levelx, levely, playerdepth) + Select Case target + Case 10 + Call message("The tree doesn't need your pity.") + Case 11 + level(levelx, levely, playerdepth) = 10 + Call message("The stump bursts forth with new life.") + Case 12 + Call message("The cactus appreciates your blessing.") + feelings(5) = 1 ' Gratitude unlock + Case 50 + Call message("A tiny amount of erosion occurs.") + Case 51 + Call message("Drops run down the wall.") + Case 52 + Call message("It's too late for a baptism.") + Case 101 + Call message("The lost soul is soothed.") + level(levelx, levely, playerdepth) = 0 + Case 104 + Call message("The rage soul is calmed.") + level(levelx, levely, playerdepth) = 0 + Case 997 + Call message("The lava repents.") + level(levelx, levely, playerdepth) = 0 + Case Else + End Select + Call displayworld +End Sub + +Sub freezesquare (screenx, screeny, levelx, levely) + target = level(levelx, levely, playerdepth) + Select Case target + Case 10 + Call message("The tree stiffens in anger.") + Case 11 + Call message("A rime of frost appears on the stump.") + Case 12 + Call message("That's not really what the cactus had in mind.") + Case 50 + Call message("Cold doesn't bother the stone.") + Case 51 + Call message("The wall is sound enough to keep the cold out.") + + Case 100 + Call message("The scorpion slows, then hardens, then fades.") + level(levelx, levely, playerdepth) = 0 + Case 101 + Call message("The lost soul is soothed by the cold.") + level(levelx, levely, playerdepth) = 0 + Case 102 + Call message("The snake recoils from the cold and vanishes.") + level(levelx, levely, playerdepth) = 0 + Case 103 + Call message("The wisp is not cut out for cold weather.") + level(levelx, levely, playerdepth) = 0 + Case 104 + Call message("The rage soul's ardor is cooled.") + level(levelx, levely, playerdepth) = 0 + Case 105 + Call message("The spider casts no shadow in winter.") + level(levelx, levely, playerdepth) = 0 + Case 106 + Call message("The fungus shrinks away from the cold.") + level(levelx, levely, playerdepth) = 0 + Case 800 + Call message("It can't get any colder.") + Case 997 + Call message("The lava cools and expands.") + level(levelx, levely, playerdepth) = 50 + seed(levelx, levely, 3) = Int(Rnd * 20) + Case 998 + Call message("The water freezes.") + level(levelx, levely, playerdepth) = 0 + seed(levelx, levely, playerdepth) = Int(Rnd * 2) + 81 + groundcolor~&(levelx, levely, playerdepth) = _RGB(100, 255, 255) + Case Else + End Select + Call displayworld +End Sub + + +Sub acidsquare (screenx, screeny, levelx, levely) + target = level(levelx, levely, playerdepth) + Select Case target + Case 10 + Call message("The tree is unimpressed.") + Case 11 + Call message("The stump dissolves.") + level(levelx, levely, playerdepth) = 0 + Case 12 + Call message("The cactus petrifies.") + level(levelx, levely, playerdepth) = 50 + Case 50 + Call message("Idiot patterns are etched into the stone.") + Case 51 + Call message("The wall melts.") + level(levelx, levely, playerdepth) = 0 + Case 100 + Call message("The scorpion spirit dissolves.") + level(levelx, levely, playerdepth) = 0 + Case 101 + Call message("The lost soul is obliterated.") + level(levelx, levely, playerdepth) = 0 + Case 102 + Call message("The echo serpent sizzles and disintegrates.") + level(levelx, levely, playerdepth) = 0 + Case 103 + Call message("The wisp drips away to nothing.") + level(levelx, levely, playerdepth) = 0 + Case 104 + Call message("The rage soul is consumed by its own bile.") + level(levelx, levely, playerdepth) = 0 + Case 105 + Call message("The spider-shadow is etched away.") + level(levelx, levely, playerdepth) = 0 + Case 106 + Call message("The psychic fungus blackens and shrinks.") + level(levelx, levely, playerdepth) = 0 + Case 800 + Call message("You etch an insulting moustache onto the statue.") + End Select + Call displayworld +End Sub + + +Sub bustamphora (x, y, depth) + Call message("The contents spill to meet your needs.") + healthodds = 30 + If (playerhp < 40) Then healthodds = 50 + If (playerhp < 30) Then healthodds = 60 + If (playerhp < 20) Then healthodds = 80 + If (playerhp < 10) Then healthodds = 100 + + manaodds = 50 + If (playermp < 25) Then manaodds = 60 + If (playermp < 20) Then manaodds = 70 + If (playermp < 15) Then manaodds = 80 + If (playermp < 10) Then manaodds = 90 + If (playermp < 5) Then manaodds = 100 + + If Int(Rnd * 100) < healthodds Then + level(x, y, depth) = 2 + ElseIf Int(Rnd * 100) < manaodds Then + level(x, y, depth) = 3 + Else + level(x, y, depth) = 8 ' fall back to knowledge gem + End If +End Sub + +Sub moveenemies + ' move enemies and other autonomous objects near the player + For lop = -15 To 15 + For lopp = -15 To 15 + enemyupdated(lop + 16, lopp + 16) = 0 ' keeping track of whether we've already moved an enemy to a square + Next lopp + Next lop + For lop = -15 To 15 + For lopp = -15 To 15 + If (lop <> 0 Or lopp <> 0) And enemyupdated(lop + 16, lopp + 16) = 0 Then + enemyx = playerx + lop + enemyy = playery + lopp + contents = level(enemyx, enemyy, playerdepth) + movement = 0 + Select Case contents + Case 100 ' ghost scorpion + adj = adjacent(lop, lopp) + If adj Then ' attack if in melee range + Call message("The scorpion spirit still has a sting.") + Call damageplayer(3, 0) + Else ' infinite detection range + If distance(enemyx, enemyy, playerx, playery) < 10 Then movement = 8 ' move randomly + If distance(enemyx, enemyy, playerx, playery) < 5 + difficulty Then movement = 1 ' or seek player if close + groundcolorlimit~& = groundcolors~&(1) + End If + Case 101 ' lost soul + adj = adjacent(lop, lopp) + If adj Then + Call message("The lost soul shares its sorrow.") + Call damageplayer(2, 2) 'lowish damage + soulattacks = soulattacks + 1 + If soulattacks >= 3 Then feelings(6) = 1 ' Melancholy unlock + Else + If distance(enemyx, enemyy, playerx, playery) < 12 Then movement = 9 ' move randomly + If distance(enemyx, enemyy, playerx, playery) < 6 + difficulty Then movement = 2 ' or seek player if close + End If + Case 102 ' snake + adj = adjacent(lop, lopp) + If adj Then ' attack if in melee range + Call message("The echo serpent drains what it can.") + Call damageplayer(3, 0) + Else + If distance(enemyx, enemyy, playerx, playery) < 9 Then movement = 8 ' move randomly sticking to groundcolor + If distance(enemyx, enemyy, playerx, playery) < 5 + difficulty Then movement = 1 ' or seek player if close + groundcolorlimit~& = groundcolors~&(6) + End If + Case 103 ' will-o-the-wisp + adj = adjacent(lop, lopp) + If adj Then ' attack if in melee range + Call message("The wisp is hypnotic.") + Call damageplayer(1, 1) + Else ' always seek player from long range, the forest maze makes this okay + If distance(enemyx, enemyy, playerx, playery) < 14 Then + movement = 1 + groundcolorlimit~& = groundcolors~&(3) + End If + End If + Case 104 ' rage soul + adj = adjacent(lop, lopp) + If adj Then + Call message("The rage soul screams incoherently.") + Call damageplayer(3, 0) + Else ' once it's made, seek the player from infinite range + + movement = 2 ' or seek player if close + End If + Case 105 ' spider + adj = adjacent(lop, lopp) + If adj Then + Call message("The spider-shadow bites.") + Call damageplayer(5, 2) + Else + If distance(enemyx, enemyy, playerx, playery) < 13 Then movement = 9 ' move randomly + If distance(enemyx, enemyy, playerx, playery) < 8 + difficulty Then movement = 2 ' or seek player if close + If distance(enemyx, enemyy, playerx, playery) < 4 Then feelings(1) = 1 ' Fear unlock + End If + Case 106 ' fungus (doesn't care about adjacency, only hurts you if you step through it + If distance(enemyx, enemyy, playerx, playery) < 6 Then movement = 10 ' clone self if you get close + + End Select + If movement = 1 Then ' basic one space toward player on a specific ground color + ' this is done in an extremely stupid (overly deterministic) way because it was done quickly + moved = 0 + If playerx > enemyx And level(enemyx + 1, enemyy, playerdepth) = 0 And groundcolor~&(enemyx + 1, enemyy, playerdepth) = groundcolorlimit~& Then + Call moveenemy(enemyx, enemyy, enemyx + 1, enemyy) + enemyupdated(lop + 16 + 1, lopp + 16) = 1 + moved = 1 + End If + If moved = 0 And playerx < enemyx And level(enemyx - 1, enemyy, playerdepth) = 0 And groundcolor~&(enemyx - 1, enemyy, playerdepth) = groundcolorlimit~& Then + Call moveenemy(enemyx, enemyy, enemyx - 1, enemyy) + enemyupdated(lop + 16 - 1, lopp + 16) = 1 + moved = 1 + End If + If moved = 0 And playery > enemyy And level(enemyx, enemyy + 1, playerdepth) = 0 And groundcolor~&(enemyx, enemyy + 1, playerdepth) = groundcolorlimit~& Then + Call moveenemy(enemyx, enemyy, enemyx, enemyy + 1) + enemyupdated(lop + 16, lopp + 16 + 1) = 1 + moved = 1 + End If + If moved = 0 And playery < enemyy And level(enemyx, enemyy - 1, playerdepth) = 0 And groundcolor~&(enemyx, enemyy - 1, playerdepth) = groundcolorlimit~& Then + Call moveenemy(enemyx, enemyy, enemyx, enemyy - 1) + enemyupdated(lop + 16, lopp + 16 - 1) = 1 + moved = 1 + End If + If moved = 0 Then movement = 8 ' if we didn't succeed, then wander + End If + If movement = 2 Then ' basic one space toward player + moved = 0 + If playerx > enemyx And level(enemyx + 1, enemyy, playerdepth) = 0 Then + Call moveenemy(enemyx, enemyy, enemyx + 1, enemyy) + enemyupdated(lop + 16 + 1, lopp + 16) = 1 + moved = 1 + End If + If moved = 0 And playerx < enemyx And level(enemyx - 1, enemyy, playerdepth) = 0 Then + Call moveenemy(enemyx, enemyy, enemyx - 1, enemyy) + enemyupdated(lop + 16 - 1, lopp + 16) = 1 + moved = 1 + End If + If moved = 0 And playery > enemyy And level(enemyx, enemyy + 1, playerdepth) = 0 Then + Call moveenemy(enemyx, enemyy, enemyx, enemyy + 1) + enemyupdated(lop + 16, lopp + 16 + 1) = 1 + moved = 1 + End If + If moved = 0 And playery < enemyy And level(enemyx, enemyy - 1, playerdepth) = 0 Then + Call moveenemy(enemyx, enemyy, enemyx, enemyy - 1) + enemyupdated(lop + 16, lopp + 16 - 1) = 1 + moved = 1 + End If + If moved = 0 Then movement = 9 ' if we didn't succeed then wander + End If + If movement = 8 Then 'wander randomly limited by groundcolor + tryx = 0: tryy = 0 + If Int(Rnd * 2) = 1 Then + If Int(Rnd * 2) = 1 Then tryx = -1 Else tryx = 1 + Else + If Int(Rnd * 2) = 1 Then tryy = -1 Else tryy = 1 + End If + If level(enemyx + tryx, enemyy + tryy, playerdepth) = 0 And groundcolor~&(enemyx + tryx, enemyy + tryy, playerdepth) = groundcolorlimit~& Then + Call moveenemy(enemyx, enemyy, enemyx + tryx, enemyy + tryy) + enemyupdated(lop + 16 + tryx, lopp + 16 + tryy) = 1 + moved = 1 + End If + End If + If movement = 9 Then 'wander randomly + tryx = 0: tryy = 0 + If Int(Rnd * 2) = 1 Then + If Int(Rnd * 2) = 1 Then tryx = -1 Else tryx = 1 + Else + If Int(Rnd * 2) = 1 Then tryy = -1 Else tryy = 1 + End If + If level(enemyx + tryx, enemyy + tryy, playerdepth) = 0 Then + Call moveenemy(enemyx, enemyy, enemyx + tryx, enemyy + tryy) + enemyupdated(lop + 16 + tryx, lopp + 16 + tryy) = 1 + moved = 1 + End If + End If + If movement = 10 Then ' clone self in a random direction + tryx = 0: tryy = 0 + If Int(Rnd * 2) = 1 Then + If Int(Rnd * 2) = 1 Then tryx = -1 Else tryx = 1 + Else + If Int(Rnd * 2) = 1 Then tryy = -1 Else tryy = 1 + End If + If level(enemyx + tryx, enemyy + tryy, playerdepth) = 0 And (enemyx + tryx <> playerx And enemyy + tryy <> playery) Then + Call cloneenemy(enemyx, enemyy, enemyx + tryx, enemyy + tryy) + enemyupdated(lop + 16 + tryx, lopp + 16 + tryy) = 1 + End If + End If + + End If + Next lopp + Next lop +End Sub + +Sub moveenemy (fromx, fromy, tox, toy) + level(tox, toy, playerdepth) = level(fromx, fromy, playerdepth) + level(fromx, fromy, playerdepth) = 0 + Call displayworld +End Sub + +Sub cloneenemy (fromx, fromy, tox, toy) + level(tox, toy, playerdepth) = level(fromx, fromy, playerdepth) + Call displayworld +End Sub + +Function adjacent (x, y) + adjacent = 0 + If x = -1 And y = 0 Then adjacent = 1 + If x = 1 And y = 0 Then adjacent = 1 + If y = -1 And x = 0 Then adjacent = 1 + If y = 1 And x = 0 Then adjacent = 1 +End Function + +Sub addmp (amount) + Call message("You gain " + Str$(amount) + " Influence.") + playermp = playermp + amount +End Sub + +Sub damageplayer (dmg, mdmg) + Call displayworld + If dmg > 0 And mdmg > 0 Then + flash~& = _RGB(255, 0, 255) + Call message("You lose " + Str$(dmg) + " Coherence and " + Str$(mdmg) + " Influence.") + End If + If dmg > 0 And mdmg = 0 Then + flash~& = _RGB(255, 0, 0) + Call message("You lose " + Str$(dmg) + " Coherence.") + End If + If mdmg > 0 And dmg = 0 Then + flash~& = _RGB(0, 0, 255) + Call message("You lose " + Str$(mdmg) + " Influence.") + End If + For grolp = 1 To 3 + Color flash~& + For lop = 1 To 33 + Locate 1, lop: Print Chr$(219) + Locate 33, lop: Print Chr$(219) + Locate lop, 1: Print Chr$(219) + Locate lop, 33: Print Chr$(219) + Next lop + _Delay .05 + Color _RGB(255, 255, 255) + For lop = 1 To 33 + Locate 1, lop: Print Chr$(219) + Locate 33, lop: Print Chr$(219) + Locate lop, 1: Print Chr$(219) + Locate lop, 33: Print Chr$(219) + Next lop + _Delay .05 + Next grolp + playerhp = playerhp - dmg + playermp = playermp - mdmg + If playermp < 0 Then playermp = 0 + If playerhp < 0 Then playerhp = 0 + Call updateui + If playerhp < 1 Then + For lop = 1 To 10 + Color _RGBA(255, 0, 0, lop * 25) + For lopp = 2 To 32 + For loppp = 2 To 32 + Locate lopp, loppp + Print Chr$(219) + Next loppp + Next lopp + _Delay .3 + Next lop + If permadeath = 2 Then + Call gameoverscreen + Else + Color _RGB(0, 0, 0), _RGB(255, 0, 0) + Locate 17, 10 + Print "Press any key..." + While InKey$ = "": Wend + playerx = 99 + playery = 103 + playerdepth = 1 + level(playerx, playery, 1) = 0 + playerhp = balancevar(10) + playermp = balancevar(11) + Call displayworld + Call updateui + End If + End If +End Sub + +Sub moveplayer (dir$) + While Timer < lastmove + .15: Wend + lastmove = Timer + If debugmovement = 0 Then + checkcollision = 1 + distmoved = 1 + Else ' debugging level gen and such + checkcollision = 0 + distmoved = 5 + End If + drow = 0 + dcol = 0 + Select Case dir$ + Case "up" + drow = -1 + Case "down" + drow = 1 + Case "left" + dcol = -1 + Case "right" + dcol = 1 + End Select + ' check collision here, don't be an idiot + If checkcollision Then + newspace = level(playerx + dcol, playery + drow, playerdepth) + If (newspace > 9 And newspace <> 106) Then ' anything other than blank space probably blocks movement? (fungus and pickups) + drow = 0 + dcol = 0 + Select Case newspace + Case 10 + Call message("The tree forbids you from occupying its space.") + Case 11 + Call message("The stump's despair gives you pause.") + Case 12 + Call message("The cactus wants water, not company.") + Case 50 + Call message("You refuse to be one with the stone.") + Case 51 + Call message("The wood remembers, and does not yield.") + Case 52 + Call message("You're stuck on this side of the grave.") + Case 90 + If groundcolor~&(playerx + dcol, playery + drow, playerdepth) = groundcolors~&(1) Then + Call message("The amphora has been ignoring ghosts for centuries.") + ElseIf groundcolor~&(playerx + dcol, playery + drow, playerdepth) = groundcolors~&(5) Then + Call message("A ceramic vessel. It regards you without comment.") + ElseIf groundcolor~&(playerx + dcol, playery + drow, playerdepth) = groundcolors~&(6) Then + Call message("The cairn is unmoved by your attention.") + Else + Call message("These aren't your bones and they don't care about you.") + End If + Case 100, 101, 102, 103, 104, 105 + Call message("A Coherence collision. It hurts.") + Call damageplayer(5, 0) + Call addmp(3) + Case 800 + Call message("It looks just like you. You hate it.") + Case 997 + Call message("You would boil away to nothing.") + Case 998 + Call message("Fear grips you as you near the water.") + Case 999 + Call message("The void rejects you.") + Case Else + Call message("You cannot move through that.") + End Select + End If + End If + playerx = playerx + (dcol * distmoved) + playery = playery + (drow * distmoved) + moved = 1 + If drow = 0 And dcol = 0 Then moved = 0 + If (playerx < 15) Then playerx = 15 ' just in case something goes super wrong + If (playerx > 285) Then playerx = 285 + If (playery < 15) Then playery = 15 + If (playery > 285) Then playery = 285 + If newspace = 2 Then ' coherence gem + playerhp = playerhp + balancevar(1) + Call message("A cluster of Coherence.") + level(playerx, playery, playerdepth) = 0 + End If + If newspace = 3 Then ' influence gem + playermp = playermp + balancevar(2) + Call message("An accretion of Influence.") + level(playerx, playery, playerdepth) = 0 + End If + If newspace = 7 Then ' knowledge fragment + Call message("A memory is recovered.") + playerscore = playerscore + balancevar(3) + level(playerx, playery, playerdepth) = 0 + End If + If newspace = 8 Then ' knowledge gem + Call message("A tiny, fleeting memory.") + playerscore = playerscore + 1 + level(playerx, playery, playerdepth) = 0 + End If + If newspace = 9 Then ' influence mote + playermp = playermp + 3 + Call message("A mote of loose Influence.") + level(playerx, playery, playerdepth) = 0 + End If + If newspace = 106 Then ' knowledge gem + Call message("The psychic fungus bursts wetly beneath you.") + feelings(4) = 1 ' Disgust unlock + Call damageplayer(difficulty, 0) + level(playerx, playery, playerdepth) = 0 + End If + + If newspace = 4 Then ' new spell! + whichspell = 0 + If (playerdepth = 2) Then + whichspell = 2 ' dagger + If (playerx < 120 And playery < 120) Then whichspell = 1 ' blade under mountains + If (playerx > 150 And playery > 150) Then whichspell = 8 ' acid under town + End If + If (playerdepth = 1 And playerx < 150 And playery > 150) Then + If spells(3) = 0 Then whichspell = 3 Else whichspell = 4 ' candle and fireball in desert + End If + If (playerdepth = 1 And playerx > 150 And playery < 150) Then ' hammer and bomb in forest + If spells(5) = 0 Then whichspell = 5 Else whichspell = 6 + End If + If (playerdepth = 1 And playerx > 150 And playery > 150) Then whichspell = 7 ' holy water in town + If (playerdepth = 3) Then whichspell = 9 ' ice in lava zone + spells(whichspell) = whichspell + If whichspell = 1 Then currentspell = 1 ' autoselect the blade + level(playerx, playery, playerdepth) = 0 + Select Case whichspell + Case 1 + Call message("I remember a sword. I wasn't great with it.") + Case 2 + Call message("A bow. Arrows. Not my cup of tea.") + Case 3 + Call message("There was a candle. I liked it.") + Case 4: + Call message("Fireballs! Those were very good.") + Case 5: + Call message("A hammer. Sometimes the problem was a nail.") + Case 6: + Call message("I had bombs. Crude, but effective.") + Case 7: + Call message("Holy water. More Rebecca's style than mine.") + Case 8: + Call message("I could make clouds of acid. I remember.") + Case 9: + Call message("A freezing beam. I was proud of that.") + End Select + End If + If newspace = 5 Then ' stairs down + If level(playerx, playery, playerdepth + 1) = 6 Then playerdepth = playerdepth + 1 Else Call message("This passage down is blocked.") + If playerdepth = 3 Then feelings(7) = 1 ' Surprise unlock + End If + If newspace = 6 Then ' stairs up + level(playerx, playery, playerdepth - 1) = 5 ' let the player come up through stairs they haven't revealed yet + secretstairs(playerx, playery, playerdepth - 1) = 0 ' prevent scrying weirdness + playerdepth = playerdepth - 1 + End If + Call advanceframe + Call updateui + If moved And playermp = 0 Then + pitymana = pitymana + 1 + If pitymana > 9 Then + Call message("You find a trickle of influence, somewhere deep.") + playermp = 1 + pitymana = 0 + End If + End If + If moved Then Call moveenemies +End Sub + +Sub advanceframe + frame = frame + 1 + If frame = 21 Then frame = 1 +End Sub + +Sub message (k$) + + If k$ = messages$(7) GoTo skipmessage + For lop = 1 To 6 + messages$(lop) = messages$(lop + 1) + Next lop + messages$(7) = k$ + Call updateui + skipmessage: +End Sub + +Function distance (x, y, x2, y2) + distance = Int(Sqr((Abs(x - x2) ^ 2) + (Abs(y - y2) ^ 2))) +End Function + +Sub buildworld + ' set default seeds for random character display + For lop = 1 To 300 + For lopp = 1 To 300 + For lopth = 1 To 3 + level(lop, lopp, lopth) = 0 ' overwrite data from previous game + seed(lop, lopp, lopth) = Int(Rnd * 20) + 1 + groundcolor~&(lop, lopp, lopth) = _RGB(0, 0, 0) + secretstairs(lop, lopp, lopth) = 0 + Next lopth + Next lopp + Next lop + + + For lop = 1 To 300 + For lopp = 1 To 300 + ' depth 1 features + If (distance(lop, lopp, 80, 220) < 50) Or (distance(lop, lopp, 40, 195) < 35) Or (distance(lop, lopp, 100, 260) < 35) Then 'Southwestern desert + seed(lop, lopp, 1) = Int(Rnd * 20) + 20 + If Int(Rnd * 30) = 1 Then level(lop, lopp, 1) = 12 ' sparse cactus + If (Int(Rnd * 300) < difficulty) Then level(lop, lopp, 1) = 100 ' scorpions everywhere + groundcolor~&(lop, lopp, 1) = groundcolors~&(1) + ElseIf distance(lop, lopp, 220, 80) < 52 Or distance(lop, lopp, 200, 30) < 40 Or distance(lop, lopp, 260, 100) < 40 Then ' northeastern forest + groundcolor~&(lop, lopp, 1) = groundcolors~&(3) + If (Int(Rnd * 10) < 3 And level(lop, lopp, 1) = 0) Then level(lop, lopp, 1) = 10 ' random trees, thick enough to be a hassle + If (Int(Rnd * 100) < difficulty + 1 And level(lop, lopp, 1) = 0) Then level(lop, lopp, 1) = 103 ' wisps everywhere + ElseIf (distance(lop, lopp, 80, 80) < 50) Or (distance(lop, lopp, 40, 105) < 35) Or (distance(lop, lopp, 90, 40) < 35) Then 'northwestern mountains + groundcolor~&(lop, lopp, 1) = groundcolors~&(6) + If (Int(Rnd * 100) = 1) Then level(lop, lopp, 1) = 90 ' cairns fairly common in mountains + If (Int(Rnd * 100) < difficulty + 1) And distance(lop, lopp, 100, 100) > 15 Then level(lop, lopp, 1) = 102 ' snakes everywhere + + Else ' any unspecified territory + groundcolor~&(lop, lopp, 1) = groundcolors~&(4) + If (lop < 184 Or lopp < 184) Then ' stuff that's only outside the village + If (Int(Rnd * 20) < 1 And level(lop, lopp, 1) = 0) Then level(lop, lopp, 1) = 10 ' very sparse trees + If (Int(Rnd * 30) < 1 And level(lop, lopp, 1) = 0) Then level(lop, lopp, 1) = 50 ' even sparser rocks + End If + End If + ' depth 2 + If (Int(Rnd * 60) < difficulty) Then level(lop, lopp, 2) = 105 ' spiders + If (Int(Rnd * 50) = 1) Then level(lop, lopp, 2) = 90 ' bone piles underground + level(lop, lopp, 2) = 50 + groundcolor~&(lop, lopp, 2) = _RGB(55, 55, 55) + groundcolor~&(lop, lopp, 3) = _RGB(25, 25, 25) + seed(lop, lopp, 3) = Int(Rnd * 5) + 60 ' for ground effects in deepest level + Next lopp + Next lop + + ' generate the deepths (probably move this to last once we figure out how we're getting down here + For lop = 15 To 285 Step 10 + For lopp = 15 To 285 + ' ancient city walls + If (Int(Rnd * 20) > 1) Then level(lop, lopp, 3) = 50 + If (Int(Rnd * 20) > 1) Then level(lopp, lop, 3) = 50 + seed(lop, lopp, 3) = 0 + seed(lopp, lop, 3) = 0 + Next lopp + Next lop + For lop = 16 To 286 Step 10 + For lopp = 16 To 286 Step 10 + If lop = 146 And lopp = 146 Then + Call stamproom(lop, lopp, 3, "ancient", 30) ' central spell chamber + Else + Call stamproom(lop, lopp, 3, "ancient", 0) + End If + Next lopp + Next lop + lakex = Int(Rnd * 20) + 100 + lakey = Int(Rnd * 20) + 200 + Call stampcircle(lakex, lakey, 3, Int(Rnd * 5) + 5, "lava", 1) + Call longriver(lakex, lakey, 3, 2, -1, 0, "lava") + Call longriver(lakex, lakey, 3, 2, 1, 0, "lava") + Call longriver(lakex, lakey, 3, 2, 0, -1, "lava") + Call longriver(lakex, lakey, 3, 2, 0, 1, "lava") + lakex = 200 + Int(Rnd * 20) + lakey = 100 + Int(Rnd * 20) + Call stampcircle(lakex, lakey, 3, Int(Rnd * 5) + 5, "lava", 1) + Call longriver(lakex, lakey, 3, 2, -1, 0, "lava") + Call longriver(lakex, lakey, 3, 2, 1, 0, "lava") + Call longriver(lakex, lakey, 3, 2, 0, -1, "lava") + Call longriver(lakex, lakey, 3, 2, 0, 1, "lava") + + ' generate mountain area + For lop = 5 To 185 Step 10 + For lopp = 5 To 185 Step 10 + If groundcolor~&(lop + 9, lopp + 9, 1) = groundcolors~&(6) Then + Call stamproom(lop + 1, lopp + 1, 1, "mountain", 0) + End If + Next lopp + Next lop + Call stamproom(95, 95, 1, "mountain", 30) ' starting tile + ' extremely sparse trees in mountains + For lop = 1 To 200 + For lopp = 1 To 200 + If groundcolor~&(lop, lopp, 1) = groundcolors~&(6) And Int(Rnd * 30) = 1 And level(lop, lopp, 1) = 0 Then level(lop, lopp, 1) = 10 + Next lopp + Next lop + + ' initial population of caves + For lop = 15 To 285 Step 10 + For lopp = 15 To 285 Step 10 + Call stamproom(lop, lopp, 2, "cave", 0) ' stamp random cavern tiles + Next lopp + Next lop + Call stamproom(95, 95, 2, "cave", 30) ' cave beneath starting area + + ' giant central lake + Call stampcircle(150, 150, 1, Int(Rnd * 5) + 10, "water", 1) + Call stampcircle(140, 150, 1, 4 + Int(Rnd * 3), "water", 0) + Call stampcircle(150, 140, 1, 4 + Int(Rnd * 3), "water", 0) + Call stampcircle(160, 150, 1, 4 + Int(Rnd * 3), "water", 0) + Call stampcircle(150, 160, 1, 4 + Int(Rnd * 3), "water", 0) + Call stampcircle(142, 142, 1, 4 + Int(Rnd * 3), "water", 0) + Call stampcircle(142, 158, 1, 4 + Int(Rnd * 3), "water", 0) + Call stampcircle(158, 142, 1, 4 + Int(Rnd * 3), "water", 0) + Call stampcircle(158, 142, 1, 4 + Int(Rnd * 3), "water", 0) + + 'radiating rivers + width1 = Int(Rnd * 2) + 2 + Call longriver(150, 150, 1, width1, 0, 1, "water") + Call longriver(150, 150, 1, 6 - width1, 0, -1, "water") + width1 = Int(Rnd * 2) + 2 + Call longriver(150, 150, 1, width1, 1, 0, "water") + Call longriver(150, 150, 1, 6 - width1, -1, 0, "water") + + ' central island, endgame altar + Call stampcircle(150, 150, 1, 5, "land", 1) + level(150, 150, 1) = 800 + 'northeastern forest + For lop = 165 To 285 Step 10 + For lopp = 15 To 145 Step 10 + If groundcolor~&(lop, lopp, 1) = groundcolors~&(3) Then Call stamproom(lop, lopp - 10, 1, "forest", 0) + Next lopp + Next lop + ' forest spell shrines + Call stamproom(185 + Int(Rnd * 3) + 10, 35 + Int(Rnd * 3) + 10, 1, "forest", 30) + Call stamproom(245 + Int(Rnd * 2) + 10, 85 + Int(Rnd * 4) + 10, 1, "forest", 30) + + ' roads + leftedge = 80 + rightedge = 224 + topedge = 80 + bottomedge = 224 + For lop = leftedge - 10 - Int(Rnd * 20) To rightedge + 10 + Int(Rnd * 20) + Call stampmaterial(lop, topedge, 1, "road") + Call stampmaterial(lop, topedge + 1, 1, "road") + Next lop + For lop = leftedge - 10 - Int(Rnd * 20) To rightedge + 10 + Int(Rnd * 20) + Call stampmaterial(lop, bottomedge, 1, "road") + Call stampmaterial(lop, bottomedge + 1, 1, "road") + Next lop + For lop = topedge - 10 - Int(Rnd * 20) To bottomedge + 10 + Int(Rnd * 20) + Call stampmaterial(leftedge, lop, 1, "road") + Call stampmaterial(leftedge + 1, lop, 1, "road") + Next lop + For lop = topedge - 10 - Int(Rnd * 20) To bottomedge + 10 + Int(Rnd * 20) + Call stampmaterial(rightedge, lop, 1, "road") + Call stampmaterial(rightedge + 1, lop, 1, "road") + Next lop + + + 'southwestern desert ruins + For lop = 6 To 206 Step 10 + For lopp = 156 To 286 Step 10 + If distance(lop, lopp, 1, 300) < 130 And lop <> 76 Then + If (Int(Rnd * 5) = 1) Then Call stamproom(lop, lopp, 1, "desert", 0) + End If + Next lopp + Next lop + ' desert spell shrines + Call stamproom(86 + (Int(Rnd * 2) * 10), 236 + (Int(Rnd * 2) * 10), 1, "desert", 30) + Call stamproom(36 + (Int(Rnd * 2) * 10), 186 + (Int(Rnd * 2) * 10), 1, "desert", 30) + ' dagger room + lop = 86 + (Int(Rnd * 3) * 10) + lopp = 186 + (Int(Rnd * 3) * 10) + Call stamproom(lop, lopp, 1, "desert", 31) ' dagger pyramid + Call stamproom(lop, lopp, 2, "desert", 32) ' beneath dagger pyramid + + 'secret staircases + For lop = 1 To 20 + placed = 0 + While placed = 0 + testx = Int(Rnd * 150) + 75 + testy = Int(Rnd * 150) + 75 + If level(testx, testy, 1) = 0 And groundcolor~&(testx, testy, 1) = groundcolors~&(4) Then + placed = 1 + 'level(testx, testy - 1, 1) = 400 + If Int(Rnd * 2) = 1 Then level(testx, testy, 1) = 10 Else level(testx, testy, 1) = 50 'stairs hidden in a rock or a tree + secretstairs(testx, testy, 1) = 1 + circsize = 4 + Int(Rnd * 2) + Call stampcircle(testx, testy, 2, circsize + 2, "rock", 1) + Call stampcircle(testx, testy, 2, circsize, "emptycave", 1) + level(testx, testy, 2) = 6 + xoff = Int(Rnd * 2) + 1 + yoff = Int(Rnd * 2) + 1 + If (Int(Rnd * 2) = 1) Then xoff = -xoff + If (Int(Rnd * 2) = 1) Then yoff = -yoff + level(testx + xoff, testy + yoff, 2) = 7 ' hide those memories + End If + Wend + Next lop + + + ' southeastern village roads + For lop = 184 To 284 Step 10 ' horizontal roads + offset = Int((284 - lop) / 5) + leftend = 174 + offset - Int(Rnd * 8) + For lopp = leftend To 284 + Call stampmaterial(lopp, lop, 1, "road") + Call stampmaterial(lopp, lop + 1, 1, "road") + Next lopp + Next lop + For lop = 184 To 284 Step 10 ' vertical roads + offset = Int((284 - lop) / 5) + topend = 174 + offset - Int(Rnd * 8) + For lopp = topend To 284 + Call stampmaterial(lop, lopp, 1, "road") + Call stampmaterial(lop + 1, lopp, 1, "road") + Next lopp + Next lop + + 'southeastern village buildings + For lop = 186 To 286 Step 10 + For lopp = 186 To 286 Step 10 + chance = distance(lop, lopp, 240, 240) + If (chance < 40 + Int(Rnd * 50)) Then + Call stamproom(lop, lopp, 1, "town", 0) ' stamp random town rooms + End If + Next lopp + Next lop + For lop = 216 To 234 + For lopp = 216 To 234 + groundcolor~&(lop, lopp, 1) = groundcolors~&(4) + seed(lop, lopp, 1) = 1 + Next lopp + Next lop + + Call stamproom(216, 216, 1, "special", 1) 'cathedral + Call stamproom(216, 216, 2, "special", 2) 'crypt + secretstairs(230, 217, 1) = 1 ' tombstone + + spotx = 196 + Int(Rnd * 3) * 10 + spoty = 196 + Int(Rnd * 2) * 10 + Call stamproom(spotx, spoty, 1, "town", 30) ' house with basement + Call stamproom(spotx, spoty, 2, "town", 31) ' and the basement + + ' debug nonsense + 'level(95, 95, 1) = 7 'scorpion + 'level(215, 212, 1) = 3 'scorpion + 'level(250, 100, 1) = 103 + + + ' slice off the outside edges with Void Space + ' shrink in as you go further down + For lop = 1 To 300 + For lopp = 1 To 300 + For lopth = 1 To 3 + dist = Int(Sqr((Abs(lop - 150) ^ 2) + (Abs(lopp - 150) ^ 2))) + thresh = 130 + Int(Rnd * 5) + If lopth = 2 Then thresh = 110 + Int(Rnd * 5) + If lopth = 3 Then thresh = 90 + Int(Rnd * 5) + If (dist > thresh) Then level(lop, lopp, lopth) = 999 + If (dist > thresh) Then groundcolor~&(lop, lopp, lopth) = _RGB(0, 0, 0) + Next lopth + Next lopp + Next lop + + placedstairs = 0 ' place stairways from cave level to ancient ruins level + While placedstairs < 11 + lop = Int(Rnd * 260) + 20 + lopp = Int(Rnd * 260) + 20 + ringu = distance(lop, lopp, 150, 150) + If ringu > 80 And ringu < 90 And (lop < 130 Or lopp < 130) And (lop < 130 Or lop > 170) And (lopp < 130 Or lopp > 170) Then + placedstairs = placedstairs + 1 + Call stampcircle(lop, lopp, 2, 4, "rock", 0) + Call stampcircle(lop, lopp, 2, 3, "emptycave", 1) + level(lop, lopp, 2) = 5 + Call stampcircle(lop, lopp, 3, 4, "emptyspace", 1) + level(lop, lopp, 3) = 6 + For gorp = 1 To 8 + xoff = Int(Rnd * 5) - 2 + yoff = Int(Rnd * 5) - 2 + If xoff <> 0 And yoff <> 0 Then + level(lop + xoff, lopp + yoff, 3) = 50 ' drop rubble around the stairs + seed(lop + xoff, lopp + yoff, 3) = Int(Rnd * 20) + 1 ' make it normal rock if it hits clean ruin rock + End If + Next gorp + End If + Wend + + ' clear area around player + For lop = -2 To 2 + For lopp = -2 To 2 + level(playerx + lop, playery + lopp, 1) = 0 + 'groundcolor~&(playerx + lop, playery + lopp, 1) = _RGB(166, 116, 0) + Next lopp + Next lop + + +End Sub + +Sub longriver (x, y, depth, riverwidth, xdir, ydir, material$) + wobble = 0 + xpos = x + ypos = y + While xpos > 10 And xpos < 290 And ypos > 10 And ypos < 290 + Call stampmaterial(xpos, ypos, depth, material$) + If (riverwidth > 1) Then + If xdir = 0 Then Call stampmaterial(xpos - 1, ypos, depth, material$) Else Call stampmaterial(xpos, ypos - 1, depth, material$) + End If + If (riverwidth > 2) Then + If xdir = 0 Then Call stampmaterial(xpos + 1, ypos, depth, material$) Else Call stampmaterial(xpos, ypos + 1, depth, material$) + End If + If (riverwidth > 3) Then + If xdir = 0 Then Call stampmaterial(xpos - 2, ypos, depth, material$) Else Call stampmaterial(xpos, ypos - 2, depth, material$) + End If + If (riverwidth > 4) Then + If xdir = 0 Then Call stampmaterial(xpos + 2, ypos, depth, material$) Else Call stampmaterial(xpos, ypos + 2, depth, material$) + End If + Call stampmaterial(xpos, ypos, depth, material$) + xpos = xpos + xdir + ypos = ypos + ydir + wobble = wobble + 1 + If (wobble > Int(Rnd * 3) + 3) Then + wobble = 0 + If ydir = 0 Then + If Int(Rnd * 2) = 1 Then ypos = ypos + 1 Else ypos = ypos - 1 + End If + If xdir = 0 Then + If Int(Rnd * 2) = 1 Then xpos = xpos + 1 Else xpos = xpos - 1 + End If + End If + Wend +End Sub + +Sub stampmaterial (x, y, depth, material$) + Select Case material$ + Case "emptycave" + level(x, y, depth) = 0 + Case "land" + level(x, y, depth) = 0 + groundcolor~&(x, y, depth) = defaultgroundcolor~&(depth) + Case "water" + level(x, y, depth) = 998 + groundcolor~&(x, y, depth) = _RGB(0, 0, 255) + Case "rock" + level(x, y, depth) = 50 + Case "lava" + level(x, y, depth) = 997 + Case "road" + If (level(x, y, depth) = 998) Then + level(x, y, depth) = 0 + seed(x, y, depth) = 51 + Else + groundcolor~&(x, y, depth) = _RGB(126, 81, 9) + level(x, y, depth) = 0 + seed(x, y, depth) = Int(Rnd * 7) + 52 + End If + End Select +End Sub + +Sub stampcircle (x, y, depth, radius, material$, messy) + For lop = -radius To radius + For lopp = -radius To radius + xpos = x + lop + ypos = y + lopp + dist = Int(Sqr((Abs(xpos - x) ^ 2) + (Abs(ypos - y) ^ 2))) + thresh = radius + If messy And Int(Rnd * 2) = 1 Then thresh = radius - 1 + If dist < thresh Then + Call stampmaterial(xpos, ypos, depth, material$) + End If + Next lopp + Next lop +End Sub + + +Sub initialize + playerx = 99 + playery = 103 + playerhp = balancevar(10) + playermp = balancevar(11) + playerdepth = 1 + For lop = 1 To 9 + spells(lop) = 0 + feelings(lop) = 0 + Next lop + gameover = 0 + exiting = 0 + currentspell = 0 + ' spelldata + spellnames$(1) = "Sword" + spellcosts(1) = 1 + spellnames$(2) = "Bow" + spellcosts(2) = 1 + spellnames$(3) = "Candle" + spellcosts(3) = 3 + If difficulty = 1 Then spellcosts(3) = 2 + spellnames$(4) = "Fireball" + spellcosts(4) = 5 + If difficulty = 1 Then spellcosts(4) = 3 + spellnames$(5) = "Hammer" + spellcosts(5) = 3 + If difficulty = 1 Then spellcosts(5) = 2 + spellnames$(6) = "Bomb" + spellcosts(6) = 5 + If difficulty = 1 Then spellcosts(6) = 3 + spellnames$(7) = "Holy Water" + spellcosts(7) = 1 + spellnames$(8) = "Acid" + spellcosts(8) = 3 + If difficulty = 1 Then spellcosts(8) = 2 + spellnames$(9) = "Ice" + spellcosts(9) = 3 + pitymana = 0 + + ' default ground colors for things left behind + defaultgroundcolor~&(1) = _RGB(166, 116, 0) + groundcolors~&(1) = _RGB(214, 212, 68) ' desert + groundcolors~&(2) = _RGB(99, 99, 99) ' ash + groundcolors~&(3) = _RGB(17, 120, 100) ' forest + groundcolors~&(4) = _RGB(39, 174, 96) ' riverbank/town + groundcolors~&(5) = _RGB(220, 154, 130) ' house floor + groundcolors~&(6) = _RGB(154, 125, 10) ' mountain ground + +End Sub +Function balancevar (x) + If x = 1 Then balancevar = 3 ' coherence gem + If x = 2 Then balancevar = 10 ' influence gem + If x = 3 Then balancevar = 10 ' recovered memory + If x = 10 Then balancevar = 70 - (difficulty * 10) ' starting HP + If x = 11 Then balancevar = 60 - (difficulty * 10) ' starting MP +End Function + +Sub stamproom (x, y, depth, type$, which) + Dim townrooms$(40, 8) + townrooms$(0, 1) = "........" + townrooms$(0, 2) = "........" + townrooms$(0, 3) = "........" + townrooms$(0, 4) = "........" + townrooms$(0, 5) = "........" + townrooms$(0, 6) = "........" + townrooms$(0, 7) = "........" + townrooms$(0, 8) = "........" + townrooms$(1, 1) = "SSSSSsSS" + townrooms$(1, 2) = "SttttttS" + townrooms$(1, 3) = "st.tt.tS" + townrooms$(1, 4) = "St....tS" + townrooms$(1, 5) = "SttO.ttS" + townrooms$(1, 6) = "st....ts" + townrooms$(1, 7) = "Stt..ttS" + townrooms$(1, 8) = "SSs..sSS" + townrooms$(2, 1) = "........" + townrooms$(2, 2) = ".WWWWWW." + townrooms$(2, 3) = ".W,,,,W." + townrooms$(2, 4) = ".W,l,,W." + townrooms$(2, 5) = ".WWWWWW." + townrooms$(2, 6) = "....O..." + townrooms$(2, 7) = ".t....t." + townrooms$(2, 8) = "..t..t.." + townrooms$(3, 1) = "WWWW.tt." + townrooms$(3, 2) = "W,pW.tt." + townrooms$(3, 3) = "Wl,W...." + townrooms$(3, 4) = "WWWW.WWW" + townrooms$(3, 5) = ".....WlW" + townrooms$(3, 6) = ".t.WWW,W" + townrooms$(3, 7) = ".t.W,ppW" + townrooms$(3, 8) = "...WWWWW" + townrooms$(4, 1) = "WWWWWWWW" + townrooms$(4, 2) = "W,,,P,,W" + townrooms$(4, 3) = "W,,,,,,W" + townrooms$(4, 4) = "WW,WWWWW" + townrooms$(4, 5) = "W,,,W..." + townrooms$(4, 6) = "W,l,W..." + townrooms$(4, 7) = "Wp,,W..." + townrooms$(4, 8) = "WWWWW..." + townrooms$(5, 1) = "WWWWWWWW" + townrooms$(5, 2) = "Wl,,,,pW" + townrooms$(5, 3) = "W,,W,,,W" + townrooms$(5, 4) = "WWWW,,,W" + townrooms$(5, 5) = "W,,,,,,W" + townrooms$(5, 6) = "W,,W,lpW" + townrooms$(5, 7) = "WWWWWWWW" + townrooms$(5, 8) = "........" + townrooms$(6, 1) = "........" + townrooms$(6, 2) = "WWWWWWWW" + townrooms$(6, 3) = "W,,P,,,W" + townrooms$(6, 4) = "W,,,l,,W" + townrooms$(6, 5) = "WWWWWWWW" + townrooms$(6, 6) = "..T..T.." + townrooms$(6, 7) = "..T..T.." + townrooms$(6, 8) = "..T..T.." + townrooms$(7, 1) = "SSSSSSSS" + townrooms$(7, 2) = "SP,,,,PS" + townrooms$(7, 3) = "S,,O,,,S" + townrooms$(7, 4) = "SP,,O,PS" + townrooms$(7, 5) = "SSSSSSSS" + townrooms$(7, 6) = "..S..S.." + townrooms$(7, 7) = "........" + townrooms$(7, 8) = "..S..S.." + + townrooms$(30, 1) = "WWWWWWWW" ' basement house + townrooms$(30, 2) = "W,,,,,>W" + townrooms$(30, 3) = "W,,WWWWW" + townrooms$(30, 4) = "W,,W...." + townrooms$(30, 5) = "WW,W.TT." + townrooms$(30, 6) = "W,,W.TT." + townrooms$(30, 7) = "W,,W...." + townrooms$(30, 8) = "WWWW...." + townrooms$(31, 1) = "SSSSSSSS" ' under it + townrooms$(31, 2) = "S..... 0 Then forcemode = 1 ' don't rotate prefab bits + If which = 0 Then which = Int(Rnd * 7) + 1 + mode = Int(Rnd * 8) + 1 ' which rotation + If forcemode = 1 Then mode = 1 + For lop = 1 To 8 + For lopp = 1 To 8 + If mode = 1 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(townrooms$(which, lop), lopp, 1)) + If mode = 2 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(townrooms$(which, 9 - lop), lopp, 1)) + If mode = 3 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(townrooms$(which, lop), 9 - lopp, 1)) + If mode = 4 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(townrooms$(which, 9 - lop), 9 - lopp, 1)) + If mode = 5 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(townrooms$(which, lopp), lop, 1)) + If mode = 6 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(townrooms$(which, 9 - lopp), lop, 1)) + If mode = 7 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(townrooms$(which, lopp), 9 - lop, 1)) + If mode = 8 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(townrooms$(which, 9 - lopp), 9 - lop, 1)) + Next lopp + Next lop + End If + + Dim desertrooms$(40, 9) + desertrooms$(0, 1) = "........." + desertrooms$(0, 2) = "........." + desertrooms$(0, 3) = "........." + desertrooms$(0, 4) = "........." + desertrooms$(0, 5) = "........." + desertrooms$(0, 6) = "........." + desertrooms$(0, 7) = "........." + desertrooms$(0, 8) = "........." + desertrooms$(0, 9) = "........." + + desertrooms$(1, 1) = "..k...k.." + desertrooms$(1, 2) = ".SSssssSa" + desertrooms$(1, 3) = ".S......." + desertrooms$(1, 4) = "ks....k.." + desertrooms$(1, 5) = ".sa......" + desertrooms$(1, 6) = ".s......." + desertrooms$(1, 7) = "kS..k...." + desertrooms$(1, 8) = ".S......." + desertrooms$(1, 9) = "........." + + desertrooms$(2, 1) = ".s..s...." + desertrooms$(2, 2) = "......k.." + desertrooms$(2, 3) = ".SSSS...." + desertrooms$(2, 4) = ".SAAS..k." + desertrooms$(2, 5) = ".S..S...." + desertrooms$(2, 6) = ".SssS.k.." + desertrooms$(2, 7) = "........." + desertrooms$(2, 8) = ".s..s..k." + desertrooms$(2, 9) = "........." + + desertrooms$(3, 1) = "SSSSSSSSS" + desertrooms$(3, 2) = "S..k....S" + desertrooms$(3, 3) = "S.SSSSS.S" + desertrooms$(3, 4) = "S.SaaaS.S" + desertrooms$(3, 5) = "SkSaaas.S" + desertrooms$(3, 6) = "S.SaaaSkS" + desertrooms$(3, 7) = "S.SSSSS.S" + desertrooms$(3, 8) = "S...k...S" + desertrooms$(3, 9) = "SSSSSSSSS" + + desertrooms$(4, 1) = ".......c." + desertrooms$(4, 2) = "....cc.k." + desertrooms$(4, 3) = ".cc......" + desertrooms$(4, 4) = "k.sSSSSs." + desertrooms$(4, 5) = "..sSSSSs." + desertrooms$(4, 6) = "...aAa..." + desertrooms$(4, 7) = ".......c." + desertrooms$(4, 8) = "..c.k.c.." + desertrooms$(4, 9) = ".c......." + + desertrooms$(5, 1) = "...s...cc" + desertrooms$(5, 2) = "..s....cc" + desertrooms$(5, 3) = "...s....." + desertrooms$(5, 4) = ".k..sa..." + desertrooms$(5, 5) = ".....s..." + desertrooms$(5, 6) = "..c.k.s.s" + desertrooms$(5, 7) = ".c.c...s." + desertrooms$(5, 8) = "..c......" + desertrooms$(5, 9) = ".....k..." + + + desertrooms$(30, 1) = ".cSSSSSc." + desertrooms$(30, 2) = "c.S.!.S.c" + desertrooms$(30, 3) = ".k...cck." + desertrooms$(30, 4) = "..S...Sc." + desertrooms$(30, 5) = ".c..cc..." + desertrooms$(30, 6) = "..S.c.S.c" + desertrooms$(30, 7) = ".k..cc.k." + desertrooms$(30, 8) = "..S...S.." + desertrooms$(30, 9) = "c...cc..c" + + desertrooms$(31, 1) = "..cccc..." + desertrooms$(31, 2) = ".cc..cc.." + desertrooms$(31, 3) = ".c.S.Scc." + desertrooms$(31, 4) = ".cSS>SSc." + desertrooms$(31, 5) = "cc.SSScc." + desertrooms$(31, 6) = ".c..S.c.." + desertrooms$(31, 7) = "..cc...c." + desertrooms$(31, 8) = "..c.cc.c." + desertrooms$(31, 9) = "........." + + desertrooms$(32, 1) = "SSSS.SSSS" + desertrooms$(32, 2) = "SSS...SSS" + desertrooms$(32, 3) = "SS.....SS" + desertrooms$(32, 4) = "S...<...S" + desertrooms$(32, 5) = "SS.....SS" + desertrooms$(32, 6) = "SSS.!.SSS" + desertrooms$(32, 7) = "SSSS.SSSS" + desertrooms$(32, 8) = "SSSSSSSSS" + desertrooms$(32, 9) = "........." + + If type$ = "desert" Then + forcemode = 0 + If which > 0 Then forcemode = 1 ' don't rotate prefab bits + If which = 0 Then which = Int(Rnd * 5) + 1 + mode = Int(Rnd * 8) + 1 ' which rotation + If forcemode = 1 Then mode = 1 + For lop = 1 To 9 + For lopp = 1 To 9 + If mode = 1 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(desertrooms$(which, lop), lopp, 1)) + If mode = 2 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(desertrooms$(which, 10 - lop), lopp, 1)) + If mode = 3 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(desertrooms$(which, lop), 10 - lopp, 1)) + If mode = 4 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(desertrooms$(which, 10 - lop), 10 - lopp, 1)) + If mode = 5 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(desertrooms$(which, lopp), lop, 1)) + If mode = 6 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(desertrooms$(which, 10 - lopp), lop, 1)) + If mode = 7 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(desertrooms$(which, lopp), 10 - lop, 1)) + If mode = 8 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(desertrooms$(which, 10 - lopp), 10 - lop, 1)) + Next lopp + Next lop + End If + + Dim caverooms$(40, 10) + caverooms$(0, 1) = ".........." + caverooms$(0, 2) = ".........." + caverooms$(0, 3) = ".........." + caverooms$(0, 4) = ".........." + caverooms$(0, 5) = ".........." + caverooms$(0, 6) = ".........." + caverooms$(0, 7) = ".........." + caverooms$(0, 8) = ".........." + caverooms$(0, 9) = ".........." + caverooms$(0, 10) = ".........." + + caverooms$(1, 1) = "SSSS...SSS" + caverooms$(1, 2) = "SS......SS" + caverooms$(1, 3) = "S........S" + caverooms$(1, 4) = ".........S" + caverooms$(1, 5) = ".........." + caverooms$(1, 6) = ".........." + caverooms$(1, 7) = ".........S" + caverooms$(1, 8) = "SS.......S" + caverooms$(1, 9) = "SS......SS" + caverooms$(1, 10) = "SSS....SSS" + + caverooms$(2, 1) = "SSSSSSSSSS" + caverooms$(2, 2) = "SSSSSSSSSS" + caverooms$(2, 3) = "SSSSSSSSSS" + caverooms$(2, 4) = "sSSSSSSSs." + caverooms$(2, 5) = "...sSs...." + caverooms$(2, 6) = ".........s" + caverooms$(2, 7) = "SSS...sSSS" + caverooms$(2, 8) = "SSSSSSSSSS" + caverooms$(2, 9) = "SSSSSSSSSS" + caverooms$(2, 10) = "SSSSSSSSSS" + + caverooms$(3, 1) = "SSSSSSSSSS" + caverooms$(3, 2) = "SSSSSSSSSS" + caverooms$(3, 3) = "SSSSSSSSSS" + caverooms$(3, 4) = "SSSs...SsS" + caverooms$(3, 5) = "Ss......SS" + caverooms$(3, 6) = "S........S" + caverooms$(3, 7) = "Ss.......S" + caverooms$(3, 8) = "SS......sS" + caverooms$(3, 9) = "SSSs...sSS" + caverooms$(3, 10) = "SSSS.sSSSS" + + caverooms$(4, 1) = "SSSS..SSSS" + caverooms$(4, 2) = "SSSs..sSSS" + caverooms$(4, 3) = "SSS....SSS" + caverooms$(4, 4) = "SSs.ss.sSS" + caverooms$(4, 5) = ".........." + caverooms$(4, 6) = "....ss...." + caverooms$(4, 7) = "SSSSSSSSSS" + caverooms$(4, 8) = "SSSSSSSSSS" + caverooms$(4, 9) = "SSSSSSSSSS" + caverooms$(4, 10) = "SSSSSSSSSS" + + caverooms$(5, 1) = "SSSSSSSSSS" + caverooms$(5, 2) = "SSSSSsSSSS" + caverooms$(5, 3) = "SSSSSSSSSS" + caverooms$(5, 4) = "SSSSSSSSSS" + caverooms$(5, 5) = "SSsSSSSsSS" + caverooms$(5, 6) = "SSSSSSSSSS" + caverooms$(5, 7) = "SSSSSSSSsS" + caverooms$(5, 8) = "SSSSSSSSSS" + caverooms$(5, 9) = "SSSssssSSS" + caverooms$(5, 10) = "SSs....sSS" + + caverooms$(6, 1) = "SSSS.SSSSS" + caverooms$(6, 2) = "SSSS.SSSSS" + caverooms$(6, 3) = "SSSS..SSSS" + caverooms$(6, 4) = "SSSSS..SSS" + caverooms$(6, 5) = "sSSSSS...." + caverooms$(6, 6) = "sssssSSSSS" + caverooms$(6, 7) = "S...sSSSSS" + caverooms$(6, 8) = "S...sSSSSS" + caverooms$(6, 9) = "Ss..sSSSSS" + caverooms$(6, 10) = "SSSSSSSSSS" + + caverooms$(7, 1) = "SSSS.SSSSS" + caverooms$(7, 2) = "SSSS.SSSSS" + caverooms$(7, 3) = "SSSs.SSSSS" + caverooms$(7, 4) = "SSss.sSSSS" + caverooms$(7, 5) = ".....ssSSS" + caverooms$(7, 6) = "SSSs......" + caverooms$(7, 7) = "SSSss.ssSS" + caverooms$(7, 8) = "SSSSS.sSSS" + caverooms$(7, 9) = "SSSSS.SSSS" + caverooms$(7, 10) = "SSSSS.SSSS" + + + caverooms$(30, 1) = "SSSSSSSSSS" + caverooms$(30, 2) = "SSSSSSSSSS" + caverooms$(30, 3) = "SSSs:::sSS" + caverooms$(30, 4) = "SSs::!:sSS" + caverooms$(30, 5) = "SS::::::SS" + caverooms$(30, 6) = "SS::<:::SS" + caverooms$(30, 7) = "SSs::::sSS" + caverooms$(30, 8) = "SSSs::sSSS" + caverooms$(30, 9) = "SSSSSSSSSS" + caverooms$(30, 10) = "SSSSSSSSSS" + + + If type$ = "cave" Then + forcemode = 0 + If which > 0 Then forcemode = 1 ' don't rotate prefab bits + If which = 0 Then which = Int(Rnd * 7) + 1 + mode = Int(Rnd * 8) + 1 ' which rotation + If forcemode = 1 Then mode = 1 + For lop = 1 To 10 + For lopp = 1 To 10 + If mode = 1 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(caverooms$(which, lop), lopp, 1)) + If mode = 2 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(caverooms$(which, 11 - lop), lopp, 1)) + If mode = 3 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(caverooms$(which, lop), 11 - lopp, 1)) + If mode = 4 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(caverooms$(which, 11 - lop), 11 - lopp, 1)) + If mode = 5 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(caverooms$(which, lopp), lop, 1)) + If mode = 6 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(caverooms$(which, 11 - lopp), lop, 1)) + If mode = 7 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(caverooms$(which, lopp), 11 - lop, 1)) + If mode = 8 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(caverooms$(which, 11 - lopp), 11 - lop, 1)) + Next lopp + Next lop + End If + + Dim mountainrooms$(40, 9) + mountainrooms$(0, 1) = "........." + mountainrooms$(0, 2) = "........." + mountainrooms$(0, 3) = "........." + mountainrooms$(0, 4) = "........." + mountainrooms$(0, 5) = "........." + mountainrooms$(0, 6) = "........." + mountainrooms$(0, 7) = "........." + mountainrooms$(0, 8) = "........." + mountainrooms$(0, 9) = "........." + mountainrooms$(1, 1) = "........." + mountainrooms$(1, 2) = "..ss....." + mountainrooms$(1, 3) = ".sSSs...." + mountainrooms$(1, 4) = ".sSSs...." + mountainrooms$(1, 5) = "..ss....." + mountainrooms$(1, 6) = ".....ss.." + mountainrooms$(1, 7) = "....sSSs." + mountainrooms$(1, 8) = "....sSSs." + mountainrooms$(1, 9) = ".....ss.." + mountainrooms$(2, 1) = ".ssss...." + mountainrooms$(2, 2) = "sSSSSs..." + mountainrooms$(2, 3) = "sSSSSs..." + mountainrooms$(2, 4) = "sSSSs...." + mountainrooms$(2, 5) = "sSSs....." + mountainrooms$(2, 6) = ".ss......" + mountainrooms$(2, 7) = "........." + mountainrooms$(2, 8) = "........." + mountainrooms$(2, 9) = "........." + mountainrooms$(3, 1) = ".ss......" + mountainrooms$(3, 2) = ".SS......" + mountainrooms$(3, 3) = ".SSs....." + mountainrooms$(3, 4) = ".SSs....." + mountainrooms$(3, 5) = ".SSs....." + mountainrooms$(3, 6) = ".SSs....." + mountainrooms$(3, 7) = ".SSs....." + mountainrooms$(3, 8) = ".SS......" + mountainrooms$(3, 9) = ".ss......" + + + mountainrooms$(30, 1) = "........." + mountainrooms$(30, 2) = "...s....." + mountainrooms$(30, 3) = "..sSSs..." + mountainrooms$(30, 4) = ".sSSSSSs." + mountainrooms$(30, 5) = "sSSSSSSS." + mountainrooms$(30, 6) = ".sSS>SSs." + mountainrooms$(30, 7) = "........." + mountainrooms$(30, 8) = "........." + mountainrooms$(30, 9) = "........." + + + If type$ = "mountain" Then + forcemode = 0 + If which > 0 Then forcemode = 1 ' don't rotate prefab bits + If which = 0 Then which = Int(Rnd * 3) + 1 + + mode = Int(Rnd * 8) + 1 ' which rotation + If forcemode = 1 Then mode = 1 + For lop = 1 To 9 + For lopp = 1 To 9 + If mode = 1 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(mountainrooms$(which, lop), lopp, 1)) + If mode = 2 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(mountainrooms$(which, 10 - lop), lopp, 1)) + If mode = 3 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(mountainrooms$(which, lop), 10 - lopp, 1)) + If mode = 4 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(mountainrooms$(which, 10 - lop), 10 - lopp, 1)) + If mode = 5 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(mountainrooms$(which, lopp), lop, 1)) + If mode = 6 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(mountainrooms$(which, 10 - lopp), lop, 1)) + If mode = 7 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(mountainrooms$(which, lopp), 10 - lop, 1)) + If mode = 8 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(mountainrooms$(which, 10 - lopp), 10 - lop, 1)) + Next lopp + Next lop + End If + + Dim ancientrooms$(40, 9) + ancientrooms$(0, 1) = "........." + ancientrooms$(0, 2) = "........." + ancientrooms$(0, 3) = "........." + ancientrooms$(0, 4) = "........." + ancientrooms$(0, 5) = "........." + ancientrooms$(0, 6) = "........." + ancientrooms$(0, 7) = "........." + ancientrooms$(0, 8) = "........." + ancientrooms$(0, 9) = "........." + + ancientrooms$(1, 1) = "....R...." + ancientrooms$(1, 2) = "....R...." + ancientrooms$(1, 3) = "....r...." + ancientrooms$(1, 4) = "....R...." + ancientrooms$(1, 5) = "RRrRRRrRR" + ancientrooms$(1, 6) = "....R...." + ancientrooms$(1, 7) = "....r...." + ancientrooms$(1, 8) = ".9..R...." + ancientrooms$(1, 9) = "....R...." + ancientrooms$(2, 1) = "........." + ancientrooms$(2, 2) = "........." + ancientrooms$(2, 3) = "..RRRRR.." + ancientrooms$(2, 4) = "..R...R.." + ancientrooms$(2, 5) = "..R.9.R.." + ancientrooms$(2, 6) = "..R...R.." + ancientrooms$(2, 7) = "..RRrRR.." + ancientrooms$(2, 8) = "........." + ancientrooms$(2, 9) = "........." + ancientrooms$(3, 1) = "........." + ancientrooms$(3, 2) = "....9...." + ancientrooms$(3, 3) = "........." + ancientrooms$(3, 4) = "....R...." + ancientrooms$(3, 5) = "...RRR..." + ancientrooms$(3, 6) = "....R...." + ancientrooms$(3, 7) = "........." + ancientrooms$(3, 8) = "........." + ancientrooms$(3, 9) = "........." + ancientrooms$(4, 1) = "........." + ancientrooms$(4, 2) = "........." + ancientrooms$(4, 3) = "........." + ancientrooms$(4, 4) = "........." + ancientrooms$(4, 5) = "....9...." + ancientrooms$(4, 6) = "........." + ancientrooms$(4, 7) = "........." + ancientrooms$(4, 8) = "........." + ancientrooms$(4, 9) = "........." + + ancientrooms$(30, 1) = "R...R...R" + ancientrooms$(30, 2) = "........." + ancientrooms$(30, 3) = "..R.R.R.." + ancientrooms$(30, 4) = "........." + ancientrooms$(30, 5) = "R.R.!.R.R" + ancientrooms$(30, 6) = "........." + ancientrooms$(30, 7) = "..R.R.R.." + ancientrooms$(30, 8) = "........." + ancientrooms$(30, 9) = "R...R...R" + + + If type$ = "ancient" Then + forcemode = 0 + If which > 0 Then forcemode = 1 ' don't rotate prefab bits + If which = 0 Then which = Int(Rnd * 4) + 1 + + mode = Int(Rnd * 8) + 1 ' which rotation + If forcemode = 1 Then mode = 1 + For lop = 1 To 9 + For lopp = 1 To 9 + If mode = 1 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(ancientrooms$(which, lop), lopp, 1)) + If mode = 2 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(ancientrooms$(which, 10 - lop), lopp, 1)) + If mode = 3 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(ancientrooms$(which, lop), 10 - lopp, 1)) + If mode = 4 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(ancientrooms$(which, 10 - lop), 10 - lopp, 1)) + If mode = 5 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(ancientrooms$(which, lopp), lop, 1)) + If mode = 6 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(ancientrooms$(which, 10 - lopp), lop, 1)) + If mode = 7 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(ancientrooms$(which, lopp), 10 - lop, 1)) + If mode = 8 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(ancientrooms$(which, 10 - lopp), 10 - lop, 1)) + Next lopp + Next lop + End If + + + Dim forestrooms$(40, 10) + forestrooms$(0, 1) = "''''''''''" + forestrooms$(0, 2) = "''''''''''" + forestrooms$(0, 3) = "''''''''''" + forestrooms$(0, 4) = "''''''''''" + forestrooms$(0, 5) = "''''''''''" + forestrooms$(0, 6) = "''''''''''" + forestrooms$(0, 7) = "''''''''''" + forestrooms$(0, 8) = "''''''''''" + forestrooms$(0, 9) = "''''''''''" + forestrooms$(0, 10) = "''''''''''" + + forestrooms$(1, 1) = "''''TT''''" + forestrooms$(1, 2) = "''''TT''''" + forestrooms$(1, 3) = "''''TTT'''" + forestrooms$(1, 4) = "'''''TTT''" + forestrooms$(1, 5) = "TTT'''TTTT" + forestrooms$(1, 6) = "TTTT'''TTT" + forestrooms$(1, 7) = "''TTT'''''" + forestrooms$(1, 8) = "'''TTT''''" + forestrooms$(1, 9) = "''''TT''''" + forestrooms$(1, 10) = "''''TT''''" + + forestrooms$(2, 1) = "''''TT''''" + forestrooms$(2, 2) = "''''tt''''" + forestrooms$(2, 3) = "''''''''''" + forestrooms$(2, 4) = "'''TTT''''" + forestrooms$(2, 5) = "TTTtttTTTT" + forestrooms$(2, 6) = "TTTtttTTTT" + forestrooms$(2, 7) = "'''TTT''''" + forestrooms$(2, 8) = "''''''''''" + forestrooms$(2, 9) = "'''''tt'''" + forestrooms$(2, 10) = "''''TT''''" + + + forestrooms$(30, 1) = "''''TT''''" + forestrooms$(30, 2) = "''''TT''''" + forestrooms$(30, 3) = "''tTTtT'''" + forestrooms$(30, 4) = "'TTtttTtT'" + forestrooms$(30, 5) = "TTtSSStTTT" + forestrooms$(30, 6) = "TttS!SttTT" + forestrooms$(30, 7) = "'tt...tt''" + forestrooms$(30, 8) = "''Tt.tT'''" + forestrooms$(30, 9) = "'''TtTt'''" + forestrooms$(30, 10) = "''''TT''''" + + + If type$ = "forest" Then + forcemode = 0 + If which > 0 Then forcemode = 1 ' don't rotate prefab bits + If which = 0 Then which = Int(Rnd * 2) + 1 + mode = Int(Rnd * 8) + 1 ' which rotation + If forcemode = 1 Then mode = 1 + For lop = 1 To 10 + For lopp = 1 To 10 + If mode = 1 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(forestrooms$(which, lop), lopp, 1)) + If mode = 2 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(forestrooms$(which, 11 - lop), lopp, 1)) + If mode = 3 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(forestrooms$(which, lop), 11 - lopp, 1)) + If mode = 4 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(forestrooms$(which, 11 - lop), 11 - lopp, 1)) + If mode = 5 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(forestrooms$(which, lopp), lop, 1)) + If mode = 6 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(forestrooms$(which, 11 - lopp), lop, 1)) + If mode = 7 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(forestrooms$(which, lopp), 11 - lop, 1)) + If mode = 8 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(forestrooms$(which, 11 - lopp), 11 - lop, 1)) + Next lopp + Next lop + End If + + Dim specialrooms$(40, 20) + specialrooms$(0, 1) = "...................." + specialrooms$(0, 2) = "...................." + specialrooms$(0, 3) = "...................." + specialrooms$(0, 4) = "...................." + specialrooms$(0, 5) = "...................." + specialrooms$(0, 6) = "...................." + specialrooms$(0, 7) = "...................." + specialrooms$(0, 8) = "...................." + specialrooms$(0, 9) = "...................." + specialrooms$(0, 10) = "...................." + specialrooms$(0, 11) = "...................." + specialrooms$(0, 12) = "...................." + specialrooms$(0, 13) = "...................." + specialrooms$(0, 14) = "...................." + specialrooms$(0, 15) = "...................." + specialrooms$(0, 16) = "...................." + specialrooms$(0, 17) = "...................." + specialrooms$(0, 18) = "...................." + specialrooms$(0, 19) = "...................." + specialrooms$(0, 20) = "...................." + + specialrooms$(1, 1) = "......WWWWWWW......." + specialrooms$(1, 2) = "......W,,,,,W.G....." + specialrooms$(1, 3) = "......W,,,,,W......." + specialrooms$(1, 4) = "..WWWWWWWWW,WWWWW..." + specialrooms$(1, 5) = "..W,,,,,SSS,W,,,W..." + specialrooms$(1, 6) = "..W,,,W,S!S,W,,,W..." + specialrooms$(1, 7) = "..W,,,W,SSS,W,,,W..." + specialrooms$(1, 8) = "..W,,,W,,l,,W,,,W..." + specialrooms$(1, 9) = "..W,,,W,,,,,,,,,W..." + specialrooms$(1, 10) = "..WWWWW,l,l,WWWWW..." + specialrooms$(1, 11) = "......W,,,,,W......." + specialrooms$(1, 12) = ".SSSS.W,l,l,W.G.G.G." + specialrooms$(1, 13) = ".S.>S.W,,,,,W......." + specialrooms$(1, 14) = ".SSSS.W,l,l,W.G.G..." + specialrooms$(1, 15) = "......W,,,,,W......." + specialrooms$(1, 16) = "..G.G.W,,,,,W.G.G.G." + specialrooms$(1, 17) = "......WWWWWWW......." + specialrooms$(1, 18) = "..G.G.........G.G..." + specialrooms$(1, 19) = "...................." + specialrooms$(1, 20) = "...................." + + specialrooms$(2, 1) = "ss..sSSSSSSSSSSSSSSS" + specialrooms$(2, 2) = "s..sSSSSSSSS..<..SSS" + specialrooms$(2, 3) = "..sSSSSSSSS.......SS" + specialrooms$(2, 4) = ".sSSSSSSSSS..@.@..SS" + specialrooms$(2, 5) = "sSSSSSSSSSSS..@..SSS" + specialrooms$(2, 6) = "SSSSSSSsSSSSSSSSSSSS" + specialrooms$(2, 7) = "SSSSSSSSSSSSSSSSSSSS" + specialrooms$(2, 8) = "SSSSsSSSSSSSsSSSSSSS" + specialrooms$(2, 9) = "SSSSSSSSSSSSSSSsSSSS" + specialrooms$(2, 10) = "SSSSSS.A.A.A.SSSSSSS" + specialrooms$(2, 11) = "SS...........SSSSSSS" + specialrooms$(2, 12) = "SS.SSS.A.A.A.SSSSSSS" + specialrooms$(2, 13) = "SS. 0 Then forcemode = 1 ' don't rotate prefab bits + If which = 0 Then which = Int(Rnd * 2) + 1 + mode = Int(Rnd * 8) + 1 ' which rotation + If forcemode = 1 Then mode = 1 + For lop = 1 To 20 + For lopp = 1 To 20 + If mode = 1 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(specialrooms$(which, lop), lopp, 1)) + If mode = 2 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(specialrooms$(which, 21 - lop), lopp, 1)) + If mode = 3 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(specialrooms$(which, lop), 21 - lopp, 1)) + If mode = 4 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(specialrooms$(which, 21 - lop), 21 - lopp, 1)) + If mode = 5 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(specialrooms$(which, lopp), lop, 1)) + If mode = 6 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(specialrooms$(which, 21 - lopp), lop, 1)) + If mode = 7 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(specialrooms$(which, lopp), 21 - lop, 1)) + If mode = 8 Then Call stampchar(x - 1 + lopp, y - 1 + lop, depth, Mid$(specialrooms$(which, 21 - lopp), 21 - lop, 1)) + Next lopp + Next lop + End If + + +End Sub + +Sub stampchar (x, y, depth, char$) + Select Case char$ + Case "." ' enforced nothing + level(x, y, depth) = 0 + If depth = 3 Then ' fungus in the deepths + If Int(Rnd * 50) = 1 Then + level(x, y, depth) = 106 + End If + End If + If depth = 2 Then ' spiders and cairns + If Int(Rnd * 50) = 1 Then + level(x, y, depth) = 105 + ElseIf (Int(Rnd * 50) = 1) Then + level(x, y, depth) = 90 + End If + End If + Case ":" ' supernothing + level(x, y, depth) = 0 + Case "," ' wood floor + level(x, y, depth) = 0 + groundcolor~&(x, y, depth) = groundcolors~&(5) + Case ">" + level(x, y, depth) = 5 + groundcolor~&(x, y, depth) = _RGB(0, 0, 0) + Case "<" + level(x, y, depth) = 6 + groundcolor~&(x, y, depth) = _RGB(0, 0, 0) + Case "@" + level(x, y, depth) = 7 + Case "!" ' spell + level(x, y, depth) = 4 + Case "9" ' influence mote + chance = 10 + If difficulty = 2 Then chance = 7 + If difficulty = 3 Then chance = 4 + If Int(Rnd * 10) + 1 <= chance Then level(x, y, depth) = 9 + Case "T" 'tree + level(x, y, depth) = 10 + Case "t" ' 50% tree + If Int(Rnd * 2) = 1 Then level(x, y, depth) = 10 + Case "A" 'amphora + level(x, y, depth) = 90 + Case "a" ' 25% amphora + If (Int(Rnd * 2) = 1) Then level(x, y, depth) = 90 Else level(x, y, depth) = 0 '' since this is possibly overwriting a desert ruin + Case "P" 'amphora in house + level(x, y, depth) = 90 + groundcolor~&(x, y, depth) = groundcolors~&(5) + Case "p" ' 25% amphora in house + If (Int(Rnd * 2) = 1) Then level(x, y, depth) = 90 Else level(x, y, depth) = 0 '' since this is possibly overwriting a desert ruin + groundcolor~&(x, y, depth) = groundcolors~&(5) + Case "C" 'cactus + level(x, y, depth) = 12 + Case "c" ' 50% cactus + If Int(Rnd * 2) = 1 Then level(x, y, depth) = 12 Else level(x, y, depth) = 0 '' since this is possibly overwriting a desert ruin + Case "S" ' stone + level(x, y, depth) = 50 + Case "s" ' 50% stone + If Int(Rnd * 2) = 1 Then level(x, y, depth) = 50 Else level(x, y, depth) = 0 '' since we fill in the caves fully in the beginning... + Case "R" ' stone in ruins + level(x, y, depth) = 50 + seed(x, y, depth) = 0 + Case "r" ' 50% stone in ruins + If Int(Rnd * 2) = 1 Then + level(x, y, depth) = 50 + seed(x, y, depth) = 0 + End If + Case "W" ' wood wall + level(x, y, depth) = 51 + groundcolor~&(x, y, depth) = groundcolors~&(5) + Case "w" ' 50% wood wall + If Int(Rnd * 2) = 1 Then level(x, y, depth) = 51 + groundcolor~&(x, y, depth) = groundcolors~&(5) + Case "G" ' gravestone + level(x, y, depth) = 52 + Case "L" ' lost soul (indoors) + level(x, y, depth) = 101 + groundcolor~&(x, y, depth) = groundcolors~&(5) + Case "l" ' lost soul (indoors) + If Int(Rnd * 2) = 1 Then level(x, y, depth) = 101 + groundcolor~&(x, y, depth) = groundcolors~&(5) + Case "O" ' lost soul (outdoors) + level(x, y, depth) = 101 + Case "o" ' lost soul (outdoors) + If Int(Rnd * 2) = 1 Then level(x, y, depth) = 101 + Case "K" ' scorpion + level(x, y, depth) = 100 + Case "k" ' 50% scorpion + If Int(Rnd * 2) = 1 Then level(x, y, depth) = 100 + + End Select +End Sub + +Sub drawline (row, line$) + For lop = 1 To 60 + Locate row + 2, lop + Select Case Mid$(line$, lop, 1) + + Case "X" + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Print Chr$(219); + Case "R" + Color _RGB(255, 0, 0), _RGB(0, 0, 0) + Print Chr$(219); + Case "W" + Color _RGB(155, 155, 155), _RGB(0, 0, 0) + Print Chr$(219); + Case Else + End Select + Next lop +End Sub + +Sub titlescreen + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Cls + + Call drawline(2, "....WWWWWWWWWWWW............................................") + Call drawline(3, "....WWWWWWWWWWWW................XX..X..X...XX....XX..XXXXX..") + Call drawline(4, "..WWWWWWWWWWWWWWWW.............X..X.X..X..X..X..X......X....") + Call drawline(5, "..WWWWWWWWWWWWWWWW............X.....XXXX.X....X..XX....X....") + Call drawline(6, "..WWWW..WWWW..WWWW............X..XX.X..X.X....X....X...X....") + Call drawline(7, "..WWWW..WWWW..WWWW.............X..X.X..X..X..X..X..X...X....") + Call drawline(8, "..WWWWWWWWWWWWWWWW..............XX..X..X...XX....XX....X....") + Call drawline(9, "..WWWWWWWWWWWWWWWW..........................................") + Call drawline(10, "..WWWW........WWWW.....X.....X.XXX.XXXX...X...XXXX..XXX.....") + Call drawline(11, "..WWWW........WWWW.....X.....X..X.....X..X.X..X...X.X..X....") + Call drawline(12, "..WWWWWW....WWWWWW.....X..X..X..X....X..X...X.XXXX..X...X...") + Call drawline(13, "..WWWWWW....WWWWWW......X.X.X...X...X...XXXXX.X.X...X...X...") + Call drawline(14, "..WWWWWWWWWWWWWWWW......X.X.X...X..X....X...X.X..X..X..X....") + Call drawline(15, "..WWWWWWWWWWWWWWWW.......X.X...XXX.XXXX.X...X.X...X.XXX.....") + Call drawline(16, "....WWWWWWWWWWWW............................................") + Call drawline(17, "....WWWWWWWWWWWW............................................") + + If permadeath = 0 Then permadeath = 1 ' initialize these + If difficulty = 0 Then difficulty = 2 + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + + inputtop: + fore~& = _RGB(255, 255, 255) + unselectedback~& = _RGB(0, 0, 0) + selectedback~& = _RGB(50, 50, 255) + Locate 25, 3 + If permadeath = 1 Then Color fore~&, selectedback~& Else Color fore~&, unselectedback~& + Print " (A) Adventure Mode " + Locate 26, 3 + If permadeath = 2 Then Color fore~&, selectedback~& Else Color fore~&, unselectedback~& + Print " (R) Roguelike Mode " + + Locate 25, 27 + If difficulty = 1 Then Color fore~&, selectedback~& Else Color fore~&, unselectedback~& + Print " (1) Easy " + Locate 26, 27 + If difficulty = 2 Then Color fore~&, selectedback~& Else Color fore~&, unselectedback~& + Print " (2) Medium " + Locate 27, 27 + If difficulty = 3 Then Color fore~&, selectedback~& Else Color fore~&, unselectedback~& + Print " (3) Hard " + + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + + Locate 25, 45 + Print "(P) Play" + Locate 26, 45 + Print "(Q) Quit" + k$ = "" + While k$ = "" + k$ = UCase$(InKey$) + Select Case k$ + Case "A" + permadeath = 1 + Case "R" + permadeath = 2 + Case "1" + difficulty = 1 + Case "2" + difficulty = 2 + Case "3" + difficulty = 3 + Case "Q" + System + Case "P" + Exit Sub + End Select + Wend + GoTo inputtop +End Sub + + +Sub gameoverscreen + Cls + + Call drawline(2, "....WWWWWWWWWWWW............................................") + Call drawline(3, "....WWWWWWWWWWWW...............RR....R...R...R.RRRR.........") + Call drawline(4, "..WWWWWWWWWWWWWWWW............R..R..R.R..RR.RR.R............") + Call drawline(5, "..WWWWWWWWWWWWWWWW...........R.....R...R.R.R.R.RRRR.........") + Call drawline(6, "..WWWW..WWWW..WWWW...........R..RR.RRRRR.R...R.R............") + Call drawline(7, "..WWWW..WWWW..WWWW............R..R.R...R.R...R.R............") + Call drawline(8, "..WWWWWWWWWWWWWWWW.............RR..R...R.R...R.RRRR.........") + Call drawline(9, "..WWWWWWWWWWWWWWWW..........................................") + Call drawline(10, "..WWWWWW....WWWWWW............RR...R...R.RRRR.RRRR..........") + Call drawline(11, "..WWWWWW....WWWWWW...........R..R..R...R.R....R...R.........") + Call drawline(12, "..WWWW........WWWW..........R....R.R...R.RRRR.RRRR..........") + Call drawline(13, "..WWWW........WWWW..........R....R..R.R..R....R.R...........") + Call drawline(14, "..WWWWWWWWWWWWWWWW...........R..R...R.R..R....R..R..........") + Call drawline(15, "..WWWWWWWWWWWWWWWW............RR.....R...RRRR.R...R.........") + Call drawline(16, "....WWWWWWWWWWWW............................................") + Call drawline(17, "....WWWWWWWWWWWW............................................") + + Locate 25, 22 + Print "Press any key..." + While InKey$ = "": Wend + gameover = 1 + +End Sub + +Sub winscreen + Color _RGB(255, 255, 255), _RGB(0, 0, 0) + Cls + Call drawline(2, "............................................................") + Call drawline(3, "...........X...X...XX...X..X.....X.....X...XX...X...X..X....") + Call drawline(4, "...........X...X..X..X..X..X.....X.....X..X..X..XX..X..X....") + Call drawline(5, "............X.X..X....X.X..X.....X..X..X.X....X.X.X.X..X....") + Call drawline(6, ".............X...X....X.X..X......X.X.X..X....X.X..XX..X....") + Call drawline(7, ".............X....X..X..X..X......X.X.X...X..X..X...X.......") + Call drawline(8, ".............X.....XX....XX........X.X.....XX...X...X..X....") + Call drawline(9, "............................................................") + Call drawline(10, "............................................................") + Call drawline(11, "............................................................") + Call drawline(12, "..WWWWWW....WWWW............................................") + Call drawline(13, "..WWWWWW....WWWW............................................") + Call drawline(14, "....WWWWWWWWWW......WW......................................") + Call drawline(15, "....WWWWWWWWWW......WW......................................") + Call drawline(16, "WW..WWWWWWWWWWWW..WWWWWW..WW................................") + Call drawline(17, "WW..WWWWWWWWWWWW..WWWWWW..WW................................") + + Color _RGB(255, 255, 255) + Locate 22, 20 + Print "Thank you for playing!" + Locate 24, 22 + Print "Press any key..." + While InKey$ = "": Wend + gameover = 1 +End Sub + diff --git a/samples/gl.md b/samples/gl.md new file mode 100644 index 0000000..6950927 --- /dev/null +++ b/samples/gl.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: GL + +**[3D Grapher](3d-grapher/index.md)** + +[🐝 Ashish Kushwaha](ashish-kushwaha.md) [🐝 STxAxTIC](stxaxtic.md) 🔗 [3d](3d.md), [gl](gl.md) + +3D Grapher made in QB64. diff --git a/samples/globe/index.md b/samples/globe/index.md index 063a6e8..43e1cc3 100644 --- a/samples/globe/index.md +++ b/samples/globe/index.md @@ -22,9 +22,9 @@ Glen Jeh, 8/12/1994, William Yu (05-28-96) > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "globe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/globe/src/globe.bas) -* [RUN "globe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/globe/src/globe.bas) -* [PLAY "globe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/globe/src/globe.bas) +* [LOAD "globe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/globe/src/globe.bas) +* [RUN "globe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/globe/src/globe.bas) +* [PLAY "globe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/globe/src/globe.bas) ### File(s) diff --git a/samples/gorillas/img/screenshot.png b/samples/gorillas/img/screenshot.png new file mode 100644 index 0000000..1cba2e8 Binary files /dev/null and b/samples/gorillas/img/screenshot.png differ diff --git a/samples/gorillas/index.md b/samples/gorillas/index.md new file mode 100644 index 0000000..ab6efd2 --- /dev/null +++ b/samples/gorillas/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: GORILLAS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Gorilla-based artillery game by Microsoft. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "gorillas.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/gorillas/src/gorillas.bas) +* [RUN "gorillas.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/gorillas/src/gorillas.bas) +* [PLAY "gorillas.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/gorillas/src/gorillas.bas) + +### File(s) + +* [gorillas.bas](src/gorillas.bas) + +🔗 [game](../game.md), [artillery](../artillery.md) diff --git a/samples/gorillas/src/gorillas.bas b/samples/gorillas/src/gorillas.bas new file mode 100644 index 0000000..a95bcf8 --- /dev/null +++ b/samples/gorillas/src/gorillas.bas @@ -0,0 +1,1096 @@ +' Q B a s i c G o r i l l a s +' +' Copyright (C) Microsoft Corporation 1990 +' +' Your mission is to hit your opponent with the exploding banana +' by varying the angle and power of your throw, taking into account +' wind speed, gravity, and the city skyline. +' +' Speed of this game is determined by the constant SPEEDCONST. If the +' program is too slow or too fast adjust the "CONST SPEEDCONST = 500" line +' below. The larger the number the faster the game will go. +' +' 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. +' + +$NoPrefix + +'Set default data type to integer for faster game play +DefInt A-Z + +'Make all arrays Dynamic +'$DYNAMIC + +$Resize:Smooth + +'User-Defined TYPEs +Type XYPoint + XCoor As Integer + YCoor As Integer +End Type + +'Constants +Const FALSE = 0, TRUE = Not FALSE +Const SPEEDCONST = 500 +Const HITSELF = 1 +Const BACKATTR = 0 +Const OBJECTCOLOR = 1 +Const WINDOWCOLOR = 14 +Const SUNATTR = 3 +Const SUNHAPPY = FALSE +Const SUNSHOCK = TRUE +Const RIGHTUP = 1 +Const LEFTUP = 2 +Const ARMSDOWN = 3 + +'Global Variables +Dim Shared GorillaX(1 To 2) 'Location of the two gorillas +Dim Shared GorillaY(1 To 2) +Dim Shared LastBuilding + +Dim Shared LBan&(x), RBan&(x), UBan&(x), DBan&(x) 'Graphical picture of banana +Dim Shared GorD&(120) 'Graphical picture of Gorilla arms down +Dim Shared GorL&(120) 'Gorilla left arm raised +Dim Shared GorR&(120) 'Gorilla right arm raised + +Dim Shared gravity# +Dim Shared Wind + +'Screen Mode Variables +Dim Shared ScrHeight +Dim Shared ScrWidth +Dim Shared Mode +Dim Shared MaxCol + +'Screen Color Variables +Dim Shared ExplosionColor +Dim Shared BackColor +Dim Shared SunHit + +Dim Shared SunHt +Dim Shared GHeight +Dim Shared MachSpeed& + +Def Seg = 0 ' Set NumLock to ON +KeyFlags = Peek(1047) +If (KeyFlags And 32) = 0 Then + Poke 1047, KeyFlags Or 32 +End If +Def Seg + +GoSub InitVars +Intro +GetInputs Name1$, Name2$, NumGames +GorillaIntro Name1$, Name2$ +PlayGame Name1$, Name2$, NumGames + +Def Seg = 0 ' Restore NumLock state +Poke 1047, KeyFlags +Def Seg + +System 0 + + +CGABanana: +'BananaLeft +Data 327686,-252645316,60 +'BananaDown +Data 196618,-1057030081,49344 +'BananaUp +Data 196618,-1056980800,63 +'BananaRight +Data 327686,1010580720,240 + +EGABanana: +'BananaLeft +Data 458758,202116096,471604224,943208448,943208448,943208448,471604224,202116096,0 +'BananaDown +Data 262153,-2134835200,-2134802239,-2130771968,-2130738945,8323072,8323199,4063232,4063294 +'BananaUp +Data 262153,4063232,4063294,8323072,8323199,-2130771968,-2130738945,-2134835200,-2134802239 +'BananaRight +Data 458758,-1061109760,-522133504,1886416896,1886416896,1886416896,-522133504,-1061109760,0 + +InitVars: +'This is a clever way to pick the best graphics mode available +On Error GoTo ScreenModeError +Mode = 9 +Screen Mode +FullScreen SquarePixels , Smooth +On Error GoTo PaletteError +If Mode = 9 Then Palette 4, 0 'Check for 64K EGA +On Error GoTo 0 + +MachSpeed& = CalcDelay& + +If Mode = 9 Then + ScrWidth = 640 + ScrHeight = 350 + GHeight = 25 + Restore EGABanana + ReDim LBan&(8), RBan&(8), UBan&(8), DBan&(8) + + For i = 0 To 8 + Read LBan&(i) + Next i + + For i = 0 To 8 + Read DBan&(i) + Next i + + For i = 0 To 8 + Read UBan&(i) + Next i + + For i = 0 To 8 + Read RBan&(i) + Next i + + SunHt = 39 + +Else + + ScrWidth = 320 + ScrHeight = 200 + GHeight = 12 + Restore CGABanana + ReDim LBan&(2), RBan&(2), UBan&(2), DBan&(2) + ReDim GorL&(20), GorD&(20), GorR&(20) + + For i = 0 To 2 + Read LBan&(i) + Next i + For i = 0 To 2 + Read DBan&(i) + Next i + For i = 0 To 2 + Read UBan&(i) + Next i + For i = 0 To 2 + Read RBan&(i) + Next i + + MachSpeed& = MachSpeed& * 1.3 + SunHt = 20 +End If +Return + +ScreenModeError: +If Mode = 1 Then + Cls + Locate 10, 5 + Print "Sorry, you must have CGA, EGA color, or VGA graphics to play GORILLA.BAS" + End 1 +Else + Mode = 1 + Resume +End If + +PaletteError: +Mode = 1 '64K EGA cards will run in CGA mode. +Resume Next + +Rem $STATIC +'CalcDelay: +' Checks speed of the machine. +Function CalcDelay& + s# = Timer + Do + i& = i& + 1 + Loop Until Timer - s# >= .5 + CalcDelay& = i& +End Function + +' Center: +' Centers and prints a text string on a given row +' Parameters: +' Row - screen row number +' Text$ - text to be printed +' +Sub Center (Row, Text$) + Col = (MaxCol - Len(Text$)) \ 2 + 1 + Locate Row, Col + Print Text$; +End Sub + +' DoExplosion: +' Produces explosion when a shot is fired +' Parameters: +' X#, Y# - location of explosion +' +Sub DoExplosion (x#, y#) + Play "MBO0L32EFGEFDC" + Radius = ScrHeight / 50 + If Mode = 9 Then Inc# = .5 Else Inc# = .41 + For c# = 0 To Radius Step Inc# + Circle (x#, y#), c#, ExplosionColor + Next c# + For c# = Radius To 0 Step (-1 * Inc#) + Circle (x#, y#), c#, BACKATTR + Rest .005 + Next c# +End Sub + +' DoShot: +' Controls banana shots by accepting player input and plotting +' shot angle +' Parameters: +' PlayerNum - Player +' x, y - Player's gorilla position +' +Function DoShot (PlayerNum, x, y) + 'Input shot + If PlayerNum = 1 Then + LocateCol = 1 + Else + If Mode = 9 Then + LocateCol = 66 + Else + LocateCol = 26 + End If + End If + + Locate 2, LocateCol + Print "Angle:"; + Angle# = GetNum#(2, LocateCol + 7) + + Locate 3, LocateCol + Print "Velocity:"; + Velocity = GetNum#(3, LocateCol + 10) + + If PlayerNum = 2 Then + Angle# = 180 - Angle# + End If + + 'Erase input + For i = 1 To 4 + Locate i, 1 + Print Space$(30 \ (80 \ MaxCol)); + Locate i, (50 \ (80 \ MaxCol)) + Print Space$(30 \ (80 \ MaxCol)); + Next + + SunHit = FALSE + PlayerHit = PlotShot(x, y, Angle#, Velocity, PlayerNum) + If PlayerHit = 0 Then + DoShot = FALSE + Else + DoShot = TRUE + If PlayerHit = PlayerNum Then PlayerNum = 3 - PlayerNum + VictoryDance PlayerNum + End If +End Function + +' DoSun: +' Draws the sun at the top of the screen. +' Parameters: +' Mouth - If TRUE draws "O" mouth else draws a smile mouth. +' +Sub DoSun (Mouth) + 'set position of sun + x = ScrWidth \ 2: y = Scl(25) + + 'clear old sun + Line (x - Scl(22), y - Scl(18))-(x + Scl(22), y + Scl(18)), BACKATTR, BF + + 'draw new sun: + 'body + Circle (x, y), Scl(12), SUNATTR + Paint (x, y), SUNATTR + + 'rays + Line (x - Scl(20), y)-(x + Scl(20), y), SUNATTR + Line (x, y - Scl(15))-(x, y + Scl(15)), SUNATTR + + Line (x - Scl(15), y - Scl(10))-(x + Scl(15), y + Scl(10)), SUNATTR + Line (x - Scl(15), y + Scl(10))-(x + Scl(15), y - Scl(10)), SUNATTR + + Line (x - Scl(8), y - Scl(13))-(x + Scl(8), y + Scl(13)), SUNATTR + Line (x - Scl(8), y + Scl(13))-(x + Scl(8), y - Scl(13)), SUNATTR + + Line (x - Scl(18), y - Scl(5))-(x + Scl(18), y + Scl(5)), SUNATTR + Line (x - Scl(18), y + Scl(5))-(x + Scl(18), y - Scl(5)), SUNATTR + + 'mouth + If Mouth Then 'draw "o" mouth + Circle (x, y + Scl(5)), Scl(2.9), 0 + Paint (x, y + Scl(5)), 0, 0 + Else 'draw smile + Circle (x, y), Scl(8), 0, (210 * Pi / 180), (330 * Pi / 180) + End If + + 'eyes + Circle (x - 3, y - 2), 1, 0 + Circle (x + 3, y - 2), 1, 0 + PSet (x - 3, y - 2), 0 + PSet (x + 3, y - 2), 0 +End Sub + +'DrawBan: +' Draws the banana +'Parameters: +' xc# - Horizontal Coordinate +' yc# - Vertical Coordinate +' r - rotation position (0-3). ( \_/ ) /-\ +' bc - if TRUE then DrawBan draws the banana ELSE it erases the banana +Sub DrawBan (xc#, yc#, r, bc) + Select Case r + Case 0 + If bc Then Put (xc#, yc#), LBan&(), PSet Else Put (xc#, yc#), LBan&(), Xor + Case 1 + If bc Then Put (xc#, yc#), UBan&(), PSet Else Put (xc#, yc#), UBan&(), Xor + Case 2 + If bc Then Put (xc#, yc#), RBan&(), PSet Else Put (xc#, yc#), RBan&(), Xor + Case 3 + If bc Then Put (xc#, yc#), DBan&(), PSet Else Put (xc#, yc#), DBan&(), Xor + End Select + +End Sub + +'DrawGorilla: +' Draws the Gorilla in either CGA or EGA mode +' and saves the graphics data in an array. +'Parameters: +' x - x coordinate of gorilla +' y - y coordinate of the gorilla +' arms - either Left up, Right up, or both down +Sub DrawGorilla (x, y, arms) + Dim i As Single ' Local index must be single precision + + 'draw head + Line (x - Scl(4), y)-(x + Scl(2.9), y + Scl(6)), OBJECTCOLOR, BF + Line (x - Scl(5), y + Scl(2))-(x + Scl(4), y + Scl(4)), OBJECTCOLOR, BF + + 'draw eyes/brow + Line (x - Scl(3), y + Scl(2))-(x + Scl(2), y + Scl(2)), 0 + + 'draw nose if ega + If Mode = 9 Then + For i = -2 To -1 + PSet (x + i, y + 4), 0 + PSet (x + i + 3, y + 4), 0 + Next i + End If + + 'neck + Line (x - Scl(3), y + Scl(7))-(x + Scl(2), y + Scl(7)), OBJECTCOLOR + + 'body + Line (x - Scl(8), y + Scl(8))-(x + Scl(6.9), y + Scl(14)), OBJECTCOLOR, BF + Line (x - Scl(6), y + Scl(15))-(x + Scl(4.9), y + Scl(20)), OBJECTCOLOR, BF + + 'legs + For i = 0 To 4 + Circle (x + Scl(i), y + Scl(25)), Scl(10), OBJECTCOLOR, 3 * Pi / 4, 9 * Pi / 8 + Circle (x + Scl(-6) + Scl(i - .1), y + Scl(25)), Scl(10), OBJECTCOLOR, 15 * Pi / 8, Pi / 4 + Next + + 'chest + Circle (x - Scl(4.9), y + Scl(10)), Scl(4.9), 0, 3 * Pi / 2, 0 + Circle (x + Scl(4.9), y + Scl(10)), Scl(4.9), 0, Pi, 3 * Pi / 2 + + For i = -5 To -1 + Select Case arms + Case 1 + 'Right arm up + Circle (x + Scl(i - .1), y + Scl(14)), Scl(9), OBJECTCOLOR, 3 * Pi / 4, 5 * Pi / 4 + Circle (x + Scl(4.9) + Scl(i), y + Scl(4)), Scl(9), OBJECTCOLOR, 7 * Pi / 4, Pi / 4 + Get (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorR&() + Case 2 + 'Left arm up + Circle (x + Scl(i - .1), y + Scl(4)), Scl(9), OBJECTCOLOR, 3 * Pi / 4, 5 * Pi / 4 + Circle (x + Scl(4.9) + Scl(i), y + Scl(14)), Scl(9), OBJECTCOLOR, 7 * Pi / 4, Pi / 4 + Get (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorL&() + Case 3 + 'Both arms down + Circle (x + Scl(i - .1), y + Scl(14)), Scl(9), OBJECTCOLOR, 3 * Pi / 4, 5 * Pi / 4 + Circle (x + Scl(4.9) + Scl(i), y + Scl(14)), Scl(9), OBJECTCOLOR, 7 * Pi / 4, Pi / 4 + Get (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorD&() + End Select + Next i +End Sub + +'ExplodeGorilla: +' Causes gorilla explosion when a direct hit occurs +'Parameters: +' X# - shot X-location +Function ExplodeGorilla (x#) + YAdj = Scl(12) + XAdj = Scl(5) + SclX# = ScrWidth / 320 + SclY# = ScrHeight / 200 + If x# < ScrWidth / 2 Then PlayerHit = 1 Else PlayerHit = 2 + Play "MBO0L16EFGEFDC" + + For i = 1 To 8 * SclX# + Circle (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + 7 * SclY# + YAdj), i, ExplosionColor, , , -1.57 + Line (GorillaX(PlayerHit) + 7 * SclX#, GorillaY(PlayerHit) + 9 * SclY# - i)-(GorillaX(PlayerHit), GorillaY(PlayerHit) + 9 * SclY# - i), ExplosionColor + Rest .005 + Next i + + For i = 1 To 16 * SclX# + If i < (8 * SclX#) Then Circle (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + 7 * SclY# + YAdj), (8 * SclX# + 1) - i, BACKATTR, , , -1.57 + Circle (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + YAdj), i, i Mod 2 + 1, , , -1.57 + Rest .005 + Next i + + For i = 24 * SclX# To 1 Step -1 + Circle (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + YAdj), i, BACKATTR, , , -1.57 + Rest .01 + Next i + + ExplodeGorilla = PlayerHit +End Function + +Function FnRan (x) + FnRan = Int(Rnd(1) * x) + 1 +End Function + +'GetInputs: +' Gets user inputs at beginning of game +'Parameters: +' Player1$, Player2$ - player names +' NumGames - number of games to play +Sub GetInputs (Player1$, Player2$, NumGames) + Color 7, 0 + Cls + + Locate 8, 15 + Line Input "Name of Player 1 (Default = 'Player 1'): "; Player1$ + If Player1$ = "" Then + Player1$ = "Player 1" + Else + Player1$ = Left$(Player1$, 10) + End If + + Locate 10, 15 + Line Input "Name of Player 2 (Default = 'Player 2'): "; Player2$ + If Player2$ = "" Then + Player2$ = "Player 2" + Else + Player2$ = Left$(Player2$, 10) + End If + + Do + Locate 12, 56: Print Space$(25); + Locate 12, 13 + Input "Play to how many total points (Default = 3)"; game$ + NumGames = Val(Left$(game$, 2)) + Loop Until NumGames > 0 And Len(game$) < 3 Or Len(game$) = 0 + If NumGames = 0 Then NumGames = 3 + + Do + Locate 14, 53: Print Space$(28); + Locate 14, 17 + Input "Gravity in Meters/Sec (Earth = 9.8)"; grav$ + gravity# = Val(grav$) + Loop Until gravity# > 0 Or Len(grav$) = 0 + If gravity# = 0 Then gravity# = 9.8 +End Sub + +'GetNum: +' Gets valid numeric input from user +'Parameters: +' Row, Col - location to echo input +Function GetNum# (Row, Col) + Result$ = "" + Done = FALSE + While InKey$ <> "": Wend 'Clear keyboard buffer + + Do While Not Done + + Locate Row, Col + Print Result$; Chr$(95); " "; + + Kbd$ = InKey$ + Select Case Kbd$ + Case "0" TO "9" + Result$ = Result$ + Kbd$ + Case "." + If InStr(Result$, ".") = 0 Then + Result$ = Result$ + Kbd$ + End If + Case Chr$(13) + If Val(Result$) > 360 Then + Result$ = "" + Else + Done = TRUE + End If + Case Chr$(8) + If Len(Result$) > 0 Then + Result$ = Left$(Result$, Len(Result$) - 1) + End If + Case Else + If Len(Kbd$) > 0 Then + Beep + End If + End Select + Loop + + Locate Row, Col + Print Result$; " "; + + GetNum# = Val(Result$) +End Function + +'GorillaIntro: +' Displays gorillas on screen for the first time +' allows the graphical data to be put into an array +'Parameters: +' Player1$, Player2$ - The names of the players +' +Sub GorillaIntro (Player1$, Player2$) + Locate 16, 34: Print "--------------" + Locate 18, 34: Print "V = View Intro" + Locate 19, 34: Print "P = Play Game" + Locate 21, 35: Print "Your Choice?" + + Do While Char$ = "" + Char$ = InKey$ + Loop + + If Mode = 1 Then + x = 125 + y = 100 + Else + x = 278 + y = 175 + End If + + Screen Mode + SetScreen + + If Mode = 1 Then Center 5, "Please wait while gorillas are drawn." + + View Print 9 To 24 + + If Mode = 9 Then Palette OBJECTCOLOR, BackColor + + DrawGorilla x, y, ARMSDOWN + Cls 2 + DrawGorilla x, y, LEFTUP + Cls 2 + DrawGorilla x, y, RIGHTUP + Cls 2 + + View Print 1 To 25 + If Mode = 9 Then Palette OBJECTCOLOR, 46 + + If UCase$(Char$) = "V" Then + Center 2, "Q B A S I C G O R I L L A S" + Center 5, " STARRING: " + P$ = Player1$ + " AND " + Player2$ + Center 7, P$ + + Put (x - 13, y), GorD&(), PSet + Put (x + 47, y), GorD&(), PSet + Rest 1 + + Put (x - 13, y), GorL&(), PSet + Put (x + 47, y), GorR&(), PSet + before# = Timer(.001) + Play "t120o1l16b9n0baan0bn0bn0baaan0b9n0baan0b" + Rest .3 + 2.944 - (Timer(.001) - before#) + + Put (x - 13, y), GorR&(), PSet + Put (x + 47, y), GorL&(), PSet + before# = Timer(.001) + Play "o2l16e-9n0e-d-d-n0e-n0e-n0e-d-d-d-n0e-9n0e-d-d-n0e-" + Rest .3 + 2.944 - (Timer(.001) - before#) + + Put (x - 13, y), GorL&(), PSet + Put (x + 47, y), GorR&(), PSet + before# = Timer(.001) + Play "o2l16g-9n0g-een0g-n0g-n0g-eeen0g-9n0g-een0g-" + Rest .3 + 2.944 - (Timer(.001) - before#) + + Put (x - 13, y), GorR&(), PSet + Put (x + 47, y), GorL&(), PSet + before# = Timer(.001) + Play "o2l16b9n0baan0g-n0g-n0g-eeen0o1b9n0baan0b" + Rest .3 + 2.944 - (Timer(.001) - before#) + + For i = 1 To 4 + Put (x - 13, y), GorL&(), PSet + Put (x + 47, y), GorR&(), PSet + before# = Timer(.001) + Play "T160O0L32EFGEFDC" + Rest .1 + .328 - (Timer(.001) - before#) + Put (x - 13, y), GorR&(), PSet + Put (x + 47, y), GorL&(), PSet + before# = Timer(.001) + Play "T160O0L32EFGEFDC" + Rest .1 + .328 - (Timer(.001) - before#) + Next + End If +End Sub + +'Intro: +' Displays game introduction +Sub Intro + Screen 0 + Width 80, 25 + MaxCol = 80 + Color 15, 0 + Cls + + Center 4, "Q B a s i c G O R I L L A S" + Color 7 + Center 6, "Copyright (C) Microsoft Corporation 1990" + Center 8, "Your mission is to hit your opponent with the exploding" + Center 9, "banana by varying the angle and power of your throw, taking" + Center 10, "into account wind speed, gravity, and the city skyline." + Center 11, "The wind speed is shown by a directional arrow at the bottom" + Center 12, "of the playing field, its length relative to its strength." + Center 24, "Press any key to continue" + + Play "MBT160O1L8CDEDCDL4ECC" + SparklePause + If Mode = 1 Then MaxCol = 40 +End Sub + +'MakeCityScape: +' Creates random skyline for game +'Parameters: +' BCoor() - a user-defined type array which stores the coordinates of +' the upper left corner of each building. +Sub MakeCityScape (BCoor() As XYPoint) + x = 2 + + 'Set the sloping trend of the city scape. NewHt is new building height + Slope = FnRan(6) + Select Case Slope + Case 1: NewHt = 15 'Upward slope + Case 2: NewHt = 130 'Downward slope + Case 3 TO 5: NewHt = 15 '"V" slope - most common + Case 6: NewHt = 130 'Inverted "V" slope + End Select + + If Mode = 9 Then + BottomLine = 335 'Bottom of building + HtInc = 10 'Increase value for new height + DefBWidth = 37 'Default building height + RandomHeight = 120 'Random height difference + WWidth = 3 'Window width + WHeight = 6 'Window height + WDifV = 15 'Counter for window spacing - vertical + WDifh = 10 'Counter for window spacing - horizontal + Else + BottomLine = 190 + HtInc = 6 + NewHt = NewHt * 20 \ 35 'Adjust for CGA + DefBWidth = 18 + RandomHeight = 54 + WWidth = 1 + WHeight = 2 + WDifV = 5 + WDifh = 4 + End If + + CurBuilding = 1 + Do + + Select Case Slope + Case 1 + NewHt = NewHt + HtInc + Case 2 + NewHt = NewHt - HtInc + Case 3 TO 5 + If x > ScrWidth \ 2 Then + NewHt = NewHt - 2 * HtInc + Else + NewHt = NewHt + 2 * HtInc + End If + Case 4 + If x > ScrWidth \ 2 Then + NewHt = NewHt + 2 * HtInc + Else + NewHt = NewHt - 2 * HtInc + End If + End Select + + 'Set width of building and check to see if it would go off the screen + BWidth = FnRan(DefBWidth) + DefBWidth + If x + BWidth > ScrWidth Then BWidth = ScrWidth - x - 2 + + 'Set height of building and check to see if it goes below screen + BHeight = FnRan(RandomHeight) + NewHt + If BHeight < HtInc Then BHeight = HtInc + + 'Check to see if Building is too high + If BottomLine - BHeight <= MaxHeight + GHeight Then BHeight = MaxHeight + GHeight - 5 + + 'Set the coordinates of the building into the array + BCoor(CurBuilding).XCoor = x + BCoor(CurBuilding).YCoor = BottomLine - BHeight + + If Mode = 9 Then BuildingColor = FnRan(3) + 4 Else BuildingColor = 2 + + 'Draw the building, outline first, then filled + Line (x - 1, BottomLine + 1)-(x + BWidth + 1, BottomLine - BHeight - 1), BACKGROUND, B + Line (x, BottomLine)-(x + BWidth, BottomLine - BHeight), BuildingColor, BF + + 'Draw the windows + c = x + 3 + Do + For i = BHeight - 3 To 7 Step -WDifV + If Mode <> 9 Then + WinColr = (FnRan(2) - 2) * -3 + ElseIf FnRan(4) = 1 Then + WinColr = 8 + Else + WinColr = WINDOWCOLOR + End If + Line (c, BottomLine - i)-(c + WWidth, BottomLine - i + WHeight), WinColr, BF + Next + c = c + WDifh + Loop Until c >= x + BWidth - 3 + + x = x + BWidth + 2 + + CurBuilding = CurBuilding + 1 + + Loop Until x > ScrWidth - HtInc + + LastBuilding = CurBuilding - 1 + + 'Set Wind speed + Wind = FnRan(10) - 5 + If FnRan(3) = 1 Then + If Wind > 0 Then + Wind = Wind + FnRan(10) + Else + Wind = Wind - FnRan(10) + End If + End If + + 'Draw Wind speed arrow + If Wind <> 0 Then + WindLine = Wind * 3 * (ScrWidth \ 320) + Line (ScrWidth \ 2, ScrHeight - 5)-(ScrWidth \ 2 + WindLine, ScrHeight - 5), ExplosionColor + If Wind > 0 Then ArrowDir = -2 Else ArrowDir = 2 + Line (ScrWidth / 2 + WindLine, ScrHeight - 5)-(ScrWidth / 2 + WindLine + ArrowDir, ScrHeight - 5 - 2), ExplosionColor + Line (ScrWidth / 2 + WindLine, ScrHeight - 5)-(ScrWidth / 2 + WindLine + ArrowDir, ScrHeight - 5 + 2), ExplosionColor + End If +End Sub + +'PlaceGorillas: +' PUTs the Gorillas on top of the buildings. Must have drawn +' Gorillas first. +'Parameters: +' BCoor() - user-defined TYPE array which stores upper left coordinates +' of each building. +Sub PlaceGorillas (BCoor() As XYPoint) + If Mode = 9 Then + XAdj = 14 + YAdj = 30 + Else + XAdj = 7 + YAdj = 16 + End If + SclX# = ScrWidth / 320 + SclY# = ScrHeight / 200 + + 'Place gorillas on second or third building from edge + For i = 1 To 2 + If i = 1 Then BNum = FnRan(2) + 1 Else BNum = LastBuilding - FnRan(2) + + BWidth = BCoor(BNum + 1).XCoor - BCoor(BNum).XCoor + GorillaX(i) = BCoor(BNum).XCoor + BWidth / 2 - XAdj + GorillaY(i) = BCoor(BNum).YCoor - YAdj + Put (GorillaX(i), GorillaY(i)), GorD&(), PSet + Next i +End Sub + +'PlayGame: +' Main game play routine +'Parameters: +' Player1$, Player2$ - player names +' NumGames - number of games to play +Sub PlayGame (Player1$, Player2$, NumGames) + Dim BCoor(0 To 30) As XYPoint + Dim TotalWins(1 To 2) + + J = 1 + + For i = 1 To NumGames + + Cls + Randomize (Timer) + Call MakeCityScape(BCoor()) + Call PlaceGorillas(BCoor()) + DoSun SUNHAPPY + Hit = FALSE + Do While Hit = FALSE + J = 1 - J + Locate 1, 1 + Print Player1$ + Locate 1, (MaxCol - 1 - Len(Player2$)) + Print Player2$ + Center 23, LTrim$(Str$(TotalWins(1))) + ">Score<" + LTrim$(Str$(TotalWins(2))) + Tosser = J + 1: Tossee = 3 - J + + 'Plot the shot. Hit is true if Gorilla gets hit. + Hit = DoShot(Tosser, GorillaX(Tosser), GorillaY(Tosser)) + + 'Reset the sun, if it got hit + If SunHit Then DoSun SUNHAPPY + + If Hit = TRUE Then Call UpdateScores(TotalWins(), Tosser, Hit) + Loop + Sleep 1 + Next i + + Screen 0 + Width 80, 25 + Color 7, 0 + MaxCol = 80 + Cls + + Center 8, "GAME OVER!" + Center 10, "Score:" + Locate 11, 30: Print Player1$; Tab(50); TotalWins(1) + Locate 12, 30: Print Player2$; Tab(50); TotalWins(2) + Center 24, "Press any key to continue" + SparklePause + Color 7, 0 + Cls +End Sub + +'PlayGame: +' Plots banana shot across the screen +'Parameters: +' StartX, StartY - starting shot location +' Angle - shot angle +' Velocity - shot velocity +' PlayerNum - the banana thrower +Function PlotShot (StartX, StartY, Angle#, Velocity, PlayerNum) + Angle# = Angle# / 180 * Pi 'Convert degree angle to radians + Radius = Mode Mod 7 + + InitXVel# = Cos(Angle#) * Velocity + InitYVel# = Sin(Angle#) * Velocity + + oldx# = StartX + oldy# = StartY + + 'draw gorilla toss + If PlayerNum = 1 Then + Put (StartX, StartY), GorL&(), PSet + Else + Put (StartX, StartY), GorR&(), PSet + End If + + 'throw sound + Play "MBo0L32A-L64CL16BL64A+" + Rest .1 + + 'redraw gorilla + Put (StartX, StartY), GorD&(), PSet + + adjust = Scl(4) 'For scaling CGA + + xedge = Scl(9) * (2 - PlayerNum) 'Find leading edge of banana for check + + Impact = FALSE + ShotInSun = FALSE + OnScreen = TRUE + PlayerHit = 0 + NeedErase = FALSE + + StartXPos = StartX + StartYPos = StartY - adjust - 3 + + If PlayerNum = 2 Then + StartXPos = StartXPos + Scl(25) + direction = Scl(4) + Else + direction = Scl(-4) + End If + + If Velocity < 2 Then 'Shot too slow - hit self + x# = StartX + y# = StartY + pointval = OBJECTCOLOR + End If + + Do While (Not Impact) And OnScreen + + Rest .02 + + 'Erase old banana, if necessary + If NeedErase Then + NeedErase = FALSE + Call DrawBan(oldx#, oldy#, oldrot, FALSE) + End If + + x# = StartXPos + (InitXVel# * t#) + (.5 * (Wind / 5) * t# ^ 2) + y# = StartYPos + ((-1 * (InitYVel# * t#)) + (.5 * gravity# * t# ^ 2)) * (ScrHeight / 350) + + If (x# >= ScrWidth - Scl(10)) Or (x# <= 3) Or (y# >= ScrHeight - 3) Then + OnScreen = FALSE + End If + + + If OnScreen And y# > 0 Then + + 'check it + LookY = 0 + LookX = Scl(8 * (2 - PlayerNum)) + Do + pointval = Point(x# + LookX, y# + LookY) + If pointval = 0 Then + Impact = FALSE + If ShotInSun = TRUE Then + If Abs(ScrWidth \ 2 - x#) > Scl(20) Or y# > SunHt Then ShotInSun = FALSE + End If + ElseIf pointval = SUNATTR And y# < SunHt Then + If Not SunHit Then DoSun SUNSHOCK + SunHit = TRUE + ShotInSun = TRUE + Else + Impact = TRUE + End If + LookX = LookX + direction + LookY = LookY + Scl(6) + Loop Until Impact Or LookX <> Scl(4) + + If Not ShotInSun And Not Impact Then + 'plot it + rot = (t# * 10) Mod 4 + Call DrawBan(x#, y#, rot, TRUE) + NeedErase = TRUE + End If + + oldx# = x# + oldy# = y# + oldrot = rot + + End If + + + t# = t# + .1 + + Loop + + If pointval <> OBJECTCOLOR And Impact Then + Call DoExplosion(x# + adjust, y# + adjust) + ElseIf pointval = OBJECTCOLOR Then + PlayerHit = ExplodeGorilla(x#) + End If + + PlotShot = PlayerHit +End Function + +'Rest: +' pauses the program +Sub Rest (t#) + If (t# > 0) Then Delay t# +End Sub + +'Scl: +' Pass the number in to scaling for cga. If the number is a decimal, then we +' want to scale down for cga or scale up for ega. This allows a full range +' of numbers to be generated for scaling. +' (i.e. for 3 to get scaled to 1, pass in 2.9) +Function Scl (n!) + If n! <> Int(n!) Then + If Mode = 1 Then n! = n! - 1 + End If + If Mode = 1 Then + Scl = CInt(n! / 2 + .1) + Else + Scl = CInt(n!) + End If +End Function + +'SetScreen: +' Sets the appropriate color statements +Sub SetScreen + If Mode = 9 Then + ExplosionColor = 2 + BackColor = 1 + Palette 0, 1 + Palette 1, 46 + Palette 2, 44 + Palette 3, 54 + Palette 5, 7 + Palette 6, 4 + Palette 7, 3 + Palette 9, 63 'Display Color + Else + ExplosionColor = 2 + BackColor = 0 + Color BackColor, 2 + End If +End Sub + +'SparklePause: +' Creates flashing border for intro and game over screens +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 + Rest .06 + Next A + Wend +End Sub + +'UpdateScores: +' Updates players' scores +'Parameters: +' Record - players' scores +' PlayerNum - player +' Results - results of player's shot +Sub UpdateScores (Record(), PlayerNum, Results) + If Results = HITSELF Then + Record(Abs(PlayerNum - 3)) = Record(Abs(PlayerNum - 3)) + 1 + Else + Record(PlayerNum) = Record(PlayerNum) + 1 + End If +End Sub + +'VictoryDance: +' gorilla dances after he has eliminated his opponent +'Parameters: +' Player - which gorilla is dancing +Sub VictoryDance (Player) + For i# = 1 To 4 + Put (GorillaX(Player), GorillaY(Player)), GorL&(), PSet + before# = Timer(.001) + Play "O0L32EFGEFDC" + Rest .2 + .328 - (Timer(.001) - before#) + Put (GorillaX(Player), GorillaY(Player)), GorR&(), PSet + before# = Timer(.001) + Play "O0L32EFGEFDC" + Rest .2 + .328 - (Timer(.001) - before#) + Next +End Sub + diff --git a/samples/graph.md b/samples/graph.md new file mode 100644 index 0000000..b6d4b58 --- /dev/null +++ b/samples/graph.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: GRAPH + +**[3D Engine Prototypes](3d-engine-prototypes/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [3d](3d.md), [graph](graph.md) + +Various experiments in software 3D graphics. Warning: Uses no functions or subs! diff --git a/samples/graphics.md b/samples/graphics.md index 856ecf9..ad72485 100644 --- a/samples/graphics.md +++ b/samples/graphics.md @@ -2,12 +2,18 @@ ## SAMPLES: GRAPHICS -**[Fire](fire/index.md)** +**[Fire 13](fire-13/index.md)** [🐝 *missing*](author-missing.md) 🔗 [fire](fire.md), [graphics](graphics.md) Fire dominates the lower screen. +**[Fire Demo](fire-demo/index.md)** + +[🐝 harixxx](harixxx.md) 🔗 [graphics](graphics.md), [fire](fire.md) + +_Title "FIRE Demo v1.0" '-----| by harixxx '-----| 6-16-2010 + **[Floormaper](floormaper/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [graphics](graphics.md), [floorscape](floorscape.md) @@ -26,6 +32,18 @@ Graphical Lissajou's Figures. For added eye-candy-ness, I've changed the plot l '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' PIXELplus 256 Us... +**[Plasma Effect](plasma-effect/index.md)** + +[🐝 Cyperium](cyperium.md) 🔗 [graphics](graphics.md), [plasma](plasma.md) + +Use the left mousebutton to draw a line, change color with the right mousebutton, the middle mous... + +**[Relief 3D](relief-3d/index.md)** + +[🐝 Danilin](danilin.md) 🔗 [graphics](graphics.md), [isometric](isometric.md) + +Isometric 3D demo. + **[SineCube](sinecube/index.md)** [🐝 Mennonite](mennonite.md) 🔗 [graphics](graphics.md) diff --git a/samples/gujero2/index.md b/samples/gujero2/index.md index c4febe4..11bfdcf 100644 --- a/samples/gujero2/index.md +++ b/samples/gujero2/index.md @@ -24,9 +24,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "gujero.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/gujero2/src/gujero.bas) -* [RUN "gujero.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/gujero2/src/gujero.bas) -* [PLAY "gujero.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/gujero2/src/gujero.bas) +* [LOAD "gujero.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/gujero2/src/gujero.bas) +* [RUN "gujero.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/gujero2/src/gujero.bas) +* [PLAY "gujero.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/gujero2/src/gujero.bas) ### File(s) diff --git a/samples/hangman.md b/samples/hangman.md new file mode 100644 index 0000000..cfe5e7a --- /dev/null +++ b/samples/hangman.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: HANGMAN + +**[Hangman](hangman/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [game](game.md), [hangman](hangman.md), [dos world](dos-world.md) + +' HANGMAN.BAS by Antonio & Alfonso De Pasquale ' Copyright (C) 1993, 1994 DOS Resource Guide ' ... diff --git a/samples/hangman/img/screenshot.png b/samples/hangman/img/screenshot.png new file mode 100644 index 0000000..e912d0a Binary files /dev/null and b/samples/hangman/img/screenshot.png differ diff --git a/samples/hangman/index.md b/samples/hangman/index.md new file mode 100644 index 0000000..0bc84ea --- /dev/null +++ b/samples/hangman/index.md @@ -0,0 +1,63 @@ +[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: HANGMAN + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 A&A De Pasquale](../a&a-de-pasquale.md) + +### Description + +```text +' HANGMAN.BAS by Antonio & Alfonso De Pasquale +' Copyright (C) 1993, 1994 DOS Resource Guide +' Published in Issue #14, March 1994 + +============================================================================== + +------------- + HANGMAN.BAS +------------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later. + +WHAT HANGMAN.BAS DOES: +Hangman is a classic computer word game that has been played on machinery +ranging from the largest mainframe computer to the smallest programmable +calculator. HANGMAN.BAS implements the game in QBasic. + +The object of the game is to determine what word that the computer is +"thinking of" by guessing letters one at a time. Each incorrect guess brings +you one step closer to the hangman's noose. After six incorrect guesses, +you're "hung," and you lose the game. + +USING HANGMAN.BAS: +To load the program in QBasic, type QBASIC HANGMAN.BAS (using path names if +necessary) at the DOS prompt. Then run the program by selecting the Start +option in QBasic's Run menu, or press Shift-F5. You'll be asked if you wish to +play the game with a default word list provided by the program or with a word +list of your own creation. Either way, you'll be shown the length of the +mystery word and asked to start guessing the letters it contains. Each time +you guess incorrectly, the "body" hanging from the graphical gallows on the +right side of the display will grow: First the head will appear, then the +torso, followed by the arms, then the legs. If the hanging body is fully +formed before you have guessed the word, you lose! + +For further details on HANGMAN.BAS, see DRG #14, March 1994. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "hangman.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/hangman/src/hangman.bas) +* [RUN "hangman.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/hangman/src/hangman.bas) +* [PLAY "hangman.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/hangman/src/hangman.bas) + +### File(s) + +* [hangman.bas](src/hangman.bas) + +🔗 [game](../game.md), [hangman](../hangman.md), [dos world](../dos-world.md) diff --git a/samples/hangman/src/hangman.bas b/samples/hangman/src/hangman.bas new file mode 100644 index 0000000..3baaeea --- /dev/null +++ b/samples/hangman/src/hangman.bas @@ -0,0 +1,271 @@ +' HANGMAN.BAS by Antonio & Alfonso De Pasquale +' Copyright (C) 1993, 1994 DOS Resource Guide +' Published in Issue #14, March 1994 + +DECLARE SUB BOX (R1!, C1!, R2!, C2!) +DECLARE SUB CENTER (M$) + +MAIN: + CLS : CLEAR : BOX 1, 1, 5, 79: COLOR 9 + LOCATE 2, 31: CENTER "** PC Hangman **" + LOCATE 3, 39: CENTER "By" + LOCATE 4, 26: CENTER "Antonio & Alfonso De Pasquale" + COLOR 7: GOSUB DRAWGALLOWS: BOX 9, 1, 20, 42 + LOCATE 11, 4: PRINT "Please select one of the following:" + LOCATE 13, 7: PRINT "

lay with default words" + LOCATE 14, 7: PRINT "oad words from text file" + LOCATE 15, 7: PRINT "uit game" + LOCATE 17, 4: PRINT "Your Choice: " + + K$ = "" + DO WHILE K$ <> "P" AND K$ <> "L" AND K$ <> "Q" + K$ = UCASE$(INKEY$) + LOOP + + IF K$ = "Q" THEN CLS : END + IF K$ = "L" THEN GOSUB USEFILE + IF K$ = "P" THEN + NUMWORDS = 40 + DIM WORD$(NUMWORDS) + FOR X = 1 TO NUMWORDS: READ WORD$(X): NEXT X + END IF + + T1 = VAL(LEFT$(TIME$, 2)): T2 = VAL(MID$(TIME$, 3, 2)) + T3 = VAL(RIGHT$(TIME$, 2)): TT = T1 + T2 + T3 + RANDOMIZE (TT + TT * 100) + DIM LETTER$(26): GOSUB PLAYGAME: GOTO MAIN: END + +PLAYGAME: + FOR X = 6 TO 23: LOCATE X, 1: PRINT SPACE$(79): NEXT X + BOX 7, 1, 11, 42: GOSUB DRAWGALLOWS + X = INT(RND * NUMWORDS) + 1 + SECRET$ = WORD$(X): WLN = LEN(SECRET$): HP1 = INT(21 - WLN / 2) + LOCATE 9, HP1 + + FOR X = 1 TO 26: LETTER$(X) = "": NEXT X + STRIKE = 0: SCORE = 0: CANCEL = 0: NUMLET = 1: UL = 12 + + FOR X = 1 TO WLN + IF MID$(SECRET$, X, 1) <> " " THEN + PRINT "-"; + ELSE + PRINT "/"; + END IF + + IF MID$(SECRET$, X, 1) = " " THEN + SCORE = SCORE + 1 + END IF + NEXT X + + GOSUB PRINTRULES: GOSUB GETLETTERS + IF CANCEL = 1 THEN RETURN + GOTO PLAYGAME + +PRINTRULES: + BOX 12, 1, 16, 42 + LOCATE 13, 3: PRINT "Type in letters that you believe are" + LOCATE 14, 3: PRINT "in the word. You may make as many as" + LOCATE 15, 3: PRINT "six wrong guesses. Press Esc to exit." + BOX 17, 1, 19, 42 + BOX 20, 1, 23, 42 + LOCATE 18, 3: PRINT "Letters:" + RETURN + +GETLETTERS: + K$ = "" + DO WHILE K$ = "" + K$ = INKEY$ + LOOP + + K$ = UCASE$(K$): K = ASC(K$) + IF K$ = CHR$(27) THEN CANCEL = 1: RETURN + IF K < 65 OR K > 90 THEN GOTO GETLETTERS + + USED = 0 + IF NUMLET = 1 THEN LETTER$(NUMLET) = K$ + IF NUMLET > 1 THEN + LETTER$(NUMLET) = K$ + FOR X = 1 TO NUMLET - 1 + IF K$ = LETTER$(X) THEN USED = 1 + NEXT X + END IF + IF USED = 1 THEN GOTO GETLETTERS + NUMLET = NUMLET + 1 + HP2 = HP1: FOUND = 0: + LOCATE 18, UL: PRINT K$: UL = UL + 1 + + FOR X = 1 TO WLN + IF K$ = MID$(SECRET$, X, 1) THEN + LOCATE 9, HP2 + PRINT K$ + FOUND = 1 + SCORE = SCORE + 1 + END IF + HP2 = HP2 + 1 + NEXT X + + IF SCORE >= WLN THEN GOSUB WIN: RETURN + IF FOUND = 0 THEN + SOUND 50, 4 + STRIKE = STRIKE + 1 + SELECT CASE STRIKE + CASE 1 + GOSUB DRAWHEAD + CASE 2 + GOSUB DRAWBODY + CASE 3 + GOSUB DRAWLEFTARM + CASE 4 + GOSUB DRAWRIGHTARM + CASE 5 + GOSUB DRAWLEFTLEG + CASE 6 + GOSUB DRAWRIGHTLEG + GOSUB LOSE + RETURN + END SELECT + END IF + GOTO GETLETTERS + +DRAWGALLOWS: + BOX 7, 46, 23, 79: CH$ = CHR$(177) + COLOR 6: LOCATE 8, 58 + FOR X = 1 TO 16: PRINT CH$; : NEXT X + LOCATE 9, 58: PRINT CH$; CH$ + FOR X = 9 TO 21: LOCATE X, 71: PRINT CH$; CH$; CH$: NEXT X + LOCATE 22, 50: FOR X = 1 TO 26: PRINT CH$; : NEXT X + COLOR 7: RETURN + +DRAWHEAD: + COLOR 10 + FOR X = 10 TO 12 + LOCATE X, 56: FOR Y = 1 TO 6: PRINT CH$; : NEXT Y: NEXT X + COLOR 7: RETURN + +DRAWBODY: + COLOR 10 + FOR X = 13 TO 18: LOCATE X, 58: PRINT CH$; CH$: NEXT X + COLOR 7: RETURN + +DRAWLEFTARM: + COLOR 10 + LOCATE 14, 52: PRINT CH$; CH$; CH$; CH$; CH$; CH$ + LOCATE 15, 52: PRINT CH$; CH$ + COLOR 7: RETURN + +DRAWRIGHTARM: + COLOR 10 + LOCATE 14, 60: PRINT CH$; CH$; CH$; CH$; CH$; CH$ + LOCATE 15, 64: PRINT CH$; CH$ + COLOR 7: RETURN + +DRAWLEFTLEG: + COLOR 10 + LOCATE 18, 54: FOR X = 1 TO 5: PRINT CH$; : NEXT X + LOCATE 19, 54: PRINT CH$; CH$ + LOCATE 20, 54: PRINT CH$; CH$ + COLOR 7: RETURN + +DRAWRIGHTLEG: + COLOR 10 + LOCATE 18, 59: FOR X = 1 TO 5: PRINT CH$; : NEXT X + LOCATE 19, 62: PRINT CH$; CH$ + LOCATE 20, 62: PRINT CH$; CH$ + COLOR 7: RETURN + +LOSE: + COLOR 4: LOCATE 21, 5: PRINT "Sorry! You didn't guess the word." + LOCATE 22, 5: PRINT "Press Enter to play again or exit." + LOCATE 9, HP1: PRINT SECRET$: COLOR 7 + PLAY "P4 O1 C3 C3 C8 C3 E-4 D8 D4 C8 C4 O0 B8 O1 C2" + DO: LOOP UNTIL INKEY$ = CHR$(13): RETURN + +WIN: + COLOR 2: LOCATE 21, 5: PRINT "Well Done! You guessed the word!" + LOCATE 22, 5: PRINT "Press Enter to play again or exit." + COLOR 14: LOCATE 9, HP1: PRINT SECRET$: COLOR 7 + PLAY "P4 O2 F+8 E8 F+8 G4 O1 G4 B4 O2 D2" + DO: LOOP UNTIL INKEY$ = CHR$(13): RETURN + +USEFILE: + FOR X = 9 TO 20: LOCATE X, 1: PRINT SPACE$(42): NEXT X + BOX 10, 1, 20, 42 + LOCATE 12, 4: PRINT "Type in the name of the file that" + LOCATE 13, 4: PRINT "contains the words you wish to use" + LOCATE 15, 4: PRINT "["; SPACE$(34); "]" + LOCATE 15, 5: INPUT "", NAME$ + IF NAME$ = "" THEN GOTO MAIN + + ON ERROR GOTO NOFILE + OPEN NAME$ FOR INPUT AS #1 + LOCATE 17, 5: PRINT "Now reading file. Please wait..." + + DIM WORD$(750): PASS = 1 + DO WHILE (NOT EOF(1)) AND (PASS < 750) + LINE INPUT #1, LINE$ + TWORD$ = "" + + FOR X = 1 TO LEN(LINE$) + CHAR$ = UCASE$(MID$(LINE$, X, 1)) + IF ASC(CHAR$) > 64 AND ASC(CHAR$) < 91 THEN + TWORD$ = TWORD$ + CHAR$ + ELSE + IF LEN(TWORD$) > 4 THEN + WORD$(PASS) = UCASE$(TWORD$) + PASS = PASS + 1 + END IF + TWORD$ = "" + END IF + NEXT X + + LOOP + CLOSE #1: NUMWORDS = PASS: RETURN + +NOFILE: + SOUND 600, 4 + LOCATE 17, 5: PRINT "The filename you supplied does" + LOCATE 18, 5: PRINT "not exist. Press Enter" + DO UNTIL INKEY$ = CHR$(13): LOOP: GOTO MAIN + +DATASECTION: + DATA AUTOGRAPH, SCIENCE FICTION, SUBMARINE, MAGAZINE, FANTASY, ALIEN + DATA MONSTER, COMMANDER, CALENDAR, COMIC BOOK, SIGNATURE, PROGRAM + DATA FLOPPY DISK, MOUSE, JOYSTICK, COMPACT DISC, JAZZ, TELEVISION SET + DATA LOTTERY, SOCIAL SECURITY, BATMAN AND ROBIN, AUTUMN, DILEMMA + DATA SPLENDID, RECEPTIONIST, MORPHOLOGY, DISHONEST, TWILIGHT ZONE + DATA CLINT EASTWOOD, SEAN CONNERY, STAR TREK, I LOVE LUCY, POSTCARD + DATA GONE WITH THE WIND, WAR AND PEACE, DUKE ELLINGTON, BILL COSBY + DATA KIRK DOUGLAS, KIRK AND SPOCK, MILES DAVIS + + END + +SUB BOX (R1, C1, R2, C2) + + LOCATE R1, C1 + PRINT CHR$(218); + FOR X = (C1 + 1) TO (C2 - 1) + PRINT CHR$(196); + NEXT X + PRINT CHR$(191) + + FOR X = (R1 + 1) TO (R2 - 1) + LOCATE X, C1 + PRINT CHR$(179); SPACE$(C2 - C1 - 1); CHR$(179) + NEXT X + + LOCATE R2, C1 + PRINT CHR$(192); + FOR X = (C1 + 1) TO (C2 - 1) + PRINT CHR$(196); + NEXT X + PRINT CHR$(217) + +END SUB + +SUB CENTER (M$) + + LN = LEN(M$) + PRINT TAB(40 - LN / 2); M$ + +END SUB + diff --git a/samples/hardin-brothers.md b/samples/hardin-brothers.md new file mode 100644 index 0000000..c8ebf6e --- /dev/null +++ b/samples/hardin-brothers.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 BY HARDIN BROTHERS + +**[Colors](colors/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [color picker](color-picker.md), [dos world](dos-world.md) + +' COLORS.BAS ' Copyright (c) 1993 DOS Resource Guide ' Published in Issue #12, November 199... + +**[Cram](cram/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [game](game.md), [dos world](dos-world.md) + +'CRAM! ' by Hardin Brothers ' ' Copyright (C) 1993 DOS Resource Guide ' Published in Issue ... + +**[Phone](phone/index.md)** + +[🐝 Hardin Brothers](hardin-brothers.md) 🔗 [data management](data-management.md), [dos world](dos-world.md) + +' ' PHONE.BAS by Hardin Brothers ' Copyright (C) 1992 DOS Resource Guide ' Published in Issue ... diff --git a/samples/harixxx.md b/samples/harixxx.md new file mode 100644 index 0000000..c77ce11 --- /dev/null +++ b/samples/harixxx.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 HARIXXX + +**[Fire Demo](fire-demo/index.md)** + +[🐝 harixxx](harixxx.md) 🔗 [graphics](graphics.md), [fire](fire.md) + +_Title "FIRE Demo v1.0" '-----| by harixxx '-----| 6-16-2010 diff --git a/samples/hex.md b/samples/hex.md new file mode 100644 index 0000000..439efcf --- /dev/null +++ b/samples/hex.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: HEX + +**[XE Hex Editor](xe-hex-editor/index.md)** + +[🐝 Dav](dav.md) 🔗 [editor](editor.md), [hex](hex.md) + +'============ 'XE.BAS v1.10 '============ 'A simple Binary File (HEX) editor. 'Coded by Dav on AU... diff --git a/samples/hunter/img/screenshot.png b/samples/hunter/img/screenshot.png new file mode 100644 index 0000000..056a7ab Binary files /dev/null and b/samples/hunter/img/screenshot.png differ diff --git a/samples/hunter/index.md b/samples/hunter/index.md new file mode 100644 index 0000000..ae3cc91 --- /dev/null +++ b/samples/hunter/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: HUNTER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Microsoft](../microsoft.md) + +### Description + +```text +Maze hunter game by Microsoft. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "hunter.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/hunter/src/hunter.bas) +* [RUN "hunter.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/hunter/src/hunter.bas) +* [PLAY "hunter.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/hunter/src/hunter.bas) + +### File(s) + +* [hunter.bas](src/hunter.bas) + +🔗 [game](../game.md), [maze](../maze.md) diff --git a/samples/hunter/src/hunter.bas b/samples/hunter/src/hunter.bas new file mode 100644 index 0000000..03b6f3e --- /dev/null +++ b/samples/hunter/src/hunter.bas @@ -0,0 +1,433 @@ +$NoPrefix +DefInt A-Z +$Resize:Smooth + +'declare types +Type bulletType + row As Integer + col As Integer + direction As Integer + bcolor As Integer +End Type + +Type playerType + row As Integer + col As Integer + direction As Integer + score As Integer + icon As String * 1 + iconColor As Integer +End Type + +'declare constants +Const FALSE = 0, TRUE = Not FALSE + +'declare global arrays +Dim Shared arena$(25) 'String representation of playing field. Used to +'Make creating/drawing the field easier +Dim Shared map(25, 80) 'Represents the screen. There is 1 array location +'for every screen char. the value of a element of +'map(row,col) will be one of the following: +' 0 : Nothing there +' 1 : Wall +' 2 : Player +' 3 : bullet +'The use of map() speeds up the game +'considerably, since it has a quick way of +'knowing where things are. + + +Initialize +DoIntro +DrawScreen +Hunter + +System 0 + +'Add bullet to bullet array +Sub AddBullet (bullet() As bulletType, numBullets, direction, player As playerType) + If numBullets < 10 Then + numBullets = numBullets + 1 + bullet(numBullets).row = player.row + bullet(numBullets).col = player.col + bullet(numBullets).direction = direction + bullet(numBullets).bcolor = player.iconColor + MoveBullet bullet(numBullets) + End If +End Sub + +' Center a text string at row ROW +Sub Center (row, text$) + Locate row, 41 - Len(text$) / 2 + Print text$; +End Sub + +'Goes through bullet array, and removes any bullet with direction of 0, +Sub DeleteBullets (bullet() As bulletType, numBullets) + top = 0 'num bullets in the new array + curr = 1 'current index into the array + While curr <= numBullets + If bullet(curr).direction = 0 Then + HideBullet bullet(curr) + Else + top = top + 1 + bullet(top).row = bullet(curr).row + bullet(top).col = bullet(curr).col + bullet(top).direction = bullet(curr).direction + bullet(top).bcolor = bullet(curr).bcolor + End If + curr = curr + 1 + Wend + numBullets = top +End Sub + +Sub DoIntro + Width , 25 + View Print + Locate , , 0 + + Color 12, 1 + Cls + Center 3, "Q u i c k B A S I C M A Z E H U N T E R" + Color 14 + Center 5, "INSTRUCTIONS: Maze Hunter is a two player game! Your goal is to hunt down" + Center 6, "and kill your enemy in the maze. " + + Color 15 + Center 8, "The following keys are used while playing this game" + Center 10, "Left Player Move Up: t Right Player Move Up: 8" + Center 11, "Left Player Move Left: f Right Player Move Left: 4" + Center 12, "Left Player Move Down: g Right Player Move Down: 5" + Center 13, "Left Player Move Right: h Right Player Move Right: 6" + + Center 15, "Left Player Shoot Up: w Right Player Shoot Up: p" + Center 16, "Left Player Shoot Left: a Right Player Shoot Left: l" + Center 17, "Left Player Shoot Down: s Right Player Shoot Down: ;" + Center 18, "Left Player Shoot Right: d Right Player Shoot Right: '" + + + Center 22, "[-] Decrease Game Delay [+] Increase Game Delay [Esc] Stop play" + + + Center 25, "Push Any Key To Continue" + Color 11 + SparklePause +End Sub + +Sub DrawScreen + Color 14, 1 + Cls + View Print + For a = 1 To 25 + Locate a, 1 + Print arena$(a); + Next a +End Sub + +'Prints a space over the location of the bullet +Sub HideBullet (bullet As bulletType) + Locate bullet.row, bullet.col + Print " "; + map(bullet.row, bullet.col) = 0 +End Sub + +'Draws a space over the player icon, thus hiding it +Sub HidePlayer (player As playerType) + Locate player.row, player.col + Print " "; + map(player.row, player.col) = 0 +End Sub + +Sub Hunter + 'dimension bullet array and players + Dim bullet(100) As bulletType + Dim player1 As playerType + Dim player2 As playerType + + 'initialize players + player1.icon = Chr$(1) + player1.row = 12 + player1.col = 2 + player1.direction = 0 + player1.score = 0 + player1.iconColor = 12 + + player2.icon = Chr$(2) + player2.row = 12 + player2.col = 79 + player2.direction = 0 + player2.score = 0 + player2.iconColor = 11 + + numBullets = 0 + + ShowPlayer player1 + ShowPlayer player2 + + finished = FALSE + tickMax = 25 'delay factor + + Do + Color 15 + Do 'Do until escape key hit + Do 'Action Game loop + tick = (tick + 2) Mod tickMax - 1 + If tick = 0 Then + Color 15, 1 + Center 1, Str$(player2.score) + " > score <" + Str$(player1.score) + " " + MovePlayer player1 + MovePlayer player2 + MoveBullets bullet(), numBullets + DeleteBullets bullet(), numBullets + Else + kbd$ = InKey$ + End If + Loop While kbd$ = "" + + 'handle keystrokes + Select Case kbd$ + Case "-": GoSub HunterDecreaseGameDelay + Case "+": GoSub HunterIncreaseGameDelay + Case "w", "W": AddBullet bullet(), numBullets, 1, player1 + Case "a", "A": AddBullet bullet(), numBullets, 3, player1 + Case "s", "S": AddBullet bullet(), numBullets, 2, player1 + Case "d", "D": AddBullet bullet(), numBullets, 4, player1 + Case "t", "T": If player1.direction = 2 Then player1.direction = 0 Else player1.direction = 1 + Case "f", "F": If player1.direction = 4 Then player1.direction = 0 Else player1.direction = 3 + Case "g", "G": If player1.direction = 1 Then player1.direction = 0 Else player1.direction = 2 + Case "h", "H": If player1.direction = 3 Then player1.direction = 0 Else player1.direction = 4 + Case "p", "P": AddBullet bullet(), numBullets, 1, player2 + Case "l", "l": AddBullet bullet(), numBullets, 3, player2 + Case ";": AddBullet bullet(), numBullets, 2, player2 + Case "'": AddBullet bullet(), numBullets, 4, player2 + Case "8": If player2.direction = 2 Then player2.direction = 0 Else player2.direction = 1 + Case "5": If player2.direction = 1 Then player2.direction = 0 Else player2.direction = 2 + Case "2": If player2.direction = 1 Then player2.direction = 0 Else player2.direction = 2 + Case "4": If player2.direction = 4 Then player2.direction = 0 Else player2.direction = 3 + Case "6": If player2.direction = 3 Then player2.direction = 0 Else player2.direction = 4 + Case Chr$(27): finished = TRUE + Case Else + End Select + Loop Until finished + Loop Until score1 = 5 Or score2 = 5 Or finished + Exit Sub + + HunterDecreaseGameDelay: + If tickMax > 2 Then + tickMax = tickMax - 1 + End If + Color 15 + Locate 1, 60 + Print " Delay ="; tickMax - 1; " " + Return + + HunterIncreaseGameDelay: + Color 15 + tickMax = tickMax + 1 + Locate 1, 60 + Print " Delay ="; tickMax - 1; " " + Return +End Sub + +Sub Initialize + 'insure random maze + Randomize Timer + + 'setup boarder + arena$(1) = "" + String$(78, "") + "" + arena$(25) = "" + String$(78, "") + "" + For a = 2 To 24 + arena$(a) = "" + Space$(78) + "" + Next a + + 'draw maze elements + For a = 1 To 15 + row = Rnd(1) * 20 + 3 + col = Rnd(1) * 70 + 5 + Mid$(arena$(row), col, 1) = Chr$(197) + Mid$(arena$(row - 1), col, 1) = Chr$(179) + Mid$(arena$(row + 1), col, 1) = Chr$(179) + Mid$(arena$(row), col - 1, 1) = Chr$(196) + Mid$(arena$(row), col - 2, 1) = Chr$(196) + Mid$(arena$(row), col + 1, 1) = Chr$(196) + Mid$(arena$(row), col + 2, 1) = Chr$(196) + Next a + + 'Scan through arena$() and where evere there is a wall, put a + '1 in the map array to indicate it's location. Put a 0 wherever there + 'is a blank space + For row = 1 To 25 + For col = 1 To 80 + If Mid$(arena$(row), col, 1) = " " Then + map(row, col) = 0 + Else + map(row, col) = 1 + End If + Next col + Next row +End Sub + +Sub MoveBullet (bullet As bulletType) + 'Move the bullet based on the direction. + Select Case bullet.direction + Case 0 + Case 1 'up + Select Case map(bullet.row - 1, bullet.col) + Case 0, 2, 3 + HideBullet bullet + bullet.row = bullet.row - 1 + ShowBullet bullet + Case 1 + bullet.direction = 0 + End Select + Case 2 'down + Select Case map(bullet.row + 1, bullet.col) + Case 0, 2, 3 + HideBullet bullet + bullet.row = bullet.row + 1 + ShowBullet bullet + Case 1 + bullet.direction = 0 + End Select + Case 3 'left + Select Case map(bullet.row, bullet.col - 1) + Case 0, 2, 3 + HideBullet bullet + bullet.col = bullet.col - 1 + ShowBullet bullet + Case 1 + bullet.direction = 0 + End Select + Case 4 'right + Select Case map(bullet.row, bullet.col + 1) + Case 0, 2, 3 + HideBullet bullet + bullet.col = bullet.col + 1 + ShowBullet bullet + Case 1 + bullet.direction = 0 + End Select + End Select +End Sub + +'Move every bullet in the bullet array +Sub MoveBullets (bullet() As bulletType, numBullets) + a = 1 + While a <= numBullets + MoveBullet bullet(a) + a = a + 1 + Wend + Delay .03 +End Sub + +'based on the direction of the player, move the player +Sub MovePlayer (player As playerType) + 'if bullet hit the player, inc score + If map(player.row, player.col) = 3 Then + player.score = player.score + 1 + Beep + End If + + Select Case player.direction + Case 0 'no motion + ShowPlayer player + Case 1 'up + Select Case map(player.row - 1, player.col) + Case 0 'nothing + HidePlayer player + player.row = player.row - 1 + ShowPlayer player + Case 1, 2 'wall,enemy + player.direction = 0 + Case 3 'bullet + player.score = player.score + 1 + Beep + End Select + Case 2 'down + Select Case map(player.row + 1, player.col) + Case 0 'nothing + HidePlayer player + player.row = player.row + 1 + ShowPlayer player + Case 1, 2 'wall,enemy + player.direction = 0 + Case 3 'bullet + player.score = player.score + 1 + Beep + End Select + Case 3 'left + Select Case map(player.row, player.col - 1) + Case 0 'nothing + HidePlayer player + player.col = player.col - 1 + ShowPlayer player + Case 1, 2 'wall,enemy + player.direction = 0 + Case 3 'bullet + player.score = player.score + 1 + Beep + End Select + Case 4 'right + Select Case map(player.row, player.col + 1) + Case 0 'nothing + HidePlayer player + player.col = player.col + 1 + ShowPlayer player + Case 1, 2 'wall,enemy + player.direction = 0 + Case 3 'bullet + player.score = player.score + 1 + Beep + End Select + End Select + + Delay .003 +End Sub + +'print the bullet char at bullet location +Sub ShowBullet (bullet As bulletType) + Color bullet.bcolor + Locate bullet.row, bullet.col + Print Chr$(4); + map(bullet.row, bullet.col) = 3 +End Sub + +'show player icon in player color at player location +Sub ShowPlayer (player As playerType) + Color player.iconColor + Locate player.row, player.col + Print player.icon; + map(player.row, player.col) = 2 +End Sub + +Sub SparklePause + a$ = "* * * * * * * * * * * * * * * * * " + + While InKey$ = "" + 'print horizontal sparkles + For a = 1 To 5 + Locate 1, 1 + Print Mid$(a$, a, 80); + Locate 20, 1 + Print Mid$(a$, 6 - a, 80); + + 'print vertical sparkles + For b = 2 To 19 + c = (a + b) Mod 5 + If c = 1 Then + Locate b, 80 + Print "*"; + Locate 21 - b, 1 + Print "*"; + Else + Locate b, 80 + Print " "; + Locate 21 - b, 1 + Print " "; + End If + Next b + Delay .06 + Next a + Wend +End Sub + diff --git a/samples/hunters-revenge/img/screenshot.png b/samples/hunters-revenge/img/screenshot.png new file mode 100644 index 0000000..67be68a Binary files /dev/null and b/samples/hunters-revenge/img/screenshot.png differ diff --git a/samples/hunters-revenge/index.md b/samples/hunters-revenge/index.md new file mode 100644 index 0000000..b763e23 --- /dev/null +++ b/samples/hunters-revenge/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: HUNTERS REVENGE + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Ashish Kushwaha](../ashish-kushwaha.md) + +### Description + +```text +# Hunter-Revenge +A shooting game created in QB64 +``` + +### File(s) + +* [main.bas](src/main.bas) +* [main.zip](src/main.zip) + +🔗 [game](../game.md), [shooter](../shooter.md) diff --git a/samples/hunters-revenge/src/main.bas b/samples/hunters-revenge/src/main.bas new file mode 100644 index 0000000..2dc80ab --- /dev/null +++ b/samples/hunters-revenge/src/main.bas @@ -0,0 +1,2660 @@ +'################################################################ +' H U N T E R ' S R E V E N G E 2 0 1 7 - 1 8 +' By Ashish Kushwaha +' **** Hit F5 and Enjoy the Game!! **** +'Note :- +'The executable should be inside Hunter-Revenge folder +'If you are facing any problem, report it at Qb64.org Forum +' +'*** Tell Me You You Think About This Game On Twitter with @KingOfCoders *** +' +'################################################################ + +'$CONSOLE +'_CONSOLETITLE "Hunter's Revenge [DEBUG_OUTPUT]" + +If Command$(1) = "--reset" Then + Dim dummy As String + Input "Are you sure that you want to reset the game? (Y/N) ", dummy + If UCase$(dummy) = "Y" Then Kill "Save_Game/save.dat": createConfig: System +End If + +'App icon +$ExeIcon:'./Images/game.ico' +Dim tmp_icon As Long +tmp_icon& = _LoadImage("Images/cursor.png", 32) +_ClearColor _RGB(255, 255, 255), tmp_icon& +_Icon tmp_icon& +_FreeImage tmp_icon& + +Do: Loop Until _ScreenExists +Randomize Timer +'$include:'Vendor/spritetop.bi' +_Delay 1 +_MouseHide + +_Title "Hunter's Revenge" + +Screen _NewImage(800, 600, 32) +Do: Loop Until _ScreenExists + +' ON ERROR GOTO 404 + +_DisplayOrder _Software , _Hardware , _GLRender , _Hardware1 + +'Notification Section +Dim Shared NEvent, NFPSCount%, NImage&, NText$, NShow As _Byte + +'Frame Rate Section +Dim Shared FPSEvent, FPSEvt, FPSCurrent%, FPSRate%, FPSBg& + +'Loader Section +Dim Shared Loader&, LoaderX%, LoaderY%, LoaderCF%, LoaderEvt! +LoaderX% = 730: LoaderY% = 500 + +'Game Types +Type GameMenu + click As _Byte + hover As _Byte + y As Integer + img As Long + img2 As Long 'software image +End Type + +Type Mousetype + x As Integer + y As Integer + lclick As _Byte + rclick As _Byte + mclick As _Byte + cursor As Long + cursor2 As Long + hovering As _Byte +End Type + +Type fonttype + smaller As Long + normal As Long + bigger As Long + biggest As Long +End Type +'game objects + +Type explosiontype + x As Integer + y As Integer + img As Integer + active As _Byte + currentFrame As Integer + totalFrames As Integer + f As Integer + n As Integer +End Type + +Type guntype + name As String * 32 + damage As Integer + id As Integer + img As Long +End Type + +Type Enemies + x As Integer ' x position + y As Integer ' y position + typ As String * 16 'type of enemie + life As Integer 'life of the enemie + life2 As Integer 'backup of life + damage As Integer 'useless + ending As _Byte 'enemie is dead or not + img As Integer 'sprite handle + active As _Byte 'enemie is active or not + u As Long 'delay (in milliseconds) after which enemie will show up in his scene in gameplay + n As Integer 'delay between change of frame of animation + f As Integer 'increment varible, if greater than above 'n', then frame is change + m As Double 'movement speed + points As Integer 'holds point + scene As Integer 'hold scene + snd As Long 'hold sound handle + sndPaused As _Byte ' = true when sound is paused. +End Type + +Type Levels + enemies As Integer 'total enemies in a level + scenes As Integer 'total scenes in a level + currentScene As Integer 'current scene of the gameplay + completed As _Byte 'level has been completed or not + u As Long 'current frame of the gameplay (always increases during gameplay) + over As _Byte ' level has been over or not + background As String * 64 'background image path of the level + bg As Long 'background image handle of the level + mode As Integer 'MODs of the game. Can be either THUNDERMODE, STORMMODE, FOGMODE, THUNDERMODE+FOGMODE, THUNDERMODE+STORMMODE + cancel As _Byte 'level has been cancel or not + time As _Unsigned Integer 'number of seconds a level has to be completed in (in seconds). +End Type + +Type fog + x As Integer + move As Integer + handle As Long +End Type + +Type drops + x As Integer + y As Integer + z As Integer + len As Double + yspeed As Double + gravity As Double +End Type + +Type Settings + fullscreen As _Byte + music As _Byte + sfx As _Byte + musicV As Double + sfxV As Double + SE As _Byte + fps As Integer + done As _Byte +End Type + +'score flasher +Type scoreFlasher + x As Single + y As Single + img As Long + active As _Byte + sclX As Single + sclY As Single + __ops As Single +End Type + +' TYPE Vector_Particles_Text_Type +' x AS SINGLE 'x position +' y AS SINGLE 'y position +' vx AS SINGLE 'visual x +' vy AS SINGLE 'visual y +' delX AS SINGLE 'delta velocity +' delY AS SINGLE 'delta velocity +' dist AS SINGLE 'distance +' distX AS SINGLE ' distance x +' distY AS SINGLE 'distance y +' k AS SINGLE +' END TYPE + +'$DYNAMIC + +Randomize Timer +Dim Shared W As Settings +readConfig + +'DIM SHARED Paused AS _BYTE + +'REDIM SHARED Text_Particles(1) AS Vector_Particles_Text_Type + +'DIM SHARED Text_Particles_Status, Text_Particles_Color AS _UNSIGNED LONG + +Dim Shared randomLevels As _Byte 'Computer chooses level! ^_* + +Dim Shared Menubg&, GlobalEvent As Single, TimerEvent, GameRenderingEvent, Minutes%, Seconds% + +Dim Shared Mouse As Mousetype + +Dim Shared Fonts As fonttype + +Dim Shared GameMenus(19) As GameMenu + +Dim Shared MenuBlood%, MenuChoice + +Dim Shared ShotScore(5) As scoreFlasher + +Dim Shared explosions(20) As explosiontype, Gun As guntype, Bloods(50) As explosiontype + +Dim Shared Level As Levels + +Dim Shared HighScore%, LevelStage%, LevelStage2%, CurrentScore% + +Dim Shared ScoreBoard&, GunImg&(1), OldScore%, OldSeconds% + +Dim Shared Musics&(2) + +Randomize Timer +'Rains +Dim Shared Drop(700) As drops +Dim Shared Rainx8&, Rainx16&, RainLight&, RainSound&, RainVol#, ThunderCount, ThunderEvent + + + +'max level +Const MAX_LEVEL = 14 +'storm +Dim Shared StormImg&, StormX% + +'Sparks +Dim Shared ExplosionsZ(1) As explosiontype + +'MODS +Const FOGMODE = 1 +Const THUNDERMODE = 3 +Const STORMMODE = 5 +Dim Shared Fogs As fog + +'SFXs +Dim Shared Eagle& +Dim Shared Bird& +Dim Shared Crow& +Dim Shared Expos& +Dim Shared Jet& +Dim Shared Gun1& +Dim Shared Gun2& + +'Enemies scores image +Dim Shared scoresImage(5) As Long + +ReDim Shared Enemie(0) As Enemies + +Dim Shared Jet1_Sheet% +Dim Shared Jet2_Sheet% +Dim Shared Jet3_Sheet% +Dim Shared Bird_Sheet% +Dim Shared Crow_Sheet% +Dim Shared eagle_Sheet% +Dim Shared blood_Sheet% +Dim Shared explosion_Sheet% +Dim Shared spark_Sheet% +Dim Shared lifeBars(99) As Long + +FPSEvent = _FreeTimer 'Event for showing current FPS (Frame Per Second) +FPSEvt = _FreeTimer 'Event for calculating current FPS (Frame Per Second) +GlobalEvent = _FreeTimer 'Event for game main menu +TimerEvent = _FreeTimer 'Event of timer which is displayed during gameplay +GameRenderingEvent = _FreeTimer 'Event in which level objects are rendered. +NEvent = _FreeTimer ' Global Event for notification + +'Splash Screen + +Splash + + +LoaderStart + +loadComponents +'cursors +Mouse.cursor = _LoadImage("Images/cursor.png", 33) +Mouse.cursor2 = _LoadImage("Images/cursor2.png", 33) + +'fonts +Fonts.biggest = _LoadFont("Font/ARDESTINE.ttf", 68) +Fonts.bigger = _LoadFont("Font/ARDESTINE.ttf", 40) +Fonts.smaller = _LoadFont("Font/arial.ttf", 12, "dontblend") +Fonts.normal = _LoadFont("Font/ARDESTINE.ttf", 24) + +'scores image + +scoresImage(0) = _LoadImage("Images/10.png", 33) +scoresImage(1) = _LoadImage("Images/20.png", 33) +scoresImage(2) = _LoadImage("Images/35.png", 33) +scoresImage(3) = _LoadImage("Images/50.png", 33) +scoresImage(4) = _LoadImage("Images/75.png", 33) +scoresImage(5) = _LoadImage("Images/100.png", 33) + +'fogs +Fogs.x = 0 +Fogs.move = 1 +Fogs.handle = _LoadImage("Images/fogs_.png", 33) + +'rains +Rainx8& = _LoadImage("Images/rainx8.png", 33) +Rainx16& = _LoadImage("Images/rainx16.png", 33) + + +'storm +StormImg& = _LoadImage("Images\storm.png", 33) 'we're using hardware image + +'LifeBars +Dim i As Integer, r As Integer, g As Integer +For i = 0 To 99 + lifeBars(i) = _NewImage(100, 6, 32) + _Dest lifeBars(i) + r = p5map(i + 1, 1, 100, 255, 0) + g = p5map(i + 1, 1, 100, 0, 255) + Line (0, 0)-(100, 6), _RGB(0, 0, 0), BF + Line (0, 0)-(i + 1, 6), _RGB(r, g, 0), BF + Line (0, 0)-(99, 5), _RGB(255, 255, 255), B + _Dest 0 +Next + +Dim tmp& +For i = 0 To 99 + tmp& = _CopyImage(lifeBars(i)) + _FreeImage lifeBars(i) + lifeBars(i) = _CopyImage(tmp&, 33) + _FreeImage tmp& +Next + +Gun.damage = 3 +Gun.id = 1 +Gun.name = "Shot Gun" + +Menubg& = _LoadImage("Images\farm1.jpg") +GunImg&(0) = _LoadImage("Images\gun_shot.png") +GunImg&(1) = _LoadImage("Images\Gun_ak-47.png") +ScoreBoard& = _LoadImage("Images\score_board.png") + +blood_Sheet% = SPRITESHEETLOAD("Images\blood.png", 64, 62, _RGB(0, 0, 0)) +Jet1_Sheet% = SPRITESHEETLOAD("Images\Jet.png", 120, 122, _RGB(0, 0, 0)) +Jet2_Sheet% = SPRITESHEETLOAD("Images\Jet_2.png", 120, 122, _RGB(0, 0, 0)) +Jet3_Sheet% = SPRITESHEETLOAD("Images\Jet_3.png", 150, 122, _RGB(0, 0, 0)) +eagle_Sheet% = SPRITESHEETLOAD("Images\eagle.png", 40, 40, _RGB(0, 0, 0)) +Crow_Sheet% = SPRITESHEETLOAD("Images\crow.png", 97, 120, _RGB(0, 0, 0)) +Bird_Sheet% = SPRITESHEETLOAD("Images\bird.png", 180, 170, _RGB(0, 0, 0)) + +explosion_Sheet% = SPRITESHEETLOAD("Images\explosion.png", 100, 100, _RGB(0, 0, 0)) + +For i = 0 To 1 + ExplosionsZ(i).img = SPRITENEW(explosion_Sheet%, 1, SAVE) + SPRITEANIMATESET ExplosionsZ(i).img, 1, 81 + ExplosionsZ(i).y = 300 +Next + +ExplosionsZ(0).x = 100: ExplosionsZ(1).x = 700 + +For i = 0 To 20 + Bloods(i).img = SPRITENEW(blood_Sheet%, 1, SAVE) + SPRITEANIMATESET Bloods(i).img, 1, 6 + explosions(i).img = SPRITENEW(explosion_Sheet%, 1, SAVE) + SPRITEANIMATESET explosions(i).img, 1, 81 + Bloods(i).totalFrames = 6 + Bloods(i).n = 5 + explosions(i).totalFrames = 81 + explosions(i).n = 4 +Next +MenuBlood% = SPRITENEW(blood_Sheet%, 1, SAVE) +SPRITEANIMATESET MenuBlood%, 1, 6 + + + +'Setup Notificaton stuff +On Timer(NEvent, .013) Notify +Timer(NEvent) On + +_Font Fonts.bigger + +tmp& = _NewImage(400, 60, 32) +_Dest tmp& +_Font Fonts.bigger +Color , _RGBA(0, 0, 0, 0) +_PrintString (CenterPrintX("Play"), 0), "Play" +_Dest 0 +GameMenus(0).img = _CopyImage(tmp&, 33) +GameMenus(0).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(0).y = 150 + +tmp& = _NewImage(400, 60, 32) +_Dest tmp& +_Font Fonts.bigger +Color , _RGBA(0, 0, 0, 0) +_PrintString (CenterPrintX("Options"), 0), "Options" +_Dest 0 +GameMenus(1).img = _CopyImage(tmp&, 33) +GameMenus(1).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(1).y = GameMenus(0).y + 60 + +tmp& = _NewImage(400, 60, 32) +_Dest tmp& +_Font Fonts.bigger +Color , _RGBA(0, 0, 0, 0) +_PrintString (CenterPrintX("Help"), 0), "Help" +_Dest 0 +GameMenus(2).img = _CopyImage(tmp&, 33) +GameMenus(2).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(2).y = GameMenus(1).y + 60 + +tmp& = _NewImage(400, 60, 32) +_Dest tmp& +_Font Fonts.bigger +Color , _RGBA(0, 0, 0, 0) +_PrintString (CenterPrintX("Credits"), 0), "Credits" +_Dest 0 +GameMenus(3).img = _CopyImage(tmp&, 33) +GameMenus(3).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(3).y = GameMenus(2).y + 60 + +tmp& = _NewImage(400, 60, 32) +_Dest tmp& +_Font Fonts.bigger +Color , _RGBA(0, 0, 0, 0) +_PrintString (CenterPrintX("Exit"), 0), "Exit" +_Dest 0 +GameMenus(4).img = _CopyImage(tmp&, 33) +GameMenus(4).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(4).y = GameMenus(3).y + 60 + + +tmp& = _NewImage(400, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "Fullscreen" +_Dest 0 +GameMenus(5).img = _CopyImage(tmp&, 33) +GameMenus(5).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(5).y = 113 + +tmp& = _NewImage(400, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "Fullscreen Method " +_Dest 0 +GameMenus(6).img = _CopyImage(tmp&, 33) +GameMenus(6).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(6).y = GameMenus(5).y + 34 + +tmp& = _NewImage(400, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "Music " +_Dest 0 +GameMenus(7).img = _CopyImage(tmp&, 33) +GameMenus(7).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(7).y = GameMenus(6).y + 34 + +tmp& = _NewImage(400, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "SFX " +_Dest 0 +GameMenus(8).img = _CopyImage(tmp&, 33) +GameMenus(8).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(8).y = GameMenus(7).y + 34 + +tmp& = _NewImage(400, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "Music Volume " +_Dest 0 +GameMenus(9).img = _CopyImage(tmp&, 33) +GameMenus(9).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(9).y = GameMenus(8).y + 34 + +tmp& = _NewImage(400, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "SFX Volume" +_Dest 0 +GameMenus(10).img = _CopyImage(tmp&, 33) +GameMenus(10).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(10).y = GameMenus(9).y + 34 + +tmp& = _NewImage(400, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "3D Sound Effect" +_Dest 0 +GameMenus(11).img = _CopyImage(tmp&, 33) +GameMenus(11).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(11).y = GameMenus(10).y + 34 + +tmp& = _NewImage(400, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "Frame Rate " +_Dest 0 +GameMenus(12).img = _CopyImage(tmp&, 33) +GameMenus(12).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(12).y = GameMenus(11).y + 34 + +tmp& = _NewImage(500, 30, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (CenterPrintX("Default Settings"), 0), "Default Settings" +_Dest 0 +GameMenus(13).img = _CopyImage(tmp&, 33) +GameMenus(13).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(13).y = GameMenus(12).y + 34 + +tmp& = _NewImage(500, 200, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (CenterPrintX("Apply Settings"), 0), "Apply Settings" +_Dest 0 +GameMenus(14).img = _CopyImage(tmp&, 33) +GameMenus(14).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(14).y = GameMenus(13).y + 34 + +tmp& = _NewImage(500, 200, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (CenterPrintX("Go Back To Main Menu"), 0), "Go Back To Main Menu" +_Dest 0 +GameMenus(15).img = _CopyImage(tmp&, 33) +GameMenus(15).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(15).y = GameMenus(14).y + 34 + +tmp& = _NewImage(500, 200, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "Fullscreen" +_Dest 0 +GameMenus(16).img = _CopyImage(tmp&, 33) +GameMenus(16).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(16).y = 232 + +tmp& = _NewImage(500, 200, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "Music Volume" +_Dest 0 +GameMenus(17).img = _CopyImage(tmp&, 33) +GameMenus(17).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(17).y = GameMenus(16).y + 34 + +tmp& = _NewImage(500, 200, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (20, 0), "SFX Volume" +_Dest 0 +GameMenus(18).img = _CopyImage(tmp&, 33) +GameMenus(18).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(18).y = GameMenus(17).y + 34 + +tmp& = _NewImage(500, 200, 32) +_Dest tmp& +Color , _RGBA(0, 0, 0, 0) +_Font Fonts.normal +_PrintString (CenterPrintX("Exit to Main Menu"), 0), "Exit to Main Menu" +_Dest 0 +GameMenus(19).img = _CopyImage(tmp&, 33) +GameMenus(19).img2 = _CopyImage(tmp&, 32) +_FreeImage tmp& +GameMenus(19).y = GameMenus(18).y + 34 + + + + + + +LoaderEnd + +start: + +Color _RGB(255, 255, 255), _RGBA(0, 0, 0, 0) + +' echo COMMAND$(1) +' echo COMMAND$(2) +' IF COMMAND$(1) = "-loadlevel" AND VAL(COMMAND$(2)) > 0 THEN +' LevelStage% = VAL(COMMAND$(2)) +' LevelStage2% = LevelStage% +' GOTO newgame +' END IF + +GameMenu + + + + +If MenuChoice = 1 Then MenuChoice = 0: GoTo newgame +If MenuChoice = 2 Then + MenuChoice = 0 + + 'save current settings in dummy variable :P + Dim preConfig As Settings + preConfig = W ' W is a global variable which stored all game settings + + Dim on_switch&, off_switch&, bd&, cj&, gfx&, ac& 'images surface + on_switch& = _LoadImage("Images/on.png", 33) + off_switch& = _LoadImage("Images/off.png", 33) + For i = 0 To 4 + _PutImage (200, GameMenus(i).y), GameMenus(i).img2 + Next + + bd& = _CopyImage(0) + cj& = _CopyImage(bd&) + + BLURIMAGE cj&, 5 + gfx& = _NewImage(500, 340, 32) + _Dest gfx& + Cls , 0 'make it transparent + Line (0, 0)-Step(_Width, _Height), _RGBA(0, 0, 0, 150), BF + For i = 5 To 14 + _PutImage (0, GameMenus(i).y - 103), GameMenus(i).img2 + Next + + _Dest 0 + + For i = 0 To 255 Step 10 + _SetAlpha i, , cj& + _PutImage , bd& + _PutImage , cj& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i / 3), BF + _PutImage (150, 103), gfx&, 0, (0, 0)-(500, p5map(i, 0, 255, 0, 340)) + _Display + Next + ac& = _CopyImage(cj&) + _Dest ac& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, 85), BF + _Dest 0 + Do + While _MouseInput: Wend + Mouse.x = _MouseX: Mouse.y = _MouseY + Mouse.lclick = 0 + Mouse.rclick = 0 + If _MouseButton(1) Then + While _MouseButton(1): While _MouseInput: Wend: Wend + Mouse.lclick = -1 + End If + If _MouseButton(2) Then + While _MouseButton(2): While _MouseInput: Wend: Wend + Mouse.rclick = -1 + End If + _PutImage , ac& + Line (150, 103)-Step(500, 374), _RGBA(0, 0, 0, 150), BF + For i = 5 To 15 + If Mouse.x > 150 And Mouse.x < 650 And Mouse.y > GameMenus(i).y - 10 And Mouse.y < GameMenus(i).y + 24 Then + Line (150, GameMenus(i).y - 10)-(650, GameMenus(i).y + 24), _RGBA(255, 100, 0, 100), BF + If Mouse.lclick Then + Select Case i + Case 5 + If W.fullscreen > 0 Then W.fullscreen = 0 Else W.fullscreen = 1 + Case 6 + W.fullscreen = W.fullscreen + 1 + If W.fullscreen > 2 Then W.fullscreen = 1 + Case 7 + If W.music Then W.music = 0 Else W.music = -1 + Case 8 + If W.sfx Then W.sfx = 0 Else W.sfx = -1 + Case 9 + W.musicV = W.musicV + .1 + If W.musicV > 1.0 Then W.musicV = .1 + Case 10 + W.sfxV = W.sfxV + .1 + If W.sfxV > 1 Then W.sfxV = 0.1 + Case 11 + If W.SE Then W.SE = 0 Else W.SE = -1 + Case 12 + W.fps = W.fps + 30 + If W.fps > 240 Then W.fps = 30 + Case 13 + W.fullscreen = 0 + W.music = -1 + W.sfx = -1 + W.musicV = 1 + W.sfxV = 1 + W.SE = -1 + W.fps = 30 + Case 14 + writeConfig + loadComponents + showNotification "Settings have been applied." + Case 15 + Exit Do + End Select + End If + End If + _PutImage (150, GameMenus(i).y), GameMenus(i).img + Select Case i + Case 5 + If W.fullscreen > 0 Then _PutImage (580, GameMenus(i).y - 3), on_switch& Else _PutImage (580, GameMenus(i).y - 3), off_switch& + Case 6 + _Font Fonts.normal + Select Case W.fullscreen + Case 1 + _PrintString (630 - txtWidth("Stretch"), GameMenus(i).y), "Stretch" + Case 2 + _PrintString (630 - txtWidth("Square Pixels"), GameMenus(i).y), "Square Pixels" + Case Else + _PrintString (630 - txtWidth("Disable"), GameMenus(i).y), "Disable" + End Select + Case 7 + If W.music Then _PutImage (580, GameMenus(i).y - 3), on_switch& Else _PutImage (580, GameMenus(i).y - 3), off_switch& + Case 8 + If W.sfx Then _PutImage (580, GameMenus(i).y - 3), on_switch& Else _PutImage (580, GameMenus(i).y - 3), off_switch& + Case 9 + _Font Fonts.normal + If W.musicV > .9 Then + _PrintString (630 - txtWidth(" 10"), GameMenus(i).y), " 10 " + Else + _PrintString (630 - txtWidth(Str$(Int(W.musicV * 10))), GameMenus(i).y), Str$(Int(W.musicV * 10)) + End If + Case 10 + _Font Fonts.normal + If W.sfxV > .9 Then + _PrintString (630 - txtWidth(" 10"), GameMenus(i).y), " 10 " + Else + _PrintString (630 - txtWidth(Str$(Int(W.sfxV * 10))), GameMenus(i).y), Str$(Int(W.sfxV * 10)) + End If + Case 11 + If W.SE Then _PutImage (580, GameMenus(i).y - 3), on_switch& Else _PutImage (580, GameMenus(i).y - 3), off_switch& + Case 12 + _Font Fonts.normal + _PrintString (630 - txtWidth(Str$(W.fps)), GameMenus(i).y), Str$(W.fps) + End Select + Next + _Limit W.fps + If Mouse.hovering Then + _PutImage (Mouse.x - 16, Mouse.y - 16), Mouse.cursor2 + _Display + Else + _PutImage (Mouse.x - 16, Mouse.y - 16), Mouse.cursor + _Display + End If + + Loop + For i = 255 To 0 Step -10 + _SetAlpha i, , cj& + _PutImage , bd& + _PutImage , cj& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i / 3), BF + _PutImage (150, 103), gfx&, 0, (0, 0)-(500, p5map(i, 0, 255, 0, 340)) + _Display + Next + _FreeImage bd& + _FreeImage cj& + _FreeImage ac& + _FreeImage gfx& + _FreeImage on_switch& + _FreeImage off_switch& + GoTo start +End If +If MenuChoice = 3 Then + MenuChoice = 0 + For i = 0 To 4 + _PutImage (200, GameMenus(i).y), GameMenus(i).img2 + Next + bd& = _CopyImage(0) + cj& = _CopyImage(bd&) + + BLURIMAGE cj&, 5 + Dim k& + k& = _LoadImage("Images\help.png") + + For i = 0 To 255 Step 10 + _SetAlpha i, , cj& + _PutImage , bd& + _PutImage , cj& + _SetAlpha i / 1.25, , k& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i / 5), BF + centerImage k& + _Display + Next + + Do + 'mouse input + While _MouseInput: Wend + Mouse.x = _MouseX: Mouse.y = _MouseY + + If _MouseButton(1) Then + While _MouseButton(1): While _MouseInput: Wend: Wend + Mouse.lclick = -1 + Else + Mouse.lclick = 0 + End If + + If _MouseButton(2) Then + While _MouseButton(2): While _MouseInput: Wend: Wend + Mouse.rclick = -1 + Else + Mouse.rclick = 0 + End If + + _Limit W.fps + + _Display + + If Mouse.lclick Or Mouse.rclick Or _KeyHit = 27 Then Exit Do + Loop + + For i = 255 To 0 Step -10 + _SetAlpha i, , cj& + _PutImage , bd& + _PutImage , cj& + _SetAlpha i / 1.25, , k& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i / 5), BF + centerImage k& + _Display + Next + + _PutImage , bd& + _FreeImage bd& + _FreeImage cj& + _FreeImage k& + GoTo start + +End If + +If MenuChoice = 4 Then + For i = 0 To 4 + _PutImage (200, GameMenus(i).y), GameMenus(i).img2 + Next + + bd& = _CopyImage(0) + + For i = 0 To 255 Step 5 + _PutImage , bd& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i), BF + _Display + Next + + showCredits + + For i = 255 To 0 Step -5 + _PutImage , bd& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i), BF + _Display + Next + + _FreeImage bd& + MenuChoice = 0 + GoTo start + +End If + +If MenuChoice = 5 Then System 1 +MenuChoice = 0 +End +newgame: + + +Cls + +LoaderStart +SetupRain +If Command$(1) = "-loadlevel" Then + LoadLevel +Else + If getCurrentLevel > MAX_LEVEL Then randomLevels = -1 Else randomLevels = 0: LoadLevel +End If + + +_Font Fonts.bigger + +'################### Random Levels ################################ +Dim F As Integer +If randomLevels Then + Level.completed = 0 + Level.over = 0 + LevelStage% = p5random(1, MAX_LEVEL) + F = FreeFile + 'LevelStage% = VAL(COMMAND$(2)) + Open "stages/stage" + RTrim$(LTrim$(Str$(LevelStage%))) + ".dat" For Input As #F + Input #F, Level.enemies + Input #F, Level.scenes + Input #F, Seconds% + Input #F, Level.mode + Input #F, Level.background + Close #F + Level.bg = _LoadImage("Images\" + RTrim$(Level.background)) + OldSeconds% = Seconds% +End If + +If randomLevels Then _PrintString (CenterPrintX("Random Levels"), 300), "Random Levels" Else _PrintString (CenterPrintX("Stage " + LTrim$(RTrim$(Str$(LevelStage%)))), 300), "Stage " + LTrim$(RTrim$(Str$(LevelStage%))) + +_Delay Rnd * 3 + +' if randomLevels then LoaderEnd : goto game_rendering_begin +' _DELAY 0.5 + + +'############################# Custom Levels ############################# + +Erase Enemie 'clear all previous enemie data + +ReDim Shared Enemie(Level.enemies) As Enemies + +'Enemie Configuirations + +F = FreeFile +Level.completed = 0 +Level.over = 0 +Level.cancel = 0 +CurrentScore% = 0 +Level.u = 0 +Level.currentScene = 1 + +Open "Stages\Stage" + LTrim$(RTrim$(Str$(LevelStage%))) + ".lvl" For Input As #F + +For i = 1 To Level.enemies + Input #F, Enemie(i).typ + + Select Case RTrim$(Enemie(i).typ) + + Case "bird" + Enemie(i).img = SPRITENEW(Bird_Sheet%, 1, SAVE) + SPRITEANIMATESET Enemie(i).img, 1, 14 + SPRITEZOOM Enemie(i).img, 50 + Enemie(i).n = 6 + Enemie(i).points = 10 + Enemie(i).life = 4 + Enemie(i).life2 = Enemie(i).life + Enemie(i).snd = _SndCopy(Bird&) + Case "crow" + Enemie(i).img = SPRITENEW(Crow_Sheet%, 1, SAVE) + SPRITEANIMATESET Enemie(i).img, 1, 4 + SPRITEZOOM Enemie(i).img, 70 + Enemie(i).n = 12 + Enemie(i).points = 20 + Enemie(i).life = 7 + Enemie(i).life2 = Enemie(i).life + Enemie(i).snd = _SndCopy(Crow&) + Case "eagle" + Enemie(i).img = SPRITENEW(eagle_Sheet%, 7, SAVE) + SPRITEANIMATESET Enemie(i).img, 7, 9 + Enemie(i).n = 12 + Enemie(i).points = 35 + Enemie(i).life = 14 + Enemie(i).life2 = Enemie(i).life + Enemie(i).snd = _SndCopy(Eagle&) + Case "jet1" + Enemie(i).img = SPRITENEW(Jet1_Sheet%, 1, SAVE) + SPRITEANIMATESET Enemie(i).img, 1, 3 + SPRITEZOOM Enemie(i).img, 70 + Enemie(i).n = 10 + Enemie(i).points = 50 + Enemie(i).life = 30 + Enemie(i).life2 = Enemie(i).life + Enemie(i).snd = _SndCopy(Jet&) + Case "jet2" + Enemie(i).img = SPRITENEW(Jet2_Sheet%, 1, SAVE) + SPRITEANIMATESET Enemie(i).img, 1, 3 + SPRITEZOOM Enemie(i).img, 70 + Enemie(i).n = 10 + Enemie(i).points = 75 + Enemie(i).life = 45 + Enemie(i).life2 = Enemie(i).life + Enemie(i).snd = _SndCopy(Jet&) + Case "jet3" + Enemie(i).img = SPRITENEW(Jet3_Sheet%, 1, SAVE) + SPRITEANIMATESET Enemie(i).img, 1, 3 + SPRITEZOOM Enemie(i).img, 70 + Enemie(i).n = 10 + Enemie(i).points = 100 + Enemie(i).life = 70 + Enemie(i).life2 = Enemie(i).life + Enemie(i).snd = _SndCopy(Jet&) + End Select + Input #F, Enemie(i).u + Input #F, Enemie(i).y + Input #F, Enemie(i).m + If Enemie(i).m < 0 Then Enemie(i).x = _Width: SPRITEFLIP Enemie(i).img, HORIZONTAL Else Enemie(i).x = 0 + + Input #F, Enemie(i).scene +Next + +Close #F + +LoaderEnd + +game_rendering_begin::: + +_PutImage (0, 0)-(_Width, _Height), Level.bg +_PutImage (0, 520), ScoreBoard& +_PutImage (50, 550)-(170, 590), GunImg&(Gun.id - 1) +_Font Fonts.smaller +_PrintString (40, 580), RTrim$(Gun.name) +_Font Fonts.normal + +If randomLevels Then _PrintString (CenterPrintX("Random Levels"), 560), "Random Levels" Else _PrintString (CenterPrintX("Stage " + Str$(LevelStage%)), 560), "Stage " + Str$(LevelStage%) +_Font Fonts.smaller + +Minutes% = (Seconds% - (Seconds% Mod 60)) / 60 +Dim t As Integer +t = Seconds% Mod 60 + +_PrintString (600, 560), "Score - " + Str$(CurrentScore%) +_PrintString (600, 580), "Time Left -" + Str$(Minutes%) + ":" + Str$(t) +StartLevel + +For i = 1 To Level.enemies 'free all the sound buffer stream (sound stream will reload again when next gameplay starts. + _SndClose Enemie(i).snd +Next + +Color _RGB(255, 255, 255), _RGBA(0, 0, 0, 0) +'checking if the level has benn canceled by the user. +If Level.cancel Then + 'free the level background image + _FreeImage Level.bg + Level.cancel = 0 + GoTo start +End If + +'checking if game is completed + +If Level.completed Then + ' IF COMMAND$(1) = "-loadlevel" THEN + ' echo "Level : " + STR$(LevelStage%) + ' echo "Time taken to complete : " + STR$(Level.time - Seconds%) + ' END IF + + _PutImage (0, 0)-(_Width, _Height), Level.bg + + 'crosfading start here - + Dim blured& + + blured& = _CopyImage(Level.bg) + BLURIMAGE blured&, 5 + For i = 1 To 255 Step 20 + _SetAlpha i, , blured& + _PutImage , Level.bg + _PutImage , blured& + _Display + Next + + _FreeImage blured& + + Line (200, 200)-(_Width - 200, _Height - 200), _RGBA(0, 0, 0, 180), BF + _Font Fonts.normal + _PrintString (CenterPrintX("Stage " + Str$(LevelStage%) + "Completed!"), 210), "Stage " + Str$(LevelStage%) + " Completed" + _Font Fonts.smaller + Dim a$ + a$ = "Congratulations!! You created new high score!" + + If CurrentScore% > HighScore% Then _PrintString (CenterPrintX(a$), 250), a$ + + _PrintString (CenterPrintX("Score - " + Str$(CurrentScore%)), 300), "Score - " + Str$(CurrentScore%) + _PrintString (CenterPrintX("Bonus Score - " + Str$(Seconds% * 2)), 320), "Bonus Score - " + Str$(Seconds% * 2) + _PrintString (CenterPrintX("Total Score - " + Str$(Seconds% * 2 + CurrentScore%)), 340), "Total Score - " + Str$(Seconds% * 2 + CurrentScore%) + + If LevelStage% = MAX_LEVEL Then a$ = "Game Completed" Else a$ = "Be ready for next stage. Wait a moment..." + _PrintString (CenterPrintX(a$), 380), a$ + + Do + If F = 1 Then SPRITESHOW ExplosionsZ(0).img: SPRITESHOW ExplosionsZ(1).img + For i = 0 To 1 + SPRITENEXT ExplosionsZ(i).img + SPRITEPUT ExplosionsZ(i).x, ExplosionsZ(i).y, ExplosionsZ(i).img + Next + _Limit W.fps + _Display + F = F + 1 + Loop Until F > 180 + SPRITEHIDE ExplosionsZ(0).img + SPRITEHIDE ExplosionsZ(1).img + + F = 0 + If Command$(1) = "-loadlevel" Then System + SaveGame + + If LevelStage% > MAX_LEVEL Then + bd& = _CopyImage(0) + For i = 0 To 255 Step 5 + _PutImage , bd& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i), BF + _Display + Next + showCredits + + GoTo start + End If + 'free the level background image + _FreeImage Level.bg + + GoTo newgame +End If +If Level.over Then + Color _RGB(255, 0, 0) + ' IF COMMAND$(1) = "-loadlevel" THEN + ' echo "Level failed to compete" + ' END IF + + _PutImage (0, 0)-(_Width, _Height), Level.bg + 'crosfading start here - + blured& = _CopyImage(Level.bg) + BLURIMAGE blured&, 5 + For i = 1 To 255 Step 20 + _SetAlpha i, , blured& + _PutImage , Level.bg + _PutImage , blured& + _Display + Next + + _FreeImage blured& + Line (200, 250)-(_Width - 200, _Height - 250), _RGBA(0, 0, 0, 180), BF + _Font Fonts.bigger + _PrintString (CenterPrintX("Game Over"), 260), "Game Over" + _Font Fonts.smaller + _PrintString (CenterPrintX("Click To Continue..."), _Height - 280), "Click to Continue..." + _Display + + Do + While _MouseInput: Wend + If _MouseButton(1) Then + While _MouseButton(1): While _MouseInput: Wend: Wend + Exit Do + End If + _Limit 30 + Loop + GoTo start + 'free the level background image + _FreeImage Level.bg + +End If + +404 +_MouseShow +_Font 16 +Cls +Color _RGB(255, 255, 255) +Circle (_Width / 2, 200), 100 +Circle (_Width / 2 - 50, 150), 5 +Circle (_Width / 2 + 50, 150), 5 +Circle (_Width / 2, 250), 50, , 0, _Pi + +centerPrint "An Error has ocurred!", 350 +centerPrint "Error Code - " + Str$(Err), 366 +If _InclErrorFile$ <> "" Then + centerPrint "Error File - " + _InclErrorFile$, 382 + centerPrint "Error Line - " + Str$(_InclErrorLine), 398 +Else + centerPrint "Error File - Main_File", 382 + centerPrint "Error Line - " + Str$(_ErrorLine), 398 +End If +End + + + + + + + +Sub echo (m$) 'always write to console + Dim preDest As Long + preDest = _Dest + _Dest _Console + Print m$ + _Dest preDest +End Sub + +Sub showNotification (message$) + NText$ = message$ + NShow = -1 +End Sub + +Sub Notify () + Static imgy + If NShow = -1 Then + If NFPSCount% = 0 Then + _Font 16 + Dim __w As Integer, h As Integer, tmp&, preDest As Long + __w = Len(NText$) * 8 + 40 + h = 36 + + tmp& = _NewImage(__w, h, 32) + + preDest = _Dest + _Dest tmp& + + Color _RGB(10, 10, 10), _RGB(355, 245, 245) + Cls , _RGB(255, 245, 245) + _PrintString (20, 10), NText$ + + _Dest preDest + NImage& = _CopyImage(tmp&, 33) + _FreeImage tmp& + + imgy = -40 + End If + If NFPSCount% > 0 And NFPSCount% < 40 Then + imgy = imgy + 1 + _PutImage (_Width / 2 - _Width(NImage&) / 2, imgy), NImage& + End If + If NFPSCount% > 40 And NFPSCount% < 160 Then + _PutImage (_Width / 2 - _Width(NImage&) / 2, imgy), NImage& + End If + If NFPSCount% > 160 And NFPSCount% < 200 Then + _PutImage (_Width / 2 - _Width(NImage&) / 2, imgy), NImage& + imgy = imgy - 1 + End If + NFPSCount% = NFPSCount% + 1 + If NFPSCount% > 200 Then + _FreeImage NImage& + NFPSCount% = 0 + NShow = 0 + End If + End If +End Sub + + +Sub readConfig () + Dim F As Integer + + If Not _FileExists("Settings/settings.dat") Then writeConfig + F = FreeFile + Open "Settings/settings.dat" For Input As #F + Input #F, W.fullscreen + Input #F, W.music + Input #F, W.sfx + Input #F, W.musicV + Input #F, W.sfxV + Input #F, W.SE + Input #F, W.fps + Close #F +End Sub + +Sub writeConfig () + Dim f As Integer + + f = FreeFile + Open "Settings/settings.dat" For Output As #f + Print #f, W.fullscreen + Print #f, W.music + Print #f, W.sfx + Print #f, W.musicV + Print #f, W.sfxV + Print #f, W.SE + Print #f, W.fps + Close #f +End Sub + +Sub createConfig () + W.fullscreen = 0 + W.music = -1 + W.sfx = -1 + W.musicV = 1 + W.sfxV = 1 + W.SE = -1 + W.fps = 90 + writeConfig +End Sub + +Sub loadComponents () + If W.fullscreen = 0 Then + If _FullScreen <> 0 Then _FullScreen _Off + ElseIf W.fullscreen = 1 Then + If _FullScreen <> 1 Then _FullScreen _Stretch , _Smooth + ElseIf W.fullscreen = 2 Then + If _FullScreen <> 2 Then _FullScreen _SquarePixels , _Smooth + End If + + 'SFXs + ' screen_conf: + If Gun1& = 0 Then Gun1& = _SndOpen("SFX/Gun1.ogg", "sync,vol,pause") + If Gun2& = 0 Then Gun2& = _SndOpen("SFX/Gun2.ogg", "sync,vol,pause") + If Bird& = 0 Then Bird& = _SndOpen("SFX/bird.ogg", "sync,vol,pause") + If Crow& = 0 Then Crow& = _SndOpen("SFX/Crow.ogg", "sync,vol,pause") + If Eagle& = 0 Then Eagle& = _SndOpen("SFX/Eagle.ogg", "sync,vol,pause") + If Expos& = 0 Then Expos& = _SndOpen("SFX/Explosion.mp3", "sync,vol,pause") + If Jet& = 0 Then Jet& = _SndOpen("SFX/Jet.ogg", "sync,vol,pause") + If RainSound& = 0 Then RainSound& = _SndOpen("SFX/Rain.mp3", "vol,sync,pause") + + If Musics&(0) = 0 Then Musics&(0) = _SndOpen("Musics/Hunter's_Revenge-Against_Evil.mp3", "sync,vol,pause") + If Musics&(1) = 0 Then Musics&(1) = _SndOpen("Musics/Hunter's_Revenge-End_Of_Game.mp3", "sync,vol,pause") + If Musics&(2) = 0 Then Musics&(2) = _SndOpen("Musics/Hunter's_Revenge-Who's_Next.mp3", "sync,vol,pause") + + setMusicVol W.musicV + If Not W.music Then 'if menu background music disable, then stop the musics, regardless of whether the are being played or not. + _SndStop Musics&(0) + _SndStop Musics&(1) + _SndStop Musics&(2) + End If + + W.done = -1 +End Sub + +Sub Splash () + + Cls + + Dim stars&, x As Integer, y As Integer, F As Integer + + stars& = _NewImage(_Width * 2, _Height, 32) + _Dest stars& + Do + x = Int(Rnd * _Width(stars&)) + y = Int(Rnd * _Height) + PSet (x, y), _RGB(255, 255, 255) + F = F + 1 + Loop Until F > 700 + + Dim spT&, sp&, eft1&, p As Integer, a As Integer, xx As Integer + + _Dest 0 + spT& = _LoadImage("Images\splash.png") + _ClearColor _RGB(0, 0, 0), spT& + sp& = _CopyImage(spT&, 33) + F = 0 + eft1& = _NewImage(_Width, _Height, 32) + _Dest eft1& + Line (0, 0)-(_Width, _Height), _RGB(0, 0, 50), BF + _Dest 0 + + p = 6 + FPSStart + Do + _SetAlpha a, , eft1&: _PutImage , eft1& + _PutImage (xx, 0), stars& + _PutImage , sp& + xx = xx - 1 + If xx < -_Width - 2 Then xx = 0 + _Limit 60 + a = a + p + If a > 250 Then p = -p + If a < 6 Then p = 6 + _Display + F% = F% + 1 + FPSCurrent% = FPSCurrent% + 1 + Loop Until F% > 360 + + FPSEnd + Cls + + _FreeImage sp& + _FreeImage spT& + _FreeImage eft1& + _FreeImage stars& +End Sub + +Sub FPSStart () + On Timer(FPSEvent, 1) FPS + On Timer(FPSEvt, 0.01) FPSShow + Timer(FPSEvent) On + Timer(FPSEvt) On +End Sub + +Sub FPS () + FPSRate% = FPSCurrent% + FPSCurrent% = 0 +End Sub + +Sub FPSShow () + Color _RGB(255, 255, 255) + _PrintString (720, 0), Str$(FPSRate%) + " FPS" +End Sub + +Sub FPSEnd () + Timer(FPSEvent) Off + Timer(FPSEvt) Off +End Sub + +Sub LoaderStart () + Loader& = _LoadImage("Images\loader.gif", 33) + LoaderEvt! = _FreeTimer + On Timer(LoaderEvt!, 0.1) ShowLoader + Timer(LoaderEvt!) On +End Sub + +Sub LoaderEnd () + Timer(LoaderEvt!) Off + _FreeImage Loader& +End Sub + +Sub ShowLoader () + If LoaderCF% = 0 Then LoaderCF% = 1 + _PutImage (LoaderX%, LoaderY%), Loader&, 0, (LoaderCF% * 48 - 48, 0)-(LoaderCF% * 48 - 1, 48) + LoaderCF% = LoaderCF% + 1 + If LoaderCF% > 8 Then LoaderCF% = 1 + _Display +End Sub + +' SUB PlayMovie (m$) +' LoaderStart + +' DIM f AS INTEGER, n AS LONG, i AS LONG, k AS INTEGER + +' f = FREEFILE +' OPEN "Movies\" + m$ + "\" + m$ + ".txt" FOR INPUT AS #f +' INPUT #f, n +' CLOSE #f +' DIM Temps_Buffers&(n) +' FOR i = 1 TO n +' Temps_Buffers&(i) = _LOADIMAGE("Movies\" + m$ + "\produce" + LTRIM$(RTRIM$(STR$(i))) + ".jpg", 33) +' NEXT +' LoaderEnd +' FOR i = 1 TO n +' FOR k = 1 TO 3 +' _PUTIMAGE , Temps_Buffers&(i) +' _DISPLAY +' NEXT +' _DELAY .05 +' _FREEIMAGE Temps_Buffers&(i) +' NEXT +' ERASE Temps_Buffers& +' END SUB + +Sub GameMenu () + _PutImage , Menubg& + Dim n% + 'Menu background music + If W.music Then + n% = p5random(0, 2) + If Not (_SndPlaying(Musics&(0)) Or _SndPlaying(Musics&(1)) Or _SndPlaying(Musics&(2))) Then _SndPlay Musics&(n%) + End If + + On Timer(GlobalEvent, 0.01) GameMenu2 + Timer(GlobalEvent) On + Do + While _MouseInput: Wend + Mouse.x = _MouseX: Mouse.y = _MouseY + Mouse.lclick = _MouseButton(1) + _Limit W.fps + If MenuChoice > 0 Then Exit Do + Loop + Timer(GlobalEvent) Off +End Sub + +Sub GameMenu2 () + If _ScreenIcon Then Exit Sub + + _PutImage , Menubg& + Line (200, 130)-(_Width - 200, 450), _RGBA(0, 0, 0, 150), BF + + Dim i As Integer + + For i = 0 To 4 + Color _RGB(255, 255, 255), _RGBA(0, 0, 0, 0) + If Mouse.x > 200 And Mouse.x < 600 And Mouse.y > GameMenus(i).y - 20 And Mouse.y < GameMenus(i).y + _FontHeight(Fonts.bigger) Then + Line (200, GameMenus(i).y - 20)-(600, GameMenus(i).y + _FontHeight(Fonts.bigger)), _RGBA(255, 100, 0, 100), BF + SPRITEPUT 150, GameMenus(i).y + 20, MenuBlood% + SPRITENEXT MenuBlood% + ' _PRINTSTRING (GameMenus(i).x, GameMenus(i).y), RTRIM$(GameMenus(i).text) + _PutImage (200, GameMenus(i).y), GameMenus(i).img + If Mouse.lclick Then + Timer(GlobalEvent!) Off + Select Case i + Case 0 + MenuChoice = 1 + Case 1 + MenuChoice = 2 + Case 2 + MenuChoice = 3 + Case 3 + MenuChoice = 4 + Case 4 + MenuChoice = 5 + + End Select + End If + Else + ' _PRINTSTRING (GameMenus(i).x, GameMenus(i).y), RTRIM$(GameMenus(i).text) + _PutImage (200, GameMenus(i).y), GameMenus(i).img + End If + Next + If Mouse.hovering Then + _PutImage (Mouse.x - 16, Mouse.y - 16), Mouse.cursor2 + _Display + Else + _PutImage (Mouse.x - 16, Mouse.y - 16), Mouse.cursor + _Display + End If + +End Sub + + +Function CenterPrintX (m$) + Dim i As Integer, a As Integer + For i = 1 To Len(m$) + a = a + _PrintWidth(Mid$(m$, i, 1)) + Next + CenterPrintX = (_Width / 2) - (a / 2) +End Function + +Function getCurrentLevel% () + If Not _FileExists("Save_Game/save.dat") Then getCurrentLevel% = 1: Exit Function + Dim F As Integer, tmp As Integer + F = FreeFile + Open "Save_Game\save.dat" For Binary As #F + Seek F, 3 + Get #F, , tmp + getCurrentLevel% = tmp + Close #F +End Function + +Sub LoadLevel () + Level.completed = 0 + Level.over = 0 + Dim F As Integer + F = FreeFile + ' IF COMMAND$(1) = "-loadlevel" THEN + ' GOTO skip_game_save_info + ' END IF + If Not _FileExists("Save_Game\save.dat") Then + Open "Save_Game\save.dat" For Binary As #F + LevelStage% = 1 + HighScore% = 0 + Put #F, , HighScore% + Put #F, , LevelStage% + Close #F + Else + Open "Save_Game\save.dat" For Binary As #F + Get #F, , HighScore% + Get #F, , LevelStage% + Close #F + End If + skip_game_save_info::: + ' echo "loading level/stage : " + STR$(LevelStage%) + Open "Stages\Stage" + RTrim$(LTrim$(Str$(LevelStage%))) + ".dat" For Input As #F + Input #F, Level.enemies + Input #F, Level.scenes + Input #F, Level.time + Input #F, Level.mode + Input #F, Level.background + Close #F + LevelStage2% = LevelStage% + Level.bg = _LoadImage("Images\" + RTrim$(Level.background)) + Seconds% = Level.time + OldSeconds% = Seconds% + 'LevelStage% = clevel% +End Sub + +Sub StartLevel () + + 'Stop music during gameplay + Dim i As Integer, k&, onn&, offf&, bd&, bd2&, ac&, gfx& + If W.music Then + For i = 0 To 2 + _SndStop Musics&(i) + Next 'stops all musics + End If + If W.sfx Then updateSfxVolume + + On Timer(GameRenderingEvent, 1 / W.fps) UpdateStatus + On Timer(TimerEvent, 1) UpdateTime + Timer(GameRenderingEvent) On + Timer(TimerEvent) On + Mouse.lclick = 0 + Mouse.rclick = 0 + Mouse.mclick = 0 + Do + While _MouseInput: Wend + + Mouse.x = _MouseX: Mouse.y = _MouseY + If _MouseButton(1) Then + While _MouseButton(1): While _MouseInput: Wend: Wend + Mouse.lclick = -1 + End If + If _MouseButton(2) Then + While _MouseButton(2): While _MouseInput: Wend: Wend + Mouse.rclick = -1 + End If + If _MouseButton(3) Then + While _MouseButton(3): While _MouseInput: Wend: Wend + Mouse.mclick = -1 + Else Mouse.mclick = 0 + End If + + k& = _KeyHit + If k& = 27 Or Mouse.mclick Then + Timer(GameRenderingEvent) Off + Timer(TimerEvent) Off + If W.sfx Then PauseSound 'Pause the sounds + + onn& = _LoadImage("Images/on.png", 33) + offf& = _LoadImage("Images/off.png", 33) + + bd& = _CopyImage(0) + bd2& = _CopyImage(0) + + BLURIMAGE bd2&, 5 + gfx& = _NewImage(500, 156, 32) + _Dest gfx& + Cls , 0 'make it transparent + Line (0, 0)-Step(_Width, _Height), _RGBA(0, 0, 0, 150), BF + For i = 16 To 19 + _PutImage (0, GameMenus(i).y - 222), GameMenus(i).img2 + Next + _Dest 0 + + For i = 0 To 255 Step 10 + _SetAlpha i, , bd2& + _PutImage , bd& + _PutImage , bd2& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i / 3), BF + _PutImage (150, 222), gfx&, 0, (0, 0)-(500, p5map(i, 0, 255, 0, 136)) + _Display + Next + ac& = _CopyImage(0) + Do + While _MouseInput: Wend + Mouse.x = _MouseX: Mouse.y = _MouseY + Mouse.lclick = 0 + Mouse.rclick = 0 + If _MouseButton(1) Then + While _MouseButton(1): While _MouseInput: Wend: Wend + Mouse.lclick = -1 + End If + If _MouseButton(2) Then + While _MouseButton(2): While _MouseInput: Wend: Wend + Mouse.rclick = -1 + End If + + _PutImage , ac& + Line (150, 222)-Step(500, 136), _RGBA(0, 0, 0, 50), BF + For i = 16 To 19 + If Mouse.x > 150 And Mouse.x < 650 And Mouse.y > GameMenus(i).y - 10 And Mouse.y < GameMenus(i).y + 24 Then + If Mouse.lclick Then + Select Case i + Case 16 + If W.fullscreen > 0 Then W.fullscreen = 0 Else W.fullscreen = 1 + Case 17 + W.musicV = W.musicV + .1 + If W.musicV > 1 Then W.musicV = .1 + Case 18 + W.sfxV = W.sfxV + .1 + If W.sfxV > 1 Then W.sfxV = .1 + Case 19 + Level.cancel = -1 + Exit Do + End Select + End If + Line (150, GameMenus(i).y - 10)-(650, GameMenus(i).y + 24), _RGBA(255, 100, 0, 100), BF + End If + _PutImage (150, GameMenus(i).y), GameMenus(i).img + Select Case i + Case 16 + If W.fullscreen > 0 Then _PutImage (580, GameMenus(i).y - 3), onn& Else _PutImage (580, GameMenus(i).y - 3), offf& + Case 17 + _Font Fonts.normal + If W.musicV > .9 Then + _PrintString (630 - txtWidth(" 10"), GameMenus(i).y), " 10 " + Else + _PrintString (630 - txtWidth(Str$(Int(W.musicV * 10))), GameMenus(i).y), Str$(Int(W.musicV * 10)) + End If + Case 18 + _Font Fonts.normal + If W.sfxV > .9 Then + _PrintString (630 - txtWidth(" 10"), GameMenus(i).y), " 10 " + Else + _PrintString (630 - txtWidth(Str$(Int(W.sfxV * 10))), GameMenus(i).y), Str$(Int(W.sfxV * 10)) + End If + End Select + Next + If _KeyHit = 27 Or _MouseButton(3) Then Exit Do + _Limit W.fps + _PutImage (Mouse.x - 8, Mouse.y - 8), Mouse.cursor + _Display + Loop + For i = 255 To 0 Step -10 + _SetAlpha i, , bd2& + _PutImage , bd& + _PutImage , bd2& + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, i / 3), BF + _PutImage (150, 222), gfx&, 0, (0, 0)-(500, p5map(i, 0, 255, 0, 222)) + _Display + Next + + _PutImage , bd& 'Erase that menu line + _FreeImage bd& + _FreeImage bd2& + _FreeImage ac& + _FreeImage gfx& + _FreeImage onn& + _FreeImage offf& + loadComponents + + If W.sfx Then 'update the sfx volume and play the paused sound. + updateSfxVolume + If Not Level.cancel Then PlayPausedSound + End If + + Timer(GameRenderingEvent) On + Timer(TimerEvent) On + + If Level.cancel Then Exit Do + End If + _Limit W.fps + Loop Until Level.completed Or Level.over + Timer(GameRenderingEvent) Off + CloseTime + For i = 0 To 20 + If Bloods(i).active Then + Bloods(i).active = 0 + SPRITEHIDE Bloods(i).img + End If + If explosions(i).active Then + explosions(i).active = 0 + SPRITEHIDE explosions(i).img + End If + Next + For i = 0 To UBound(ShotScore) + ShotScore(i).active = 0 + Next +End Sub + +Sub UpdateStatus () + ' $checking:off + Static thunder_f_count, thunder_ha_count, thunder_ha_count_limit + Dim i As Integer, t As Integer, tmp&, tmp2& + + If Seconds% < OldSeconds% Or OldScore% < CurrentScore% Then _PutImage (0, 0)-(_Width, _Height), Level.bg + + If _ScreenIcon Then Exit Sub + For i = 1 To Level.enemies + If Enemie(i).u = Level.u And Enemie(i).active = 0 And Enemie(i).scene = Level.currentScene Then + Enemie(i).active = -1 + PlayEnemieMusic i + 'echo "[New Enemie] (Scene " + STR$(Level.currentScene) + ")" + 'echo "Type : " + Enemie(i).typ + 'echo "u : " + STR$(Enemie(i).u) + 'echo "Current u : " + STR$(Enemie(i).u) + 'echo " Enemie Scene : " + STR$(Enemie(i).scene) + 'echo "Enemie Movement : " + STR$(Enemie(i).m) + End If + Next + For i = 1 To Level.enemies + If Enemie(i).active And Enemie(i).scene = Level.currentScene Then + 'IF Enemie(i).u = Level.u THEN + ' echo "Rendered" + ' echo "********************************************************************************" + 'END IF + If Enemie(i).f > Enemie(i).n Then SPRITENEXT Enemie(i).img: Enemie(i).f = 0 + + SPRITEPUT Enemie(i).x, Enemie(i).y, Enemie(i).img + + Enemie(i).x = Enemie(i).x + Enemie(i).m + Enemie(i).f = Enemie(i).f + 1 + + If W.SE Then _SndBal Enemie(i).snd, p5map(Enemie(i).x, 0, _Width, -1, 1), p5map(Enemie(i).y, 0, _Height, 1, -1), , 2 + + If Enemie(i).x > _Width + SPRITECURRENTWIDTH(Enemie(i).img) Then Enemie(i).m = -Enemie(i).m: SPRITEFLIP Enemie(i).img, HORIZONTAL: PlayEnemieMusic i + If Enemie(i).x < -SPRITECURRENTWIDTH(Enemie(i).img) Then Enemie(i).m = -Enemie(i).m: SPRITEFLIP Enemie(i).img, NONE: PlayEnemieMusic i + + If Mouse.x > SPRITEX1(Enemie(i).img) And Mouse.x < SPRITEX2(Enemie(i).img) And Mouse.y > SPRITEY1(Enemie(i).img) And Mouse.y < SPRITEY2(Enemie(i).img) Then + Mouse.hovering = -1 + + If Mouse.lclick Then Enemie(i).life = Enemie(i).life - Gun.damage + If Enemie(i).life < 0 Then Enemie(i).life = 0 + + 'Showing Enemie current life with life bar + If Enemie(i).life = 0 Then + _PutImage (Enemie(i).x - SPRITECURRENTWIDTH(Enemie(i).img) / 2, Enemie(i).y - 30), lifeBars(0) + Else + _PutImage (Enemie(i).x - SPRITECURRENTWIDTH(Enemie(i).img) / 2, Enemie(i).y - 30), lifeBars(Int(Enemie(i).life / Enemie(i).life2 * 100) - 1) 'shows life bar :) + End If + End If + 'checking if any enemie is dead :D + If Enemie(i).life = 0 Then + SPRITEHIDE Enemie(i).img + Enemie(i).ending = -1 + Enemie(i).active = 0 + StopEnemieMusic i + 'echo "[Enemie Dead]" + 'echo "Type : " + Enemie(i).typ + 'echo "Enemie Scene" + STR$(Enemie(i).scene) + 'echo "--------------------------------------------------------------------------------------" + 'You will get more score with ShotGun :P + + If Gun.id = 1 Then CurrentScore% = CurrentScore% + Int(Enemie(i).points * 1.4) + + MakeScoreFlash Enemie(i).x, Enemie(i).y, Enemie(i).points + CurrentScore% = CurrentScore% + Enemie(i).points + MakeBloods Enemie(i).x, Enemie(i).y, Enemie(i).typ + End If + End If + Next + + If Mouse.rclick Then + If Gun.id = 1 Then Gun.id = 2: Gun.name = "Ak-47": Gun.damage = 6 Else Gun.id = 1: Gun.name = "Shot Gun": Gun.damage = 3 + Mouse.rclick = 0 + End If + For i = 0 To 20 + If Bloods(i).active Then + If Bloods(i).f > Bloods(i).n Then SPRITENEXT Bloods(i).img: Bloods(i).f = 0: Bloods(i).currentFrame = Bloods(i).currentFrame + 1 + Bloods(i).f = Bloods(i).f + 1 + SPRITEPUT Bloods(i).x, Bloods(i).y, Bloods(i).img + If Bloods(i).currentFrame > Bloods(i).totalFrames * 2 Then Bloods(i).active = 0: SPRITEHIDE Bloods(i).img + End If + Next + For i = 0 To 20 + If explosions(i).active Then + If explosions(i).f > explosions(i).n Then SPRITENEXT explosions(i).img: explosions(i).f = 0: explosions(i).currentFrame = explosions(i).currentFrame + 1 + explosions(i).f = explosions(i).f + 1 + SPRITEPUT explosions(i).x, explosions(i).y, explosions(i).img + If explosions(i).currentFrame > explosions(i).totalFrames Then explosions(i).active = 0: SPRITEHIDE explosions(i).img + End If + Next + + If Seconds% < OldSeconds% Or OldScore% < CurrentScore% Then + If Seconds% < 1 Then Level.over = -1 + OldSeconds% = Seconds% + OldScore% = CurrentScore% + If Seconds% < 11 Then Color _RGB(255, 0, 0) Else Color _RGB(255, 255, 255) + 'redraw scoreboard + _PutImage (0, 520), ScoreBoard& + _PutImage (50, 550)-(170, 590), GunImg&(Gun.id - 1) + _Font Fonts.smaller + _PrintString (40, 580), RTrim$(Gun.name) + _PrintString (600, 560), "Score - " + Str$(CurrentScore%) + If Seconds% >= 60 Then t = Seconds% Mod 60 Else t = Seconds% + _PrintString (600, 580), "Time left - " + Str$(Minutes%) + ":" + Str$(t) + _Font Fonts.normal + If randomLevels Then _PrintString (CenterPrintX("Random Levels"), 560), "Random Levels" Else _PrintString (CenterPrintX("Stage " + Str$(LevelStage%)), 560), "Stage " + Str$(LevelStage%) + + End If + + Level.u = Level.u + 1 + 'creating new game scene + If SceneEnd(Level.currentScene) Then + Level.currentScene = Level.currentScene + 1 + Level.u = 0 + 'echo "Current Scene : " + STR$(Level.currentScene) + If Level.currentScene > Level.scenes Then Level.completed = -1 + End If + + 'game MODS + Select Case Level.mode + Case FOGMODE + Fogs.x = Fogs.x - Fogs.move + If Fogs.x < -1600 Or Fogs.x > 0 Then Fogs.move = -Fogs.move + _PutImage (Fogs.x, 0), Fogs.handle + + Case THUNDERMODE + FallDrops + DrawDrops + + Case STORMMODE + _PutImage (StormX%, 0), StormImg& + StormX% = StormX% - 1 + If StormX% < -2300 Then StormX% = 0 + + Case FOGMODE + THUNDERMODE + Fogs.x = Fogs.x - Fogs.move + If Fogs.x < -1600 Or Fogs.x > 0 Then Fogs.move = -Fogs.move + _PutImage (Fogs.x, 0), Fogs.handle + + FallDrops + DrawDrops + + Case FOGMODE + THUNDERMODE + 7 + Fogs.x = Fogs.x - Fogs.move + If Fogs.x < -1600 Or Fogs.x > 0 Then Fogs.move = -Fogs.move + _PutImage (Fogs.x, 0), Fogs.handle + + FallDrops + DrawDrops + Case STORMMODE + THUNDERMODE + _PutImage (StormX%, 0), StormImg& + StormX% = StormX% - 1 + If StormX% < -2300 Then StormX% = 0 + + FallDrops + DrawDrops + + Case STORMMODE + FOGMODE + THUNDERMODE + Fogs.x = Fogs.x - Fogs.move + If Fogs.x < -1600 Or Fogs.x > 0 Then Fogs.move = -Fogs.move + _PutImage (Fogs.x, 0), Fogs.handle + + _PutImage (StormX%, 0), StormImg& + StormX% = StormX% - 1 + If StormX% < -2300 Then StormX% = 0 + + FallDrops + DrawDrops + + End Select + + 'scores effect + For i = 0 To UBound(ShotScore) + If ShotScore(i).active = -1 Then + ShotScore(i).sclX = Sin(ShotScore(i).__ops) * .5 + .5 + _PutImage (ShotScore(i).x - (ShotScore(i).sclX * _Width(ShotScore(i).img) / 2), ShotScore(i).y - (ShotScore(i).sclX * _Height(ShotScore(i).img)) / 2)-(ShotScore(i).x + (ShotScore(i).sclX * _Width(ShotScore(i).img)) / 2, ShotScore(i).y + (ShotScore(i).sclX * _Height(ShotScore(i).img)) / 2), ShotScore(i).img + ShotScore(i).__ops = ShotScore(i).__ops + .1 + If ShotScore(i).__ops > _Pi(1.5) Then + ShotScore(i).active = 0 + End If + End If + Next + + 'countdown when game time is less or equal to 10s + If Seconds% < 11 Then + Color _RGB(255, 0, 0) + _Font Fonts.biggest + _PrintString (CenterPrintX(RTrim$(LTrim$(Str$(Seconds%)))), _Height / 2 - _FontHeight / 2), RTrim$(LTrim$(Str$(Seconds%))) + End If + + 'cursors + If Mouse.lclick Then + Mouse.lclick = 0 + If W.sfx Then + If Gun.id = 1 Then _SndPlayCopy Gun1& Else _SndPlayCopy Gun2& + End If + End If + If Mouse.hovering Then + Mouse.hovering = 0 + _PutImage (Mouse.x - 16, Mouse.y - 16), Mouse.cursor2 + Else + _PutImage (Mouse.x - 16, Mouse.y - 16), Mouse.cursor + End If + + If Level.mode = THUNDERMODE Or Level.mode = THUNDERMODE + FOGMODE + 7 Then + If thunder_ha_count_limit = 0 Then thunder_ha_count_limit = p5random(1, 4) + If ThunderEvent = 0 Then ThunderEvent = p5random(30, 340) + ThunderCount = ThunderCount + 1 + If ThunderCount > ThunderEvent Then + thunder_f_count = thunder_f_count + 1 + tmp& = _CopyImage(0) + tmp2& = _CopyImage(0) + MakeThunderImage tmp& + _PutImage , tmp& + _Display + _PutImage , tmp2& + _FreeImage tmp& + _FreeImage tmp2& + If thunder_f_count > 3 Then + If thunder_ha_count < thunder_ha_count_limit Then + ' ThunderCount = 0 + thunder_f_count = 0 + ThunderEvent = ThunderEvent + p5random(4, 25) + 3 + thunder_ha_count = thunder_ha_count + 1 + Else + thunder_ha_count = 0 + thunder_f_count = 0 + ThunderEvent = 0 + ThunderCount = 0 + thunder_ha_count_limit = p5random(1, 4) + End If + End If + Else + _Display + End If + Else + _Display + End If + ' $checking:on +End Sub + +Sub MakeBloods (x, y, typ As String * 16) + Select Case RTrim$(typ) + Case "jet1", "jet2", "jet3" + MakeExplosions x, y + Exit Sub + End Select + Dim i As Integer + For i = 0 To 20 + If Bloods(i).active = 0 Then + Bloods(i).active = -1 + Bloods(i).x = x + Bloods(i).y = y + Bloods(i).currentFrame = 1 + SPRITESHOW Bloods(i).img + Exit Sub + End If + Next +End Sub + +Sub MakeExplosions (x, y) + Dim i As Integer + For i = 0 To 20 + If explosions(i).active = 0 Then + explosions(i).active = -1 + explosions(i).x = x + explosions(i).y = y + explosions(i).currentFrame = 1 + SPRITESHOW explosions(i).img + If W.sfx Then _SndPlay Expos& + Exit Sub + End If + Next +End Sub + +Sub MakeScoreFlash (x, y, s) + Dim i As Integer + For i = 0 To UBound(ShotScore) + If ShotScore(i).active = 0 Then + ShotScore(i).active = -1 + ShotScore(i).x = x + ShotScore(i).y = y + ShotScore(i).__ops = -_Pi(.5) + Select Case s + Case 10 + ShotScore(i).img = scoresImage(0) + Case 20 + ShotScore(i).img = scoresImage(1) + Case 35 + ShotScore(i).img = scoresImage(2) + Case 50 + ShotScore(i).img = scoresImage(3) + Case 75 + ShotScore(i).img = scoresImage(4) + Case 100 + ShotScore(i).img = scoresImage(5) + End Select + End If + Next +End Sub + +Sub UpdateTime () + Seconds% = Seconds% - 1 + Minutes% = (Seconds% - (Seconds% Mod 60)) / 60 +End Sub + +Sub CloseTime + Timer(TimerEvent) Off +End Sub + +Sub PlayEnemieMusic (which&) + If W.sfx = 0 Then Exit Sub + + _SndPlay Enemie(which&).snd +End Sub + +Sub StopEnemieMusic (which&) + _SndStop Enemie(which&).snd + Enemie(which&).sndPaused = 2 '2 for stop and 1 for paused +End Sub + +Sub updateSfxVolume () + If Not W.sfx Then Exit Sub + + Dim i As Integer + For i = 1 To Level.enemies + _SndVol Enemie(i).snd, W.sfxV + Next + _SndVol RainSound&, W.sfxV +End Sub + +Sub setMusicVol (v!) + If Not W.music Then Exit Sub + _SndVol Musics&(0), v! + _SndVol Musics&(1), v! + _SndVol Musics&(2), v! +End Sub + +Sub PlayPausedSound () + Dim i As Integer + For i = 1 To Level.enemies + If Enemie(i).sndPaused = 1 Then Enemie(i).sndPaused = 0: _SndPlay Enemie(i).snd + Next + If Level.mode = THUNDERMODE Or Level.mode = FOGMODE + THUNDERMODE Then + If Not _SndPlaying(RainSound&) Then _SndPlay RainSound& + End If +End Sub + +Sub PauseSound () + + Dim i As Integer + For i = 1 To Level.enemies + If Enemie(i).sndPaused = 0 Then _SndStop Enemie(i).snd: Enemie(i).sndPaused = 1 + Next + + If _SndPlaying(RainSound&) Then _SndStop RainSound& + +End Sub + +Function SceneEnd (which%) + Dim i As Integer, d As _Byte + + For i = 1 To Level.enemies + If Enemie(i).ending = 0 And Enemie(i).scene = which% Then d = -1: Exit For + Next + If d = 0 Then SceneEnd = -1 Else SceneEnd = 0 +End Function + +Sub SaveGame () + Dim a$, F As Integer + a$ = "Save_Game\save.dat" + Kill a$ + F = FreeFile + LevelStage% = LevelStage% + 1 + Open a$ For Binary As #F + If HighScore% < CurrentScore% Then Put #F, , CurrentScore% Else Put #F, , HighScore% + Put #F, , LevelStage% + Close #F +End Sub + +Sub SetupRain () + Dim i As Integer + For i = 0 To UBound(Drop) + Drop(i).x = Rnd * _Width + Drop(i).y = -(Rnd * (_Height * 3)) + Drop(i).z = Int(Rnd * 1) + Drop(i).yspeed = Map(Drop(i).z, 0, 1, 1, 2) + Drop(i).len = Map(Drop(i).z, 0, 1, 8, 16) + Drop(i).gravity = Map(Drop(i).z, 0, 1, 0.1, 0.3) + Next + RainVol# = -1.0 +End Sub + +Sub FallDrops () + Dim i As Integer + For i = 0 To UBound(Drop) + Drop(i).y = Drop(i).y + Drop(i).yspeed + Drop(i).yspeed = Drop(i).yspeed + Drop(i).gravity + If Drop(i).y > _Height Then Drop(i).y = Rnd * -400: Drop(i).yspeed = Map(Drop(i).z, 0, 1, 1, 2) + Next +End Sub + +Sub DrawDrops () + Dim i As Integer + If W.sfx Then + ' IF RainVol# < .98 THEN RainVol# = RainVol# + 0.01: _SNDBAL RainSound&, 0, 0, RainVol# + If Not _SndPlaying(RainSound&) Then _SndPlay RainSound& + End If + For i = 0 To UBound(Drop) + If Drop(i).z = 0 Then _PutImage (Drop(i).x, Drop(i).y), Rainx8& Else _PutImage (Drop(i).x, Drop(i).y), Rainx16& + Next + +End Sub + + +Function Map (value, r1, r2, e1, e2) + If value = r1 Then Map = e1 + If value = r2 Then Map = e2 +End Function + +Sub MakeThunderImage (original_img&) + If original_img& = -1 Then Exit Sub + + $Checking:Off + Dim buffer As _MEM, o As _Offset, o2 As _Offset + Dim b As _Unsigned _Byte, n As _Byte + n = p5random(30, 120) + + buffer = _MemImage(original_img&) + o = buffer.OFFSET + o2 = o + _Width(original_img&) * _Height(original_img&) * 4 + Do + ' echo str$(o) + b = _MemGet(buffer, o, _Unsigned _Byte) + If b + n < 256 Then b = b + n Else b = 255 + _MemPut buffer, o, b As _UNSIGNED _BYTE + b = _MemGet(buffer, o + 1, _Unsigned _Byte) + If b + n < 256 Then b = b + n Else b = 255 + _MemPut buffer, o + 1, b As _UNSIGNED _BYTE + b = _MemGet(buffer, o + 2, _Unsigned _Byte) + If b + n < 256 Then b = b + n Else b = 255 + _MemPut buffer, o + 2, b As _UNSIGNED _BYTE + o = o + 4 + Loop Until o = o2 + _MemFree buffer + $Checking:On +End Sub + +Sub centerImage (img&) + _PutImage ((_Width / 2) - (_Width(img&) / 2), (_Height / 2) - (_Height(img&) / 2))-Step(_Width(img&), _Height(img&)), img& +End Sub + +Sub showCredits () + Dim k&, f&, i As Integer, f2&, yy As Integer + + k& = _LoadImage("Images/credits.png", 33) + f& = _NewImage(_Width(k&), _Height(k&), 32) + _Dest f& + For i = 0 To 255 + Line (0, (_Height - 255) + i)-(_Width, (_Height - 255) + i), _RGBA(0, 0, 0, i) + Line (0, 255 - i)-(_Width, 255 - i), _RGBA(0, 0, 0, i) + Next + _Dest 0 + f2& = _CopyImage(f&, 33) + Swap f&, f2& + _FreeImage f2& + yy = _Height + 50 + Do + + _PutImage (50, yy), k& + _PutImage , f& + yy = yy - 1 + + _Display + _Limit W.fps + Loop Until yy < -_Height(k&) + _FreeImage f& + _FreeImage k& +End Sub + +' SUB showCredits2 () +' CLS +' _FONT Fonts.bigger +' _PRINTSTRING (CenterPrintX("Super Hunters 2017-18"), 250), "Super Hunters 2017-18" +' _FONT Fonts.normal +' _PRINTSTRING (CenterPrintX("By Ashish Kushwaha"), 290), "By Ashish Kushwaha" +' initTextParticles _RGB(255, 255, 255) +' CLS +' DO +' CLS +' moveTextParticles +' _LIMIT W.fps +' _DISPLAY +' LOOP UNTIL Text_Particles_Status = 1 +' _DELAY 1 +' fallTextParticles "fall" +' CLS +' _FONT Fonts.bigger +' _PRINTSTRING (CenterPrintX("Programmer"), 250), "Programmer" +' _FONT Fonts.normal +' _PRINTSTRING (CenterPrintX("Ashish Kushwaha"), 290), "Ashish Kushwaha" +' initTextParticles _RGB(255, 255, 255) +' ' _DISPLAY: SLEEP +' CLS +' DO +' CLS +' moveTextParticles +' _LIMIT W.fps +' _DISPLAY +' LOOP UNTIL Text_Particles_Status = 1 +' _DELAY 1 +' fallTextParticles "lessgravity" +' CLS +' _FONT Fonts.bigger +' _PRINTSTRING (CenterPrintX("Graphic Designer"), 250), "Graphic Designer" +' _FONT Fonts.normal +' _PRINTSTRING (CenterPrintX("Google Images & Ashish Kushwaha"), 290), "Google Images & Ashish Kushwaha" +' initTextParticles _RGB(255, 255, 255) +' CLS +' DO +' CLS +' moveTextParticles +' _LIMIT W.fps +' _DISPLAY +' LOOP UNTIL Text_Particles_Status = 1 +' _DELAY 1 +' fallTextParticles "explode" +' CLS +' _FONT Fonts.bigger +' _PRINTSTRING (CenterPrintX("Level Designer"), 250), "Level Designer" +' _FONT Fonts.normal +' _PRINTSTRING (CenterPrintX("Ashish Kushwaha"), 290), "Ashish Kushwaha" +' initTextParticles _RGB(255, 255, 255) +' CLS +' DO +' CLS +' moveTextParticles +' _LIMIT W.fps +' _DISPLAY +' LOOP UNTIL Text_Particles_Status = 1 +' _DELAY 1 +' fallTextParticles "horizontal" +' CLS +' _FONT Fonts.bigger +' _PRINTSTRING (CenterPrintX("Special Thanks -"), 230), "Special Thanks -" +' _FONT Fonts.normal +' _PRINTSTRING (CenterPrintX("Terry Ritchie for sprite library"), 270), "Terry Ritchie for sprite library" +' _PRINTSTRING (CenterPrintX("Unseenmachine & Waltersmind for BlurImage"), 320), "Unseenmachine & Waltersmind for BlurImage" +' _PRINTSTRING (CenterPrintX("and player of this game!"), 345), "and player of this game!" +' initTextParticles _RGB(255, 255, 255) +' CLS +' DO +' CLS +' moveTextParticles +' _LIMIT W.fps +' _DISPLAY +' LOOP UNTIL Text_Particles_Status = 1 +' _DELAY 1 +' fallTextParticles "boom" + +' END SUB + +' SUB initTextParticles (which~&) +' SHARED Text_Particles() AS Vector_Particles_Text_Type +' FOR y = 0 TO _HEIGHT - 1 +' FOR x = 0 TO _WIDTH - 1 +' col~& = POINT(x, y) +' IF col~& = which~& THEN n = n + 1 +' NEXT x, y + +' REDIM Text_Particles(n) AS Vector_Particles_Text_Type +' n = 0 +' Text_Particles_Color = which~& +' FOR x = 0 TO _WIDTH - 1 +' FOR y = 0 TO _HEIGHT - 1 +' col~& = POINT(x, y) +' IF col~& = which~& THEN +' Text_Particles(n).x = x +' Text_Particles(n).y = y +' Text_Particles(n).vx = p5random(0, _WIDTH) +' Text_Particles(n).vy = p5random(0, _HEIGHT) +' Text_Particles(n).dist = dist(Text_Particles(n).vx, Text_Particles(n).vy, Text_Particles(n).x, Text_Particles(n).y) +' Text_Particles(n).distX = ABS(Text_Particles(n).x - Text_Particles(n).vx) +' Text_Particles(n).distY = ABS(Text_Particles(n).y - Text_Particles(n).vy) +' n = n + 1 +' END IF +' NEXT y, x +' END SUB + +' SUB moveTextParticles () +' SHARED Text_Particles() AS Vector_Particles_Text_Type +' FOR i = 0 TO UBOUND(Text_Particles) +' IF Text_Particles(i).k < Text_Particles(i).dist THEN +' PSET (Text_Particles(i).vx + Text_Particles(i).delX, Text_Particles(i).vy + Text_Particles(i).delY), Text_Particles_Color +' IF Text_Particles(i).vx > Text_Particles(i).x THEN Text_Particles(i).delX = Text_Particles(i).delX - Text_Particles(i).distX / Text_Particles(i).dist ELSE Text_Particles(i).delX = Text_Particles(i).delX + Text_Particles(i).distX / Text_Particles(i).dist +' IF Text_Particles(i).vy > Text_Particles(i).y THEN Text_Particles(i).delY = Text_Particles(i).delY - Text_Particles(i).distY / Text_Particles(i).dist ELSE Text_Particles(i).delY = Text_Particles(i).delY + Text_Particles(i).distY / Text_Particles(i).dist +' Text_Particles(i).k = Text_Particles(i).k + 1 +' ELSE +' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color +' check = check + 1 +' END IF +' NEXT +' IF check >= UBOUND(text_particles) THEN Text_Particles_Status = 1: EXIT SUB ELSE Text_Particles_Status = 0 + +' END SUB + +' SUB fallTextParticles (typ$) +' SHARED Text_Particles() AS Vector_Particles_Text_Type +' typ$ = LCASE$(typ$) +' SELECT CASE typ$ +' CASE "explode" +' FOR i = 0 TO UBOUND(Text_Particles) +' Text_Particles(i).vx = 0 +' Text_Particles(i).vy = 0 +' Text_Particles(i).delX = p5random(-0.1, 0.1) +' Text_Particles(i).delY = p5random(-0.1, 0.1) +' NEXT +' DO +' CLS +' z = 0 +' FOR i = 0 TO UBOUND(Text_Particles) + +' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color +' IF i < array_len THEN +' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx +' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy +' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX +' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY +' END IF +' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1 +' NEXT +' IF array_len < UBOUND(Text_Particles) THEN array_len = array_len + steps +' _DISPLAY +' _LIMIT W.fps +' steps = steps + 1 +' IF z > UBOUND(Text_Particles) THEN EXIT DO +' LOOP UNTIL INKEY$ <> "" +' EXIT SUB +' CASE "fall" +' FOR i = 0 TO UBOUND(text_particles) +' Text_Particles(i).vx = 0 +' Text_Particles(i).vy = 0 +' Text_Particles(i).delX = p5random(-.02, .02) +' Text_Particles(i).delY = p5random(0.1, 0.2) +' NEXT +' DO +' CLS +' z = 0 +' FOR i = 0 TO UBOUND(text_particles) +' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color +' IF i < array_len THEN +' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx +' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy +' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX +' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY +' END IF +' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1 +' NEXT +' IF array_len < UBOUND(text_particles) THEN array_len = array_len + steps +' _DISPLAY +' _LIMIT W.fps +' steps = steps + 1 +' IF z = UBOUND(text_particles) THEN EXIT DO +' LOOP +' EXIT SUB + +' CASE "lessgravity" +' FOR i = 0 TO UBOUND(Text_Particles) +' Text_Particles(i).vx = 0 +' Text_Particles(i).vy = 0 +' Text_Particles(i).delX = p5random(-.02, .02) +' Text_Particles(i).delY = p5random(-0.1, -0.2) +' NEXT +' DO +' CLS +' z = 0 +' FOR i = 0 TO UBOUND(Text_Particles) +' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color +' IF i < array_len THEN +' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx +' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy +' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX +' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY +' END IF +' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1 +' NEXT +' IF array_len < UBOUND(Text_Particles) THEN array_len = array_len + steps +' _DISPLAY +' _LIMIT W.fps +' steps = steps + 1 +' LOOP UNTIL INKEY$ <> "" OR z >= UBOUND(text_particles) +' EXIT SUB +' CASE "horizontal" +' FOR i = 0 TO UBOUND(Text_Particles) +' Text_Particles(i).vx = 0 +' Text_Particles(i).vy = 0 +' Text_Particles(i).delX = p5random(-.2, .2) +' Text_Particles(i).delY = 0 +' NEXT +' DO +' CLS +' z = 0 +' FOR i = 0 TO UBOUND(Text_Particles) +' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color +' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx +' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy +' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX +' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY +' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1 +' NEXT +' _DISPLAY +' _LIMIT W.fps +' LOOP UNTIL INKEY$ <> "" OR z >= UBOUND(text_particles) +' EXIT SUB +' CASE "vertical" +' FOR i = 0 TO UBOUND(Text_Particles) +' Text_Particles(i).vx = 0 +' Text_Particles(i).vy = 0 +' Text_Particles(i).delX = 0 +' Text_Particles(i).delY = p5random(-0.2, 0.2) +' NEXT +' DO +' CLS +' z = 0 +' FOR i = 0 TO UBOUND(Text_Particles) +' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color + +' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx +' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy +' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX +' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY + +' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1 +' NEXT +' _DISPLAY +' _LIMIT W.fps +' LOOP UNTIL INKEY$ <> "" OR z >= UBOUND(text_particles) +' EXIT SUB + +' CASE "boom" +' FOR i = 0 TO UBOUND(Text_Particles) +' Text_Particles(i).vx = 0 +' Text_Particles(i).vy = 0 +' Text_Particles(i).delX = p5random(-.1, .1) +' Text_Particles(i).delY = p5random(-0.1, 0.1) +' NEXT +' DO +' CLS +' steps = 0 +' FOR i = 0 TO UBOUND(Text_Particles) +' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color +' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx +' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy +' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX +' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY +' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN steps = steps + 1 +' NEXT +' _DISPLAY +' _LIMIT W.fps +' IF steps > UBOUND(Text_Particles) THEN EXIT DO +' LOOP UNTIL INKEY$ <> "" OR steps > UBOUND(text_particles) +' EXIT SUB +' END SELECT +' END SUB + +Sub centerPrint (a$, b) + Dim i As Integer, v As Integer + For i = 1 To Len(a$) + v = v + _PrintWidth(Mid$(a$, i, 1)) + Next + _PrintString (_Width / 2 - v / 2, b), a$ +End Sub + +Function txtWidth (a$) + Dim i As Integer, v As Integer, g As Integer + For i = 1 To Len(a$) + g = _PrintWidth(Mid$(a$, i, 1)) + v = v + g + Next + txtWidth = v +End Function +'these p5random(), p5map! (original map!) and dist() functions are taken from p5js.bas +Function p5random! (mn!, mx!) + Dim tmp! + + If mn! > mx! Then + tmp! = mn! + mn! = mx! + mx! = tmp! + End If + p5random! = Rnd * (mx! - mn!) + mn! +End Function + +Function dist! (x1!, y1!, x2!, y2!) + dist! = Sqr((x2! - x1!) ^ 2 + (y2! - y1!) ^ 2) +End Function + +Function p5map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!) + p5map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange! +End Function + + +'By UnseenMachine & Waltersmind +'http://www.qb64.net/forum/index.php?topic=12658 +Sub BLURIMAGE (Image As Long, Blurs As _Unsigned Integer) + + Dim ImageMemory As _MEM + Dim ImageOffsetCurrent As _Offset + Dim ImageOffsetStart As _Offset + Dim ImageOffsetEnd As _Offset + + Dim TopOffset As _Offset + Dim LeftOffset As _Offset + Dim RightOffset As _Offset + Dim BottomOffset As _Offset + + Dim Red1 As _Unsigned _Byte + Dim Green1 As _Unsigned _Byte + Dim Blue1 As _Unsigned _Byte + Dim Alpha1 As _Unsigned _Byte + + Dim Red2 As _Unsigned _Byte + Dim Green2 As _Unsigned _Byte + Dim Blue2 As _Unsigned _Byte + Dim Alpha2 As _Unsigned _Byte + + Dim Red3 As _Unsigned _Byte + Dim Green3 As _Unsigned _Byte + Dim Blue3 As _Unsigned _Byte + Dim Alpha3 As _Unsigned _Byte + + Dim Red4 As _Unsigned _Byte + Dim Green4 As _Unsigned _Byte + Dim Blue4 As _Unsigned _Byte + Dim Alpha4 As _Unsigned _Byte + + ImageMemory = _MemImage(Image) + + $Checking:Off + + Dim iterations% + + For iterations% = 0 To Blurs - 1 + + ImageOffsetStart = ImageMemory.OFFSET + ImageOffsetCurrent = ImageOffsetStart + ImageOffsetEnd = ImageOffsetStart + _Width(Image) * _Height(Image) * 4 + + Do + TopOffset = ImageOffsetCurrent - _Width(Image) * 4 + LeftOffset = ImageOffsetCurrent - 4 + RightOffset = ImageOffsetCurrent + 4 + BottomOffset = ImageOffsetCurrent + _Width(Image) * 4 + + ' *** Let's go ahead and set the color values to zero, and only change them when required. + Red1 = 0: Green1 = 0: Blue1 = 0: Alpha1 = 0 + Red2 = 0: Green2 = 0: Blue2 = 0: Alpha2 = 0 + Red3 = 0: Green3 = 0: Blue3 = 0: Alpha3 = 0 + Red4 = 0: Green4 = 0: Blue4 = 0: Alpha4 = 0 + + ' *** Get the color values from the pixel above the current pixel, if it is with the image. + If TopOffset >= ImageOffsetStart Then + Red1 = _MemGet(ImageMemory, TopOffset + 2, _Unsigned _Byte) + Green1 = _MemGet(ImageMemory, TopOffset + 1, _Unsigned _Byte) + Blue1 = _MemGet(ImageMemory, TopOffset, _Unsigned _Byte) + Alpha1 = _MemGet(ImageMemory, TopOffset + 3, _Unsigned _Byte) + End If + + ' *** Get the color values from the pixel to the left of the current pixel, if it is with the image. + If ((((LeftOffset - ImageOffsetStart) / 4) Mod _Width(Image)) < (((ImageOffsetCurrent - ImageOffsetStart) / 4) Mod _Width(Image))) Then + Red2 = _MemGet(ImageMemory, LeftOffset + 2, _Unsigned _Byte) + Green2 = _MemGet(ImageMemory, LeftOffset + 1, _Unsigned _Byte) + Blue2 = _MemGet(ImageMemory, LeftOffset, _Unsigned _Byte) + Alpha2 = _MemGet(ImageMemory, LeftOffset + 3, _Unsigned _Byte) + End If + + ' *** Get the color values from the pixel to the right of the current pixel, if it is with the image. + If ((((RightOffset - ImageOffsetStart) / 4) Mod _Width(Image)) > (((ImageOffsetCurrent - ImageOffsetStart) / 4) Mod _Width(Image))) Then + Red3 = _MemGet(ImageMemory, RightOffset + 2, _Unsigned _Byte) + Green3 = _MemGet(ImageMemory, RightOffset + 1, _Unsigned _Byte) + Blue3 = _MemGet(ImageMemory, RightOffset, _Unsigned _Byte) + Alpha3 = _MemGet(ImageMemory, RightOffset + 3, _Unsigned _Byte) + End If + + ' *** Get the color values from the pixel below the current pixel, if it is with the image. + If BottomOffset < ImageOffsetEnd Then + Red4 = _MemGet(ImageMemory, BottomOffset + 2, _Unsigned _Byte) + Green4 = _MemGet(ImageMemory, BottomOffset + 1, _Unsigned _Byte) + Blue4 = _MemGet(ImageMemory, BottomOffset, _Unsigned _Byte) + Alpha4 = _MemGet(ImageMemory, BottomOffset + 3, _Unsigned _Byte) + End If + + ' *** draw the current pixel with a newly defined _RGBA color value. + _MemPut ImageMemory, ImageOffsetCurrent, _RGBA((Red1 + Red2 + Red3 + Red4) / 4, (Green1 + Green2 + Green3 + Green4) / 4, (Blue1 + Blue2 + Blue3 + Blue4) / 4, (Alpha1 + Alpha2 + Alpha3 + Alpha4) / 4) As _UNSIGNED LONG + + '' *** These are here for fun nd testing purposes. + '_MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA((Red1 + Red2 + Red3 + Red4) / 4, (Green1 + Green2 + Green3 + Green4) / 4, (Blue1 + Blue2 + Blue3 + Blue4) / 4, 255) AS _UNSIGNED LONG + '_MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA(0, 0, (Blue1 + Blue2 + Blue3 + Blue4) / 4, 255) AS _UNSIGNED LONG + '_MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA(0, (Green1 + Green2 + Green3 + Green4) / 4, 0, 255) AS _UNSIGNED LONG + '_MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA((Red1 + Red2 + Red3 + Red4) / 4, 0, 0, 255) AS _UNSIGNED LONG + + ImageOffsetCurrent = ImageOffsetCurrent + 4 + + Loop Until ImageOffsetCurrent = ImageOffsetEnd + + Next + + $Checking:On + _MemFree ImageMemory + +End Sub +'$include:'Vendor\sprite.bi' + +'End of Code ! :) + diff --git a/samples/hunters-revenge/src/main.zip b/samples/hunters-revenge/src/main.zip new file mode 100644 index 0000000..84409cf Binary files /dev/null and b/samples/hunters-revenge/src/main.zip differ diff --git a/samples/image-manipulation.md b/samples/image-manipulation.md new file mode 100644 index 0000000..88767e9 --- /dev/null +++ b/samples/image-manipulation.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: IMAGE MANIPULATION + +**[Jpeg Maker](jpeg-maker/index.md)** + +[🐝 Artelius](artelius.md) 🔗 [jpeg](jpeg.md), [image manipulation](image-manipulation.md) + +'JPEG Encoder v2 by Artelius 'WARNING: OVERWRITES TEST.JPG diff --git a/samples/integrators/img/screenshot.png b/samples/integrators/img/screenshot.png new file mode 100644 index 0000000..44b341f Binary files /dev/null and b/samples/integrators/img/screenshot.png differ diff --git a/samples/integrators/index.md b/samples/integrators/index.md new file mode 100644 index 0000000..e760b46 --- /dev/null +++ b/samples/integrators/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: INTEGRATORS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 STxAxTIC](../stxaxtic.md) + +### Description + +```text +Demonstrates the efficacy of various integration methods in physics. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "integrators.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/integrators/src/integrators.bas) +* [RUN "integrators.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/integrators/src/integrators.bas) +* [PLAY "integrators.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/integrators/src/integrators.bas) + +### File(s) + +* [integrators.bas](src/integrators.bas) + +🔗 [physics](../physics.md), [simulation](../simulation.md) diff --git a/samples/integrators/src/integrators.bas b/samples/integrators/src/integrators.bas new file mode 100644 index 0000000..1db6565 --- /dev/null +++ b/samples/integrators/src/integrators.bas @@ -0,0 +1,347 @@ +'OPTION _EXPLICIT + +Do Until _ScreenExists: Loop +_Title "Integrators" + +Screen _NewImage(1280, 480, 32) + +Const Black = _RGB32(0, 0, 0) +Const Blue = _RGB32(0, 0, 255) +Const Gray = _RGB32(128, 128, 128) +Const Green = _RGB32(0, 128, 0) +Const Red = _RGB32(255, 0, 0) +Const White = _RGB32(255, 255, 255) +Const Yellow = _RGB32(255, 255, 0) + +problem$ = ProblemPrompt$(0) + +' Initial conditions +q10 = 0 +p10 = 0 +q20 = 0 +p20 = 0 +Select Case Val(Left$(problem$, 1)) + Case 1 + dt = .003 + cyclic = 1 + delayfactor = 1000 + scalebig = 20 + scalesmall = dt * 5 + m1 = 1 + m2 = 1 + g = 1 + Select Case (Right$(problem$, 1)) + Case "a" + q10 = 1: p10 = -.2: q20 = 0: p20 = 1 + Case "b" + q10 = .5: p10 = 1: q20 = -.5: p20 = 1 + Case "c" + q10 = 1: p10 = .5: q20 = 0: p20 = 1.15 + End Select + Case 2 + dt = .001 + cyclic = 0 + delayfactor = 1000 + scalebig = 20 + scalesmall = dt * 10 + m1 = 1 + m2 = 1 + g = 1 + Select Case (Right$(problem$, 1)) + Case "a" + q10 = 1: p10 = 0: q20 = 0: p20 = 1.22437 + End Select + Case 3 + dt = .03 + cyclic = 0 + delayfactor = 1000 + scalebig = 10 + scalesmall = dt * 7.5 + m = 1 + k = 1 + Select Case (Right$(problem$, 1)) + Case "a" + q10 = 0: p10 = 2 + Case "b" + q10 = 2: p10 = 0 + End Select + Case 4 + dt = .003 + cyclic = 1 + delayfactor = 50000 + scalebig = 12 + scalesmall = dt * 7.5 + m = 1 + k = 1 + Select Case (Right$(problem$, 1)) + Case "a" + q10 = 0: p10 = 2: q20 = 0: p20 = 2 + Case "b" + q10 = 2: p10 = 0: q20 = -2: p20 = 0 + Case "c" + q10 = 2: p10 = 0: q20 = 0: p20 = 0 + End Select + Case 5 + dt = .03 + cyclic = 1 + delayfactor = 500000 + scalebig = 10 + scalesmall = dt * 5 + m = 1 + g = 1 + l = 1 + Select Case (Right$(problem$, 1)) + Case "a" + q10 = 0: p10 = 1.5: scalebig = 10 + End Select + Case 6 + dt = .03 + cyclic = 1 + delayfactor = 500000 + scalebig = 10 + scalesmall = dt * 5 + m = 1 + g = 1 + l = 1 + Select Case (Right$(problem$, 1)) + Case "a" + q10 = 0: p10 = 2.19 + Case "b" + q10 = 0: p10 = 2.25 + End Select + Case 7, 8 + dt = .03 + cyclic = 1 + delayfactor = 500000 + scalebig = 10 + scalesmall = dt * 5 + m = 1 + g = 1 + l = 1 + Select Case (Right$(problem$, 1)) + Case "a" + q10 = 0: p10 = -1.5 + Case "b" + q10 = 0: p10 = 1.999 + Case "c" + q10 = 0: p10 = 2.001 + End Select + Case Else + problem$ = ProblemPrompt$(0) +End Select + +Cls +Call DrawAxes + +' Main loop. +iterations = 0 +q1 = q10 +p1 = p10 +q2 = q20 +p2 = p20 + +Do + + For thedelay = 0 To delayfactor: Next + + q1temp = q1 + p1temp = p1 + q2temp = q2 + p2temp = p2 + + Select Case Val(Left$(problem$, 1)) + Case 1 + ' Particle in r^-1 central potential - Symplectic integrator + q1 = q1temp + dt * (p1temp / m2) + q2 = q2temp + dt * (p2temp / m2) + p1 = p1temp - dt * g * m1 * m2 * (q1 / ((q1 ^ 2 + q2 ^ 2) ^ (3 / 2))) + p2 = p2temp - dt * g * m1 * m2 * (q2 / ((q1 ^ 2 + q2 ^ 2) ^ (3 / 2))) + Case 2 + ' Particle in r^-2 central potential - Symplectic integrator + q1 = q1temp + dt * (p1temp / m2) + q2 = q2temp + dt * (p2temp / m2) + p1 = p1temp - dt * g * m1 * m2 * ((3 / 2) * q1 / ((q1 ^ 2 + q2 ^ 2) ^ (5 / 2))) + p2 = p2temp - dt * g * m1 * m2 * ((3 / 2) * q2 / ((q1 ^ 2 + q2 ^ 2) ^ (5 / 2))) + Case 3 + ' Mass on a spring - Forward Euler method + q1 = q1temp + (p1temp / m) * dt + p1 = p1temp - (q1temp * k) * dt + ' Mass on a spring - Backward Euler method + q2 = (q2temp + (p2temp / m) * dt) / (1 + dt ^ 2) + p2 = (p2temp - (q2temp * k) * dt) / (1 + dt ^ 2) + Case 4 + ' Two equal masses connected by three springs - Symplectic integrator + q1 = q1temp + m * (p1temp) * dt + p1 = p1temp - dt * k * (2 * (q1temp + m * (p1temp) * dt) - (q2temp + m * (p2temp) * dt)) + q2 = q2temp + m * (p2temp) * dt + p2 = p2temp - dt * k * (2 * (q2temp + m * (p2temp) * dt) - (q1temp + m * (p1temp) * dt)) + Case 5 + ' Plane pendulum - Forward Euler method + q1 = q1temp + (p1temp / m) * dt + p1 = p1temp - (g / l) * Sin(q1temp) * dt + Case 6 + ' Plane pendulum - Runge-Kutta 4th + k1w = -(g / l) * Sin(q1temp) + k1t = p1temp + w2 = p1temp + k1w * dt / 2 + t2 = q1temp + k1t * dt / 2 + k2w = -(g / l) * Sin(t2) + k2t = w2 + w3 = p1temp + k2w * dt / 2 + t3 = q1temp + k2t * dt / 2 + k3w = -(g / l) * Sin(t3) + k3t = w3 + w4 = p1temp + k3w * dt + t4 = q1temp + k3t * dt + k4w = -(g / l) * Sin(t4) + dwdt = (k1w + 2 * k2w + 2 * k3w + k4w) / 6 + dtdt = (k1t + 2 * k2t + 2 * k3t + k4t) / 6 + p1 = p1temp + dwdt * dt + q1 = q1temp + dtdt * dt + Case 7 + ' Plane pendulum - Symplectic integrator + q1 = q1temp + dt * (p1temp / m) + p1 = p1temp - dt * (g / l) * (Sin(q1)) + Case 8 + ' Plane pendulum - Modified Euler method + q1 = q1temp + (p1temp / m) * dt + p1 = p1temp - (g / l) * Sin(q1) * dt + End Select + + x = (iterations * scalesmall - 180) + If (x <= 80) Then + x = x + (320 - _Width / 2) + Call cpset(x, (q1 * scalebig + 160), Yellow) ' q1 plot + Call cpset(x, (p1 * scalebig + 60), Yellow) ' p1 plot + Call cpset(x, (q2 * scalebig - 60), Red) ' q2 plot + Call cpset(x, (p2 * scalebig - 160), Red) ' p2 plot + Else + If (cyclic = 1) Then + iterations = 0 + Paint (1, 1), _RGBA(0, 0, 0, 100) + Call DrawAxes + Else + Exit Do + End If + End If + + ' Phase portrait + Call cpset((q1temp * (2 * scalebig) + (190 + (320 - _Width / 2))), (p1temp * (2 * scalebig) + 100), Yellow) + Call cpset((q1 * (2 * scalebig) + (190 + (320 - _Width / 2))), (p1 * (2 * scalebig) + 100), Gray) + Call cpset((q2temp * (2 * scalebig) + (190 + (320 - _Width / 2))), (p2temp * (2 * scalebig) + 100), Red) + Call cpset((q2 * (2 * scalebig) + (190 + (320 - _Width / 2))), (p2 * (2 * scalebig) + 100), White) + + ' Position portrait + Call cpset((q1temp * (2 * scalebig) + (190 + (320 - _Width / 2))), (q2temp * (2 * scalebig) - 100), Blue) + Call cpset((q1 * (2 * scalebig) + (190 + (320 - _Width / 2))), (q2 * (2 * scalebig) - 100), White) + + ' System portrait - Requires 2x wide window. + Select Case Val(Left$(problem$, 1)) + Case 4 + Call cline(160, 0, 220 + 20 * q1, 0, Green) + Call cline(220 + 20 * q1, 0, 380 + 20 * q2, 0, Yellow) + Call cline(380 + 20 * q2, 0, 440, 0, Green) + Call ccircle(220 + 20 * q1temp, 0, 15, Black) + Call ccircle(220 + 20 * q1, 0, 15, Blue) + Call ccircle(380 + 20 * q2temp, 0, 15, Black) + Call ccircle(380 + 20 * q2, 0, 15, Red) + Case 5, 6, 7, 8 + Call cline(200, 0, 400, 0, White) + Call cline(300, 0, 300 + 100 * Sin(q1temp), -100 * Cos(q1temp), Black) + Call cline(300, 0, 300 + 100 * Sin(q1), -100 * Cos(q1), Blue) + End Select + + iterations = iterations + 1 + + '_DISPLAY + '_Limit 1000 + +Loop Until InKey$ <> "" +Do: Loop Until InKey$ <> "" + +End + +Function ProblemPrompt$ (dummy As Integer) + Dim p As String + _KeyClear + Cls + Color White + Print " Type a problem number and press ENTER." + Print + Print " PROBLEM" + Print " 1) Particle in r^-1 central potential" + Print " a) Perturbed motion ......................... Stable, Symplectic" + Print " b) Elliptical motion ........................ Stable, Symplectic" + Print " c) Eccentric elliptical motion .............. Stable, Symplectic" + Print " 2) Particle in r^-2 central potential" + Print " a) Attempted circular motion ................ Unstable, Symplectic" + Print " 3) Mass on a spring" + Print " a) Initial Momentum ..........*Incorrect*.... Unstable, Euler" + Print " b) Initial Displacement ......*Incorrect*.... Unstable, Euler" + Print " 4) Two equal masses connected by three springs" + Print " a) Symmetric mode ........................... Stable, Symplectic" + Print " b) Antisymmetric mode ....................... Stable, Symplectic" + Print " c) Perturbed motion ......................... Stable, Symplectic" + Print " 5) Plane pendulum (Part I)" + Print " a) Initial Momentum ..........*Incorrect*.... Unstable, Euler" + Print " 6) Plane pendulum (Part III)" + Print " a) Sub-critical case ........................ Stable, RK4" + Print " b) Over-critical case ....................... Stable, RK4" + Print " 7) Plane pendulum (Part III)" + Print " a) Initial Displacement ..................... Stable, Symplectic" + Print " b) Sub-critical case ........................ Stable, Symplectic" + Print " c) Over-critical case ....................... Stable, Symplectic" + Print " 8) Plane pendulum (Part IV)" + Print " a) Initial Displacement ..................... Stable, Mixed Euler"; "" + Print + Input " Enter a problem (ex. 1a): ", p + p = LTrim$(RTrim$(LCase$(p))) + ProblemPrompt = p +End Function + +Sub DrawAxes + Cls + ' Axis for q1 plot + Color White + Locate 2, 3: Print "Generalized" + Locate 3, 3: Print "Coordinates" + Call cline(-_Width / 2 + 140, 160, -_Width / 2 + 400, 160, Gray) + Color White: Locate 5, 3: Print "Position q1(t)" + Color Gray: Locate 6, 3: Print "q1(0) ="; q10 + ' Axis for p1 plot + Call cline(-_Width / 2 + 140, 60, -_Width / 2 + 400, 60, Gray) + Color White: Locate 11, 3: Print "Momentum p1(t)" + Color Gray: Locate 12, 3: Print "p1(0) ="; p10 + ' Axis for q2 plot + Call cline(-_Width / 2 + 140, -60, -_Width / 2 + 400, -60, Gray) + Color White: Locate 18, 3: Print "Position q2(t)" + Color Gray: Locate 19, 3: Print "q2(0) ="; q20 + ' Axis for p2 plot + Call cline(-_Width / 2 + 140, -160, -_Width / 2 + 400, -160, Gray) + Color White: Locate 25, 3: Print "Momentum p2(t)" + Color Gray: Locate 26, 3: Print "p2(0) ="; p20 + ' Axes for q & p plots + Color White + Locate 2, 60: Print "Phase and" + Locate 3, 58: Print "Position Plots" + Locate 4, 66: Print "p" + Locate 10, 76: Print "q" + Call cline((190 + (320 - _Width / 2)), 80 + 100, (190 + (320 - _Width / 2)), -80 + 100, Gray) + Call cline((190 + (320 - _Width / 2)) - 100, 100, (190 + (320 - _Width / 2)) + 100, 100, Gray) + Locate 17, 66: Print "q2" + Locate 23, 75: Print "q1" + Call cline((190 + (320 - _Width / 2)), -80 - 100, (190 + (320 - _Width / 2)), 80 - 100, Gray) + Call cline((190 + (320 - _Width / 2)) - 100, -100, (190 + (320 - _Width / 2)) + 100, -100, Gray) +End Sub + +Sub cline (x1, y1, x2, y2, col As _Unsigned Long) + Line (_Width / 2 + x1, -y1 + _Height / 2)-(_Width / 2 + x2, -y2 + _Height / 2), col +End Sub + +Sub ccircle (x1, y1, rad, col As _Unsigned Long) + Circle (_Width / 2 + x1, -y1 + _Height / 2), rad, col +End Sub + +Sub cpset (x1, y1, col As _Unsigned Long) + PSet (_Width / 2 + x1, -y1 + _Height / 2), col +End Sub diff --git a/samples/interface.md b/samples/interface.md new file mode 100644 index 0000000..89cc41c --- /dev/null +++ b/samples/interface.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: INTERFACE + +**[TUI](tui/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [interface](interface.md), [tui](tui.md) + +Text User Interface for QB64 projects diff --git a/samples/interpolation.md b/samples/interpolation.md new file mode 100644 index 0000000..d18671c --- /dev/null +++ b/samples/interpolation.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: INTERPOLATION + +**[Curve Smoother](curve-smoother/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [curve](curve.md), [interpolation](interpolation.md) + +This program demonstrates (i) linear interpolation to create a curve between points, (ii) a relax... diff --git a/samples/interpreter.md b/samples/interpreter.md new file mode 100644 index 0000000..81fb254 --- /dev/null +++ b/samples/interpreter.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: INTERPRETER + +**[Lisp Interpreter](lisp-interpreter/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [interpreter](interpreter.md), [lisp](lisp.md) + +Scheme is a functional programming language that uses a minimalist implementation of the LISP lan... diff --git a/samples/intersections.md b/samples/intersections.md index 4ddd6f7..8b9ad34 100644 --- a/samples/intersections.md +++ b/samples/intersections.md @@ -19,3 +19,9 @@ This is an interactive (mouse-driven) demo that calculates the intersection of a [🐝 STxAxTIC](stxaxtic.md) 🔗 [geometry](geometry.md), [intersections](intersections.md) ... all I could think is "why stop at circles when you can do ellipses?" + +**[Lines Intersecting](lines-intersecting/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [geometry](geometry.md), [intersections](intersections.md) + +Line segments intersecting. diff --git a/samples/inverse-julia-fractal-explorer/index.md b/samples/inverse-julia-fractal-explorer/index.md index bf82edc..8414697 100644 --- a/samples/inverse-julia-fractal-explorer/index.md +++ b/samples/inverse-julia-fractal-explorer/index.md @@ -18,9 +18,9 @@ The longer you hold your mouse at one position, the more it starts to glow. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "inversejulia.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/inverse-julia-fractal-explorer/src/inversejulia.bas) -* [RUN "inversejulia.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/inverse-julia-fractal-explorer/src/inversejulia.bas) -* [PLAY "inversejulia.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/inverse-julia-fractal-explorer/src/inversejulia.bas) +* [LOAD "inversejulia.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/inverse-julia-fractal-explorer/src/inversejulia.bas) +* [RUN "inversejulia.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/inverse-julia-fractal-explorer/src/inversejulia.bas) +* [PLAY "inversejulia.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/inverse-julia-fractal-explorer/src/inversejulia.bas) ### File(s) diff --git a/samples/isometric.md b/samples/isometric.md new file mode 100644 index 0000000..5a38b25 --- /dev/null +++ b/samples/isometric.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: ISOMETRIC + +**[Relief 3D](relief-3d/index.md)** + +[🐝 Danilin](danilin.md) 🔗 [graphics](graphics.md), [isometric](isometric.md) + +Isometric 3D demo. diff --git a/samples/john-wolfskill.md b/samples/john-wolfskill.md new file mode 100644 index 0000000..20507e9 --- /dev/null +++ b/samples/john-wolfskill.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 JOHN WOLFSKILL + +**[Diamond Pong](diamond-pong/index.md)** + +[🐝 John Wolfskill](john-wolfskill.md) 🔗 [game](game.md), [pong](pong.md), [dos world](dos-world.md) + +' Diamond Pong ' by ' John Wol... diff --git a/samples/jpeg-maker/img/screenshot.png b/samples/jpeg-maker/img/screenshot.png new file mode 100644 index 0000000..753b699 Binary files /dev/null and b/samples/jpeg-maker/img/screenshot.png differ diff --git a/samples/jpeg-maker/index.md b/samples/jpeg-maker/index.md new file mode 100644 index 0000000..4287562 --- /dev/null +++ b/samples/jpeg-maker/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: JPEG MAKER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Artelius](../artelius.md) + +### Description + +```text +'JPEG Encoder v2 by Artelius +'WARNING: OVERWRITES TEST.JPG +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "jpegmake.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/jpeg-maker/src/jpegmake.bas) +* [RUN "jpegmake.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/jpeg-maker/src/jpegmake.bas) +* [PLAY "jpegmake.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/jpeg-maker/src/jpegmake.bas) + +### File(s) + +* [jpegmake.bas](src/jpegmake.bas) + +🔗 [jpeg](../jpeg.md), [image manipulation](../image-manipulation.md) diff --git a/samples/jpeg-maker/src/jpegmake.bas b/samples/jpeg-maker/src/jpegmake.bas new file mode 100644 index 0000000..b08bb34 --- /dev/null +++ b/samples/jpeg-maker/src/jpegmake.bas @@ -0,0 +1,729 @@ +'JPEG Encoder v2 by Artelius +'WARNING: OVERWRITES TEST.JPG +DECLARE FUNCTION Atan2! (X AS SINGLE, Y AS SINGLE) +DECLARE SUB PutChar (FileNo AS INTEGER, Char AS INTEGER) + +DECLARE SUB JPEG.Precalc () +DECLARE SUB JPEG.Begin (FileNo AS INTEGER, W AS INTEGER, H AS INTEGER, Sampling() AS INTEGER, State AS ANY, QT() AS INTEGER, Huff() AS INTEGER) +DECLARE SUB JPEG.Block.Output (B() AS INTEGER, State AS ANY, QT() AS INTEGER, Huff() AS INTEGER) +DECLARE SUB JPEG.StandardQT (quality AS SINGLE, QT() AS INTEGER) +DECLARE SUB JPEG.Finish (State AS ANY) +DECLARE FUNCTION JPEG.Category% (X AS INTEGER) +DECLARE FUNCTION JPEG.Cb% (R AS INTEGER, G AS INTEGER, B AS INTEGER) +DECLARE FUNCTION JPEG.Cr% (R AS INTEGER, G AS INTEGER, B AS INTEGER) +DECLARE FUNCTION JPEG.Y% (R AS INTEGER, G AS INTEGER, B AS INTEGER) + +TYPE JPEGState +FileNo AS INTEGER +YCount AS INTEGER +CbCount AS INTEGER +CrCount AS INTEGER +YDC AS INTEGER +CbDC AS INTEGER +CrDC AS INTEGER +Position AS INTEGER +Leftover AS INTEGER +LeftoverBits AS INTEGER +END TYPE + +'The following are internal to JPEG. +DECLARE SUB JPEG.ACHuff (RLE AS INTEGER, AC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS ANY) +DECLARE SUB JPEG.Block.Huffman (B() AS INTEGER, LastDC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS ANY) +DECLARE SUB JPEG.Block.Transform (B() AS INTEGER, O() AS INTEGER, QT() AS INTEGER, A AS INTEGER) +DECLARE SUB JPEG.DCHuff (DC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS ANY) +DECLARE SUB JPEG.GenerateHuffmanTable (Huff() AS INTEGER, A AS INTEGER, B AS INTEGER) +DECLARE SUB JPEG.PutBinString (BS AS INTEGER, Length AS INTEGER, State AS ANY) +DECLARE SUB JPEG.PutByte (FileNo AS INTEGER, Byte AS INTEGER) +DECLARE SUB JPEG.PutRightBinString (BS AS INTEGER, Length AS INTEGER, State AS ANY) +DECLARE SUB JPEG.PutWord (FileNo AS INTEGER, Word AS INTEGER) +DECLARE FUNCTION JPEG.Shift% (I AS INTEGER, N AS INTEGER) + +DEFINT A-Z + +DIM SHARED Pow2(0 TO 15) AS LONG +DIM SHARED Cosine(0 TO 7, 0 TO 7) AS SINGLE +DIM SHARED ZigZagX(0 TO 63) AS INTEGER, ZigZagY(0 TO 63) AS INTEGER +JPEG.Precalc + +DIM Huff(0 TO 255, 0 TO 1, 0 TO 1, 0 TO 1) AS INTEGER +DIM QT(0 TO 7, 0 TO 7, 0 TO 1) AS INTEGER +DIM State AS JPEGState + +DIM Sampling(0 TO 2, 0 TO 1) AS INTEGER +Sampling(0, 0) = 2 'Sampling factor (x then y) for luminance +Sampling(0, 1) = 2 +Sampling(1, 0) = 1 'Sampling factor for "blue" chrominance +Sampling(1, 1) = 1 +Sampling(2, 0) = 1 'Sampling factor for "red" chrominance +Sampling(2, 1) = 1 + + +'Delete file then open for binary +OPEN "test.jpg" FOR OUTPUT AS #1 +CLOSE +OPEN "test.jpg" FOR BINARY AS #1 + +'Set quality tables +'The smaller the paramter, the higher the quality +'0.01 is 100% quality +JPEG.StandardQT .5, QT() + +'Start image (64x64) +JPEG.Begin 1, 128, 128, Sampling(), State, QT(), Huff() + + +DIM B(0 TO 7, 0 TO 7) AS INTEGER + +FOR SuperY = 0 TO 127 STEP 16 +FOR SuperX = 0 TO 127 STEP 16 + +'Output the luminance blocks + +FOR BlockY = 0 TO 15 STEP 8 +FOR BlockX = 0 TO 15 STEP 8 +FOR OffY = 0 TO 7: FOR OffX = 0 TO 7 +X! = OffX + BlockX + SuperX - 63.5 +Y! = OffY + BlockY + SuperY - 63.5 +D! = SQR(X! * X! + Y! * Y!) / 6 + Atan2(X!, Y!) +R = 255 +G = 255 - (COS(D!) + 1) * 127.5 +B = 255 - (COS(D!) + 1) * 127.5 +B(OffX, OffY) = JPEG.Y(R, G, B) +NEXT OffX, OffY +JPEG.Block.Output B(), State, QT(), Huff() +NEXT BlockX, BlockY + +'Output the blue chrominance block + +FOR OffY = 0 TO 7: FOR OffX = 0 TO 7 +X! = OffX * 2 + SuperX - 63 +Y! = OffY * 2 + SuperY - 63 +D! = SQR(X! * X! + Y! * Y!) / 6 + Atan2(X!, Y!) +R = 255 +G = 255 - (COS(D!) + 1) * 127.5 +B = 255 - (COS(D!) + 1) * 127.5 +B(OffX, OffY) = JPEG.Cb(R, G, B) +NEXT OffX, OffY +JPEG.Block.Output B(), State, QT(), Huff() + +'Output the red chrominance block + +FOR OffY = 0 TO 7: FOR OffX = 0 TO 7 +X! = OffX * 2 + SuperX - 63 +Y! = OffY * 2 + SuperY - 63 +D! = SQR(X! * X! + Y! * Y!) / 6 + Atan2(X!, Y!) +R = 255 +G = 255 - (COS(D!) + 1) * 127.5 +B = 255 - (COS(D!) + 1) * 127.5 +B(OffX, OffY) = JPEG.Cr(R, G, B) +NEXT OffX, OffY +JPEG.Block.Output B(), State, QT(), Huff() + +NEXT SuperX, SuperY + + +JPEG.Finish State + +CLOSE + +END + +Huff0: +DATA 0 +DATA 1, 0 +DATA 5, 1, 2, 3, 4, 5 +DATA 1, 6 +DATA 1, 7 +DATA 1, 8 +DATA 1, 9 +DATA 1, 10 +DATA 1, 11 +DATA 0, 0, 0, 0, 0, 0, 0 + +Huff1: +DATA 0 +DATA 3, 0, 1, 2 +DATA 1, 3 +DATA 1, 4 +DATA 1, 5 +DATA 1, 6 +DATA 1, 7 +DATA 1, 8 +DATA 1, 9 +DATA 1, 10 +DATA 1, 11 +DATA 0, 0, 0, 0, 0 + +Huff2: +DATA 0 +DATA 2, 1, 2 +DATA 1, 3 +DATA 3, 0, 4, &H11 +DATA 3, 5, &H12, &H21 +DATA 2, &H31, &H41 +DATA 4, 6, &H13, &H51, &H61 +DATA 3, 7, &H22, &H71 +DATA 5, &H14, &H32, &H81, &H91, &HA1 +DATA 5, &H08, &H23, &H42, &HB1, &HC1 +DATA 4, &H15, &H52, &HD1, &HF0 +DATA 4, &H24, &H33, &H62, &H72 +DATA 0 +DATA 0 +DATA 1, &H82 +DATA 125, &H09, &H0A, &H16, &H17, &H18, &H19, &H1A, &H25, &H26, &H27, &H28, &H29, &H2A, &H34, &H35, &H36 +DATA &H37, &H38, &H39, &H3A, &H43, &H44, &H45, &H46, &H47, &H48, &H49, &H4A, &H53, &H54, &H55, &H56 +DATA &H57, &H58, &H59, &H5A, &H63, &H64, &H65, &H66, &H67, &H68, &H69, &H6A, &H73, &H74, &H75, &H76 +DATA &H77, &H78, &H79, &H7A, &H83, &H84, &H85, &H86, &H87, &H88, &H89, &H8A, &H92, &H93, &H94, &H95 +DATA &H96, &H97, &H98, &H99, &H9A, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &HA9, &HAA, &HB2, &HB3 +DATA &HB4, &HB5, &HB6, &HB7, &HB8, &HB9, &HBA, &HC2, &HC3, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, &HCA +DATA &HD2, &HD3, &HD4, &HD5, &HD6, &HD7, &HD8, &HD9, &HDA, &HE1, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7 +DATA &HE8, &HE9, &HEA, &HF1, &HF2, &HF3, &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, &HFA + +Huff3: +DATA 0 +DATA 2, 0, 1 +DATA 1, 2 +DATA 2, 3, &H11 +DATA 4, 4, 5, &H21, &H31 +DATA 4, 6, &H12, &H41, &H51 +DATA 3, 7, &H61, &H71 +DATA 4, &H13, &H22, &H32, &H81 +DATA 7, 8, &H14, &H42, &H91, &HA1, &HB1, &HC1 +DATA 5, 9, &H23, &H33, &H52, &HF0 +DATA 4, &H15, &H62, &H72, &HD1 +DATA 4, &HA, &H16, &H24, &H34 +DATA 0 +DATA 1, &HE1 +DATA 2, &H25, &HF1 +DATA 119, &H17, &H18, &H19, &H1A, &H26, &H27, &H28, &H29, &H2A, &H35, &H36, &H37, &H38, &H39, &H3A, &H43 +DATA &H44, &H45, &H46, &H47, &H48, &H49, &H4A, &H53, &H54, &H55, &H56, &H57, &H58, &H59, &H5A, &H63 +DATA &H64, &H65, &H66, &H67, &H68, &H69, &H6A, &H73, &H74, &H75, &H76, &H77, &H78, &H79, &H7A, &H82 +DATA &H83, &H84, &H85, &H86, &H87, &H88, &H89, &H8A, &H92, &H93, &H94, &H95, &H96, &H97, &H98, &H99 +DATA &H9A, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &HA9, &HAA, &HB2, &HB3, &HB4, &HB5, &HB6, &HB7 +DATA &HB8, &HB9, &HBA, &HC2, &HC3, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, &HCA, &HD2, &HD3, &HD4, &HD5 +DATA &HD6, &HD7, &HD8, &HD9, &HDA, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7, &HE8, &HE9, &HEA, &HF2, &HF3 +DATA &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, &HFA + +StandardQT: +DATA 16, 11, 10, 16, 24, 40, 51, 61 +DATA 12, 12, 14, 19, 26, 58, 60, 55 +DATA 14, 13, 16, 24, 40, 57, 69, 56 +DATA 14, 17, 22, 29, 51, 87, 80, 62 +DATA 18, 22, 37, 56, 68, 109, 103, 77 +DATA 24, 35, 55, 64, 81, 104, 113, 92 +DATA 49, 64, 78, 87, 103, 121, 120, 101 +DATA 72, 92, 95, 98, 112, 100, 103, 99 + +DATA 17, 18, 24, 47, 99, 99, 99, 99 +DATA 18, 24, 26, 66, 99, 99, 99, 99 +DATA 24, 26, 56, 99, 99, 99, 99, 99 +DATA 47, 66, 99, 99, 99, 99, 99, 99 +DATA 99, 99, 99, 99, 99, 99, 99, 99 +DATA 99, 99, 99, 99, 99, 99, 99, 99 +DATA 99, 99, 99, 99, 99, 99, 99, 99 +DATA 99, 99, 99, 99, 99, 99, 99, 99 + +DEFSNG A-Z +FUNCTION Atan2! (X AS SINGLE, Y AS SINGLE) + +'Code borrowed from London +Atan2 = ATN(Y / X) - ATN(1) * 4 * (X < 0 - 2 * (X < 0 AND Y < 0)) + +END FUNCTION + +SUB JPEG.ACHuff (RLE AS INTEGER, AC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS JPEGState) +DIM C AS INTEGER, X AS INTEGER +C = JPEG.Category(AC) +X = RLE * 16 + C +JPEG.PutBinString Huff(X, 1, A, 0), Huff(X, 1, A, 1), State +JPEG.PutRightBinString AC + (AC < 0), C, State +END SUB + +SUB JPEG.Begin (FileNo AS INTEGER, W AS INTEGER, H AS INTEGER, Sampling() AS INTEGER, State AS JPEGState, QT() AS INTEGER, Huff() AS INTEGER) + +DIM I AS INTEGER, J AS INTEGER, X AS INTEGER, Y AS INTEGER, T AS INTEGER + +State.FileNo = FileNo + +RESTORE Huff0 +JPEG.GenerateHuffmanTable Huff(), 0, 0 +JPEG.GenerateHuffmanTable Huff(), 0, 1 +JPEG.GenerateHuffmanTable Huff(), 1, 0 +JPEG.GenerateHuffmanTable Huff(), 1, 1 + + +State.YCount = Sampling(0, 0) * Sampling(0, 1) +State.CbCount = Sampling(1, 0) * Sampling(1, 1) +State.CrCount = Sampling(2, 0) * Sampling(2, 1) +State.YDC = 0 +State.CbDC = 0 +State.CrDC = 0 + +State.Position = 0 + +State.Leftover = 0 +State.LeftoverBits = 0 + + +'SOI +PutChar FileNo, 255 +PutChar FileNo, 216 +'APP0 +PutChar FileNo, 255 +PutChar FileNo, 224 +JPEG.PutWord FileNo, 16 +S$ = "JFIF" + CHR$(0): PUT FileNo, , S$ +PutChar FileNo, 1 +PutChar FileNo, 2 +PutChar FileNo, 0 +PutChar FileNo, 0 +PutChar FileNo, 1 +PutChar FileNo, 0 +PutChar FileNo, 1 +PutChar FileNo, 0 +PutChar FileNo, 0 + +'DQT +PutChar FileNo, 255 +PutChar FileNo, 219 +JPEG.PutWord FileNo, 132 + +PutChar FileNo, 0 +FOR I = 0 TO 63 +PutChar FileNo, QT(ZigZagX(I), ZigZagY(I), 0) +NEXT + + + +PutChar FileNo, 1 +FOR I = 0 TO 63 +PutChar FileNo, QT(ZigZagX(I), ZigZagY(I), 1) +NEXT + + + +'DHT +PutChar FileNo, 255 +PutChar FileNo, 196 +T = 2 + 4 * (16 + 1) +RESTORE Huff0 +FOR I = 1 TO 16 * 4 +READ X +FOR J = 1 TO X +READ Y +T = T + 1 +NEXT +NEXT + +JPEG.PutWord FileNo, T + +PutChar FileNo, 0 +RESTORE Huff0 +FOR I = 1 TO 16 +READ X +PutChar FileNo, X +FOR J = 1 TO X +READ Y +NEXT +NEXT +RESTORE Huff0 +FOR I = 1 TO 16 +READ X +FOR J = 1 TO X +READ Y +PutChar FileNo, Y +NEXT +NEXT + +PutChar FileNo, 1 +RESTORE Huff1 +FOR I = 1 TO 16 +READ X +PutChar FileNo, X +FOR J = 1 TO X +READ Y +NEXT +NEXT +RESTORE Huff1 +FOR I = 1 TO 16 +READ X +FOR J = 1 TO X +READ Y +PutChar FileNo, Y +NEXT +NEXT + +PutChar FileNo, 16 +RESTORE Huff2 +FOR I = 1 TO 16 +READ X +PutChar FileNo, X +FOR J = 1 TO X +READ Y +NEXT +NEXT +RESTORE Huff2 +FOR I = 1 TO 16 +READ X +FOR J = 1 TO X +READ Y +PutChar FileNo, Y +NEXT +NEXT + +PutChar FileNo, 17 +RESTORE Huff3 +FOR I = 1 TO 16 +READ X +PutChar FileNo, X +FOR J = 1 TO X +READ Y +NEXT +NEXT +RESTORE Huff3 +FOR I = 1 TO 16 +READ X +FOR J = 1 TO X +READ Y +PutChar FileNo, Y +NEXT +NEXT + +'SOF0 +PutChar FileNo, 255 +PutChar FileNo, 192 +JPEG.PutWord FileNo, 8 + 9 +PutChar FileNo, 8 +JPEG.PutWord FileNo, H +JPEG.PutWord FileNo, W + +PutChar FileNo, 3 + +PutChar FileNo, 1 +PutChar FileNo, Sampling(0, 0) * 16 + Sampling(0, 1) +PutChar FileNo, 0 +PutChar FileNo, 2 +PutChar FileNo, Sampling(1, 0) * 16 + Sampling(1, 1) +PutChar FileNo, 1 +PutChar FileNo, 3 +PutChar FileNo, Sampling(2, 0) * 16 + Sampling(2, 1) +PutChar FileNo, 1 + +'SOS + +PutChar FileNo, 255 +PutChar FileNo, 218 +JPEG.PutWord FileNo, 12 + +PutChar FileNo, 3 + +PutChar FileNo, 1 +PutChar FileNo, &H0 +PutChar FileNo, 2 +PutChar FileNo, &H11 +PutChar FileNo, 3 +PutChar FileNo, &H11 + +PutChar FileNo, 0 +PutChar FileNo, 63 +PutChar FileNo, 0 + +END SUB + +SUB JPEG.Block.Huffman (B() AS INTEGER, LastDC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS JPEGState) +DIM DC AS INTEGER, I AS INTEGER +DIM C AS INTEGER +DC = B(0) - LastDC +JPEG.DCHuff DC, Huff(), A, State +B(64) = -1 + +I = 1 +DO +C = 0 +IF B(I) = 0 THEN + +DO +I = I + 1 +C = C + 1 +LOOP WHILE B(I) = 0 +IF I = 64 THEN + +JPEG.PutBinString Huff(0, 1, A, 0), Huff(0, 1, A, 1), State +EXIT DO +END IF +WHILE C >= 16 + +JPEG.PutBinString Huff(&HF0, 1, A, 0), Huff(&HF0, 1, A, 1), State +C = C - 16 +WEND + +END IF + + +JPEG.ACHuff C, B(I), Huff(), A, State +I = I + 1 +LOOP WHILE I < 64 +END SUB + +SUB JPEG.Block.Output (B() AS INTEGER, State AS JPEGState, QT() AS INTEGER, Huff() AS INTEGER) + +DIM O(0 TO 64) AS INTEGER +State.Position = State.Position + 1 +IF State.Position > State.YCount + State.CbCount + State.CrCount THEN State.Position = 1 +IF State.Position <= State.YCount THEN +JPEG.Block.Transform B(), O(), QT(), 0 +JPEG.Block.Huffman O(), State.YDC, Huff(), 0, State +State.YDC = O(0) +ELSE +JPEG.Block.Transform B(), O(), QT(), 1 +IF State.Position <= State.YCount + State.CbCount THEN +JPEG.Block.Huffman O(), State.CbDC, Huff(), 1, State +State.CbDC = O(0) +ELSE +JPEG.Block.Huffman O(), State.CrDC, Huff(), 1, State +State.CrDC = O(0) +END IF +END IF + +END SUB + +SUB JPEG.Block.Transform (B() AS INTEGER, O() AS INTEGER, QT() AS INTEGER, A AS INTEGER) +DIM U AS INTEGER, V AS INTEGER, X AS INTEGER, Y AS INTEGER +DIM B2(0 TO 7, 0 TO 7) AS SINGLE +DIM T AS SINGLE + +FOR V = 0 TO 7: FOR U = 0 TO 7 +T = 0 +FOR X = 0 TO 7 +T = T + B(X, V) * Cosine(X, U) +NEXT X +B2(U, V) = T +NEXT U, V + +FOR U = 0 TO 7: FOR V = 0 TO 7 +T = 0 +FOR Y = 0 TO 7 +T = T + B2(U, Y) * Cosine(Y, V) +NEXT Y +T = T / 4 +IF U = 0 THEN T = T / SQR(2) +IF V = 0 THEN T = T / SQR(2) +B(U, V) = CINT(T / QT(U, V, A)) +NEXT V, U + +FOR U = 0 TO 63 +O(U) = B(ZigZagX(U), ZigZagY(U)) +NEXT + +END SUB + +FUNCTION JPEG.Category% (X AS INTEGER) +DIM T AS INTEGER, I AS INTEGER +T = ABS(X) +WHILE T +T = T \ 2 +I = I + 1 +WEND +JPEG.Category = I +END FUNCTION + +FUNCTION JPEG.Cb% (R AS INTEGER, G AS INTEGER, B AS INTEGER) + +JPEG.Cb = -.1687 * R - .3313 * G + .5 * B + +END FUNCTION + +FUNCTION JPEG.Cr% (R AS INTEGER, G AS INTEGER, B AS INTEGER) + +JPEG.Cr = .5 * R - .4187 * G - .0813 * B + +END FUNCTION + +SUB JPEG.DCHuff (DC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS JPEGState) +DIM C AS INTEGER +C = JPEG.Category(DC) +JPEG.PutBinString Huff(C, 0, A, 0), Huff(C, 0, A, 1), State +JPEG.PutRightBinString DC + (DC < 0), C, State +END SUB + +SUB JPEG.Finish (State AS JPEGState) + +DEF SEG = VARSEG(State.Leftover) +IF State.LeftoverBits > 8 THEN +JPEG.PutByte State.FileNo, PEEK(VARPTR(State.Leftover) + 1) +POKE VARPTR(State.Leftover) + 1, State.Leftover AND 255 +State.LeftoverBits = State.LeftoverBits - 8 +END IF + +IF State.LeftoverBits THEN +JPEG.PutByte State.FileNo, PEEK(VARPTR(State.Leftover) + 1) OR (Pow2(8 - State.LeftoverBits) - 1) +END IF +DEF SEG + +'EOF marker +PutChar State.FileNo, 255 +PutChar State.FileNo, 217 + +END SUB + +SUB JPEG.GenerateHuffmanTable (Huff() AS INTEGER, A AS INTEGER, B AS INTEGER) +DIM S AS LONG, I AS INTEGER, J AS INTEGER, T AS INTEGER +DIM X AS INTEGER, Y AS INTEGER +S = -1 + +FOR I = 1 TO 16 +READ X +FOR J = 1 TO X + +IF S = -1 THEN +S = 0 +ELSE +S = S + Pow2(T) +END IF + + +READ Y +IF S AND 32768 THEN Huff(Y, A, B, 0) = CINT(S AND 32767&) OR -32768 ELSE Huff(Y, A, B, 0) = S +Huff(Y, A, B, 1) = I +T = 16 - I + +NEXT +NEXT +END SUB + +SUB JPEG.Precalc +DIM X AS INTEGER, Y AS INTEGER, T AS INTEGER, Dir AS INTEGER, L AS LONG + +L = 1 +FOR X = 0 TO 15 +Pow2(X) = L +L = L + L +NEXT +FOR Y = 0 TO 7 +FOR X = 0 TO 7 +Cosine(X, Y) = COS((2 * X + 1) * Y * .1963495) +NEXT X, Y + +X = 0: Y = 0 +T = 0 +Dir = 0 +DO +ZigZagX(T) = X +ZigZagY(T) = Y +T = T + 1 +IF T = 64 THEN EXIT DO +IF Dir THEN +IF Y = 7 THEN +X = X + 1 +Dir = 0 +ELSEIF X = 0 THEN +Y = Y + 1 +Dir = 0 +ELSE +X = X - 1 +Y = Y + 1 +END IF + +ELSE +IF Y = 0 THEN +X = X + 1 +Dir = 1 +ELSEIF X = 7 THEN +Y = Y + 1 +Dir = 1 +ELSE +X = X + 1 +Y = Y - 1 +END IF +END IF +LOOP + + + +END SUB + +SUB JPEG.PutBinString (BS AS INTEGER, Length AS INTEGER, State AS JPEGState) +DIM Temp AS INTEGER + +Temp = BS +State.Leftover = State.Leftover OR JPEG.Shift(Temp, State.LeftoverBits) +State.LeftoverBits = State.LeftoverBits + Length +IF State.LeftoverBits >= 16 THEN +DEF SEG = VARSEG(State.Leftover) +JPEG.PutByte State.FileNo, PEEK(VARPTR(State.Leftover) + 1) +DEF SEG +JPEG.PutByte State.FileNo, State.Leftover AND 255 +State.LeftoverBits = State.LeftoverBits - 16 +State.Leftover = Temp +END IF + +END SUB + +SUB JPEG.PutByte (FileNo AS INTEGER, Byte AS INTEGER) +DIM C AS STRING * 1 +C = CHR$(Byte) +PUT FileNo, , C +IF Byte = 255 THEN C = CHR$(0): PUT FileNo, , C +END SUB + +SUB JPEG.PutRightBinString (BS AS INTEGER, Length AS INTEGER, State AS JPEGState) + +DIM Temp AS LONG +IF Length THEN +Temp = (CLNG(BS) AND Pow2(Length) - 1) * Pow2(16 - Length) +IF Temp AND 32768 THEN Temp = Temp OR -65536 +JPEG.PutBinString CINT(Temp), Length, State +END IF + +END SUB + +SUB JPEG.PutWord (FileNo AS INTEGER, Word AS INTEGER) +DIM C AS STRING * 1 +C = CHR$(Word \ 256) +PUT FileNo, , C +C = CHR$(Word AND 255) +PUT FileNo, , C +END SUB + +FUNCTION JPEG.Shift% (I AS INTEGER, N AS INTEGER) +DIM T AS LONG + +IF N = 0 THEN +JPEG.Shift = I +I = 0 +EXIT FUNCTION +END IF +T = CLNG(I) AND 65535 + +JPEG.Shift = T \ Pow2(N) + +T = (T AND (Pow2(N) - 1)) * Pow2((16 - N) AND 15) +IF T AND 32768 THEN I = CINT(T AND 32767&) OR -32768 ELSE I = CINT(T) +END FUNCTION + +SUB JPEG.StandardQT (quality AS SINGLE, QT() AS INTEGER) + +DIM I AS INTEGER, X AS INTEGER, Y AS INTEGER, T AS INTEGER +RESTORE StandardQT + +FOR I = 0 TO 1: FOR Y = 0 TO 7: FOR X = 0 TO 7 +READ T + +QT(X, Y, I) = T * quality + +IF QT(X, Y, I) = 0 THEN QT(X, Y, I) = 1 +NEXT X, Y, I + +END SUB + +FUNCTION JPEG.Y% (R AS INTEGER, G AS INTEGER, B AS INTEGER) + +JPEG.Y = .299 * R + .587 * G + .114 * B - 128 + +END FUNCTION + +SUB PutChar (FileNo AS INTEGER, Char AS INTEGER) +DIM C AS STRING * 1 +C = CHR$(Char) +PUT FileNo, , C +END SUB diff --git a/samples/jpeg.md b/samples/jpeg.md new file mode 100644 index 0000000..b158934 --- /dev/null +++ b/samples/jpeg.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: JPEG + +**[Jpeg Maker](jpeg-maker/index.md)** + +[🐝 Artelius](artelius.md) 🔗 [jpeg](jpeg.md), [image manipulation](image-manipulation.md) + +'JPEG Encoder v2 by Artelius 'WARNING: OVERWRITES TEST.JPG diff --git a/samples/julia-rings/index.md b/samples/julia-rings/index.md index a197f84..a929923 100644 --- a/samples/julia-rings/index.md +++ b/samples/julia-rings/index.md @@ -18,9 +18,9 @@ Automated Julia set explorer. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "juliarings.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/julia-rings/src/juliarings.bas) -* [RUN "juliarings.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/julia-rings/src/juliarings.bas) -* [PLAY "juliarings.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/julia-rings/src/juliarings.bas) +* [LOAD "juliarings.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/julia-rings/src/juliarings.bas) +* [RUN "juliarings.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/julia-rings/src/juliarings.bas) +* [PLAY "juliarings.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/julia-rings/src/juliarings.bas) ### File(s) diff --git a/samples/kaleidoscope-3d/img/screenshot.png b/samples/kaleidoscope-3d/img/screenshot.png new file mode 100644 index 0000000..00d63e4 Binary files /dev/null and b/samples/kaleidoscope-3d/img/screenshot.png differ diff --git a/samples/kaleidoscope-3d/index.md b/samples/kaleidoscope-3d/index.md new file mode 100644 index 0000000..95570e6 --- /dev/null +++ b/samples/kaleidoscope-3d/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: KALEIDOSCOPE 3D + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 qbguy](../qbguy.md) + +### Description + +```text +Move mouse to rotate, escape to quit +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "kaleid3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/kaleidoscope-3d/src/kaleid3d.bas) +* [RUN "kaleid3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/kaleidoscope-3d/src/kaleid3d.bas) +* [PLAY "kaleid3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/kaleidoscope-3d/src/kaleid3d.bas) + +### File(s) + +* [kaleid3d.bas](src/kaleid3d.bas) + +🔗 [3d](../3d.md), [art](../art.md) diff --git a/samples/kaleidoscope-3d/src/kaleid3d.bas b/samples/kaleidoscope-3d/src/kaleid3d.bas new file mode 100644 index 0000000..88fe25d --- /dev/null +++ b/samples/kaleidoscope-3d/src/kaleid3d.bas @@ -0,0 +1,74 @@ +Dim Shared RGB As Integer +Dim Shared CT As Single, ST As Single, CP As Single, SP As Single +Dim X(0 To 179) As Integer, Y(0 To 179) As Integer, Z(0 To 179) As Integer +Dim XM As Integer, YM As Integer, OLDXM As Integer, OLDYM As Integer +Randomize Timer +Screen 9, , 0, 1 +Call _MouseHide +XX = 75: YY = 50: ZZ = 25 +NDX = 0 +Do + OLDXM = XM + OLDYM = YM + Call getmouse(XM, YM) + P = (DM - 320) / 150: T = (96 - YM) / 150 + CT = Cos(T): ST = Sin(T) + CP = Cos(P): SP = Sin(P) + XX = XX + Int(Rnd(1) * 10) - 5 + YY = YY + Int(Rnd(1) * 11) - 5 + ZZ = ZZ + Int(Rnd(1) * 12) - 5 + If Abs(XX) > 200 Or Abs(YY) > 200 Or Abs(ZZ) > 200 Then + XX = 0: YY = 0: ZZ = 0 + Cls + End If + X(NDX) = XX + Y(NDX) = YY + Z(NDX) = ZZ + PCopy 0, 1 + Cls + For K = 0 To 179 + RGB = K / 30 + 1 + Call MIRROR(X(K), Y(K), Z(K)) + Next + NDX = (NDX + 1) Mod 180 + T = Timer + While T = Timer + If InKey$ = Chr$(27) Then End + Wend +Loop + +Sub MIRROR (X As Integer, Y As Integer, Z As Integer) + Call OCTANTS(X, Y, Z) + Call OCTANTS(X, Z, Y) + Call OCTANTS(Y, Z, X) + Call OCTANTS(Y, X, Z) + Call OCTANTS(Z, X, Y) + Call OCTANTS(Z, Y, X) +End Sub + +Sub OCTANTS (X As Integer, Y As Integer, Z As Integer) + Call PROJECT(X, Y, Z) + Call PROJECT(X, Y, -Z) + Call PROJECT(X, -Y, Z) + Call PROJECT(X, -Y, -Z) + Call PROJECT(-X, Y, Z) + Call PROJECT(-X, Y, -Z) + Call PROJECT(-X, Y, -Z) + Call PROJECT(-X, -Y, Z) + Call PROJECT(-X, -Y, -Z) +End Sub + +Sub PROJECT (X As Integer, Y As Integer, Z As Integer) + XX = CP * X + SP * (CT * Z + ST * Y) + YY = CT * Y - ST * Z + ZZ = CP * (CT * Z + ST * Y) - SP * X + PSet (320 + XX, 175 - YY), RGB - 8 * (ZZ > 0) +End Sub + +Sub getmouse (x%, y%) + Do + Loop Until _MouseInput = 0 + x% = _MouseX + y% = _MouseY +End Sub + diff --git a/samples/kaleidoscope-doodler/img/screenshot.png b/samples/kaleidoscope-doodler/img/screenshot.png new file mode 100644 index 0000000..4909b00 Binary files /dev/null and b/samples/kaleidoscope-doodler/img/screenshot.png differ diff --git a/samples/kaleidoscope-doodler/index.md b/samples/kaleidoscope-doodler/index.md new file mode 100644 index 0000000..3c4e79f --- /dev/null +++ b/samples/kaleidoscope-doodler/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: KALEIDOSCOPE DOODLER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 qbguy](../qbguy.md) + +### Description + +```text +Left-click to draw, right click or middle click to clear screen, escape to quit. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "kaleid.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/kaleidoscope-doodler/src/kaleid.bas) +* [RUN "kaleid.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/kaleidoscope-doodler/src/kaleid.bas) +* [PLAY "kaleid.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/kaleidoscope-doodler/src/kaleid.bas) + +### File(s) + +* [kaleid.bas](src/kaleid.bas) + +🔗 [art](../art.md), [drawing](../drawing.md) diff --git a/samples/kaleidoscope-doodler/src/kaleid.bas b/samples/kaleidoscope-doodler/src/kaleid.bas new file mode 100644 index 0000000..917981d --- /dev/null +++ b/samples/kaleidoscope-doodler/src/kaleid.bas @@ -0,0 +1,43 @@ +DefInt A-Z +Screen 12 +Dim Shared COLOUR +X = 0 +Y = 0 +Z = 0 +D = (640 - 480) / 2 + +LOOP1: +If InKey$ = Chr$(27) Then End +Call getmouse(X, Y, Z) +If Z = 0 Then GoTo LOOP1 +If Z = 1 Then GoTo DRAW1 +Cls +DRAW1: +COLOUR = Int(Rnd(1) * 15) + 1 +Call SOLIDCIRCLE(X, Y, 3) +Call SOLIDCIRCLE(X, 480 - Y, 3) +Call SOLIDCIRCLE(640 - X, Y, 3) +Call SOLIDCIRCLE(640 - X, 480 - Y, 3) +Call SOLIDCIRCLE(Y + D, X - D, 3) +Call SOLIDCIRCLE(480 - Y + D, X - D, 3) +Call SOLIDCIRCLE(Y + D, 480 - X + D, 3) +Call SOLIDCIRCLE(480 - Y + D, 480 - X + D, 3) +GoTo LOOP1 + +Sub SOLIDCIRCLE (X, Y, RAD) + Circle (X, Y), RAD, COLOUR + Paint (X, Y), COLOUR +End Sub + +Sub getmouse (x%, y%, b%) + b% = 0 + wheel% = 0 + Do + If _MouseButton(1) Then b% = b% Or 1 + If _MouseButton(2) Then b% = b% Or 2 + If _MouseButton(3) Then b% = b% Or 4 + Loop Until _MouseInput = 0 + x% = _MouseX + y% = _MouseY +End Sub + diff --git a/samples/kaleidoscope-mill/index.md b/samples/kaleidoscope-mill/index.md index 7d14c00..7bc2bd8 100644 --- a/samples/kaleidoscope-mill/index.md +++ b/samples/kaleidoscope-mill/index.md @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "kaleidoscopemill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/kaleidoscope-mill/src/kaleidoscopemill.bas) -* [RUN "kaleidoscopemill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/kaleidoscope-mill/src/kaleidoscopemill.bas) -* [PLAY "kaleidoscopemill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/kaleidoscope-mill/src/kaleidoscopemill.bas) +* [LOAD "kaleidoscopemill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/kaleidoscope-mill/src/kaleidoscopemill.bas) +* [RUN "kaleidoscopemill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/kaleidoscope-mill/src/kaleidoscopemill.bas) +* [PLAY "kaleidoscopemill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/kaleidoscope-mill/src/kaleidoscopemill.bas) ### File(s) diff --git a/samples/kaleidoscope/index.md b/samples/kaleidoscope/index.md index ccde989..f3db361 100644 --- a/samples/kaleidoscope/index.md +++ b/samples/kaleidoscope/index.md @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "kaleidoscope.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/kaleidoscope/src/kaleidoscope.bas) -* [RUN "kaleidoscope.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/kaleidoscope/src/kaleidoscope.bas) -* [PLAY "kaleidoscope.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/kaleidoscope/src/kaleidoscope.bas) +* [LOAD "kaleidoscope.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/kaleidoscope/src/kaleidoscope.bas) +* [RUN "kaleidoscope.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/kaleidoscope/src/kaleidoscope.bas) +* [PLAY "kaleidoscope.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/kaleidoscope/src/kaleidoscope.bas) ### File(s) diff --git a/samples/kevin.md b/samples/kevin.md new file mode 100644 index 0000000..8504c3a --- /dev/null +++ b/samples/kevin.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 KEVIN + +**[Robo Raider](robo-raider/index.md)** + +[🐝 Kevin](kevin.md) 🔗 [game](game.md) + +****RoboRaider**** ****README.TXT**** Robo Raider is ... diff --git a/samples/kinem.md b/samples/kinem.md new file mode 100644 index 0000000..1244b9a --- /dev/null +++ b/samples/kinem.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 KINEM + +**[Breakout](breakout/index.md)** + +[🐝 kinem](kinem.md) 🔗 [game](game.md), [breakout](breakout.md) + +Breakout game. diff --git a/samples/legacy.md b/samples/legacy.md new file mode 100644 index 0000000..eaba613 --- /dev/null +++ b/samples/legacy.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: LEGACY + +**[3DS Viewer](3ds-viewer/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [3d](3d.md), [wireframe](wireframe.md), [legacy](legacy.md) + +3D Grapher made in QB64. + +**[Beatdown](beatdown/index.md)** + +[🐝 Brian Murphy](brian-murphy.md) 🔗 [game](game.md), [legacy](legacy.md) + +' Beat Down ' 1998 MicroTrip ' ... diff --git a/samples/leif-j.-burrow.md b/samples/leif-j.-burrow.md new file mode 100644 index 0000000..4dd198c --- /dev/null +++ b/samples/leif-j.-burrow.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 LEIF J. BURROW + +**[Schemat](schemat/index.md)** + +[🐝 Leif J. Burrow](leif-j.-burrow.md) 🔗 [circuits](circuits.md), [schematics](schematics.md) + +# Schemat An old DOS QuickBasic schematic design editor updated for QB64. **What is it good for?... diff --git a/samples/lens-simulator/img/ss1.png b/samples/lens-simulator/img/ss1.png new file mode 100644 index 0000000..556ada2 Binary files /dev/null and b/samples/lens-simulator/img/ss1.png differ diff --git a/samples/lens-simulator/img/ss2.png b/samples/lens-simulator/img/ss2.png new file mode 100644 index 0000000..91b5053 Binary files /dev/null and b/samples/lens-simulator/img/ss2.png differ diff --git a/samples/lens-simulator/index.md b/samples/lens-simulator/index.md new file mode 100644 index 0000000..b04f3fc --- /dev/null +++ b/samples/lens-simulator/index.md @@ -0,0 +1,33 @@ +[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: LENS SIMULATOR + +![ss1.png](img/ss1.png) + +### Author + +[🐝 STxAxTIC](../stxaxtic.md) + +### Description + +```text +This program simulates light rays passing through a lens with a given index of refraction and concavity. The bent rays emerge to collide with a target (of fixed shape) or pass it by. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "lens-simulator.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/lens-simulator/src/lens-simulator.bas) +* [RUN "lens-simulator.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/lens-simulator/src/lens-simulator.bas) +* [PLAY "lens-simulator.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/lens-simulator/src/lens-simulator.bas) + +### File(s) + +* [lens-simulator.bas](src/lens-simulator.bas) + +### Additional Image(s) + +![ss2.png](img/ss2.png) + +🔗 [2d](../2d.md), [ray tracer](../ray-tracer.md) diff --git a/samples/lens-simulator/src/lens-simulator.bas b/samples/lens-simulator/src/lens-simulator.bas new file mode 100644 index 0000000..9413ca8 --- /dev/null +++ b/samples/lens-simulator/src/lens-simulator.bas @@ -0,0 +1,298 @@ +'#lang "qb" + +Screen 12 +Randomize Timer + +pi = 3.141592653589793# + +' +' This program can simulate any signle lens, convex or concave or otherwise. +' Rays may enter the lens in any fashion. +' There are three separate sections where user may change parameters. +' There is also an adjustable target. +' + +'************************************************************ +'begin first user-controlled parameter section +drawscale = 2 'enter 1 for no change +indexxair = 1 +indexxlens = 1.6 +rad1 = -75 'change the sign on these radii to change concavity +rad2 = 120 'change the sign on these radii to change concavity +'end first user-controlled parameter section +'************************************************************ + +'Determine focus using Lensmaker's equation. +foc.temp.a = 1 / rad1 +foc.temp.b = -1 / rad2 +foc.temp.c = ((indexxlens - 1) * thickness) / (indexxlens * rad1 * rad2) +foc.temp = (indexxlens - 1) * (foc.temp.a + foc.temp.b + foc.temp.c) +If Sqr(foc.temp ^ 2) < .00001 Then foc.temp = .00001 +focus = 1 / foc.temp +'Done finding focus. + +'************************************************************ +'begin second user-controlled parameter section +left.ext = -10 'prefers value to be always less than 0 +right.ext = 6 'prefers value to be always greater than 0 +objectx = -Sqr((focus * .75) ^ 2) +targetx = 130 +yplacecnt = -20 +yplacemax = 20 +yinc = 10 +angcnt = -85 * pi / 180 +angmax = 85 * pi / 180 +anginc = 5 * pi / 180 +angcnt.min = angcnt +extras = .1 'display normal and tangent lines, etc (see subsequent code for exact use) +tolerance = 1 '10 +speed = .005 +'end second user-controlled parameter section +'************************************************************ + +thickness = right.ext - left.ext +left.edge = left.ext +right.edge = right.ext +yplacecnt = yplacecnt - yinc +angcnt = angcnt - anginc +left.ext = left.ext + rad1 +right.ext = right.ext + rad2 + +Cls +GoSub DrawLens +Locate 2, 3: Print "PRESS ANY KEY" +Locate 3, 3: Print " TO BEGIN. " +Do: Loop Until InKey$ <> "" + +Triggers = 0 +NumRays = 0 + +mainloop: +Do + 'yplacecnt = yplacecnt + yinc + Do + NewRay: + NumRays = NumRays + 1 + ni = indexxair + lockleft = 0 + lockright = 0 + + '************************************************************ + 'begin third user-controlled parameter section + + 'angcnt = angcnt + anginc + angcnt = 9999 + + 'IF focus < 0 THEN x = focus ELSE x = -focus + x = objectx + 'x = ((-1) ^ INT(RND * 2)) * RND * 100 - 200 + + 'y = yplacecnt + 'yplacecnt = 9999 + y = ((-1) ^ Int(Rnd * 2)) * Rnd * (50 / 2) + 'y = 0 + + 'ang = angcnt + 'ang = ((-1) ^ INT(RND * 2)) * RND * pi / 8 + 't = 2 * RND - 1 + 'ang = .25 * ATN(t / SQR(1 - t ^ 2)) + 'ang = 0 + ang = -pi / 32 + + 'end third user-controlled parameter section + '************************************************************ + + x0 = x: y0 = y + GoSub convert.x0y0 + xi = x0: yi = y0 + + GoSub PrintData + + Do + GoSub convert.xiyi + PSet (xxi, yyi), 14 + xi = xi + speed * Cos(ang) + yi = yi + speed * Sin(ang) + 'Look for detector. + GoSub convert.xiyi + If Point(xxi, yyi) = 12 Then: Triggers = Triggers + 1: Exit Do + 'Look for left lens interface. + If (xi - (left.ext)) ^ 2 + (yi) ^ 2 > (rad1 ^ 2 - tolerance) And (xi - (left.ext)) ^ 2 + (yi) ^ 2 < (rad1 ^ 2 + tolerance) And lockleft = 0 Then + lockleft = 1 + ni = indexxlens + n.old = indexxair + n.new = indexxlens + 'Determine the slope of the tangent line to the circle. + If yi = 0 Then yi = .00001 + m = (-xi + left.ext) / yi + mn = (-1 / m) + rad.i = rad1 + GoSub lens.interface + End If + 'Look for right lens interface. + If (xi - (right.ext)) ^ 2 + (yi) ^ 2 > (rad2 ^ 2 - tolerance) And (xi - (right.ext)) ^ 2 + (yi) ^ 2 < (rad2 ^ 2 + tolerance) And lockright = 0 Then + lockright = 1 + ni = indexxair + n.old = indexxlens + n.new = indexxair + 'Determine the slope of the tangent line to the circle. + If yi = 0 Then yi = .00001 + m = (-xi + right.ext) / yi + mn = (-1 / m) + rad.i = rad2 + GoSub lens.interface + End If + key$ = InKey$ + Select Case key$ + Case " ": Exit Do + Case Chr$(27): End + End Select + key$ = "" + 'LOOP UNTIL drawscale * xi > 1.1 * drawscale * targetx OR 2 * drawscale * xi > 320 OR drawscale * SQR(yi ^ 2) > 240 + Loop Until drawscale * xi > 320 Or drawscale * Sqr(yi ^ 2) > 240 + tir.bypass: + 'Redraw the focii. + x = focus: y = 0: GoSub convert.xy: Circle (xx, yy), 3, 4 + x = -focus: y = 0: GoSub convert.xy: Circle (xx, yy), 3, 4 + 'Draw 3mm detector. + x = targetx - 1: y = 15: GoSub convert.xy + x1 = xx: y1 = yy + x = targetx + 1: y = -15: GoSub convert.xy + x2 = xx: y2 = yy + Line (x1, y1)-(x2, y2), 12, BF + Loop Until angcnt >= angmax + angcnt = angcnt.min - anginc + 'LOOP UNTIL yplacecnt >= yplacemax +Loop Until NumRays >= 500 +GoSub PrintData +Sleep +End + +lens.interface: +'Calculate the tangent line at intersection point. +x = xi - 5 +y = m * (x - xi) + yi +GoSub convert.xy +x1 = xx: y1 = yy +x = xi + 5: y = m * (x - xi) + yi +GoSub convert.xy +x2 = xx: y2 = yy +If extras = 1 And indexxlens <> 1 Then Line (x1, y1)-(x2, y2), 11 + +'Calculate the normal line at intersection point. +x = xi - 10 +y = mn * (x - xi) + yi +GoSub convert.xy +x1 = xx: y1 = yy +x = xi + 10: y = mn * (x - xi) + yi +GoSub convert.xy +x2 = xx: y2 = yy +If extras > .5 And indexxlens <> 1 Then Line (x1, y1)-(x2, y2), 4 + +'Indicate the intersection point with a circle. +If extras > 0 And indexxlens <> 1 Then x = xi: y = yi: GoSub convert.xy: Circle (xx, yy), 3, 3 + +normal.ang = -Atn(mn) +inc.ang = ang + normal.ang + +'Recalculate velocity angle. +t = n.old * Sin(inc.ang) / n.new +If t ^ 2 < 1 Then + ang = Atn(t / Sqr(1 - t ^ 2)) + ang = ang - normal.ang +Else + 'Total internal reflection. + x = xi: y = yi: GoSub convert.xy: Circle (xx, yy), 3, 5 + Line (xx - 2, yy - 2)-(xx + 2, yy + 2), 5, BF + If angcnt < angmax Then GoTo NewRay Else GoTo tir.bypass +End If +GoSub PrintData +Return + +DrawLens: +'Draw border grid. +For ii = 0 To 320 / drawscale Step 25 + Line (320 + ii * drawscale, 0)-(320 + ii * drawscale, 480), 8 + Line (320 - ii * drawscale, 0)-(320 - ii * drawscale, 480), 8 +Next +For ii = 0 To 240 / drawscale Step 25 + Line (0, 240 + ii * drawscale)-(640, 240 + ii * drawscale), 8 + Line (0, 240 - ii * drawscale)-(640, 240 - ii * drawscale), 8 +Next +Line (320, 0)-(320, 480), 11 +Line (0, 240)-(640, 240), 11 +x = left.ext: y = 0 +GoSub convert.xy +If indexxlens <> 1 Then Circle (xx, yy), Sqr(rad1 ^ 2) * drawscale, 9 +x = right.ext: y = 0 +GoSub convert.xy +If indexxlens <> 1 Then Circle (xx, yy), Sqr(rad2 ^ 2) * drawscale, 9 +If indexxlens <> 1 Then Paint (320, 240), 1, 9 +'Draw the border of lens 2 again in a new color. +If indexxlens <> 1 Then Circle (xx, yy), Sqr(rad2 ^ 2) * drawscale, 10 +'Draw border scale. +For ii = 0 To 320 Step 25 + Line (320 + ii * drawscale, 470)-(320 + ii * drawscale, 480), 2 + Line (320 - ii * drawscale, 470)-(320 - ii * drawscale, 480), 2 +Next +For ii = 0 To 240 Step 25 + Line (0, 240 + ii * drawscale)-(10, 240 + ii * drawscale), 2 + Line (0, 240 - ii * drawscale)-(10, 240 - ii * drawscale), 2 +Next +'Draw 3mm detector. +x = targetx - 1: y = 15: GoSub convert.xy +x1 = xx: y1 = yy +x = targetx + 1: y = -15: GoSub convert.xy +x2 = xx: y2 = yy +Line (x1, y1)-(x2, y2), 12, BF +Locate 2, 59: Print "-Optical Parameters-" +Locate 3, 59: Print Using "Index: ##########.##"; indexxlens +Locate 4, 59: Print Using "Left rad: ########.#"; rad1 +Locate 5, 59: Print Using "Right rad: #######.#"; rad2 +Locate 6, 59: Print Using "Thickness: #######.#"; thickness +Locate 7, 59: Print Using "Left edge: #######.#"; left.edge +Locate 8, 59: Print Using "Right edge: ######.#"; right.edge +Locate 9, 59: Print Using "Focus: ###########.#"; focus +Locate 10, 59: Print Using "Object: ##########.#"; objectx +Locate 11, 59: Print Using "Target: ##########.#"; targetx +x = focus: y = 0: GoSub convert.xy: Circle (xx, yy), 3, 4 +x = -focus: y = 0: GoSub convert.xy: Circle (xx, yy), 3, 4 +Return + +PrintData: +Color 15 +Locate 2, 3: Print "Ray & Interface Data" +Locate 3, 3: Print Using "Present index: ##.##"; ni +Locate 4, 3: Print Using "Ray angle: ######.##"; ang * 180 / pi +Locate 5, 3: Print Using "Incident: #######.##"; inc.ang * 180 / pi; +Locate 6, 3: Print Using "Normal: #########.##"; normal.ang * 180 / pi; +Locate 7, 3: Print Using "Height: #########.##"; yi +If (NumRays - 1) <> 0 Then + Locate 8, 3: Print Using "Hits: ###/####/###%"; Triggers; (NumRays - 1); 100 * Triggers / (NumRays - 1) +Else + Locate 8, 3: Print Using "Trigg: ###/####/###%"; 0; 0; 0 +End If +Return + +convert.xy: +xx = x * drawscale + 320 +yy = -y * drawscale + 240 +Return + +convert.x0y0: +xx0 = x0 * drawscale + 320 +yy0 = -y0 * drawscale + 240 +Return + +convert.xiyi: +xxi = xi * drawscale + 320 +yyi = -yi * drawscale + 240 +Return + +convert.x1y1x2y2: +xx1 = x1 * drawscale + 320 +yy1 = -y1 * drawscale + 240 +xx2 = x2 * drawscale + 320 +yy2 = -y2 * drawscale + 240 +Return + diff --git a/samples/letter-blast/img/screenshot.png b/samples/letter-blast/img/screenshot.png new file mode 100644 index 0000000..e170154 Binary files /dev/null and b/samples/letter-blast/img/screenshot.png differ diff --git a/samples/letter-blast/index.md b/samples/letter-blast/index.md new file mode 100644 index 0000000..ad7d064 --- /dev/null +++ b/samples/letter-blast/index.md @@ -0,0 +1,76 @@ +[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: LETTER BLAST + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 A&A De Pasquale](../a&a-de-pasquale.md) + +### Description + +```text +' LETBLAST.BAS - Shoot the falling letters! +' by Antonio & Alfonso De Pasquale +' +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #9, May 1993, page 50 +' +' -------------------------------------------------------------- +' Last modified by Robert Smith on 22 Jun 2006 +' --Increased difficulty by penalizing player with +' a strike if the player strikes the wrong key. +' --Added two new difficulties; training and really slow +' because I suck at typing. +' Version number# 1.1 +' -------------------------------------------------------------- + +============================================================================== + +-------------- + LETBLAST.BAS +-------------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later. + +WHAT LETBLAST.BAS DOES: +This simple game helps you improve your typing skills by blasting randomly +generated letters that cascade down the screen. As you increase the difficulty +level from slow to intermediate to fast, the letters fall more quickly, making +the game more challenging. + +USING LETBLAST.BAS: +To load the program, type QBASIC LETBLAST.BAS (using path names if necessary) +at the DOS prompt. Then run the program by selecting the Start option in +QBasic's Run menu, or press Shift-F5. The screen clears, a greeting appears, +and the program asks which speed you want to play at. Press S for slow, I for +intermediate, and F for fast. When you're ready to begin the game, press +Enter. Pressing Q and Enter ends the game. + +When the game begins, letters start to fall from the top of the screen. Press +the corresponding key on your keyboard to blast the letter. If you type the +correct letter, the computer beeps and awards a point to you. If you miss a +letter, the computer buzzes and gives you a strike. The game ends when you get +three strikes or 50 letters. + +At the end of the game, you receive your final score and an assessment of your +performance. Press Enter to return to the main menu and play again. + +For further details on LETBLAST.BAS, see "Letter Blaster" (DRG #9, May 1993, +page 50). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "letblast.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/letter-blast/src/letblast.bas) +* [RUN "letblast.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/letter-blast/src/letblast.bas) +* [PLAY "letblast.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/letter-blast/src/letblast.bas) + +### File(s) + +* [letblast.bas](src/letblast.bas) + +🔗 [game](../game.md), [letter](../letter.md), [dos world](../dos-world.md) diff --git a/samples/letter-blast/src/letblast.bas b/samples/letter-blast/src/letblast.bas new file mode 100644 index 0000000..b5c0341 --- /dev/null +++ b/samples/letter-blast/src/letblast.bas @@ -0,0 +1,173 @@ +' LETBLAST.BAS - Shoot the falling letters! +' by Antonio & Alfonso De Pasquale +' +' Copyright (C) 1993 DOS Resource Guide +' Published in Issue #9, May 1993, page 50 +' +' -------------------------------------------------------------- +' Last modified by Robert Smith on 22 Jun 2006 +' --Increased difficulty by penalizing player with +' a strike if the player strikes the wrong key. +' --Added two new difficulties; training and really slow +' because I suck at typing. +' Version number# 1.1 +' -------------------------------------------------------------- +DECLARE SUB CENTER (m$) +DECLARE SUB BOX (r1, c1, r2, c2) +SETUP: + CLS + BOX 1, 5, 5, 75 + BOX 7, 21, 18, 59 + LOCATE 2, 6: CENTER "** Letter Blaster **" + LOCATE 3, 6: CENTER "By" + LOCATE 4, 6: CENTER "Antonio & Alfonso De Pasquale & Robert Smith" + LOCATE 8, 26: PRINT "Please select a game speed:" + LOCATE 10, 30: PRINT "(T)raining" + LOCATE 11, 30: PRINT "(R)eally Slow" + LOCATE 12, 30: PRINT "(S)low" + LOCATE 13, 30: PRINT "(I)intermediate" + LOCATE 14, 30: PRINT "(F)ast" + LOCATE 15, 30: PRINT "(Q)uit This Game" + + DO + speed$ = "" + LOCATE 17, 26: INPUT "Enter your selection: ", speed$ + speed$ = UCASE$(LEFT$(speed$, 1)) + LOOP UNTIL (INSTR(1, "TRSIFQ", speed$)) + IF speed$ = "Q" THEN + CLS + END + END IF + BOX 19, 5, 21, 75 + LOCATE 20, 6: CENTER "Press to begin playing" + DO: LOOP UNTIL INKEY$ = CHR$(13) + GOSUB SETSPEED + GOSUB SETVARS + GOSUB PLAYGAME + GOSUB FINALSCORE + GOTO SETUP +SETSPEED: + SELECT CASE speed$ + CASE "T" + delay = 1 / 4 + CASE "R" + delay = 1 / 8 + CASE "S" + delay = 1 / 16 + CASE "I" + delay = 1 / 32 + CASE "F" + delay = 1 / 64 + END SELECT + RETURN +SETVARS: + score = 0: strike = 0: pass = 0: maxpass = 50: mdl = 50 + char$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + numchars = 26 + t1 = VAL(LEFT$(TIME$, 2)) + t2 = VAL(MID$(TIME$, 3, 2)) + t3 = VAL(RIGHT$(TIME$, 2)) + tt = t1 + t2 + t3 + RANDOMIZE (tt + tt * 100) + RETURN +PLAYGAME: + CLS + BOX 1, 5, 3, 75 + LOCATE 2, 6: CENTER "** Letter Blaster **" + BOX 21, 1, 23, 79 + LOCATE 22, 67: PRINT USING "Score: ####"; score + DO + lt = INT(RND * numchars) + 1: lt$ = MID$(char$, lt, 1) + hp = INT(RND * 70) + 5: vp = 4 + DO + LOCATE vp, hp + PRINT lt$ + Begin! = TIMER + DO UNTIL ABS(TIMER - Begin!) > delay + LOOP + LOCATE vp, hp + PRINT " " + vp = vp + 1 + Key$ = UCASE$(INKEY$) + LOOP UNTIL (vp = 20) OR (Key$ <> "") + IF (Key$ <> lt$) THEN vp = 21 + IF vp < 20 THEN + score = score + 1 + LOCATE vp, hp: PRINT lt$ + FOR x = 20 TO vp STEP -1 + LOCATE x, hp: PRINT "*" + FOR y = 1 TO mdl: NEXT y + LOCATE x, hp: PRINT " " + NEXT x + + SOUND 800, 3 + LOCATE 22, 67: PRINT USING "Score: ####"; score + ELSE + strike = strike + 1 + SOUND 50, 8 + SELECT CASE strike + CASE 1 + tb = 3 + CASE 2 + tb = 14 + CASE 3 + tb = 25 + END SELECT + LOCATE 22, tb: PRINT USING "STRIKE #"; strike + END IF + pass = pass + 1 + LOOP UNTIL (strike = 3) OR (pass = maxpass) + LOCATE 22, 2: PRINT SPACE$(76) + LOCATE 22, 2: CENTER "Game Over! Press to continue" + DO: LOOP UNTIL INKEY$ = CHR$(13) + RETURN +FINALSCORE: + CLS + BOX 1, 5, 3, 75 + LOCATE 2, 6: CENTER "** Letter Blaster **" + BOX 6, 5, 16, 75 + LOCATE 8, 6: CENTER "Your final score is " + LTRIM$(STR$(score)) + " points" + LOCATE 9, 6: CENTER "on " + LTRIM$(STR$(pass)) + " letters." + + SELECT CASE score + CASE IS < 11 + m$ = "Come on! You can do better than that!" + CASE IS < 21 + m$ = "Not bad. But there's still room for improvement." + CASE IS < 31 + m$ = "Pretty good. You're getting better." + CASE IS < 50 + m$ = "All right! You're well on your way to perfection." + CASE 50 + m$ = "Perfect! You are a master of the keyboard!" + END SELECT + + LOCATE 11, 6: CENTER m$ + LOCATE 14, 6: CENTER "Press to continue" + DO: LOOP UNTIL INKEY$ = CHR$(13) + RETURN + +SUB BOX (r1, c1, r2, c2) + + LOCATE r1, c1 + PRINT CHR$(218); + FOR x = (c1 + 1) TO (c2 - 1) + PRINT CHR$(196); + NEXT x + PRINT CHR$(191) + FOR x = (r1 + 1) TO (r2 - 1) + LOCATE x, c1 + PRINT CHR$(179); SPACE$(c2 - c1 - 1); CHR$(179) + NEXT x + LOCATE r2, c1 + PRINT CHR$(192); + FOR x = (c1 + 1) TO (c2 - 1) + PRINT CHR$(196); + NEXT x + PRINT CHR$(217) +END SUB + +SUB CENTER (m$) + PRINT TAB(40 - (LEN(m$) / 2)); m$ +END SUB + diff --git a/samples/letter.md b/samples/letter.md new file mode 100644 index 0000000..d9ee2ba --- /dev/null +++ b/samples/letter.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: LETTER + +**[Letter Blast](letter-blast/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [game](game.md), [letter](letter.md), [dos world](dos-world.md) + +' LETBLAST.BAS - Shoot the falling letters! ' by Antonio & Alfonso De Pasquale ' ' Copyr... diff --git a/samples/lightning-one/index.md b/samples/lightning-one/index.md index b117cff..a211dba 100644 --- a/samples/lightning-one/index.md +++ b/samples/lightning-one/index.md @@ -6,7 +6,7 @@ ### Author -[🐝 RhoSigma](../rhosigma.md) +[🐝 Rho Sigma](../rho-sigma.md) ### Description @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "lightning.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/lightning-one/src/lightning.bas) -* [RUN "lightning.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/lightning-one/src/lightning.bas) -* [PLAY "lightning.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/lightning-one/src/lightning.bas) +* [LOAD "lightning.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/lightning-one/src/lightning.bas) +* [RUN "lightning.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/lightning-one/src/lightning.bas) +* [PLAY "lightning.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/lightning-one/src/lightning.bas) ### File(s) diff --git a/samples/lightning-two/index.md b/samples/lightning-two/index.md index 3c9326f..85624a7 100644 --- a/samples/lightning-two/index.md +++ b/samples/lightning-two/index.md @@ -6,7 +6,7 @@ ### Author -[🐝 RhoSigma](../rhosigma.md) +[🐝 Rho Sigma](../rho-sigma.md) ### Description @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "lightning2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/lightning-two/src/lightning2.bas) -* [RUN "lightning2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/lightning-two/src/lightning2.bas) -* [PLAY "lightning2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/lightning-two/src/lightning2.bas) +* [LOAD "lightning2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/lightning-two/src/lightning2.bas) +* [RUN "lightning2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/lightning-two/src/lightning2.bas) +* [PLAY "lightning2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/lightning-two/src/lightning2.bas) ### File(s) diff --git a/samples/lines-intersecting/img/screenshot.png b/samples/lines-intersecting/img/screenshot.png new file mode 100644 index 0000000..3691629 Binary files /dev/null and b/samples/lines-intersecting/img/screenshot.png differ diff --git a/samples/lines-intersecting/index.md b/samples/lines-intersecting/index.md new file mode 100644 index 0000000..d0ee511 --- /dev/null +++ b/samples/lines-intersecting/index.md @@ -0,0 +1,32 @@ +[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: LINES INTERSECTING + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 STxAxTIC](../stxaxtic.md) + +### Description + +```text +Line segments intersecting. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "linesegments.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/lines-intersecting/src/linesegments.bas) +* [RUN "linesegments.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/lines-intersecting/src/linesegments.bas) +* [PLAY "linesegments.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/lines-intersecting/src/linesegments.bas) + +### File(s) + +* [linesegments.bas](src/linesegments.bas) + +🔗 [geometry](../geometry.md), [intersections](../intersections.md) + + +Reference: [qb64forum](https://qb64forum.alephc.xyz/index.php?topic=2342.0) diff --git a/samples/lines-intersecting/src/linesegments.bas b/samples/lines-intersecting/src/linesegments.bas new file mode 100644 index 0000000..e288974 --- /dev/null +++ b/samples/lines-intersecting/src/linesegments.bas @@ -0,0 +1,287 @@ +Screen 12 +Randomize Timer + +Type Vector + x As Double + y As Double +End Type + +Type LineSegment + ' Endpoint definition: + p1 As Vector ' Endpoint 1 + p2 As Vector ' Endpoint 2 + ' Parameterized definition: + b As Vector ' Origin vector + alpha1 As Double ' End-parameter 1 + alpha2 As Double ' End-parameter 2 + ang As Double ' Orientation angle + t As Vector ' Tangent (unit) vector +End Type + +Dim Shared Segments(100) As LineSegment +Dim Shared NumSegments As Integer +NumSegments = 0 + +'' Example: Define a line using parameters (calculates endpoints anyway): +'NumSegments = NumSegments + 1 +'Segments(NumSegments).b.x = 0 +'Segments(NumSegments).b.y = 0 +'Segments(NumSegments).alpha1 = 0 +'Segments(NumSegments).alpha2 = 100 +'Segments(NumSegments).ang = ATN(0) +'Segments(NumSegments).t.x = COS(Segments(NumSegments).ang) +'Segments(NumSegments).t.y = SIN(Segments(NumSegments).ang) +'CALL CalcEndpoints(NumSegments) + +'' Example: Define a line using endpoints (calculates parameters anyway): +'NumSegments = NumSegments + 1 +'Segments(NumSegments).p1.x = 0 +'Segments(NumSegments).p1.y = 0 +'Segments(NumSegments).p2.x = 100 +'Segments(NumSegments).p2.y = 0 + +' Main lines and shapes + +NumSegments = NumSegments + 1 +Segments(NumSegments).p1.x = -100 +Segments(NumSegments).p1.y = -100 +Segments(NumSegments).p2.x = 100 +Segments(NumSegments).p2.y = -100 + +NumSegments = NumSegments + 1 +Segments(NumSegments).p1.x = -200 +Segments(NumSegments).p1.y = -100 +Segments(NumSegments).p2.x = 200 +Segments(NumSegments).p2.y = -100 + +NumSegments = NumSegments + 1 +Segments(NumSegments).p1.x = 200 +Segments(NumSegments).p1.y = -100 +Segments(NumSegments).p2.x = 0 +Segments(NumSegments).p2.y = 200 + +NumSegments = NumSegments + 1 +Segments(NumSegments).p1.x = 0 +Segments(NumSegments).p1.y = 200 +Segments(NumSegments).p2.x = -200 +Segments(NumSegments).p2.y = -100 + +NumSegments = NumSegments + 1 +Segments(NumSegments).p1.x = -200 +Segments(NumSegments).p1.y = -200 +Segments(NumSegments).p2.x = 200 +Segments(NumSegments).p2.y = 200 + +NumSegments = NumSegments + 1 +Segments(NumSegments).p1.x = 200 +Segments(NumSegments).p1.y = -200 +Segments(NumSegments).p2.x = -200 +Segments(NumSegments).p2.y = 200 + +' Main loop +Do + + ' User input + Do While _MouseInput + x = _MouseX + y = _MouseY + If ((x > 0) And (x < _Width) And (y > 0) And (y < _Height)) Then + If (_MouseButton(1)) Then + Call CalcParameters(1) + x = _MouseX + y = _MouseY + Segments(1).b.x = Int((x - _Width / 2)) + Segments(1).b.y = Int((-y + _Height / 2)) + Call CalcEndpoints(1) + End If + If (_MouseWheel > 0) Then + Call CalcParameters(1) + Segments(1).ang = Segments(1).ang + Atn(1) / 10 + Segments(1).t.x = Cos(Segments(1).ang) + Segments(1).t.y = Sin(Segments(1).ang) + Call CalcEndpoints(1) + End If + If (_MouseWheel < 0) Then + Call CalcParameters(1) + Segments(1).ang = Segments(1).ang - Atn(1) / 10 + Segments(1).t.x = Cos(Segments(1).ang) + Segments(1).t.y = Sin(Segments(1).ang) + Call CalcEndpoints(1) + End If + End If + Loop + + ' Graphics + Cls + For k = 1 To NumSegments + Call cline(Segments(k).p1.x, Segments(k).p1.y, Segments(k).p2.x, Segments(k).p2.y, 15) + Next + + ' Intersections loop + For k = 1 To NumSegments + For j = k + 1 To NumSegments + a1x = Segments(k).p1.x + a1y = Segments(k).p1.y + a2x = Segments(k).p2.x + a2y = Segments(k).p2.y + b1x = Segments(j).p1.x + b1y = Segments(j).p1.y + b2x = Segments(j).p2.x + b2y = Segments(j).p2.y + Call CalcIntersections(a1x, a1y, a2x, a2y, b1x, b1y, b2x, b2y) + Next + Next + + _Display + _Limit 60 +Loop + +End + +Sub CalcIntersections (a1x, a1y, a2x, a2y, b1x, b1y, b2x, b2y) + ' Requires UDT LineSegment + ' Requires FUNCTION DotProduct + + Dim s1 As LineSegment + Dim s2 As LineSegment + + s1.p1.x = a1x + s1.p1.y = a1y + s1.p2.x = a2x + s1.p2.y = a2y + s1.ang = Atn((s1.p2.y - s1.p1.y) / (s1.p2.x - s1.p1.x)) + s1.b.x = .5 * (s1.p1.x + s1.p2.x) + s1.b.y = .5 * (s1.p1.y + s1.p2.y) + s1.alpha1 = -.5 * _Hypot(s1.p2.x - s1.p1.x, s1.p2.y - s1.p1.y) + s1.alpha2 = .5 * _Hypot(s1.p2.x - s1.p1.x, s1.p2.y - s1.p1.y) + s1.t.x = Cos(s1.ang) + s1.t.y = Sin(s1.ang) + + s2.p1.x = b1x + s2.p1.y = b1y + s2.p2.x = b2x + s2.p2.y = b2y + s2.ang = Atn((s2.p2.y - s2.p1.y) / (s2.p2.x - s2.p1.x)) + s2.b.x = .5 * (s2.p1.x + s2.p2.x) + s2.b.y = .5 * (s2.p1.y + s2.p2.y) + s2.alpha1 = -.5 * _Hypot(s2.p2.x - s2.p1.x, s2.p2.y - s2.p1.y) + s2.alpha2 = .5 * _Hypot(s2.p2.x - s2.p1.x, s2.p2.y - s2.p1.y) + s2.t.x = Cos(s2.ang) + s2.t.y = Sin(s2.ang) + + Dim db As Vector + db.x = s2.b.x - s1.b.x + db.y = s2.b.y - s1.b.y + qj = DotProduct(db, s1.t) + ql = DotProduct(db, s2.t) + p = DotProduct(s1.t, s2.t) + pp = p * p + If (pp < 1) Then ' Non-parallel case + alphaj = (qj - p * ql) / (1 - pp) + alphal = (p * qj - ql) / (1 - pp) + If ((alphaj > s1.alpha1) And (alphaj < s1.alpha2)) Then + If ((alphal > s2.alpha1) And (alphal < s2.alpha2)) Then + Call ccircle(s1.b.x + alphaj * s1.t.x, s1.b.y + alphaj * s1.t.y, 3, 13) + Call ccircle(s2.b.x + alphal * s2.t.x, s2.b.y + alphal * s2.t.y, 5, 15) + End If + End If + Else ' Parallel case + Dim dbhat As Vector + dbmag = Sqr(db.x * db.x + db.y * db.y) + If (dbmag <> 0) Then + dbhat.x = db.x / dbmag + dbhat.y = db.y / dbmag + thresh = DotProduct(dbhat, s1.t) + End If + If ((1 - thresh * thresh < 0.001) Or (dbmag = 0)) Then ' Overlap detection + t1t2 = DotProduct(s1.t, s2.t) + alphaj1 = s2.alpha1 * t1t2 + DotProduct(s1.t, db) + alphaj2 = s2.alpha2 * t1t2 + DotProduct(s1.t, db) + x1 = 0 + y1 = 0 + x2 = 0 + y2 = 0 + If ((alphaj1 >= s1.alpha1) And (alphaj1 <= s1.alpha2)) Then + xx = s1.b.x + alphaj1 * s1.t.x + yy = s1.b.y + alphaj1 * s1.t.y + If (x1 = 0) Then x1 = xx Else x2 = xx + If (y1 = 0) Then y1 = yy Else y2 = yy + Call ccircle(xx, yy, 3, 13) + 'CALL ccircle(s2.b.x + s2.alpha1 * s2.t.x, s2.b.y + s2.alpha1 * s2.t.y, 4, 14) + End If + If ((alphaj2 >= s1.alpha1) And (alphaj2 <= s1.alpha2)) Then + xx = s1.b.x + alphaj2 * s1.t.x + yy = s1.b.y + alphaj2 * s1.t.y + If (x1 = 0) Then x1 = xx Else x2 = xx + If (y1 = 0) Then y1 = yy Else y2 = yy + Call ccircle(xx, yy, 3, 13) + 'CALL ccircle(s2.b.x + s2.alpha2 * s2.t.x, s2.b.y + s2.alpha2 * s2.t.y, 4, 14) + End If + alphal1 = s1.alpha1 * t1t2 - DotProduct(s2.t, db) + alphal2 = s1.alpha2 * t1t2 - DotProduct(s2.t, db) + If ((alphal1 >= s2.alpha1) And (alphal1 <= s2.alpha2)) Then + xx = s2.b.x + alphal1 * s2.t.x + yy = s2.b.y + alphal1 * s2.t.y + If (x1 = 0) Then x1 = xx Else x2 = xx + If (y1 = 0) Then y1 = yy Else y2 = yy + Call ccircle(xx, yy, 3, 15) + 'CALL ccircle(s1.b.x + s1.alpha1 * s1.t.x, s1.b.y + s1.alpha1 * s1.t.y, 5, 15) + End If + If ((alphal2 >= s2.alpha1) And (alphal2 <= s2.alpha2)) Then + xx = s2.b.x + alphal2 * s2.t.x + yy = s2.b.y + alphal2 * s2.t.y + If (x1 = 0) Then x1 = xx Else x2 = xx + If (y1 = 0) Then y1 = yy Else y2 = yy + Call ccircle(xx, yy, 3, 15) + 'CALL ccircle(s1.b.x + s1.alpha2 * s1.t.x, s1.b.y + s1.alpha2 * s1.t.y, 5, 15) + End If + If (x1 Or x2 Or y1 Or y2) Then ' Overlap occurred + Call cline(x1, y1, x2, y2, 13) + End If + End If + End If + +End Sub + +Sub CalcEndpoints (i As Integer) + Segments(i).p1.x = Segments(i).b.x + Segments(i).alpha1 * Segments(i).t.x + Segments(i).p1.y = Segments(i).b.y + Segments(i).alpha1 * Segments(i).t.y + Segments(i).p2.x = Segments(i).b.x + Segments(i).alpha2 * Segments(i).t.x + Segments(i).p2.y = Segments(i).b.y + Segments(i).alpha2 * Segments(i).t.y +End Sub + +Sub CalcParameters (i As Integer) + Segments(i).ang = Atn((Segments(i).p2.y - Segments(i).p1.y) / (Segments(i).p2.x - Segments(i).p1.x)) + Segments(i).b.x = .5 * (Segments(i).p1.x + Segments(i).p2.x) + Segments(i).b.y = .5 * (Segments(i).p1.y + Segments(i).p2.y) + Segments(i).alpha1 = -.5 * _Hypot(Segments(i).p2.x - Segments(i).p1.x, Segments(i).p2.y - Segments(i).p1.y) + Segments(i).alpha2 = .5 * _Hypot(Segments(i).p2.x - Segments(i).p1.x, Segments(i).p2.y - Segments(i).p1.y) + Segments(i).t.x = Cos(Segments(i).ang) + Segments(i).t.y = Sin(Segments(i).ang) +End Sub + +Function DotProduct (a As Vector, b As Vector) + DotProduct = a.x * b.x + a.y * b.y +End Function + +Sub cline (x1 As Double, y1 As Double, x2 As Double, y2 As Double, col As _Unsigned Long) + Line (_Width / 2 + x1, -y1 + _Height / 2)-(_Width / 2 + x2, -y2 + _Height / 2), col +End Sub + +Sub ccircle (x1 As Double, y1 As Double, rad As Double, col As _Unsigned Long) + Circle (_Width / 2 + x1, -y1 + _Height / 2), rad, col +End Sub + +Sub cpset (x1 As Double, y1 As Double, col As _Unsigned Long) + PSet (_Width / 2 + x1, -y1 + _Height / 2), col +End Sub + +Sub cpaint (x1 As Double, y1 As Double, col1 As _Unsigned Long, col2 As _Unsigned Long) + Paint (_Width / 2 + x1, -y1 + _Height / 2), col1, col2 +End Sub + +Sub cprintstring (y As Double, a As String) + _PrintString (_Width / 2 - (Len(a) * 8) / 2, -y + _Height / 2), a +End Sub + + diff --git a/samples/lisp-interpreter/img/screenshot.png b/samples/lisp-interpreter/img/screenshot.png new file mode 100644 index 0000000..d519d2b Binary files /dev/null and b/samples/lisp-interpreter/img/screenshot.png differ diff --git a/samples/lisp-interpreter/index.md b/samples/lisp-interpreter/index.md new file mode 100644 index 0000000..1cfa6d1 --- /dev/null +++ b/samples/lisp-interpreter/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: LISP INTERPRETER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 qbguy](../qbguy.md) + +### Description + +```text +Scheme is a functional programming language that uses a minimalist implementation of the LISP language. + +Any sufficiently complicated C or Fortran program contains an ad hoc, informally-specified, bug-ridden, slow implementation of half of Common Lisp. - Greenspun's tenth rule of programming +``` + +### File(s) + +* [lispqb.bas](src/lispqb.bas) +* [lisptest.bas](src/lisptest.bas) + +🔗 [interpreter](../interpreter.md), [lisp](../lisp.md) diff --git a/samples/lisp-interpreter/src/lispqb.bas b/samples/lisp-interpreter/src/lispqb.bas new file mode 100644 index 0000000..f03509a --- /dev/null +++ b/samples/lisp-interpreter/src/lispqb.bas @@ -0,0 +1,766 @@ +DECLARE FUNCTION hash (s$) +DECLARE FUNCTION READOBJ (depth) +DECLARE FUNCTION READTOKEN (depth) +DECLARE FUNCTION STRTOATOM (s$) +DECLARE FUNCTION CONS (car, cdr) +DECLARE FUNCTION READLIST (depth) +DECLARE FUNCTION ALLOC () +DECLARE SUB PRINTOBJ (id) +DECLARE FUNCTION EVALOBJ (id, env) +DECLARE FUNCTION apply (f, args) +DECLARE FUNCTION lookup (anum, env) +DECLARE FUNCTION lvals (id, env) +DECLARE SUB defvar (var, vals, env) +DECLARE SUB setvar (id, vals, env) +DECLARE FUNCTION mkprimop (id) +DECLARE FUNCTION collect(p) +DECLARE SUB gc(root) +DECLARE FUNCTION DoLISP$(TheStringIn$, envin) + +' Make these smaller to get it to work in QBASIC / QuickBASIC +Const msize = 16384 'size of memory -- arbitrary +Const hsize = 4096 'size of hash table -- should be power of 2 + +Dim Shared bufpos As Integer, state As Integer +Dim Shared buf As String +Dim Shared hptr +Dim Shared atom$(0 To hsize - 1), heap(2 * msize - 1, 2) +Dim Shared mmin, nmin, gcnow + +mmin = 1: nmin = msize + +Dim Shared TheInput$ +Dim Shared TheOutput$ + +Const TRUE = -1 +Const FALSE = 0 +Const TNIL = 0 +Const TCONS = 2 +Const TNUM = 3 +Const TSYM = 4 +Const TPROC = 5 +Const TPPROC = 6 +Const TOKNIL = 0 +Const TOKERR = -1 +Const TOKOPEN = -2 +Const TOKCLOSE = -3 +Const TOKQUOTE = -4 +Const TOKDOT = -5 + +Const PPLUS = 1 +Const PMINUS = 2 +Const PTIMES = 3 +Const PCONS = 4 +Const PCAR = 5 +Const PCDR = 6 +Const PEQUAL = 7 +Const PNOT = 8 +Const PEQ = 9 +Const PSETCAR = 10 +Const PSETCDR = 11 +Const PAPPLY = 12 +Const PLIST = 13 +Const PREAD = 14 +Const PLT = 15 +Const PGT = 16 +Const PGEQ = 17 +Const PLEQ = 18 +Const PNUMP = 20 +Const PPROCP = 21 +Const PSYMP = 22 +Const PCONSP = 24 + +''''' + +$Console +_Dest _Console + +GoSub KickStartLISP + +Do + Line Input a$ + Print DoLISP$(a$, env) +Loop + +End + + +KickStartLISP: +hptr = mmin: bufpos = 1 +vars = TNIL +vals = TNIL +frame = CONS(vars, vals) +env = CONS(frame, TNIL) +Call defvar(STRTOATOM("+"), mkprimop(PPLUS), env) +Call defvar(STRTOATOM("-"), mkprimop(PMINUS), env) +Call defvar(STRTOATOM("*"), mkprimop(PTIMES), env) +Call defvar(STRTOATOM("CONS"), mkprimop(PCONS), env) +Call defvar(STRTOATOM("CAR"), mkprimop(PCAR), env) +Call defvar(STRTOATOM("CDR"), mkprimop(PCDR), env) +Call defvar(STRTOATOM("="), mkprimop(PEQUAL), env) +Call defvar(STRTOATOM("NOT"), mkprimop(PNOT), env) +Call defvar(STRTOATOM("EQ?"), mkprimop(PEQ), env) +Call defvar(STRTOATOM("EQV?"), mkprimop(PEQ), env) +Call defvar(STRTOATOM("T"), STRTOATOM("T"), env) ' true +Call defvar(STRTOATOM("SET-CAR!"), mkprimop(PSETCAR), env) +Call defvar(STRTOATOM("SET-CDR!"), mkprimop(PSETCDR), env) +Call defvar(STRTOATOM("APPLY"), mkprimop(PAPPLY), env) +Call defvar(STRTOATOM("LIST"), mkprimop(PLIST), env) +Call defvar(STRTOATOM("READ"), mkprimop(PREAD), env) +Call defvar(STRTOATOM("<"), mkprimop(PLT), env) +Call defvar(STRTOATOM(">"), mkprimop(PGT), env) +Call defvar(STRTOATOM(">="), mkprimop(PGEQ), env) +Call defvar(STRTOATOM("<="), mkprimop(LEQ), env) +Call defvar(STRTOATOM("SYMBOL?"), mkprimop(PSYMP), env) +Call defvar(STRTOATOM("NUMBER?"), mkprimop(PNUMP), env) +Call defvar(STRTOATOM("PROCEDURE?"), mkprimop(PPROCP), env) +Call defvar(STRTOATOM("PAIR?"), mkprimop(PCONSP), env) +Return + +''''' + + +Function DoLISP$ (TheStringIn As String, envin) + TheInput$ = TheStringIn + TheOutput$ = "" + s = READOBJ(0) + Select Case s + Case TOKCLOSE + ' unmatched closed parenthesis + Case TOKDOT + 'PRINT "dot used outside list" + Case TOKERR + 'PRINT "[Error]" + TheOutput$ = TheOutput$ + "[Error]" + Case Else + Call PRINTOBJ(EVALOBJ(s, envin)) + End Select + DoLISP$ = TheOutput$ +End Function + +'DO +' s = READOBJ(0) +' SELECT CASE s +' CASE TOKCLOSE +' ' unmatched closed parenthesis +' CASE TOKDOT +' PRINT "dot used outside list" +' CASE TOKERR +' PRINT "[Error]" +' CASE ELSE +' CALL PRINTOBJ(EVALOBJ(s, env)) +' END SELECT +' PRINT +' IF gcnow THEN CALL gc(env) +'LOOP + +Function ALLOC + ALLOC = hptr + hptr = hptr + 1 + If hptr > (mmin + 3 * (msize / 4)) Then gcnow = -1 +End Function + +Function apply (id, args) + If heap(id, 0) = TPROC Then + params = heap(id, 1) + body = heap(heap(id, 2), 1) + procenv = heap(heap(id, 2), 2) + env = CONS(CONS(params, args), procenv) + Do While heap(body, 2) + t = heap(body, 1) + t = EVALOBJ(t, env) 'ignore result + body = heap(body, 2) + Loop + t = heap(body, 1) + apply = EVALOBJ(t, env) + ElseIf heap(id, 0) = TPPROC Then + Select Case heap(id, 1) + Case PPLUS + sum = 0 + a = args + While a + sum = sum + heap(heap(a, 1), 1) + a = heap(a, 2) + Wend + p = ALLOC + heap(p, 0) = TNUM + heap(p, 1) = sum + apply = p + Case PTIMES + prod = 1 + a = args + While a + prod = prod * heap(heap(a, 1), 1) + a = heap(a, 2) + Wend + p = ALLOC + heap(p, 0) = TNUM + heap(p, 1) = prod + apply = p + Case PCONS + apply = CONS(heap(args, 1), heap(heap(args, 2), 1)) + Case PCAR + apply = heap(heap(args, 1), 1) + Case PCDR + apply = heap(heap(args, 1), 2) + Case PEQUAL + If args = TNIL Then apply = STRTOATOM("T"): Exit Function + f = heap(heap(args, 1), 1) + a = heap(args, 2) + Do While a + If heap(heap(a, 1), 1) <> f Then apply = TNIL: Exit Function + a = heap(a, 2) + Loop + apply = STRTOATOM("T"): Exit Function + Case PNOT + If heap(args, 1) Then apply = TNIL Else apply = STRTOATOM("T") + Case PEQ + arg1 = heap(args, 1) + arg2 = heap(heap(args, 2), 1) + If heap(arg1, 0) <> heap(arg2, 0) Then apply = TNIL: Exit Function + Select Case heap(arg1, 0) + Case TNUM, TPROC, TPPROC, TSYM + If heap(arg1, 1) = heap(arg2, 1) Then apply = STRTOATOM("T") + Case TCONS, TNIL + If arg1 = arg2 Then apply = STRTOATOM("T") + End Select + Case PLT + If args = TNIL Then apply = STRTOATOM("T"): Exit Function + f = heap(heap(args, 1), 1) + a = heap(args, 2) + Do While a + If f < heap(heap(a, 1), 1) Then + f = heap(heap(a, 1), 1) + a = heap(a, 2) + Else + apply = TNIL: Exit Function + End If + Loop + apply = STRTOATOM("T"): Exit Function + Case PGT + If args = TNIL Then apply = STRTOATOM("T"): Exit Function + f = heap(heap(args, 1), 1) + a = heap(args, 2) + Do While a + If f > heap(heap(a, 1), 1) Then + f = heap(heap(a, 1), 1) + a = heap(a, 2) + Else + apply = TNIL: Exit Function + End If + Loop + apply = STRTOATOM("T"): Exit Function + Case PLEQ + If args = TNIL Then apply = STRTOATOM("T"): Exit Function + f = heap(heap(args, 1), 1) + a = heap(args, 2) + Do While a + If f <= heap(heap(a, 1), 1) Then + f = heap(heap(a, 1), 1) + a = heap(a, 2) + Else + apply = TNIL: Exit Function + End If + Loop + apply = STRTOATOM("T"): Exit Function + Case PGEQ + If args = TNIL Then apply = STRTOATOM("T"): Exit Function + f = heap(heap(args, 1), 1) + a = heap(args, 2) + Do While a + If f >= heap(heap(a, 1), 1) Then + f = heap(heap(a, 1), 1) + a = heap(a, 2) + Else + apply = TNIL: Exit Function + End If + Loop + apply = STRTOATOM("T"): Exit Function + Case PSETCAR + arg1 = heap(args, 1) + arg2 = heap(heap(args, 2), 1) + heap(arg1, 1) = arg2 + Case PSETCDR + arg1 = heap(args, 1) + arg2 = heap(heap(args, 2), 1) + heap(arg2, 2) = arg2 + Case PAPPLY + arg1 = heap(args, 1) + arg2 = heap(heap(args, 2), 1) + apply = apply(arg1, arg2) + Case PLIST + apply = args + Case PREAD + apply = READOBJ(0) + Case PMINUS + arg1 = heap(heap(args, 1), 1) + rargs = heap(args, 2) + If rargs Then + res = arg1 + While rargs + res = res - heap(heap(rargs, 1), 1) + rargs = heap(rargs, 2) + Wend + p = ALLOC + heap(p, 0) = TNUM: heap(p, 1) = res: apply = p + Else + p = ALLOC: heap(p, 0) = TNUM: heap(p, 1) = -arg1 + apply = p + End If + Case PSYMP + targ1 = heap(heap(args, 1), 0) + If targ1 = TSYM Then apply = STRTOATOM("T") + Case PNUMP + targ1 = heap(heap(args, 1), 0) + If targ1 = TNUM Then apply = STRTOATOM("T") + Case PPROCP + targ1 = heap(heap(args, 1), 0) + If targ1 = TPROC Or targ1 = TPPROC Then apply = STRTOATOM("T") + Case PCONSP + targ1 = heap(heap(args, 1), 0) + If targ1 = TCONS Then apply = STRTOATOM("T") + End Select + Else + Print "Bad application -- not a function" + apply = TOKERR + End If +End Function + +Function CONS (car, cdr) + p = ALLOC + heap(p, 0) = TCONS + heap(p, 1) = car + heap(p, 2) = cdr + CONS = p +End Function + +Sub defvar (id, value, env) + anum = heap(id, 1) + frame = heap(env, 1) + vars = heap(frame, 1) + vals = heap(frame, 2) + While vars + If heap(heap(vars, 1), 1) = anum Then + heap(vals, 1) = value: Exit Sub + End If + vars = heap(vars, 2): vals = heap(vals, 2) + Wend + vars = heap(frame, 1) + vals = heap(frame, 2) + heap(frame, 1) = CONS(id, vars) + heap(frame, 2) = CONS(value, vals) +End Sub + +Function EVALOBJ (id, env) + 1 Select Case heap(id, 0) + Case TNIL, TNUM ' self-evaluating + EVALOBJ = id + Case TSYM + EVALOBJ = lookup(heap(id, 1), env) + Case TCONS + o = heap(id, 1) + t = heap(o, 0) + If t = TSYM Then + a$ = atom$(heap(o, 1)) ' symbol name of car(id) + Select Case a$ + Case "QUOTE" + EVALOBJ = heap(heap(id, 2), 1) + Case "SET!" + vid = heap(heap(id, 2), 1) 'cadr + aval = heap(heap(heap(id, 2), 2), 1) 'caddr + Call setvar(vid, EVALOBJ(aval, env), env) + Case "DEFINE" + vid = heap(heap(id, 2), 1) + aval = heap(heap(heap(id, 2), 2), 1) + Call setvar(vid, EVALOBJ(aval, env), env) + Case "IF" + ' (if pred ic ia) + pred = heap(heap(id, 2), 1) 'predicate = cadr + ic = heap(heap(heap(id, 2), 2), 1) ' caddr + ia = heap(heap(heap(heap(id, 2), 2), 2), 1) ' cadddr + If EVALOBJ(pred, env) Then + ' return EVALOBJ(ic,env) + id = ic: GoTo 1 + Else + ' return EVALOBJ(ia,env) + id = ia: GoTo 1 + End If + Case "LAMBDA" + p = ALLOC + heap(p, 0) = TPROC + heap(p, 1) = heap(heap(id, 2), 1) ' cadr = args + heap(p, 2) = CONS(heap(heap(id, 2), 2), env) 'caddr = body + EVALOBJ = p + Case "BEGIN" + seq = heap(id, 2) + Do While heap(seq, 2) + t = heap(seq, 1) + t = EVALOBJ(t, env) 'ignore result + seq = heap(seq, 2) + Loop + id = heap(seq, 1): GoTo 1 + Case "AND" + seq = heap(id, 2) + Do While heap(seq, 2) + t = heap(seq, 1) + t = EVALOBJ(t, env) + If t = 0 Then EVALOBJ = 0: Exit Function + seq = heap(seq, 2) + Loop + id = heap(seq, 1): GoTo 1 + Case "OR" + seq = heap(id, 2) + Do While heap(seq, 2) + t = heap(seq, 1) + t = EVALOBJ(t, env) + If t Then EVALOBJ = t: Exit Function + seq = heap(seq, 2) + Loop + id = heap(seq, 1): GoTo 1 + Case "COND" + clauses = heap(id, 2) + While clauses + clause = heap(clauses, 1) + pred = heap(clause, 1) + If EVALOBJ(pred, env) Then + seq = heap(clause, 2) + Do While heap(seq, 2) + t = heap(seq, 1) + t = EVALOBJ(t, env) 'ignore result + seq = heap(seq, 2) + Loop + id = heap(seq, 1): GoTo 1 + End If + clauses = heap(clauses, 2) + Wend + Case Else + args = heap(id, 2) + proc = EVALOBJ(o, env) + EVALOBJ = apply(proc, lvals(args, env)) + End Select + Else + args = heap(id, 2) + proc = EVALOBJ(o, env) + EVALOBJ = apply(proc, lvals(args, env)) + End If + Case Else + Print "Unhandled expression type: "; a$ + EVALOBJ = id + End Select +End Function + +Function hash (s$) + Dim h As Long + For i = 1 To Len(s$) + c = Asc(Mid$(s$, i, 1)) + h = (h * 33 + c) Mod hsize + Next + hash = h +End Function + +Function lookup (anum, env) + ' env is a list of (vars . vals) frames + ' where: vars is a list of symbols + ' vals is a list of their values + e = env + Do + frame = heap(e, 1) ' get the first frame + + vars = heap(frame, 1) ' vars is car + + vals = heap(frame, 2) ' vals is cdr + + While vars ' while vars left to check + If heap(heap(vars, 1), 1) = anum Then 'atom number of car(vars) = anum + lookup = heap(vals, 1) ' car(vals) + Exit Function + End If + vars = heap(vars, 2) 'cdr(vars) + vals = heap(vals, 2) 'cdr(vals) + Wend + e = heap(e, 2) ' cdr(e) + Loop While e + Print "Unbound variable: "; atom$(anum): lookup = TOKERR +End Function + +Function lvals (id, env) + If heap(id, 0) = TCONS Then + car = heap(id, 1) + ecar = EVALOBJ(car, env) + head = CONS(ecar, 0) + l = heap(id, 2): prev = head + While l + car = heap(l, 1) + ecar = EVALOBJ(car, env) + new = CONS(ecar, 0) + heap(prev, 2) = new + prev = new + l = heap(l, 2) + Wend + lvals = head + Else + lvals = 0 + End If +End Function + +Function mkprimop (id) + p = ALLOC + heap(p, 0) = TPPROC + heap(p, 1) = id + mkprimop = p +End Function + +Sub PRINTOBJ (id) + + If id = TOKERR Then Print "[Error]": Exit Sub + Select Case heap(id, 0) + Case TNIL + 'PRINT "()"; + TheOutput$ = TheOutput$ + "()" + Case TCONS + 'PRINT "("; + TheOutput$ = TheOutput$ + "(" + printlist: + Call PRINTOBJ(heap(id, 1)) + 'PRINT " "; + TheOutput$ = TheOutput$ + " " + cdr = heap(id, 2) + If heap(cdr, 0) = TCONS Then id = cdr: GoTo printlist + If heap(cdr, 0) = TNIL Then + 'PRINT ")"; + TheOutput$ = TheOutput$ + ")" + Else + 'PRINT "."; + TheOutput$ = TheOutput$ + "." + Call PRINTOBJ(cdr) + 'PRINT ")"; + TheOutput$ = TheOutput$ + ")" + End If + Case TNUM + 'PRINT heap(id, 1); + TheOutput$ = TheOutput$ + Str$(heap(id, 1)) + Case TSYM + 'PRINT atom$(heap(id, 1)); + TheOutput$ = TheOutput$ + atom$(heap(id, 1)) + Case TPROC, TPPROC + 'PRINT "[Procedure]" + TheOutput$ = TheOutput$ + "[Procedure]" + End Select +End Sub + +Function READLIST (depth) + SH = READOBJ(depth) + Select Case SH + Case TOKERR + READLIST = TOKERR + Case TOKCLOSE + READLIST = 0 + Case TOKDOT + SH = READOBJ(depth) + Select Case SH + Case TOKERR, TOKDOT, TOKCLOSE + READLIST = TOKERR + Case Else + ST = READLIST(depth) + If ST Then READLIST = TOKERR Else READLIST = SH + End Select + Case Else + ST = READLIST(depth) + If ST = TOKERR Then READLIST = TOKERR Else READLIST = CONS(SH, ST) + End Select +End Function + +Function READOBJ (depth) + tok = READTOKEN(depth) + Select Case tok + Case TOKOPEN + s = READLIST(depth + 1) + READOBJ = s + Case TOKQUOTE + tok = READOBJ(depth + 1) + Select Case tok + Case TOKCLOSE + Print "warning: quote before close parenthesis" + READOBJ = tok + Case TOKDOT + Print "warning: quote before dot" + READOBJ = tok + Case Else + s = CONS(STRTOATOM("QUOTE"), CONS(tok, 0)) + READOBJ = s + End Select + Case Else + READOBJ = tok + End Select +End Function + +Function READTOKEN (depth) + + start1: bufend = Len(buf) + While bufpos < bufend And InStr(" " + Chr$(9), Mid$(buf, bufpos, 1)) + bufpos = bufpos + 1 + Wend + c$ = Mid$(buf, bufpos, 1) + If InStr(":;", c$) Then + If c$ = ":" Then + bufpos = bufpos + 1 + If bufpos <= bufend Then + Select Case Mid$(buf, bufpos, 1) + Case "q", "Q" ' quit + System + Case "g", "G" ' garbage collect now + gcnow = -1 + Case Else + READTOKEN = TOKERR + Exit Function + End Select + End If + End If + bufpos = bufend + 1 + End If + If bufpos > bufend Then + 'IF depth = 0 THEN PRINT "]=> "; + 'LINE INPUT buf + buf = TheInput$ + bufend = Len(buf) + bufpos = 1 + GoTo start1 + End If + Select Case c$ + Case "(" + bufpos = bufpos + 1 + READTOKEN = TOKOPEN + Case ")" + bufpos = bufpos + 1 + READTOKEN = TOKCLOSE + Case "'" + bufpos = bufpos + 1 + READTOKEN = TOKQUOTE + Case "." + bufpos = bufpos + 1 + READTOKEN = TOKDOT + Case Else + strbeg = bufpos + bufpos = bufpos + 1 + Do While bufpos <= bufend + c$ = Mid$(buf, bufpos, 1) + If c$ = " " Or c$ = "." Or c$ = "(" Or c$ = ")" Then Exit Do + bufpos = bufpos + 1 + Loop + READTOKEN = STRTOATOM(Mid$(buf, strbeg, bufpos - strbeg)) + End Select +End Function + +Sub setvar (id, value, env) + anum = heap(id, 1) + e = env + Do + frame = heap(e, 1) + vars = heap(frame, 1) + vals = heap(frame, 2) + While vars + If heap(heap(vars, 1), 1) = anum Then + heap(vals, 1) = value: Exit Sub + End If + vars = heap(vars, 2): vals = heap(vals, 2) + Wend + e = heap(e, 2) + Loop While e + Call defvar(id, value, env) +End Sub + +Function STRTOATOM (s$) + l = Len(s$) + c$ = Left$(s$, 1) + If (c$ = "-" And l >= 2) Or (c$ >= "0" And c$ <= "9") Then + v = 0 + If c$ = "-" Then neg = 1: idx = 2 Else neg = 0: idx = 1 + For idx = idx To l + c$ = Mid$(s$, idx, 1) + If (c$ >= "0" And c$ <= "9") Then + v = v * 10 + (Asc(c$) - Asc("0")) + Else + Exit For + End If + Next + If idx = l + 1 Then + If neg Then v = -v + p = ALLOC + heap(p, 0) = TNUM + heap(p, 1) = v + STRTOATOM = p: Exit Function + End If + End If + If UCase$(s$) = "NIL" Then STRTOATOM = TOKNIL: Exit Function + + i = hash(UCase$(s$)) + For count = 1 To hsize + If atom$(i) = UCase$(s$) Then + found = TRUE: Exit For + ElseIf atom$(i) = "" Then + atom$(i) = UCase$(s$) + found = TRUE + Exit For + Else + i = (i + count) Mod hsize + End If + Next + If Not found Then Print "Symbol table full!" + p = ALLOC: heap(p, 0) = TSYM: heap(p, 1) = i + STRTOATOM = p +End Function + +Sub gc (root) + hptr = nmin + root = collect(root) + Swap mmin, nmin + Swap mmax, nmax + gcnow = 0 +End Sub + +Function collect (p) + + Select Case heap(p, 0) + + Case -1 + collect = heap(p, 1) + + Case TCONS, TPROC + + ' address of new copy + x = ALLOC + + ' car, cdr + a = heap(p, 1) + d = heap(p, 2) + + ' replace with forwarding address + heap(p, 0) = -1 + heap(p, 1) = x + + ' copy + heap(x, 0) = heap(p, 0) + heap(x, 1) = collect(a) + heap(x, 2) = collect(d) + collect = x + + Case TNIL + collect = 0 + + Case Else + x = ALLOC + + ' copy the entire structure + For i = 0 To 2 + heap(x, i) = heap(p, i) + Next + + ' write forwarding address + heap(p, 0) = -1 + heap(p, 1) = x + collect = x + End Select + +End Function + + diff --git a/samples/lisp-interpreter/src/lisptest.bas b/samples/lisp-interpreter/src/lisptest.bas new file mode 100644 index 0000000..d5f051e --- /dev/null +++ b/samples/lisp-interpreter/src/lisptest.bas @@ -0,0 +1,13 @@ +(+ 2 2) +(apply + '(1 2 3)) +(+ 1 -3 2 5) +(define generator (lambda (x) (lambda (y) (if y (generator y) x)))) +(define pocket (generator 8)) +(pocket nil) +(define pocktwo (pocket 10)) +(pocktwo '()) +(define fact (lambda (x) (if (= x 0) 1 (* x (fact (+ x -1)))))) +(fact 5) +(fact 7) +(DEFINE MAP (LAMBDA (F X) (IF X (CONS (F (CAR X)) (MAP F (CDR X)))))) +(MAP (LAMBDA (X) (* X 2)) '(1 2 3 4 5 6 7 )) diff --git a/samples/lisp.md b/samples/lisp.md new file mode 100644 index 0000000..bc73e29 --- /dev/null +++ b/samples/lisp.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: LISP + +**[Lisp Interpreter](lisp-interpreter/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [interpreter](interpreter.md), [lisp](lisp.md) + +Scheme is a functional programming language that uses a minimalist implementation of the LISP lan... diff --git a/samples/lissajous-curve-table/index.md b/samples/lissajous-curve-table/index.md index 132dbef..299eea3 100644 --- a/samples/lissajous-curve-table/index.md +++ b/samples/lissajous-curve-table/index.md @@ -18,9 +18,9 @@ Graphical Lissajou's Figures. For added eye-candy-ness, I've changed the plot l > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "lissajous-curve-table.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/lissajous-curve-table/src/lissajous-curve-table.bas) -* [RUN "lissajous-curve-table.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/lissajous-curve-table/src/lissajous-curve-table.bas) -* [PLAY "lissajous-curve-table.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/lissajous-curve-table/src/lissajous-curve-table.bas) +* [LOAD "lissajous-curve-table.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/lissajous-curve-table/src/lissajous-curve-table.bas) +* [RUN "lissajous-curve-table.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/lissajous-curve-table/src/lissajous-curve-table.bas) +* [PLAY "lissajous-curve-table.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/lissajous-curve-table/src/lissajous-curve-table.bas) ### File(s) diff --git a/samples/lissajous-screensaver/index.md b/samples/lissajous-screensaver/index.md index 4bbc01c..daea4c1 100644 --- a/samples/lissajous-screensaver/index.md +++ b/samples/lissajous-screensaver/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "lissaj.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/lissajous-screensaver/src/lissaj.bas) -* [RUN "lissaj.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/lissajous-screensaver/src/lissaj.bas) -* [PLAY "lissaj.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/lissajous-screensaver/src/lissaj.bas) +* [LOAD "lissaj.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/lissajous-screensaver/src/lissaj.bas) +* [RUN "lissaj.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/lissajous-screensaver/src/lissaj.bas) +* [PLAY "lissaj.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/lissajous-screensaver/src/lissaj.bas) ### File(s) diff --git a/samples/loan-amortization/img/screenshot.png b/samples/loan-amortization/img/screenshot.png new file mode 100644 index 0000000..5046a8d Binary files /dev/null and b/samples/loan-amortization/img/screenshot.png differ diff --git a/samples/loan-amortization/index.md b/samples/loan-amortization/index.md new file mode 100644 index 0000000..7132268 --- /dev/null +++ b/samples/loan-amortization/index.md @@ -0,0 +1,72 @@ +[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: LOAN AMORTIZATION + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Alan Zeichick](../alan-zeichick.md) + +### Description + +```text +' Loan amortization program +' Alan Zeichick, March 16, 1993 +' Copyright (c) 1993 DOS Resource Guide +' Published in Issue #11, September 1993, page 49 +' +' This program produces a loan amortization table, given +' the amount of a loan, number of payments, annual interest +' rate, and extra money (if any) to be paid each month. + +****************************************************************************** + +----------- + AMORT.BAS +----------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x, and (optionally) a printer. + +WHAT AMORT.BAS DOES +This program lets you calculate and print a table of principal and interest +payments for a loan. Use it to determine the amount of each payment and the +amount of interest you'll pay over the term of the loan. + +USING AMORT.BAS +To load the program, type QBASIC AMORT.BAS (using pathnames if necessary) +at the DOS prompt. Then run the program by selecting the Start option in +QBasic's Run menu, or press Shift-F5. The screen clears, and the program +requests several items of information. These include the principal amount, +the term of the loan in months, and the interest rate. At this point, +AMORT.BAS calculates and displays the monthly payment amount, the sum of all +payments, and the total interest paid. The program now lets you add an extra +amount to be applied toward the pricipal each month, if you wish. Doing so +can dramatically decrease the term of the loan and the total interest paid. + +Next, the program offers a set of options for displaying, saving, and printing +the amortization table. Option S displays the table on the screen, while P +sends it to your printer. Pressing D saves the table to a disk file suitable +for printing, while C creates a comma-delimited data file that can be imported +into a spreadsheet or other program. Option R allows starting a new +calculation without printing or displaying the amortization table, and Q quits +the program. + +For further details on AMORT.BAS, see "An Interest in QBasic" (DRG #11, +September 1993, page 49). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "amort.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/loan-amortization/src/amort.bas) +* [RUN "amort.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/loan-amortization/src/amort.bas) +* [PLAY "amort.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/loan-amortization/src/amort.bas) + +### File(s) + +* [amort.bas](src/amort.bas) + +🔗 [finance](../finance.md), [dos world](../dos-world.md) diff --git a/samples/loan-amortization/src/amort.bas b/samples/loan-amortization/src/amort.bas new file mode 100644 index 0000000..ad81344 --- /dev/null +++ b/samples/loan-amortization/src/amort.bas @@ -0,0 +1,209 @@ +DECLARE SUB SetDefaults (Principal!, Months!, AnnualInt!, Extra!, EndProg!) +DECLARE SUB GetInputs (Principal!, Months!, AnnualInt!) +DECLARE SUB FinCalc (Principal!, Months!, AnnualInt!, MonthInt!, Payment!) +DECLARE SUB GetExtra (Principal!, Months!, Payment!, Extra!) +DECLARE SUB PrintIt (Principal!, Months!, AnnualInt!, MonthInt!, Payment!, Extra!, EndProg!) +DECLARE FUNCTION Min! (A!, B!) +DECLARE FUNCTION ROUND2! (Value!) +' +' Loan amortization program +' Alan Zeichick, March 16, 1993 +' Copyright (c) 1993 DOS Resource Guide +' Published in Issue #11, September 1993, page 49 +' +' This program produces a loan amortization table, given +' the amount of a loan, number of payments, annual interest +' rate, and extra money (if any) to be paid each month. +' +' +' Here is the main program +' +CONST False = 0, True = 1 + +CALL SetDefaults(Principal, Months, AnnualInt, Extra, EndProg) + +WHILE EndProg = False + + CALL GetInputs(Principal, Months, AnnualInt) + CALL FinCalc(Principal, Months, AnnualInt, MonthInt, Payment) + CALL GetExtra(Principal, Months, Payment, Extra) + CALL PrintIt(Principal, Months, AnnualInt, MonthInt, Payment, Extra, EndProg) + +WEND + +END + +SUB FinCalc (Principal, Months, AnnualInt, MonthInt, Payment) + +MonthInt = AnnualInt / 12 + +Payment = (Principal * (MonthInt / (1 - (1 + MonthInt) ^ -Months))) + +END SUB + +SUB GetExtra (Principal, Months, Payment, Extra) + +PRINT +PRINT "Based on your input data," +PRINT " The monthly payment is $"; ROUND2(Payment) +PRINT " The sum of payments is $"; ROUND2(Payment * Months) +PRINT " The total amount of interest to be paid is $"; ROUND2(Payment * Months - Principal) +PRINT +PRINT "Enter any additional payment amount (default=$"; Extra; ") "; +INPUT Answer$ +IF Answer$ <> "" THEN Extra = VAL(Answer$) +END SUB + +SUB GetInputs (Principal, Months, AnnualInt) + +CLS +PRINT "What principal amount do you wish to use? (default=$"; Principal; ")" +PRINT "Please do not enter the dollar sign or commas." +INPUT Answer$ +IF Answer$ <> "" THEN Principal = VAL(Answer$) + +PRINT "How many months does the loan cover? (default="; Months; ")" +INPUT Answer$ +IF Answer$ <> "" THEN Months = VAL(Answer$) + +PRINT "What is the annual interest rate? (default="; AnnualInt * 100; "%)" +INPUT Answer$ +IF Answer$ <> "" THEN AnnualInt = VAL(Answer$) +IF AnnualInt > 1 THEN AnnualInt = AnnualInt / 100 + +END SUB + +FUNCTION Min (A, B) + +IF A < B THEN Min = A ELSE Min = B + +END FUNCTION + +SUB PrintIt (Principal, Months, AnnualInt, MonthInt, Payment, Extra, EndProg) + +OkayToProceed = False + +WHILE OkayToProceed = False + PRINT + PRINT "Do you wish to:" + PRINT " S - Output amortization table to screen" + PRINT " P - Send amortization table to printer" + PRINT " D - Output as printable disk file" + PRINT " C - Create a comma-delimited data file" + PRINT " R - Restart without printing table" + PRINT " Q - Quit program" + PRINT "(default=S) "; + INPUT DESTINATION$ + DESTINATION$ = UCASE$(LEFT$(DESTINATION$ + "S", 1)) + IF INSTR("SPDCRQ", DESTINATION$) > 0 THEN OkayToProceed = True + WEND + +filenum = FREEFILE + +IF INSTR("CD", DESTINATION$) THEN + PRINT "Please enter disk file name (default=C:\AMORT.OUT) "; + INPUT OutputFile$ + IF OutputFile$ = "" THEN OutputFile$ = "C:\AMORT.OUT" + OPEN OutputFile$ FOR OUTPUT AS filenum + END IF + +IF DESTINATION$ = "P" THEN OPEN "prn" FOR OUTPUT AS filenum + +IF DESTINATION$ = "S" THEN OPEN "scrn:" FOR OUTPUT AS filenum + +IF INSTR("DPS", DESTINATION$) THEN + PRINT #filenum, "Amortization table" + PRINT #filenum, "Principal = $"; Principal; "" + PRINT #filenum, "Annual Interest Rate ="; 100 * AnnualInt; "%" + PRINT #filenum, "Monthly Interest Rate ="; 100 * MonthInt; "%" + PRINT #filenum, "Basic monthly payment = $"; ROUND2(Payment) + PRINT #filenum, "Extra amount towards principal = $"; Extra + PRINT #filenum, + PRINT #filenum, "Payment Principal Interest Applied Extra New Balance" + +END IF + +IF DESTINATION$ = "C" THEN + WRITE #filenum, "Payment", "Principal", "Interest", "Applied", "Extra", "New Balance" + END IF + +IF INSTR("CDPS", DESTINATION$) THEN + + TotalInterest = 0 + PaymentNumber = 0 + Balance = Principal + + WHILE Balance > 0 + + InterestAmount = Balance * MonthInt + PrincipalAmount = Min(Payment - InterestAmount, Balance) + ExtraAmount = Min(Balance - PrincipalAmount, Extra) + NewBalance = Balance - PrincipalAmount - ExtraAmount + PaymentNumber = PaymentNumber + 1 + + TotalInterest = TotalInterest + InterestAmount + TotalPayments = TotalPayments + PrincipalAmount + TotalExtra = TotalExtra + ExtraAmount + + IF INSTR("DPS", DESTINATION$) THEN + PRINT #filenum, USING "####"; PaymentNumber; + PRINT #filenum, USING " $$###,###,###.##"; Balance; + PRINT #filenum, USING " $$###,###.##"; InterestAmount; + PRINT #filenum, USING " $$###,###.##"; PrincipalAmount; + PRINT #filenum, USING " $$###,###.##"; ExtraAmount; + PRINT #filenum, USING " $$###,###,###.##"; NewBalance + ELSE + WRITE #filenum, PaymentNumber, Balance, InterestAmount, PrincipalAmount, ExtraAmount, NewBalance + END IF + + Balance = NewBalance + + WEND + + AmountSaved = ROUND2(Months * Payment - Principal - TotalInterest) + + IF DESTINATION$ = "DP" THEN + PRINT #filenum, + PRINT #filenum, "Actual number of payments ="; PaymentNumber; + PRINT #filenum, "you saved"; Months - PaymentNumber; "months." + PRINT #filenum, "Actual amount of interest paid = $"; ROUND2(TotalInterest); + PRINT #filenum, "you saved $"; ROUND2(AmountSaved) + END IF + + PRINT + PRINT "Actual number of payments ="; PaymentNumber; + PRINT "you saved"; Months - PaymentNumber; "months." + PRINT "Actual amount of interest paid = $"; ROUND2(TotalInterest); + PRINT "you saved $"; ROUND2(AmountSaved) + + CLOSE #filenum + +END IF + +IF DESTINATION$ <> "Q" THEN + PRINT "Enter Q to end program, anything else to continue:" + INPUT Answer$ +END IF + +IF DESTINATION$ = "Q" OR UCASE$(LEFT$(Answer$, 1)) = "Q" THEN + EndProg = True +ELSE + EndProg = False +END IF + +END SUB + +FUNCTION ROUND2 (Value) + + ROUND2 = INT(Value * 100 + .5) / 100 + +END FUNCTION + +SUB SetDefaults (Principal, Months, AnnualInt, Extra, EndProg) +Principal = 10000 +Months = 48 +AnnualInt = .08 +Extra = 0 +EndProg = False +END SUB + diff --git a/samples/lorenz-attractor/index.md b/samples/lorenz-attractor/index.md index cc3e957..f8671e8 100644 --- a/samples/lorenz-attractor/index.md +++ b/samples/lorenz-attractor/index.md @@ -18,9 +18,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "lorenz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/lorenz-attractor/src/lorenz.bas) -* [RUN "lorenz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/lorenz-attractor/src/lorenz.bas) -* [PLAY "lorenz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/lorenz-attractor/src/lorenz.bas) +* [LOAD "lorenz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/lorenz-attractor/src/lorenz.bas) +* [RUN "lorenz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/lorenz-attractor/src/lorenz.bas) +* [PLAY "lorenz.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/lorenz-attractor/src/lorenz.bas) ### File(s) diff --git a/samples/lucid-drawing/img/drawingprogramlucid.png b/samples/lucid-drawing/img/drawingprogramlucid.png new file mode 100644 index 0000000..6cc2ec1 Binary files /dev/null and b/samples/lucid-drawing/img/drawingprogramlucid.png differ diff --git a/samples/lucid-drawing/index.md b/samples/lucid-drawing/index.md new file mode 100644 index 0000000..8965e15 --- /dev/null +++ b/samples/lucid-drawing/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: LUCID DRAWING + +![drawingprogramlucid.png](img/drawingprogramlucid.png) + +### Author + +[🐝 Lucid](../lucid.md) + +### Description + +```text +Drawing program by Lucid. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "lucid-drawing.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/lucid-drawing/src/lucid-drawing.bas) +* [RUN "lucid-drawing.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/lucid-drawing/src/lucid-drawing.bas) +* [PLAY "lucid-drawing.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/lucid-drawing/src/lucid-drawing.bas) + +### File(s) + +* [lucid-drawing.bas](src/lucid-drawing.bas) + +🔗 [2d](../2d.md), [draw](../draw.md) diff --git a/samples/lucid-drawing/src/lucid-drawing.bas b/samples/lucid-drawing/src/lucid-drawing.bas new file mode 100644 index 0000000..db40686 --- /dev/null +++ b/samples/lucid-drawing/src/lucid-drawing.bas @@ -0,0 +1,28 @@ +Start: +Screen 12 +Line (0, 0)-(640, 480), 15, BF +Locate 1, 1: Print String$(80, 32) +Brushtype = 1 + +Do + Do While _MouseInput: Loop + If Brushtype = 1 And _MouseButton(1) Then Line (mousex, mousey)-(_MouseX, _MouseY), 0 + If Brushtype = 2 And _MouseButton(1) Then For r = 0 To 6: Line (mousex + r, mousey + r)-(_MouseX + r, _MouseY + r), 0: Next r + If Brushtype = 3 And _MouseButton(1) Then For r = 0 To 6: Line (mousex, mousey + r)-(_MouseX, _MouseY + r), 0: Next r + If Brushtype = 4 And _MouseButton(1) Then For r = 0 To 44: Circle (_MouseX, _MouseY), r, r: Next r + + If _MouseButton(2) Then Paint (_MouseX, _MouseY), 0 + + A$ = InKey$ + If A$ = " " Then GoTo Start: ' reset + If A$ = "1" Then Let Brushtype = 1 ' normal brush + If A$ = "2" Then Let Brushtype = 2 ' calligraphy 1 + If A$ = "3" Then Let Brushtype = 3 ' calligraphy 2 + If A$ = "4" Then Let Brushtype = 4 ' rainbow + + mousex = _MouseX + mousey = _MouseY + + Locate 1, 1: Print " QB64 Draw "; Chr$(179); " X:"; _MouseX; "Y:"; _MouseY; " Press 1-4 for different pencils "; +Loop + diff --git a/samples/lucid.md b/samples/lucid.md new file mode 100644 index 0000000..300c1b3 --- /dev/null +++ b/samples/lucid.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 LUCID + +**[Lucid Drawing](lucid-drawing/index.md)** + +[🐝 Lucid](lucid.md) 🔗 [2d](2d.md), [draw](draw.md) + +Drawing program by Lucid. diff --git a/samples/luke.md b/samples/luke.md new file mode 100644 index 0000000..1e83fd0 --- /dev/null +++ b/samples/luke.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 LUKE + +**[Conways Game of Life](conways-game-of-life/index.md)** + +[🐝 Luke](luke.md) 🔗 [automata](automata.md), [conway](conway.md) + +Standard Conway's Game of Life simulation. diff --git a/samples/manadla/index.md b/samples/manadla/index.md index 24389db..496592c 100644 --- a/samples/manadla/index.md +++ b/samples/manadla/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "mandala.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/manadla/src/mandala.bas) -* [RUN "mandala.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/manadla/src/mandala.bas) -* [PLAY "mandala.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/manadla/src/mandala.bas) +* [LOAD "mandala.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/manadla/src/mandala.bas) +* [RUN "mandala.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/manadla/src/mandala.bas) +* [PLAY "mandala.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/manadla/src/mandala.bas) ### File(s) diff --git a/samples/mandelbrot-animator/index.md b/samples/mandelbrot-animator/index.md index df8eec5..a665a2b 100644 --- a/samples/mandelbrot-animator/index.md +++ b/samples/mandelbrot-animator/index.md @@ -14,9 +14,9 @@ Mandelbrot animator. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "mandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/mandelbrot-animator/src/mandel.bas) -* [RUN "mandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-animator/src/mandel.bas) -* [PLAY "mandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-animator/src/mandel.bas) +* [LOAD "mandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/mandelbrot-animator/src/mandel.bas) +* [RUN "mandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-animator/src/mandel.bas) +* [PLAY "mandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-animator/src/mandel.bas) ### File(s) diff --git a/samples/mandelbrot-set-2003/index.md b/samples/mandelbrot-set-2003/index.md index e5b2210..53f7968 100644 --- a/samples/mandelbrot-set-2003/index.md +++ b/samples/mandelbrot-set-2003/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "mandelb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/mandelbrot-set-2003/src/mandelb.bas) -* [RUN "mandelb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-set-2003/src/mandelb.bas) -* [PLAY "mandelb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-set-2003/src/mandelb.bas) +* [LOAD "mandelb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/mandelbrot-set-2003/src/mandelb.bas) +* [RUN "mandelb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-set-2003/src/mandelb.bas) +* [PLAY "mandelb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-set-2003/src/mandelb.bas) ### File(s) diff --git a/samples/mandelbrot-set-2008/index.md b/samples/mandelbrot-set-2008/index.md index 60e85de..4c8deca 100644 --- a/samples/mandelbrot-set-2008/index.md +++ b/samples/mandelbrot-set-2008/index.md @@ -18,9 +18,9 @@ public domain, uses qb64's 2d prototype > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qbguymandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/mandelbrot-set-2008/src/qbguymandel.bas) -* [RUN "qbguymandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-set-2008/src/qbguymandel.bas) -* [PLAY "qbguymandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-set-2008/src/qbguymandel.bas) +* [LOAD "qbguymandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/mandelbrot-set-2008/src/qbguymandel.bas) +* [RUN "qbguymandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-set-2008/src/qbguymandel.bas) +* [PLAY "qbguymandel.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-set-2008/src/qbguymandel.bas) ### File(s) diff --git a/samples/mandelbrot-spiral/img/screenshot.png b/samples/mandelbrot-spiral/img/screenshot.png new file mode 100644 index 0000000..9acceaa Binary files /dev/null and b/samples/mandelbrot-spiral/img/screenshot.png differ diff --git a/samples/mandelbrot-spiral/index.md b/samples/mandelbrot-spiral/index.md new file mode 100644 index 0000000..8717cb4 --- /dev/null +++ b/samples/mandelbrot-spiral/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: MANDELBROT SPIRAL + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 qbguy](../qbguy.md) + +### Description + +```text +Mandelbrot spiral by qbguy. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "mandelbrotspiral.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/mandelbrot-spiral/src/mandelbrotspiral.bas) +* [RUN "mandelbrotspiral.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-spiral/src/mandelbrotspiral.bas) +* [PLAY "mandelbrotspiral.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-spiral/src/mandelbrotspiral.bas) + +### File(s) + +* [mandelbrotspiral.bas](src/mandelbrotspiral.bas) + +🔗 [fractal](../fractal.md), [mandelbrot](../mandelbrot.md) diff --git a/samples/mandelbrot-spiral/src/mandelbrotspiral.bas b/samples/mandelbrot-spiral/src/mandelbrotspiral.bas new file mode 100644 index 0000000..5b74ed9 --- /dev/null +++ b/samples/mandelbrot-spiral/src/mandelbrotspiral.bas @@ -0,0 +1,51 @@ +DECLARE FUNCTION mandel% (ox!, oy!, limit!) +'public domain +Screen 12 +Dim red(15) As Integer, green(15) As Integer, blue(15) As Integer +For i = 0 To 15: Read red(i): Next +For i = 0 To 15: Read green(i): Next +For i = 0 To 15: Read blue(i): Next +For i = 0 To 15: Palette i, 65536 * blue(i) + 256& * green(i) + red(i): Next +Data 0,63,63,63,63,63,47,31,31,47,47,47,55,59,59,63 +Data 0,31,39,47,55,63,63,63,55,47,39,31,31,31,31,31 +Data 0,31,31,31,31,31,31,31,47,63,63,63,63,63,52,42 +real = -.77195: imag = -.116 +incr = .0000025# +For y = 0 To 479 + r = real + For x = 0 To 639 + colour = mandel(r, imag, 256) + If (colour <> 256) Then colour = 1 + colour Mod 15 Else colour = 0 + PSet (x, y), colour + r = r + incr + Next + imag = imag + incr +Next +j = 14 +Do + For i = 0 To 15 + colour = i + j + If colour < 0 Then colour = colour + 15 + If colour > 14 Then colour = colour - 15 + Palette 1 + colour, 65536 * blue(i) + 256& * green(i) + red(i) + Next + j = j - 1 + If j < 0 Then j = j + 15 + T! = Timer + .05 + If T! >= 86400 Then T! = T! - 86400 + Do + If InKey$ = Chr$(27) Then System + Loop While T! > Timer +Loop + +Function mandel% (ox, oy, limit) + x = ox: y = oy + For c% = limit To 1 Step -1 + xx = x * x: yy = y * y + If xx + yy >= 4 Then Exit For + y = x * y * 2 + oy + x = xx - yy + ox + Next + mandel = c% +End Function + diff --git a/samples/mandelbrot-zoomer/index.md b/samples/mandelbrot-zoomer/index.md index cf80447..00de74c 100644 --- a/samples/mandelbrot-zoomer/index.md +++ b/samples/mandelbrot-zoomer/index.md @@ -4,6 +4,10 @@ ![screenshot.png](img/screenshot.png) +### Author + +[🐝 Tor Myklebust](../tor-myklebust.md) + ### Description ```text @@ -60,9 +64,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qbdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/mandelbrot-zoomer/src/qbdemo.bas) -* [RUN "qbdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-zoomer/src/qbdemo.bas) -* [PLAY "qbdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-zoomer/src/qbdemo.bas) +* [LOAD "qbdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/mandelbrot-zoomer/src/qbdemo.bas) +* [RUN "qbdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/mandelbrot-zoomer/src/qbdemo.bas) +* [PLAY "qbdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/mandelbrot-zoomer/src/qbdemo.bas) ### File(s) diff --git a/samples/mandelbrot.md b/samples/mandelbrot.md index eac2562..c66f615 100644 --- a/samples/mandelbrot.md +++ b/samples/mandelbrot.md @@ -20,8 +20,14 @@ Mandelbrot animator. public domain, uses qb64's 2d prototype +**[Mandelbrot Spiral](mandelbrot-spiral/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) + +Mandelbrot spiral by qbguy. + **[Mandelbrot Zoomer](mandelbrot-zoomer/index.md)** -[🐝 *missing*](author-missing.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) +[🐝 Tor Myklebust](tor-myklebust.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) 'QBDEMO (C) 2002 Tor Myklebust 'The fractal zoomer should run at 60FPS on a 500MHz machine. I d... diff --git a/samples/maptriangle-in-3d/index.md b/samples/maptriangle-in-3d/index.md index dfe751a..ebeb058 100644 --- a/samples/maptriangle-in-3d/index.md +++ b/samples/maptriangle-in-3d/index.md @@ -20,9 +20,9 @@ Librarian's Note: The sample given here is just one of a number of _MAPTRIANGLE( > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "maptriangle3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/maptriangle-in-3d/src/maptriangle3d.bas) -* [RUN "maptriangle3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/maptriangle-in-3d/src/maptriangle3d.bas) -* [PLAY "maptriangle3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/maptriangle-in-3d/src/maptriangle3d.bas) +* [LOAD "maptriangle3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/maptriangle-in-3d/src/maptriangle3d.bas) +* [RUN "maptriangle3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/maptriangle-in-3d/src/maptriangle3d.bas) +* [PLAY "maptriangle3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/maptriangle-in-3d/src/maptriangle3d.bas) ### File(s) diff --git a/samples/mario.md b/samples/mario.md new file mode 100644 index 0000000..e9c19a4 --- /dev/null +++ b/samples/mario.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: MARIO + +**[Super Mario Jump](super-mario-jump/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [mario](mario.md) + +Super Mario Jump! diff --git a/samples/math.md b/samples/math.md new file mode 100644 index 0000000..7bb013c --- /dev/null +++ b/samples/math.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: MATH + +**[Dec to Frac](dec-to-frac/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [math](math.md), [dos world](dos-world.md) + +' DEC_FRAC.BAS - Fraction/Decimal conversion functions ' and sample program ' b... diff --git a/samples/matrix-effect/index.md b/samples/matrix-effect/index.md index d50340a..d0e8e2a 100644 --- a/samples/matrix-effect/index.md +++ b/samples/matrix-effect/index.md @@ -18,9 +18,9 @@ If you look close, it spells F-e-l-l-i-p-p-e. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "darkomatrix.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/matrix-effect/src/darkomatrix.bas) -* [RUN "darkomatrix.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/matrix-effect/src/darkomatrix.bas) -* [PLAY "darkomatrix.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/matrix-effect/src/darkomatrix.bas) +* [LOAD "darkomatrix.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/matrix-effect/src/darkomatrix.bas) +* [RUN "darkomatrix.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/matrix-effect/src/darkomatrix.bas) +* [PLAY "darkomatrix.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/matrix-effect/src/darkomatrix.bas) ### File(s) diff --git a/samples/matt-bross.md b/samples/matt-bross.md new file mode 100644 index 0000000..9084054 --- /dev/null +++ b/samples/matt-bross.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 MATT BROSS + +**[Frogger](frogger/index.md)** + +[🐝 Matt Bross](matt-bross.md) 🔗 [game](game.md), [frogger](frogger.md) + +Frogger game by Matt Bross. diff --git a/samples/matthew-river-knight.md b/samples/matthew-river-knight.md new file mode 100644 index 0000000..0741f00 --- /dev/null +++ b/samples/matthew-river-knight.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 MATTHEW RIVER KNIGHT + +**[QB Tank Commander](qb-tank-commander/index.md)** + +[🐝 Matthew River Knight](matthew-river-knight.md) 🔗 [game](game.md), [tank](tank.md) + +'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ' ' ±± ±... diff --git a/samples/maze.md b/samples/maze.md index a2ec31d..65d6db4 100644 --- a/samples/maze.md +++ b/samples/maze.md @@ -2,6 +2,12 @@ ## SAMPLES: MAZE +**[Hunter](hunter/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [maze](maze.md) + +Maze hunter game by Microsoft. + **[Mazes of Misery](mazes-of-misery/index.md)** [🐝 Steve M.](steve-m..md) 🔗 [game](game.md), [maze](maze.md) diff --git a/samples/mazes-of-misery/index.md b/samples/mazes-of-misery/index.md index 3eae213..2d9cbd8 100644 --- a/samples/mazes-of-misery/index.md +++ b/samples/mazes-of-misery/index.md @@ -33,9 +33,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "mzupd2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/mazes-of-misery/src/mzupd2.bas) -* [RUN "mzupd2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/mazes-of-misery/src/mzupd2.bas) -* [PLAY "mzupd2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/mazes-of-misery/src/mzupd2.bas) +* [LOAD "mzupd2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/mazes-of-misery/src/mzupd2.bas) +* [RUN "mzupd2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/mazes-of-misery/src/mzupd2.bas) +* [PLAY "mzupd2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/mazes-of-misery/src/mzupd2.bas) ### File(s) diff --git a/samples/measure.md b/samples/measure.md new file mode 100644 index 0000000..2ac80a3 --- /dev/null +++ b/samples/measure.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: MEASURE + +**[Measure](measure/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [measure](measure.md), [dos world](dos-world.md) + +' MEASURE.BAS - A program for performing measurement conversions ' by Antonio & Alfonso De P... diff --git a/samples/measure/img/screenshot.png b/samples/measure/img/screenshot.png new file mode 100644 index 0000000..8a07579 Binary files /dev/null and b/samples/measure/img/screenshot.png differ diff --git a/samples/measure/index.md b/samples/measure/index.md new file mode 100644 index 0000000..4ee18fd --- /dev/null +++ b/samples/measure/index.md @@ -0,0 +1,63 @@ +[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: MEASURE + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 A&A De Pasquale](../a&a-de-pasquale.md) + +### Description + +```text +' MEASURE.BAS - A program for performing measurement conversions +' by Antonio & Alfonso De Pasquale +' +' Copyright (C) 1993 DOS Resource Guide +' 80 Elm Street +' Peterborough NH 03458 +' Published in Issue #13, January 1994, page 50 +' + +============================================================================== + +------------- + MEASURE.BAS +------------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later. + +WHAT MEASURE.BAS DOES: +This program converts lengths, areas, weights, liquid capacities, and dry +capacities from one unit of measure to another. It includes both English +(U.S.) and metric units. Use it to convert feet to fathoms, ounces to +kilograms, liters to pints, etc. + +USING MEASURE.BAS: +To load the program, type QBASIC MEASURE.BAS (using path names if necessary) +at the DOS prompt. Then run the program by selecting the Start option in +QBasic's Run menu, or press Shift-F5. The screen clears, and a menu appears to +let you choose the type of unit you want to convert: length, area, weight, +liquid capacity, or dry capacity. When you make a selection, a new menu +appears so you may select the units to convert to and from, as well as enter +the value to convert. The answer is displayed immediately, and pressing Enter +readies the program for another conversion. + +For further details on MEASURE.BAS, see "Convert-O-Matic" (DRG #13, January +1994, page 50). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "measure.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/measure/src/measure.bas) +* [RUN "measure.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/measure/src/measure.bas) +* [PLAY "measure.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/measure/src/measure.bas) + +### File(s) + +* [measure.bas](src/measure.bas) + +🔗 [measure](../measure.md), [dos world](../dos-world.md) diff --git a/samples/measure/src/measure.bas b/samples/measure/src/measure.bas new file mode 100644 index 0000000..47a8a42 --- /dev/null +++ b/samples/measure/src/measure.bas @@ -0,0 +1,206 @@ +' MEASURE.BAS - A program for performing measurement conversions +' by Antonio & Alfonso De Pasquale +' +' Copyright (C) 1993 DOS Resource Guide +' 80 Elm Street +' Peterborough NH 03458 +' Published in Issue #13, January 1994, page 50 +' + +DECLARE SUB BOX (r1, c1, r2, c2) +DECLARE SUB CMENU (m$, maxval, v$()) + +FILLARRAYS: + DIM length(10), area(7), weight(10), liquid(10), dry(6) + DIM length$(10), area$(7), weight$(10), liquid$(10), dry$(6) + DIM v$(10) + + FOR x = 1 TO 10: READ length(x): NEXT x + FOR x = 1 TO 7: READ area(x): NEXT x + FOR x = 1 TO 10: READ weight(x): NEXT x + FOR x = 1 TO 10: READ liquid(x): NEXT x + FOR x = 1 TO 6: READ dry(x): NEXT x + FOR x = 1 TO 10: READ length$(x): NEXT x + FOR x = 1 TO 7: READ area$(x): NEXT x + FOR x = 1 TO 10: READ weight$(x): NEXT x + FOR x = 1 TO 10: READ liquid$(x): NEXT x + FOR x = 1 TO 6: READ dry$(x): NEXT x + +MAINMENU: + DO + CLS + BOX 1, 21, 3, 57 + LOCATE 2, 25: PRINT "** Measurement Converter **" + BOX 5, 5, 15, 75 + LOCATE 6, 10: PRINT "Please Select One of the Following:" + LOCATE 8, 10: PRINT "(1) For Length Conversions" + LOCATE 9, 10: PRINT "(2) For Area Conversions" + LOCATE 10, 10: PRINT "(3) For Weight Conversions" + LOCATE 11, 10: PRINT "(4) For Liquid Capacity Conversions" + LOCATE 12, 10: PRINT "(5) For Dry Capacity Conversions" + LOCATE 14, 10: INPUT "Type In Your Selection (or Press ENTER to Quit): ", sel$ + sel = VAL(sel$): IF sel > 0 AND sel < 6 THEN GOSUB CONVERTMENU + LOOP UNTIL sel = 0 + CLS + END + +CONVERTMENU: + DO + GOSUB CLEARSCREEN + BOX 4, 1, 18, 34: BOX 4, 35, 18, 79: BOX 19, 1, 23, 79 + LOCATE 5, 3 + SELECT CASE sel + CASE 1 + m$ = "Length Conversions" + maxval = 10 + FOR x = 1 TO maxval: v$(x) = length$(x): NEXT x + CASE 2 + m$ = "Area Conversions" + maxval = 7 + FOR x = 1 TO maxval: v$(x) = area$(x): NEXT x + CASE 3 + m$ = "Weight Conversions" + maxval = 10 + FOR x = 1 TO maxval: v$(x) = weight$(x): NEXT x + CASE 4 + m$ = "Liquid Capacity Conversions" + maxval = 10 + FOR x = 1 TO maxval: v$(x) = liquid$(x): NEXT x + CASE 5 + m$ = "Dry Capacity Conversions" + maxval = 6 + FOR x = 1 TO maxval: v$(x) = dry$(x): NEXT x + END SELECT + CMENU m$, maxval, v$() + GOSUB ENTRY + LOOP UNTIL unit1 = 0 OR unit2 = 0 OR num = 0 + RETURN + +ENTRY: + GOSUB GETFROM: IF unit1 = 0 THEN RETURN + GOSUB GETTO: IF unit2 = 0 THEN RETURN + GOSUB GETVALUE: IF num = 0 THEN RETURN + GOSUB CONVERTVALUE + RETURN + +GETFROM: + x$ = SPACE$(15) + LOCATE 7, 37: PRINT "Select the unit you wish to convert FROM" + LOCATE 8, 37: INPUT "Selection: ", x$ + x = VAL(x$): IF x < 0 OR x > maxval THEN GOTO GETFROM + unit1 = x + RETURN + +GETTO: + x$ = SPACE$(15) + LOCATE 10, 37: PRINT "Select the unit you wish to convert TO" + LOCATE 11, 37: INPUT "Selection: ", x$ + x = VAL(x$): IF x < 0 OR x > maxval THEN GOTO GETTO + unit2 = x + RETURN + +GETVALUE: + x$ = SPACE$(15) + LOCATE 13, 37: PRINT "Type the value to convert (ENTER cancels)" + LOCATE 14, 37: INPUT "Value: ", x$ + x = VAL(x$): x = INT((x + .005) * 100) / 100 + LOCATE 14, 43: PRINT x; SPACE$(5) + maxval = 99999: IF x < 0 OR x > maxval THEN GOTO GETVALUE + num = x + RETURN + +CONVERTVALUE: + SELECT CASE sel + CASE 1 + cnval = num * length(unit1) / length(unit2) + m1$ = length$(unit1) + m2$ = length$(unit2) + CASE 2 + cnval = num * area(unit1) / area(unit2) + m1$ = area$(unit1) + m2$ = area$(unit2) + CASE 3 + cnval = num * weight(unit1) / weight(unit2) + m1$ = weight$(unit1) + m2$ = weight$(unit2) + CASE 4 + cnval = num * liquid(unit1) / liquid(unit2) + m1$ = liquid$(unit1) + m2$ = liquid$(unit2) + CASE 5 + cnval = num * dry(unit1) / dry(unit2) + m1$ = dry$(unit1) + m2$ = dry$(unit2) + END SELECT + cnval = INT((cnval + .005) * 100) / 100 + LOCATE 20, 5: PRINT USING "###,###.## "; num; + PRINT m1$; " is equal to "; + PRINT USING "###,###.## "; cnval; + PRINT m2$ + LOCATE 22, 25: PRINT "*** Press ENTER to continue ***" + DO UNTIL INKEY$ = CHR$(13): LOOP + RETURN + +CLEARSCREEN: + FOR x = 4 TO 23: LOCATE x, 1: PRINT SPACE$(79): NEXT x + RETURN + +DATASECTION: + DATA .3937, 1, 12, 36, 39.37, 72, 39370, 63360, 71013.24, 190080 + DATA .1550003, 1, 144, 1296, 1550.003, 4014489600, 6272640 + DATA .01543236, 1, 3.086, 15.43236, 437.5, 480, 7000, 5760, 15432.36, 11520000 + DATA 1, 1.333333, 4, 8, 64, 128, 256, 270.51218, 1024, 7660.052 + DATA .0297616, 1, 1.816166, 2, 16, 64 + + DATA "Centimeters", "Inches", "Feet", "Yards", "Meters", "Fathoms" + DATA "Kilometers", "Statute Miles", "Nautical Miles", "Leagues" + + DATA "Square Centimeters", "Square Inches", "Square Feet", "Square Yards" + DATA "Square Meters", "Square Miles", "Acres" + + DATA "Milligrams", "Grains", "Carats", "Grams", "Ounces (Avoirdupois)" + DATA "Ounces (Troy)", "Pounds (Avoirdupois)", "Pounds (Troy)" + DATA "Kilograms", "Tons" + + DATA "Drams", "Teaspoons", "Tablespoons", "Fluid Ounces", "Cups", "Pints" + DATA "Quarts", "Liters", "Gallons", "Cubic Feet" + + DATA "Cubic Inches", "Pints", "Liters", "Quarts", "Pecks", "Bushels" + +SUB BOX (r1, c1, r2, c2) + + LOCATE r1, c1 + PRINT CHR$(218); + FOR x = (c1 + 1) TO (c2 - 1) + PRINT CHR$(196); + NEXT x + PRINT CHR$(191) + + FOR x = (r1 + 1) TO (r2 - 1) + LOCATE x, c1 + PRINT CHR$(179); SPACE$(c2 - c1 - 1); CHR$(179) + NEXT x + + LOCATE r2, c1 + PRINT CHR$(192); + FOR x = (c1 + 1) TO (c2 - 1) + PRINT CHR$(196); + NEXT x + PRINT CHR$(217) + +END SUB + +SUB CMENU (m$, maxval, v$()) + + vpos = 7 + LOCATE 5, 4 + PRINT m$ + FOR x = 1 TO maxval + LOCATE vpos, 4 + PRINT USING "(##) - "; x; + PRINT v$(x) + vpos = vpos + 1 + NEXT x + +END SUB + diff --git a/samples/michael-fogleman.md b/samples/michael-fogleman.md new file mode 100644 index 0000000..7ab0178 --- /dev/null +++ b/samples/michael-fogleman.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 MICHAEL FOGLEMAN + +**[Future Blocks](future-blocks/index.md)** + +[🐝 Michael Fogleman](michael-fogleman.md) 🔗 [game](game.md), [tetris](tetris.md) + +Tetris clone by Michael Fogleman. diff --git a/samples/microsoft.md b/samples/microsoft.md index 046f639..d0ec973 100644 --- a/samples/microsoft.md +++ b/samples/microsoft.md @@ -8,24 +8,36 @@ A turn-based artillery game by Microsoft. +**[Gorillas](gorillas/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [artillery](artillery.md) + +Gorilla-based artillery game by Microsoft. + +**[Hunter](hunter/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [maze](maze.md) + +Maze hunter game by Microsoft. + **[Money](money/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) Money manager by Microsoft. +**[MS Phone](ms-phone/index.md)** + +[🐝 Microsoft](microsoft.md) 🔗 [data management](data-management.md) + +Simple phone directory 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) diff --git a/samples/minecraft.md b/samples/minecraft.md new file mode 100644 index 0000000..aeadb2d --- /dev/null +++ b/samples/minecraft.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: MINECRAFT + +**[MyCraft](mycraft/index.md)** + +[🐝 Galleon](galleon.md) 🔗 [game](game.md), [minecraft](minecraft.md) + +Progress toward a Minecraft clone. diff --git a/samples/mini-clock/index.md b/samples/mini-clock/index.md index 3d51920..b1ceac9 100644 --- a/samples/mini-clock/index.md +++ b/samples/mini-clock/index.md @@ -22,9 +22,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "mclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/mini-clock/src/mclock.bas) -* [RUN "mclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/mini-clock/src/mclock.bas) -* [PLAY "mclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/mini-clock/src/mclock.bas) +* [LOAD "mclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/mini-clock/src/mclock.bas) +* [RUN "mclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/mini-clock/src/mclock.bas) +* [PLAY "mclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/mini-clock/src/mclock.bas) ### File(s) diff --git a/samples/money.md b/samples/money.md new file mode 100644 index 0000000..9e15559 --- /dev/null +++ b/samples/money.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: MONEY + +**[Stock Watcher](stock-watcher/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [money](money.md), [stocks](stocks.md) + +Stock Watcher program. diff --git a/samples/ms-phone/img/screenshot.png b/samples/ms-phone/img/screenshot.png new file mode 100644 index 0000000..564bfef Binary files /dev/null and b/samples/ms-phone/img/screenshot.png differ diff --git a/samples/ms-phone/index.md b/samples/ms-phone/index.md new file mode 100644 index 0000000..84ef94d --- /dev/null +++ b/samples/ms-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: MS 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/ms-phone/src/phone.bas b/samples/ms-phone/src/phone.bas new file mode 100644 index 0000000..ca8fd67 --- /dev/null +++ b/samples/ms-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/ms-phone/src/phone.zip b/samples/ms-phone/src/phone.zip new file mode 100644 index 0000000..323366f Binary files /dev/null and b/samples/ms-phone/src/phone.zip differ diff --git a/samples/multi-mill/index.md b/samples/multi-mill/index.md index c833d68..1c8e993 100644 --- a/samples/multi-mill/index.md +++ b/samples/multi-mill/index.md @@ -6,7 +6,7 @@ ### Author -[🐝 RhoSigma](../rhosigma.md) +[🐝 Rho Sigma](../rho-sigma.md) ### Description @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "multimill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/multi-mill/src/multimill.bas) -* [RUN "multimill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/multi-mill/src/multimill.bas) -* [PLAY "multimill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/multi-mill/src/multimill.bas) +* [LOAD "multimill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/multi-mill/src/multimill.bas) +* [RUN "multimill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/multi-mill/src/multimill.bas) +* [PLAY "multimill.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/multi-mill/src/multimill.bas) ### File(s) diff --git a/samples/mycraft/img/screenshot.png b/samples/mycraft/img/screenshot.png new file mode 100644 index 0000000..a6d8ca6 Binary files /dev/null and b/samples/mycraft/img/screenshot.png differ diff --git a/samples/mycraft/index.md b/samples/mycraft/index.md new file mode 100644 index 0000000..cd7f574 --- /dev/null +++ b/samples/mycraft/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: MYCRAFT + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Galleon](../galleon.md) + +### Description + +```text +Progress toward a Minecraft clone. +``` + +### File(s) + +* [mycraft_0_001.bas](src/mycraft_0_001.bas) +* [mycraft_0_001.zip](src/mycraft_0_001.zip) + +🔗 [game](../game.md), [minecraft](../minecraft.md) diff --git a/samples/mycraft/src/mycraft_0_001.bas b/samples/mycraft/src/mycraft_0_001.bas new file mode 100644 index 0000000..15c7853 --- /dev/null +++ b/samples/mycraft/src/mycraft_0_001.bas @@ -0,0 +1,1433 @@ +CONST MaxVis& = 15 'how many squares away you can see (warning: massive performance implications at this stage) +CONST HardwareOnly& = 1 'set to 1 to disable the software "SCREEN" (you will lose PRINTed debugging output but will get performance gains) + +IF _DIREXISTS("mycraft") THEN CHDIR "mycraft" +IF _DIREXISTS("blocks") = 0 OR _DIREXISTS("items") = 0 THEN + PRINT "Could not locate resource files" + END +END IF + +DEFLNG A-Z +$RESIZE:ON +'$DYNAMIC + +SCREEN _NEWIMAGE(1024, 600, 32) + +'Generate Perlin Noise +'Modified from http://forum.qbasicnews.com/index.php?action=printpage;topic=3459.0 +'-generates noise from 0 to 255 +'-doesn't use x=0,y=0 +'-noise tiles +DEFSNG A-Z +Iter = 8 +BumpFactor = 1.2 +CloudWidth% = 2 ^ Iter + 1 +CloudHeight% = 2 ^ Iter + 1 + +DIM Cloud%(CloudWidth%, CloudHeight%) +DIM CloudBumpFactor(CloudWidth%, CloudHeight%) AS SINGLE +'1.5=undulating hills (mostly walkable, quite bumpy) +'2.0=ultra-flat +DIM CloudDirectionBias(CloudWidth%, CloudHeight%) AS SINGLE '-0.3 to 0.3 +FOR x = 0 TO CloudWidth% + FOR y = 0 TO CloudHeight% + '1.3=perfect mountains + '1.5=plains + CloudBumpFactor(x, y) = 1.3 '1.4 '+ x * 0.002 '1.2 + x + NEXT +NEXT +FOR x = 0 TO CloudWidth% + FOR y = 0 TO CloudHeight% + CloudDirectionBias(x, y) = 0 '0.3 'x * 0.0008 '1.1 + x * 0.004 '1.2 + x + NEXT +NEXT +RANDOMIZE TIMER +T0 = TIMER +' Init the corners +Cloud%(1, 1) = 128 +Cloud%(1, CloudHeight%) = 128 +Cloud%(CloudWidth%, 1) = 128 +Cloud%(CloudWidth%, CloudHeight%) = 128 + +' Init the edges +FOR Rank% = 1 TO Iter + + dx = 2 ^ (Iter - Rank% + 1) + dy = 2 ^ (Iter - Rank% + 1) + Nx% = 2 ^ (Rank% - 1) + 1 + Ny% = 2 ^ (Rank% - 1) + 1 + + FOR kx = 1 TO Nx% - 1 + x% = (kx - 1) * dx + 1: y% = 1 + Alt% = (Cloud%(x%, y%) + Cloud%(x% + dx, y%)) / 2 + + ' zNew% = Bump%(Alt%, Rank%, BumpFactor) + zNew% = Bump%(Alt%, Rank%, CloudBumpFactor(x% + dx / 2, 1), CloudDirectionBias(x% + dx / 2, 1)) + + Cloud%(x% + dx / 2, 1) = zNew% + Cloud%(x% + dx / 2, CloudHeight%) = zNew% + NEXT kx + + FOR ky = 1 TO Ny% - 1 + x% = 1: y% = (ky - 1) * dy + 1 + Alt% = (Cloud%(x%, y%) + Cloud%(x%, y% + dy)) / 2 + ' zNew% = Bump%(Alt%, Rank%, BumpFactor) + zNew% = Bump%(Alt%, Rank%, CloudBumpFactor(1, y% + dy / 2), CloudDirectionBias(1, y% + dy / 2)) + + + Cloud%(1, y% + dy / 2) = zNew% + Cloud%(CloudWidth%, y% + dy / 2) = zNew% + NEXT ky + +NEXT Rank% + + +' Fill the clouds +FOR Rank% = 1 TO Iter + + dx = 2 ^ (Iter - Rank% + 1): dy = dx + Nx% = 2 ^ (Rank% - 1) + 1: Ny% = Nx% + + FOR kx = 1 TO Nx% - 1 + FOR ky = 1 TO Ny% - 1 + x% = (kx - 1) * dx + 1 + y% = (ky - 1) * dy + 1 + + Alt% = (Cloud%(x%, y%) + Cloud%(x% + dx, y%) + Cloud%(x%, y% + dy) + Cloud%(x% + dx, y% + dy)) / 4 + Cloud%(x% + dx / 2, y% + dy / 2) = Bump%(Alt%, Rank%, CloudBumpFactor(x% + dx / 2, y% + dy / 2), CloudDirectionBias(x% + dx / 2, y% + dy / 2)) + Alt% = (Cloud%(x%, y%) + Cloud%(x% + dx, y%)) / 2 + IF y% <> 1 THEN Cloud%(x% + dx / 2, y%) = Bump%(Alt%, Rank%, CloudBumpFactor(x% + dx / 2, y%), CloudDirectionBias(x% + dx / 2, y%)) + Alt% = (Cloud%(x%, y%) + Cloud%(x%, y% + dy)) / 2 + IF x% <> 1 THEN Cloud%(x%, y% + dy / 2) = Bump%(Alt%, Rank%, CloudBumpFactor(x%, y% + dy / 2), CloudDirectionBias(x%, y% + dy / 2)) + Alt% = (Cloud%(x% + dx, y%) + Cloud%(x% + dx, y% + dy)) / 2 + IF (x% + dx) <> CloudWidth% THEN Cloud%(x% + dx, y% + dy / 2) = Bump%(Alt%, Rank%, CloudBumpFactor(x% + dx, y% + dy / 2), CloudDirectionBias(x% + dx, y% + dy / 2)) + Alt% = (Cloud%(x%, y% + dy) + Cloud%(x% + dx, y% + dy)) / 2 + IF (y% + dy) <> CloudHeight% THEN Cloud%(x% + dx / 2, y% + dy) = Bump%(Alt%, Rank%, CloudBumpFactor(x% + dx / 2, y% + dy), CloudDirectionBias(x% + dx / 2, y% + dy)) + + NEXT ky + NEXT kx + +NEXT Rank% +dt = TIMER - T0 +FOR x = 0 TO CloudWidth% + FOR y = 0 TO CloudHeight% + PSET (x, y), _RGB(Cloud%(x, y), 0, 0) + NEXT +NEXT + +DEFLNG A-Z + +DIM SHARED MapLimitX AS LONG, MapLimitY AS LONG, MapLimitZ AS LONG +MapLimitX = CloudWidth% - 1: MapLimitY = CloudHeight% - 1: MapLimitZ = 100 + + + + +DIM SHARED TexLast +TexLast = 0 +DIM SHARED Tex(1000, 15, 3) AS LONG 'handle, brightness, hue-specific to time of day + +DIM SHARED darken +darken = _NEWIMAGE(1, 1) +_DEST darken +_DONTBLEND +PSET (0, 0), _RGBA(0, 0, 0, 50) +_BLEND +_DEST 0 + + +_MOUSEHIDE + + +DIM PX AS SINGLE +DIM PY AS SINGLE +DIM PZ AS SINGLE + +DIM oPX AS SINGLE +DIM oPY AS SINGLE +DIM oPZ AS SINGLE + +PZ = 70 + + +'TYPE BoxType +' left AS LONG +' right AS LONG +' top AS LONG +' bottom AS LONG +' front AS LONG +' back AS LONG +'END TYPE + +'DIM SHARED Box(1000) AS BoxType + +'load textures +grass = LoadTexture("grass") +water = LoadTexture("water") + +'I = 0 +'I = I + 1 + +'h = grass +'Box(I).left = h +'Box(I).right = h +'Box(I).top = h +'Box(I).bottom = h +'Box(I).front = h +'Box(I).back = h + + + +TYPE MapBlockType + Typ AS LONG '0=air, 1=... + Vis AS LONG + Lit AS LONG 'light offset +END TYPE + +DIM Blk(-1 TO MapLimitX + 1, -1 TO MapLimitY + 1, -1 TO MapLimitZ + 1) AS MapBlockType + + +'place bottom layer (a single layer of "rock" which cannot be crossed) +z = 0 +FOR x = 0 TO MapLimitX + FOR y = 0 TO MapLimitY + Blk(x, y, z).Typ = 1: boxcount = boxcount + 1 + NEXT +NEXT + + +DIM GM(-1 TO MapLimitX + 1, -1 TO MapLimitY + 1) +'get GM +FOR x = 0 TO MapLimitX + FOR y = 0 TO MapLimitY + h = Cloud%(x + 1, y + 1) \ 4 + 30 + GM(x, y) = h + NEXT +NEXT + +FOR f = 5 TO 8 + 'despeckle "pinacles" + FOR x = 0 TO MapLimitX + FOR y = 0 TO MapLimitY + h = GM(x, y) + c = 0 + c2 = 0 + FOR x2 = x - 1 TO x + 1 + FOR y2 = y - 1 TO y + 1 + IF x2 <> x OR y2 <> y THEN + h2 = GM(x2, y2) + IF h2 < h THEN c = c + 1 + IF h2 > h THEN c2 = c2 + 1 + END IF + NEXT + NEXT + IF c >= 5 THEN + GM(x, y) = GM(x, y) - 1 + 'END + 'GM(x, y) = 2 + END IF + IF c2 >= 5 THEN + GM(x, y) = GM(x, y) + 1 + END IF + + NEXT + NEXT +NEXT + +wl = 128 \ 4 + 30 - 3 + +'place "dirt" +FOR x = 0 TO MapLimitX + FOR y = 0 TO MapLimitY + zz = GM(x, y) + FOR z = zz TO 1 STEP -1 + Blk(x, y, z).Typ = 1 + NEXT + NEXT +NEXT + +'place water + + +FOR x = 0 TO MapLimitX + FOR y = 0 TO MapLimitY + zz = GM(x, y) + IF zz < wl THEN + Blk(x, y, wl).Typ = 2 + END IF + NEXT +NEXT + + +IF 1 = 0 THEN + zrange = 10 + FOR basez = 1 TO MapLimitZ - zrange - 50 + FOR I = 1 TO (MapLimitX * MapLimitY) * 10 + + x = INT(RND * (MapLimitX + 1)) + y = INT(RND * (MapLimitY + 1)) + z = basez + INT(RND * (10)) 'cannot replace lowest layer + + ''' IF Blk(x, y, z).Typ = 0 AND Blk(x, y, z - 1).Typ <> 0 THEN + n = 0 + FOR z2 = z - 1 TO z + 1 + FOR y2 = y - 1 TO y + 1 + FOR x2 = x - 1 TO x + 1 + dist = ABS(x2 - x) + ABS(y2 - y) + ABS(z2 - z) + IF dist <= 2 THEN + + x3 = x2: y3 = y2: z3 = z2 + MapOffset x3, y3, z3 + IF Blk(x3, y3, z3).Typ > 0 THEN + n = n + 1 + END IF + + END IF + NEXT + NEXT + NEXT + + IF n >= 3 THEN + Blk(x, y, z).Typ = 1: boxcount = boxcount + 1 + IF z > highestz THEN highestz = z + END IF + + + '''END IF + NEXT + NEXT 'basez + 'fill map till top reached + +END IF + + +'assess visibility + +FOR z = 0 TO MapLimitZ + FOR x = 0 TO MapLimitX + FOR y = 0 TO MapLimitY + IF Blk(x, y, z).Typ THEN + visible = 0 + FOR x2 = x - 1 TO x + 1 + IF Blk(x2, y, z).Typ <> 1 THEN visible = 1 + NEXT + + FOR y2 = y - 1 TO y + 1 + IF Blk(x, y2, z).Typ <> 1 THEN visible = 1 + NEXT + FOR z2 = z - 1 TO z + 1 + IF Blk(x, y, z2).Typ <> 1 THEN visible = 1 + NEXT + + IF visible = 1 THEN + Blk(x, y, z).Vis = 1: viscount = viscount + 1 + END IF + END IF + NEXT + NEXT +NEXT + +'assess lighting offsets +FOR z = 0 TO MapLimitZ + FOR x = 0 TO MapLimitX + FOR y = 0 TO MapLimitY + IF Blk(x, y, z).Vis THEN 'it is visible + count = 0 + FOR z2 = z + 1 TO z + 5 + FOR y2 = y - 1 TO y + 1 + FOR x2 = x - 1 TO x + 1 + IF Blk(x2, y2, z2).Typ <> 0 THEN count = count + 1 + NEXT + NEXT + NEXT + IF count > 30 THEN count = 30 + Blk(x, y, z).Lit = -count / 2 + + END IF + NEXT + NEXT +NEXT + + + + +DIM SHARED ax AS SINGLE, ay AS SINGLE +DIM SHARED SINax AS SINGLE +DIM SHARED COSax AS SINGLE +DIM SHARED SINay AS SINGLE +DIM SHARED COSay AS SINGLE + + +TYPE Point3D + x AS SINGLE + y AS SINGLE + z AS SINGLE +END TYPE + +TYPE TexturePoint3D + p AS Point3D + tx AS SINGLE + ty AS SINGLE +END TYPE + + +TYPE Triangle3D + p1 AS TexturePoint3D + p2 AS TexturePoint3D + p3 AS TexturePoint3D + textureHandle AS LONG +END TYPE + +TYPE Rect3D + p1 AS TexturePoint3D + p2 AS TexturePoint3D + p3 AS TexturePoint3D + p4 AS TexturePoint3D + textureHandle AS LONG +END TYPE + +DIM SHARED vert(1 TO 8) AS Point3D +DIM SHARED side(1 TO 6) AS Rect3D + + + + + + + +zz = -10 + +IF HardwareOnly THEN + _DISPLAYORDER _HARDWARE + bgImage = _NEWIMAGE(1, 1, 32) + _DEST bgImage + PSET (0, 0), _RGB(180, 220, 255) + _DEST 0 + bgImage = _COPYIMAGE(bgImage, 33) +END IF + +DIM SHARED ETT AS DOUBLE +ETT = TIMER(0.001) +DIM SHARED ET AS SINGLE + +DIM SHARED TOD AS SINGLE +TOD = 0 + +'gun32 = _LOADIMAGE("items\gun1.png", 32) +gun32 = _LOADIMAGE("items\sworddiamond.png", 32) +gun = _COPYIMAGE(gun32, 33) + +'sets of vertexes for scaling/rotation/etc + + +DIM SHARED VertexSource AS LONG +DIM SHARED VertexCount AS LONG 'the number of vertices to apply an operation to +DIM SHARED VertexLast AS LONG +VertexLast = 0 +DIM SHARED VertexX(1 TO 10000) AS SINGLE +DIM SHARED VertexY(1 TO 10000) AS SINGLE +DIM SHARED VertexZ(1 TO 10000) AS SINGLE +DIM SHARED VertexTX(1 TO 10000) AS SINGLE +DIM SHARED VertexTY(1 TO 10000) AS SINGLE + +DIM SHARED TriangleSource AS LONG 'the base index of the first triangle's vertex + +DIM SHARED TriangleLast AS LONG +TriangleLast = 0 +DIM SHARED TriangleCount AS LONG 'the number of triangles to apply an operation to +DIM SHARED TriangleVertex(1 TO 10000) AS LONG + +TYPE MODEL + VertexCount AS LONG + FirstVertex AS LONG + FirstTriangle AS LONG + TriangleCount AS LONG +END TYPE +DIM SHARED Model(1 TO 10000) AS MODEL + + + +'add object +tex = gun +tx = _WIDTH(tex) +ty = _HEIGHT(tex) +p = VertexLast +t = TriangleLast +d = 1 + + + + +'convert 2D image into a 3D object by giving it depth + +'place image onto a canvas which has an extra unit on each size +tex = gun32 +w = _WIDTH(tex) +h = _HEIGHT(tex) +I = _NEWIMAGE(w + 2, h + 2, 32) +_DONTBLEND I +_PUTIMAGE (1, 1), tex, I + +_SOURCE I +_DEST I +DIM col AS LONG +FOR y = 1 TO h + FOR x = 1 TO w + col = POINT(x, y) + alpha = _ALPHA(col) + + col2 = POINT(x, y - 1) + alpha2 = _ALPHA(col2) + + IF alpha2 = 0 AND alpha <> 0 THEN + + + x1 = x - 1 + y1 = y - 1 + + + + + bp = p + + t = t + 1: TriangleVertex(t) = bp + 1 + t = t + 1: TriangleVertex(t) = bp + 2 + t = t + 1: TriangleVertex(t) = bp + 3 + t = t + 1: TriangleVertex(t) = bp + 1 + t = t + 1: TriangleVertex(t) = bp + 3 + t = t + 1: TriangleVertex(t) = bp + 4 + + p = p + 1: VertexX(p) = x1: VertexY(p) = -y1: VertexZ(p) = 0 + VertexTX(p) = x1: VertexTY(p) = y1 + p = p + 1: VertexX(p) = x1 + 1: VertexY(p) = -y1: VertexZ(p) = 0 + VertexTX(p) = x1: VertexTY(p) = y1 + p = p + 1: VertexX(p) = x1 + 1: VertexY(p) = -y1: VertexZ(p) = d + VertexTX(p) = x1: VertexTY(p) = y1 + p = p + 1: VertexX(p) = x1: VertexY(p) = -y1: VertexZ(p) = d + VertexTX(p) = x1: VertexTY(p) = y1 + + + END IF + + + + col2 = POINT(x - 1, y) + alpha2 = _ALPHA(col2) + + IF alpha2 = 0 AND alpha <> 0 THEN + + x1 = x - 1 + y1 = y - 1 + + + + + bp = p + + t = t + 1: TriangleVertex(t) = bp + 1 + t = t + 1: TriangleVertex(t) = bp + 2 + t = t + 1: TriangleVertex(t) = bp + 3 + t = t + 1: TriangleVertex(t) = bp + 1 + t = t + 1: TriangleVertex(t) = bp + 3 + t = t + 1: TriangleVertex(t) = bp + 4 + + p = p + 1: VertexX(p) = x1: VertexY(p) = -y1: VertexZ(p) = 0 + VertexTX(p) = x1: VertexTY(p) = y1 + p = p + 1: VertexX(p) = x1: VertexY(p) = -y1: VertexZ(p) = d + VertexTX(p) = x1: VertexTY(p) = y1 + p = p + 1: VertexX(p) = x1: VertexY(p) = -y1 - 1: VertexZ(p) = d + VertexTX(p) = x1: VertexTY(p) = y1 + p = p + 1: VertexX(p) = x1: VertexY(p) = -y1 - 1: VertexZ(p) = 0 + VertexTX(p) = x1: VertexTY(p) = y1 + + END IF + + + + + + + + + + + + + + + NEXT +NEXT + +_SOURCE 0 +_DEST 0 + +itemPicture = I + + + + + + + + +FOR oz = 0 TO d STEP d + bp = p + + t = t + 1: TriangleVertex(t) = bp + 1 + t = t + 1: TriangleVertex(t) = bp + 2 + t = t + 1: TriangleVertex(t) = bp + 3 + t = t + 1: TriangleVertex(t) = bp + 1 + t = t + 1: TriangleVertex(t) = bp + 3 + t = t + 1: TriangleVertex(t) = bp + 4 + + p = p + 1: VertexX(p) = 0: VertexY(p) = 0: VertexZ(p) = oz + VertexTX(p) = -0.49: VertexTY(p) = -0.49 + p = p + 1: VertexX(p) = tx: VertexY(p) = 0: VertexZ(p) = oz + VertexTX(p) = tx - 1 + 0.49: VertexTY(p) = -0.49 + p = p + 1: VertexX(p) = tx: VertexY(p) = -ty: VertexZ(p) = oz + VertexTX(p) = tx - 1 + 0.49: VertexTY(p) = ty - 1 + 0.49 + p = p + 1: VertexX(p) = 0: VertexY(p) = -ty: VertexZ(p) = oz + VertexTX(p) = -0.49: VertexTY(p) = ty - 1 + 0.49 + + +NEXT + + +VertexCount = p - VertexLast +TriangleCount = (t - TriangleLast) \ 3 + + +m = 1 +Model(m).VertexCount = VertexCount +Model(m).FirstVertex = VertexLast + 1 +Model(m).TriangleCount = TriangleCount +Model(m).FirstTriangle = TriangleLast + 1 + +VertexLast = p +TriangleLast = t + + + +DO + + T# = TIMER(0.001) + ET = T# - ETT + ETT = T# + + TOD = TOD + ET + IF TOD >= 24 THEN TOD = TOD - 24 + + SINax = SIN(ax) + COSax = COS(ax) + SINay = SIN(ay) + COSay = COS(ay) + + + + IF HardwareOnly THEN + _PUTIMAGE (0, 0)-(_WIDTH - 1, _HEIGHT - 1), bgImage + ELSE + CLS , _RGB(180, 220, 255) + END IF + + + + + LOCATE 1, 1 + PRINT TOD + + PRINT boxcount, viscount + + PRINT zz + + + + + RANDOMIZE TIMER 'USING 1 + + + OX = INT(PX) + OY = INT(PY) + oz = INT(PZ) + + PRINT PX, PY, PZ + PRINT OX, OY, oz + + + x = OX + y = OY + z = oz + MapOffset x, y, z + PRINT x, y, z, "!" + + _PUTIMAGE (0, 0), itemPicture + + nn = 0 + + + + 'opaque pass + FOR mapz = oz + MaxVis TO oz - MaxVis STEP -1 + FOR mapx = OX - MaxVis TO OX + MaxVis + FOR mapy = OY - MaxVis TO OY + MaxVis + x = mapx + y = mapy + z = mapz + MapOffset x, y, z + IF Blk(x, y, z).Vis THEN + typ = Blk(x, y, z).Typ + IF typ = 1 THEN + DrawCube mapx - PX, mapz - PZ, mapy - PY, typ, Blk(x, y, z).Lit + END IF + END IF + NEXT + NEXT + NEXT + + 'semi-tranparent pass + '_DEPTHBUFFER LOCK + FOR mapz = oz - MaxVis TO oz + MaxVis + FOR mapx = OX - MaxVis TO OX + MaxVis + FOR mapy = OY - MaxVis TO OY + MaxVis + x = mapx + y = mapy + z = mapz + MapOffset x, y, z + IF Blk(x, y, z).Vis THEN + typ = Blk(x, y, z).Typ + IF typ = 2 THEN + DrawCube mapx - PX, mapz - PZ, mapy - PY, typ, Blk(x, y, z).Lit + END IF + END IF + NEXT + NEXT + NEXT + + + + 'draw object(s) + + 'preserve offsets of permanent content + oldVertexLast = VertexLast + oldTriangleLast = TriangleLast + + VertexSource = Model(1).FirstVertex + TriangleSource = Model(1).FirstTriangle + TriangleCount = Model(1).TriangleCount + VertexCount = Model(1).VertexCount + + + TriangleSource = TriangleLast + 1 + VertexSource = VertexLast + 1 + CopyModel (1) + + tex = gun + + 'orient pointing forwards + VertexRotateXZ_YZ -90, 0 + 'scale + VertexScale 0.1 * 0.7 * 2 + 'move to right hand + VertexTranslate 1, 0, -2 - 0.5 + + 'render the objects + _DEPTHBUFFER _CLEAR + _DEPTHBUFFER ON + + FOR t = TriangleSource TO TriangleSource + TriangleCount * 3 - 3 STEP 3 + p1 = TriangleVertex(t) + p2 = TriangleVertex(t + 1) + p3 = TriangleVertex(t + 2) +_maptriangle( VertexTX(p1), VertexTY(p1))-( VertexTX(p2), VertexTY(p2))-( VertexTX(p3), VertexTY(p3)), _ +tex to _ +(VertexX(p1),Vertexy(p1),Vertexz(p1))-(VertexX(p2),Vertexy(p2),Vertexz(p2))-(VertexX(p3),Vertexy(p3),Vertexz(p3)) + + NEXT + + + + + + + + + + + + + + + + 'move vertically + ms! = .1 + IF _KEYDOWN(ASC("q")) THEN PZ = PZ + ms! * 4 + IF _KEYDOWN(ASC("z")) THEN PZ = PZ - ms! * 4 + + oPX = PX: oPY = PY: oPZ = PZ + + DO + k$ = INKEY$ + IF k$ = " " THEN 'jump (teleport up 2 squares) + PZ = PZ + 2 + END IF + LOOP UNTIL k$ = "" + + IF _KEYDOWN(ASC("w")) THEN 'walk forwards + PX = PX + SIN(ax) * ms! + PY = PY - COS(ax) * ms! + 'PZ = PZ + SIN(ay) * ms! + END IF + + + IF _KEYDOWN(ASC("s")) THEN 'walk backwards + PX = PX - SIN(ax) * ms! + PY = PY + COS(ax) * ms! + 'PZ = PZ - SIN(ay) * ms! + END IF + + + + PZ = PZ - 1 * ms! + + x = INT(PX) + y = INT(PY) + z = INT(PZ) + MapOffset x, y, z + t = Blk(x, y, z).Typ + IF t = 1 THEN + ' PX = oPX + ' PY = oPY + ' PZ = oPZ + END IF + + + 'calculate x/y/z dist to adjacent blocks + + 'check z movement + + + + newpx! = PX + newpy! = PY + newpz! = PZ + + + PX = oPX + PY = oPY + PZ = newpz! + + x = INT(PX) + y = INT(PY) + z = INT(PZ) + + ox! = PX - INT(PX) + oy! = PY - INT(PY) + oz! = PZ - INT(PZ) + + ' IF PX >= 0 THEN + dx1! = ox! + dx2! = 1 - ox! + ' ELSE + ' dx2! = ox! + ' dx1! = 1 - ox! + ' END IF + + ' IF PY >= 0 THEN + dy1! = oy! + dy2! = 1 - oy! + ' ELSE + ' dy2! = oy! + ' dy1! = 1 - oy! + 'END IF + + ' IF PZ >= 0 THEN + dz1! = oz! + dz2! = 1 - oz! + ' ELSE + ' dz2! = oz! + ' dz1! = 1 - oz! + 'END IF + + + + 'PRINT + 'PRINT PX; PY; PZ + 'PRINT dx1!; dx2!; dy1!; dy2!; dz1!; dz2!; + 'PRINT + + FOR z2 = z - 1 TO z + 1 + + relevant = 0 + IF z2 = z THEN relevant = 0 'if we are already in the square--too bad! + + 'IF z2 <> z THEN + 'check z relevance + ' relvant = 0 + IF z2 < z AND dz1! < 0.4 THEN relevant = 1 + IF z2 > z AND dz2! < 0.4 THEN relevant = 1 + IF relevant THEN PRINT z2 + + IF relevant THEN + + + FOR y2 = y - 1 TO y + 1 + FOR x2 = x - 1 TO x + 1 + + dx = ABS(x2 - x) + dy = ABS(y2 - y) + relevant = 0 + IF dx + dy THEN + 'check if location should be checked + dx! = 0 + IF x2 > x THEN dx! = dx2! + IF x2 < x THEN dx! = dx1! + dy! = 0 + IF y2 > y THEN dy! = dy2! + IF y2 < y THEN dy! = dy1! + IF dx! < 0.4 AND dy! < 0.4 THEN + relevant = 1 + PRINT "["; x2 - x; ","; y2 - y; "]"; + END IF + ELSE + relevant = 1 + END IF + 'END IF + + IF relevant THEN + x3 = x2: y3 = y2: z3 = z2 + MapOffset x3, y3, z3 + t2 = Blk(x3, y3, z3).Typ + IF t2 = 1 THEN + 'PZ = oPZ + newpz! = oPZ + + END IF + END IF + NEXT + NEXT + + END IF + NEXT + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + PX = newpx! + PY = oPY + PZ = newpz! + + + x = INT(PX) + y = INT(PY) + z = INT(PZ) + + ox! = PX - INT(PX) + oy! = PY - INT(PY) + oz! = PZ - INT(PZ) + + ' IF PX >= 0 THEN + dx1! = ox! + dx2! = 1 - ox! + ' ELSE + ' dx2! = ox! + ' dx1! = 1 - ox! + ' END IF + + ' IF PY >= 0 THEN + dy1! = oy! + dy2! = 1 - oy! + ' ELSE + ' dy2! = oy! + ' dy1! = 1 - oy! + 'END IF + + ' IF PZ >= 0 THEN + dz1! = oz! + dz2! = 1 - oz! + ' ELSE + ' dz2! = oz! + ' dz1! = 1 - oz! + 'END IF + + + z2 = z + + FOR x2 = x - 1 TO x + 1 + relevant = 0 + IF x2 < x AND dx1! < 0.4 THEN relevant = 1 + IF x2 > x AND dx2! < 0.4 THEN relevant = 1 + IF relevant THEN + + + FOR y2 = y - 1 TO y + 1 + FOR z2 = z - 1 TO z + 1 + + dy = ABS(y2 - y) + dz = ABS(z2 - z) + + relevant = 0 + + IF dy + dz THEN + 'check if location should be checked + + dz! = 0 + IF z2 > z THEN dz! = dz2! + IF z2 < z THEN dz! = dz1! + + dy! = 0 + IF y2 > y THEN dy! = dy2! + IF y2 < y THEN dy! = dy1! + + IF dy! < 0.4 AND dz! < 0.4 THEN + relevant = 1 + END IF + + + ELSE + relevant = 1 + END IF + + IF relevant THEN + x3 = x2: y3 = y2: z3 = z2 + MapOffset x3, y3, z3 + t2 = Blk(x3, y3, z3).Typ + IF t2 = 1 THEN + 'PX = oPX + newpx! = oPX + + END IF + END IF + NEXT + NEXT + END IF + NEXT + + + + PX = newpx! + PY = newpy! + PZ = newpz! + + x = INT(PX) + y = INT(PY) + z = INT(PZ) + + ox! = PX - INT(PX) + oy! = PY - INT(PY) + oz! = PZ - INT(PZ) + + ' IF PX >= 0 THEN + dx1! = ox! + dx2! = 1 - ox! + ' ELSE + ' dx2! = ox! + ' dx1! = 1 - ox! + ' END IF + + ' IF PY >= 0 THEN + dy1! = oy! + dy2! = 1 - oy! + ' ELSE + ' dy2! = oy! + ' dy1! = 1 - oy! + 'END IF + + ' IF PZ >= 0 THEN + dz1! = oz! + dz2! = 1 - oz! + ' ELSE + ' dz2! = oz! + ' dz1! = 1 - oz! + 'END IF + + + z2 = z + + FOR y2 = y - 1 TO y + 1 + relevant = 0 + IF y2 < y AND dy1! < 0.4 THEN relevant = 1 + IF y2 > y AND dy2! < 0.4 THEN relevant = 1 + IF relevant THEN + + FOR z2 = z - 1 TO z + 1 + + FOR x2 = x - 1 TO x + 1 + + dx = ABS(x2 - x) + dz = ABS(z2 - z) + + relevant = 0 + IF dx + dz THEN + 'check if location should be checked + + dz! = 0 + IF z2 > z THEN dz! = dz2! + IF z2 < z THEN dz! = dz1! + + dx! = 0 + IF x2 > x THEN dx! = dx2! + IF x2 < x THEN dx! = dx1! + + IF dx! < 0.4 AND dz! < 0.4 THEN + relevant = 1 + END IF + ELSE + relevant = 1 + END IF + + IF relevant THEN + x3 = x2: y3 = y2: z3 = z2 + MapOffset x3, y3, z3 + t2 = Blk(x3, y3, z3).Typ + IF t2 = 1 THEN + ' PY = oPY + newpy! = oPY + + END IF + END IF + NEXT + NEXT + END IF + NEXT + + PX = newpx! + PY = newpy! + PZ = newpz! + + + + + DO WHILE _MOUSEINPUT + mmx = mmx + _MOUSEMOVEMENTX + mmy = mmy + _MOUSEMOVEMENTY + LOOP + PRINT mmx, mmy + + ax = mmx / 100 + ay = -mmy / 400 + + my = _MOUSEY + MX = _MOUSEX + + _LIMIT 30 + _DISPLAY + + VertexLast = oldVertexLast + TriangleLast = oldTriangleLast + + IF _RESIZE THEN + oldscreen = _DEST + SCREEN _NEWIMAGE(_RESIZEWIDTH, _RESIZEHEIGHT, 32) + _FREEIMAGE oldscreen + END IF + +LOOP + +SUB DrawCube (x AS SINGLE, y AS SINGLE, z AS SINGLE, typ AS LONG, lit AS LONG) + + +DEFSNG A-Z +DEFLNG I + +size = 1 + +FOR i = 1 TO 8 + vert(i).x = x: vert(i).y = y: vert(i).z = z + IF i > 4 THEN vert(i).y = vert(i).y + size + IF i = 2 OR i = 3 OR i = 6 OR i = 7 THEN vert(i).x = vert(i).x + size + IF i = 3 OR i = 4 OR i = 7 OR i = 8 THEN vert(i).z = vert(i).z + size +NEXT + +'rotate verticies horizontally x/z +FOR i = 1 TO 8 + + x = vert(i).x + z = vert(i).z + x2 = SINax * z + x * COSax + z2 = COSax * z - SINax * x + x = x2 + z = z2 + vert(i).x = x + vert(i).z = z + + + y = vert(i).y + z = vert(i).z + y2 = SINay * z + y * COSay + z2 = COSay * z - SINay * y + y = y2 + z = z2 + vert(i).y = y + vert(i).z = z + + +NEXT + +'base: +'1-2 +'| | +'4-3 +'top: +'5-6 +'| | +'8-7 + +i = 0 + + +'front +i = i + 1 +side(i).p1.p = vert(8) +side(i).p2.p = vert(7) +side(i).p3.p = vert(3) +side(i).p4.p = vert(4) + +'right +i = i + 1 +side(i).p1.p = vert(7) +side(i).p2.p = vert(6) +side(i).p3.p = vert(2) +side(i).p4.p = vert(3) + + +'back +i = i + 1 +side(i).p1.p = vert(6) +side(i).p2.p = vert(5) +side(i).p3.p = vert(1) +side(i).p4.p = vert(2) + +'left +i = i + 1 +side(i).p1.p = vert(5) +side(i).p2.p = vert(8) +side(i).p3.p = vert(4) +side(i).p4.p = vert(1) + + +'top +i = i + 1 +side(i).p1.p = vert(5) +side(i).p2.p = vert(6) +side(i).p3.p = vert(7) +side(i).p4.p = vert(8) + + +'bottom +i = i + 1 +side(i).p1.p = vert(4) +side(i).p2.p = vert(3) +side(i).p3.p = vert(2) +side(i).p4.p = vert(1) + +b = 1 +FOR i = 1 TO 6 + + 'IF i = 1 THEN t = Box(b).front + 'IF i = 2 THEN t = Box(b).right + 'IF i = 3 THEN t = Box(b).back + 'IF i = 4 THEN t = Box(b).left + 'IF i = 5 THEN t = Box(b).top + 'IF i = 6 THEN t = Box(b).bottom + + l = lit - i + IF i = 5 THEN l = l + 5 + IF l < -15 THEN l = -15 + + t = Tex(typ, 15 + l, 0) + + IF typ = 1 THEN + _DONTBLEND t + + _MAPTRIANGLE _CLOCKWISE (0, 0)-(63, 0)-(63, 63), t TO(side(i).p1.p.x, side(i).p1.p.y, side(i).p1.p.z)-(side(i).p2.p.x, side(i).p2.p.y, side(i).p2.p.z)-(side(i).p3.p.x, side(i).p3.p.y, side(i).p3.p.z), , _SMOOTHSHRUNK + _MAPTRIANGLE _CLOCKWISE (0, 0)-(63, 63)-(0, 63), t TO(side(i).p1.p.x, side(i).p1.p.y, side(i).p1.p.z)-(side(i).p3.p.x, side(i).p3.p.y, side(i).p3.p.z)-(side(i).p4.p.x, side(i).p4.p.y, side(i).p4.p.z), , _SMOOTHSHRUNK + + + + + END IF + + IF (typ = 2 AND i = 5) THEN + _BLEND t + _MAPTRIANGLE (0, 0)-(63, 0)-(63, 63), t TO(side(i).p1.p.x, side(i).p1.p.y, side(i).p1.p.z)-(side(i).p2.p.x, side(i).p2.p.y, side(i).p2.p.z)-(side(i).p3.p.x, side(i).p3.p.y, side(i).p3.p.z), , _SMOOTHSHRUNK + _MAPTRIANGLE (0, 0)-(63, 63)-(0, 63), t TO(side(i).p1.p.x, side(i).p1.p.y, side(i).p1.p.z)-(side(i).p3.p.x, side(i).p3.p.y, side(i).p3.p.z)-(side(i).p4.p.x, side(i).p4.p.y, side(i).p4.p.z), , _SMOOTHSHRUNK + + END IF + + +NEXT + +DEFLNG A-Z +END SUB + + +FUNCTION LoadTexture (filename$) +TexLast = TexLast + 1 +T = TexLast +path$ = "blocks\" +PRINT path$ + filename$ + ".png" +i = _LOADIMAGE(path$ + filename$ + ".png", 32) +i2 = _COPYIMAGE(i) +FOR l = 15 TO 0 STEP -1 + _PUTIMAGE , darken, i2 + FOR TOD = 0 TO 3 'time of day (will support sunrise & sunset) + '_DEST i2 + 'LOCATE 1, 1 + 'PRINT l; + 'PRINT tod; + _DEST 0 + Tex(T, l, TOD) = _COPYIMAGE(i2, 33) + NEXT +NEXT +LoadTexture = TexLast +END FUNCTION + +SUB MapOffset (x, y, z) +IF x >= 0 THEN + x = x MOD (MapLimitX + 1) +ELSE + x = ((MapLimitX + 1) - ((-x) * -1)) MOD (MapLimitX + 1) +END IF +IF y >= 0 THEN + y = y MOD (MapLimitY + 1) +ELSE + y = ((MapLimitY + 1) - ((-y) * -1)) MOD (MapLimitY + 1) +END IF +IF z < 0 THEN + z = 0 +END IF +IF z > MapLimitZ THEN + z = MapLimitZ +END IF +END SUB + + + +DEFSNG A-Z +FUNCTION Bump% (Alt%, Rank%, BumpFactor, Bias) + +DO + DO + r = RND - .5 + Bias + LOOP WHILE r < -.5 OR r > 0.5 + dAlt = r / (BumpFactor ^ Rank%) * Alt% +LOOP WHILE Alt% + dAlt < 0 OR Alt% + dAlt > 255 + +Bump% = INT(Alt% + dAlt) + +END FUNCTION +DEFLNG A-Z + + +DEFSNG A-Z +SUB VertexTranslate (x, y, z) +DIM p AS LONG +FOR p = VertexSource TO VertexSource + VertexCount - 1 + VertexX(p) = VertexX(p) + x + VertexY(p) = VertexY(p) + y + VertexZ(p) = VertexZ(p) + z +NEXT +END SUB +DEFLNG A-Z + + +DEFSNG A-Z +SUB VertexScale (s) +DIM p AS LONG +FOR p = VertexSource TO VertexSource + VertexCount - 1 + VertexX(p) = VertexX(p) * s + VertexY(p) = VertexY(p) * s + VertexZ(p) = VertexZ(p) * s +NEXT +END SUB +DEFLNG A-Z + +DEFSNG A-Z +'positive XZ/a1 is clockwise (when viewing from above) +'positive YZ/a2 is clockwise (when viewing from the right) +SUB VertexRotateXZ_YZ (a1, a2) +DIM p AS LONG + +a1_rad = a1 * -0.0174532925 +a1_sin = SIN(a1_rad): a1_cos = COS(a1_rad) + +a2_rad = a2 * 0.0174532925 +a2_sin = SIN(a2_rad): a2_cos = COS(a2_rad) + +FOR p = VertexSource TO VertexSource + VertexCount - 1 + + x = VertexX(p) + y = VertexY(p) + z = VertexZ(p) + + x2 = a1_sin * z + x * a1_cos + z = a1_cos * z - a1_sin * x + x = x2 + + y2 = a2_sin * z + y * a2_cos + z = a2_cos * z - a2_sin * y + y = y2 + + VertexX(p) = x + VertexY(p) = y + VertexZ(p) = z + +NEXT +END SUB +DEFLNG A-Z + +SUB CopyModel (m) + +v2 = VertexLast + +dif = (v2 + 1) - Model(m).FirstVertex + +FOR v1 = Model(m).FirstVertex TO Model(m).FirstVertex + Model(m).VertexCount - 1 + v2 = v2 + 1 + VertexX(v2) = VertexX(v1) + VertexY(v2) = VertexY(v1) + VertexZ(v2) = VertexZ(v1) + VertexTX(v2) = VertexTX(v1) + VertexTY(v2) = VertexTY(v1) +NEXT +VertexLast = v2 + +t2 = TriangleLast +FOR t1 = Model(m).FirstTriangle TO Model(m).FirstTriangle + Model(m).TriangleCount * 3 - 1 + t2 = t2 + 1 + TriangleVertex(t2) = TriangleVertex(t1) + dif +NEXT +TriangleLast = t2 + +END SUB diff --git a/samples/mycraft/src/mycraft_0_001.zip b/samples/mycraft/src/mycraft_0_001.zip new file mode 100644 index 0000000..223773e Binary files /dev/null and b/samples/mycraft/src/mycraft_0_001.zip differ diff --git a/samples/mystify/index.md b/samples/mystify/index.md index 5da8cec..49f0f36 100644 --- a/samples/mystify/index.md +++ b/samples/mystify/index.md @@ -6,7 +6,7 @@ ### Author -[🐝 RhoSigma](../rhosigma.md) +[🐝 Rho Sigma](../rho-sigma.md) ### Description @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "mystify.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/mystify/src/mystify.bas) -* [RUN "mystify.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/mystify/src/mystify.bas) -* [PLAY "mystify.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/mystify/src/mystify.bas) +* [LOAD "mystify.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/mystify/src/mystify.bas) +* [RUN "mystify.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/mystify/src/mystify.bas) +* [PLAY "mystify.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/mystify/src/mystify.bas) ### File(s) diff --git a/samples/names/img/screenshot.png b/samples/names/img/screenshot.png new file mode 100644 index 0000000..3745fda Binary files /dev/null and b/samples/names/img/screenshot.png differ diff --git a/samples/names/index.md b/samples/names/index.md new file mode 100644 index 0000000..ee759b2 --- /dev/null +++ b/samples/names/index.md @@ -0,0 +1,71 @@ +[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: NAMES + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 David Bannon](../david-bannon.md) + +### Description + +```text +' NAMES.BAS by David Bannon +' Copyright (C) 1992 DOS Resource Guide +' Published in Issue #6, November 1992, page 65 +' + +============================================================================== + +------------- + NAMES.BAS + NAMES.BAT + INSTALL.BAT +------------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x. Two companion files, INSTALL.BAT and NAMES.BAT (both of which are on +this diskette), simplify installing and starting NAMES.BAS. + +WHAT NAMES.BAS DOES: +This QBasic program lets you create a simple database of companies, contact +names, and telephone numbers. You can search the database by company name or +by first or last name. PHONE.BAS on this diskette performs a similar +function. + +USING NAMES.BAS: +You can follow the standard QBasic procedures for starting NAMES.BAS, but +you'll probably find it more convenient to use NAMES.BAS with its companion +files, INSTALL.BAT and NAMES.BAT. + +INSTALL.BAT simplifies installation, copying NAMES.BAS from its current +location to your C:\DOS subdirectory. INSTALL.BAT also places NAMES.BAT, the +batch file used to start NAMES.BAS, in your hard disk's root directory. + +When you type NAMES at the DOS prompt, NAMES.BAT changes to your \DOS +directory, starts QBasic, and runs NAMES.BAS. NAMES.BAS presents you with +three options: entering a name, searching for a name, or quitting the program. +When you press 1 to choose the first option, NAMES.BAS prompts you to enter +the name, area code, phone number, and company name for each entry. If you +type END (any combination of upper- and lowercase number is acceptable) in the +last-name field, the program closes the file and returns you to the main menu. + +When you press 2 to select the search option, the program asks you to supply +the name you want to look for. When a match is found, NAMES.BAS prints all the +database entries that match your criteria. The program informs you if no match +exists and repeats its request for a name. As with the first option, typing +END returns you to the main menu. + +Choose option 3 from the main menu to quit the program. + +For further details on NAMES.BAS, see "Building a QBasic Database" (DRG #6, +November 1992, page 65). +``` + +### File(s) + +* [names.bas](src/names.bas) +* [names.zip](src/names.zip) + +🔗 [data management](../data-management.md), [dos world](../dos-world.md) diff --git a/samples/names/src/names.bas b/samples/names/src/names.bas new file mode 100644 index 0000000..468ab95 --- /dev/null +++ b/samples/names/src/names.bas @@ -0,0 +1,165 @@ +' NAMES.BAS by David Bannon +' Copyright (C) 1992 DOS Resource Guide +' Published in Issue #6, November 1992, page 65 +' +DEFINT A-Z +DECLARE SUB Menu (Row, Column, Option$(), Escape, Selection) + +CONST TRUE = -1 +CONST FG = 7, BG = 4 + +DIM Main$(1 TO 10) +FOR X = 1 TO 10 + READ Main$(X) +NEXT + + +' Display the main menu +MainMenu: +DATA NAMES DATABASE, Keep track of those, Names and Numbers!, MAIN MENU, - +DATA 1. ENTER a name, 2. SEARCH for a name, 3. Quit, -, Select a number + +CLS +CALL Menu(6, 30, Main$(), LastKey, Selection) +COLOR 7, 1 + +' A simple database program for entering names, phone numbers and +' company names, and searching for them. + +file$ = "NAMES.TXT" ' Database file name +form$ = "\ \\ \" +form$ = "(\ \)\ \" +form$ = "\ \" + + + +' Get the user's choice +DO: choice$ = INKEY$ +LOOP UNTIL choice$ = "1" OR choice$ = "2" OR choice$ = "3" + +SELECT CASE choice$ + CASE "1" ' Add a name to the database + OPEN file$ FOR APPEND AS #1 + WHILE UCASE$(last$) <> "END" + CLS : LOCATE 11, 25: PRINT "ADD a name to the database" + LOCATE 12, 25: PRINT "(To stop, enter END as a last name)" + LOCATE 14, 25: INPUT "Last name: ", last$ + IF UCASE$(last$) <> "END" THEN + LOCATE 16, 24: INPUT "First name: ", first$ + LOCATE 18, 40: PRINT "(Press Enter if n/a)" + LOCATE 18, 25: INPUT "Area code: ", area$ + LOCATE 20, 22: INPUT "Phone number: ", phone$ + LOCATE 22, 22: INPUT "Company name: ", compa$ + WRITE #1, last$, first$, area$, phone$, compa$: CLS + END IF + WEND + CLOSE #1: last$ = "": GOTO MainMenu + +CASE "2" ' Search for a name in the database + WHILE UCASE$(search$) <> "END" + OPEN file$ FOR INPUT AS #1 + CLS : LOCATE 11, 25: PRINT "SEARCH for a name in the database" + LOCATE 12, 25: PRINT "(To stop, enter END as the name)" + LOCATE 14, 25: INPUT "Name to search for: ", search$: PRINT + IF UCASE$(search$) <> "END" THEN + DO WHILE (NOT EOF(1)) + INPUT #1, last$, first$, area$, phone$, compa$ + SELECT CASE UCASE$(search$) + CASE UCASE$(last$) + hit% = 1: LOCATE , 25 + PRINT USING form$; last$; first$; + LOCATE , 25: PRINT USING form$; area$; phone$ + LOCATE , 25: PRINT USING form$; compa$ + CASE UCASE$(first$) + hit% = 1: LOCATE , 25 + PRINT USING form$; last$; first$; + LOCATE , 25: PRINT USING form$; area$; phone$ + LOCATE , 25: PRINT USING form$; compa$ + CASE UCASE$(compa$) + hit% = 1: LOCATE , 25 + PRINT USING form$; last$; first$; + LOCATE , 25: PRINT USING form$; area$; phone$ + LOCATE , 25: PRINT USING form$; compa$ + END SELECT + LOOP + IF hit% = 0 THEN + LOCATE , 25: PRINT "No match found for "; search$ + END IF + hit% = 0: LOCATE , 25: PRINT + LOCATE , 25: PRINT "Press any key to continue" + DO WHILE INKEY$ = "": LOOP + CLOSE #1 + END IF + WEND + CLOSE #1: search$ = "": GOTO MainMenu + + CASE "3" ' Quit the program + CLS : SYSTEM + +END SELECT + +' +SUB Menu (Row, Column, Option$(), last, Selection) STATIC + + + LMax = 0 'Max length of options + NumOpts = UBOUND(Option$) 'Number of options + IF Selection = 0 OR Selection > NumOpts THEN Selection = 1 + + FOR A = 1 TO NumOpts 'Determine longest item + B = LEN(Option$(A)) + IF B > LMax THEN LMax = B + NEXT + LMax = LMax + 2 'Add two for surrounding spaces + + FOR A = 1 TO NumOpts 'Display the choices + COLOR FG, BG + F = Row + A - 1 + LOCATE F, Column + IF Option$(A) = "-" THEN + PRINT STRING$(LMax, 196) + ELSE + PRINT " "; Option$(A); TAB(Column + LMax); + + B = INSTR(UCASE$(Option$(A)), A$) + IF B THEN + LOCATE F, Column + B + PRINT MID$(Option$(A), B, 1) + END IF + END IF + NEXT + + + COLOR FG, BG + LOCATE Row + Selection - 1, Column + PRINT " "; Option$(Selection); TAB(Column + LMax); + B = INSTR(UCASE$(Option$(Selection)), A$) + IF B THEN + LOCATE Row + Selection - 1, Column + B + PRINT MID$(Option$(Selection), B, 1) + END IF + + SELECT CASE T + CASE -71 'Home + Selection = 1 + CASE -79 'End + Selection = NumOpts + CASE -72 + Selection = Selection - 1 'Up arrow + IF Selection = 0 THEN Selection = NumOpts + IF MID$(Option$(Selection), 2, 1) = "-" THEN + Selection = Selection - 1 + END IF + CASE -80 'Down arrow + Selection = Selection + 1 + IF Selection > NumOpts THEN Selection = 1 + IF Option$(Selection) = "-" THEN + Selection = Selection + 1 + END IF + CASE ELSE + Selection = Letter + END SELECT + + + END SUB + diff --git a/samples/names/src/names.zip b/samples/names/src/names.zip new file mode 100644 index 0000000..c73c93c Binary files /dev/null and b/samples/names/src/names.zip differ diff --git a/samples/nathan-thomas.md b/samples/nathan-thomas.md new file mode 100644 index 0000000..963e92a --- /dev/null +++ b/samples/nathan-thomas.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 NATHAN THOMAS + +**[QB-NVentory](qb-nventory/index.md)** + +[🐝 Nathan Thomas](nathan-thomas.md) 🔗 [data management](data-management.md) + +# qbasic-nventory (i)nventory manager written in qbasic! This is a personal software project fro... diff --git a/samples/nibbles/index.md b/samples/nibbles/index.md index 789226c..4995203 100644 --- a/samples/nibbles/index.md +++ b/samples/nibbles/index.md @@ -18,9 +18,9 @@ Snake clone by Microsoft. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "nibbles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/nibbles/src/nibbles.bas) -* [RUN "nibbles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/nibbles/src/nibbles.bas) -* [PLAY "nibbles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/nibbles/src/nibbles.bas) +* [LOAD "nibbles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/nibbles/src/nibbles.bas) +* [RUN "nibbles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/nibbles/src/nibbles.bas) +* [PLAY "nibbles.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/nibbles/src/nibbles.bas) ### File(s) diff --git a/samples/parabolas/img/screenshot.png b/samples/parabolas/img/screenshot.png new file mode 100644 index 0000000..f84bec6 Binary files /dev/null and b/samples/parabolas/img/screenshot.png differ diff --git a/samples/parabolas/index.md b/samples/parabolas/index.md new file mode 100644 index 0000000..860e771 --- /dev/null +++ b/samples/parabolas/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: PARABOLAS + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 STxAxTIC](../stxaxtic.md) + +### Description + +```text +Parabola-based screensaver by STxAxTIC. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "parabolas.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/parabolas/src/parabolas.bas) +* [RUN "parabolas.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/parabolas/src/parabolas.bas) +* [PLAY "parabolas.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/parabolas/src/parabolas.bas) + +### File(s) + +* [parabolas.bas](src/parabolas.bas) + +🔗 [zen](../zen.md) diff --git a/samples/parabolas/src/parabolas.bas b/samples/parabolas/src/parabolas.bas new file mode 100644 index 0000000..7d7652d --- /dev/null +++ b/samples/parabolas/src/parabolas.bas @@ -0,0 +1,103 @@ +'#lang "qb" ' freebasic edit 2011-06 +delayconst = 900000 ' freebasic edit 2011-06 +'CLEAR ' freebasic edit 2011-06 + +Cls +Screen 12 +Randomize Timer + +Locate 1, 2: Input "Enter number of particles (default is 80): ", num +If num = 0 Then num = 80 +Dim x(num), y(num), xold(num), yold(num), v0x(num), v0y(num), col(num) + +start: +Cls +iterations = 0 +'g = RND * 10 + 20 +g = Rnd * 15 + 25 +xdamp = Rnd * .15 + .55 +ydamp = Rnd * .15 + .55 +exploderadius = 200 '75 +numobstacles = 0 +iterationmax = 1200 + +choosecol: +bgcol = Int(Rnd * 14) +wallcol = 0 'INT(RND * 14)'change to zero for spider mode +If bgcol = wallcol Then GoTo choosecol + +Line (1, 1)-(639, 479), bgcol, BF +Line (1, 1)-(639, 479), wallcol, B + +'Draw obstacles randomly. +For i = 1 To numobstacles + Line (Rnd * 640, Rnd * 480)-(Rnd * 640, Rnd * 480), wallcol, B +Next i + +'Make predetermined obstacles. +'LINE (50, 75)-(600, 125), wallcol, B + +'Toggle for random starting position. +xshift = Rnd * 640 +yshift = Rnd * 480 +'Toggle for fixed starting position +'xshift = 100 +'yshift = 100 + +For i = 1 To num + speed = Rnd * 90 + ang1 = Rnd * 2 * 3.141592653589793# + ang2 = Rnd * 2 * 3.141592653589793# + x(i) = xshift + Rnd * exploderadius * Cos(ang1) + y(i) = yshift + Rnd * exploderadius * Sin(ang1) + v0x(i) = 1.5 * speed * Cos(ang2) + v0y(i) = speed * Sin(ang2) + dotcol: + col(i) = Int(Rnd * 13 + 1) + If col(i) = bgcol Or col(i) = wallcol Then GoTo dotcol + If Point(x(i), y(i)) = wallcol Or x(i) < 1 Or x(i) > 639 Or y(i) < 1 Or y(i) > 479 Then i = i - 1 + dv = Sqr((v0x(i)) ^ 2 + (v0y(i)) ^ 2) + If dv > vmax Then vmax = dv + PSet (x(i), y(i)), col(i) +Next + +dt = .995 / vmax + +Sleep 1 + +Do + idel = 0: Do: idel = idel + 1: Loop Until idel > delayconst ' freebasic edit 2011-06 + + iterations = iterations + 1 + smax = 0 + For i = 1 To num + xold(i) = x(i) + yold(i) = y(i) + v0x(i) = v0x(i) + 0 * dt + v0y(i) = v0y(i) + g * dt + xtmp = x(i) + v0x(i) * dt + ytmp = y(i) + v0y(i) * dt + If Point(xtmp, yold(i)) = wallcol Then v0x(i) = v0x(i) * -1 * xdamp + If Point(xold(i), ytmp) = wallcol Then v0y(i) = v0y(i) * -1 * ydamp + x(i) = x(i) + v0x(i) * dt + y(i) = y(i) + v0y(i) * dt + 'Recolor stagnant particles. + xx = x(i) - xold(i) + yy = y(i) - yold(i) + If Sqr(xx ^ 2 + yy ^ 2) < .05 Then col(i) = bgcol + PSet (xold(i), yold(i)), 0 'bgcol + PSet (x(i), y(i)), col(i) + ds = Sqr((y(i) - yold(i)) ^ 2 + (x(i) - xold(i)) ^ 2) + If ds > smax Then smax = ds + Next + If smax > .95 Then dt = dt * (1 - .01) + If smax < .9 Then dt = dt * (1 + .01) + If iterations > iterationmax Then + Sleep 2 + GoTo start + End If + Line (19, 459)-(151, 471), wallcol, B + Line (20, 460)-(20 + 130 * (iterations / iterationmax), 470), 15, BF +Loop Until InKey$ <> "" +End + diff --git a/samples/particle-fountain/index.md b/samples/particle-fountain/index.md index 837b794..7439cbc 100644 --- a/samples/particle-fountain/index.md +++ b/samples/particle-fountain/index.md @@ -18,9 +18,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "particlefountain.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/particle-fountain/src/particlefountain.bas) -* [RUN "particlefountain.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/particle-fountain/src/particlefountain.bas) -* [PLAY "particlefountain.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/particle-fountain/src/particlefountain.bas) +* [LOAD "particlefountain.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/particle-fountain/src/particlefountain.bas) +* [RUN "particlefountain.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/particle-fountain/src/particlefountain.bas) +* [PLAY "particlefountain.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/particle-fountain/src/particlefountain.bas) ### File(s) diff --git a/samples/particles.md b/samples/particles.md index 0236025..149f0e9 100644 --- a/samples/particles.md +++ b/samples/particles.md @@ -7,3 +7,9 @@ [🐝 bplus](bplus.md) 🔗 [particles](particles.md) ' Created by QB64 community member bplus. + +**[Rockets](rockets/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [screensaver](screensaver.md), [particles](particles.md) + +Screensaver with rocket-like particles. diff --git a/samples/pattern/index.md b/samples/pattern/index.md index 48889f2..a388e09 100644 --- a/samples/pattern/index.md +++ b/samples/pattern/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "pattern.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/pattern/src/pattern.bas) -* [RUN "pattern.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/pattern/src/pattern.bas) -* [PLAY "pattern.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/pattern/src/pattern.bas) +* [LOAD "pattern.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/pattern/src/pattern.bas) +* [RUN "pattern.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/pattern/src/pattern.bas) +* [PLAY "pattern.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/pattern/src/pattern.bas) ### File(s) diff --git a/samples/pdf.md b/samples/pdf.md new file mode 100644 index 0000000..d4e06eb --- /dev/null +++ b/samples/pdf.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: PDF + +**[Calendar](calendar/index.md)** + +[🐝 A&A De Pasquale](a&a-de-pasquale.md) 🔗 [calendar](calendar.md), [pdf](pdf.md), [dos world](dos-world.md) + +' Antonio & Alfonso De Pasquale ' Copyright (C) 1993 DOS Resource Guide ' Published in Issue #8, ... diff --git a/samples/pendulum.md b/samples/pendulum.md index ce42a71..433a2cd 100644 --- a/samples/pendulum.md +++ b/samples/pendulum.md @@ -2,6 +2,12 @@ ## SAMPLES: PENDULUM +**[Double Pendulum](double-pendulum/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [physics](physics.md), [pendulum](pendulum.md) + +Simulated double pendulum with damping. + **[Pendulum Game](pendulum-game/index.md)** [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [game](game.md), [pendulum](pendulum.md) diff --git a/samples/phone/img/screenshot.png b/samples/phone/img/screenshot.png index 564bfef..6e22284 100644 Binary files a/samples/phone/img/screenshot.png and b/samples/phone/img/screenshot.png differ diff --git a/samples/phone/index.md b/samples/phone/index.md index 3076928..1bab7c5 100644 --- a/samples/phone/index.md +++ b/samples/phone/index.md @@ -6,12 +6,53 @@ ### Author -[🐝 Microsoft](../microsoft.md) +[🐝 Hardin Brothers](../hardin-brothers.md) ### Description ```text -Simple phone directory by Microsoft. +' +' PHONE.BAS by Hardin Brothers +' Copyright (C) 1992 DOS Resource Guide +' Published in Issue # 4, page 63 +' + +============================================================================== + +----------- + PHONE.BAS +----------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x. + +WHAT PHONE.BAS DOES: +This easy-to-use QBasic database gives you quick access to important phone +numbers, organizing them by last name or company name. NAMES.BAS on this +diskette performs a similar function. + +USING PHONE.BAS: +To load the program, type QBASIC PHONE.BAS (using path names if necessary) at +the DOS prompt. Then run the program by selecting the Start option in QBasic's +Run menu, or press Shift-F5. + +A menu at the bottom of your screen offers five choices: PgUp, PgDn, Add a +Name, Delete a Name, and Esc. To enter names and phone numbers, press A (Add a +Name). At the prompts, enter a last name, first name, and a phone number, +pressing Enter after each one. After you complete each database entry, +PHONE.BAS assigns it a number and displays the page containing the entry on +screen. The program organizes entries alphabetically by last name. + +To delete an entry, press D at the main menu. The program prompts you to type +the number of the entry to remove and asks you to confirm your intention to +delete it. After erasing the entry, the program displays the current page of +database entries, renumbering entries as necessary. + +Use the PgUp and PgDn keys to move from page to page. To exit the program, +press Esc from the main menu. + +For further details on PHONE.BAS, see "Elementary Steps to Programming" (DRG +#4, page 63). ``` ### File(s) @@ -19,4 +60,4 @@ Simple phone directory by Microsoft. * [phone.bas](src/phone.bas) * [phone.zip](src/phone.zip) -🔗 [data management](../data-management.md) +🔗 [data management](../data-management.md), [dos world](../dos-world.md) diff --git a/samples/phone/src/phone.bas b/samples/phone/src/phone.bas index ca8fd67..b6c4762 100644 --- a/samples/phone/src/phone.bas +++ b/samples/phone/src/phone.bas @@ -1,523 +1,243 @@ -'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 +' PHONE.BAS by Hardin Brothers +' Copyright (C) 1992 DOS Resource Guide +' Published in Issue # 4, page 63 +' +DEFINT A-Z + +TYPE EntryType + LastName AS STRING * 20 + FirstName AS STRING * 20 + Phone AS STRING * 14 +END TYPE + +CONST RecLen = 54 'Length of EntryType +CONST FALSE = 0 +CONST TRUE = NOT FALSE +CONST FormLength = 18 'Lines in screen top +CONST MaxEntries = 500 'Maximum number of entries +CONST FileName$ = "PHONE.LST" 'Data filename + +CONST PgUp = -&H49 +CONST PgDn = -&H51 +CONST Esc = 27 + +DIM SHARED Entry(1 TO MaxEntries) AS EntryType +DIM SHARED CurrentEntry, LastEntry +DIM SHARED ErrorFlag +DIM SHARED BlankLine$, DashLine$ + +BlankLine$ = STRING$(79, " ") +DashLine$ = STRING$(79, "=") + +ReadFile +MainDisplay +SaveFile +CLS +END + +ErrorTrap: + ErrorFlag = ERR + RESUME NEXT + +SUB AddEntry + ClearBottom + LOCATE FormLength + 1 + PRINT DashLine$ + IF LastEntry < MaxEntries THEN + PRINT "Last Name ==> "; + LINE INPUT Name$ + IF LEN(Name$) < 1 THEN + ShowMenu + EXIT SUB + ELSE + LastEntry = LastEntry + 1 + Entry(LastEntry).LastName$ = Name$ + PRINT "First Name==> "; + LINE INPUT Entry(LastEntry).FirstName$ + PRINT "Phone ==> "; + LINE INPUT Entry(LastEntry).Phone$ + SortList + END IF + ELSE + PRINT "The phone list is full" + PRINT "Press any key to continue"; + Z$ = INPUT$(1) + END IF + IF CurrentEntry = 0 THEN CurrentEntry = 1 + ShowMenu +END SUB + +SUB ClearBottom + LOCATE FormLength + 1, 1 + FOR Lp = FormLength + 1 TO 23 + PRINT BlankLine$ + NEXT Lp + PRINT BlankLine$; +END SUB + +SUB ClearTop + LOCATE 1, 1 + FOR Lp = 1 TO FormLength + PRINT BlankLine$ + NEXT Lp +END SUB + +SUB DeleteEntry + ClearBottom + LOCATE FormLength + 1 + PRINT DashLine$ + PRINT "Entry number to delete ==> "; + LINE INPUT Item$ + Item = VAL(Item$) + IF Item > 0 AND Item <= LastEntry THEN + PRINT Entry(Item).LastName$; " "; + PRINT Entry(Item).FirstName$; " "; + PRINT Entry(Item).Phone$ + PRINT "Delete this entry"; + IF YesNo = "Y" THEN + FOR Lp = Item TO LastEntry - 1 + Entry(Lp) = Entry(Lp + 1) + NEXT Lp + LastEntry = LastEntry - 1 + END IF + END IF + ShowMenu +END SUB + +FUNCTION FileExists (File$) + ErrorFlag = 0 + FileNum = FREEFILE + ON ERROR GOTO ErrorTrap + OPEN File$ FOR INPUT AS FileNum + ON ERROR GOTO 0 + CLOSE FileNum + IF ErrorFlag = 0 THEN + FileExists = TRUE + ELSE + FileExists = FALSE + END IF +END FUNCTION + +FUNCTION GetKey + DO + Ch$ = INKEY$ + LOOP UNTIL LEN(Ch$) > 0 + IF LEN(Ch$) = 1 THEN + GetKey = ASC(UCASE$(Ch$)) + ELSE + GetKey = -1 * ASC(RIGHT$(Ch$, 1)) + END IF +END FUNCTION + +SUB MainDisplay + CLS + LOCATE , , 0 'Turn off cursor + ShowMenu + DO + ShowList (CurrentEntry) + SELECT CASE GetKey + CASE PgUp + CurrentEntry = CurrentEntry - FormLength + IF CurrentEntry < 1 THEN + CurrentEntry = 1 + END IF + CASE PgDn + IF CurrentEntry + FormLength <= LastEntry THEN + CurrentEntry = CurrentEntry + FormLength + END IF + CASE ASC("A") + AddEntry + CASE ASC("D") + DeleteEntry + CASE Esc + EXIT SUB + CASE ELSE + END SELECT + LOOP +END SUB + +SUB ReadFile + IF FileExists(FileName$) THEN + OPEN FileName$ FOR RANDOM AS #1 LEN = RecLen + LastEntry = LOF(1) \ RecLen + FOR Lp = 1 TO LastEntry + GET #1, , Entry(Lp) + NEXT Lp + CLOSE #1 + IF LastEntry > 0 THEN + CurrentEntry = 1 + ELSE + CurrentEntry = 0 + END IF + ELSE + CurrentEntry = 0 + LastEntry = 0 + END IF +END SUB + +SUB SaveFile + IF LastEntry > 0 THEN + OPEN FileName$ FOR RANDOM AS #1 LEN = RecLen + FOR Lp = 1 TO LastEntry + PUT #1, , Entry(Lp) + NEXT Lp + CLOSE #1 + END IF +END SUB + +SUB ShowList (Start) + ClearTop + LOCATE 1, 1 + IF Start > 0 THEN + FOR Lp = Start TO Start + FormLength - 1 + IF Lp > LastEntry THEN EXIT FOR + PRINT USING "###_. "; Lp; + PRINT Entry(Lp).LastName$; " "; + PRINT Entry(Lp).FirstName$; " "; + PRINT Entry(Lp).Phone$ + NEXT Lp + END IF +END SUB + +SUB ShowMenu + ClearBottom + LOCATE FormLength + 1, 1 + PRINT DashLine$ + PRINT " Commands: " + PRINT " dd Name elete Name" + PRINT " to end" + PRINT DashLine$ +END SUB + +SUB SortList + DIM SortChart$(0 TO 3) + SortChart$(0) = "\": SortChart$(1) = CHR$(179) + SortChart$(2) = "/": SortChart$(3) = CHR$(196) + ClearBottom + LOCATE FormLength + 1, 1 + PRINT DashLine$ + PRINT " Sorting "; + IF LastEntry >= 2 THEN + FOR Lp1 = 1 TO LastEntry - 1 + FOR Lp2 = Lp1 TO LastEntry + IF Entry(Lp1).LastName$ > Entry(Lp2).LastName$ THEN + SWAP Entry(Lp1), Entry(Lp2) + END IF + NEXT Lp2 + LOCATE CSRLIN, POS(0) - 1 + PRINT SortChart$(Lp1 MOD 4); + NEXT Lp1 + END IF + ShowMenu +END SUB + +FUNCTION YesNo$ + PRINT " (y/n) ==> "; + DO + Ch$ = UCASE$(INPUT$(1)) + LOOP UNTIL Ch$ = "Y" OR Ch$ = "N" + PRINT Ch$ + YesNo$ = Ch$ +END FUNCTION diff --git a/samples/physics.md b/samples/physics.md index 4d94c09..de0f376 100644 --- a/samples/physics.md +++ b/samples/physics.md @@ -7,3 +7,15 @@ [🐝 Timothy Baxendale](timothy-baxendale.md) 🔗 [physics](physics.md), [collisions](collisions.md) Realistic collisions between sphreres in two dimensions. + +**[Double Pendulum](double-pendulum/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [physics](physics.md), [pendulum](pendulum.md) + +Simulated double pendulum with damping. + +**[Integrators](integrators/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [physics](physics.md), [simulation](simulation.md) + +Demonstrates the efficacy of various integration methods in physics. diff --git a/samples/plasma-effect/img/screenshot.png b/samples/plasma-effect/img/screenshot.png new file mode 100644 index 0000000..4af6e49 Binary files /dev/null and b/samples/plasma-effect/img/screenshot.png differ diff --git a/samples/plasma-effect/index.md b/samples/plasma-effect/index.md new file mode 100644 index 0000000..9e4b7a0 --- /dev/null +++ b/samples/plasma-effect/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: PLASMA EFFECT + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Cyperium](../cyperium.md) + +### Description + +```text +Use the left mousebutton to draw a line, change color with the right mousebutton, the middle mousebutton will draw a multicolor circle into the effect. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "plasmaeffect.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/plasma-effect/src/plasmaeffect.bas) +* [RUN "plasmaeffect.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/plasma-effect/src/plasmaeffect.bas) +* [PLAY "plasmaeffect.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/plasma-effect/src/plasmaeffect.bas) + +### File(s) + +* [plasmaeffect.bas](src/plasmaeffect.bas) + +🔗 [graphics](../graphics.md), [plasma](../plasma.md) diff --git a/samples/plasma-effect/src/plasmaeffect.bas b/samples/plasma-effect/src/plasmaeffect.bas new file mode 100644 index 0000000..01c1a01 --- /dev/null +++ b/samples/plasma-effect/src/plasmaeffect.bas @@ -0,0 +1,35 @@ +Screen 13, 0, 1, 0 +For k = 1 To 100 + Circle (160, 100), k, Int(Rnd * 255) + 1 +Next +Do + PCopy 1, 0 + PSet (musx, musy), Point(musx, musy) + Do + musz = 0 + Do + If _MouseButton(1) Then musz = musz Or 1 + If _MouseButton(2) Then musz = musz Or 2 + If _MouseButton(3) Then musz = musz Or 4 + Loop Until _MouseInput = 0 + musx = _MouseX + musy = _MouseY + If musz = 4 Then + For siz = 1 To 10 + Circle (musx, musy), siz, Rnd * 255 + Next + End If + If musz = 3 Then Line -(musx, musy), c: c = c + 1: If c > 255 Then c = 0 + If musz = 2 Then c = c + 1: If c > 255 Then c = 0 + If musz = 1 Then Line -(musx, musy), c + Loop Until musz = 0 + For x = 0 To 319 + For y = 0 To 199 + If Point(x - 1, y) <> 0 And Point(x + 1, y) <> 0 And Point(x, y - 1) <> 0 And Point(x, y + 1) <> 0 Then + PSet (x, y), ((Point(x - 1, y) + Point(x + 1, y) + Point(x, y - 1) + Point(x, y + 1) + Point(x + 1, y + 1) + Point(x - 1, y - 1) + Point(x + 1, y - 1) + Point(x - 1, y + 1)) / (8 + Rnd * .5 - .25)) + End If + Next + Next + If InKey$ = Chr$(27) Then End +Loop + diff --git a/samples/plasma-non-pal/index.md b/samples/plasma-non-pal/index.md index fb06467..b0c7c7b 100644 --- a/samples/plasma-non-pal/index.md +++ b/samples/plasma-non-pal/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "npplasma.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/plasma-non-pal/src/npplasma.bas) -* [RUN "npplasma.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/plasma-non-pal/src/npplasma.bas) -* [PLAY "npplasma.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/plasma-non-pal/src/npplasma.bas) +* [LOAD "npplasma.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/plasma-non-pal/src/npplasma.bas) +* [RUN "npplasma.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/plasma-non-pal/src/npplasma.bas) +* [PLAY "npplasma.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/plasma-non-pal/src/npplasma.bas) ### File(s) diff --git a/samples/plasma.md b/samples/plasma.md index c88ed01..3c53de4 100644 --- a/samples/plasma.md +++ b/samples/plasma.md @@ -2,6 +2,12 @@ ## SAMPLES: PLASMA +**[Plasma Effect](plasma-effect/index.md)** + +[🐝 Cyperium](cyperium.md) 🔗 [graphics](graphics.md), [plasma](plasma.md) + +Use the left mousebutton to draw a line, change color with the right mousebutton, the middle mous... + **[Plasma Non-Pal](plasma-non-pal/index.md)** [🐝 Relsoft](relsoft.md) 🔗 [screensaver](screensaver.md), [plasma](plasma.md) diff --git a/samples/pong.md b/samples/pong.md index c4c7ffb..61d13b9 100644 --- a/samples/pong.md +++ b/samples/pong.md @@ -2,6 +2,12 @@ ## SAMPLES: PONG +**[Diamond Pong](diamond-pong/index.md)** + +[🐝 John Wolfskill](john-wolfskill.md) 🔗 [game](game.md), [pong](pong.md), [dos world](dos-world.md) + +' Diamond Pong ' by ' John Wol... + **[Four Player Pong](four-player-pong/index.md)** [🐝 Matthew](matthew.md) 🔗 [game](game.md), [pong](pong.md) diff --git a/samples/qb-clock/img/qbclock.png b/samples/qb-clock/img/qbclock.png new file mode 100644 index 0000000..ef988b6 Binary files /dev/null and b/samples/qb-clock/img/qbclock.png differ diff --git a/samples/qb-clock/index.md b/samples/qb-clock/index.md new file mode 100644 index 0000000..66105d8 --- /dev/null +++ b/samples/qb-clock/index.md @@ -0,0 +1,71 @@ +[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: QB CLOCK + +![qbclock.png](img/qbclock.png) + +### Author + +[🐝 Alan Zeichick](../alan-zeichick.md) + +### Description + +```text +' Analog Clock for QBasic +' by Alan Zeichick copyright (c) 1986, 1992 +' Copyright (C) 1992 DOS Resource Guide +' Published in Issue #7, January 1993, page 47 +' +' This program may be freely given away, +' but may not be sold without the author's +' express written permission. + +' This program 1. Initializes some global variables. +' 2. Determines what video is installed. +' 3. Sets up video characteristics for this +' display type. +' 4. Calculates an analog clock's parameters. +' 5. Displays an analog clock until a key +' is pressed. + +' First, let's initialize global variables which well use as constants. +' Radian is the conversion factor between degree and radian +' measurements. It will be used when calculating hand positions. +' DrawBlack, DrawWhite, and DrawBright are screen colors. + +============================================================================== + +------------- + QBCLOCK.BAS +------------- +SYSTEM REQUIREMENTS: +The version of QBasic that comes with DOS 5 or later, or Microsoft Quick Basic +4.x. + +WHAT QBCLOCK.BAS DOES: +This QBasic program displays a large analog clock in the middle of your +screen. The clock's moving seconds indicator and minute and hour hands keep +accurate time until you press any key to stop the clock. + +USING QBCLOCK.BAS: +To load the program, type QBASIC QBCLOCK.BAS (using path names if necessary) +at the DOS prompt. Then, run the program by selecting the Start option in +QBasic's Run menu, or press Shift-F5. To stop the clock, press any key. + +For further details on QBCLOCK.BAS, as well as hints for modifying the +program, see "The Big Clock" (DRG #7, January 1993, page 47). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "qbclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/qb-clock/src/qbclock.bas) +* [RUN "qbclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/qb-clock/src/qbclock.bas) +* [PLAY "qbclock.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/qb-clock/src/qbclock.bas) + +### File(s) + +* [qbclock.bas](src/qbclock.bas) + +🔗 [clock](../clock.md) diff --git a/samples/qb-clock/src/qbclock.bas b/samples/qb-clock/src/qbclock.bas new file mode 100644 index 0000000..e163507 --- /dev/null +++ b/samples/qb-clock/src/qbclock.bas @@ -0,0 +1,285 @@ +DECLARE SUB TimeLoop (VideoX!, VideoY!, VideoAspect!) +DECLARE SUB DrawHands (NewTime$, VideoX!, VideoY!, VideoAspect!, DrawColor!) +DECLARE SUB DrawClockHands (VideoX!, VideoY!, VideoAspect!) +DECLARE SUB DrawBox (VideoWidth!, VideoHeight!, VideoAspect!) +DECLARE SUB SetVideoParameters (VideoType$, VideoWidth!, VideoHeight!, VideoAspect!) +DECLARE SUB SetVideoType (VideoType$) +COMMON SHARED Radian, DrawBright, DrawWhite, DrawBlack + +' Analog Clock for QBasic +' by Alan Zeichick copyright (c) 1986, 1992 +' Copyright (C) 1992 DOS Resource Guide +' Published in Issue #7, January 1993, page 47 +' +' This program may be freely given away, +' but may not be sold without the author's +' express written permission. + +' This program 1. Initializes some global variables. +' 2. Determines what video is installed. +' 3. Sets up video characteristics for this +' display type. +' 4. Calculates an analog clock's parameters. +' 5. Displays an analog clock until a key +' is pressed. + +' First, let's initialize global variables which well use as constants. +' Radian is the conversion factor between degree and radian +' measurements. It will be used when calculating hand positions. +' DrawBlack, DrawWhite, and DrawBright are screen colors. + +Radian = 3.1415926535# / 180 +DrawBlack = 0 +DrawWhite = 7 +DrawBright = 15 + +' First, call the routine to tell what video's installed. +' This routine, which uses the VideoModeError error handler +' in the main program, returns the variable VideoType$. +' Possible values are "Text" "CGA" "EGA" and "VGA" which are +' passed to the next variable -- unless the result is "Text" +' in which case the program aborts, with the appropriate +' message. + +CALL SetVideoType(VideoType$) + +' Oh, yes, we could have handled the "Text" situation in the +' SetVideoParameters subroutine, but it's rude for a subroutine +' to end the main program, as well as hard to debug. + +IF VideoType$ = "Text" THEN + PRINT "Sorry - this program only works on CGA, EGA, and VGA systems." + END ' Stop the program, and return to DOS. +END IF + +' Next, let's call SetVideoParameters. This routine sets the +' proper SCREEN and WIDTH values, and returns three numbers: +' VideoX (Integer) will be the number of horizontal dots +' VideoY (Integer) will be the number of vertical dots. +' VideoAspect (Real) will be the screen's aspect ratio. + +CALL SetVideoParameters(VideoType$, VideoX, VideoY, VideoAspect) + +' The next routine draws the box for the clock, and the hour tick marks. + +CALL DrawBox(VideoX, VideoY, VideoAspect) + +' The next routine keeps on drawing the clock's hands until a key is +' pressed, at which time it returns control to the main program. + +CALL TimeLoop(VideoX, VideoY, VideoAspect) + +END + +' Error-handling routines have to be in the main program. +' This one is designed to complement the SetVideoType +' subroutine. If that routine tests a video display type +' that the machine is not equipped for, control branches +' to VideoBailout, which resets the VideoType$ variable to +' indicate that a suitable video mode has not been found. +' It then returns control to SetVideoType, which tests the +' next video setting. + +' It would have been desireable to keep this error handler +' in the SetVideoType routine, but QBasic does not permit +' this. + +VideoModeError: + VideoType$ = "Text" +RESUME NEXT + +SUB DrawBox (VideoX, VideoY, VideoAspect) + +' Let's set up our local constants: + CenterX = VideoX / 2 ' The horizontal screen center + CenterY = VideoY / 2 ' The vertical screen center + TickLength = CenterY * .96 ' Where the video ticks go + +' We'll also be using a few local variables: +' TickX will be the horizontal coordinate of the hourly tick mark. +' TickY will be the vertical coordinate of the hourly tick mark. + +' First, draw a square around the screen. + +LINE (CenterX - CenterY * VideoAspect, 1)-(CenterX + CenterY * VideoAspect, VideoY - 1), DrawWhite, B + +' Next, draw in the hour tick marks. Refer to the article for +' details of how the TickX and TickY values are calculated. + +FOR HourCounter = 0 TO 11 + TickX = CenterX + TickLength * VideoAspect * SIN(HourCounter * 30 * Radian) + TickY = CenterY - TickLength * COS(HourCounter * 30 * Radian) + LINE (TickX - 1, TickY - 1)-(TickX + 1, TickY + 1), DrawWhite, B + NEXT HourCounter + +END SUB + +SUB DrawHands (NewTime$, VideoX, VideoY, VideoAspect, DrawColor) + +' This subroutine draws the clock hands, based on the time in NewTime$, +' centered in a screen box of size VideoX by VideoY, with an aspect +' ratio of VideoAspect. The clock is drawn in color DrawColor. +' Note how generic this is; that's a benefit of modular programming. + +' The following are local constant, relative to the input values: + CenterX = VideoX / 2 ' The horizontal screen center + CenterY = VideoY / 2 ' The vertical screen center + HourLength = CenterY * .6 ' The length of the hour hand + MinuteLength = CenterY * .8 ' The length of the minute hand + SecondLength = CenterY * .9 ' The position of the second circle + +' The following are local variables: +' HourX = 0 is the horizontal coordinate of the hour hand's far end +' HourY = 0 is the vertical coordinate of the hour hand's far end +' MinuteX is the horizontal coordinate of the minute hand's far end +' MinuteY is the vertical coordinate of the minute hand's far end +' SecondX is the horizontal coordinate of the second circle's center +' SecondY is the vertical coordinate of the second circle's far end +' NewSecond is the numeric value of the seconds, from NewTime$ +' NewMinute is the numeric value of the minutes plus NewSecond/60 +' NewHour is the numeric value of the hour plus NewMinute/60 + +' Let's dismantle the time into component parts, and add in the +' fractional part of the hours and minutes. + +NewSecond = VAL(MID$(NewTime$, 7, 2)) +NewMinute = VAL(MID$(NewTime$, 4, 2)) + NewSecond / 60 +NewHour = VAL(MID$(NewTime$, 1, 2)) + NewMinute / 60 + +' Calculate the new X and Y positions of the circle center. +' They are calculated just like the hourly tick marks in DrawBox. +' The constant '6' indicates that one second equals 6 degrees. +' Note that we're multiplying by a Radian conversion factor. + +SecondX = CenterX + VideoAspect * SIN(NewSecond * 6 * Radian) * SecondLength +SecondY = CenterY - COS(NewSecond * 6 * Radian) * SecondLength +CIRCLE (SecondX, SecondY), 4, DrawColor + +' Draw a line for the minute hand. We calculate the end point +' the same way we calculated the second hand's center, but this +' time we draw a line connecting it to the screen's center. + +MinuteX = CenterX + VideoAspect * SIN(NewMinute * 6 * Radian) * MinuteLength +MinuteY = CenterY - COS(NewMinute * 6 * Radian) * MinuteLength +LINE (CenterX, CenterY)-(MinuteX, MinuteY), DrawColor + +' Do the same thing for the hour hand. +' The constant this time is '30' since one hour equals 30 degrees. + +HourX = CenterX + VideoAspect * SIN(NewHour * 30 * Radian) * HourLength +HourY = CenterY - COS(NewHour * 30 * Radian) * HourLength +LINE (CenterX, CenterY)-(HourX, HourY), DrawColor + +END SUB + +SUB SetVideoParameters (VideoType$, VideoX, VideoY, VideoAspect) + +' This subroutine makes sure that the screen is set in the proper +' mode for the desired graphics capability (as discovered in +' SetVideoType). You can find out more details about the SCREEN +' command by checking in QBasic's online help under SCREEN, and then +' under SCREEN MODES. + +' There are two local constants; you should substitute your own +' screen measurements for them. +ScreenX = 10 ' Your monitor's width, in inches or millimeters +ScreenY = 7 ' Your monitor's height, in the same units as ScreenX + +' This case statement sets the screen area appropriately for the +' prediscovered resolution, and then sets the variables VideoX and +' VideoY to be the correct horizontal and vertical resolution, +' in pixels. + +SELECT CASE VideoType$ + CASE "CGA" + SCREEN 1 + VideoX = 320 + VideoY = 200 + CASE "EGA" + SCREEN 9 + VideoX = 640 + VideoY = 350 + CASE "VGA" + SCREEN 11 + VideoX = 640 + VideoY = 480 +END SELECT + +CLS + +' This next statement calculates the proper screen aspect ratio, +' depending on your screen's pixel resolution (figured in the CASE +' statement above) and your screen's physical width and height +' (assigned to ScreenX and ScreenY above). + +VideoAspect = (ScreenY / ScreenX) * (VideoX / VideoY) + +END SUB + +SUB SetVideoType (VideoType$) +' +' This subroutine tests the screen's graphics capability. +' It returns one of four values, Text, CGA, EGA, or VGA. +' It requires the labeled statements VideoModeError (in the main +' program) in order to test for SCREEN error conditions. +' I would be nice if VideoModeError could be inside the subroutine, +' but QBasic does not permit this. + +' First, set up the error trap. + +ON ERROR GOTO VideoModeError + +' Make assumptions by assigning VideoType$ to the desired video +' type, and then test that assumption with the SCREEN statement. +' If the assumption is invalid, a program error will occur, and +' ON ERROR will execute the code at VideoModeError. + +VideoType$ = "VGA" +SCREEN 11 +IF VideoType$ = "Text" THEN + VideoType$ = "EGA" + SCREEN 9 + IF VideoType$ = "Text" THEN + VideoType$ = "CGA" + SCREEN 1 + END IF + END IF + +' Since we're done, let's turn off error trapping. + +ON ERROR GOTO 0 + +END SUB + +SUB TimeLoop (VideoX, VideoY, VideoAspect) + +' This subroutine is the "tick-tock" part of the clock. +' It starts the loop by drawing the hands (calling DrawHands with +' the color DrawBright). Then, it waits for the time to change, +' calls DrawHands with the old time with DrawBlack to erase the hands. +' This loop continues until the user presses a key on the keyboard. + +WHILE INKEY$ = "" + + ' Find out what time it is. + + NewTime$ = TIME$ + + ' Draw in the hands, in color "DrawBright." + + CALL DrawHands(NewTime$, VideoX, VideoY, VideoAspect, DrawBright) + + ' Sit in an endless loop until the clock changes + + WHILE TIME$ = NewTime$: WEND + + ' Erase the hands by drawing them in color "DrawBlack." + + CALL DrawHands(NewTime$, VideoX, VideoY, VideoAspect, DrawBlack) + + ' Go back around the loop to draw the next minute. + + WEND + +END SUB + diff --git a/samples/qb-nventory/img/screenshot.png b/samples/qb-nventory/img/screenshot.png new file mode 100644 index 0000000..fb7e421 Binary files /dev/null and b/samples/qb-nventory/img/screenshot.png differ diff --git a/samples/qb-nventory/index.md b/samples/qb-nventory/index.md new file mode 100644 index 0000000..64fd6ab --- /dev/null +++ b/samples/qb-nventory/index.md @@ -0,0 +1,31 @@ +[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: QB-NVENTORY + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Nathan Thomas](../nathan-thomas.md) + +### Description + +```text +# qbasic-nventory +(i)nventory manager written in qbasic! + +This is a personal software project from 1993. This was intented just to keep track of an inventory of "things". While the version and release numbers might seem "high" for such a project, I was basically just making them up at that time to be "cool" along with random company names + +I remember compiling this to an executable using QB45. Designed to run from the DOS prompt it was just "NVENTORY.EXE" + +There are some issues with disk storage, writing seems fine, but reading doesn't appear to be working in data, but it does know how `many` items have been saved. + +Here's some screens! Running for the first time in almost 20 years using [qb64] +``` + +### File(s) + +* [nventory.bas](src/nventory.bas) +* [nventory.zip](src/nventory.zip) + +🔗 [data management](../data-management.md) diff --git a/samples/qb-nventory/src/nventory.bas b/samples/qb-nventory/src/nventory.bas new file mode 100644 index 0000000..cab0215 --- /dev/null +++ b/samples/qb-nventory/src/nventory.bas @@ -0,0 +1,2044 @@ +DefInt A-Z +$Resize:Smooth +'$DYNAMIC + +Const MAXWINDOW = 5 +Const FALSE = 0 +Const TRUE = Not FALSE + +Type WindowStruct + Frame As String * 6 + XPos As Integer + YPos As Integer + Foreground As Integer + Background As Integer + Length As Integer + Height As Integer + Title As String * 65 + Buffer As String * 2000 + Shadow As Integer + ShadChar As String * 1 +End Type + +Dim Shared Handle(0 To MAXWINDOW + 1) As WindowStruct +Dim Shared WinCount +Dim Shared redraw +Dim Shared BackChar$ +Dim Shared Fore +Dim Shared Back +Dim Shared Move$ +Dim Shared Dur +Dim Shared choice +Dim Shared subchoice +Dim Shared DoubleFrame As String * 6 +Dim Shared SingleFrame As String * 6 +DoubleFrame = "ɻȼ" +SingleFrame = "ڿٳ" + +'Start of NVENTORY +Const STARTMAX = 1 + +Dim Shared MAXRECS +MAXRECS = STARTMAX + +Type RecordStruct + SerialNumber As String * 15 + Item As String * 20 + Model As String * 10 + Department As String * 10 + Location As String * 10 + Note1 As String * 10 + Note2 As String * 10 +End Type +Dim Shared Equip As RecordStruct +Dim Shared EquipLength +EquipLength = Len(Equip) + +Dim Shared PrintErr +Dim Shared IDNum$ +Dim Shared MenuC1 +Dim Shared MenuC2 +Dim Shared ManipulateC1 +Dim Shared ManipulateC2 +Dim Shared InfoC1 +Dim Shared InfoC2 +Dim Shared PercentageChar$ +Dim Shared Model$(19) +Dim Shared SortField +Dim Shared Directory$ +Dim Shared RanFile$ +Dim Shared PrintedLines + +Dim Shared Info$(7, 2) +Dim Shared Title$(5) +Dim Shared Locs(5) + +Title$(1) = "Serial Number" +Locs(1) = 1 +Title$(2) = "Item Description" +Locs(2) = 16 +Title$(3) = "Model Num" +Locs(3) = 37 +Title$(4) = "Department" +Locs(4) = 48 +Title$(5) = "Location" +Locs(5) = 59 + +On Error GoTo ErrorHandler + + +Locate , , 1, 11, 12 +Print +Do + Print "Are you using a (C)olor or (M)onochrome monitor?"; + GetKey Kbd$ + Print Kbd$; + Kbd$ = UCase$(Kbd$) + + Select Case Kbd$ + Case "M" + MenuC1 = 0 + MenuC2 = 7 + ManipulateC1 = 0 + ManipulateC2 = 7 + InfoC1 = 0 + InfoC2 = 7 + Exit Do + + Case "C" + MenuC1 = 15 + MenuC2 = 4 + ManipulateC1 = 1 + ManipulateC2 = 3 + InfoC1 = 7 + InfoC2 = 1 + Exit Do + + Case Else + End Select + +Loop +Print + +BarMenu + +ErrorHandler: +Select Case Err + Case 24, 25, 27 + PrintErr = TRUE + BadPrint = ExplodeWindow(10, 13, 53, 1, 15, 4, SingleFrame, "ERROR!", 1, "") + WinPrintCenter BadPrint, 1, "Printer not responding ... Any key to continue" + Sound 1900, .2 + GetKey "" + CloseWindow BadPrint + Resume Next + Case 7, 14 + Locate 2, 1, 1 + Color 7, 0 + Print "The program has run out of memory. TERMINATING PROGRAM!"; + Sleep 5 + End + Case 70 + Sleep 2 + Resume + Case Else +End Select +Resume Next + +Rem $STATIC +Sub AboutMenu + Dim MenuItem$(1) + + MenuItem$(1) = " About..." + Hot$ = "A" + + Do Until NewChoice < 0 + Color MenuC2, MenuC1 + Locate 1, 2 + Print " " + + NewChoice = Menu(NewChoice, 2, 1, 22, MenuC1, MenuC2, MenuItem$(), Hot$, 1) + + Select Case NewChoice + Case 1 + GoSub ShowAboutStuff + Case -2 + subchoice = -2 + Case -3 + subchoice = -3 + Case Else + End Select + Loop + Exit Sub + + ShowAboutStuff: + AboutWin = ExplodeWindow(7, 17, 45, 8, ManipulateC1, ManipulateC2, SingleFrame, "", 1, "") + WinPrintCenter AboutWin, 2, "INVENTORY MANAGER" + WinPrintCenter AboutWin, 3, "Version 4.8 Release 3" + WinPrintCenter AboutWin, 4, "Copyright (C) Nathan Thomas, 1993." + WinPrintCenter AboutWin, 5, "Produced by Independent Distributors" + WinPrintCenter AboutWin, 7, String$(45, 196) + WinPrintCenter AboutWin, 8, "< OK >" + + Kbd$ = "" + Do Until Kbd$ = Chr$(13) + Kbd$ = GetString$(AboutWin, 8, 22, "", "", 0, 0) + Loop + + CloseWindow AboutWin + Return + +End Sub + +Sub AddRecord + Equip.SerialNumber = Chr$(255) + Equip.Item = Chr$(255) + Equip.Model = Chr$(255) + Equip.Department = Chr$(255) + Equip.Location = Chr$(255) + Equip.Note1 = Chr$(255) + Equip.Note2 = Chr$(255) + + AddWin = ExplodeWindow(3, 2, 74, 9, ManipulateC1, ManipulateC2, DoubleFrame, "Add an Item", 1, "") + WinPrint AddWin, 2, 1, "Serial Number:_______________ Item Description:____________________" + WinPrint AddWin, 3, 1, String$(74, 196) + WinPrint AddWin, 4, 1, "Model:__________ Department:__________ Location:__________" + WinPrint AddWin, 5, 1, String$(74, 196) + WinPrint AddWin, 6, 1, "TAB to move forward in fields to abort input" + WinPrint AddWin, 7, 1, "BACKTAB to move backward in fields to accept information" + WinPrint AddWin, 8, 1, String$(74, 196) + WinPrintCenter AddWin, 9, "Type a '?' in the Department field for a list of Departments" + + place = 1 + + Do Until finished = TRUE + If place = 1 Then + Kbd$ = GetString$(AddWin, 2, 15, Serial$, Serial$, 15, 15) + If Move$ = "TAB" Then place = 2 + If Move$ = "BKTAB" Then place = 5 + If Move$ = "ESC" Then CloseWindow AddWin: Exit Sub + If Move$ = "RET" Then finished = TRUE + End If + If place = 2 Then + Kbd$ = GetString$(AddWin, 2, 52, Item$, Item$, 20, 20) + If Move$ = "TAB" Then place = 3 + If Move$ = "BKTAB" Then place = 1 + If Move$ = "ESC" Then CloseWindow AddWin: Exit Sub + If Move$ = "RET" Then finished = TRUE + End If + If place = 3 Then + Kbd$ = GetString$(AddWin, 4, 7, Model$, Model$, 10, 10) + If Move$ = "TAB" Then place = 4 + If Move$ = "BKTAB" Then place = 2 + If Move$ = "ESC" Then CloseWindow AddWin: Exit Sub + If Move$ = "RET" Then finished = TRUE + End If + If place = 4 Then + Kbd$ = GetString$(AddWin, 4, 32, Department$, Department$, 10, 10) + If RTrim$(Department$) = "?" Then + GoSub ShowChoices + End If + If Move$ = "TAB" Then place = 5 + If Move$ = "BKTAB" Then place = 3 + If Move$ = "ESC" Then CloseWindow AddWin: Exit Sub + If Move$ = "RET" Then finished = TRUE + End If + If place = 5 Then + Kbd$ = GetString$(AddWin, 4, 55, Location$, Location$, 10, 10) + If Move$ = "TAB" Then place = 1 + If Move$ = "BKTAB" Then place = 4 + If Move$ = "ESC" Then CloseWindow AddWin: Exit Sub + If Move$ = "RET" Then finished = TRUE + End If + + If finished = TRUE Then + flag = 0 + If RTrim$(Serial$) = "" Then + ErrorWin = ExplodeWindow(6, 25, 40, 1, 15, 4, SingleFrame, "ERROR!", 1, "") + WinPrintCenter ErrorWin, 1, "Can't save without Serial Number!" + Sound 1900, .2 + GetKey "" + CloseWindow ErrorWin + finished = FALSE + flag = -1 + Else + ShowMessage "Searching..." + + CalcMax + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + For count = 1 To MAXRECS + + Get #1, count, Equip + + If RTrim$(UCase$(Equip.SerialNumber)) = RTrim$(UCase$(Serial$)) Then + flag = -1 + Exit For + End If + + If Asc(Equip.SerialNumber) = 255 Then + flag = count + Exit For + End If + Next + Close #1 + + If flag = 0 Then + flag = count + finished = TRUE + End If + If flag = -1 Then + ErrorWin = ExplodeWindow(6, 25, 41, 1, 15, 4, SingleFrame, "ERROR!", 1, "") + WinPrintCenter ErrorWin, 1, "There's already an item by that number!" + Sound 1900, .2 + GetKey "" + CloseWindow ErrorWin + finished = FALSE + End If + If flag >= 0 Then + finished = TRUE + ShowMessage "Writing Record..." + + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + + Serial$ = UCase$(Serial$) + Department$ = UCase$(Department$) + + If RTrim$(Item$) = "" Then Item$ = Chr$(255) + If RTrim$(Model$) = "" Then Model$ = Chr$(255) + If RTrim$(Department$) = "" Then Department$ = Chr$(255) + If RTrim$(Location$) = "" Then Location$ = Chr$(255) + Equip.SerialNumber = Serial$ + Equip.Item = Item$ + Equip.Model = Model$ + Equip.Department = Department$ + Equip.Location = Location$ + Equip.Note1 = IDNum$ + Equip.Note2 = "" + Put #1, flag, Equip + Close #1 + ShowMessage "Inventory Manager (c)Copyright 1993 by Nathan Thomas" + End If + End If + End If + Loop + CloseWindow AddWin + Exit Sub + + ShowChoices: + For t = 1 To MAXRECS + Model$(t) = "" + Next + ShowFlag = 0 + + NumberOfChoices = 0 + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + num.recs = LOF(1) / EquipLength + For count = 1 To num.recs + Get #1, count, Equip + If Asc(Equip.Department) <> 255 Then + CurrentInfo$ = UCase$(RTrim$(Equip.Department)) + For t = 1 To NumberOfChoices + If CurrentInfo$ = Model$(t) Then + ShowFlag = 1 + Exit For + End If + Next + If ShowFlag = 0 Then + ShowFlag = 0 + Model$(NumberOfChoices + 1) = CurrentInfo$ + NumberOfChoices = NumberOfChoices + 1 + Else + ShowFlag = 0 + End If + End If + Next + Close #1 + + Equip.SerialNumber = Serial$ + Equip.Item = Item$ + Equip.Model = Model$ + Equip.Location = Location$ + Equip.Note1 = Create$ + + If NumberOfChoices > 18 Then NumberOfChoices = 18 + + Model$(NumberOfChoices + 1) = "None!" + + NewChoice = Menu(NewChoice, 4, 4, 10, MenuC1, MenuC2, Model$(), Hot$, NumberOfChoices + 1) + + Move$ = "" + + If NewChoice = NumberOfChoices + 1 Or NewChoice < 1 Then Department$ = "": Return + + Department$ = RTrim$(Model$(NewChoice)) + + Return +End Sub + +Sub BarMenu + BackChar$ = "" + PercentageChar$ = "" + Fore = 7 + Back = 0 + Dur = 3 + GetDirectory + GenerateRandomFile + WindowInitialize + Intro + + choice = 2 + + Do + Select Case choice + Case 1 + AboutMenu + Case 2 + FileMenu + Case 3 + EditMenu + Case 4 + PrintMenu + Case 5 + OptionsMenu + End Select + + Select Case subchoice + Case -2 + choice = choice - 1 + If choice = 0 Then choice = 5 + Case -3 + choice = choice + 1 + If choice = 6 Then choice = 1 + End Select + Loop +End Sub + +Function Browse% (currItem, X, Y, L, H, Shadow, ShadChar$, NumOfFields, Locs(), Title$(), NumOfInfo, WindowTitle$) + BrowseC1 = ManipulateC1 + BrowseC2 = ManipulateC2 + + Dim BInfo$(6, 20) + + DT = Dur + Dur = 3 + + BrowseWin = ExplodeWindow(X, Y, L, H, BrowseC1, BrowseC2, DoubleFrame, WindowTitle$, Shadow, ShadChar$) + redraw = 0 + WinPrint BrowseWin, 1, Locs(1), Title$(1) + For t = 2 To NumOfFields + WinPrint BrowseWin, 1, Locs(t), "" + Title$(t) + Next + WinPrint BrowseWin, 2, 1, String$(L, 196) + For t = 2 To NumOfFields + WinPrint BrowseWin, 2, Locs(t), "" + Next + WinRedraw BrowseWin + + FirstItem = 1 + If currItem > NumOfInfo Or currItem < 1 Then currItem = 1 + If currItem > H - 2 Then + FirstItem = currItem + currItem = 1 + End If + + BrowseWin1 = MakeWindow(X + 2, Y, L, H - 2, BrowseC1, BrowseC2, "", "", 0, "") + + redraw = 0 + BrowseWin2 = MakeWindow(X + 1 + currItem, Y, L, 1, BrowseC2, BrowseC1, "", "", 0, "") + redraw = 1 + + GoSub ShowItems + + finished = FALSE + Do Until finished = TRUE + GoSub ShowBar + GetKey Kbd$ + + Select Case Kbd$ + Case Chr$(0) + "H" + currItem = currItem - 1 + If currItem = 0 Then + FirstItem = FirstItem - 1 + If FirstItem = 0 Then FirstItem = 1 + currItem = 1 + GoSub ShowItems + End If + + Case Chr$(0) + "P" + currItem = currItem + 1 + If ((currItem + FirstItem) - 1) > NumOfInfo Then currItem = currItem - 1 + If currItem = H - 1 Then + FirstItem = FirstItem + 1 + currItem = H - 2 + GoSub ShowItems + End If + + Case Chr$(0) + "I" + FirstItem = FirstItem - (H - 2) + If FirstItem < 1 Then FirstItem = 1: currItem = 1 + GoSub ShowItems + + Case Chr$(0) + "Q" + FirstItem = FirstItem + (H - 2) + If FirstItem + currItem - 1 > NumOfInfo Then FirstItem = NumOfInfo: currItem = 1 + GoSub ShowItems + + Case Chr$(27) + Browse% = -1 + finished = TRUE + + Case Chr$(13) + Browse% = ((currItem + FirstItem) - 1) + finished = TRUE + + Case "P", "p" + Browse% = ((currItem + FirstItem) - 1) + finished = TRUE + + Case "A", "a" + Browse% = ((currItem + FirstItem) - 1) + finished = TRUE + + Case Else + Sound 1900, .2 + End Select + Loop + + redraw = 0 + CloseWindow BrowseWin2 + CloseWindow BrowseWin1 + CloseWindow BrowseWin + redraw = 1 + RedrawAll + + Dur = DT + Move$ = UCase$(Kbd$) + ShowMessage "Inventory Manager (c)Copyright 1993 by Nathan Thomas" + Erase BInfo$ + Exit Function + + ShowItems: + redraw = 0 + Handle(BrowseWin1).Buffer = "" + + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + For count = 1 To H - 2 + Get #1, FirstItem + count - 1, Equip + BInfo$(1, count) = Equip.SerialNumber + BInfo$(2, count) = Equip.Item + BInfo$(3, count) = Equip.Model + BInfo$(4, count) = Equip.Department + BInfo$(5, count) = Equip.Location + BInfo$(6, count) = Equip.Note1 + + For count1 = 1 To NumOfFields + If count1 <> 1 Then + WinPrint BrowseWin1, count, Locs(count1), "" + BInfo$(count1, count) + Else + WinPrint BrowseWin1, count, Locs(count1), BInfo$(count1, count) + End If + Next + + If FirstItem + count - 1 >= NumOfInfo Then Exit For + Next + Close #1 + redraw = 1 + WinRedraw BrowseWin1 + Return + + ShowBar: + Handle(BrowseWin2).Buffer = "" + Handle(BrowseWin2).XPos = X + 1 + currItem + WinRedraw BrowseWin1 + For count1 = 1 To NumOfFields + If count1 <> 1 Then + WinPrint BrowseWin2, 1, Locs(count1), "" + BInfo$(count1, currItem) + Else + WinPrint BrowseWin2, 1, Locs(count1), BInfo$(count1, currItem) + End If + Next + ShowMessage "(" + LTrim$(Str$(FirstItem + currItem - 1)) + " of" + Str$(NumOfInfo) + " R#" + LTrim$(RTrim$(BInfo$(6, currItem))) + ")" + Return +End Function + +Sub CalcMax + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + MAXRECS = LOF(1) / EquipLength + Close #1 +End Sub + +Sub ChangeDir + DirWin = ExplodeWindow(8, 20, 46, 2, ManipulateC1, ManipulateC2, DoubleFrame, "", 1, "") + + WinPrint DirWin, 1, 1, "Enter the new directory location of the files" + WinPrint DirWin, 2, 1, "Directory:" + + Kill Directory$ + RanFile$ + + If Directory$ <> "" Then + Directory$ = Left$(Directory$, Len(Directory$) - 1) + End If + + Kbd$ = GetString$(DirWin, 2, 11, Directory$, Directory$, 35, 64) + + Directory$ = UCase$(RTrim$(Directory$)) + + If Right$(Directory$, 1) <> "\" And Directory$ <> "" Then + Directory$ = Directory$ + "\" + End If + + ClearTemp + CloseWindow DirWin +End Sub + +Sub ChangeRecord + + finished = FALSE + Do Until finished = TRUE + MoveFile + + Sort 6, SortField, MAXRECS + + flag1 = Browse(flag1, 3, 5, 69, 15, 1, " ", 5, Locs(), Title$(), MAXRECS, "Change a Record - to change") + + If flag1 = -1 Then + finished = TRUE + End If + + If finished = FALSE Then + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + Get #1, flag1, Equip + Close #1 + flag = Val(Equip.Note1) + + + If Asc(Equip.SerialNumber) <> 255 Then + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + Get #1, flag, Equip + Close #1 + + If RTrim$(Equip.Note2) <> "LOCKED" Then + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + PLock flag + Close #1 + Create$ = RTrim$(UCase$(Equip.Note1)) + + If IDNum$ = Create$ Or IDNum$ = "MANAGER" Then + Serial$ = Equip.SerialNumber + Item$ = RTrim$(Equip.Item) + If Asc(Item$) = 255 Then Item$ = "" + Model$ = RTrim$(Equip.Model) + If Asc(Model$) = 255 Then Model$ = "" + Department$ = RTrim$(Equip.Department) + If Asc(Department$) = 255 Then Department$ = "" + Location$ = RTrim$(Equip.Location) + If Asc(Location$) = 255 Then Location$ = "" + Create$ = RTrim$(UCase$(Equip.Note1)) + + ChangeWin = ExplodeWindow(3, 2, 74, 9, ManipulateC1, ManipulateC2, DoubleFrame, "Change an Item", 1, "") + WinPrint ChangeWin, 2, 1, "Serial Number: Item Description:____________________" + WinPrint ChangeWin, 3, 1, String$(74, 196) + WinPrint ChangeWin, 4, 1, "Model:__________ Department:__________ Location:__________" + WinPrint ChangeWin, 5, 1, String$(74, 196) + WinPrint ChangeWin, 6, 1, "TAB to move forward in fields to abort input" + WinPrint ChangeWin, 7, 1, "BACKTAB to move backward in fields to accept information" + WinPrint ChangeWin, 8, 1, String$(74, 196) + WinPrintCenter ChangeWin, 9, "Type a '?' in the Department field for a list of Departments" + + WinPrint ChangeWin, 2, 15, UCase$(Serial$) + WinPrint ChangeWin, 2, 52, Item$ + WinPrint ChangeWin, 4, 7, Model$ + WinPrint ChangeWin, 4, 32, Department$ + WinPrint ChangeWin, 4, 55, Location$ + + place = 1 + + Do + If place = 1 Then + Kbd$ = GetString$(ChangeWin, 2, 52, Item$, Item$, 20, 20) + Equip.Item = Item$ + If Move$ = "TAB" Then place = 2 + If Move$ = "BKTAB" Then place = 4 + If Move$ = "ESC" Then Exit Do + If Move$ = "RET" Then Exit Do + End If + If place = 2 Then + Kbd$ = GetString$(ChangeWin, 4, 7, Model$, Model$, 10, 10) + If Move$ = "TAB" Then place = 3 + If Move$ = "BKTAB" Then place = 1 + If Move$ = "ESC" Then Exit Do + If Move$ = "RET" Then Exit Do + End If + If place = 3 Then + Kbd$ = GetString$(ChangeWin, 4, 32, Department$, Department$, 10, 10) + If RTrim$(Department$) = "?" Then + GoSub ShowChangeChoices + End If + If Move$ = "TAB" Then place = 4 + If Move$ = "BKTAB" Then place = 2 + If Move$ = "ESC" Then Exit Do + If Move$ = "RET" Then Exit Do + End If + If place = 4 Then + Kbd$ = GetString$(ChangeWin, 4, 55, Location$, Location$, 10, 10) + If Move$ = "TAB" Then place = 1 + If Move$ = "BKTAB" Then place = 3 + If Move$ = "ESC" Then Exit Do + If Move$ = "RET" Then Exit Do + End If + Loop + + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + For t = 1 To LOF(1) / EquipLength + Get #1, t, Equip + If RTrim$(Equip.SerialNumber) = RTrim$(Serial$) Then + flag = t + Exit For + End If + Next + + If Move$ = "RET" Then + Equip.SerialNumber = Serial$ + Equip.Item = Item$ + Equip.Model = Model$ + Equip.Department = Department$ + Equip.Location = Location$ + Equip.Department = UCase$(Department$) + Put #1, flag, Equip + End If + + PUnlock flag + Close #1 + + CloseWindow ChangeWin + Else + ErrWin = ExplodeWindow(8, 5, 41, 5, 15, 4, DoubleFrame, "ERROR!", 1, "") + WinPrintCenter ErrWin, 1, "Your ID number does not match up with" + WinPrintCenter ErrWin, 2, "the ID number that created this item." + WinPrintCenter ErrWin, 3, "Therefore, YOU CANNOT CHANGE THIS ITEM!" + WinPrintCenter ErrWin, 5, "" + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + PUnlock flag + Close #1 + GetKey "" + CloseWindow ErrWin + End If + ElseIf RTrim$(Equip.Note2) = "LOCKED" Then + ErrWin = ExplodeWindow(7, 15, 50, 4, 15, 4, DoubleFrame, "ERROR!", 1, "") + WinPrintCenter ErrWin, 1, "You cannot change this record at this time." + WinPrintCenter ErrWin, 2, "Another user is accessing it." + WinPrintCenter ErrWin, 4, "" + GetKey "" + CloseWindow ErrWin + Close #1 + End If + Else + ErrWin = ExplodeWindow(7, 15, 50, 3, 15, 4, DoubleFrame, "ERROR!", 1, "") + WinPrintCenter ErrWin, 1, "You cannot change a nonexistent item!" + WinPrintCenter ErrWin, 3, "" + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + PUnlock flag + Close #1 + GetKey "" + CloseWindow ErrWin + End If + End If + Loop + Exit Sub + + ShowChangeChoices: + For t = 1 To MAXRECS + Model$(t) = "" + Next + ShowFlag = 0 + + Serial$ = RTrim$(Equip.SerialNumber) + Item$ = RTrim$(Equip.Item) + Model$ = RTrim$(Equip.Model) + Department$ = RTrim$(Equip.Department) + Location$ = RTrim$(Equip.Location) + Create$ = RTrim$(UCase$(Equip.Note1)) + + + NumberOfChoices = 0 + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + num.recs = LOF(1) / EquipLength + For count = 1 To num.recs + Get #1, count, Equip + If Asc(Equip.Department) <> 255 Then + CurrentInfo$ = UCase$(RTrim$(Equip.Department)) + For t = 1 To NumberOfChoices + If CurrentInfo$ = Model$(t) Then + ShowFlag = 1 + Exit For + End If + Next + If ShowFlag = 0 Then + ShowFlag = 0 + Model$(NumberOfChoices + 1) = CurrentInfo$ + NumberOfChoices = NumberOfChoices + 1 + Else + ShowFlag = 0 + End If + End If + Next + Close #1 + + Equip.SerialNumber = Serial$ + Equip.Item = Item$ + Equip.Model = Model$ + Equip.Location = Location$ + Equip.Note1 = Create$ + + If NumberOfChoices > 18 Then NumberOfChoices = 18 + + Model$(NumberOfChoices + 1) = "None!" + + NewChoice = Menu(NewChoice, 4, 4, 10, MenuC1, MenuC2, Model$(), Hot$, NumberOfChoices + 1) + + Move$ = "" + + If NewChoice = NumberOfChoices + 1 Or NewChoice < 1 Then Department$ = "": Return + + Department$ = RTrim$(Model$(NewChoice)) + + Return +End Sub + +Sub ChangeSortField + Dim Item$(6) + + Item$(1) = " Serial Number" + Item$(2) = " Item Description" + Item$(3) = " Model Number" + Item$(4) = " Department" + Item$(5) = " Location" + Item$(6) = " Quit!" + Hot$ = "SIMDLQ" + + NewChoice = SortField + + NewChoice = Menu(NewChoice, 7, 10, 19, MenuC1, MenuC2, Item$(), Hot$, 6) + + If NewChoice > 5 Or NewChoice < 1 Then + Exit Sub + ElseIf NewChoice < 6 Then + SortField = NewChoice + End If + + Open Directory$ + Left$(IDNum$, 8) + ".INI" For Output As #1 + Print #1, SortField + Close #1 + +End Sub + +Sub ClearKey + Do Until InKey$ = "": Loop +End Sub + +Sub ClearRandom + Kill Directory$ + "INVENRAN.DAT" + + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + For count = 1 To STARTMAX + Get #1, count, Equip + Equip.SerialNumber = Chr$(255) + Equip.Item = Chr$(255) + Equip.Model = Chr$(255) + Equip.Department = Chr$(255) + Equip.Location = Chr$(255) + Equip.Note1 = Chr$(255) + Equip.Note2 = Chr$(255) + Put #1, count, Equip + Next + Close #1 +End Sub + +Sub ClearTemp + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + For count = 1 To MAXRECS + Get #1, count, Equip + If Asc(Equip.SerialNumber) <> 255 Then + Equip.SerialNumber = Chr$(255) + Equip.Item = Chr$(255) + Equip.Model = Chr$(255) + Equip.Department = Chr$(255) + Equip.Location = Chr$(255) + Equip.Note1 = Chr$(255) + Equip.Note2 = Chr$(255) + Put #1, count, Equip + End If + Next + Close #1 +End Sub + +Sub CloseAll + For i = 1 To WinCount + CloseWindow WinCount + Next +End Sub + +Sub CloseWindow (WinNumber) + If WinNumber = 0 Then Exit Sub + If WinNumber > WinCount Then Exit Sub + For count = WinNumber To WinCount + Handle(count) = Handle(count + 1) + Next + WinCount = WinCount - 1 + If redraw = 1 Then RedrawAll +End Sub + +Sub DeleteRecord + Do Until finished = TRUE + MoveFile + + Sort 6, SortField, MAXRECS + + flag1 = Browse(flag1, 3, 5, 69, 15, 1, " ", 5, Locs(), Title$(), MAXRECS, "Delete a Record - to Delete") + + If flag1 = -1 Then + finished = TRUE + End If + + If finished = FALSE Then + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + Get #1, flag1, Equip + Close #1 + flag = Val(Equip.Note1) + + If Asc(Equip.SerialNumber) <> 255 And Move$ = Chr$(13) Then + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + Get #1, flag, Equip + Close #1 + Create$ = RTrim$(UCase$(Equip.Note1)) + + If RTrim$(Equip.Note2) <> "LOCKED" Then + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + PLock flag + Get #1, flag, Equip + Close #1 + If IDNum$ = Create$ Or IDNum$ = "MANAGER" Then + + AskWin = ExplodeWindow(6, 7, 20, 1, InfoC1, InfoC2, DoubleFrame, "Delete", 1, "") + WinPrintCenter AskWin, 1, "Are you sure? " + + Ask$ = "" + Do While UCase$(Ask$) <> "Y" And UCase$(Ask$) <> "N" + Kbd$ = GetString$(AskWin, 1, 17, "", Ask$, 1, 1) + Ask$ = UCase$(Ask$) + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + For t = 1 To LOF(1) / EquipLength + Get #1, t, Equip + If RTrim$(Equip.SerialNumber) = RTrim$(Serial$) Then + flag = t + Exit For + End If + Next + + If Ask$ = "Y" Then + Equip.SerialNumber = Chr$(255) + Equip.Item = Chr$(255) + Equip.Model = Chr$(255) + Equip.Department = Chr$(255) + Equip.Location = Chr$(255) + Equip.Note1 = Chr$(255) + Equip.Note2 = "" + Put #1, flag, Equip + ElseIf Ask$ = "N" Then + PUnlock flag + End If + + Close #1 + Loop + + CloseWindow AskWin + Else + ErrWin = ExplodeWindow(8, 5, 41, 5, 15, 4, DoubleFrame, "ERROR!", 1, "") + WinPrintCenter ErrWin, 1, "Your ID number does not match up with" + WinPrintCenter ErrWin, 2, "the ID number that created this item." + WinPrintCenter ErrWin, 3, "Therefore, YOU CANNOT DELETE THIS ITEM!" + WinPrintCenter ErrWin, 5, "" + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + PUnlock flag + Close #1 + GetKey "" + CloseWindow ErrWin + End If + ElseIf RTrim$(Equip.Note2) = "LOCKED" Then + ErrWin = ExplodeWindow(7, 15, 50, 4, 15, 4, DoubleFrame, "ERROR!", 1, "") + WinPrintCenter ErrWin, 1, "You cannot change this record at this time." + WinPrintCenter ErrWin, 2, "Another user is accessing it." + WinPrintCenter ErrWin, 4, "" + GetKey "" + CloseWindow ErrWin + End If + ElseIf Asc(Equip.SerialNumber) = 255 Then + ErrWin = ExplodeWindow(7, 15, 50, 3, 15, 4, DoubleFrame, "ERROR!", 1, "") + WinPrintCenter ErrWin, 1, "You cannot delete a nonexistent item!" + WinPrintCenter ErrWin, 3, "" + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + PUnlock flag + Close #1 + GetKey "" + CloseWindow ErrWin + End If + End If + Loop +End Sub + +Sub DrawFrame (WinNumber) + X = Handle(WinNumber).XPos + Y = Handle(WinNumber).YPos + L = Handle(WinNumber).Length + H = Handle(WinNumber).Height + F = Handle(WinNumber).Foreground + B = Handle(WinNumber).Background + Frame$ = Handle(WinNumber).Frame + + If X = 0 Or Y = 0 Or L = 0 Or H = 0 Or RTrim$(Frame$) = "" Then Exit Sub + + Color F, B + Locate X, Y + Print Left$(Frame$, 1); String$(L, Right$(Frame$, 1)); Mid$(Frame$, 2, 1); + For count = 1 To H + Locate X + count, Y + Print Mid$(Frame$, 5, 1); + Locate X + count, Y + L + 1 + Print Mid$(Frame$, 5, 1); + Next + Locate X + count, Y + Print Mid$(Frame$, 3, 1); String$(L, Right$(Frame$, 1)); Mid$(Frame$, 4, 1); +End Sub + +Sub DrawShadow (WinNumber) + X = Handle(WinNumber).XPos + Y = Handle(WinNumber).YPos + F = Handle(WinNumber).Foreground + B = Handle(WinNumber).Background + L = Handle(WinNumber).Length + H = Handle(WinNumber).Height + Shadow = Handle(WinNumber).Shadow + Shad$ = Handle(WinNumber).ShadChar + + If Shadow = 1 Then + Color 7, 0 + YY = Y + L + 2 + XX = X + For cnt = 1 To H + 1 + Locate XX + cnt, YY + Print String$(2, Shad$); + Next + If X + H + 2 <= 25 Then Locate X + H + 2, Y + 2: Print String$(L + 2, Shad$); + Color F, B + End If +End Sub + +Sub DrawTitle (WinNumber) + X = Handle(WinNumber).XPos + Y = Handle(WinNumber).YPos + L = Handle(WinNumber).Length + F = Handle(WinNumber).Foreground + B = Handle(WinNumber).Background + Title$ = Handle(WinNumber).Title + If RTrim$(Title$) = "" Then Exit Sub + + Color F, B + + If RTrim$(Title$) <> "" And Len(RTrim$(Title$)) < (L - 2) Then + YY = (Int(L / 2)) - (Int(Len(RTrim$(Title$)) / 2)) + Locate X, Y + YY: Print " "; RTrim$(Title$); " "; + End If +End Sub + +Sub EditMenu + Dim MenuItem$(6) + + MenuItem$(1) = " Enter new Item..." + MenuItem$(2) = " Delete Item(s)..." + MenuItem$(3) = " Change Item(s)..." + MenuItem$(4) = "" + MenuItem$(5) = " Browse through specified Items..." + MenuItem$(6) = " Browse through all Items" + Hot$ = "EDC SA" + + Do Until NewChoice < 0 + Color MenuC2, MenuC1 + Locate 1, 11 + Print " Edit " + + NewChoice = Menu(NewChoice, 2, 10, 36, MenuC1, MenuC2, MenuItem$(), Hot$, 6) + + Select Case NewChoice + Case 1 + AddRecord + Case 2 + DeleteRecord + Case 3 + ChangeRecord + Case 5 + SelectBrowse + Case 6 + ShowAll + Case -2 + subchoice = -2 + Case -3 + subchoice = -3 + Case Else + End Select + Loop +End Sub + +Sub Ending + WinRedraw 0 + FinalWindow = ExplodeWindow(5, 20, 40, 9, MenuC1, MenuC2, DoubleFrame, "Goodbye!", 1, "") + WinPrintCenter FinalWindow, 1, "Thank you for using the" + WinPrintCenter FinalWindow, 2, "Ŀ" + WinPrintCenter FinalWindow, 3, " " + WinPrintCenter FinalWindow, 4, "" + WinPrintCenter FinalWindow, 5, "Your records are safe with us!" + WinPrintCenter FinalWindow, 8, "(c)Copyright 1993 by Nathan Thomas" + WinPrintCenter FinalWindow, 9, "All Rights Reserved" + FinalWindow1 = MakeWindow(7, 23, 35, 1, ManipulateC2, ManipulateC1, "", "", 0, "") + WinPrintCenter FinalWindow1, 1, "I N V E N T O R Y M A N A G E R" + Sleep 4 + redraw = 0 + CloseAll + ClearKey + Color 7, 0 + Cls + Kill Directory$ + RanFile$ + End +End Sub + +Function ExplodeWindow% (X, Y, L, H, Fore, Back, Frame$, Title$, Shadow, ShadChar$) + Dur = Int(Dur) + If Dur < 1 Then Dur = 1 + WinCount = WinCount + 1 + Handle(WinCount).XPos = X + Handle(WinCount).YPos = Y + Handle(WinCount).Length = L + Handle(WinCount).Height = H + Handle(WinCount).Foreground = Fore + Handle(WinCount).Background = Back + Handle(WinCount).Frame = Frame$ + Handle(WinCount).Title = Title$ + Handle(WinCount).Shadow = Shadow + Handle(WinCount).ShadChar = ShadChar$ + Handle(WinCount).Buffer = "" + + Color Fore, Back + L1 = 0 + H1 = 0 + X1 = X + Int(H / 2) + 1 + Y1 = Y + Int(L / 2) + Do + Locate X1, Y1 + Print Left$(Frame$, 1); String$(L1, Right$(Frame$, 1)); Mid$(Frame$, 2, 1); + For count = 1 To H1 + Locate X1 + count, Y1 + Print Mid$(Frame$, 5, 1); Space$(L1); Mid$(Frame$, 5, 1); + Next + Locate X1 + count, Y1 + Print Mid$(Frame$, 3, 1); String$(L1, Right$(Frame$, 1)); Mid$(Frame$, 4, 1); + + If L1 = L And H1 = H And X1 = X And Y1 = Y Then Exit Do + + If L1 + (Dur * 2) > L Then + L1 = L + Else + L1 = L1 + (Dur * 2) + End If + + If Y1 - Dur < Y Then + Y1 = Y + Else + Y1 = Y1 - Dur + End If + + If H1 + Dur > H Then + H1 = H + Else + H1 = H1 + Dur + End If + + If X1 - Dur < X Then + X1 = X + Else + X1 = X1 - Dur + End If + For t = 1 To 500: Next + Loop + ExplodeWindow% = WinCount + DrawTitle WinCount + DrawShadow WinCount +End Function + +Sub FileMenu + Dim MenuItem$(6) + + MenuItem$(1) = " Clear Data File" + MenuItem$(2) = "" + MenuItem$(4) = "" + MenuItem$(5) = " DOS Shell" + MenuItem$(6) = " Exit" + Hot$ = "C D SX" + + Do Until NewChoice < 0 + DD$ = Left$(Directory$ + " ", 20) + If Len(DD$) < Len(Directory$) Then + DD$ = Left$(DD$, 19) + Chr$(16) + End If + + MenuItem$(3) = " Directory " + DD$ + + Color MenuC2, MenuC1 + Locate 1, 5 + Print " File " + + NewChoice = Menu(NewChoice, 2, 4, 38, MenuC1, MenuC2, MenuItem$(), Hot$, 6) + + Select Case NewChoice + Case 1 + ClearRandom + Case 3 + ChangeDir + Case 5 + Color 7, 0 + Cls + Color MenuC1, MenuC2 + Locate 8, 1: Print "Type EXIT to return to the Inventory Manager" + Shell + Locate 25, 30: Print "Press any key to return to the INVENTORY MANAGER..."; + GetKey "" + RedrawAll + Case 6 + CloseAll + Ending + Case -2 + subchoice = -2 + Case -3 + subchoice = -3 + Case Else + End Select + Loop +End Sub + +Sub GenerateRandomFile + Randomize Timer + For t = 1 To 8 + cc = Int(Rnd(1) * 25) + 65 + RanFile$ = RanFile$ + Chr$(cc) + Print Chr$(cc); + Next + RanFile$ = RanFile$ + ".TMP" +End Sub + +Sub GetDirectory + Shell "cd > CURRDIR" + Open "CURRDIR" For Input As #1 + Line Input #1, Directory$ + Close #1 + Kill "CURRDIR" + + If Right$(Directory$, 1) <> "\" And Directory$ <> "" Then + Directory$ = UCase$(Directory$) + "\" + End If +End Sub + +Sub GetKey (Char$) + ClearKey + + Char$ = "" + Do Until Char$ <> "" + Char$ = InKey$ + Loop +End Sub + +Function GetString$ (WinNumber, row, col, Start$, end$, Vis, MAX) + Move$ = "" + If WinNumber > WinCount Then Exit Function + If WinNumber = 0 Then Exit Function + + X = Handle(WinNumber).XPos + Y = Handle(WinNumber).YPos + F = Handle(WinNumber).Foreground + B = Handle(WinNumber).Background + row = row + X + col = col + Y + + curr$ = Left$(Start$, MAX) + If curr$ = Chr$(8) Then curr$ = "" + + Locate , , 1 + Color F, B + + finished = FALSE + Do + GoSub GetStringShowText + Kbd$ = "" + GetKey Kbd$ + Locate , , 1 + + Select Case Kbd$ + Case Chr$(0) + Chr$(15) + Move$ = "BKTAB" + finished = TRUE + + Case Chr$(9) + Move$ = "TAB" + finished = TRUE + + Case Chr$(27) + Move$ = "ESC" + finished = TRUE + + Case Chr$(13) + Move$ = "RET" + finished = TRUE + GetString$ = Kbd$ + + Case Chr$(27) + finished = TRUE + GetString$ = Kbd$ + Move$ = Kbd$ + + Case Chr$(8) + If curr$ <> "" Then + curr$ = Left$(curr$, Len(curr$) - 1) + Else + Sound 1900, .2 + End If + + Case " " To Chr$(255) + If Len(curr$) < MAX Then + curr$ = curr$ + Kbd$ + Else + Sound 1900, .2 + End If + + Case Else + Sound 1900, .2 + End Select + + Loop Until finished + + end$ = curr$ + + Locate , , 0 + Color F, B + Exit Function + + GetStringShowText: + Locate row, col, 0 + Color F, B + If Len(curr$) > Vis Then + WinPrint WinNumber, row - X, col - Y, Right$(curr$, Vis) + Else + WinPrint WinNumber, row - X, col - Y, curr$ + String$(Vis - Len(curr$), "_") + Locate row, col + Len(curr$) + End If + Locate , , 1 + Return +End Function + +Sub Intro + FirstWin = ExplodeWindow(4, 18, 47, 9, 0, 7, SingleFrame, "Welcome!", 1, "") + WinPrintCenter FirstWin, 2, "Welcome to Inventory Manager" + WinPrintCenter FirstWin, 4, "Copyright (C) Nathan Thomas, 1993." + WinPrintCenter FirstWin, 5, "All Rights Reserved." + WinPrintCenter FirstWin, 7, String$(47, 196) + WinPrintCenter FirstWin, 8, "Developed for NorthWest High School" + WinPrintCenter FirstWin, 9, "Programmed by Nathan Thomas" + + + InputWin = ExplodeWindow(16, 35, 34, 1, ManipulateC1, ManipulateC2, DoubleFrame, "", 1, "") + WinPrint InputWin, 1, 3, "Enter your login ID:__________" + + Do Until IDNum$ <> "" And Pass$ = "INVENTORY" + IDNum$ = UCase$(Environ$("ID")) + Kbd$ = GetString$(InputWin, 1, 23, IDNum$, IDNum$, 10, 10) + IDNum$ = UCase$(RTrim$(IDNum$)) + + If IDNum$ = "MANAGER" Then + PassWin = ExplodeWindow(17, 38, 34, 1, MenuC1, MenuC2, DoubleFrame, "", 1, "") + WinPrint PassWin, 1, 3, "Enter the password:_________" + Kbd$ = GetString$(PassWin, 1, 22, "", Pass$, 10, 10) + Pass$ = UCase$(RTrim$(Pass$)) + If Pass$ <> "INVENTORY" Then CloseWindow PassWin + Else + Pass$ = "INVENTORY" + End If + Loop + + redraw = 0 + CloseAll + redraw = 1 + RedrawAll + + WinInfo = MakeWindow(24, 0, 80, 1, InfoC1, InfoC2, "", "", 0, "") + ShowMessage "Inventory Manager (c)Copyright 1993 by Nathan Thomas" + + BarWin = MakeWindow(0, 0, 80, 1, MenuC1, MenuC2, "", "", 0, "") + WinPrint BarWin, 1, 1, " File Edit Print Options" + WinPrint BarWin, 1, 61, "Temp: " + RanFile$ + WinPrint BarWin, 1, (60 - Len(IDNum$)), IDNum$ + SortField = 1 + + Open Directory$ + Left$(IDNum$, 8) + ".INI" For Input As #1 + Input #1, SortField + Close #1 +End Sub + +Function MakeWindow% (X, Y, L, H, Fore, Back, Frame$, Title$, Shadow, ShadChar$) + WinCount = WinCount + 1 + Handle(WinCount).XPos = X + Handle(WinCount).YPos = Y + Handle(WinCount).Length = L + Handle(WinCount).Height = H + Handle(WinCount).Foreground = Fore + Handle(WinCount).Background = Back + Handle(WinCount).Frame = Frame$ + Handle(WinCount).Title = Title$ + Handle(WinCount).Shadow = Shadow + Handle(WinCount).ShadChar = ShadChar$ + Handle(WinCount).Buffer = "" + + Color Fore, Back + If redraw = 1 Then + DrawFrame WinCount + DrawTitle WinCount + DrawShadow WinCount + For t = 1 To H + Locate X + t, Y + 1 + Print Space$(L); + Next + End If + MakeWindow% = WinCount +End Function + +Function Menu% (currChoice, X, Y, Length, Fg, Bg, Item$(), Hot$, NumOfItems) + + Hot$ = UCase$(Hot$) + If RTrim$(Hot$) <> "" Then Length = Length + 1 + + Height = NumOfItems + + MenuWin = MakeWindow(X, Y, Length, Height, Fg, Bg, DoubleFrame, "", 1, "") + For t = 1 To NumOfItems + Item$(t) = Left$(Item$(t) + Space$(Length), Length) + If RTrim$(Hot$) <> "" And Mid$(Hot$, t, 1) <> " " Then + Item$(t) = Left$(Item$(t), Length - 1) + Mid$(Hot$, t, 1) + " " + ElseIf Left$(Item$(t), 1) = "" Then + Item$(t) = Left$(Item$(t), Length - 1) + "" + End If + WinPrint MenuWin, t, 1, Item$(t) + Next + + If currChoice = 0 Then currChoice = 1 + + redraw = 0 + MenuWin1 = MakeWindow(X + currChoice - 1, Y, Length, 1, Bg, Fg, "", "", 0, "") + redraw = 1 + + finished = FALSE + Do Until finished = TRUE + WinRedraw MenuWin + WinPrint MenuWin1, 1, 1, Item$(currChoice) + + GetKey Kbd$ + Kbd$ = UCase$(Kbd$) + + Select Case Kbd$ + Case Chr$(0) + "H" + currChoice = currChoice - 1 + If currChoice = 0 Then currChoice = NumOfItems + If Left$(Item$(currChoice), 1) = "" Or Left$(Item$(currChoice), 1) = "" Then + currChoice = currChoice - 1 + End If + + Case Chr$(0) + "P" + currChoice = currChoice + 1 + If currChoice = NumOfItems + 1 Then currChoice = 1 + If Left$(Item$(currChoice), 1) = "" Or Left$(Item$(currChoice), 1) = "" Then + currChoice = currChoice + 1 + End If + + Case Chr$(0) + "K" + currChoice = -2 + finished = TRUE + + Case Chr$(0) + "M" + currChoice = -3 + finished = TRUE + + Case Chr$(13) + finished = TRUE + + Case "A" To "z" + GoSub GetHotKey + + Case Else + Sound 1900, .2 + End Select + + Handle(MenuWin1).XPos = X + currChoice - 1 + Handle(MenuWin1).YPos = Y + Loop + redraw = 0 + CloseWindow MenuWin1 + CloseWindow MenuWin + redraw = 1 + RedrawAll + Menu% = currChoice + Exit Function + + GetHotKey: + For MB = 1 To NumOfItems + If UCase$(Mid$(Hot$, MB, 1)) = UCase$(Kbd$) Then + finished = TRUE + + If MB <> currChoice Then + Handle(MenuWin1).XPos = X + MB - 1 + Handle(MenuWin1).YPos = Y + WinRedraw MenuWin + WinPrint MenuWin1, 1, 1, Item$(MB) + For t = 1 To 12000: Next + End If + + currChoice = MB + End If + Next + Return + +End Function + +Sub MoveFile + CalcMax + HoldOn = ExplodeWindow(10, 26, 27, 2, 0, 7, SingleFrame, "", 1, "") + WinPrintCenter HoldOn, 1, "Updating..." + WinPrint HoldOn, 2, 3, "[] 0% " + + Kill Directory$ + RanFile$ + + st$ = "copy " + Directory$ + "INVENRAN.DAT " + Directory$ + RanFile$ + " > NUL" + + Locate , , , 16, 16 + Shell st$ + Locate , , , 11, 12 + + Interval = Int(MAXRECS / 15) + + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + For count = 1 To MAXRECS + Get #1, count, Equip + Equip.Note1 = Str$(count) + Equip.Note2 = "" + Put #1, count, Equip + + If count = count1 + Interval Then + WinPrint HoldOn, 2, 22, LTrim$(RTrim$(Str$(Int(100 * (count / MAXRECS))))) + "%" + If NumOfCounts < 15 Then WinPrint HoldOn, 2, 4 + NumOfCounts, PercentageChar$ + count1 = count + NumOfCounts = NumOfCounts + 1 + End If + Next + WinPrint HoldOn, 2, 3, "[" + String$(15, PercentageChar$) + "] 100%" + Close #1 + + CloseWindow HoldOn +End Sub + +Sub Optimize + CalcMax + Kill Directory$ + RanFile$ + + st$ = "copy " + Directory$ + "INVENRAN.DAT " + Directory$ + RanFile$ + " > NUL" + + Locate , , , 16, 16 + Shell st$ + Locate , , , 11, 12 + + Sort 7, SortField, MAXRECS + + Kill Directory$ + "INVENRAN.DAT" + + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + num.recs = LOF(1) / EquipLength + Open Directory$ + "INVENRAN.DAT" For Random As #2 Len = EquipLength + For count = 1 To num.recs + Get #1, count, Equip + If Asc(Equip.SerialNumber) <> 255 Then + Put #2, count, Equip + End If + Next + Close #2 + Close #1 +End Sub + +Sub OptionsMenu + Dim MenuItem$(3) + + Do Until NewChoice < 0 + + MenuItem$(1) = " Change Sort Field..." + If MenuC1 = 15 Then + CSys$ = "Color" + Else + CSys$ = "Monochrome" + End If + MenuItem$(2) = " Toggle Colors " + Right$(" " + CSys$, 10) + MenuItem$(3) = " Optimize" + Hot$ = "CTO" + + If IDNum$ = "MANAGER" Then ccs = 3 Else ccs = 2 + + Color MenuC2, MenuC1 + Locate 1, 24 + Print " Options " + + NewChoice = Menu(NewChoice, 2, 23, 30, MenuC1, MenuC2, MenuItem$(), Hot$, ccs) + + Select Case NewChoice + Case 1 + ChangeSortField + Case 2 + If CSys$ = "Color" Then + MenuC1 = 0 + Handle(2).Foreground = 0 + MenuC2 = 7 + Handle(2).Background = 7 + ManipulateC1 = 0 + ManipulateC2 = 7 + InfoC1 = 0 + Handle(1).Foreground = 0 + InfoC2 = 7 + Handle(1).Background = 7 + Else + MenuC1 = 15 + Handle(2).Foreground = 15 + MenuC2 = 4 + Handle(2).Background = 4 + ManipulateC1 = 1 + ManipulateC2 = 3 + InfoC1 = 7 + Handle(1).Foreground = 7 + InfoC2 = 1 + Handle(1).Background = 1 + End If + RedrawAll + Case 3 + Optimize + Case -2 + subchoice = -2 + Case -3 + subchoice = -3 + Case Else + End Select + Loop +End Sub + +Sub PLock (RecordNum) + Get #1, RecordNum, Equip + Equip.Note2 = "LOCKED" + Put #1, RecordNum, Equip +End Sub + +Sub PrintAll + PrintErr = FALSE + LPrint + If PrintErr = TRUE Then Exit Sub + + ShowMessage "Printing all Records..." + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + For count = 1 To MAXRECS + Get #1, count, Equip + flag = Val(Equip.Note1) + If Asc(Equip.SerialNumber) <> 255 Then + SendToPrinter flag + End If + Next + Close #1 + ShowMessage "Inventory Manager (c)Copyright 1993 by Nathan Thomas" +End Sub + +Sub PrintMenu + Dim MenuItem$(2) + + MenuItem$(1) = " Print All Records" + MenuItem$(2) = " Form Feed Printer" + Hot$ = "PF" + + Do Until NewChoice < 0 + Color MenuC2, MenuC1 + Locate 1, 17 + Print " Print " + + NewChoice = Menu(NewChoice, 2, 16, 20, MenuC1, MenuC2, MenuItem$(), Hot$, 2) + + Select Case NewChoice + Case 1 + MoveFile + PrintAll + Case 2 + LPrint Chr$(12) + PrintedLines = 0 + Case -2 + subchoice = -2 + Case -3 + subchoice = -3 + Case Else + End Select + Loop +End Sub + +Sub PUnlock (RecordNum) + Get #1, RecordNum, Equip + Equip.Note2 = Chr$(255) + Put #1, RecordNum, Equip +End Sub + +Sub RedrawAll + For WCount = 0 To WinCount + WinRedraw WCount + Next + Color 7, 0 +End Sub + +Sub SelectBrowse + Dim MenuItem$(4) + + MenuItem$(1) = " Show by Model" + MenuItem$(2) = " Show by Location" + MenuItem$(3) = " Show by Department" + MenuItem$(4) = " Quit!" + Hot$ = "MLDQ" + + Do Until NewChoice = 4 + ShowFlag = 0 + NewChoice = Menu(NewChoice, 7, 10, 21, MenuC1, MenuC2, MenuItem$(), Hot$, 4) + + ClearTemp + + Select Case NewChoice + + Case 1 + InputWin = ExplodeWindow(6, 10, 41, 1, InfoC1, InfoC2, DoubleFrame, "Browse Model Type", 1, "") + WinPrintCenter InputWin, 1, "Enter the model number: " + Kbd$ = GetString$(InputWin, 1, 28, "", Model$, 10, 10) + Model$ = RTrim$(UCase$(Model$)) + CloseWindow InputWin + + If Model$ <> "" Then + ShowFlag = 1 + count = 1 + ShowMessage "Searching..." + CalcMax + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + Open Directory$ + RanFile$ For Random As #2 Len = EquipLength + For count1 = 1 To MAXRECS + Get #1, count1, Equip + If RTrim$(UCase$(Equip.Model)) = Model$ Then + Equip.Note1 = Str$(count1) + Put #2, count, Equip + count = count + 1 + End If + Next + Close #2 + Close #1 + End If + + Case 2 + InputWin = ExplodeWindow(6, 10, 41, 1, InfoC1, InfoC2, DoubleFrame, "Browse Location", 1, "") + WinPrintCenter InputWin, 1, "Enter the Location: " + Kbd$ = GetString$(InputWin, 1, 26, "", Location$, 10, 10) + Location$ = RTrim$(UCase$(Location$)) + If Location$ = "" Then CloseWindow InputWin: Return + CloseWindow InputWin + + If Location$ <> "" Then + ShowFlag = 1 + count = 1 + ShowMessage "Searching..." + CalcMax + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + Open Directory$ + RanFile$ For Random As #2 Len = EquipLength + For count1 = 1 To MAXRECS + Get #1, count1, Equip + If Left$(RTrim$(UCase$(Equip.Location)), Len(Location$)) = Location$ Then + Equip.Note1 = Str$(count1) + Put #2, count, Equip + count = count + 1 + End If + Next + Close #2 + Close #1 + End If + + Case 3 + InputWin = ExplodeWindow(6, 10, 41, 1, InfoC1, InfoC2, DoubleFrame, "Browse Department", 1, "") + WinPrintCenter InputWin, 1, "Enter the Department: " + Kbd$ = GetString$(InputWin, 1, 27, "", Department$, 10, 10) + Department$ = RTrim$(UCase$(Department$)) + If Department$ = "" Then CloseWindow InputWin: Return + CloseWindow InputWin + + If Department$ <> "" Then + ShowFlag = 1 + count = 1 + ShowMessage "Searching..." + CalcMax + Open Directory$ + "INVENRAN.DAT" For Random As #1 Len = EquipLength + Open Directory$ + RanFile$ For Random As #2 Len = EquipLength + For count1 = 1 To MAXRECS + Get #1, count1, Equip + If Left$(RTrim$(UCase$(Equip.Department)), Len(Department$)) = Department$ Then + Equip.Note1 = Str$(count1) + Put #2, count, Equip + count = count + 1 + End If + Next + Close #2 + Close #1 + End If + + Case 4 + Exit Sub + Case Else + NewChoice = 1 + + End Select + + ShowMessage "Inventory Manager (c)Copyright 1993 by Nathan Thomas" + If ShowFlag = 1 Then + If choice < 4 And (count - 1 > 0) Then + Sort 6, SortField, count - 1 + + Do + flag1 = Browse(flag1, 3, 5, 69, 15, 1, "", 5, Locs(), Title$(), count - 1, "Browse through Items -

to print record / to print all") + If flag1 = -1 Then Exit Do + + If Move$ = "P" Then + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + Get #1, flag1, Equip + Close #1 + + If Val(Equip.Note1) <> 0 Then + flag = Val(Equip.Note1) + SendToPrinter flag + End If + ElseIf Move$ = "A" Then + PrintAll + End If + Loop + End If + End If + Loop +End Sub + +Sub SendToPrinter (RecordNum) + PrintErr = FALSE + + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + Get #1, RecordNum, Equip + Close #1 + + LPrint + If PrintErr = FALSE Then + PrintWin = ExplodeWindow(9, 27, 25, 3, ManipulateC1, ManipulateC2, DoubleFrame, "Print", 1, "") + WinPrintCenter PrintWin, 2, "Printing Record:" + Str$(RecordNum) + + LPrint "Ŀ"; + LPrint " Serial Number:"; Equip.SerialNumber; " Item Description:"; Equip.Item; " "; + LPrint "Ĵ"; + LPrint " Model:"; Equip.Model; " Department:"; Equip.Department; " Location:"; Equip.Location; " "; + LPrint ""; + CloseWindow PrintWin + End If +End Sub + +Sub ShowAll + + MoveFile + + Sort 6, SortField, MAXRECS + + Do + flag1 = Browse(flag1, 3, 5, 69, 15, 1, "", 5, Locs(), Title$(), MAXRECS, "Browse through Items -

to print / to print all") + If flag1 = -1 Then Exit Do + If Move$ = "P" Then + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + Get #1, flag1, Equip + Close #1 + + If Val(Equip.Note1) <> 0 Then + flag = Val(Equip.Note1) + SendToPrinter flag + End If + ElseIf Move$ = "A" Then + PrintAll + End If + Loop +End Sub + +Sub ShowMessage (Message$) + Message$ = RTrim$(LTrim$(Message$)) + + WinPrint 1, 1, 1, Space$(80) + WinPrintCenter 1, 1, Message$ + WinRedraw 1 +End Sub + +Sub Sort (NumOfFields, SortField, NumOfItems) + If SortField < 1 Then Exit Sub + + ShowMessage "Sorting..." + + Open Directory$ + RanFile$ For Random As #1 Len = EquipLength + num.recs = LOF(1) / EquipLength + + Offset = Int(num.recs / 2) + + Do While Offset > 0 + Limit = num.recs - Offset + Do + Switch = FALSE + + For X = 1 To Limit + Get #1, X, Equip + Info$(1, 1) = Equip.SerialNumber + Info$(2, 1) = Equip.Item + Info$(3, 1) = Equip.Model + Info$(4, 1) = Equip.Department + Info$(5, 1) = Equip.Location + Info$(6, 1) = Equip.Note1 + Info$(7, 1) = Equip.Note2 + Get #1, X + Offset, Equip + Info$(1, 2) = Equip.SerialNumber + Info$(2, 2) = Equip.Item + Info$(3, 2) = Equip.Model + Info$(4, 2) = Equip.Department + Info$(5, 2) = Equip.Location + Info$(6, 2) = Equip.Note1 + Info$(7, 2) = Equip.Note2 + + If UCase$(Info$(SortField, 1)) > UCase$(Info$(SortField, 2)) Then + For cnt = 1 To NumOfFields + Swap Info$(cnt, 1), Info$(cnt, 2) + Next + Equip.SerialNumber = Info$(1, 1) + Equip.Item = Info$(2, 1) + Equip.Model = Info$(3, 1) + Equip.Department = Info$(4, 1) + Equip.Location = Info$(5, 1) + Equip.Note1 = Info$(6, 1) + Equip.Note2 = Info$(7, 1) + Put #1, X, Equip + Equip.SerialNumber = Info$(1, 2) + Equip.Item = Info$(2, 2) + Equip.Model = Info$(3, 2) + Equip.Department = Info$(4, 2) + Equip.Location = Info$(5, 2) + Equip.Note1 = Info$(6, 2) + Equip.Note2 = Info$(7, 2) + Put #1, X + Offset, Equip + + Switch = X + End If + Next + + Limit = Switch - Offset + Loop While Switch + + Offset = Offset \ 2 + Loop + Close #1 + + ShowMessage "Inventory Manager (c)Copyright 1993 by Nathan Thomas" +End Sub + +Sub WindowInitialize + Cls + Locate 1, 1, 0, 11, 12 + View Print 1 To 25 + If BackChar$ = "" Then BackChar$ = " " + WinCount = -1 + redraw = 0 + FirstWin = MakeWindow(1, 0, 80, 23, Fore, Back, "", "", 0, "") + Handle(0).Buffer = String$(2000, BackChar$) + redraw = 1 + WinRedraw 0 + RedrawAll +End Sub + +Sub WinPrint (WinNumber, row, col, text$) + If WinNumber > WinCount Then Exit Sub + If WinNumber < 1 Then Exit Sub + X = Handle(WinNumber).XPos + Y = Handle(WinNumber).YPos + L = Handle(WinNumber).Length + H = Handle(WinNumber).Height + Buffer$ = Handle(WinNumber).Buffer + + For t = 1 To row - 1 + place = place + L + Next + place = place + col + + Mid$(Buffer$, place, Len(text$)) = text$ + Handle(WinNumber).Buffer = Buffer$ + + If redraw = 1 Then + If WinNumber = WinCount Then + X = Handle(WinNumber).XPos + Y = Handle(WinNumber).YPos + L = Handle(WinNumber).Length + H = Handle(WinNumber).Height + F = Handle(WinNumber).Foreground + B = Handle(WinNumber).Background + Buffer$ = Handle(WinNumber).Buffer + + Color F, B + + pl = 1 + For t = 1 To H + Locate X + t, Y + 1 + Print Mid$(Buffer$, pl, L); + pl = pl + L + Next + Else + WinRedraw WinNumber + End If + End If +End Sub + +Sub WinPrintCenter (WinNumber, X, text$) + L = Handle(WinNumber).Length + If Len(text$) > L Then text$ = Left$(text$, L) + Y = (Int(L / 2)) - (Int(Len(text$) / 2)) + 1 + WinPrint WinNumber, X, Y, text$ +End Sub + +Sub WinRedraw (WinNumber) + For i = WinNumber To WinCount + X = Handle(WinNumber).XPos + Y = Handle(WinNumber).YPos + L = Handle(WinNumber).Length + H = Handle(WinNumber).Height + F = Handle(WinNumber).Foreground + B = Handle(WinNumber).Background + Buffer$ = Handle(WinNumber).Buffer + + Color F, B + DrawFrame WinNumber + DrawTitle WinNumber + DrawShadow WinNumber + + pl = 1 + For t = 1 To H + Locate X + t, Y + 1 + Print Mid$(Buffer$, pl, L); + pl = pl + L + Next + Next +End Sub + diff --git a/samples/qb-nventory/src/nventory.zip b/samples/qb-nventory/src/nventory.zip new file mode 100644 index 0000000..29ca0a9 Binary files /dev/null and b/samples/qb-nventory/src/nventory.zip differ diff --git a/samples/qb-tank-commander/img/screenshot.png b/samples/qb-tank-commander/img/screenshot.png new file mode 100644 index 0000000..103ac61 Binary files /dev/null and b/samples/qb-tank-commander/img/screenshot.png differ diff --git a/samples/qb-tank-commander/index.md b/samples/qb-tank-commander/index.md new file mode 100644 index 0000000..2b9e3bc --- /dev/null +++ b/samples/qb-tank-commander/index.md @@ -0,0 +1,50 @@ +[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: QB TANK COMMANDER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Matthew River Knight](../matthew-river-knight.md) + +### Description + +```text +'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +' +' ±± ±± ±±±±±± ±±±±±± ±± ±±±±± ±±±±±± ±±± ±± ±±±±±± +' ±± ±± ±± ±± ±± ±± ±± ±± ±± ±± ±± ±± ±± ±± +' ±±±±±±±± ±± ±± ±±±±±± ±± ±± ±± ±± ±± ±±±± ±±±± +' ±± ±± ±± ±± ±± ±± ±± ±± ±± ±± ±± ±±± ±± +' ±± ±± ±±±±±± ±± ±± ±± ±±±±±± ±±±±±± ±± ±± ±±±±± +' +' I N T E R A C T I V E E N T E R T A I N M E N T - 1 9 9 9 +' +' +' Game Name: Qbasic TANK COMMANDER version 2 +' Programmer: Matthew River Knight +' Completed: August 15, 1999 +' +' +'This game is a remake of the last TANK COMMANDER, having been improved and +'modified a great deal. The sprites now move very fluidly and without any +'flicker on 286 PCs and up. The code is also alot smaller than the last +'version and has been made as readable and easy to edit as possible. +' +' * * * * +' +'This is a two player game in which you and a friend drive about the arena +'in tanks trying to blow eachother up. You both have very powerfull tanks +'capable of driving through anything in your path. Even the most secure of +'fortresses stands no chance against these armoured beasts. Each of the tanks +'is equipt with powerfull bomb launchers, capable of blowing up the other +'tank beyond repair, with a single strike. +``` + +### File(s) + +* [tcv2.bas](src/tcv2.bas) +* [tcv2.zip](src/tcv2.zip) + +🔗 [game](../game.md), [tank](../tank.md) diff --git a/samples/qb-tank-commander/src/tcv2.bas b/samples/qb-tank-commander/src/tcv2.bas new file mode 100644 index 0000000..7ffec04 --- /dev/null +++ b/samples/qb-tank-commander/src/tcv2.bas @@ -0,0 +1,423 @@ +'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +' +' +' +' +' +' +' +' I N T E R A C T I V E E N T E R T A I N M E N T - 1 9 9 9 +' +' +' Game Name: Qbasic TANK COMMANDER version 2 +' Programmer: Matthew River Knight +' Completed: August 15, 1999 +' +' +'This game is a remake of the last TANK COMMANDER, having been improved and +'modified a great deal. The sprites now move very fluidly and without any +'flicker on 286 PCs and up. The code is also alot smaller than the last +'version and has been made as readable and easy to edit as possible. +' +' * * * * +' +'This is a two player game in which you and a friend drive about the arena +'in tanks trying to blow eachother up. You both have very powerfull tanks +'capable of driving through anything in your path. Even the most secure of +'fortresses stands no chance against these armoured beasts. Each of the tanks +'is equipt with powerfull bomb launchers, capable of blowing up the other +'tank beyond repair, with a single strike. +' +'The keys for the game are pretty standard, and have been designed to allow +'both players to play at the same keyboard without getting in eachothers way. +'You MUST ensure that NUMLOCK is ON before running the game !!! The keys +'are as follows: +' +'BLUE TANK - up: 8 +' down: 2 +' left: 4 +' right: 6 +' brakes: 5 +' shoot: 0 +' +'GREEN TANK - up: Q +' down: A +' left: O +' right: P +' brakes: S +' shoot: SPACE BAR +' +' * * * * +' +'The graphics for this game have been BSAVEd, and thus have to be loaded +'directly into memory to be drawn. This presents quite a problem because +'Qbasic often has quite a bit of trouble locating files that need to be +'BLOADed. This problem may be corrected by reffering to line 122 where there +'is a CHDIR. All you have to do is type the directory in which this game +'resides into the "" marks. +' +'Another potential problem with this game is the delay loop, which controls +'how fast the program runs. This game was designed on a computer using a +'CYRIX MII300 CPU, a 4MB graphics accelerator card and 512K cache - your +'computer may be faster or slower, and thus, for example, if you have a +'PENTIUM III, clocked at 500MHZ, this game will run so fast that it will be +'unplayable. +' +'This problem could have been eliminated by adding a CPU independant delay +'into the code by testing how fast your CPU is, however this presents us with +'another problem: different versions of Qbasic tend to give different results +'for these kinds of tests, and thus the game would have run inconsistantly +'on different platforms, even if they were being run on exactly the same +'kind of system. Since I wanted this game to be playable on any version of +'Qbasic, I chose to let everybody set the delay loop themselves. +' +'The delay loop variable is on line 125, under the name of Speed. All you +'have to do is change what it is = to. The default setting is 550 which is +'perfect for my system when running the game under WINDOWS 95 and on a Qbasic +'4.5 platform. Just experiment with the setting until the game runs at a +'speed with which you are satisfied. Just remember that the lower the number +'Speed is = to, the faster the game is going to run! +' +' * * * * +' +'This game has been programmed from scratch by Matthew River Knight. All the +'code here is my own, with the exception of the FADE IN/OUT code which was +'kindly provided by Manny Najera of FLASH GAMES, on his web site. Any code +'that you find usefull in this game may be taken. The graphics files used +'in this game may not be taken, however. Please give this game to anybody, +'and everybody, though if you do, please DO NOT give them a modified version, +'and DO NOT remove this text! I spent ages making the code the way it is and +'personally I am very proud of it. Please leave it as it is! +' +'File list for Qbasic TANK COMMANDER v2: +' +'* TCV2.BAS....................Game code file. +'* ARENA.BSV...................BSAVEd graphics file for game arena. +'* SPRITES.BSV.................BSAVEd graphics file for sprites. +' +'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + +$NoPrefix +'$Static +$Resize:Smooth + +'Define variables A-Z as integers. +DefInt A-Z + +'Define the data TYPE, PaletteType. +Type PaletteType + r As Integer + g As Integer + b As Integer +End Type + +'SHAREing of certain variables. +Dim Shared Pal As PaletteType +Dim Shared pData(0 To 255, 1 To 3) + +'Change the default directory to the one being used for TANK COMMANDER. When +'setting this, remember to uncomment it. +'CHDIR "" + +'Initial values of various variables. +D1 = 2: D2 = 4: T1H = 6: T1V = 87: T2H = 300: T2V = 102: Speed = 550 + +'Customise the VGA color palette for the introductory text. +Screen 13 +FullScreen SquarePixels , Smooth + +C = 16: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * A) + (256 * 0) + 0: C = C + 1: Next +C = 32: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * 0) + (256 * A) + 0: C = C + 1: Next +C = 48: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * 0) + (256 * 0) + A: C = C + 1: Next +C = 64: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * A) + (256 * A) + 0: C = C + 1: Next +C = 80: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * A) + (256 * 0) + A: C = C + 1: Next +C = 96: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * 0) + (256 * A) + A: C = C + 1: Next +C = 112: B = 0: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * A) + (256 * B) + 0: B = B + 3: C = C + 1: Next +C = 128: B = 0: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * B) + (256 * 0) + A: B = B + 3: C = C + 1: Next +C = 144: B = 0: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * B) + (256 * A) + 0: B = B + 3: C = C + 1: Next +C = 160: B = 0: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * B) + (256 * A) + A: B = B + 3: C = C + 1: Next +C = 176: B = 0: For A = 16 To 61 Step 3: Palette C, (256 ^ 2 * A) + (256 * A) + A: C = C + 1: Next +C = 192: B = 12: AA = 0: For A = 30 To 62 Step 2: Palette C, (256 ^ 2 * B) + (256 * AA) + A: B = B + 2: C = C + 1: Next +C = 208: B = 12: AA = 0: For A = 30 To 62 Step 2: Palette C, (256 ^ 2 * B) + (256 * B) + A: B = B + 2: C = C + 1: Next +C = 224: B = 12: AA = 0: For A = 30 To 62 Step 2: Palette C, (256 ^ 2 * AA) + (256 * B) + A: B = B + 2: C = C + 1: Next + +'Do presentation text. +Palette.FadeOut +Color 1 +Locate 9, 16: Print " HORIZONS Interactive Entertainment" +Locate 13, 13: Print "P R E S E N T S" + +'Color in company name with various shades of green. +Y = 72: C = 32 +Do + For X = 1 To 300 + If Point(X, Y) > 0 Then PSet (X, Y), C + Rnd * 15 + Next + Y = Y + 1 +Loop Until Y = 79 + +'Color in "PRESENTS" with various shades of red. Once this has been done, +'fade in the screen, melt it, and then fade out. +Y = 96: C = 49 +Do + For X = 1 To 300 + If Point(X, Y) > 0 Then PSet (X, Y), C + Rnd * 14 + Next + Y = Y + 1 +Loop Until Y = 103 +Palette.FadeIn +NOW! = Timer: While (Timer - 1) < NOW!: Wend +Dim Melt%(1500) +For R = 1 To 1500 + Randomize Timer + X = Int(Rnd * 271) + Randomize Timer + Y = Int(Rnd * 150) + Get (X, Y)-(X + 48, Y + 18), Melt%() + Put (X, Y + 1), Melt%(), PSet + If InKey$ = Chr$(27) Then Exit For + Limit 480 +Next +Palette.FadeOut +Cls: Palette: Palette.FadeOut + +'GET the sprite data. +Def Seg = 40960: BLoad "sprites.bsv" +Dim Tank1(150): Get (1, 1)-(15, 10), Tank1() +Dim Tank2(150): Get (1, 14)-(15, 23), Tank2() +Dim Tank3(150): Get (1, 27)-(15, 36), Tank3() +Dim Tank4(150): Get (1, 40)-(15, 49), Tank4() +Dim Tank5(150): Get (20, 1)-(34, 10), Tank5() +Dim Tank6(150): Get (20, 14)-(34, 23), Tank6() +Dim Tank7(150): Get (20, 27)-(34, 36), Tank7() +Dim Tank8(150): Get (20, 40)-(34, 49), Tank8() + +'Load the file ARENA.BSV, which is the graphics data for the arena, into the +'video memory segment (segment 40960). +BLoad "arena.bsv" + +'Place both tanks in their initial positions and fade in the completed arena. +Put (T1H, T1V), Tank1(), PSet +Put (T2H, T2V), Tank6(), PSet +Palette.FadeIn + +'Main program loop. +Do + + 'IF Count < Speed THEN Count = Count + 1 ELSE Count = 0 + Limit 60 + + If Go1 = 1 And Count = 0 Then + If D1 = 1 And T1V > 26 Then T1V = T1V - 1: Put (T1H, T1V), Tank3(), PSet + If D1 = 2 And T1H < 305 Then T1H = T1H + 1: Put (T1H, T1V), Tank1(), PSet + If D1 = 3 And T1V < 190 Then T1V = T1V + 1: Put (T1H, T1V), Tank4(), PSet + If D1 = 4 And T1H > 0 Then T1H = T1H - 1: Put (T1H, T1V), Tank2(), PSet + End If + If Go2 = 1 And Count = 0 Then + If D2 = 1 And T2V > 26 Then T2V = T2V - 1: Put (T2H, T2V), Tank7(), PSet + If D2 = 2 And T2H < 305 Then T2H = T2H + 1: Put (T2H, T2V), Tank5(), PSet + If D2 = 3 And T2V < 190 Then T2V = T2V + 1: Put (T2H, T2V), Tank8(), PSet + If D2 = 4 And T2H > 0 Then T2H = T2H - 1: Put (T2H, T2V), Tank6(), PSet + End If + If St1 = 30 Then St1 = 0: Fire1 = 0: PSet (B1H, B1V), Col + If St2 = 30 Then St2 = 0: Fire2 = 0: PSet (B2H, B2V), Col2 + If Fire1 = 1 And St1 < 30 And Count = 0 Then + PSet (B1H, B1V), Col + If BD1 = 1 Then B1V = B1V - 2 + If BD1 = 2 Then B1H = B1H + 2 + If BD1 = 3 Then B1V = B1V + 2 + If BD1 = 4 Then B1H = B1H - 2 + Col = Point(B1H, B1V) + PSet (B1H, B1V), 14 + St1 = St1 + 1 + GoSub CheckBullet1 + End If + If Fire2 = 1 And St2 < 30 And Count = 0 Then + PSet (B2H, B2V), Col2 + If BD2 = 1 Then B2V = B2V - 2 + If BD2 = 2 Then B2H = B2H + 2 + If BD2 = 3 Then B2V = B2V + 2 + If BD2 = 4 Then B2H = B2H - 2 + Col2 = Point(B2H, B2V) + PSet (B2H, B2V), 14 + St2 = St2 + 1 + GoSub CheckBullet2 + End If + Key$ = InKey$ + If Key$ = Chr$(27) Then Palette.FadeOut: GoTo Results + If Key$ = "4" Then Go1 = 1: D1 = 4 + If Key$ = "6" Then Go1 = 1: D1 = 2 + If Key$ = "8" Then Go1 = 1: D1 = 1 + If Key$ = "2" Then Go1 = 1: D1 = 3 + If Key$ = "0" Then If Fire1 = 0 Then GoSub Shoot1 + If Key$ = "5" Then Go1 = 0 + If Key$ = "O" Or Key$ = "o" Then Go2 = 1: D2 = 4 + If Key$ = "P" Or Key$ = "p" Then Go2 = 1: D2 = 2 + If Key$ = "Q" Or Key$ = "q" Then Go2 = 1: D2 = 1 + If Key$ = "A" Or Key$ = "a" Then Go2 = 1: D2 = 3 + If Key$ = "S" Or Key$ = "s" Then Go2 = 0 + If Key$ = Chr$(32) Then If Fire2 = 0 Then GoSub Shoot2 +Loop + +Shoot1: 'Initiates the shooting from Tank 1. +BD1 = D1 +If BD1 = 0 Then Return +If BD1 = 1 Then B1H = (T1H + 7): B1V = (T1V - 1) +If BD1 = 2 Then B1H = (T1H + 14): B1V = (T1V + 5) +If BD1 = 3 Then B1H = (T1H + 7): B1V = (T1V + 11) +If BD1 = 4 Then B1H = (T1H - 1): B1V = (T1V + 5) +St1 = 1: Fire1 = 1: Col = Point(B1H, B1V) +Return + +Shoot2: 'Initiates the shooting from Tank 2. +BD2 = D2 +If BD2 = 0 Then Return +If BD2 = 1 Then B2H = (T2H + 7): B2V = (T2V - 1) +If BD2 = 2 Then B2H = (T2H + 14): B2V = (T2V + 5) +If BD2 = 3 Then B2H = (T2H + 7): B2V = (T2V + 11) +If BD2 = 4 Then B2H = (T2H - 1): B2V = (T2V + 5) +St2 = 1: Fire2 = 1: Col2 = Point(B2H, B2V) +Return + +CheckBullet1: 'Hit detection from Tank 1 bullet. +T2V = T2V + 2: T2H = T2H + 3 +For ScanTank2 = 1 To 7 + For Scan = 1 To 9 + If B1H = T2H And B1V = T2V Then Crash = 2: GoTo Explode + T2H = T2H + 1 + Next + T2H = T2H - 9: T2V = T2V + 1 +Next +T2V = T2V - 9: T2H = T2H - 3 +Return + +CheckBullet2: 'Hit detection from Tank 2 bullet. +T1V = T1V + 2: T1H = T1H + 3 +For ScanTank1 = 1 To 7 + For Scan = 1 To 9 + If B2H = T1H And B2V = T1V Then Crash = 1: GoTo Explode + T1H = T1H + 1 + Next + T1H = T1H - 9: T1V = T1V + 1 +Next +T1V = T1V - 9: T1H = T1H - 3 +Return + +Explode: 'Create very cheap graphic explosion. +If Crash = 1 Then ExplodeH = T1H: ExplodeV = T1V: T2Wins = 1 +If Crash = 2 Then ExplodeH = T2H: ExplodeV = T2V: T1Wins = 1 +For Explode = 1 To 9 + If Explode = 1 Then Col = 14 + If Explode = 5 Then Col = 12 + If Explode = 7 Then Col = 4 + Circle (ExplodeH, ExplodeV), Explode, Col + NOW! = Timer: While (Timer - .01) < NOW!: Wend +Next +NOW! = Timer: While (Timer - 1) < NOW!: Wend +Palette.FadeOut + +Results: 'Announce the winning tank and display credits. +Screen 0: Width 80, 25 +Color 12, 4 +Print " G A M E R E S U L T S " +Print +Color 4, 0 +Print "Blue tank wins:" +Color 2 +Locate 3, 17: Print T1Wins +Color 4 +Print "Green tank wins:" +Color 2 +Locate 4, 18: Print T2Wins +Print +Color 12, 4 +Print " C R E D I T S " +Print +Color 4, 0 +Print "Concept:" +Print "Programming:" +Print "Game art:" +Print "Fade effect:" +Print "Testing:" +Print "Debugging:" +Color 2 +Locate 8, 11: Print "About a million other un-origional programmers ;)" +Locate 9, 15: Print "Matthew Knight" +Locate 10, 12: Print "Matthew Knight" +Locate 11, 15: Print "Manny Najera" +Locate 12, 11: Print "Matthew Knight" +Locate 13, 13: Print "Matthew Knight" +Print +Color 9 +Print "All code in this game was programmed from scratch by Matthew Knight, with" +Print "exception of the fade effect which was kindly supplied by Manny Najera." +Print "No code was taken from any other games. Any similarity to another game is" +Print "purely coincidental." +Print +Color 4 +Print "Thank you for trying Qbasic TANK COMMANDER v2 !!!" +Print "Hope you liked it :)" +Color 7 + +Sub Palette.FadeIn + Dim tT(1 To 3) + For I = 1 To 64 + Limit 60 + For O = 0 To 255 + Palette.Get O, Pal + tT(1) = Pal.r + tT(2) = Pal.g + tT(3) = Pal.b + If tT(1) < pData(O, 1) Then tT(1) = tT(1) + 1 + If tT(2) < pData(O, 2) Then tT(2) = tT(2) + 1 + If tT(3) < pData(O, 3) Then tT(3) = tT(3) + 1 + Pal.r = tT(1) + Pal.g = tT(2) + Pal.b = tT(3) + Palette.Set O, Pal + Next + Next +End Sub + +Sub Palette.FadeOut + Dim tT(1 To 3) + For I = 0 To 255 + Palette.Get I, Pal + pData(I, 1) = Pal.r + pData(I, 2) = Pal.g + pData(I, 3) = Pal.b + Next + For I = 1 To 64 + Limit 60 + For O = 0 To 255 + Palette.Get O, Pal + tT(1) = Pal.r + tT(2) = Pal.g + tT(3) = Pal.b + If tT(1) > 0 Then tT(1) = tT(1) - 1 + If tT(2) > 0 Then tT(2) = tT(2) - 1 + If tT(3) > 0 Then tT(3) = tT(3) - 1 + Pal.r = tT(1) + Pal.g = tT(2) + Pal.b = tT(3) + Palette.Set O, Pal + Next + Next +End Sub + +Sub Palette.Get (nColor%, pInfo As PaletteType) + Out &H3C6, &HFF + Out &H3C7, nColor% + pInfo.r = Inp(&H3C9) + pInfo.g = Inp(&H3C9) + pInfo.b = Inp(&H3C9) +End Sub + +Sub Palette.Set (nColor%, pInfo As PaletteType) + Out &H3C6, &HFF + Out &H3C8, nColor% + Out &H3C9, pInfo.r + Out &H3C9, pInfo.g + Out &H3C9, pInfo.b +End Sub + diff --git a/samples/qb-tank-commander/src/tcv2.zip b/samples/qb-tank-commander/src/tcv2.zip new file mode 100644 index 0000000..6106fc9 Binary files /dev/null and b/samples/qb-tank-commander/src/tcv2.zip differ diff --git a/samples/qbascii/index.md b/samples/qbascii/index.md index 34d859f..294afbe 100644 --- a/samples/qbascii/index.md +++ b/samples/qbascii/index.md @@ -23,9 +23,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qbascii.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/qbascii/src/qbascii.bas) -* [RUN "qbascii.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/qbascii/src/qbascii.bas) -* [PLAY "qbascii.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/qbascii/src/qbascii.bas) +* [LOAD "qbascii.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/qbascii/src/qbascii.bas) +* [RUN "qbascii.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/qbascii/src/qbascii.bas) +* [PLAY "qbascii.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/qbascii/src/qbascii.bas) ### File(s) diff --git a/samples/qbguy.md b/samples/qbguy.md index 3fcd5b3..2422c9a 100644 --- a/samples/qbguy.md +++ b/samples/qbguy.md @@ -2,8 +2,38 @@ ## SAMPLES BY QBGUY +**[Kaleidoscope 3D](kaleidoscope-3d/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [3d](3d.md), [art](art.md) + +Move mouse to rotate, escape to quit + +**[Kaleidoscope Doodler](kaleidoscope-doodler/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [art](art.md), [drawing](drawing.md) + +Left-click to draw, right click or middle click to clear screen, escape to quit. + +**[Lisp Interpreter](lisp-interpreter/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [interpreter](interpreter.md), [lisp](lisp.md) + +Scheme is a functional programming language that uses a minimalist implementation of the LISP lan... + **[Mandelbrot Set 2008](mandelbrot-set-2008/index.md)** [🐝 qbguy](qbguy.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) public domain, uses qb64's 2d prototype + +**[Mandelbrot Spiral](mandelbrot-spiral/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) + +Mandelbrot spiral by qbguy. + +**[Tic Tac Toe 3D](tic-tac-toe-3d/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [game](game.md), [tic tac toe](tic-tac-toe.md) + +The goal is to get four in a row while preventing the computer from doing the same. Move by click... diff --git a/samples/qblocks/index.md b/samples/qblocks/index.md index 7c0e646..d997d95 100644 --- a/samples/qblocks/index.md +++ b/samples/qblocks/index.md @@ -18,9 +18,9 @@ Tetris clone by Microsoft. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/qblocks/src/qblocks.bas) -* [RUN "qblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/qblocks/src/qblocks.bas) -* [PLAY "qblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/qblocks/src/qblocks.bas) +* [LOAD "qblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/qblocks/src/qblocks.bas) +* [RUN "qblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/qblocks/src/qblocks.bas) +* [PLAY "qblocks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/qblocks/src/qblocks.bas) ### File(s) diff --git a/samples/qbricks/index.md b/samples/qbricks/index.md index a8d5d68..a39b496 100644 --- a/samples/qbricks/index.md +++ b/samples/qbricks/index.md @@ -18,9 +18,9 @@ Breakout clone by Microsoft. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qbricks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/qbricks/src/qbricks.bas) -* [RUN "qbricks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/qbricks/src/qbricks.bas) -* [PLAY "qbricks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/qbricks/src/qbricks.bas) +* [LOAD "qbricks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/qbricks/src/qbricks.bas) +* [RUN "qbricks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/qbricks/src/qbricks.bas) +* [PLAY "qbricks.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/qbricks/src/qbricks.bas) ### File(s) diff --git a/samples/qmaze/index.md b/samples/qmaze/index.md index d13b916..f7470e5 100644 --- a/samples/qmaze/index.md +++ b/samples/qmaze/index.md @@ -18,9 +18,9 @@ Maze puzzle game by Microsoft. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qmaze.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/qmaze/src/qmaze.bas) -* [RUN "qmaze.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/qmaze/src/qmaze.bas) -* [PLAY "qmaze.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/qmaze/src/qmaze.bas) +* [LOAD "qmaze.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/qmaze/src/qmaze.bas) +* [RUN "qmaze.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/qmaze/src/qmaze.bas) +* [PLAY "qmaze.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/qmaze/src/qmaze.bas) ### File(s) diff --git a/samples/qships/index.md b/samples/qships/index.md index 5d2fa18..ac73f9c 100644 --- a/samples/qships/index.md +++ b/samples/qships/index.md @@ -18,9 +18,9 @@ Turn-based artillery game by Microsoft. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qships.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/qships/src/qships.bas) -* [RUN "qships.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/qships/src/qships.bas) -* [PLAY "qships.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/qships/src/qships.bas) +* [LOAD "qships.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/qships/src/qships.bas) +* [RUN "qships.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/qships/src/qships.bas) +* [PLAY "qships.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/qships/src/qships.bas) ### File(s) diff --git a/samples/qspace/index.md b/samples/qspace/index.md index 9438408..00000b0 100644 --- a/samples/qspace/index.md +++ b/samples/qspace/index.md @@ -18,9 +18,9 @@ Space station defense game by Microsoft. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qspace.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/qspace/src/qspace.bas) -* [RUN "qspace.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/qspace/src/qspace.bas) -* [PLAY "qspace.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/qspace/src/qspace.bas) +* [LOAD "qspace.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/qspace/src/qspace.bas) +* [RUN "qspace.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/qspace/src/qspace.bas) +* [PLAY "qspace.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/qspace/src/qspace.bas) ### File(s) diff --git a/samples/qtrek/index.md b/samples/qtrek/index.md index 9370e88..fef6606 100644 --- a/samples/qtrek/index.md +++ b/samples/qtrek/index.md @@ -18,9 +18,9 @@ Star Trek-like game by Philipp Strathausen. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "qtrek.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/qtrek/src/qtrek.bas) -* [RUN "qtrek.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/qtrek/src/qtrek.bas) -* [PLAY "qtrek.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/qtrek/src/qtrek.bas) +* [LOAD "qtrek.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/qtrek/src/qtrek.bas) +* [RUN "qtrek.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/qtrek/src/qtrek.bas) +* [PLAY "qtrek.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/qtrek/src/qtrek.bas) ### File(s) diff --git a/samples/ray-tracer-z/img/screenshot.png b/samples/ray-tracer-z/img/screenshot.png new file mode 100644 index 0000000..02e0674 Binary files /dev/null and b/samples/ray-tracer-z/img/screenshot.png differ diff --git a/samples/ray-tracer-z/index.md b/samples/ray-tracer-z/index.md new file mode 100644 index 0000000..5d029ca --- /dev/null +++ b/samples/ray-tracer-z/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: RAY TRACER Z + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Zom-B](../zom-b.md) + +### Description + +```text +This is a ray tracer I've been working on for the past 6 years. Well, on and off of course :) It's still a beta version. 43Kb. Bet this won't run in QB45. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "ray-tracer-zomb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/ray-tracer-z/src/ray-tracer-zomb.bas) +* [RUN "ray-tracer-zomb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/ray-tracer-z/src/ray-tracer-zomb.bas) +* [PLAY "ray-tracer-zomb.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/ray-tracer-z/src/ray-tracer-zomb.bas) + +### File(s) + +* [ray-tracer-zomb.bas](src/ray-tracer-zomb.bas) + +🔗 [3d](../3d.md), [ray tracer](../ray-tracer.md) diff --git a/samples/ray-tracer-z/src/ray-tracer-zomb.bas b/samples/ray-tracer-z/src/ray-tracer-zomb.bas new file mode 100644 index 0000000..a0de392 --- /dev/null +++ b/samples/ray-tracer-z/src/ray-tracer-zomb.bas @@ -0,0 +1,1212 @@ +'> Merged with Zom-B's smart $include merger 0.51 + +' Best viewed with 120 or more columns + +DefDbl A-Z +Option Base 1 + +'#################################################################################################################### +'# Math Library V1.0 (include) +'# By Zom-B +'#################################################################################################################### + +Const sqrt2 = 1.41421356237309504880168872420969807856967187537695 ' Knuth01 +Const sqrt3 = 1.73205080756887729352744634150587236694280525381038 ' Knuth02 +Const sqrt5 = 2.23606797749978969640917366873127623544061835961153 ' Knuth03 +Const sqrt10 = 3.16227766016837933199889354443271853371955513932522 ' Knuth04 +Const cubert2 = 1.25992104989487316476721060727822835057025146470151 ' Knuth05 +Const cubert3 = 1.44224957030740838232163831078010958839186925349935 ' Knuth06 +Const q2pow025 = 1.18920711500272106671749997056047591529297209246382 ' Knuth07 +Const phi = 1.61803398874989484820458683436563811772030917980576 ' Knuth08 +Const log2 = 0.69314718055994530941723212145817656807550013436026 ' Knuth09 +Const log3 = 1.09861228866810969139524523692252570464749055782275 ' Knuth10 +Const log10 = 2.30258509299404568401799145468436420760110148862877 ' Knuth11 +Const logpi = 1.14472988584940017414342735135305871164729481291531 ' Knuth12 +Const logphi = 0.48121182505960344749775891342436842313518433438566 ' Knuth13 +Const q1log2 = 1.44269504088896340735992468100189213742664595415299 ' Knuth14 +Const q1log10 = 0.43429448190325182765112891891660508229439700580367 ' Knuth15 +Const q1logphi = 2.07808692123502753760132260611779576774219226778328 ' Knuth16 +Const pi = 3.14159265358979323846264338327950288419716939937511 ' Knuth17 +Const deg2rad = 0.01745329251994329576923690768488612713442871888542 ' Knuth18 +Const q1pi = 0.31830988618379067153776752674502872406891929148091 ' Knuth19 +Const pisqr = 9.86960440108935861883449099987615113531369940724079 ' Knuth20 +Const gamma05 = 1.7724538509055160272981674833411451827975494561224 ' Knuth21 +Const gamma033 = 2.6789385347077476336556929409746776441286893779573 ' Knuth22 +Const gamma067 = 1.3541179394264004169452880281545137855193272660568 ' Knuth23 +Const e = 2.71828182845904523536028747135266249775724709369996 ' Knuth24 +Const q1e = 0.36787944117144232159552377016146086744581113103177 ' Knuth25 +Const esqr = 7.38905609893065022723042746057500781318031557055185 ' Knuth26 +Const eulergamma = 0.57721566490153286060651209008240243104215933593992 ' Knuth27 +Const expeulergamma = 1.7810724179901979852365041031071795491696452143034 ' Knuth28 +Const exppi025 = 2.19328005073801545655976965927873822346163764199427 ' Knuth29 +Const sin1 = 0.84147098480789650665250232163029899962256306079837 ' Knuth30 +Const cos1 = 0.54030230586813971740093660744297660373231042061792 ' Knuth31 +Const zeta3 = 1.2020569031595942853997381615114499907649862923405 ' Knuth32 +Const nloglog2 = 0.36651292058166432701243915823266946945426344783711 ' Knuth33 + +Const logr10 = 0.43429448190325182765112891891660508229439700580367 +Const logr2 = 1.44269504088896340735992468100189213742664595415299 +Const pi05 = 1.57079632679489661923132169163975144209858469968755 +Const pi2 = 6.28318530717958647692528676655900576839433879875021 +Const q05log10 = 0.21714724095162591382556445945830254114719850290183 +Const q05log2 = 0.72134752044448170367996234050094606871332297707649 +Const q05pi = 0.15915494309189533576888376337251436203445964574046 +Const q13 = 0.33333333333333333333333333333333333333333333333333 +Const q16 = 0.16666666666666666666666666666666666666666666666667 +Const q2pi = 0.63661977236758134307553505349005744813783858296183 +Const q2sqrt5 = 0.89442719099991587856366946749251049417624734384461 +Const rad2deg = 57.2957795130823208767981548141051703324054724665643 +Const sqrt02 = 0.44721359549995793928183473374625524708812367192231 +Const sqrt05 = 0.70710678118654752440084436210484903928483593768847 +Const sqrt075 = 0.86602540378443864676372317075293618347140262690519 +Const y2q112 = 1.05946309435929526456182529494634170077920431749419 ' Chromatic base + +'#################################################################################################################### +'# Vector math library v0.1 (include part) +'# By Zom-B +'#################################################################################################################### + +Type VECTOR + x As Double + y As Double + z As Double +End Type + +'#################################################################################################################### +'# Screen mode selector v1.0 (include) +'# By Zom-B +'#################################################################################################################### + +videoaspect: +Data "all aspect",15 +Data "4:3",11 +Data "16:10",10 +Data "16:9",14 +Data "5:4",13 +Data "3:2",12 +Data "5:3",9 +Data "1:1",7 +Data "other",8 +Data , + +videomodes: +Data 256,256,7 +Data 320,240,1 +Data 400,300,1 +Data 512,384,1 +Data 512,512,7 +Data 640,480,1 +Data 720,540,1 +Data 768,576,1 +Data 800,480,2 +Data 800,600,1 +Data 854,480,3 +Data 1024,600,8 +Data 1024,640,2 +Data 1024,768,1 +Data 1024,1024,7 +Data 1152,768,5 +Data 1152,864,1 +Data 1280,720,3 +Data 1280,768,6 +Data 1280,800,2 +Data 1280,854,5 +Data 1280,960,1 +Data 1280,1024,4 +Data 1366,768,3 +Data 1400,1050,1 +Data 1440,900,2 +Data 1440,960,5 +Data 1600,900,3 +Data 1600,1200,1 +Data 1680,1050,2 +Data 1920,1080,3 +Data 1920,1200,2 +Data 2048,1152,3 +Data 2048,1536,1 +Data 2048,2048,7 +Data ,, + + +'#################################################################################################################### +'# Ray Tracer (Beta version) +'# By Zom-B +'#################################################################################################################### + +Const Doantialias = -1 +Const Usegaussian = 0 + +Const FLOOR = 1 +Const SPHERE = 2 + +Type TEXTURE + image As Long + w As Integer + h As Integer + scaleU As Single + scaleV As Single + offsetU As Single + offsetV As Single + bumpfactor As Single +End Type + +Dim Shared sizeX%, sizeY% +Dim Shared maxX%, maxY% +Dim Shared halfX%, halfY% + +Dim Shared texture&(4) + +Dim Shared camPos As VECTOR +Dim Shared camDir As VECTOR +Dim Shared camUp As VECTOR +Dim Shared camRight As VECTOR + +'Speed required with these variables, so not using TYPEs here +Dim Shared objectType%(7) ' Object type +Dim Shared positionX(7), positionY(7), positionZ(7) ' Object position +Dim Shared size(7) ' Radius (in case of a sphere) +Dim Shared colorR!(7), colorG!(7), colorB!(7), colorA!(7) ' RGBA color +Dim Shared specular!(7), highlight!(7) ' Phong parameters +Dim Shared reflection!(7) ' Ray reflection amount +Dim Shared textures(7) As TEXTURE, bumpmap(7) As TEXTURE ' image handle +Dim Shared numObjects% + +Dim Shared lightX(4), lightY(4), lightZ(4) ' Light position +Dim Shared lightR!(4), lightG!(4), lightB!(4) ' Light color +Dim Shared numLights% + +init +main + +worldMap: +Data "!~#!~#!~#!-#(.69AEGFC@5.224;DJMORQND:)(*$!:#'#$!e#+.+1WX\_`ab\MCOZ!/baaQ5&!)#'<;CB=,&!&#$06,8@6/$!%#&&##$8NL" +Data ":1%!P#-=@@D25CGHIKJYZ]A)=^b`!0b]:!+#$0M?80!.#*-6.!&#%#%#/6?VR=6)!*#'%!B#,DDID?>>/LLPRINQE,!%#$#'F!.bZ0!;#=P=" +Data "-%$'$%)7GV^!)bA/)&6.##-BL/0+!,#/!'#$/80)&!'#$)5NA\]^]W3EQZ,[]baaN>0!&#J_!+bZ2!%#$$!+#$/3-!)#8V*##+R]PUV\!/ba" +Data "bb8CBN[XRF26/!(#(=*##&B`!'b_YQPYaaVVMTVVX]YJY]YFMaZ_!%b9$##/Q!(b]TJ6$!-#%>V`ba`UJ<),2;!&#$@Y!+baZbb^=.##%Cbb^][)!4#2T+##9>Q^,3Q`!%b_!EbO*##$$1U\(!+#),3+!*#6Qa_a!&ba_abb`bbU" +Data "G,Taab``U8!2#/LJK$#-ZO;>T!>babTa!'babbN1'!&#L`=#&!&#')'%&!-#$)L`baa!*b_!%bGa`baabaX-!1#;?KaGJ!@babbabZ\!-bT$" +Data "!%#;6!&#&#'!4#*FYaa!)b`bQZ!'b[L7,PI%!2#9DZ!Rb[<*!%#'!=#+a!,bYPAU[!&b_@4(2)!2#%N!&b^!'bZMZWbbaW!@b^/5#'&!?#/a" +Data "!-bYPQVXb_84-!4#)C@PbMEER=[bb`-$(.Sb`(T!*b`!4b\R.(Q;%!@#,a!-baa^`bY9%!6#-!%bA($:2N3aNWJW[KPbbG3!9b]``X)##08!C#" +Data "N!1ba1!2#$!'#/[aP&*,3.;$B>D!%abbabM-!9b[7?U##)K2!C#)X!0bW&!9#4KJ`bbX!&#+('19!?bU&,Q.HQI$!E#K]!-bD!:#5a!(bQ:$" +Data "HA/)/M!@b@$%J-$!G#*B^!&b`GJ<8Q/!7#$%(N!+b]!&b`a!&bL`!:bC##%!J#;=_!%bA!J5!7#+Z!2b=!&bW:KV!7bX&#'!L#:0]bb6!&#" +Data "4BU,!6#I!3bLB!&b]\E(',\!2bU>3%!<#'*!3#Dbb@#-L)79Q4/!4#%a!4b5]!'b])##/V!&b_A?!&b`FL-#%!?#(!3#(H``HYX!%#/)E3,$" +Data "!/#$##V!4bJ5!&b\2!&#(!%bU(##G!%bV1-##*6!R#';;^ZM8$!(#(!.#*#&_!5b?YbZ=!)#TbP'!%#0!W#(0N!(b>0!0#8]!%bZX!1bJ!)#%#&" +Data "E&!%#'$G-! $3Q##$!V#F!*bQ!0#*;/0#&@W!.b[)!)#%%!(#&L?U$%%C_0!?#$!<#1a!+bG!6#J!)b`!%bS*!3#0[_,/Wb_/2*4!1#%!C#" +Data "(!%#P!-bS4'!3#Q!(baB_bW&!5#=bR0`bK@<'*6F35$#%%!*#$!F#T!0bI+!1#)\!'b^bba-!6#$Da/05-=B%0+#/!/b" +Data "C!Q#@!(bF!:#Hbb^6!@#]bbM=4I!'b^/!Q#R!&b^:!;#*3*$!@#$=0'!&#?[bb`D!)#/&!H#*a!%b]C!g#-NP@)!)#%Q1!G#/_b_K&!j#1:!*#" +Data "=C##%!E#1^bZ*!k#'1!(#)K>!I#Cbb;!t#8;!J#Wb`3!Q#-!n#G_W##0*!P#$!l#%AO5$!*#'&!~#!H#(!~#!;#$##%!(#%!~#!8#)8;'!W#" +Data "&!f#+>\O!G#&/EH3&!)#5?@:>[NLA7BD52;ONCDA92/!'#$$!F#$!'#.@>`bM%!5#+,)*+-41-'+8CD1GWa!(b_ZH8BY!9bTNOA8&!B#$6BA" +Data "30.%#'4E`!%bM!0#.6DX^a!,babb`!,b^_!Cb^W7!0#'/37>DIQZVUPOIB>K!'b`X`!(bL*!,#)IT!@b]`!BbaK2&!%#21!%./7?JHTa!Bb_" +Data "RG:7?;:GT`!db_;DDC?7!~b!=ba_!Uba!%baa!hbaabaa!%b`^!%bab]a`ba!?b_a!qba\_!~b!Ib" + +'#################################################################################################################### +'#################################################################################################################### +'#################################################################################################################### + +Sub init () + Width , 40 + Color 11: Print + Print Tab(27); "Ray Tracer (Beta version)" + Color 7 + Print Tab(36); "By Zom-B" + + scrn& = selectScreenMode&(4, 32) + + makeTextures + 'texture&(1) = _LOADIMAGE("d:\0synced\software\qb64\wTex.png", 32) + 'texture&(2) = _LOADIMAGE("d:\0synced\software\qb64\wBump.png", 32) + 'texture&(3) = _LOADIMAGE("d:\0synced\software\qb64\fTex.png", 32) + 'texture&(4) = _LOADIMAGE("d:\0synced\software\qb64\fBump.png", 32) + + makeScene + + Screen scrn& + _Dest scrn& + 'SCREEN _NEWIMAGE(640, 480, 32) + + sizeX% = _Width + sizeY% = _Height + maxX% = sizeX% - 1 + maxY% = sizeY% - 1 + halfX% = sizeX% \ 2 + halfY% = sizeY% \ 2 + + cameraPrepare 150, -250, 200, 0, 0, 66, 0, 0, 1, 60, maxX% / maxY% + 'cameraPrepare 0, 0, 400, 0, 0, 132, 0, -1, 0, 45, maxX% / maxY% +End Sub + +'#################################################################################################################### + +Sub main () + 'FOR i% = 0 TO 360 STEP 30 + ' x = 100 * COS(i% * _deg2rad) + ' y = 100 * SIN(i% * _deg2rad) + ' cameraPrepare x, y, 400, 0, 0, 200, 0, 0, 1, 60, maxX% / maxY% + + renderProgressive 256, 4 + + Circle (maxX% \ 2, maxY% \ 2), 3, _RGB32(255, 255, 255), , , 1 + 'NEXT +End Sub + +'#################################################################################################################### +'#################################################################################################################### +'#################################################################################################################### + +Sub cameraPrepare (posX, posY, posZ, lookAtX, lookAtY, lookAtZ, upX, upY, upZ, fov, aspect) + camPos.x = posX + camPos.y = posY + camPos.z = posZ + + camDir.x = lookAtX - posX + camDir.y = lookAtY - posY + camDir.z = lookAtZ - posZ + vectorNormalize camDir + 'PRINT camDir.x, camDir.y, camDir.z + + camUp.x = upX + camUp.y = upY + camUp.z = upZ + 'vectorNormalize camUp + 'PRINT camUp.x, camUp.y, camUp.z + + 'Right vec + vectorCross camUp, camDir, camRight + vectorNormalize camRight + 'PRINT camRight.x, camRight.y, camRight.z + + vectorCross camDir, camRight, camUp + vectorNormalize camUp + 'PRINT camUp.x, camUp.y, camUp.z + 'END + + scaleY = Tan(fov * (_Pi / 360)) * 0.75 + scaleX = scaleY * aspect + + vectorScale camRight, scaleX + vectorScale camUp, scaleY + + 'PRINT fov, scaleX, scaleY + 'END +End Sub + +'#################################################################################################################### + +Sub renderProgressive (startSize%, endSize%) + pixStep% = startSize% + + pixWidth% = pixStep% - 1 + For y% = 0 To maxY% Step pixStep% + For x% = 0 To maxX% Step pixStep% + tracePoint x%, y%, r!, g!, b! + Line (x%, y%)-Step(pixWidth%, pixWidth%), _RGB(r! * 255, g! * 255, b! * 255), BF + Next + If InKey$ = Chr$(27) Then System + Next + + While pixStep% > 2 + pixSize% = pixStep% \ 2 + pixWidth% = pixSize% - 1 + For y% = 0 To maxY% Step pixStep% + y1% = y% + pixSize% + For x% = 0 To maxX% Step pixStep% + x1% = x% + pixSize% + + If x1% < sizeX% Then + tracePoint x1%, y%, r!, g!, b! + Line (x1%, y%)-Step(pixWidth%, pixWidth%), _RGB(r! * 255, g! * 255, b! * 255), BF + End If + If y1% < sizeY% Then + tracePoint x%, y1%, r!, g!, b! + Line (x%, y1%)-Step(pixWidth%, pixWidth%), _RGB(r! * 255, g! * 255, b! * 255), BF + If x1% < sizeX% Then + tracePoint x1%, y1%, r!, g!, b! + Line (x1%, y1%)-Step(pixWidth%, pixWidth%), _RGB(r! * 255, g! * 255, b! * 255), BF + End If + End If + Next + If InKey$ = Chr$(27) Then System + Next + pixStep% = pixStep% \ 2 + Wend + + For y% = 0 To maxY% + y1% = y% + 1 + For x% = 0 To maxX% + x1% = x% + 1 + + If x1% < sizeX% Then + tracePoint x1%, y%, r!, g!, b! + PSet (x1%, y%), _RGB(r! * 255, g! * 255, b! * 255) + End If + If y1% < sizeY% Then + tracePoint x%, y1%, r!, g!, b! + PSet (x%, y1%), _RGB(r! * 255, g! * 255, b! * 255) + If x1% < sizeX% Then + tracePoint x1%, y1%, r!, g!, b! + PSet (x1%, y1%), _RGB(r! * 255, g! * 255, b! * 255) + End If + End If + Next + If InKey$ = Chr$(27) Then System + Next + + If Not Doantialias Then Exit Sub + + factor! = 255 / (endSize% * endSize%) + + If Usegaussian Then + For y% = 0 To maxY% + For x% = 0 To maxX% + c& = Point(x%, y%) + r! = _Red(c&) + g! = _Green(c&) + b! = _Blue(c&) + For i% = 2 To endArea% + Do 'Marsaglia polar method for random gaussian + u! = Rnd * 2 - 1 + v! = Rnd * 2 - 1 + s! = u! * u! + v! * v! + Loop While s! >= 1 Or s! = 0 + s! = Sqr(-2 * Log(s!) / s!) * 0.5 + u! = u! * s! + v! = v! * s! + + tracePoint x% + u!, y% + v!, r1!, g1!, b1! + + r! = r! + r1! + g! = g! + g1! + b! = b! + b1! + Next + + PSet (x%, y%), _RGB(r! * factor!, g! * factor!, b! * factor!) + If InKey$ = Chr$(27) Then System + Next + Next + Else + For y% = 0 To maxY% + For x% = 0 To maxX% + r! = 0 + g! = 0 + b! = 0 + For v% = 0 To endSize% - 1 + y1! = y% + v% / endSize% + For u% = 0 To endSize% - 1 + If u% = 0 And v& = 0 Then + c& = Point(x%, y%) + Else + x1! = x% + u% / endSize% + tracePoint x1!, y1!, r1!, g1!, b1! + End If + r! = r! + r1! + g! = g! + g1! + b! = b! + b1! + Next + Next + + PSet (x%, y%), _RGB(r! * factor!, g! * factor!, b! * factor!) + If InKey$ = Chr$(27) Then System + Next + Next + End If +End Sub + +'#################################################################################################################### + +Sub tracePoint (x!, y!, r!, g!, b!) + x0! = (x! - halfX%) / halfX% + y0! = (halfY% - y!) / halfY% + + rayX = camDir.x + x0! * camRight.x + y0! * camUp.x + rayY = camDir.y + x0! * camRight.y + y0! * camUp.y + rayZ = camDir.z + x0! * camRight.z + y0! * camUp.z + + 'normalize to a vector length of 1 + d = 1 / Sqr(rayX * rayX + rayY * rayY + rayZ * rayZ) + traceRay camPos.x, camPos.y, camPos.z, rayX * d, rayY * d, rayZ * d, 3, -1, r!, g!, b! +End Sub + +'#################################################################################################################### + +Sub traceRay (startX, startY, startZ, rayX, rayY, rayZ, depth%, lastObj%, lightR!, lightG!, lightB!) + findMinObj startX, startY, startZ, rayX, rayY, rayZ, lastObj%, minobj%, minDepth + + If minobj% = 0 Then ' Infinity + lightR! = 0 + lightG! = 0 + lightB! = 0 + Else ' An object was found + intersectX = startX + rayX * minDepth + intersectY = startY + rayY * minDepth + intersectZ = startZ + rayZ * minDepth + + 'Calculate normal vector + Select Case objectType%(minobj%) + Case FLOOR: + normalX = 0 + normalY = 0 + normalZ = 1 + Case SPHERE: + normalX = (intersectX - positionX(minobj%)) / size(minobj%) + normalY = (intersectY - positionY(minobj%)) / size(minobj%) + normalZ = (intersectZ - positionZ(minobj%)) / size(minobj%) + End Select + + 'Calculate UV coordinates + If textures(minobj%).image <> -1 Or bumpmap(minobj%).image <> -1 Then + Select Case objectType%(minobj%) + Case FLOOR: + texcoordU! = intersectX + texcoordV! = intersectY + Case SPHERE: + If normalX = 0 Then + If normalY <= 0 Then texcoordU! = 0 Else texcoordU! = 0.5 + Else + texcoordU! = atan2(normalX, normalY) / pi2 + 0.5 + End If + + texcoordV! = acos(normalZ) / _Pi + End Select + End If + + 'Bumpmapping + If bumpmap(minobj%).image <> -1 Then + If minobj% < 3 Then + texdirxx = 1 + texdirxy = 0 + texdirxz = 0 + + texdiryx = 0 + texdiryy = 1 + texdiryz = 0 + Else + texdirxx = normalY + texdirxy = -normalX + texdirxz = 0 + + texdiryx = normalZ * normalX + texdiryy = normalZ * normalY + texdiryz = -(normalX * normalX + normalY * normalY) + End If + + x! = texcoordU! * bumpmap(minobj%).scaleU - bumpmap(minobj%).offsetU + y! = texcoordV! * bumpmap(minobj%).scaleV - bumpmap(minobj%).offsetV + x1% = Int(x!) + y1% = Int(y!) + + dx1! = x! - x1% + dy1! = y! - y1% + dx2! = 1 - dx1! + dy2! = 1 - dy1! + dx1dy1! = dx1! * dy1! + dx1dy2! = dx1! * dy2! + dx2dy1! = dx2! * dy1! + dx2dy2! = dx2! * dy2! + + x0% = remainder%(x1%, bumpmap(minobj%).w) + y0% = remainder%(y1%, bumpmap(minobj%).h) + x1% = remainder%(x1% + 1, bumpmap(minobj%).w) + y1% = remainder%(y1% + 1, bumpmap(minobj%).h) + + _Source bumpmap(minobj%).image + c0& = Point(x0%, y0%) + c1& = Point(x1%, y0%) + c2& = Point(x0%, y1%) + c3& = Point(x1%, y1%) + + sx! = ((_Red(c0&) - 127) * dx2dy2! + (_Red(c1&) - 127) * dx1dy2! + (_Red(c2&) - 127) * dx2dy1! + (_Red(c3&) - 127) * dx1dy1!) * bumpmap(minobj%).bumpfactor / 127 + sy! = ((_Green(c0&) - 127) * dx2dy2! + (_Green(c1&) - 127) * dx1dy2! + (_Green(c2&) - 127) * dx2dy1! + (_Green(c3&) - 127) * dx1dy1!) * bumpmap(minobj%).bumpfactor / 127 + + normalX = normalX - (texdirxx * sx! + texdiryx * sy) + normalY = normalY - (texdirxy * sx! + texdiryy * sy) + normalZ = normalZ - (texdirxz * sx! + texdiryz * sy) + + r = Sqr(normalX * normalX + normalY * normalY + normalZ * normalZ) + normalX = normalX / r + normalY = normalY / r + normalZ = normalZ / r + End If + + 'lighting + r = 2 * (rayX * normalX + rayY * normalY + rayZ * normalZ) + rayX = rayX - normalX * r + rayY = rayY - normalY * r + rayZ = rayZ - normalZ * r + + diffuseR! = 0 + diffuseG! = 0 + diffuseB! = 0 + specularR! = 0 + specularG! = 0 + specularB! = 0 + + For a% = numLights% To 1 Step -1 + dirX = lightX(a%) - intersectX + dirY = lightY(a%) - intersectY + dirZ = lightZ(a%) - intersectZ + + r = 1 / Sqr(dirX * dirX + dirY * dirY + dirZ * dirZ) + dirX = dirX * r + dirY = dirY * r + dirZ = dirZ * r + + 'Shadows testing + findShadow intersectX, intersectY, intersectZ, dirX, dirY, dirZ, minobj%, noShadows% + + If noShadows% Then + 'Diffuse lighting + r = normalX * dirX + normalY * dirY + normalZ * dirZ + If r > 0 Then + diffuseR! = diffuseR! + colorR!(minobj%) * lightR!(a%) * r + diffuseG! = diffuseG! + colorG!(minobj%) * lightG!(a%) * r + diffuseB! = diffuseB! + colorB!(minobj%) * lightB!(a%) * r + End If + + 'Specular lighting + r = rayX * dirX + rayY * dirY + rayZ * dirZ + If r > 0 Then + c! = r ^ (1 / highlight!(minobj%)) * specular!(minobj%) + + specularR! = specularR! + lightR!(a%) * c! + specularG! = specularG! + lightG!(a%) * c! + specularB! = specularB! + lightB!(a%) * c! + End If + End If + Next + + lightR! = diffuseR! + specularR! + lightG! = diffuseG! + specularG! + lightB! = diffuseB! + specularB! + + 'texturing + If textures(minobj%).image <> -1 Then + x! = texcoordU! * textures(minobj%).scaleU - textures(minobj%).offsetU + y! = texcoordV! * textures(minobj%).scaleV - textures(minobj%).offsetV + x0% = Int(x!) + y0% = Int(y!) + + dx1! = x! - x0% + dy1! = y! - y0% + dx2! = 1 - dx1! + dy2! = 1 - dy1! + dx1dy1! = dx1! * dy1! + dx1dy2! = dx1! * dy2! + dx2dy1! = dx2! * dy1! + dx2dy2! = dx2! * dy2! + + x1% = remainder%(x0% + 1, textures(minobj%).w) ' returns positive value only, in contrast to MOD + y1% = remainder%(y0% + 1, textures(minobj%).h) + x0% = remainder%(x0%, textures(minobj%).w) + y0% = remainder%(y0%, textures(minobj%).h) + + _Source textures(minobj%).image + c0& = Point(x0%, y0%) + c1& = Point(x1%, y0%) + c2& = Point(x0%, y1%) + c3& = Point(x1%, y1%) + + materialr! = _Red(c0&) * dx2dy2! + _Red(c1&) * dx1dy2! + _Red(c2&) * dx2dy1! + _Red(c3&) * dx1dy1! + materialg! = _Green(c0&) * dx2dy2! + _Green(c1&) * dx1dy2! + _Green(c2&) * dx2dy1! + _Green(c3&) * dx1dy1! + materialb! = _Blue(c0&) * dx2dy2! + _Blue(c1&) * dx1dy2! + _Blue(c2&) * dx2dy1! + _Blue(c3&) * dx1dy1! + + lightR! = lightR! * materialr! / 255F + lightG! = lightG! * materialg! / 255F + lightB! = lightB! * materialb! / 255F + End If + + 'Reflection + If reflection!(minobj%) > 0 And depth% > 0 Then + traceRay intersectX, intersectY, intersectZ, rayX, rayY, rayZ, depth% - 1, minobj%, reflectR!, reflectG!, reflectB! + lightR! = lightR! + (reflectR! - lightR!) * reflection!(minobj%) + lightG! = lightG! + (reflectG! - lightG!) * reflection!(minobj%) + lightB! = lightB! + (reflectB! - lightB!) * reflection!(minobj%) + End If + + ' Global intensity + r = Exp(-minDepth / 1000.0) + + lightR! = lightR! * r + lightG! = lightG! * r + lightB! = lightB! * r + End If +End Sub + +'#################################################################################################################### + +Sub findMinObj (startX, startY, startZ, rayX, rayY, rayZ, lastObj%, minObj%, minDepth) + minObj% = 0 + minDepth = 1E+308 + For a% = numObjects% To 1 Step -1 + If a% <> lastObj% Then + Select Case objectType%(a%) + Case FLOOR: + depth = -startZ / rayZ + Case SPHERE: + posX = positionX(a%) - startX + posY = positionY(a%) - startY + posZ = positionZ(a%) - startZ + + r = rayX * posX + rayY * posY + rayZ * posZ + d = r * r - posX * posX - posY * posY - posZ * posZ + size(a%) * size(a%) + If d >= 0 Then depth = r - Sqr(d) Else depth = -1 + End Select + + If depth >= 0 Then + If minDepth > depth Then minDepth = depth: minObj% = a% + End If + End If + Next +End Sub + +'#################################################################################################################### + +Sub findShadow (startX, startY, startZ, rayX, rayY, rayZ, lastObj%, noShadows%) + noShadows% = -1 + For a% = numObjects% To 1 Step -1 + If a% <> lastObj% Then + Select Case objectType%(a%) + Case FLOOR: + depth = -startZ / rayZ + Case SPHERE: + posX = positionX(a%) - startX + posY = positionY(a%) - startY + posZ = positionZ(a%) - startZ + + r = rayX * posX + rayY * posY + rayZ * posZ + d = r * r - posX * posX - posY * posY - posZ * posZ + size(a%) * size(a%) + If d >= 0 Then depth = r - Sqr(d) Else depth = -1 + End Select + + If depth >= 0 Then + noShadows% = 0 + Exit Sub + End If + End If + Next +End Sub + +'#################################################################################################################### +'#################################################################################################################### +'#################################################################################################################### + +Sub makeTextures + Print "Generating textures. Press any key to see them generating." + View Print 2 To 40 + showing = 0 + + world& = _NewImage(128, 64, 32) + texture&(1) = _NewImage(1024, 512, 32) + texture&(2) = _NewImage(1024, 512, 32) + texture&(3) = _NewImage(512, 512, 32) + texture&(4) = _NewImage(512, 512, 32) + + If showing Then Screen world& Else _Dest 0: Print: Print "(1/5) Decompressing world template (RLE)"; + + x% = 0: y% = 0 + For a% = 1 To 25 + _Dest world& + Read a$ + For b! = 1 To Len(a$) + c% = (Asc(Mid$(a$, b!, 1)) - 35) * 4 + If c% < 0 Then n% = Asc(Mid$(a$, b! + 1, 1)) - 34: b! = b! + 2: c% = (Asc(Mid$(a$, b!, 1)) - 35) * 4 Else n% = 1 + For n% = n% To 1 Step -1 + PSet (x%, y%), _RGB(c%, c%, c%) + x% = x% + 1: If x% = 128 Then x% = 0: y% = y% + 1 + Next + Next + If Len(InKey$) Then showing = -1: Screen world& Else If Not showing Then _Dest 0: Print "."; + Next + + If showing Then Screen texture&(1) Else _Dest 0: Print: Print "(2/5) World bump map"; + + For y% = 0 To 511 + _Source world& + _Dest texture&(1) + For x% = 0 To 1023 + getWorldBump x% / 3000, y% / 2000, a! + a! = (a! - 0.387) / 0.502: a! = a! * a! + getWorldPixel x% / 8 - 0.5, y% / 8 - 0.50, c! + c! = c! / 255: If c! > 1 Then c! = 1 + + r! = 11 + (24 + 231 * a! - 11) * c! + g! = 10 + (49 + 198 * a! - 10) * c! + b! = 50 + (8 + 181 * a! - 50) * c! + + PSet (x%, y%), _RGB32(r!, g!, b!) + Next + If Len(InKey$) Then showing = -1: Screen texture&(1) Else If Not showing Then _Dest 0: Print "."; + Next + + If showing Then Screen texture&(2) Else _Dest 0: Print: Print "(3/5) World bump map"; + + For y% = 0 To 511 + _Source world& + _Dest texture&(2) + For x% = 0 To 1023 + getWorldPixel x% / 8 - 0.46, y% / 8 - 0.50, c0!: getWorldBump x% / 300 + 0.001, y% / 300, a0!: a0! = a0! * c0! + getWorldPixel x% / 8 - 0.54, y% / 8 - 0.50, c1!: getWorldBump x% / 300 - 0.001, y% / 300, a1!: a1! = a1! * c1! + getWorldPixel x% / 8 - 0.50, y% / 8 - 0.46, c2!: getWorldBump x% / 300, y% / 300 + 0.001, a2!: a2! = a2! * c2! + getWorldPixel x% / 8 - 0.50, y% / 8 - 0.54, c3!: getWorldBump x% / 300, y% / 300 - 0.001, a3!: a3! = a3! * c3! + + r! = (a1! - a0!) * 7 + g! = (a2! - a3!) * 7 + PSet (x%, y%), _RGB32(r! + 127, g! + 127, 127) + Next + If Len(InKey$) Then showing = -1: Screen texture&(2) Else If Not showing Then _Dest 0: Print "."; + Next + + If showing Then Screen texture&(3) Else _Dest 0: Print: Print "(4/5) Floor texture"; + + For y% = 0 To 511 + _Dest texture&(3) + For x% = 0 To 511 + getFloorTexture x% / 256, y% / 256, r!, g!, b! + PSet (x%, y%), _RGB32(r! * 255, g! * 255, b! * 255) + Next + If Len(InKey$) Then showing = -1: Screen texture&(2) Else If Not showing Then _Dest 0: Print "."; + Next + + If showing Then Screen texture&(4) Else _Dest 0: Print: Print "(5/5) Floor bump map"; + + For y% = 0 To 511 + _Dest texture&(4) + For x% = 0 To 511 + getFloorBump x% / 256 - 0.002, y% / 256, a0! + getFloorBump x% / 256 + 0.002, y% / 256, a1! + getFloorBump x% / 256, y% / 256 + 0.002, a2! + getFloorBump x% / 256, y% / 256 - 0.002, a3! + + r! = (a1! - a0!) * 1400 + g! = (a2! - a3!) * 1400 + + PSet (x%, y%), _RGB32(r! + 127, g! + 127, 127) + Next + If Len(InKey$) Then showing = -1: Screen texture&(4) Else If Not showing Then _Dest 0: Print "."; + Next +End Sub + +'#################################################################################################################### + +Sub getWorldPixel (x!, y!, c0!) + x% = Int(x!) And &H7F + y% = Int(y!) And &H3F + dx! = x! - x%: If dx! < 0 Then dx! = dx! + 128 + dy! = y! - y% + + + c0! = Point(x%, y%) And &HFF + c1! = Point((x% + 1) And &H7F, y%) And &HFF + c2! = Point(x%, y% + 1) And &HFF + c3! = Point((x% + 1) And &H7F, y% + 1) And &HFF + + c0! = c0! + (c1! - c0!) * dx! + c2! = c2! + (c3! - c2!) * dx! + c0! = c0! + (c2! - c0!) * dy! + + c0! = c0! - 72: If c0! < 0 Then c0! = 0 +End Sub + + +Sub getWorldBump (u!, v!, a!) + l! = 0 + fbm u!, v!, 1, l! + a! = 0.3 * l! + 0.2 +End Sub + + +Sub getFloorTexture (u!, v!, r!, g!, b!) + v1% = v! - Int(v!) < 0.5: u1% = u! - Int(u!) < 0.5 + + If u1% = v1% Then + l! = 0 + fbm u!, v!, 3, l! + l! = l! * 0.7 + fbm u!, v!, 2, l! + r! = 0.054 * l! + 0.61 + g! = 0.054 * l! + 0.42 + b! = 0.054 * l! + 0.25 + Else + l! = 0 + fbm u!, v!, 1, l! + l! = l! * 0.6 + fbm u!, v!, 0, l! + r! = 0.10 * l! + 0.05 + g! = 0.08 * l! - 0.04 + b! = 0.07 * l! - 0.06 + End If +End Sub + + +Sub getFloorBump (u!, v!, a!) + v1% = v! - Int(v!) < 0.5: u1% = u! - Int(u!) < 0.5 + v2! = v! * 2 - Int(v! * 2): v2! = 1 - v2! * (1 - v2!) * 4: v2! = v2! * v2!: v2! = 1 - v2! * v2! + u2! = u! * 2 - Int(u! * 2): u2! = 1 - u2! * (1 - u2!) * 4: u2! = u2! * u2!: u2! = 1 - u2! * u2! + + If u1% = v1% Then + l! = 0 + fbm u!, v!, 3, l! + l! = l! * 0.7 + fbm u!, v!, 2, l! + a! = 0.02 * l! + 0.7 + Else + l! = 0 + fbm u!, v!, 1, l! + l! = l! * 0.6 + fbm u!, v!, 0, l! + a! = 0.05 * l! + 0.6 + End If + + a! = a! * u2! * v2! + + 'a! = a! + (u2! * v2! - 1) ' * 0.88 + 'IF a! < 0.06 THEN a = RND * 0.02 +End Sub + +'#################################################################################################################### + +Sub fbm (x!, y!, a%, o!) + Select Case a% + Case 0: + zx! = x! * 40 - y! * 2 + zy! = y! + i% = -5 + Case 1: + zx! = x! * 50 + zy! = y! * 50 + i% = -2 + Case 2: + zx! = x! * 80 + zy! = y! * 80 + i% = -2 + Case 3: + zx! = x! * 30 + y! * 0.5 + zy! = y! * 2 + i% = -2 + End Select + + scale! = 1 + For i% = i% To 0 + zcx! = zx!: zx! = zcx! * 0.6 - zy! * 0.8: zy! = zcx! * 0.8 + zy! * 0.6 + zcx! = CInt(zx! / scale!) * scale!: zcy! = CInt(zy! / scale!) * scale! + + rx1! = zcx! + 0.5 * scale! + 14: ry1! = zcy! + 0.5 * scale!: r! = 123094 / (rx1! * rx1! + ry1! * ry1!) + rx1! = rx1! * r!: ry1! = ry1! * r!: rx1! = rx1! - Int(rx1!): ry1! = ry1! - Int(ry1!) + rx2! = zcx! - 0.5 * scale! + 14: ry2! = zcy! + 0.5 * scale!: r! = 123094 / (rx2! * rx2! + ry2! * ry2!) + rx2! = rx2! * r!: ry2! = ry2! * r!: rx2! = rx2! - Int(rx2!): ry2! = ry2! - Int(ry2!) + rx3! = zcx! + 0.5 * scale! + 14: ry3! = zcy! - 0.5 * scale!: r! = 123094 / (rx3! * rx3! + ry3! * ry3!) + rx3! = rx3! * r!: ry3! = ry3! * r!: rx3! = rx3! - Int(rx3!): ry3! = ry3! - Int(ry3!) + rx4! = zcx! - 0.5 * scale! + 14: ry4! = zcy! - 0.5 * scale!: r! = 123094 / (rx4! * rx4! + ry4! * ry4!) + rx4! = rx4! * r!: ry4! = ry4! * r!: rx4! = rx4! - Int(rx4!): ry4! = ry4! - Int(ry4!) + x0! = (zx! - zcx!) / scale! + 0.5: x0! = (3 - 2 * x0!) * x0! * x0!: x1! = 1 - x0! + y0! = (zy! - zcy!) / scale! + 0.5: y0! = (3 - 2 * y0!) * y0! * y0!: y1! = 1 - y0! + pixcompx! = rx1! * x0! * y0! + rx3! * x0! * y1! + rx2! * x1! * y0! + rx4! * x1! * y1! + pixcompy! = ry1! * x0! * y0! + ry3! * x0! * y1! + ry2! * x1! * y0! + ry4! * x1! * y1! + o! = o! + Sqr(pixcompx! * pixcompx! + pixcompy! * pixcompy!) * scale! * scale!: scale! = scale! * 0.8 + Next +End Sub + +'#################################################################################################################### +'#################################################################################################################### +'#################################################################################################################### + +Sub makeScene + objectType%(1) = FLOOR + colorR!(1) = 1 + colorG!(1) = 1 + colorB!(1) = 1 + colorA!(1) = 1 + specular!(1) = 2 + highlight!(1) = 0.002 + reflection!(1) = 0.5 + texturePrepare textures(1), texture&(3), .005, .005, 0, 0, 0 + texturePrepare bumpmap(1), texture&(4), .005, .005, 0, 0, 1 + + objectType%(2) = SPHERE + positionX(2) = 0 + positionY(2) = 57.735 + positionZ(2) = 50 + size(2) = 50 + colorR!(2) = 1 + colorG!(2) = 0 + colorB!(2) = 0 + colorA!(2) = 1 + specular!(2) = 1 + highlight!(2) = 0.1 + reflection!(2) = 0.1 + texturePrepare textures(2), -1, 1, 1, 0, 0, 0 + texturePrepare bumpmap(2), -1, 1, 1, 0, 0, 1 + + objectType%(3) = SPHERE + positionX(3) = -50 + positionY(3) = -28.8675 + positionZ(3) = 50 + size(3) = 50 + colorR!(3) = 0 + colorG!(3) = 0 + colorB!(3) = 1 + colorA!(3) = 1 + specular!(3) = 1 + highlight!(3) = 0.04 + reflection!(3) = 0.4 + texturePrepare textures(3), -1, 1, 1, 0, 0, 0 + texturePrepare bumpmap(3), -1, 1, 1, 0, 0, 1 + + objectType%(4) = SPHERE + positionX(4) = 50 + positionY(4) = -28.8675 + positionZ(4) = 50 + size(4) = 50 + colorR!(4) = 0 + colorG!(4) = 1 + colorB!(4) = 0 + colorA!(4) = 1 + specular!(4) = 10 + highlight!(4) = 0.01 + reflection!(4) = 0.2 + texturePrepare textures(4), -1, 1, 1, 0, 0, 0 + texturePrepare bumpmap(4), -1, 1, 1, 0, 0, 1 + + objectType%(5) = SPHERE + positionX(5) = 0 + positionY(5) = 0 + positionZ(5) = 132 + size(5) = 50 + colorR!(5) = 1 + colorG!(5) = 1 + colorB!(5) = 1 + colorA!(5) = 1 + specular!(5) = 5 + highlight!(5) = 0.002 + reflection!(5) = 0.15 + texturePrepare textures(5), texture&(1), 1, 1, 0.35, 0, 0 + texturePrepare bumpmap(5), texture&(2), 1, 1, 0.35, 0, 1 + + numObjects% = 5 + + lightX(1) = 460 + lightY(1) = -460 + lightZ(1) = 460 + lightR!(1) = 1 + lightG!(1) = 0.25 + lightB!(1) = 0.25 + + lightX(2) = -640 + lightY(2) = -180 + lightZ(2) = 460 + lightR!(2) = 0.25 + lightG!(2) = 1 + lightB!(2) = 0.25 + + lightX(3) = 80 + lightY(3) = 260 + lightZ(3) = 760 + lightR!(3) = 0.25 + lightG!(3) = 0.25 + lightB!(3) = 1 + + lightX(4) = 0 + lightY(4) = 0 + lightZ(4) = 400 + lightR!(4) = 1 + lightG!(4) = 1 + lightB!(4) = 1 + + numLights% = 4 +End Sub + +'#################################################################################################################### + +Sub texturePrepare (tex As TEXTURE, handle&, sU!, sV!, oU!, oV!, bumpfactor!) + tex.image = handle& + If handle& <> -1 Then + tex.w = _Width(tex.image) + tex.h = _Height(tex.image) + tex.scaleU = sU! * tex.w + tex.scaleV = sV! * tex.h + tex.offsetU = oU! * tex.w + tex.offsetV = oV! * tex.h + tex.bumpfactor = bumpfactor! + End If +End Sub + +'#################################################################################################################### +'# Math Library V0.11 (routines) +'# By Zom-B +'#################################################################################################################### + +Function remainder% (a%, b%) + remainder% = a% - Int(a% / b%) * b% +End Function + +'> merger: Skipping unused FUNCTION fRemainder (a, b) + +'#################################################################################################################### + +'> merger: Skipping unused FUNCTION safeLog (x) + +'#################################################################################################################### + +'> merger: Skipping unused FUNCTION asin (y) + +Function acos (y) + If y <= -0.99999999999999# Then acos = _Pi: Exit Function + If y >= 0.99999999999999# Then acos = 0: Exit Function + acos = pi05 - Atn(y / Sqr(1 - y * y)) +End Function + +'> merger: Skipping unused FUNCTION safeAcos (y) + +Function atan2 (y, x) + If x > 0 Then + atan2 = Atn(y / x) + ElseIf x < 0 Then + If y > 0 Then + atan2 = Atn(y / x) + _Pi + Else + atan2 = Atn(y / x) - _Pi + End If + ElseIf y > 0 Then + atan2 = _Pi / 2 + Else + atan2 = -_Pi / 2 + End If +End Function + +'#################################################################################################################### +'# Vector math library v0.1 (module part) +'# By Zom-B +'#################################################################################################################### + +Sub vectorScale (a As VECTOR, scale) + a.x = a.x * scale + a.y = a.y * scale + a.z = a.z * scale +End Sub + +Sub vectorNormalize (a As VECTOR) + r = 1 / Sqr(a.x * a.x + a.y * a.y + a.z * a.z) + a.x = a.x * r + a.y = a.y * r + a.z = a.z * r +End Sub + +'#################################################################################################################### + +Sub vectorCross (a As VECTOR, b As VECTOR, o As VECTOR) + o.x = a.y * b.z - a.z * b.y + o.y = a.z * b.x - a.x * b.z + o.z = a.x * b.y - a.y * b.x +End Sub + +'#################################################################################################################### +'# Screen mode selector v1.1 (routines) +'# By Zom-B +'#################################################################################################################### + +Function selectScreenMode& (yOffset%, colors%) + Dim aspectName$(0 To 9), aspectCol%(0 To 9) + Restore videoaspect + For y% = 0 To 10 + Read aspectName$(y%), aspectCol%(y%) + If aspectCol%(y%) = 0 Then numAspect% = y% - 1: Exit For + Next + + Dim vidX%(1 To 100), vidY%(1 To 100), vidA%(1 To 100) + Restore videomodes + For y% = 1 To 100 + Read vidX%(y%), vidY%(y%), vidA%(y%) + If (vidX%(y%) <= 0) Then numModes% = y% - 1: Exit For + Next + + If numModes% > _Height - yOffset% - 1 Then numModes% = _Height - yOffset% - 1 + + Def Seg = &HB800 + Locate yOffset% + 1, 1 + Print "Select video mode:"; Tab(61); "Click " + Poke yOffset% * 160 + 132, 31 + + y% = 0 + lastY% = 0 + selectedAspect% = 0 + reprint% = 1 + lastButton% = 0 + Do + If InKey$ = Chr$(27) Then Cls: System + If reprint% Then + reprint% = 0 + + For x% = 1 To numModes% + Locate yOffset% + x% + 1, 1 + Color 7, 0 + Print Using "##:"; x%; + If selectedAspect% = 0 Then + Color aspectCol%(vidA%(x%)) + ElseIf selectedAspect% = vidA%(x%) Then + Color 15 + Else + Color 8 + End If + Print Str$(vidX%(x%)); ","; vidY%(x%); + Next + + For x% = 0 To numAspect% + If x% > 0 And selectedAspect% = x% Then + Color aspectCol%(x%), 3 + Else + Color aspectCol%(x%), 0 + End If + Locate yOffset% + x% + 2, 64 + Print "<"; aspectName$(x%); ">" + Next + End If + If _MouseInput Then + If lastY% > 0 Then + For x% = 0 To 159 Step 2 + Poke lastY% + x%, Peek(lastY% + x%) And &HEF + Next + End If + + x% = _MouseX + y% = _MouseY - yOffset% - 1 + + If x% <= 60 Then + If y% > 0 And y% <= numModes% Then + If _MouseButton(1) = 0 And lastButton% Then Exit Do + y% = (yOffset% + y%) * 160 + 1 + For x% = 0 To 119 Step 2 + Poke y% + x%, Peek(y% + x%) Or &H10 + Next + Else + y% = 0 + End If + Else + If y% > 0 And y% - 1 <= numAspect% Then + If _MouseButton(1) Then + selectedAspect% = y% - 1 + reprint% = 1 + End If + y% = (yOffset% + y%) * 160 + 1 + For x% = 120 To 159 Step 2 + Poke y% + x%, Peek(y% + x%) Or &H10 + Next + Else + y% = 0 + End If + End If + lastY% = y% + lastButton% = _MouseButton(1) + End If + Loop + + selectScreenMode& = _NewImage(vidX%(y%), vidY%(y%), colors%) + + Color 7 + Cls +End Function + diff --git a/samples/ray-tracer.md b/samples/ray-tracer.md new file mode 100644 index 0000000..9ff4279 --- /dev/null +++ b/samples/ray-tracer.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: RAY TRACER + +**[Lens Simulator](lens-simulator/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [2d](2d.md), [ray tracer](ray-tracer.md) + +This program simulates light rays passing through a lens with a given index of refraction and con... + +**[Ray Tracer Z](ray-tracer-z/index.md)** + +[🐝 Zom-B](zom-b.md) 🔗 [3d](3d.md), [ray tracer](ray-tracer.md) + +This is a ray tracer I've been working on for the past 6 years. Well, on and off of course :) It'... diff --git a/samples/raycaster/index.md b/samples/raycaster/index.md index 55352a3..c811f7b 100644 --- a/samples/raycaster/index.md +++ b/samples/raycaster/index.md @@ -34,9 +34,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "rc-ent6.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/raycaster/src/rc-ent6.bas) -* [RUN "rc-ent6.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/raycaster/src/rc-ent6.bas) -* [PLAY "rc-ent6.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/raycaster/src/rc-ent6.bas) +* [LOAD "rc-ent6.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/raycaster/src/rc-ent6.bas) +* [RUN "rc-ent6.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/raycaster/src/rc-ent6.bas) +* [PLAY "rc-ent6.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/raycaster/src/rc-ent6.bas) ### File(s) diff --git a/samples/relief-3d/img/sscreenshot.png b/samples/relief-3d/img/sscreenshot.png new file mode 100644 index 0000000..c091d38 Binary files /dev/null and b/samples/relief-3d/img/sscreenshot.png differ diff --git a/samples/relief-3d/index.md b/samples/relief-3d/index.md new file mode 100644 index 0000000..306d3b9 --- /dev/null +++ b/samples/relief-3d/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: RELIEF 3D + +![sscreenshot.png](img/sscreenshot.png) + +### Author + +[🐝 Danilin](../danilin.md) + +### Description + +```text +Isometric 3D demo. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "relief3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/relief-3d/src/relief3d.bas) +* [RUN "relief3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/relief-3d/src/relief3d.bas) +* [PLAY "relief3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/relief-3d/src/relief3d.bas) + +### File(s) + +* [relief3d.bas](src/relief3d.bas) + +🔗 [graphics](../graphics.md), [isometric](../isometric.md) diff --git a/samples/relief-3d/src/relief3d.bas b/samples/relief-3d/src/relief3d.bas new file mode 100644 index 0000000..1bc2cda --- /dev/null +++ b/samples/relief-3d/src/relief3d.bas @@ -0,0 +1,54 @@ +' Created by QB64 community member DANILIN + +$NoPrefix +Option Explicit +Option ExplicitArray + +Dim As Long n, q, y, x, t, i, j + +n = 200 +q = 15 +Screen 12 + +Dim a(q + 1, n) 'relup.bas 5d relief up + +For x = 1 To q + For y = 1 To n - 5 + If Int(Rnd * 100) Mod 7 = 5 Then + a(x, y) = 5 + a(x, y + 1) = 10 + a(x, y + 2) = 20 + a(x, y + 3) = 40 + a(x, y + 4) = 80 + y = y + 5 + End If + Next +Next + +For t = 1 To n - q + For i = 1 To q - 1 + For j = 1 To q - 1 + a(i, j) = a(i, j + t) + Next + Next + + Delay 0.1 + Cls + + For y = 1 To q - 1 + For x = 1 To q - 2 + Line (30 + 20 * x + 20 * y, 400 - 20 * y - a(x, y))-(30 + 20 * (x + 1) + 20 * y, 400 - 20 * y - a(x + 1, y)), (y + t Mod 7) + 1 + Next + Next + + For x = 1 To q - 1 + For y = 1 To q - 2 + Line (30 + 20 * x + 20 * y, 400 - 20 * y - a(x, y))-(30 + 20 * (x + 1) + 20 * y, 400 - 20 * (y + 1) - a(x, y + 1)), 7 + Next + Next + + Display +Next + +End + diff --git a/samples/reversi/index.md b/samples/reversi/index.md index 9760ca0..c50c72c 100644 --- a/samples/reversi/index.md +++ b/samples/reversi/index.md @@ -18,9 +18,9 @@ Reversi game by Microsoft. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "reversi.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/reversi/src/reversi.bas) -* [RUN "reversi.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/reversi/src/reversi.bas) -* [PLAY "reversi.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/reversi/src/reversi.bas) +* [LOAD "reversi.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/reversi/src/reversi.bas) +* [RUN "reversi.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/reversi/src/reversi.bas) +* [PLAY "reversi.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/reversi/src/reversi.bas) ### File(s) diff --git a/samples/rho-sigma.md b/samples/rho-sigma.md index 07d0220..234a6b4 100644 --- a/samples/rho-sigma.md +++ b/samples/rho-sigma.md @@ -8,6 +8,12 @@ '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... +**[Binary Clock](binary-clock/index.md)** + +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + **[Kaleidoscope](kaleidoscope/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) @@ -20,6 +26,30 @@ '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... +**[Lightning One](lightning-one/index.md)** + +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + +**[Lightning Two](lightning-two/index.md)** + +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + +**[Multi-Mill](multi-mill/index.md)** + +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + +**[Mystify](mystify/index.md)** + +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) + +'+---------------+---------------------------------------------------+ '|_######_######_|_____.--... + **[Splines](splines/index.md)** [🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) diff --git a/samples/rhosigma.md b/samples/rhosigma.md index ba15623..d85a9d5 100644 --- a/samples/rhosigma.md +++ b/samples/rhosigma.md @@ -2,38 +2,8 @@ ## 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 febf9a8..3654495 100644 --- a/samples/richard-frost.md +++ b/samples/richard-frost.md @@ -2,6 +2,12 @@ ## SAMPLES BY RICHARD FROST +**[Chess](chess/index.md)** + +[🐝 Richard Frost](richard-frost.md) 🔗 [game](game.md), [chess](chess.md) + +Eccentric chess implementation by Richard Frost. + **[Convert BMP to Dominoes](convert-bmp-to-dominoes/index.md)** [🐝 Richard Frost](richard-frost.md) 🔗 [image processing](image-processing.md) diff --git a/samples/robo-raider/img/screenshot.png b/samples/robo-raider/img/screenshot.png new file mode 100644 index 0000000..032596d Binary files /dev/null and b/samples/robo-raider/img/screenshot.png differ diff --git a/samples/robo-raider/index.md b/samples/robo-raider/index.md new file mode 100644 index 0000000..1868bab --- /dev/null +++ b/samples/robo-raider/index.md @@ -0,0 +1,25 @@ +[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: ROBO RAIDER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Kevin](../kevin.md) + +### Description + +```text +****RoboRaider**** + ****README.TXT**** + + Robo Raider is Copyright 2004 by Kevin +``` + +### File(s) + +* [roboraid.bas](src/roboraid.bas) +* [roboraid.zip](src/roboraid.zip) + +🔗 [game](../game.md) diff --git a/samples/robo-raider/src/roboraid.bas b/samples/robo-raider/src/roboraid.bas new file mode 100644 index 0000000..cb876dc --- /dev/null +++ b/samples/robo-raider/src/roboraid.bas @@ -0,0 +1,6046 @@ +'****************************** ROBORAIDER ********************************* +'********************************** by ************************************* +'***************************** x.t.r.GRAPHICS (TM) ************************* + +'**************************** PRESS TO PLAY!! ************************* + +'############### Copyright 2004 by Kevin ################ + +$NoPrefix +$Resize:Smooth + +Call Intro + +Sub Bonus + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>BONUS>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>GAME-TRAILER>>": Locate 11, 15: Color 15: Print ">>ROBO-PICS<<": Locate 13, 15: Color 15: Print ">>MENU<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>GAME-TRAILER<<": Locate 11, 15: Color 9: Print ">>ROBO-PICS>>": Locate 13, 15: Color 15: Print ">>MENU<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>GAME-TRAILER<<": Locate 11, 15: Color 15: Print ">>ROBO-PICS<<": Locate 13, 15: Color 14: Print ">>MENU>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Trailer + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Robopic + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Menu + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End +End Sub + +Sub Credits + Play "MB O4" + Cls + Screen 13 + Locate 22, 1 + '######## Robo Theme ####### + Play "E16 G E16 C2 C G E E3 G E C3 E16 G E16 C2 C16 C G3 E16 E E16 G F E G C3 E16 G E16 C2" + Color 10 + Print " Credits" + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print " Main Programer Kevin" + Sleep (1) + Print + Sleep (1) + Print " Graphics Kevin" + Sleep (1) + Print + Sleep (1) + Print " Debuging Kevin" + Sleep (1) + Print + Sleep (1) + Print + Color 9 + Sleep (1) + Print + Sleep (1) + Print " Special Thanks" + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print " Anyone who plays my games :)" + Sleep (1) + Print + Sleep (1) + Print " Vic's Qbasic Programing Tutorials" + Sleep (1) + Print + Sleep (1) + Print " Mallard's 'Basic Basic' Tutorials" + Sleep (1) + Print + Sleep (1) + Print " Qbasic By Exaple (by Greg Perry)" + Sleep (1) + Print + Color 14 + Sleep (1) + Print + Sleep (1) + Print " Cool sites " + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print " www.qbasic.com" + Sleep (1) + Print + Sleep (1) + Print " www.qbasicnews.com" + Sleep (1) + Print + Sleep (1) + Print " Those 2 sites link to more" + Sleep (1) + Print + Sleep (1) + Print " Look out for RoboRaider II" + Sleep (1) + Print + Sleep (1) + Print " Play all levels for Bonus Levelcode!" + Sleep (1) + Print + Sleep (1) + Print + Color 7 + Sleep (1) + Print " This is the Classic style of Robo-" + Sleep (1) + Print " Raider, I hope to have a Hi-Def " + Sleep (1) + Print " version of this one and the second" + Sleep (1) + Print " one next year." + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + Sleep (1) + Print + + Call Menu +End Sub + +Sub Creep + Cls + Screen 13 + Line (10, 37)-(20, 45), 8, BF + Line (20, 35)-(160, 50), 10, BF + Line (22, 36)-(158, 36), 8 + Line (22, 60)-(158, 60), 8 + Circle (22, 48), 15, 7 + Paint (22, 48), 7 + PSet (22, 48), 0 + Circle (158, 48), 15, 7 + Paint (158, 48), 7 + PSet (158, 48), 0 + Locate 10, 1: Print " Creeper: Mission 3:" + Locate 12, 1: Print " Did someone step on it? Nope this" + Locate 13, 1: Print " Bot is made for tight places. Like" + Locate 14, 1: Print " low hanging ceilings." + Color 10 + Locate 17, 1: Print " Press SPACEBAR to continue..." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Missionb + +End Sub + +Sub Dril + Cls + Screen 13 + Line (60, 20)-(160, 50), 9, BF + Line (60, 20)-(20, 35), 8 + Line (20, 35)-(60, 50), 8 + Line (60, 50)-(60, 20), 8 + Paint (55, 35), 8 + Line (70, 36)-(158, 36), 8 + Line (70, 60)-(158, 60), 8 + Circle (70, 48), 15, 7 + Paint (70, 48), 7 + PSet (70, 48), 0 + Circle (158, 48), 15, 7 + Paint (158, 48), 7 + PSet (158, 48), 0 + Locate 10, 1: Print " Trainer-Bot: Test 1-2:" + Locate 12, 1: Print " A simple desinged robot for easy" + Locate 13, 1: Print " repairs. Used for the first two" + Locate 14, 1: Print " test in case of a crash." + Color 10 + Locate 17, 1: Print " Press SPACEBAR to continue..." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Missionb2 + + End +End Sub + +Sub Drop + Cls + Screen 13 + Line (10, 32)-(20, 45), 8, BF + Line (20, 30)-(160, 50), 12, BF + Line (22, 36)-(158, 36), 8 + Line (22, 60)-(158, 60), 8 + '** SPIKE ** + Line (130, 29)-(110, 29), 7 + Line (130, 29)-(120, 10), 7: Line (110, 29)-(120, 10), 7 + Paint (120, 20), 7 + Line (120, 10)-(120, 29), 8 + '** WHEELS ** + Circle (22, 48), 15, 7 + Paint (22, 48), 7 + PSet (22, 48), 0 + Circle (158, 48), 15, 7 + Paint (158, 48), 7 + PSet (158, 48), 0 + Locate 10, 1: Print " Drop-Bot: Mission 4:" + Locate 12, 1: Print " This Bot has a harpoon to raise " + Locate 13, 1: Print " and lower itself to different " + Locate 14, 1: Print " levels of terrain." + Color 10 + Locate 17, 1: Print " Press SPACEBAR to continue..." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Missionb2 + +End Sub + +Sub Ending + Screen 13 + Color 15 + Cls + Print " Dr Robo's Notes:" + Print + Print " I inserted all the gems into the" + Print " disk. It began to glow, and then " + Print " another slot melted into the center. " + Print " There is another gem!! I must research," + Print " but until then then, my pilot needs a " + Print " break...." + Print " I'll give him a vacation while I " + Print " dig up the location of the last gem." + Print " Hopefuly the mystery will be solved," + Print " and we can find out what this does..." + Print + Print + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Bonus +End Sub + +Sub Help + Cls + Print " Help File:" + Print + Print " First thing first: to highlight" + Print " other menu commands, use the arrow- " + Print " keys. Press 'Enter' to select" + Print " Robots move with the arrowkeys. The" + Print " grip on the collecter bots operate" + Print " automaticaly when a item is in their" + Print " reach. You can press 'Esc' almost" + Print " anywhere in the game to exit." + Print " For any more help, open the README.TXT" + Print " located with this game." + Print + Color 10 + Print " Press any key to return" + Do + Loop While InKey$ = "" + Call Menu +End Sub + +Sub Intro + Play "MB <" + Cls + Screen 13 + FullScreen SquarePixels , Smooth + '######## Robo Theme ####### + Play "E16 G E16 C2 C G E E3 G E C3 E16 G E16 C2 C16 C G3 E16 E E16 G F E G C3 E16 G E16 C2" + '######## Intro ####### + Locate 10, 15: Color 44: Print "xt": Locate 10, 17: Color 43: Print "GRAP": Locate 10, 21: Color 42: Print "HICS(TM)": Color 15 + Sleep (3) + Cls + Locate 10, 13: Color 42: Print ">>>": Locate 10, 16: Color 43: Print "PRE": Locate 10, 19: Color 44: Print "SE": Locate 10, 21: Color 43: Print "NTS": Locate 10, 23: Color 42: Print ">>>": Color 15 + Sleep (3) + Cls + Locate 10, 14: Color 7: Print "RoboRaider": Color 15 + Sleep (3) + Cls + Print " Dr. Robo's Notes:" + Print + Print " Note to self: My last Robo-Raider," + Print " while exploring a cave, carelessly " + Print " hit a trip wire destoring one of my " + Print " finest robots. For this run on with " + Print " a rolling rock, I myself, slightly " + Print " inraged, carelessly fired him. Gee, " + Print " that leaves me with without a robot " + Print " pilot!" + Print " Note to self: Run ad in paper for " + Print " new pilot." + Color 10: Locate 23, 1: Print " Press SPACEBAR to continue...." + Do + press$ = InKey$ + Loop Until press$ = " " + Color 15 + + Print " NewsPaper AD:" + Print "" + Print " Dear R/C car fans, do you want to " + Print " be well paid for your piloting skills?" + Print " If so contact me at (###) ###-ROBO." + Print " Callers will have an appoitment setup " + Print " to take my tests. If you pass all three" + Print " tests completely, you will be hired on " + Print " the spot. " + Print + Print + Print + Print + Print + Print + Print + Print + Print + Print + Print + Print + Print + Print + Color 10: Locate 23, 1: Print " Press SPACEBAR to continue...." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Menu +End Sub + +Sub Levelcode + Cls + Screen 13 + Color 9 + Print " Turn on CAPS LOCK to type Levelcode." + Print " Press 'Enter' to check code." + Print " Levelcodes take you to levels you " + Print " last left off...." + Print + Print + Input " Insert Levelcode:", lcode$ + Print " Checking Levelcode>>"; lcode$ + Sleep (4) + + If lcode$ = "TEST001" Then GoTo swtch + If lcode$ = "TEST002" Then GoTo swtch + If lcode$ = "TEST003" Then GoTo swtch + If lcode$ = "POINTY" Then GoTo swtch + If lcode$ = "INDEEP" Then GoTo swtch + If lcode$ = "SUBRUINS" Then GoTo swtch + If lcode$ = "TOWER" Then GoTo swtch + If lcode$ = "WALLDRILL" Then GoTo swtch + If lcode$ = "AMAZEME" Then GoTo swtch + If lcode$ = "ROBOBONUS" Then GoTo swtch + If lcode$ <> "" Then GoTo err1 + If lcode$ = "" Then GoTo err1 + + swtch: Color 10 + Print + Print " "; lcode$; " is valid!" + Print " Enjoy this level!" + Sleep (6) + If lcode$ = "TEST001" Then Call Menu + If lcode$ = "TEST002" Then Call Menu2 + If lcode$ = "TEST003" Then Call Menu3 + If lcode$ = "POINTY" Then Call Menu4 + If lcode$ = "INDEEP" Then Call Menu5 + If lcode$ = "SUBRUINS" Then Call Menu6 + If lcode$ = "TOWER" Then Call Menu7 + If lcode$ = "WALLDRILL" Then Call Menu8 + If lcode$ = "AMAZEME" Then Call Menu9 + If lcode$ = "ROBOBONUS" Then Call Bonus + + err1: Color 12 + Print + Print " "; lcode$; " does not compute." + Print " To get a level's code, defeat" + Print " the level before it..." + Sleep (8) + Call Menu +End Sub + +Sub Mbrief01 + Cls + Screen 13 + Color 15 + Print " Mission Briefing:" + Print + Print " In your last mission, you " + Print " collected a round disk. This I " + Print " looked over carefuly, and I found" + Print " something... Your first Item, that" + Print " was found in the pyramid, the gem," + Print " fits perfecly in one of the slots." + Print " There are four more slots to fill." + Print " I've looked, and found what I think" + Print " are the rest. One of them I hope to" + Print " collect myself. Any way, I think " + Print " this might be important, lets get " + Print " the other gems and find out!" + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Mission03 +End Sub + +Sub Menu + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Test1>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Test001 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End +End Sub + +Sub Menu2 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Test2>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Test002 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Menu3 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Test3>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Test003 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Menu4 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Mission1>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Mission01 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Menu5 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Mission2>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Mission02 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Menu6 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Mission3>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Mbrief01 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Menu7 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Mission4>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Mission04 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + + +End Sub + +Sub Menu8 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Mission5>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Mission05 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Menu9 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Mission6>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>START>>": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 9: Print ">>LEVELCODE>>": Locate 13, 15: Color 15: Print ">>CREDITS<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>START<<": Locate 11, 15: Color 15: Print ">>LEVELCODE<<": Locate 13, 15: Color 14: Print ">>CREDITS>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Mission06 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Levelcode + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Credits + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Mission01 + Cls + Screen 7, 0, 1, 0 + Dim sch1(100), sch2(100), scv1(100), scv2(100), mask(100) + Play "MB L64 <<<" + Color 15 + Print " Mission Status:" + Print + Print " Mission 1: There has been" + Print " a recent discovery in a pyramid" + Print " over in Egypt of a small passage." + Print " It's to small for humans, but one" + Print " of my finest robots 'Scorpian' " + Print " can make the trip. My scans show" + Print " a object at the end of the shaft," + Print " and something else beyond it. " + Print " What ever that is you must find " + Print " out, good luck." + Print + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + + Cls + '############# ROBOT ########## + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 14, BF + Line (5, 1)-(6, 7), 12, BF + Line (5, 5)-(6, 8), 4, BF + PCopy 1, 0 + Get (1, 1)-(10, 10), sch1() + Cls + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 14, BF + Line (5, 3)-(6, 10), 12, BF + Line (5, 7)-(6, 10), 4, BF + PCopy 1, 0 + Get (1, 1)-(10, 10), sch2() + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 14, BF + Line (1, 5)-(7, 6), 12, BF + Line (5, 5)-(8, 6), 4, BF + Get (1, 1)-(10, 10), scv1() + PCopy 1, 0 + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 14, BF + Line (3, 5)-(10, 6), 12, BF + Line (7, 5)-(10, 6), 4, BF + Get (1, 1)-(10, 10), scv2() + PCopy 1, 0 + Cls + Get (1, 1)-(10, 10), mask() + '######## LEVEL ######## + Line (150, 200)-(150, 50), 12 + Line (170, 200)-(170, 50), 12 + Line (150, 50)-(170, 50), 12 + Circle (160, 60), 2, 9: Paint (160, 60), 9 + PCopy 1, 0 + '######## Level INTRO #### + x = 155: y = 180 + stat$ = "Hmm, Scorpian's video feed shows a smaller shaft than my scans did. Never mind that, get that item." + Put (x, y), sch1(), PSet + Do + press$ = InKey$ + Locate 1, 1: Print stat$ + PCopy 1, 0 + Loop While press$ = "" + Cls + stat$ = "Collect Item:" + '######## LEVEL ######## + Line (150, 200)-(150, 50), 12 + Line (170, 200)-(170, 50), 12 + Line (150, 50)-(170, 50), 12 + PCopy 1, 0 + d = 1 + Do + press$ = InKey$ + Locate 1, 1: Print stat$ + '######## Item Code ####### + If i = 0 Then Circle (160, 60), 2, 9: Paint (160, 60), 9 Else Circle (160, 60), 2, 0: Paint (160, 60), 0 + If i = 1 Then Line (120, 50)-(200, 10), 12, B: Put (155, 46), mask(), PSet: Circle (160, 23), 10, 1: Paint (160, 23), 1: Circle (160, 23), 10, 7: stat$ = "Do not enter, there's a trip line on the door!" + If y = 62 Then If x = 155 Or x = 156 Then i = 1 + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '####### Wall codes ####### + If x = 150 Then GoTo mcrash1 + If x = 161 Then GoTo mcrash1 + If y = 50 Then GoTo mcrash1 + If i = 0 And y = 188 Then y = 187: stat$ = "Finish The Mission First!" + If i = 0 And y < 187 Then stat$ = "Collect Item: " + If i = 1 And y = 188 Then GoTo mfinish1 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + mfinish1: Cls + Color 10 + Print " You completed your first mission!" + Print + Print " Now for the next one!" + Print + Color 9 + Print + Print " This level's code is: POINTY" + Print " Next level's code is: INDEEP" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu5 + + mcrash1: Cls + Color 12 + Print " You Crashed My Robot!" + Print + Print " Sorry, You are fired!" + Print + Color 9 + Print + Print " This level's code is: POINTY" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + +End Sub + +Sub Mission02 + Screen 7, 0, 1, 0 + Dim sch1(100), sch2(100), scv1(100), scv2(100), mask(100) + Play "MB L64 <<<" + Color 15 + Print " Mission Status:" + Print + Print " Mission 2: Your next mission" + Print " takes you to a cave with, you " + Print " guessed, a entrance to small for" + Print " humans. My scans show a maze of " + Print " paths leading to a object. You " + Print " will be using Scorpian again, it's" + Print " more tactical than the others." + Print " You must watch your battery life," + Print " my bot has one of 30 minutes. But" + Print " be careful, I have towing bots," + Print " made just for pulling back a " + Print " stranded robot. Just don't crash!" + Color 9 + Print " NOTE: If the robot stops, its a " + Print " dead end, try a new direction" + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + '############# ROBOT ########## + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 14, BF + Line (5, 1)-(6, 7), 12, BF + Line (5, 5)-(6, 8), 4, BF + PCopy 1, 0 + Get (1, 1)-(10, 10), sch1() + Cls + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 14, BF + Line (5, 3)-(6, 10), 12, BF + Line (5, 7)-(6, 10), 4, BF + PCopy 1, 0 + Get (1, 1)-(10, 10), sch2() + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 14, BF + Line (1, 5)-(7, 6), 12, BF + Line (5, 5)-(8, 6), 4, BF + Get (1, 1)-(10, 10), scv1() + PCopy 1, 0 + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 14, BF + Line (3, 5)-(10, 6), 12, BF + Line (7, 5)-(10, 6), 4, BF + Get (1, 1)-(10, 10), scv2() + PCopy 1, 0 + Cls + Get (1, 1)-(10, 10), mask() + + m2seg1: Cls ' >>>SEGMENT #01<<<< + '######### LEVEL ######## + Line (150, 200)-(150, 100), 2 + Line (170, 200)-(170, 100), 2 + Line (0, 100)-(150, 100), 2 + Line (320, 100)-(170, 100), 2 + Line (0, 80)-(320, 80), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 155: y = 180: d = 1 + If segm = 1 Then x = 299: d = 2 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y > 90 Then GoTo mcrash2 + If x > 160 And y > 90 Then GoTo mcrash2 + If y = 80 Then GoTo mcrash2 + If x = 10 Then x = 11 + '########## DOOR CODES ########### + If i = 0 Then If y < 189 Then stat$ = "Collect Item:" + If i = 0 Then If y = 190 Then y = 189: stat$ = "Not Finished " + If i = 1 Then If y = 190 Then GoTo mfinish2 + If x = 305 Then segm = 0: GoTo m2seg2 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg2: Cls ' >>>SEGMENT #02<<< + '######### LEVEL ######## + Line (150, 0)-(150, 80), 2 + Line (170, 0)-(170, 80), 2 + Line (0, 80)-(150, 80), 2 + Line (320, 80)-(170, 80), 2 + Line (0, 100)-(320, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10: d = 4 + If segm = 1 Then y = 10: d = 3 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash2 + If x > 160 And y < 81 Then GoTo mcrash2 + If y = 91 Then GoTo mcrash2 + If x = 300 Then x = 299 + '########## DOOR CODES ######## + If x = 5 Then segm = 1: GoTo m2seg1 + If y = 5 Then segm = 0: GoTo m2seg3 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg3: Cls ' >>>SEGMENT #03<<< + '######### LEVEL ######## + Line (150, 0)-(150, 80), 2 + Line (170, 0)-(170, 80), 2 + Line (0, 80)-(150, 80), 2 + Line (320, 80)-(170, 80), 2 + Line (150, 200)-(150, 100), 2 + Line (170, 200)-(170, 100), 2 + Line (0, 100)-(150, 100), 2 + Line (320, 100)-(170, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180: d = 1 + If segm = 1 Then x = 299: d = 2 + If segm = 2 Then y = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash2 + If x > 160 And y < 81 Then GoTo mcrash2 + If x < 151 And y > 90 Then GoTo mcrash2 + If x > 160 And y > 90 Then GoTo mcrash2 + If x = 10 Then x = 11 + '########## DOOR CODES ########## + If y = 185 Then segm = 1: GoTo m2seg2 + If x = 305 Then segm = 0: GoTo m2seg4 + If y = 5 Then segm = 0: GoTo m2seg15 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg4: Cls ' >>> SEGMENT04 <<< + '######### LEVEL ############# + Line (0, 80)-(320, 80), 2 + Line (0, 100)-(320, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10: d = 4 + If segm = 1 Then x = 299: d = 2 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 80 Or y = 91 Then GoTo mcrash2 + '########## DOOR CODES ####### + If x = 5 Then segm = 1: GoTo m2seg3 + If x = 305 Then segm = 0: GoTo m2seg5 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg5: Cls ' >>> SEGMENT #05 <<< + '######### LEVEL ######## + Line (150, 0)-(150, 80), 2 + Line (170, 0)-(170, 80), 2 + Line (0, 80)-(150, 80), 2 + Line (320, 80)-(170, 80), 2 + Line (150, 200)-(150, 100), 2 + Line (170, 200)-(170, 100), 2 + Line (0, 100)-(150, 100), 2 + Line (320, 100)-(170, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then y = 10 + If segm = 2 Then y = 180 + If segm = 3 Then x = 300 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash2 + If x > 160 And y < 81 Then GoTo mcrash2 + If x < 151 And y > 90 Then GoTo mcrash2 + If x > 160 And y > 90 Then GoTo mcrash2 + '########## DOOR CODES ########## + If x = 5 Then segm = 1: GoTo m2seg4 + If y = 5 Then segm = 0: GoTo m2seg17 + If x = 305 Then segm = 1: GoTo m2seg14 + If y = 185 Then segm = 0: GoTo m2seg6 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg6: Cls ' >>> SEGMENT #06 <<< + '######### LEVEL ######## + Line (150, 0)-(150, 80), 2 + Line (170, 0)-(170, 80), 2 + Line (0, 80)-(150, 80), 2 + Line (320, 80)-(170, 80), 2 + Line (150, 200)-(150, 100), 2 + Line (170, 200)-(170, 100), 2 + Line (0, 100)-(150, 100), 2 + Line (320, 100)-(170, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 10 + If segm = 1 Then x = 10 + If segm = 2 Then x = 300 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash2 + If x > 160 And y < 81 Then GoTo mcrash2 + If x < 151 And y > 90 Then GoTo mcrash2 + If x > 160 And y > 90 Then GoTo mcrash2 + '########## DOOR CODES ########## + If x = 5 Then segm = 0: GoTo m2seg16 + If y = 5 Then segm = 2: GoTo m2seg5 + If x = 305 Then segm = 0: GoTo m2seg7 + If y = 185 Then y = 184 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg7: Cls ' >>> SEGMENT #07 <<< + '######### LEVEL ############# + Line (0, 80)-(320, 80), 2 + Line (0, 100)-(320, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10: d = 4 + If segm = 1 Then x = 299: d = 2 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 80 Or y = 91 Then GoTo mcrash2 + '########## DOOR CODES ####### + If x = 5 Then segm = 2: GoTo m2seg6 + If x = 305 Then segm = 0: GoTo m2seg8 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg8: Cls ' >>> SEGMENT #08 <<< + '######## LEVEL ######### + Line (0, 80)-(150, 80), 2 + Line (150, 80)-(150, 0), 2 + Line (0, 100)-(170, 100), 2 + Line (170, 100)-(170, 0), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then y = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash2 + If x = 161 Or y = 91 Then GoTo mcrash2 + '########## DOOR CODES ######### + If x = 5 Then segm = 1: GoTo m2seg7 + If y = 5 Then segm = 0: GoTo m2seg9 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg9: Cls ' >>> SEGMENT #09 <<< + '######## LEVEL ######### + Line (150, 200)-(150, 80), 2 + Line (150, 80)-(320, 80), 2 + Line (170, 200)-(170, 100), 2 + Line (170, 100)-(320, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180 + If segm = 1 Then x = 300 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 150 Or y = 80 Then GoTo mcrash2 + If x > 160 And y > 90 Then GoTo mcrash2 + '########## DOOR CODES ######### + If x = 305 Then segm = 0: GoTo m2seg10 + If y = 185 Then segm = 1: GoTo m2seg8 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg10: Cls ' >>> SEGMENT #10 <<< + '######## LEVEL ######### + Line (0, 80)-(150, 80), 2 + Line (150, 80)-(150, 0), 2 + Line (0, 100)-(170, 100), 2 + Line (170, 100)-(170, 0), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then y = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash2 + If x = 161 Or y = 91 Then GoTo mcrash2 + '########## DOOR CODES ######### + If x = 5 Then segm = 1: GoTo m2seg9 + If y = 5 Then segm = 0: GoTo m2seg11 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg11: Cls ' >>> SEGMENT #11 <<< + '########## LEVEL ######### + Line (150, 200)-(150, 100), 2 + Line (170, 200)-(170, 80), 2 + Line (150, 100)-(0, 100), 2 + Line (170, 80)-(0, 80), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180 + If segm = 1 Then x = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y > 90 Then GoTo mcrash2 + If x = 161 Or y = 80 Then GoTo mcrash2 + '########## DOOR CODES ########## + If y = 185 Then segm = 1: GoTo m2seg10 + If x = 5 Then segm = 0: GoTo m2seg12 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg12: Cls ' >>> SEGMENT #12 <<< + '######### LEVEL ############# + Line (0, 80)-(320, 80), 2 + Line (0, 100)-(320, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 300 + If segm = 1 Then x = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 80 Or y = 91 Then GoTo mcrash2 + '########## DOOR CODES ####### + If x = 5 Then segm = 0: GoTo m2seg13 + If x = 305 Then segm = 1: GoTo m2seg11 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg13: Cls ' >>> SEGMENT #13 <<< + '######## LEVEL ######### + Line (150, 200)-(150, 80), 2 + Line (150, 80)-(320, 80), 2 + Line (170, 200)-(170, 100), 2 + Line (170, 100)-(320, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 1 Then y = 180 + If segm = 0 Then x = 300 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 150 Or y = 80 Then GoTo mcrash2 + If x > 160 And y > 90 Then GoTo mcrash2 + '########## DOOR CODES ######### + If x = 305 Then segm = 1: GoTo m2seg12 + If y = 185 Then segm = 0: GoTo m2seg14 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + + m2seg14: Cls ' >>> SEGMENT #14 <<< + '######## LEVEL ######### + Line (0, 80)-(150, 80), 2 + Line (150, 80)-(150, 0), 2 + Line (0, 100)-(170, 100), 2 + Line (170, 100)-(170, 0), 2 + Line (151, 70)-(169, 60), 1, BF + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 10 + If segm = 1 Then x = 10 + If i = 0 Then stat$ = "Passage Blocked:" + If segm = 0 Then stat$ = "There it is!!" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## ITEM CODE ###### + If i = 0 Then Circle (160, 40), 3, 6: Paint (160, 40), 6 Else Circle (160, 40), 3, 0: Paint (160, 40), 0 + If x > 152 And x < 159 Then If y = 29 Or y = 42 Then i = 1: stat$ = "Exit Cave:Got Item" + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash2 + If x = 161 Or y = 91 Then GoTo mcrash2 + If y = 51 Or y = 70 Then GoTo mcrash2 + '########## DOOR CODES ######### + If x = 5 Then segm = 3: GoTo m2seg5 + If y = 5 Then segm = 1: GoTo m2seg13 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg15: Cls ' >>> SEGMENT #15 <<< + '######## LEVEL ######### + Line (150, 200)-(150, 80), 2 + Line (150, 80)-(320, 80), 2 + Line (170, 200)-(170, 100), 2 + Line (170, 100)-(320, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180: d = 1 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 150 Or y = 80 Then GoTo mcrash2 + If x > 160 And y > 90 Then GoTo mcrash2 + If x = 305 Then x = 304 + '########## DOOR CODES ######### + If y = 185 Then segm = 2: GoTo m2seg3 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg16: Cls ' >>> SEGMENT #16 <<< + '######## LEVEL ######### + Line (320, 100)-(150, 100), 2 + Line (320, 80)-(170, 80), 2 + Line (150, 100)-(150, 0), 2 + Line (170, 80)-(170, 0), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 300 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x > 160 And y < 81 Then GoTo mcrash2 + If x = 150 Or y = 90 Then GoTo mcrash2 + If y = 10 Then y = 11 + '########## DOOR CODES ########## + If x = 305 Then segm = 1: GoTo m2seg6 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m2seg17: Cls ' >>> SEGMENT #17 <<< + '######## LEVEL ######### + Line (150, 200)-(150, 80), 2 + Line (150, 80)-(320, 80), 2 + Line (170, 200)-(170, 100), 2 + Line (170, 100)-(320, 100), 2 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180: d = 1 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 150 Or y = 80 Then GoTo mcrash2 + If x > 160 And y > 90 Then GoTo mcrash2 + If x = 305 Then x = 304 + '########## DOOR CODES ######### + If y = 185 Then segm = 1: GoTo m2seg5 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + mfinish2: Cls + Color 10 + Print " You completed the mission!" + Print + Print " Now for the next one!" + Print + Color 9 + Print + Print " This level's code is: INDEEP" + Print " Next level's code is: SUBRUINS" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu6 + + dbtt: Cls + Color 14 + Print " Your battery ran out!" + Print + Print " Esc. = Exit| Try again?" + Print + Color 9 + Print + Print " This level's code is: INDEEP" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to Retry..." + PCopy 1, 0 + btt = 0 + Do + press$ = InKey$ + If press$ = Chr$(27) Then End + Loop Until press$ = " " + segm = 0 + GoTo m2seg1 + + End + + mcrash2: Cls + Color 12 + Print " You Crashed My Robot!" + Print + Print " Sorry, You are fired!" + Print + Color 9 + Print + Print " This level's code is: INDEEP" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + +End Sub + +Sub Mission03 + Screen 7, 0, 1, 0 + Dim crh1(100), crh2(100), crv1(100), crv2(100), mask(100) + Play "MB L64 <<<" + Color 15 + Print " Mission Status:" + Print + Print " Mission 3: In this mission, you" + Print " will be exploring a collapsed ruin. " + Print " My scans show me that my flat robot," + Print " 'Creeper' designed for getting under" + Print " things, should be able to retreive " + Print " the gem located there. It also has a" + Print " 30 minute battery life, this is " + Print " plenty of time to clear this level. " + Print " Take your time, and be careful. I " + Print " made a flat towing bot for any dead " + Print " batteries. Just don't crash!" + Print + Color 9 + Print " NOTE: If the robot stops, its a " + Print " dead end, try a new direction" + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + + '######### ROBOT ########## + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 9, BF + PSet (4, 1), 7: PSet (7, 1), 7 + PCopy 1, 0 + Get (1, 1)-(10, 10), crh1() + Cls + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 9, BF + PSet (4, 10), 7: PSet (7, 10), 7 + PCopy 1, 0 + Get (1, 1)-(10, 10), crh2() + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 9, BF + PSet (1, 4), 7: PSet (1, 7), 7 + Get (1, 1)-(10, 10), crv1() + PCopy 1, 0 + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 9, BF + PSet (10, 4), 7: PSet (10, 7), 7 + Get (1, 1)-(10, 10), crv2() + PCopy 1, 0 + Cls + Get (1, 1)-(10, 10), mask() + + m3seg1: Cls ' >>> SEGMENT #01 <<< + '######### LEVEL ######## + Line (150, 200)-(150, 0), 6 + Line (170, 200)-(170, 0), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 155: y = 180: d = 1 + If segm = 1 Then y = 10 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If y < 184 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 161 Then GoTo mcrash3 + If x = 150 Then GoTo mcrash3 + '########## DOOR CODES ########## + If i = 0 And y = 185 Then y = 184: stat$ = "Not Finished " ' ELSE GOTO mfinish3 + If i = 0 And y < 184 Then stat$ = "Collect Item:" + If y = 5 Then segm = 0: GoTo m3seg2 + If i = 1 And y = 185 Then GoTo mfinish3 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg2: Cls ' >>> SEGMENT #02 <<< + '######## LEVEL ######### + Line (150, 0)-(150, 80), 6 + Line (170, 0)-(170, 80), 6 + Line (0, 80)-(150, 80), 6 + Line (320, 80)-(170, 80), 6 + Line (150, 200)-(150, 100), 6 + Line (170, 200)-(170, 100), 6 + Line (0, 100)-(150, 100), 6 + Line (320, 100)-(170, 100), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180 + If segm = 1 Then x = 10 + If segm = 2 Then x = 300 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If y < 184 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash3 + If x > 160 And y < 81 Then GoTo mcrash3 + If x < 151 And y > 90 Then GoTo mcrash3 + If x > 160 And y > 90 Then GoTo mcrash3 + If y = 5 Then y = 6 + '########## DOOR CODES ########## + If x = 5 Then segm = 0: GoTo m3seg13 + If x = 305 Then segm = 0: GoTo m3seg3 + If y = 185 Then segm = 1: GoTo m3seg1 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg3: Cls ' >>> SEGMENT #03 <<< + '######### LEVEL ######## + Line (150, 0)-(150, 80), 6 + Line (170, 0)-(170, 80), 6 + Line (0, 80)-(150, 80), 6 + Line (320, 80)-(170, 80), 6 + Line (0, 100)-(320, 100), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then y = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash3 + If x > 160 And y < 81 Then GoTo mcrash3 + If y = 91 Then GoTo mcrash3 + If x = 300 Then x = 299 + '########## DOOR CODES ######## + If x = 5 Then segm = 2: GoTo m3seg2 + If y = 5 Then segm = 0: GoTo m3seg4 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg4: Cls ' >>> SEGMENT #04 <<< + '######### LEVEL ######## + Line (150, 200)-(150, 100), 6 + Line (170, 200)-(170, 100), 6 + Line (0, 100)-(150, 100), 6 + Line (320, 100)-(170, 100), 6 + Line (0, 80)-(320, 80), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180 + If segm = 1 Then x = 300 + If segm = 2 Then x = 10 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y > 90 Then GoTo mcrash3 + If x > 160 And y > 90 Then GoTo mcrash3 + If y = 80 Then GoTo mcrash3 + '########## DOOR CODES ########### + If y = 185 Then segm = 1: GoTo m3seg3 + If x = 5 Then segm = 1: GoTo m3seg15 + If x = 305 Then segm = 0: GoTo m3seg5 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg5: Cls ' >>> SEGMENT #05 <<< + '########## LEVEL ######## + Line (0, 80)-(150, 80), 6 + Line (0, 100)-(150, 100), 6 + Line (150, 0)-(150, 80), 6 + Line (150, 100)-(150, 200), 6 + Line (170, 0)-(170, 200), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then y = 10 + If segm = 2 Then y = 180 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash3 + If x < 151 And y > 90 Then GoTo mcrash3 + If x = 161 Then GoTo mcrash3 + '########## DOOR CODES ########## + If x = 5 Then segm = 1: GoTo m3seg4 + If y = 5 Then segm = 0: GoTo m3seg6 + If y = 185 Then segm = 0: GoTo m3seg16 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg6: Cls ' >>> SEGMENT #06 <<< + '########## LEVEL ######### + Line (150, 200)-(150, 100), 6 + Line (170, 200)-(170, 80), 6 + Line (150, 100)-(0, 100), 6 + Line (170, 80)-(0, 80), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180 + If segm = 1 Then x = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y > 90 Then GoTo mcrash3 + If x = 161 Or y = 80 Then GoTo mcrash3 + '########## DOOR CODES ########## + If y = 185 Then segm = 1: GoTo m3seg5 + If x = 5 Then segm = 1: GoTo m3seg7 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg7: Cls ' >>> SEGMENT #07 <<< + '######### LEVEL ############# + Line (0, 80)-(320, 80), 6 + Line (0, 100)-(320, 100), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then x = 300 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 80 Or y = 91 Then GoTo mcrash3 + '########## DOOR CODES ####### + If x = 5 Then segm = 1: GoTo m3seg8 + If x = 305 Then segm = 1: GoTo m3seg6 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg8: Cls ' >>> SEGMENT #08 <<< + '######### LEVEL ############# + Line (0, 80)-(320, 80), 6 + Line (0, 100)-(320, 100), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then x = 300 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 80 Or y = 91 Then GoTo mcrash3 + '########## DOOR CODES ####### + If x = 5 Then segm = 1: GoTo m3seg9 + If x = 305 Then segm = 0: GoTo m3seg7 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg9: Cls ' >>> SEGMENT #09 <<< + '######### LEVEL ######## + Line (150, 200)-(150, 100), 6 + Line (170, 200)-(170, 100), 6 + Line (0, 100)-(150, 100), 6 + Line (320, 100)-(170, 100), 6 + Line (0, 80)-(320, 80), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180 + If segm = 1 Then x = 300 + If segm = 2 Then x = 10 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y > 90 Then GoTo mcrash3 + If x > 160 And y > 90 Then GoTo mcrash3 + If y = 80 Then GoTo mcrash3 + '########## DOOR CODES ########### + If y = 185 Then segm = 0: GoTo m3seg14 + If x = 5 Then segm = 0: GoTo m3seg10 + If x = 305 Then segm = 0: GoTo m3seg8 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg10: Cls ' >>> SEGMENT #10 <<< + '######## LEVEL ######### + Line (150, 200)-(150, 80), 6 + Line (150, 80)-(320, 80), 6 + Line (170, 200)-(170, 100), 6 + Line (170, 100)-(320, 100), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 300 + If segm = 1 Then y = 180 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 150 Or y = 80 Then GoTo mcrash3 + If x > 160 And y > 90 Then GoTo mcrash3 + '########## DOOR CODES ######### + If y = 185 Then segm = 1: GoTo m3seg11 + If x = 305 Then segm = 2: GoTo m3seg9 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg11: Cls ' >>> SEGMENT #11 <<< + '######### LEVEL ######## + Line (150, 200)-(150, 0), 6 + Line (170, 200)-(170, 0), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 180 + If segm = 1 Then y = 10 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If y < 184 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 161 Then GoTo mcrash3 + If x = 150 Then GoTo mcrash3 + '########## DOOR CODES ########## + If y = 5 Then segm = 1: GoTo m3seg10 + If y = 185 Then segm = 1: GoTo m3seg12 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg12: Cls ' >>> SEGMENT #12 <<< + '######## LEVEL ######### + Line (320, 100)-(150, 100), 6 + Line (320, 80)-(170, 80), 6 + Line (150, 100)-(150, 0), 6 + Line (170, 80)-(170, 0), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 300 + If segm = 1 Then y = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If y < 184 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x > 160 And y < 81 Then GoTo mcrash3 + If x = 150 Or y = 91 Then GoTo mcrash3 + '########## DOOR CODES ########## + If x = 305 Then segm = 1: GoTo m3seg13 + If y = 5 Then segm = 0: GoTo m3seg11 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + + m3seg13: Cls ' >>> SEGMENT #13 <<< + '######### LEVEL ############# + Line (0, 80)-(320, 80), 6 + Line (0, 100)-(320, 100), 6 + Line (140, 50)-(180, 150), 6, BF + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 300 + If segm = 1 Then x = 10 + If i = 0 Then stat$ = "Collect Item:" + If segm = 0 Then stat$ = "Passage Blocked:" + If i = 1 Then stat$ = "Exit Ruin:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## ITEM CODE ########### + If i = 0 Then Circle (90, 90), 2, 10: Paint (90, 90), 10 Else Circle (90, 90), 2, 0: Paint (90, 90), 0 + If i = 0 Then If x = 79 Or x = 92 Then If y > 84 And y < 87 Then i = 1: stat$ = "Exit Ruin:Got Item" + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 80 Or y = 91 Then GoTo mcrash3 + If x = 180 Or x = 131 Then GoTo mcrash3 + '########## DOOR CODES ####### + If x = 305 Then segm = 1: GoTo m3seg2 + If x = 5 Then segm = 0: GoTo m3seg12 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg14: Cls ' >>> SEGMENT #14 <<< + '######### LEVEL ######## + Line (150, 0)-(150, 80), 6 + Line (170, 0)-(170, 80), 6 + Line (0, 80)-(150, 80), 6 + Line (320, 80)-(170, 80), 6 + Line (0, 100)-(320, 100), 6 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 10 + If segm = 1 Then x = 300 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash3 + If x > 160 And y < 81 Then GoTo mcrash3 + If y = 91 Then GoTo mcrash3 + If x = 10 Then x = 11 + '########## DOOR CODES ######## + If x = 305 Then segm = 0: GoTo m3seg15 + If y = 5 Then segm = 0: GoTo m3seg9 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg15: Cls ' >>> SEGMENT #15 <<< + '######### LEVEL ############# + Line (0, 80)-(320, 80), 6 + Line (0, 100)-(320, 100), 6 + Line (140, 50)-(180, 150), 6, BF + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10: d = 4 + If segm = 1 Then x = 299: d = 2 + If i = 0 Then stat$ = "Passage Blocked:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 80 Or y = 91 Then GoTo mcrash3 + If x = 180 Or x = 131 Then GoTo mcrash3 + '########## DOOR CODES ####### + If x = 5 Then segm = 1: GoTo m3seg14 + If x = 305 Then segm = 2: GoTo m3seg4 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m3seg16: Cls ' >>> SEGMENT #16 <<< + '######## LEVEL ######### + Line (0, 80)-(150, 80), 6 + Line (150, 80)-(150, 0), 6 + Line (0, 100)-(170, 100), 6 + Line (170, 100)-(170, 0), 6 + Line (0, 50)-(35, 150), 6, BF + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 10 + If i = 0 Then stat$ = "Passage Blocked:" + If i = 1 Then stat$ = "Exit Ruin: Got Gem" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), crh1(), PSet + If d = 2 Then Put (x, y), crv1(), PSet + If d = 3 Then Put (x, y), crh2(), PSet + If d = 4 Then Put (x, y), crv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt3 + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x < 151 And y < 81 Then GoTo mcrash3 + If x = 161 Or y = 91 Then GoTo mcrash3 + If x = 35 Then GoTo mcrash3 + '########## DOOR CODES ######### + If y = 5 Then segm = 2: GoTo m3seg5 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + mfinish3: Cls + Color 10 + Print " You completed the mission!" + Print + Print " Now for the next one!" + Print + Color 9 + Print + Print " This level's code is: SUBRUINS" + Print " Next level's code is: TOWER" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu7 + + dbtt3: Cls + Color 14 + Print " Your battery ran out!" + Print + Print " Esc. = Exit| Try again?" + Print + Color 9 + Print + Print " This level's code is: SUBRUINS" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to Retry..." + PCopy 1, 0 + btt = 0 + Do + press$ = InKey$ + If press$ = Chr$(27) Then End + Loop Until press$ = " " + segm = 0 + GoTo m3seg1 + + mcrash3: Cls + Color 12 + Print " You Crashed My Robot!" + Print + Print " Sorry, You are fired!" + Print + Color 9 + Print + Print " This level's code is: SUBRUINS" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + +End Sub + +Sub Mission04 + Screen 7, 0, 1, 0 + Dim drh1(100), drh2(100), drv1(100), drv2(100), mask(100) + Play "MB L64 <<<" + Color 15 + Print " Mission Status:" + Print + Print " Mission 4: I was successful in" + Print " retreaving the third gem. But I was " + Print " ambushed, and the gem stolen. It did" + Print " not go far. It was taken by the " + Print " Peditron Science Lab. Never fear, " + Print " you're getting it back with the help" + Print " of 'Drop Bot'. He can take on the " + Print " air-ducks to the lab where the gem " + Print " is being held. Get in and out fast, " + Print " I don't want my tecnology in their " + Print " hands. Good luck!" + Print + Color 9 + Print " NOTE: You have Three Minutes to get" + Print " in and out undetected!" + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + '######### ROBOT ########## + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 12, BF + Line (5, 5)-(6, 6), 7, BF + PSet (4, 1), 7: PSet (7, 1), 7 + PCopy 1, 0 + Get (1, 1)-(10, 10), drh1() + Cls + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 12, BF + Line (5, 5)-(6, 4), 7, BF + PSet (4, 10), 7: PSet (7, 10), 7 + PCopy 1, 0 + Get (1, 1)-(10, 10), drh2() + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 12, BF + Line (5, 5)-(6, 6), 7, BF + PSet (1, 4), 7: PSet (1, 7), 7 + Get (1, 1)-(10, 10), drv1() + PCopy 1, 0 + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 12, BF + Line (5, 5)-(4, 6), 7, BF + PSet (10, 4), 7: PSet (10, 7), 7 + Get (1, 1)-(10, 10), drv2() + PCopy 1, 0 + Cls + Get (1, 1)-(10, 10), mask() + m4seg1: Cls ' >>> SEGMENT #01 <<< + '######## LEVEL ######## + Line (2, 20)-(310, 190), 7, B + Line (20, 30)-(40, 50), 7, B + Line (20, 30)-(25, 35), 7: Line (40, 30)-(35, 35), 7 + Line (25, 35)-(35, 35), 7 + Line (25, 35)-(25, 50), 7: Line (35, 35)-(35, 50), 7 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 290: y = 180: d = 1 + If segm = 1 Then x = 26: y = 60: d = 3 + btt$ = "Time: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Press SPACEBAR to pick up bot:" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), drh1(), PSet + If d = 2 Then Put (x, y), drv1(), PSet + If d = 3 Then Put (x, y), drh2(), PSet + If d = 4 Then Put (x, y), drv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + If i = 1 Then If press$ = " " Then GoTo mfinish4 + '########### THREE MIN CODE ############ + btt = btt + 1 + If (btt / 100) > 180 Then GoTo dbtt4 + If y < 184 And (btt / 100) Then btt$ = "Time: [||||||||||]" + If (btt / 100) > 18 Then btt$ = "Time: [||||||||| ]": C = 10 + If (btt / 100) > 36 Then btt$ = "Time: [|||||||| ]": C = 10 + If (btt / 100) > 54 Then btt$ = "Time: [||||||| ]": C = 10 + If (btt / 100) > 72 Then btt$ = "Time: [|||||| ]": C = 14 + If (btt / 100) > 90 Then btt$ = "Time: [||||| ]": C = 14 + If (btt / 100) > 108 Then btt$ = "Time: [|||| ]": C = 14 + If (btt / 100) > 125 Then btt$ = "Time: [||| ]": C = 12 + If (btt / 100) > 144 Then btt$ = "Time: [|| ]": C = 12 + If (btt / 100) > 162 Then btt$ = "Time: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 181 Or y = 20 Then GoTo mcrash4 + If x = 301 Or x = 2 Then GoTo mcrash4 + '########## DOOR CODES ########## + If x > 10 And x < 41 Then If y = 21 Or y = 50 Then segm = 0: GoTo m4seg2 + If x = 40 Or x = 11 Then If y > 21 And y < 51 Then segm = 0: GoTo m4seg2 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m4seg2: Cls ' >>> SEGMENT #02 <<< + '######## LEVEL ######## + Line (2, 20)-(2, 190), 7 + Line (22, 20)-(22, 50), 7 + Line (2, 20)-(22, 20), 7 + Line (22, 70)-(22, 170), 7 + Line (22, 70)-(280, 70), 7 + Line (280, 70)-(280, 170), 7 + Line (2, 190)-(300, 190), 7 + Line (300, 190)-(300, 50), 7 + Line (300, 50)-(22, 50), 7 + Line (22, 170)-(150, 170), 7 + Line (280, 170)-(170, 170), 7 + Line (150, 170)-(150, 100), 7 + Line (170, 170)-(170, 100), 7 + Line (150, 100)-(170, 100), 7 + '**DOOR** + Line (150, 100)-(155, 105), 7 + Line (170, 100)-(165, 105), 7 + Line (150, 120)-(170, 120), 7 + Line (150, 120)-(155, 115), 7 + Line (170, 120)-(165, 115), 7 + Line (155, 105)-(165, 115), 7, B + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 8: y = 35: d = 3 + If segm = 1 Then x = 155: y = 125: d = 3 + btt$ = "Time: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Get Out Quick:" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), drh1(), PSet + If d = 2 Then Put (x, y), drv1(), PSet + If d = 3 Then Put (x, y), drh2(), PSet + If d = 4 Then Put (x, y), drv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### THREE MIN CODE ############ + btt = btt + 1 + If (btt / 100) > 180 Then GoTo dbtt4 + If (btt / 100) > 18 Then btt$ = "Time: [||||||||| ]": C = 10 + If (btt / 100) > 36 Then btt$ = "Time: [|||||||| ]": C = 10 + If (btt / 100) > 54 Then btt$ = "Time: [||||||| ]": C = 10 + If (btt / 100) > 72 Then btt$ = "Time: [|||||| ]": C = 14 + If (btt / 100) > 90 Then btt$ = "Time: [||||| ]": C = 14 + If (btt / 100) > 108 Then btt$ = "Time: [|||| ]": C = 14 + If (btt / 100) > 125 Then btt$ = "Time: [||| ]": C = 12 + If (btt / 100) > 144 Then btt$ = "Time: [|| ]": C = 12 + If (btt / 100) > 162 Then btt$ = "Time: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 181 Or y = 20 Then GoTo mcrash4 + If x = 301 Or x = 2 Then GoTo mcrash4 + If x = 13 Then If y > 20 And y < 51 Then GoTo mcrash4 + If y = 50 Then If x > 12 And x < 300 Then GoTo mcrash4 + If y = 61 Then If x > 12 And x < 280 Then GoTo mcrash4 + If x = 13 Then If y > 60 And y < 171 Then GoTo mcrash4 + If x = 280 Then If y > 60 And y < 171 Then GoTo mcrash4 + If y = 170 Then If x > 160 And x < 281 Then GoTo mcrash4 + If y = 170 Then If x > 12 And x < 151 Then GoTo mcrash4 + If x = 150 Then If y > 100 And y < 171 Then GoTo mcrash4 + If x = 161 Then If y > 100 And y < 171 Then GoTo mcrash4 + '########## DOOR CODES ########## + If y = 25 Then segm = 1: GoTo m4seg1 + If y = 120 Then If x > 150 And x < 161 Then segm = 0: GoTo m4seg3 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m4seg3: Cls ' >>> SEGMENT #03 <<< + '######## LEVEL ######## + Line (130, 100)-(190, 190), 6, B + Line (3, 100)-(53, 190), 6, B + Line (299, 100)-(249, 190), 6, B + Line (2, 20)-(300, 190), 7, B + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 155: y = 120: d = 3 + btt$ = "Time: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Get Out Quick:" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## ITEM CODE ######## + If i = 0 Then Circle (160, 180), 2, 14: Paint (160, 180), 14 Else Circle (160, 180), 2, 0: Paint (160, 180), 0 + If i = 0 Then If x > 154 And x < 157 And y = 169 Then i = 1: stat$ = "Get Out Quick:" + If i = 0 Then If y > 174 And y < 177 Then If x = 162 Or x = 149 Then i = 1: stat$ = "Get Out Quick:" + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), drh1(), PSet + If d = 2 Then Put (x, y), drv1(), PSet + If d = 3 Then Put (x, y), drh2(), PSet + If d = 4 Then Put (x, y), drv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### THREE MIN CODE ############ + btt = btt + 1 + If (btt / 100) > 180 Then GoTo dbtt4 + If (btt / 100) > 18 Then btt$ = "Time: [||||||||| ]": C = 10 + If (btt / 100) > 36 Then btt$ = "Time: [|||||||| ]": C = 10 + If (btt / 100) > 54 Then btt$ = "Time: [||||||| ]": C = 10 + If (btt / 100) > 72 Then btt$ = "Time: [|||||| ]": C = 14 + If (btt / 100) > 90 Then btt$ = "Time: [||||| ]": C = 14 + If (btt / 100) > 108 Then btt$ = "Time: [|||| ]": C = 14 + If (btt / 100) > 125 Then btt$ = "Time: [||| ]": C = 12 + If (btt / 100) > 144 Then btt$ = "Time: [|| ]": C = 12 + If (btt / 100) > 162 Then btt$ = "Time: [| ]": C = 12 + '########## BARRIER CODES ####### + If y = 181 Or y = 20 Then GoTo mcrash4 + If x = 130 Or x = 181 Then GoTo mcrash4 + '########## DOOR CODES ########## + If y = 105 Then segm = 1: GoTo m4seg2 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + mfinish4: Cls + Color 10 + Print " You completed the mission!" + Print + Print " Now for the next one!" + Print + Color 9 + Print + Print " This level's code is: TOWER" + Print " Next level's code is: WALLDRILL" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu8 + + + dbtt4: Cls + Color 12 + Print " You Lost My Robot!" + Print + Print " Sorry, You are fired!" + Print + Color 9 + Print + Print " This level's code is: TOWER" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + + End + + mcrash4: Cls + Color 12 + Print " You Crashed My Robot!" + Print + Print " Sorry, You are fired!" + Print + Color 9 + Print + Print " This level's code is: TOWER" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + +End Sub + +Sub Mission05 + Screen 7, 0, 1, 0 + Dim dbh1(100), dbh2(100), dbv1(100), dbv2(100), mask(100) + Play "MB L64 <<<" + Color 15 + Print " Mission Status:" + Print + Print " Mission 5: You're next mission " + Print " takes you back to a pyramid, but " + Print " this time a 1-inch thick wall is " + Print " keeping you from our goal. Have no " + Print " fear, I have designed a drilling bot" + Print " just right for the job. 'Drill-Bot' " + Print " is its model name. You activate the " + Print " drill by pressing the PageUp. But" + Print " be careful, the drill burns the " + Print " battery faster. So turn it on only " + Print " when you're going to drill the wall." + Print + Color 9 + Print " PS: Pressing PageDown turns off the " + Print " Drill" + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + '######### ROBOT ########## + Line (1, 4)-(2, 10), 8, BF + Line (10, 4)-(9, 10), 8, BF + Line (3, 4)-(8, 9), 9, BF + Line (2, 3)-(9, 3), 7: Line (2, 3)-(5, 1), 7: Line (9, 3)-(7, 1), 7 + PSet (6, 1), 7 + Paint (5, 2), 7 + PCopy 1, 0 + Get (1, 1)-(10, 10), dbh1() + Cls + Line (1, 1)-(2, 7), 8, BF + Line (10, 1)-(9, 7), 8, BF + Line (3, 2)-(8, 7), 9, BF + Line (2, 8)-(9, 8), 7: Line (2, 8)-(5, 10), 7: Line (9, 8)-(7, 10), 7 + PSet (6, 10), 7: Paint (5, 9), 7 + PCopy 1, 0 + Get (1, 1)-(10, 10), dbh2() + Cls + Line (4, 1)-(10, 2), 8, BF + Line (4, 10)-(10, 9), 8, BF + Line (4, 3)-(9, 8), 9, BF + Line (3, 2)-(3, 9), 7: Line (3, 2)-(1, 5), 7: Line (3, 9)-(1, 6), 7 + Paint (2, 5), 7 + Get (1, 1)-(10, 10), dbv1() + PCopy 1, 0 + Cls + Line (1, 1)-(7, 2), 8, BF + Line (1, 10)-(7, 9), 8, BF + Line (2, 3)-(7, 8), 9, BF + Line (8, 2)-(8, 9), 7: Line (8, 2)-(10, 5), 7: Line (8, 9)-(10, 7), 7 + PSet (10, 6), 7: Paint (9, 5), 7 + Get (1, 1)-(10, 10), dbv2() + PCopy 1, 0 + Cls + Get (1, 1)-(10, 10), mask() + m5seg1: Cls + '######## LEVEL ###### + Line (150, 10)-(150, 200), 12 + Line (170, 10)-(170, 200), 12 + Line (150, 10)-(170, 10), 12 + Line (150, 100)-(170, 100), 12 + PCopy 1, 0 + '######### PROGRAM ###### + x = 155: y = 180: d = 1 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Pyramid:" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## ITEM CODE ########### + If i = 0 Then Circle (160, 16), 2, 13: Paint (160, 16), 13 Else Circle (160, 16), 2, 0: Paint (160, 16), 0 + If x > 153 And x < 159 And y = 18 Then i = 1: stat$ = "Exit Pyramid:" + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), dbh1(), PSet + If d = 2 Then Put (x, y), dbv1(), PSet + If d = 3 Then Put (x, y), dbh2(), PSet + If d = 4 Then Put (x, y), dbv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + If press$ = Chr$(0) + "I" Then dr = 1 + If press$ = Chr$(0) + "Q" Then dr = 0 + '########### DRILL CODE ############## + If dr = 1 Then btt = btt + 100 + If y = 101 And dr = 1 Then w = 1 + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt5 + If y < 184 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 161 Then GoTo mcrash5 + If x = 150 Then GoTo mcrash5 + If y = 10 Then GoTo mcrash5 + If w = 0 And y = 100 Then GoTo mcrash5 + '########## DOOR CODES ########## + If i = 0 And y = 185 Then y = 184: stat$ = "Not Finished " ' ELSE GOTO mfinish3 + If i = 0 And y < 184 Then stat$ = "Collect Item:" + If i = 0 And dr = 1 Then stat$ = " Drill On!!!" + If i = 1 And y = 185 Then GoTo mfinish5 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + mfinish5: Cls + Color 10 + Print " You completed the mission!" + Print + Print " Now for the last one!" + Print + Color 9 + Print + Print " This level's code is: WALLDRILL" + Print " Next level's code is: AMAZEME" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu9 + + End + + dbtt5: Cls + Color 14 + Print " Your battery ran out!" + Print + Print " Esc. = Exit| Try again?" + Print + Color 9 + Print + Print " This level's code is: WALLDRILL" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to Retry..." + PCopy 1, 0 + btt = 0 + Do + press$ = InKey$ + If press$ = Chr$(27) Then End + Loop Until press$ = " " + segm = 0: dr = 0 + GoTo m5seg1 + End + + mcrash5: Cls + Color 12 + Print " You Crashed My Robot!" + Print + Print " Sorry, You are fired!" + Print + Color 9 + Print + Print " This level's code is: WALLDRILL" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + + + End +End Sub + +Sub Mission06 + Cls + Screen 7, 0, 1, 0 + Play "MB L64 <<<" + Dim sch1(100), sch2(100), scv1(100), scv2(100), mask(100) + Play "MB L64 <<<" + Color 15 + Print " Mission Status:" + Print + Print " Mission 6: I have the location" + Print " of the last gem. It has shown up in" + Print " a cave which seems to be a maze of " + Print " rooms. You're piloting Scorpian again" + Print " to collect the gem. Keep in mind the" + Print " the 30 minute battery life. Also keep" + Print " mind that this maze of rooms are quite" + Print " complex. So keep up with where you are" + Print " going. Good luck!" + Print + Print + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + + Cls + '############# ROBOT ########## + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 14, BF + Line (5, 1)-(6, 7), 12, BF + Line (5, 5)-(6, 8), 4, BF + PCopy 1, 0 + Get (1, 1)-(10, 10), sch1() + Cls + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 14, BF + Line (5, 3)-(6, 10), 12, BF + Line (5, 7)-(6, 10), 4, BF + PCopy 1, 0 + Get (1, 1)-(10, 10), sch2() + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 14, BF + Line (1, 5)-(7, 6), 12, BF + Line (5, 5)-(8, 6), 4, BF + Get (1, 1)-(10, 10), scv1() + PCopy 1, 0 + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 14, BF + Line (3, 5)-(10, 6), 12, BF + Line (7, 5)-(10, 6), 4, BF + Get (1, 1)-(10, 10), scv2() + PCopy 1, 0 + Cls + Get (1, 1)-(10, 10), mask() + PCopy 1, 0 + + m6seg1: Cls ' >>> SEGMENT #01 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (5, 30)-(5, 60), 0: Line (310, 30)-(310, 60), 0 + Line (140, 190)-(170, 190), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 150: y = 175: d = 1 + If segm = 1 Then x = 290 + If segm = 2 Then x = 10 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If i = 1 And x > 139 And x < 170 Then If y = 180 Then GoTo mfinish6 + If i = 0 And x > 139 And x < 170 Then If y = 180 Then y = 179: stat$ = "Not Finished!" + If i = 0 And y < 178 Then stat$ = "Collect Item:" + If y > 29 And y < 51 Then If x = 300 Then segm = 0: GoTo m6seg2 + If y > 29 And y < 51 Then If x = 6 Then segm = 0: GoTo m6seg13 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg2: Cls ' >>> SEGMENT #02 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (5, 30)-(5, 60), 0 + Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then y = 22 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 21 Then segm = 0: GoTo m6seg3 + If y > 29 And y < 51 Then If x = 6 Then segm = 1: GoTo m6seg1 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg3: Cls ' >>> SEGMENT #03 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (5, 30)-(5, 60), 0 + Line (140, 190)-(170, 190), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 170 + If segm = 1 Then x = 7 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 180 Then segm = 1: GoTo m6seg2 + If y > 29 And y < 51 Then If x = 6 Then segm = 0: GoTo m6seg4 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg4: Cls ' >>> SEGMENT #04 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (310, 30)-(310, 60), 0 + Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 290 + If segm = 1 Then y = 22 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 21 Then segm = 0: GoTo m6seg5 + If y > 29 And y < 51 Then If x = 299 Then segm = 1: GoTo m6seg3 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg5: Cls ' >>> SEGMENT #05 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (310, 30)-(310, 60), 0 + Line (140, 190)-(170, 190), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 175 + If segm = 1 Then x = 290 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 180 Then segm = 1: GoTo m6seg4 + If y > 29 And y < 51 Then If x = 300 Then segm = 0: GoTo m6seg6 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg6: Cls ' >>> SEGMENT #06 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (5, 30)-(5, 60), 0 + Line (310, 30)-(310, 60), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 10 + If segm = 1 Then x = 290 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If y > 29 And y < 51 Then If x = 300 Then segm = 0: GoTo m6seg7 + If y > 29 And y < 51 Then If x = 6 Then segm = 1: GoTo m6seg5 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg7: Cls ' >>> SEGMENT #07 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (5, 30)-(5, 60), 0 + Line (140, 190)-(170, 190), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 7 + If segm = 1 Then y = 175 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 180 Then segm = 0: GoTo m6seg8 + If y > 29 And y < 51 Then If x = 6 Then segm = 1: GoTo m6seg6 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg8: Cls ' >>> SEGMENT #08 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (310, 30)-(310, 60), 0 + Line (140, 190)-(170, 190), 0: Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 22 + If segm = 1 Then x = 290 + If segm = 2 Then y = 175 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 21 Then segm = 1: GoTo m6seg7 + If y > 29 And y < 51 Then If x = 300 Then segm = 0: GoTo m6seg9 + If x > 139 And x < 170 Then If y = 180 Then segm = 0: GoTo m6seg15 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg9: Cls ' >>> SEGMENT #09 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (5, 30)-(5, 60), 0 + Line (140, 190)-(170, 190), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 7 + If segm = 1 Then y = 175 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If y > 29 And y < 51 Then If x = 6 Then segm = 1: GoTo m6seg8 + If x > 139 And x < 170 Then If y = 180 Then segm = 0: GoTo m6seg10 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg10: Cls ' >>> SEGMENT #10 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (310, 30)-(310, 60), 0 + Line (140, 190)-(170, 190), 0: Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 22 + If segm = 1 Then x = 290 + If segm = 2 Then y = 175 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 21 Then segm = 1: GoTo m6seg9 + If y > 29 And y < 51 Then If x = 300 Then segm = 0: GoTo m6seg11 + If x > 139 And x < 170 Then If y = 180 Then segm = 0: GoTo m6seg18 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg11: Cls ' >>> SEGMENT #11 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (5, 30)-(5, 60), 0 + Line (140, 190)-(170, 190), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 7 + If segm = 1 Then y = 175 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If y > 29 And y < 51 Then If x = 6 Then segm = 1: GoTo m6seg10 + If x > 139 And x < 170 Then If y = 180 Then segm = 0: GoTo m6seg12 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg12: Cls ' >>> SEGMENT #12 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 22 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## ITEM CODE ########### + If i = 0 Then Circle (160, 187), 2, 15: Paint (160, 187), 15 Else Circle (160, 187), 2, 0: Paint (160, 187), 0 + If x > 154 And x < 157 And y = 176 Then i = 1: stat$ = "Exit Cave:Got Item" + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 21 Then segm = 1: GoTo m6seg11 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + + m6seg13: Cls ' >>> SEGMENT #13 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (310, 30)-(310, 60), 0 + Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 290 + If segm = 1 Then y = 23 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If y > 29 And y < 51 Then If x = 300 Then segm = 2: GoTo m6seg1 + If x > 139 And x < 170 Then If y = 21 Then segm = 0: GoTo m6seg14 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg14: Cls ' >>> SEGMENT #14 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (140, 190)-(170, 190), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 170 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 180 Then segm = 1: GoTo m6seg13 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + + m6seg15: Cls ' >>> SEGMENT #15 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (140, 190)-(170, 190), 0: Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 22 + If segm = 1 Then y = 175 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 21 Then segm = 2: GoTo m6seg8 + If x > 139 And x < 170 Then If y = 180 Then segm = 0: GoTo m6seg16 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg16: Cls ' >>> SEGMENT #16 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (5, 30)-(5, 60), 0 + Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 22 + If segm = 1 Then x = 7 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 21 Then segm = 1: GoTo m6seg15 + If y > 29 And y < 51 Then If x = 6 Then segm = 0: GoTo m6seg17 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg17: Cls ' >>> SEGMENT #17 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (310, 30)-(310, 60), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then x = 290 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If y > 29 And y < 51 Then If x = 300 Then segm = 1: GoTo m6seg16 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + m6seg18: Cls ' >>> SEGMENT #18 <<< + '######### LEVEL ########### + Line (5, 20)-(5, 190), 14 + Line (5, 190)-(310, 190), 14 + Line (310, 190)-(310, 20), 14 + Line (5, 20)-(310, 20), 14 + Line (140, 20)-(170, 20), 0 + PCopy 1, 0 + '######### PROGRAM ###### + If segm = 0 Then y = 22 + btt$ = "Batt: [||||||||||]": C = 10 + If i = 0 Then stat$ = "Collect Item:" + If i = 1 Then stat$ = "Exit Cave:Got Item" + Do + press$ = InKey$ + Locate 1, 1: Color C: Print btt$ + Locate 2, 1: Color 9: Print stat$ + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), sch1(), PSet + If d = 2 Then Put (x, y), scv1(), PSet + If d = 3 Then Put (x, y), sch2(), PSet + If d = 4 Then Put (x, y), scv2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '########### BATTERY CODE ############ + btt = btt + 1 + If (btt / 100) > 1800 Then GoTo dbtt6 + If y < 189 And (btt / 100) Then btt$ = "Batt: [||||||||||]" + If (btt / 100) > 180 Then btt$ = "Batt: [||||||||| ]": C = 10 + If (btt / 100) > 360 Then btt$ = "Batt: [|||||||| ]": C = 10 + If (btt / 100) > 540 Then btt$ = "Batt: [||||||| ]": C = 10 + If (btt / 100) > 720 Then btt$ = "Batt: [|||||| ]": C = 14 + If (btt / 100) > 900 Then btt$ = "Batt: [||||| ]": C = 14 + If (btt / 100) > 1080 Then btt$ = "Batt: [|||| ]": C = 14 + If (btt / 100) > 1260 Then btt$ = "Batt: [||| ]": C = 12 + If (btt / 100) > 1440 Then btt$ = "Batt: [|| ]": C = 12 + If (btt / 100) > 1620 Then btt$ = "Batt: [| ]": C = 12 + '########## BARRIER CODES ####### + If x = 5 Or x = 301 Then GoTo mcrash6 + If y = 20 Or y = 181 Then GoTo mcrash6 + '########## DOOR CODES ########### + If x > 139 And x < 170 Then If y = 21 Then segm = 2: GoTo m6seg10 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + + mfinish6: Cls + Color 10 + Print " You completed the mission!" + Print + Print " You completed the game!" + Print + Color 9 + Print + Print " This level's code is: AMAZEME" + Print " Bonus Menu code is: ROBOBONUS" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Ending + + End + + dbtt6: Cls + Color 14 + Print " Your battery ran out!" + Print + Print " Esc. = Exit| Try again?" + Print + Color 9 + Print + Print " This level's code is: AMAZEME" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to Retry..." + PCopy 1, 0 + btt = 0 + Do + press$ = InKey$ + If press$ = Chr$(27) Then End + Loop Until press$ = " " + segm = 0: dr = 0 + GoTo m6seg1 + End + + mcrash6: Cls + Color 12 + Print " You Crashed My Robot!" + Print + Print " Sorry, You are fired!" + Print + Color 9 + Print + Print " This level's code is: AMAZEME" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + + End +End Sub + +Sub Missionb + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Mission-Bots>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>SCORPIAN>>": Locate 11, 15: Color 15: Print ">>CREEPER<<": Locate 13, 15: Color 15: Print ">>PAGE-2<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>SCORPIAN<<": Locate 11, 15: Color 9: Print ">>CREEPER>>": Locate 13, 15: Color 15: Print ">>PAGE-2<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>SCORPIAN<<": Locate 11, 15: Color 15: Print ">>CREEPER<<": Locate 13, 15: Color 14: Print ">>PAGE-2>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Scorp + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Creep + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Missionb2 + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Missionb2 + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Mission-Bots>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>DRILL-BOT>>": Locate 11, 15: Color 15: Print ">>DROP-BOT<<": Locate 13, 15: Color 15: Print ">>BONUS-MENU<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>DRILL-BOT<<": Locate 11, 15: Color 9: Print ">>DROP-BOT>>": Locate 13, 15: Color 15: Print ">>BONUS-MENU<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>DRILL-BOT<<": Locate 11, 15: Color 15: Print ">>DROP-BOT<<": Locate 13, 15: Color 14: Print ">>BONUS-MENU>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Dril + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Drop + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Bonus + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Robopic + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Robo-Pics>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>TRAINER-BOTS>>": Locate 11, 15: Color 15: Print ">>MISSION-BOTS<<": Locate 13, 15: Color 15: Print ">>BONUS-MENU<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>TRAINER-BOTS<<": Locate 11, 15: Color 9: Print ">>MISSION-BOTS>>": Locate 13, 15: Color 15: Print ">>BONUS-MENU<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>TRAINER-BOTS<<": Locate 11, 15: Color 15: Print ">>MISSION-BOTS<<": Locate 13, 15: Color 14: Print ">>BONUS-MENU>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Trainerb + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Missionb + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Bonus + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + +Sub Scorp + Cls + Screen 13 + Line (20, 30)-(160, 50), 14, BF + Line (22, 36)-(158, 36), 8 + Line (22, 60)-(158, 60), 8 + '*** ARM *** + Line (150, 29)-(60, 5), 12 + Line (130, 29)-(60, 10), 12 + Line (60, 5)-(10, 20), 12 + Line (60, 10)-(14, 24), 12 + Line (150, 29)-(130, 29), 12 + Line (10, 20)-(14, 24), 12 + Paint (60, 7), 12 + '*** GRIP *** + Line (15, 18)-(0, 24), 7 + Line (19, 22)-(4, 28), 7 + Line (15, 18)-(19, 22), 7 + Line (0, 24)-(4, 28), 7 + Paint (4, 26), 7 + '*** WHEELS *** + Circle (22, 48), 15, 7 + Paint (22, 48), 7 + PSet (22, 48), 0 + Circle (158, 48), 15, 7 + Paint (158, 48), 7 + PSet (158, 48), 0 + '**TEXT** + Locate 10, 1: Print " Scorpian: Mission 1-2 & 6:" + Locate 12, 1: Print " This robot has a grip mounted on a" + Locate 13, 1: Print " boom which gives it the appearance" + Locate 14, 1: Print " of a scorpian. Its design allows it" + Locate 15, 1: Print " to pick up larger items and move " + Locate 16, 1: Print " over rough terrain." + Color 10 + Locate 20, 1: Print " Press SPACEBAR to continue..." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Missionb + +End Sub + +Sub Tbot1 + Cls + Screen 13 + Line (20, 20)-(160, 50), 10, BF + Line (22, 36)-(158, 36), 8 + Line (22, 60)-(158, 60), 8 + Circle (22, 48), 15, 7 + Paint (22, 48), 7 + PSet (22, 48), 0 + Circle (158, 48), 15, 7 + Paint (158, 48), 7 + PSet (158, 48), 0 + Locate 10, 1: Print " Trainer-Bot: Test 1-2:" + Locate 12, 1: Print " A simple desinged robot for easy" + Locate 13, 1: Print " repairs. Used for the first two" + Locate 14, 1: Print " test in case of a crash." + Color 10 + Locate 17, 1: Print " Press SPACEBAR to continue..." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Trainerb +End Sub + +Sub Tbot2 + Cls + Screen 13 + Line (10, 25)-(20, 45), 8, BF + Line (20, 20)-(160, 50), 10, BF + Line (22, 36)-(158, 36), 8 + Line (22, 60)-(158, 60), 8 + Circle (22, 48), 15, 7 + Paint (22, 48), 7 + PSet (22, 48), 0 + Circle (158, 48), 15, 7 + Paint (158, 48), 7 + PSet (158, 48), 0 + Locate 10, 1: Print " Trainer-Bot: Test 3:" + Locate 12, 1: Print " A simple desinged robot for easy" + Locate 13, 1: Print " repairs. Has small grip on front" + Locate 14, 1: Print " for picking up small items." + Color 10 + Locate 17, 1: Print " Press SPACEBAR to continue..." + Do + press$ = InKey$ + Loop Until press$ = " " + Call Trainerb + +End Sub + +Sub Test001 + Dim hor(100), vert(100), mask(100) + Play "MB L64 <<<" + Cls + Screen 7, 0, 1, 0 + Color 15 + Print " Test Status:" + Print + Print " This test is for Navigation." + Print " My fine robots are powered by none" + Print " than very two powerful 550-Can R/C" + Print " car motors. This can leave a great" + Print " deal of damage to them or whatever" + Print " they hit. So to pass this test, " + Print " make it to the other side of the " + Print " maze unharmed." + Print + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + + test1: Cls + '############# ROBOT ########## + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 10, BF + PCopy 1, 0 + Get (1, 1)-(10, 10), hor() + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 10, BF + Get (1, 1)-(10, 10), vert() + PCopy 1, 0 + Cls + Get (1, 1)-(10, 10), mask() + '############# LEVEL ########## + 'vertseg1 + Line (150, 200)-(150, 150), 9 + Line (170, 200)-(170, 170), 9 + 'horseg1 + Line (170, 170)-(250, 170), 9 + Line (150, 150)-(230, 150), 9 + 'vertseg2 + Line (250, 170)-(250, 100), 9 + Line (230, 150)-(230, 120), 9 + 'horseg2 + Line (250, 100)-(100, 100), 9 + Line (230, 120)-(80, 120), 9 + 'vertseg3 + Line (100, 100)-(100, 80), 9 + Line (80, 120)-(80, 60), 9 + 'horseg3 + Line (100, 80)-(170, 80), 9 + Line (80, 60)-(150, 60), 9 + 'vertseg4 + Line (170, 80)-(170, 0), 9 + Line (150, 60)-(150, 0), 9 + PCopy 1, 0 + '######## PROGRAM ####### + d = 1 + x = 155: y = 180 + oldx = x: oldy = y + seg1: + Do + press$ = InKey$ + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), hor(), PSet + If d = 2 Then Put (x, y), vert(), PSet + '####### Arrowkeys ######### + If d = 1 Then If press$ = Chr$(0) + "K" Then d = 2 + If d = 2 Then If press$ = Chr$(0) + "H" Then d = 1 + If d = 1 Then If press$ = Chr$(0) + "M" Then d = 2 + If d = 2 Then If press$ = Chr$(0) + "P" Then d = 1 + If press$ = Chr$(0) + "H" Then y = y - 1: Play "A" + If press$ = Chr$(0) + "P" Then y = y + 1: Play "A" + If press$ = Chr$(0) + "K" Then x = x - 1: Play "A" + If press$ = Chr$(0) + "M" Then x = x + 1: Play "A" + If y > 160 And x = 150 Then GoTo tcrash1 + If y > 160 And x = 161 Then GoTo tcrash1 + If y > 160 And y = 190 Then GoTo tcrash1 + If x < 230 And y < 160 And y >= 150 And y = 150 Then GoTo tcrash1 + If x < 230 And y < 160 And y >= 150 And x = 150 Then GoTo tcrash1 + If x > 160 And x < 230 And y = 150 Then GoTo tcrash1 + If x > 160 And x < 230 And y = 161 Then GoTo tcrash1 + If x = 241 Then GoTo tcrash1 + If x > 230 And x < 240 And y = 161 Then GoTo tcrash1 + If y > 111 And y < 150 And x = 230 Then GoTo tcrash1 + If x < 230 And x > 81 And y = 111 Then GoTo tcrash1 + If x = 80 Then GoTo tcrash1 + If x < 240 And x > 91 And y = 100 Then GoTo tcrash1 + If y < 100 And y > 71 And x = 91 Then GoTo tcrash1 + If x < 160 And x > 91 And y = 71 Then GoTo tcrash1 + If x < 150 And x > 81 And y = 60 Then GoTo tcrash1 + If y < 70 And x = 161 Then GoTo tcrash1 + If y < 60 And x = 150 Then GoTo tcrash1 + If y = 2 Then GoTo tfinish1 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + tfinish1: Cls + Color 10 + Print " You Passed!" + Print + Print " You can take Test2" + Print + Color 9 + Print + Print " This level's code is: TEST001" + Print " Next level's code is: TEST002" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu2 + + tcrash1: Cls + Color 12 + Print " You Crashed!" + Print + Print " Sorry, You do not pass." + Print + Color 9 + Print + Print " This level's code is: TEST001" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu +End Sub + +Sub Test002 + Dim hor(100), vert(100), mask(100) + Play "MB L64 <<<" + Cls + Screen 7, 0, 1, 0 + Color 15 + Print " Test Status:" + Print + Print " This test is for Balance." + Print " In order to work your way though" + Print " the many dangers of a robot, you" + Print " must be well balanced and on gaurd." + Print " This level includes two water pools " + Print " that can destoy robots in a blink" + Print " of an eye. To pass, Don't hit the " + Print " walls, or water." + Print + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + + test2: Cls + '############# ROBOT ########## + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 10, BF + PCopy 1, 0 + Get (1, 1)-(10, 10), hor() + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 10, BF + Get (1, 1)-(10, 10), vert() + PCopy 1, 0 + Cls + Get (1, 1)-(10, 10), mask() + '############# LEVEL ########## + 'vertseg1 + Line (150, 200)-(150, 150), 9 + Line (170, 200)-(170, 170), 9 + 'horseg1 + Line (170, 170)-(250, 170), 9 + Line (150, 150)-(230, 150), 9 + 'vertseg2 + Line (250, 170)-(250, 100), 9 + Line (230, 150)-(230, 120), 9 + 'horseg2 + Line (250, 100)-(100, 100), 9 + Line (230, 120)-(80, 120), 9 + 'vertseg3 + Line (100, 100)-(100, 80), 9 + Line (80, 120)-(80, 60), 9 + 'horseg3 + Line (100, 80)-(170, 80), 9 + Line (80, 60)-(150, 60), 9 + 'vertseg4 + Line (170, 80)-(170, 0), 9 + Line (150, 60)-(150, 0), 9 + 'pools + Line (150, 150)-(230, 120), 1, BF + Line (170, 80)-(100, 100), 1, BF + PCopy 1, 0 + '######## PROGRAM ####### + d = 1 + x = 155: y = 180 + oldx = x: oldy = y + Do + press$ = InKey$ + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), hor(), PSet + If d = 2 Then Put (x, y), vert(), PSet + '######## ARROWKEYS ###### + If d = 1 Then If press$ = Chr$(0) + "K" Then d = 2 + If d = 2 Then If press$ = Chr$(0) + "H" Then d = 1 + If d = 1 Then If press$ = Chr$(0) + "M" Then d = 2 + If d = 2 Then If press$ = Chr$(0) + "P" Then d = 1 + If press$ = Chr$(0) + "H" Then y = y - 1: Play "A" + If press$ = Chr$(0) + "P" Then y = y + 1: Play "A" + If press$ = Chr$(0) + "K" Then x = x - 1: Play "A" + If press$ = Chr$(0) + "M" Then x = x + 1: Play "A" + If y > 160 And x = 150 Then GoTo tcrash2 + If y > 160 And x = 161 Then GoTo tcrash2 + If y > 160 And y = 190 Then GoTo tcrash2 + If x < 230 And y < 160 And y >= 150 And y = 150 Then GoTo tcrash2 + If x < 230 And y < 160 And y >= 150 And x = 150 Then GoTo tcrash2 + If x > 160 And x < 230 And y = 150 Then GoTo tcrash2 + If x > 160 And x < 230 And y = 161 Then GoTo tcrash2 + If x = 241 Then GoTo tcrash2 + If x > 230 And x < 240 And y = 161 Then GoTo tcrash2 + If y > 111 And y < 150 And x = 230 Then GoTo tcrash2 + If x < 230 And x > 81 And y = 111 Then GoTo tcrash2 + If x = 80 Then GoTo tcrash2 + If x < 240 And x > 91 And y = 100 Then GoTo tcrash2 + If y < 100 And y > 71 And x = 91 Then GoTo tcrash2 + If x < 160 And x > 91 And y = 71 Then GoTo tcrash2 + If x < 150 And x > 81 And y = 60 Then GoTo tcrash2 + If y < 70 And x = 161 Then GoTo tcrash2 + If y < 60 And x = 150 Then GoTo tcrash2 + If y = 2 Then GoTo tfinish2 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + tfinish2: Cls + Color 10 + Print " You Passed!" + Print + Print " You can take Test3" + Print + Color 9 + Print + Print " This level's code is: TEST002" + Print " Next level's code is: TEST003" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu3 + + tcrash2: Cls + Color 12 + Print " You Crashed!" + Print + Print " Sorry, You do not pass." + Print + Color 9 + Print + Print " This level's code is: TEST002" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + +End Sub + +Sub Test003 + Dim hor1(100), hor2(100), vert1(100), vert2(100), mask(100) + Play "MB L64 <<<" + Cls + Screen 7, 0, 1, 0 + Color 15 + Print " Test Status:" + Print + Print " This test is for Collecting." + Print " One of the main jobs of a Robo-" + Print " Raider is collecting objects from" + Print " ruins. This is the same level you" + Print " last piloted, but with objets to" + Print " pick up.(this Robot picks up an" + Print " item automaticly, just by bump " + Print " into it) To pass, collect all " + Print " items (HINT: Get the items to" + Print " hit center of the grip)" + Print + Print + Print + Color 10 + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + + test3: Cls + '############# ROBOT ########## + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 10, BF + PSet (4, 1), 7: PSet (7, 1), 7 + PCopy 1, 0 + Get (1, 1)-(10, 10), hor1() + Cls + Line (1, 1)-(2, 10), 8, BF + Line (10, 1)-(9, 10), 8, BF + Line (3, 2)-(8, 9), 10, BF + PSet (4, 10), 7: PSet (7, 10), 7 + PCopy 1, 0 + Get (1, 1)-(10, 10), hor2() + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 10, BF + PSet (1, 4), 7: PSet (1, 7), 7 + Get (1, 1)-(10, 10), vert1() + PCopy 1, 0 + Cls + Line (1, 1)-(10, 2), 8, BF + Line (1, 10)-(10, 9), 8, BF + Line (2, 3)-(9, 8), 10, BF + PSet (10, 4), 7: PSet (10, 7), 7 + Get (1, 1)-(10, 10), vert2() + PCopy 1, 0 + Cls + + Get (1, 1)-(10, 10), mask() + '############# LEVEL ########## + 'vertseg1 + Line (150, 200)-(150, 150), 9 + Line (170, 200)-(170, 170), 9 + 'horseg1 + Line (170, 170)-(250, 170), 9 + Line (150, 150)-(230, 150), 9 + 'vertseg2 + Line (250, 170)-(250, 100), 9 + Line (230, 150)-(230, 120), 9 + 'horseg2 + Line (250, 100)-(100, 100), 9 + Line (230, 120)-(80, 120), 9 + 'vertseg3 + Line (100, 100)-(100, 80), 9 + Line (80, 120)-(80, 60), 9 + 'horseg3 + Line (100, 80)-(170, 80), 9 + Line (80, 60)-(150, 60), 9 + 'vertseg4 + Line (170, 80)-(170, 0), 9 + Line (150, 60)-(150, 0), 9 + 'pools + Line (150, 150)-(230, 120), 1, BF + Line (170, 80)-(100, 100), 1, BF + PCopy 1, 0 + '######## PROGRAM ####### + d = 1 + x = 155: y = 180 + oldx = x: oldy = y + Do + press$ = InKey$ + Locate 1, 1: Print "Items:"; i + '######## Items Code ###### + If i1 = 0 Then Circle (160, 153), 1, 12 Else Circle (160, 153), 1, 0 + If i2 = 0 Then Circle (236, 165), 1, 12 Else Circle (236, 165), 1, 0 + If i3 = 0 Then Circle (240, 120), 1, 12 Else Circle (240, 120), 1, 0 + If i4 = 0 Then Circle (90, 100), 1, 12 Else Circle (90, 100), 1, 0 + If i5 = 0 Then Circle (130, 69), 1, 12 Else Circle (130, 69), 1, 0 + If i6 = 0 Then Circle (159, 50), 1, 12 Else Circle (159, 50), 1, 0 + + If i1 = 0 Then If x = 155 Or x = 156 Then If y = 154 Then i1 = 1: i = i + 1 + If i2 = 0 Then If x = 225 Or x = 237 Then If y = 160 Then i2 = 1: i = i + 1 + If i2 = 0 Then If x = 231 Or x = 232 Then If y = 155 Then i2 = 1: i = i + 1 + If i3 = 0 Then If x = 235 Or x = 236 Then If y = 121 Or y = 110 Then i3 = 1: i = i + 1 + If i4 = 0 Then If x = 85 Or x = 86 Then If y = 101 Or y = 90 Then i4 = 1: i = i + 1 + If i5 = 0 Then If y = 65 Or y = 64 Then If x = 120 Or x = 131 Then i5 = 1: i = i + 1 + If i6 = 0 Then If x = 154 Or x = 155 Then If y = 51 Or y = 40 Then i6 = 1: i = i + 1 + '######## Graphics Code ####### + Put (oldx, oldy), mask(), PSet + oldx = x: oldy = y + If d = 1 Then Put (x, y), hor1(), PSet + If d = 2 Then Put (x, y), vert1(), PSet + If d = 3 Then Put (x, y), hor2(), PSet + If d = 4 Then Put (x, y), vert2(), PSet + If press$ = Chr$(0) + Chr$(75) Then d = 2 + If press$ = Chr$(0) + Chr$(72) Then d = 1 + If press$ = Chr$(0) + Chr$(77) Then d = 4 + If press$ = Chr$(0) + Chr$(80) Then d = 3 + If press$ = Chr$(0) + Chr$(72) Then y = y - 1: Play "A" + If press$ = Chr$(0) + Chr$(80) Then y = y + 1: Play "A" + If press$ = Chr$(0) + Chr$(75) Then x = x - 1: Play "A" + If press$ = Chr$(0) + Chr$(77) Then x = x + 1: Play "A" + If press$ = "4" Then d = 2 + If press$ = "8" Then d = 1 + If press$ = "2" Then d = 3 + If press$ = "6" Then d = 4 + If press$ = "8" Then y = y - 1: Play "A" + If press$ = "2" Then y = y + 1: Play "A" + If press$ = "4" Then x = x - 1: Play "A" + If press$ = "6" Then x = x + 1: Play "A" + '######## Barrier Code ####### + If y > 160 And x = 150 Then GoTo tcrash3 + If y > 160 And x = 161 Then GoTo tcrash3 + If y > 160 And y = 190 Then GoTo tcrash3 + If x < 230 And y < 160 And y >= 150 And y = 150 Then GoTo tcrash3 + If x < 230 And y < 160 And y >= 150 And x = 150 Then GoTo tcrash3 + If x > 160 And x < 230 And y = 150 Then GoTo tcrash3 + If x > 160 And x < 230 And y = 161 Then GoTo tcrash3 + If x = 241 Then GoTo tcrash3 + If x > 230 And x < 240 And y = 161 Then GoTo tcrash3 + If y > 111 And y < 150 And x = 230 Then GoTo tcrash3 + If x < 230 And x > 81 And y = 111 Then GoTo tcrash3 + If x = 80 Then GoTo tcrash3 + If x < 240 And x > 91 And y = 100 Then GoTo tcrash3 + If y < 100 And y > 71 And x = 91 Then GoTo tcrash3 + If x < 160 And x > 91 And y = 71 Then GoTo tcrash3 + If x < 150 And x > 81 And y = 60 Then GoTo tcrash3 + If y < 70 And x = 161 Then GoTo tcrash3 + If y < 60 And x = 150 Then GoTo tcrash3 + If i < 6 And y = 2 Then GoTo tfail3 + If i = 6 And y = 2 Then GoTo tfinish3 + PCopy 1, 0 + Loop Until press$ = Chr$(27) + End + + tfinish3: Cls + Color 10 + Print " You Passed!" + Print + Print " You are hired!" + Print + Color 9 + Print + Print " This level's code is: TEST003" + Print " Next level's code is: POINTY" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu4 + + tcrash3: Cls + Color 12 + Print " You Crashed!" + Print + Print " Sorry, You do not pass." + Print + Color 9 + Print + Print " This level's code is: TEST003" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + + tfail3: Cls + Color 12 + Print " You did not get all six items!" + Print + Print " Sorry, You do not pass." + Print + Color 9 + Print + Print " This level's code is: TEST003" + Print " Next level's code is: >>did not pass<<" + Print + Print " Press SPACEBAR to continue..." + PCopy 1, 0 + Do + press$ = InKey$ + Loop Until press$ = " " + Cls + Screen 13 + Call Menu + +End Sub + +Sub Trailer + Screen 9 + Cls + Locate 11, 20: Print "xtrGRAPHICS (TM)" + Sleep (2) + Cls + Locate 11, 25: Print "xtrGRAPHICS Presents....." + Sleep (4) + Cls + Locate 11, 30: Print "In a game where the need for speed is always great" + Sleep (3) + Screen 7, 0, 1, 0 + For i = 1 To 100 + x = Int(Rnd * 320) + 1 + y = Int(Rnd * 200) + 1 + PSet (x, y) + Next + Circle (100, 100), 40, 14 + Paint (100, 100), 14 + Circle (130, 150), 30, 12 + Paint (130, 150), 12 + Circle (320, 200), 60, 9 + Paint (319, 198), 9 + PCopy 1, 0 + For i = 1 To 50000: Next + + Cls + For i = 1 To 100 + x = Int(Rnd * 320) + 1 + y = Int(Rnd * 200) + 1 + PSet (x, y) + Next + Circle (0, 100), 160, 12 + Paint (0, 100), 12 + + x1 = 160: y1 = 100 + Do + press$ = InKey$ + Cls + For i = 1 To 100 + x = Int(Rnd * 320) + 1 + y = Int(Rnd * 200) + 1 + PSet (x, y) + Next + Circle (0, 100), 160, 12 + Paint (0, 100), 12 + PSet (x1, y1), 9 + x1 = x1 + 1 + PCopy 1, 0 + If press$ <> "" Then Call Bonus + For i = 1 To 1000: Next + Loop Until x1 >= 300 + + Screen 9 + Locate 11, 20: Print "Where you travel faster than the speed of light." + Sleep (3) + Cls + Screen 9 + Locate 11, 20: Print "And planet travel is all you know." + Sleep (3) + + Screen 7, 0, 1, 0 + x1 = 160: y1 = 190: + Do + press$ = InKey$ + Cls + For i = 1 To 100 + x = Int(Rnd * 320) + 1 + y = Int(Rnd * 200) + 1 + PSet (x, y) + Next + PSet (x1, y1), 9 + y1 = y1 - 1 + If y1 <= 100 Then GoTo iwarp + PCopy 1, 0 + If press$ <> "" Then Call Bonus + For i = 1 To 1000: Next + Loop + iwarp: cr = 1: + Do + press$ = InKey$ + Cls + For i = 1 To 100 + x = Int(Rnd * 320) + 1 + y = Int(Rnd * 200) + 1 + PSet (x, y) + Next + Circle (160, 100), cr, 10 + Line (160, 100)-(160, y1), 9 + y1 = y1 - 5 + cr = cr + 1 + PCopy 1, 0 + If press$ <> "" Then Call Bonus + For i = 1 To 500: Next + Loop Until cr = 20 + + Screen 9 + Locate 11, 20: Print "Hold on thight for this one...." + Sleep (3) + + Screen 7, 0, 1, 0 + x1 = 1: y1 = 100 + Do + press$ = InKey$ + Cls + For i = 1 To 100 + x = Int(Rnd * 320) + 1 + y = Int(Rnd * 200) + 1 + PSet (x, y) + Next + Circle (320, 100), 160, 10 + Paint (300, 100), 10 + PSet (x1, y1), 9 + x1 = x1 + 1 + PCopy 1, 0 + If press$ <> "" Then Call Bonus + For i = 1 To 1000: Next + Loop Until x1 >= 160 + + Screen 9 + Locate 11, 20: Print "There are more planets than you think..." + Sleep (3) + + Screen 7, 0, 1, 0 + x1 = 1: y1 = 30 + Do + press$ = InKey$ + Cls + press$ = InKey$ + Line (0, 0)-(320, 200), 1, BF + Line (0, 175)-(320, 200), 8, BF + Line (1, 100)-(40, 200), 7, BF + Line (42, 50)-(90, 200), 7, BF + Line (92, 70)-(140, 200), 7, BF + Line (142, 90)-(190, 200), 7, BF + Line (192, 110)-(260, 200), 7, BF + Line (262, 20)-(320, 200), 7, BF + PSet (x1, y1), 9 + x1 = x1 + 1 + PCopy 1, 0 + If press$ <> "" Then Call Bonus + For i = 1 To 1000: Next + Loop Until x1 >= 262 + + Cls + Dim ship(1000) + Line (1, 1)-(20, 35), 7, BF + Line (10, 1)-(1, 10), 9 + Line (10, 1)-(20, 10), 9 + Line (1, 10)-(1, 30), 9 + Line (20, 10)-(20, 30), 9 + Line (1, 30)-(20, 30), 9 + Paint (10, 10), 9 + Line (10, 30)-(10, 35), 7 + Line (1, 30)-(1, 35), 7 + Line (20, 30)-(20, 35), 7 + Circle (10, 10), 5, 8 + Paint (10, 10), 8 + PCopy 1, 0 + Get (1, 1)-(20, 35), ship() + y1 = 160 + Do + press$ = InKey$ + Cls + Line (0, 0)-(320, 200), 7, BF + Put (160, y1), ship(), PSet + y1 = y1 - 1 + PCopy 1, 0 + If press$ <> "" Then Call Bonus + Loop Until y1 = 50 + + Cls + Screen 7, 0, 1, 0 + + For i = 1 To 100 + x = Int(Rnd * 320) + 1 + y = Int(Rnd * 200) + 1 + PSet (x, y) + Next + Circle (100, 100), 40, 14 + Paint (100, 100), 14 + Circle (130, 150), 30, 12 + Paint (130, 150), 12 + Circle (320, 200), 60, 9 + Paint (319, 198), 9 + + + Line (60, 40)-(30, 60), 9 + Line (30, 60)-(60, 60), 9 + Line (60, 60)-(30, 80), 9 + + Line (63, 50)-(63, 80), 9 + Line (63, 50)-(73, 55), 9 + Line (73, 55)-(63, 65), 9 + + Circle (83, 50), 6, 9 + Line (88, 45)-(89, 55), 9 + + Line (93, 48)-(100, 40), 9 + Line (93, 48)-(105, 50), 9 + + Line (107, 45)-(117, 40), 9 + Line (107, 45)-(110, 35), 9 + Line (110, 35)-(117, 40), 9 + Line (107, 45)-(117, 45), 9 + + Line (25, 85)-(147, 37), 9 + + '************************* + + Line (70, 90)-(75, 110), 9 + Line (75, 110)-(80, 88), 9 + Line (80, 88)-(85, 109), 9 + Line (85, 109)-(90, 86), 9 + + Circle (100, 95), 6, 9 + Line (107, 98)-(102, 88), 9 + + Line (109, 87)-(111, 98), 9 + Line (109, 87)-(116, 84), 9 + + Line (119, 83)-(119, 101), 9 + Line (119, 83)-(129, 88), 9 + Line (129, 88)-(119, 92), 9 + + Line (50, 121)-(140, 100), 9 + + PCopy 1, 0 + Sleep (4) + Cls + Screen 13 + Call Bonus +End Sub + +Sub Trainerb + Cls + Screen 13 + Color 10 + Print " RoboRaiders: >>Trainer-Bots>>" + Locate 20, 3: Print "Press 'Enter' to select" + Locate 22, 2: Print "Press 'F1' for Help, Press 'Esc' to Exit" + C = 1 + Do + press$ = InKey$ + If C = 1 Then Locate 10, 15: Color 10: Print ">>TEST 1-2>>": Locate 11, 15: Color 15: Print ">>TEST 3<<": Locate 13, 15: Color 15: Print ">>BONUS-MENU<<" + If C = 2 Then Locate 10, 15: Color 15: Print ">>TEST 1-2<<": Locate 11, 15: Color 9: Print ">>TEST 3>>": Locate 13, 15: Color 15: Print ">>BONUS-MENU<<" + If C = 3 Then Locate 10, 15: Color 15: Print ">>TEST 1-2<<": Locate 11, 15: Color 15: Print ">>TEST 3<<": Locate 13, 15: Color 14: Print ">>BONUS-MENU>>" + If C = 2 Then If press$ = Chr$(0) + Chr$(80) Then C = 3: Play "D16" + If C = 1 Then If press$ = Chr$(0) + Chr$(80) Then C = 2: Play "D16" + If C = 2 Then If press$ = Chr$(0) + Chr$(72) Then C = 1: Play "D16" + If C = 3 Then If press$ = Chr$(0) + Chr$(72) Then C = 2: Play "D16" + If C = 2 Then If press$ = "2" Then C = 3: Play "D16" + If C = 1 Then If press$ = "2" Then C = 2: Play "D16" + If C = 2 Then If press$ = "8" Then C = 1: Play "D16" + If C = 3 Then If press$ = "8" Then C = 2: Play "D16" + If C = 1 Then If press$ = Chr$(13) Then Play "B16": Call Tbot1 + If C = 2 Then If press$ = Chr$(13) Then Play "B16": Call Tbot2 + If C = 3 Then If press$ = Chr$(13) Then Play "B16": Call Bonus + If press$ = Chr$(0) + ";" Then Call Help + Loop Until press$ = Chr$(27) + End + +End Sub + diff --git a/samples/robo-raider/src/roboraid.zip b/samples/robo-raider/src/roboraid.zip new file mode 100644 index 0000000..1eea498 Binary files /dev/null and b/samples/robo-raider/src/roboraid.zip differ diff --git a/samples/rockets/img/screenshot.png b/samples/rockets/img/screenshot.png new file mode 100644 index 0000000..e1a99d8 Binary files /dev/null and b/samples/rockets/img/screenshot.png differ diff --git a/samples/rockets/index.md b/samples/rockets/index.md new file mode 100644 index 0000000..502a693 --- /dev/null +++ b/samples/rockets/index.md @@ -0,0 +1,25 @@ +[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: ROCKETS + +![screenshot.png](img/screenshot.png) + +### Description + +```text +Screensaver with rocket-like particles. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "rockets.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/rockets/src/rockets.bas) +* [RUN "rockets.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/rockets/src/rockets.bas) +* [PLAY "rockets.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/rockets/src/rockets.bas) + +### File(s) + +* [rockets.bas](src/rockets.bas) + +🔗 [screensaver](../screensaver.md), [particles](../particles.md) diff --git a/samples/rockets/src/rockets.bas b/samples/rockets/src/rockets.bas new file mode 100644 index 0000000..9c5d35c --- /dev/null +++ b/samples/rockets/src/rockets.bas @@ -0,0 +1,104 @@ +$NoPrefix +Option Explicit +Option ExplicitArray +$Resize:Smooth + +DefLng A-Z + +Type vector + x As Single + y As Single +End Type + +Type Particle + pos As vector + vel As vector + fade As Single + active As _Byte + b As Single +End Type + +Type rocket + x As Single + y As Single + xs As Single + ys As Single + dead As _Byte +End Type + +Const MaxExplosion = 60 + +Dim rockets(5) As rocket +Dim particles(UBound(rockets) * MaxExplosion * 100) As Particle +Dim As Long i, n, v, k + +Randomize Timer +Screen NewImage(1280, 800, 32) +FullScreen SquarePixels , Smooth + +For i = 1 To UBound(particles) + particles(i).vel.x = Rnd * 2 + particles(i).vel.y = Rnd * 2 + particles(i).fade = Rnd * 3 + 1 + particles(i).b = 255 + If Rnd * 2 > 1 Then particles(i).vel.x = -particles(i).vel.x + If Rnd * 2 > 1 Then particles(i).vel.y = -particles(i).vel.y +Next + +For i = 1 To UBound(rockets) + rockets(i).y = _Height + rockets(i).x = Rnd * _Width + rockets(i).dead = -1 + rockets(i).xs = Rnd * 4 + rockets(i).ys = Rnd * 4 +Next + +Do While KeyHit <> 27 + Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, 50), BF + + For i = 1 To UBound(rockets) + If rockets(i).dead Then + + rockets(i).dead = 0 + rockets(i).x = Rnd * _Width + rockets(i).y = _Height + rockets(i).xs = Rnd * 4 + rockets(i).ys = Rnd * 4 + Else + n = 0 + While n < MaxExplosion + v = v + 1 + If v > UBound(particles) Then v = 0: Exit While + If Not particles(v).active Then particles(v).pos.x = rockets(i).x: particles(v).pos.y = rockets(i).y: particles(v).active = -1: n = n + 1 + Wend + rockets(i).x = rockets(i).x + rockets(i).xs + rockets(i).y = rockets(i).y - rockets(i).ys + rockets(i).ys = rockets(i).ys + .1 + rockets(i).xs = rockets(i).xs - .05 + PSet (rockets(i).x, rockets(i).y) + If rockets(i).y < 0 Then rockets(i).dead = -1: k = k + 1 + End If + Next + For i = 1 To UBound(particles) + If particles(i).active Then + PSet (particles(i).pos.x, particles(i).pos.y), _RGB(particles(i).b, particles(i).b, 0) + particles(i).pos.x = particles(i).pos.x + particles(i).vel.x + particles(i).pos.y = particles(i).pos.y + particles(i).vel.y + particles(i).vel.y = particles(i).vel.y + .05 + If particles(i).b > 0 Then particles(i).b = particles(i).b - particles(i).fade + End If + If particles(i).b < 0 Then + particles(i).active = 0 + particles(i).vel.x = Rnd * 2 + particles(i).vel.y = Rnd * 2 + particles(i).b = 255 + If Rnd * 2 > 1 Then particles(i).vel.x = -particles(i).vel.x + If Rnd * 2 > 1 Then particles(i).vel.y = -particles(i).vel.y + End If + Next + _Display + _Limit 120 +Loop + +End + diff --git a/samples/roguelike.md b/samples/roguelike.md new file mode 100644 index 0000000..17c24ed --- /dev/null +++ b/samples/roguelike.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: ROGUELIKE + +**[Ghost Wizard](ghost-wizard/index.md)** + +[🐝 Zack Johnson](zack-johnson.md) 🔗 [game](game.md), [roguelike](roguelike.md) + +' ' Ghost Wizard ' Zack Johnson ' 7DRL 2019 (Mar 2 - Mar 7) ' diff --git a/samples/rotozoomer/index.md b/samples/rotozoomer/index.md index e66e6ff..2269f0e 100644 --- a/samples/rotozoomer/index.md +++ b/samples/rotozoomer/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "rotozoom.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/rotozoomer/src/rotozoom.bas) -* [RUN "rotozoom.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/rotozoomer/src/rotozoom.bas) -* [PLAY "rotozoom.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/rotozoomer/src/rotozoom.bas) +* [LOAD "rotozoom.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/rotozoomer/src/rotozoom.bas) +* [RUN "rotozoom.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/rotozoomer/src/rotozoom.bas) +* [PLAY "rotozoom.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/rotozoomer/src/rotozoom.bas) ### File(s) diff --git a/samples/rpgfan3233.md b/samples/rpgfan3233.md new file mode 100644 index 0000000..478bfe8 --- /dev/null +++ b/samples/rpgfan3233.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 RPGFAN3233 + +**[Binary Counter](binary-counter/index.md)** + +[🐝 rpgfan3233](rpgfan3233.md) 🔗 [binary](binary.md), [counter](counter.md) + +' This program is a 12-bit Binary counter, displayed using a 3x4 grid. ' It was created in the ho... diff --git a/samples/saver/img/screenshot.png b/samples/saver/img/screenshot.png new file mode 100644 index 0000000..4dc204a Binary files /dev/null and b/samples/saver/img/screenshot.png differ diff --git a/samples/saver/index.md b/samples/saver/index.md new file mode 100644 index 0000000..9991361 --- /dev/null +++ b/samples/saver/index.md @@ -0,0 +1,54 @@ +[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: SAVER + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 David Ferrier](../david-ferrier.md) + +### Description + +```text +1 ' SAVER.BAS by David Ferrier +2 ' Copyright (C) 1992 DOS Resource Guide +3 ' Published in Issue #5, page 8 +4 ' This program works with both QBasic and GW-Basic + +============================================================================== + +----------- + SAVER.BAS +----------- +SYSTEM REQUIREMENTS: The version of QBasic that comes with DOS 5 or later, +Microsoft Quick Basic 4.x, or GW-Basic. + +WHAT SAVER.BAS DOES: +This program is a simple screen saver. When you run SAVER.BAS, it sends a +bouncing yellow line dancing across your screen in a random pattern. Use it +when you'll be away from your computer for a period of time, but want a +continuously changing screen display in your absence. + +USING SAVER.BAS: +To run the program, type QBASIC /RUN SAVER.BAS (using path names if necessary) +at the DOS prompt. The bouncing yellow line will appear and move around your +screen until you press any key to stop the program. + +For further details on SAVER.BAS, see "Color Trouble" (Tips From Readers, DRG +#5, page 8). +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "saver.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/saver/src/saver.bas) +* [RUN "saver.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/saver/src/saver.bas) +* [PLAY "saver.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/saver/src/saver.bas) + +### File(s) + +* [saver.bas](src/saver.bas) + +🔗 [screensaver](../screensaver.md), [dos world](../dos-world.md) diff --git a/samples/saver/src/saver.bas b/samples/saver/src/saver.bas new file mode 100644 index 0000000..026141b --- /dev/null +++ b/samples/saver/src/saver.bas @@ -0,0 +1,23 @@ +1 ' SAVER.BAS by David Ferrier +2 ' Copyright (C) 1992 DOS Resource Guide +3 ' Published in Issue #5, page 8 +4 ' This program works with both QBasic and GW-Basic +100 ' Moving line screen saver using QBasic or GW-Basic graphics +120 '----------------INITIALIZE LINE--------------- +130 SCREEN 9: CLS : COL = 14 +140 X1DIFF = -2: Y1DIFF = 5: X2DIFF = -3: Y2DIFF = 4 +150 X1 = 50: Y1 = 100: X2 = 200: Y2 = 300 +160 '----------------DISPLAY LINE------------------ +170 WHILE 1 = 1 +180 X1 = X1 + X1DIFF: Y1 = Y1 + Y1DIFF +190 X2 = X2 + X2DIFF: Y2 = Y2 + Y2DIFF +200 LINE (X1V, Y1V)-(X2V, Y2V), 0 +210 LINE (X1, Y1)-(X2, Y2), COL +220 X1V = X1: Y1V = Y1: X2V = X2: Y2V = Y2 +230 IF X1 > 640 OR X1 < 1 THEN X1DIFF = X1DIFF * -1 +240 IF Y1 > 350 OR Y1 < 1 THEN Y1DIFF = Y1DIFF * -1 +250 IF X2 > 640 OR X2 < 1 THEN X2DIFF = X2DIFF * -1 +260 IF Y2 > 350 OR Y2 < 1 THEN Y2DIFF = Y2DIFF * -1 +270 IF INKEY$ <> "" THEN SYSTEM +280 WEND + diff --git a/samples/schemat/img/screenshot.png b/samples/schemat/img/screenshot.png new file mode 100644 index 0000000..4ea0968 Binary files /dev/null and b/samples/schemat/img/screenshot.png differ diff --git a/samples/schemat/index.md b/samples/schemat/index.md new file mode 100644 index 0000000..d60c587 --- /dev/null +++ b/samples/schemat/index.md @@ -0,0 +1,57 @@ +[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: SCHEMAT + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Leif J. Burrow](../leif-j.-burrow.md) + +### Description + +```text +# Schemat +An old DOS QuickBasic schematic design editor updated for QB64. + +**What is it good for?** + +- Probably nothing at all. +- Maybe someone might use it to make really quick and simple schematic diagrams of small circuits for educational purposes. +- Maybe someone might place this on an old retro DOS computer for display. (If it ever works in DOS again). +- Most likely it isn't good for anything. + +**Why am I doing this?** + +I started this program when I was a teenager in high school. At the time I used to see ads for Circuit Maker and Electronics Workbench, two schematic capture and simulation programs that were popular at the time in electronics magazines. I did not have the money for this nor a computer capable of running them. I was still using MS-DOS. + +I wanted to write a similar application myself but geared towards older PCs like my own. I thought I could do this in QuickBasic. I had not yet heard of Open Source but shareware was common then. I thought I was going to sell it for a low price and make EDA software available to everyone. + +Obviously it never progressed that far but I did manage to build a simple little schematic capture program with a full version and a shareware version which my computer teacher uploaded to a BBS for me. I never heard from anyone who downloaded it. + +Over the years the floppy with my code was lost or destroyed. I still had paper printouts. I ran across these while cleaning and decided it was time to finally do something about it. I typed it all back in using QB64 and made some modifications so that it would run. + +Now I am putting it on GitHub so it doesn't get lost again. If anyone wants to extend this for their own purposes (although I doubt it) it is here. I only ask that any improvements be shared as well. + +**Acknowledgements** +This program was influenced by examples from the book "Tandy Graphics and Sound for the Tandy 1000s and PC Compatables" by William Barden, Jr. + +**What doesn't work** +- I am unable to test the print code as it was intended for use with old Epson compatible dot matrix printers connected to the printer port. It probably does not work in QB64 as an LPRINT width setting had to be commented out. +- The scale of some parts is a bit off. In particular the PNP symbol is much larger than the NPN symbol. I believe that this was fixed in the version which was lost. The printout was made before some of the symbols were completely finished. + +**What is changed** +- The original simply saved files to and loaded files from the directory it was ran from. This made much more sense on an old computer that used floppy discs. The new version saves and loads from the current working directory when it is started. It also displays this directory in the file, save and load menus so that the user can see where it is working. +- The original used bsave and bload to save and load the schematic on the screen. This seems to work differently in QB64. Instead it now saves bitmaps as .bmp files which are more compatible with new software anyway. + +**DOS** + +QB64 does not target DOS. Due to changes made in the code to get it running under QB64 it probably does not build in QuickBasic anymore. I may at some point revisit this and set up some sort of build system which comments/uncomments different parts in order to allow building in QuickBasic again. +``` + +### File(s) + +* [schemat.bas](src/schemat.bas) +* [schemat.zip](src/schemat.zip) + +🔗 [circuits](../circuits.md), [schematics](../schematics.md) diff --git a/samples/schemat/src/schemat.bas b/samples/schemat/src/schemat.bas new file mode 100644 index 0000000..cf2f8d6 --- /dev/null +++ b/samples/schemat/src/schemat.bas @@ -0,0 +1,1123 @@ +WORK_DIR$ = _StartDir$ +If Mid$(_OS$, 0, 9) = "[WINDOWS]" Then + DIR_SEP$ = "\" +Else + DIR_SEP$ = "/" +End If +Dim C%(2, 1) +Dim E1%(2, 1) +Dim E2%(2, 1) +Dim E4%(2, 2) +Dim E8%(3, 3) +Dim F(12) As String +On Error GoTo 83 +g% = FreeFile +Open "SCH.KYS" For Input As #g% +For X = 1 To 12 + Y = X + If X = 11 Then Y = 30 + If X = 12 Then Y = 31 + Input #g%, F(X) + KEY Y, F(X) +Next X +Close #g% +'*******************************TITLE SCREEN +83 Cls: Screen 0: Color 3, 0, 1 +_FullScreen 'QB64 +If _FullScreen = 0 Then _FullScreen _Off 'QB64 +Locate 10, 1: +Print " SCHEMATIC DESIGN PROGRAM " +Print " Version 1.0 " +Print " GPL Edition" +Print " (C) Copyright Leif J. Burrow 1994, 2019" +Print " Licensed under GPL 3.0 or later" +Locate 22, 1: Print " Press to begin." +Print " Press to set function key macros." +'Accept Input +84 I$ = InKey$: If I$ = "" Then 84 +If I$ = "B" Or I$ = "b" Then 85 +If I$ = "F" Or I$ = "f" Then 99 +GoTo 84 + +'********************************SETUP +85 S = 8 +Screen 2 +_FullScreen 'QB64 +If _FullScreen = 0 Then _FullScreen _Off 'QB64 +Cls +View Print 1 To 3 +Line (312, 103)-(314, 103) +Line (316, 103)-(318, 103) +Line (315, 100)-(315, 102) +Line (315, 104)-(315, 106) +Get (312, 100)-(318, 106), C%() +Cls +Line (312, 103)-(314, 103) +Line (312, 104)-(314, 104) +Get (312, 103)-(314, 104), E1%() +Cls +Line (312, 103)-(316, 103) +Line (312, 103)-(312, 105) +Line (316, 103)-(316, 105) +Line (312, 105)-(316, 105) +Get (312, 103)-(316, 105), E2%() +Cls +Line (312, 103)-(312, 107) +Line (312, 103)-(320, 103) +Line (320, 103)-(320, 107) +Line (320, 107)-(312, 107) +Get (312, 103)-(320, 107), E4%() +Cls +Line (312, 103)-(328, 103) +Line (312, 103)-(312, 111) +Line (328, 103)-(328, 111) +Line (328, 111)-(312, 111) +Get (312, 103)-(328, 111), E8%() +Cls +SX = 320 +SY = 100 +P$ = "Vert" +F$ = "SCHEMAT" +GoSub 10 + +'*******************************PLACE CURSOR +1 Put (SX - 3, SY - 3), C%(), Xor + +'**********************************COMMAND +89 I$ = InKey$: Locate 2, 69: Print Time$: If I$ = "" Then 89 +Put (SX - 3, SY - 3), C%(), Xor +If I$ = Chr$(0) + Chr$(77) Then GoSub 4 +If I$ = Chr$(0) + Chr$(75) Then GoSub 3 +If I$ = Chr$(0) + Chr$(72) Then GoSub 2 +If I$ = Chr$(0) + Chr$(80) Then GoSub 5 +If I$ = "S" Or I$ = "s" Then 8 +If I$ = "H" Or I$ = "h" Then 15 +If I$ = "L" Or I$ = "l" Then 14 +If I$ = "V" Or I$ = "v" Then 16 +If I$ = "E" Or I$ = "e" Then 9 +If I$ = "F" Or I$ = "f" Then 74 +If I$ = "T" Or I$ = "t" Then 17 +If I$ = "U" Or I$ = "u" Then 34 +If I$ = "D" Or I$ = "d" Then 36 +If I$ = "P" Or I$ = "p" Then 44 +If I$ = "C" Or I$ = "c" Then 45 +If I$ = "A" Or I$ = "a" Then 46 +If I$ = "W" Or I$ = "w" Then 53 +If I$ = "I" Or I$ = "i" Then 119 +If I$ = "M" Or I$ = "m" Then 62 +If I$ = "O" Or I$ = "o" Then 130 +If I$ = "B" Or I$ = "b" Then 142 +GoTo 1 + +'******************************** FUNCTIONS ************************************ +' CLEAR SCREEN +10 Cls +11 Print "T-Transistor V-IC A-Passive D-Diode P-Photonic C-Connection M-Misc I-Misc2" +Print "B-Tubes O-Logic L-Line F-File W-Write S-Step H-Hor V-Vert|Mode="; P$: Return +Return + +'*********************************FILE + +'Print Menu +74 Print: Print +Print "Working Directory: " + WORK_DIR$ +Print "N-New O-Open S-Save A-Save as P-Print M-Main H-Shell E-End" +75 I$ = InKey$: If I$ = "" Then 75 +If I$ = "N" Or I$ = "n" Then 78 +If I$ = "O" Or I$ = "o" Then 13 +If I$ = "S" Or I$ = "s" Then 12 +If I$ = "A" Or I$ = "a" Then 76 +If I$ = "P" Or I$ = "p" Then 60 +If I$ = "M" Or I$ = "m" Then 77 +If I$ = "H" Or I$ = "h" Then 111 +If I$ = "E" Or I$ = "e" Then End +GoTo 75 + +' SHELL +111 Print "Diagram will be lost if you have not saved it!" +Print "ontinue or ain Menu" +149 I$ = InKey$: If I$ = "" Then 149 +If I$ = "C" Or I$ = "c" Then + F$ = "SCHEMAT" + Cls + Shell + GoSub 10 + GoTo 1 +ElseIf I$ = "m" Or I$ = "m" Then + GoSub 11 + GoTo 1 +Else GoTo 149 +End If + +' New +78 Print "Diagram will be lost if you have not saved it!" +Print "ontinue or ain Menu" +150 I$ = InKey$: If I$ = "" Then 150 +If I$ = "C" Or I$ = "c" Then + F$ = "SCHEMAT" + GoSub 10 + GoTo 1 +Else GoTo 150 +End If + +'Load +13 Print: Print: Print +Print "Working Dir: " + WORK_DIR$ + "" +Input "File Name or for Main Menu "; N$ +If N$ = "M" Or N$ = "m" Then + GoSub 11 + GoTo 1 +End If +F$ = N$ +On Error GoTo 82 +' BLOAD F$ + ".SCH" ' QuickBasic +If _FileExists(WORK_DIR$ + DIR_SEP$ + F$ + ".BMP") = 0 Then 82 +img& = _LoadImage(WORK_DIR$ + DIR_SEP$ + F$ + ".BMP") +wide% = _Width(img&) +deep% = _Height(img&) +_Source img& +_Dest 0 +For Y = 0 To deep% - 1 + For X = 0 To wide% - 1 + PSet (X, Y), Point(X, Y) + Next +Next +_Source 0 +_Dest 0 +PSet (0, 0), 1 +GoSub 11 +GoTo 1 +82 Print "File Not Found" +' FOR A = 1 TO 450: NEXT A ' QuickBasic +_Delay 7 +GoTo 13 + +' Save +12 On Error GoTo 151 +' PRINT F$; ".SCH": PRINT "DATE: "; DATE$; " TIME:"; TIME$ ' QuickBasic +Print F$; ".BMP": Print "DATE: "; Date$; " TIME:"; Time$ ' QB64 +' DEF SEG = &HB800 'QuickBasic +' BSAVE F$ + ".SCH", 0, 32768! 'QuickBasic +SaveImage 0, WORK_DIR$ + DIR_SEP$ + F$ + ".BMP" + +GoSub 11 +GoTo 1 + +'Save As +76 Print: Print: Print +Print "Working Dir: " + WORK_DIR$ + "" +Input "File Name or for Main Menu "; N$ +If N$ = "M" Or N$ = "m" Then + GoSub 11 + GoTo 1 +End If +F$ = N$ +GoTo 12 + +' Print Diagram +60 On Error GoTo 151 +Print: Print " for main menu." +Input "Condenced or Full page "; I$ +If I$ = "M" Or I$ = "m" Then + GoSub 11 + GoTo 1 +End If +If I$ = "l" Then I$ = "L" Else If I$ = "k" Then I$ = "K" +Print " "; F$; ".SCH" +Print " DATE PRINTED: "; Date$; " TIME: "; Time$ +Def Seg = &HB800 +Open "LPT1:" For Output As #2 +' WIDTH "LPT1:", 255 - NOT SUPPORTED QB64 +Print #2, Chr$(27); "1"; +For X = 16112 To 16191 + B = X + Print #2, Chr$(13); + Print #2, Chr$(27); I$; Chr$(144); Chr$(1); + 54 Print #2, Chr$(Peek(B)); Chr$(0); + If B >= 0 And B < 80 Then 55 + If B < 8000 Then B = B + 8112 Else B = B - 8192 + GoTo 54 +55 Next X +Close #2 +For X = 1 To 34 + LPrint +Next X +GoSub 11 +GoTo 1 +'error +151 Print "ERROR!" +For X = 1 To 450: Next X +Close #2 +GoSub 11 +GoTo 1 + +'Main Menu +77 GoSub 11 +GoTo 1 + +'********************************MOVE CURSOR + +' Move up +2 SY = SY - S: If SY <= 24 Then SY = 24 +Return + +'Move left +3 SX = SX - S: If SX < 4 Then SX = 4 +Return + +'Move right +4 SX = SX + S: If SX >= 626 Then SX = 626 +Return + +'Move down +5 SY = SY + S: If SY > 196 Then SY = 196 +Return + +'*****************************DRAW LINES +'Replace Cursor +14 Print: Print: Print " Line" +Put (SX - 3, SY - 3), C%(), Xor + +'Start Line +PSet (SX, SY) +LX = SX: LY = SY + +'Accept Input +6 I$ = InKey$: If I$ = "" Then 6 +If I$ = "L" Or I$ = "l" Then 7 +If I$ = Chr$(0) + Chr$(77) Then 'move right + GoSub 94 + GoSub 4 + GoSub 94 + GoTo 6 +End If +If I$ = Chr$(0) + Chr$(75) Then 'move left + GoSub 94 + GoSub 3 + GoSub 94 + GoTo 6 +End If +If I$ = Chr$(0) + Chr$(72) Then 'move up + GoSub 94 + GoSub 2 + GoSub 94 + GoTo 6 +End If +If I$ = Chr$(0) + Chr$(80) Then 'move down + GoSub 94 + GoSub 5 + GoSub 94 + GoTo 6 +End If + +GoTo 6 + +'Cursor +94 Put (SX - 3, SY - 3), C%(), Xor +Return + +'Draw Line +7 Put (SX - 3, SY - 3), C%(), Xor +Line (LX, LY)-(SX, SY) +GoSub 11 +GoTo 1 + +'****************************CHANGE STEP +8 If S < 8 Then S = S * 2 Else S = 1 +GoTo 1 + +'****************************ERASE BLOCK +'Print Menu +9 Print: Print: Print +Print "E-Erase M-Main Menu" + +'Select Cursor +If S = 1 Then 95 +If S = 2 Then 96 +If S = 4 Then 97 +If S = 8 Then 98 + +'Place Cursor +95 Put (SX, SY), E1%(), Xor +GoTo 100 +96 Put (SX, SY), E2%(), Xor +GoTo 100 +97 Put (SX, SY), E4%(), Xor +GoTo 100 +98 Put (SX, SY), E8%(), Xor + +'Accept Input +100 I$ = InKey$: If I$ = "" Then 100 +If I$ = Chr$(0) + Chr$(77) Then 101 +If I$ = Chr$(0) + Chr$(75) Then 102 +If I$ = Chr$(0) + Chr$(72) Then 103 +If I$ = Chr$(0) + Chr$(80) Then 104 +If I$ = "M" Or I$ = "m" Then 107 +If I$ = "E" Or I$ = "e" Then 106 +GoTo 100 + +'Move Right +101 GoSub 105 +GoSub 4 +GoSub 105 +GoTo 100 + +'Move Left +102 GoSub 105 +GoSub 3 +GoSub 105 +GoTo 100 + +'Move Up +103 GoSub 105 +GoSub 2 +GoSub 105 +GoTo 100 + +'Move Down +104 GoSub 105 +GoSub 5 +GoSub 105 +GoTo 100 + +'Cursor +105 If S = 1 Then Put (SX, SY), E1%(), Xor +If S = 2 Then Put (SX, SY), E2%(), Xor +If S = 4 Then Put (SX, SY), E4%(), Xor +If S = 8 Then Put (SX, SY), E8%(), Xor +Return + +'Erase +106 Line Step(0, 0)-Step(S * 2, S), 0, BF +Line (0, 0)-(0, 0), 1 +GoSub 105 +GoTo 100 + +'Main Menu +107 GoSub 105 +GoSub 11 +GoTo 1 + +'*****************************CHANGE POLARIZATION +'To Horizontal +15 P$ = "Hor" +Locate 2 +Print "B-Tubes O-Logic L-Line F-File W-Write S-Step H-Hor V-Vert|Mode="; P$; "" +GoTo 1 + +' To Vertical +16 P$ = "Vert" +Locate 2 +Print "B-Tubes O-Logic L-Line F-File W-Write S-Step H-Hor V-Vert|Mode="; P$; "" +GoTo 1 + +'***************************WRITE INFO +53 View Print +Locate Int(SY / 8) + 1, Int(SX / 8) + 1 +Input ; "", U$ +View Print 1 To 3 +GoSub 11 +GoTo 1 + +'*****************************CHANGE FUNCTION KEYS +' List Fkeys +99 Cls: Screen 0: Color 3, 0, 1 +_FullScreen 'QB64 +If _FullScreen = 0 Then _FullScreen _Off 'QB64 +For X = 1 To 12 + Print " Function Key #"; X; ": "; F(X) +Next X +Print " Type 13 As Key# For Help." +Print " TYPE 14 As Key# To Print Fkeys" + +'Get New Fkeys +Input "ENTER KEY# ", X +If X = 13 Then 110 +If X = 14 Then 117 +Input "ENTER KEY SEQUENCE: ", S$ +F(X) = S$ +Input "ENTER ANOTHER? (Y/N): ", R$ +If R$ = "Y" Or R$ = "y" Then 99 + +'Save Fkeys To Disk +Input "ENTER DRIVE LETTER: ", D$ 'QuickBasic +Open D$ + "SCH.KYS" For Output As #1 'QuickBasic +For X = 1 To 12 + Print #1, F(X) +Next X +Close #1 + +' Set Fkeys +For X = 1 To 12 + Y = X + If X = 11 Then Y = 30 + If X = 12 Then Y = 31 + KEY Y, F(X) +Next X +KEY Off +GoTo 85 + +' Print Fkeys +117 For X = 1 To 12 + LPrint " Function Key #"; X; ": "; F(X) + LPrint +Next X +GoTo 99 + +'************************ COMPONENTS ************************ + +'**********************TRANSISTOR +'Print Menu +17 Locate 1, 1 +Print "N-NPN P-PNP U-UJT C-CUJT D-PUT S-SCR R-CSCR W-SCS O-SUS B-SBS T-Triac J-N JFET" +Print "F-P JFET G-N Mosfet E-P Mosfet M-Main Menu " + +' Accept Input +18 I$ = InKey$: If I$ = "" Then 18 +If I$ = "M" Or I$ = "m" Then 19 'MAIN MENU +If I$ = "N" Or I$ = "n" Then 20 'NPN +If I$ = "P" Or I$ = "p" Then 21 'PNP +If I$ = "U" Or I$ = "u" Then 22 'UJT +If I$ = "C" Or I$ = "c" Then 23 'CUJT +If I$ = "D" Or I$ = "d" Then 24 'PUT +If I$ = "R" Or I$ = "r" Then 24 'CSCR +If I$ = "S" Or I$ = "s" Then 25 'SCR +If I$ = "W" Or I$ = "w" Then 26 'SCS +If I$ = "O" Or I$ = "o" Then 27 'SUS +If I$ = "B" Or I$ = "b" Then 28 'SBS +If I$ = "T" Or I$ = "t" Then 29 'TRIAC +If I$ = "J" Or I$ = "j" Then 30 'N-JFET +If I$ = "F" Or I$ = "f" Then 31 'P-JFET +If I$ = "G" Or I$ = "g" Then 32 'N-MOSFET +If I$ = "E" Or I$ = "e" Then 33 'P-MOSFET +GoTo 18 + +' Main Menu +19 GoSub 11 +GoTo 1 + +' NPN +20 V$ = "D3 L6 R12 L2 D6 U6 L7 D2 L2 R4 L1 D1 L2 R1 D3" +H$ = "R6 U4 D8 U2 R4 U2 D4 R1 U4 D2 R1 U1 D2 R1 U2 D1 R4 BU5 L9" +GoTo 58 + +' PNP +21 V$ = "D3 R10 L20 BD1 BR 16 D6 R2 BL18 R6 U3 L2 R4 L1 U1 L2 R1 U1" +H$ = "R6 U4 D8 U2 R3 U1 D2 R1 U2 R1 U1 D4 R1 U4 D2 R5 BU5 L11 R11" +GoTo 58 + +' Unijunction Transistor +22 V$ = "G3 D1 L2 R4 L1 D1 L2 R1 D2 L7 R14 L2 D4 BL10 U4 D4" +H$ = "F4 U1 D2 R1 U2 D1 R3 U3 D6 U1 R8 BU4 L8 R8" +GoTo 58 + +' Complementary Unijunction Transistor +23 V$ = "G3 D1 R1 L3 D1 L1 R5 L2 D2 R7 L14 R2 D4 U4 R10 D4" +H$ = "F3 R2 U1 D2 R1 U2 R1 U1 D4 U2 R4 U4 D1 R7 L7 D7 U1 R7" +GoTo 58 + +'Programmable Unijunction Transistor +24 V$ = "D3 L4 R8 E3 G3 L1 D1 L6 R1 D1 R4 L1 D1 L2 R1 D2 L2 R4 L2 D2 BR20" +H$ = "R6 U2 H2 F2 D4 R1 U4 D1 R1 D2 R1 U2 D1 R4 U1 D2 U1 R4" +GoTo 58 + +' SCR +25 V$ = "D3 L4 R8 L1 D1 L6 R1 D1 R4 L1 D1 L2 R1 D1 L4 R8 L2 D3 U3 L3 G3" +H$ = "R6 U2 D4 R1 U4 D1 R1 D2 R1 U2 D1 R4 U2 D4 F2 H2 U2 R4" +GoTo 58 + +' Silicon Controlled Switch +26 V$ = "D3 L4 R8 E3 G3 L1 D1 L6 R1 D1 R4 L1 D1 L2 R1 D2 L3 R6 L2 D3 U3 L2 G3" +H$ = "R6 U2 H2 F2 D4 R1 U4 D1 R1 D2 R1 U2 D1 R4 U2 D4 F2 H2 U2 R4" +GoTo 58 + +' Silicon Unilateral Switch +27 V$ = "D3 R6 G6 U6 L6 R6 D6 L3 R6 L3 D3" +H$ = "D12 H6 R12 L12 U3 D6 U3 L6" +GoTo 58 + +' Silicon Bilateral Switch +28 If P$ = "Vert" Then 59 +H$ = "D12 U6 L9 R15 L6 U3 L6 R11 D1 G5 L6 E6 U3" +GoTo 58 + +' Triac +29 If P$ = "Hor" Then 59 +V$ = "D4 G3 H3 R12 L3 D1 F3 L6 E3 G3 D3 U3 L6 G3" +GoTo 58 + +' N-jfet +30 V$ = "D3 D1 L2 R4 L1 D1 L2 R1 D2 L7 R16 D1 L16 R2 D4 U4 R11 D4" +H$ = "R6 U3 D6 R1 U6 D1 R1 D4 R1 U4 D2 R3 U5 D10 U2 R6 L6 U6 R6" +GoTo 58 + +' P-jfet +31 V$ = "D3 L1 R2 D1 R1 L4 R2 D2 L5 R10 D1 L10 R2 D3 L6 R6 U3 R6 D3 R6" +H$ = "R4 U1 D2 R1 U2 R1 U1 D4 R1 U4 D2 R4 U5 D10 U2 R6 L6 U6 R6" +GoTo 58 + +' N-mosfet +32 V$ = "D2 R7 BD2 R3 D2 L1 D5 R4 L4 U5 L2 U2 BL3 D2 L1 D2 L2 R4 L2 D1 L1 R2 L1 D2 L6 R6 U5 L2 U2 R3 BL6 D2 L3 U2 R3 D2 L2 D5 L4" +H$ = "R5 U7 BR2 U3 R3 D2 R9 U4 D4 L9 D2 L3 BD3 R3 D1 R3 U1 D2 R1 U2 R1 U1 D4 R1 U4 D2 R3 D6 U6 L9 D2 L3 U3 BD6 D3 R3 U3 L3 D3 R3 U1 R9 D4" +GoTo 58 + +' P-mosfet +33 V$ = "D2 R7 BD2 R3 D2 L1 D5 R4 L4 U5 L2 U2 BL3 D2 L1 D2 L2 R4 L2 D1 L1 R2 L1 D2 L6 R6 U5 L2 U2 R3 BL6 D2 L3 U2 R3 D2 L2 D5 L4" +H$ = "R5 U7 BR2 U3 R3 D2 R9 U4 D4 L9 D2 L3 BD3 R3 D1 R3 U2 D4 R1 U4 D1 R1 D2 R1 U2 D1 R3 D6 U6 L9 D2 L3 U3 BD6 D3 R3 U3 L3 D3 R3 U1 R9 D4" +GoTo 58 + +'***************************INTEGRATED CIRCUITS + +' Information +34 Print: Print +Print "NUMBER OF PINS";: Input P +If P <= 2 Then 35 +P = P / 2 + +' Position +View Print +X = Int(SY / 8) + 1: Y = Int(SX / 8) + 1 +Locate X, Y + +' Top +Print ""; +For A = 1 To P: Print ""; +Next A +Print "" + +' MIDDLE +X = X + 1 +Locate X, Y +Print " ^"; +For A = 1 To P - 1: Print " "; +Next A +Print "" + +' BOTTOM +X = X + 1 +Locate X, Y +Print ""; +For A = 1 To P + Print ""; +Next A + +Print "" +View Print 1 To 3 +GoSub 11 +GoTo 1 + +'**************************Information Error Trap +35 If PN$ = "N" Or PN$ = "n" Then 24 + +'********************************DIODES + +' PRINT MENU +36 Print "D-STND Z-ZENER T-TUNNEL H-THYRECTOR I-DIAC TRIGGER M-MENU" +Print + +'Accept Input +37 I$ = InKey$: If I$ = "" Then 37 +If I$ = "D" Or I$ = "d" Then 38 +If I$ = "Z" Or I$ = "z" Then 39 +If I$ = "T" Or I$ = "t" Then 40 +If I$ = "H" Or I$ = "h" Then 41 +If I$ = "I" Or I$ = "i" Then 42 +If I$ = "M" Or I$ = "m" Then 43 +GoTo 37 + +'Standard +38 V$ = "D3 L4 R8 L1 D1 L6 R1 D1 R4 L1 D1 L2 R1 D2 L3 R6 L3 D3" +H$ = "R6 U4 D8 R1 U8 D1 R1 D6 R1 U6 D1 R1 D4 R1 U4 D2 R4 U3 D6 U3 R6" +GoTo 58 + +'Zener +39 V$ = "D3 L4 R8 L1 D1 L6 R1 D1 R4 L1 D1 L2 R1 D2 L4 U1 D1 R8 D1 U1 L4 D3" +H$ = "R6 U4 D8 R1 U8 D1 R1 D6 R1 U6 D1 R1 D4 R1 U4 D2 R5 U3 L2 R2 D6 R2 L2 U3 R6" +GoTo 58 + +'Tunnel +40 V$ = "D3 L4 R8 L1 D1 L6 R1 D1 R4 L1 D1 L2 R1 D2 L4 U1 D1 R8 U1 D1 L4 D3" +H$ = "R6 U4 D8 R1 U8 D1 R1 D6 R1 U6 D1 R1 D4 R1 U4 D2 R4 U3 L2 R2 D6 L2 R2 U3 R6" +GoTo 58 + +'Thyrector +41 V$ = "D3 L3 R6 L3 D1 L2 R4 L2 D1 L1 R2 L1 D2 L2 BL5 U2 D2 L4 R4 BR5 R4 L2 D2 L1 R2 L1 D1 L2 R4 L2 D1 L3 R6 L3 D3" +H$ = "R6 U3 D6 R1 U6 D1 R1 D4 R1 U4 D1 R1 D2 R1 U2 D1 R4 U2 D4 BD3 L4 R4 D3 U3 BU5 R4 U1 D2 R1 U2 R1 U1 D4 R1 U4 R1 U1 D6 R1 U6 D3 R4" +GoTo 58 + +'Diac Trigger +42 V$ = "L8 R17 L4 D3 L3 R6 L1 D1 L4 R1 D1 R2 L1 D2 R6 BL21 R7 U2 L1 R2 U1 R1 L4 U1 L1 R6 L3 U3" +H$ = "D8 U16 D5 R4 U4 D8 R1 U8 D1 R1 D4 R1 U4 D1 R1 D2 R1 U2 D1 R5 U6 BD20 U6 L5 U1 D2 L1 U2 L1 U1 D4 L1 U4 L1 U1 D6 L1 U6 D3 L4" +GoTo 58 + +'Main Menu +43 GoSub 11 +GoTo 1 + +'****************************PASSIVE COMPONENTS + +' Print menu +46 Print " C-Capacitor R-Resistor O-Coil M-Main Menu" +Print +'Accept Input +47 I$ = InKey$: If I$ = "" Then 47 +If I$ = "C" Or I$ = "c" Then 48 +If I$ = "R" Or I$ = "r" Then 49 +If I$ = "O" Or I$ = "o" Then 50 +If I$ = "M" Or I$ = "m" Then 52 +GoTo 47 + +'Capacitor +48 V$ = "D3 R6 L12 BD2 D3 U3 R12 D3 U3 L6 D6" +H$ = "R6 D3 U6 BR6 R4 L4 D6 R4 L4 U3 R10" +GoTo 58 + +'Resistor +49 V$ = "D3 G2 F4 G4 F4 G2 D3" +H$ = "R6 E3 F6 E6 F6 E6 F6 E3 R6" +GoTo 58 + +'Coil +'Determine Polarization +50 If P$ = "Vert" Then + 'Draw Vertical Coil + Draw "BM " + Str$(SX) + ", " + Str$(SY) + "D3" + SY = SY + 5 + For X = 1 To 3 + Circle (SX, SY), 3 + SY = SY + 3 + Next X + Draw "BM " + Str$(SX) + ", " + Str$(SY) + " D3" + SY = SY + 3 + GoSub 11 + GoTo 1 +Else + 'Draw Horizontal Coil + Draw "BM " + Str$(SX) + ", " + Str$(SY) + " R6" + SX = SX + 11 + For X = 1 To 3 + Circle (SX, SY), 6 + SX = SX + 6 + Next X + SX = SX + 2 + Draw "BM " + Str$(SX) + ", " + Str$(SY) + " R6" + SX = SX + 6 + GoSub 11 + GoTo 1 +End If + +'Main Menu +52 GoSub 11 +GoTo 1 + +'***************************** MISC PARTS + +'Print Menu +62 Print "V-Variable Arrow A-Antenna B-Box G-Ground C-Chassis Gnd. S-Switch X-Xtal" +Print "L-Left Arrow R-Right Arrow U-Up Arrow D-Down Arrow P-Push Btn M-Main Menu " + +'Accept Input +63 I$ = InKey$: If I$ = "" Then 63 +If I$ = "V" Or I$ = "v" Then 64 +If I$ = "A" Or I$ = "a" Then 65 +If I$ = "B" Or I$ = "b" Then 66 +If I$ = "G" Or I$ = "g" Then 67 +If I$ = "C" Or I$ = "c" Then 68 +If I$ = "S" Or I$ = "s" Then 69 +If I$ = "L" Or I$ = "l" Then 70 +If I$ = "R" Or I$ = "r" Then 71 +If I$ = "U" Or I$ = "u" Then 72 +If I$ = "D" Or I$ = "d" Then 73 +If I$ = "X" Or I$ = "x" Then 80 +If I$ = "M" Or I$ = "m" Then 81 +If I$ = "P" Or I$ = "p" Then 118 +GoTo 63 + +'Main Menu +81 GoSub 11 +GoTo 1 + +'Variable Arrow +64 V$ = "H16 R3 L3 D3" +H$ = "E14 D3 U3 L3" +GoTo 58 + +'Antenna +65 If P$ = "Hor" Then 59 +V$ = "U9 G6 R12 H6" +GoTo 58 + +'Box +66 V$ = "R96 D32 L96 U32" +H$ = V$ +GoTo 58 + +'Ground +67 If P$ = "Hor" Then 59 +V$ = "D3 L3 R6 L1 BD2 L4 R1 BD2 R2" +GoTo 58 + +'Chassis Ground +68 If P$ = "Hor" Then 59 +V$ = "D6 U3 L6 D3 U3 R12 D3" +GoTo 58 + +'Switch +69 Circle (SX, SY), 4 +V$ = "D8" +H$ = "BU4 R16" +GoTo 58 + +'Left Arrow +70 V$ = "E2 G2 F2 H2 R7" +H$ = V$ +GoTo 58 + +'Right Arrow +71 V$ = "R7 H2 F2 G2" +H$ = V$ +GoTo 58 + +'Up Arrow +72 V$ = "U5 G2 E2 F2" +H$ = V$ +GoTo 58 + +'Down Arrow +73 V$ = "D5 H2 F2 E2" +H$ = V$ +GoTo 58 + +'Crystal +80 V$ = "D3 R3 L6 BD2 R6 D2 L6 U2 D2 BD2 R6 L3 D3" +H$ = "R6 U3 D6 BR4 U6 R4 D6 L4 BR8 U6 D3 R6" +GoTo 58 + +'Push Button +118 V$ = "D3 L6 R12" +H$ = "R6 D3 U6" +GoTo 58 + + +'********************* MISC PARTS #2 + +'Print Menu +119 Print "A-AC Plug E-Meter L-Lamp B-Battery S-Speaker P-Piezo Buzzer O-Op Amp" +Print "M-Main Menu" + +' Accept Input +120 I$ = InKey$: If I$ = "" Then 120 +If I$ = "A" Or I$ = "a" Then 121 +If I$ = "E" Or I$ = "e" Then 122 +If I$ = "L" Or I$ = "l" Then 123 +If I$ = "B" Or I$ = "b" Then 124 +If I$ = "S" Or I$ = "s" Then 125 +If I$ = "P" Or I$ = "p" Then 126 +If I$ = "M" Or I$ = "m" Then 129 +If I$ = "O" Or I$ = "o" Then 139 +GoTo 120 + +' AC Plug +121 V$ = "BU11 D3 R2 L3 U3 D3 L5 U3 L1 D3 L3 R1 D1 F2 D5 U5 F3 R1 E3 D5 U5 E2 U1" +H$ = V$ +GoTo 58 + +'Meter +122 V$ = "R6 U3 R14 D3 R6 L6 D6 L14 U6 D3 R14 L4 H4" +H$ = V$ +GoTo 58 + +'Lamp +123 V$ = "D4 F6 E2 U2 L2 G6 D4" +H$ = "R7 E3 H1 L2 D1 F3 R7" +GoTo 58 + +'Battery +124 V$ = "D3 L4 L6 R6 D2 R6 U8 L6 D2 U2 R6 E6 D21 H6" +H$ = "R6 U3 D3 L2 D3 R8 U3 L2 R2 D3 F6 L21 E6" +GoTo 58 + +'Speaker +125 V$ = "R6 D4 L6 R6 D2 R6 U8 L6 D2 U2 R6 E6 D21 H6" +H$ = "D3 L4 U3 D3 L2 D3 R8 U3 L2 R2 D3 F6 L21 E6" +GoTo 58 + +'Piezo Buzzer +'Determine Polarization +126 If P$ = "Hor" Then + 'Draw Vertical + Draw "BD3 R6 BR22 R6" + CX = SX + 13 + Circle (SX, CY), 10 + Circle (SX, CY), 3 + GoSub 11 + GoTo 1 +Else + 'Draw Horizontal + Draw "BR2 D3 BD10 D3" + CY = SY + 5 + Circle (SX, CY), 10 + Circle (SX, CY), 3 + GoSub 11 + GoTo 1 +End If + +'Operational Amplifier +139 V$ = "D3 G6 R3 D3 U3 R6 D3 U3 R3 H6" +H$ = "" +GoTo 58 + +'Main Menu +129 GoSub 11 +GoTo 1 + + +'****************************** LOGIC + +'Display Menu +130 Print "A-And N-Nand I=Inverter O-Or R-Nor E-Ex-or M-Main Menu" +Print + +'Accept Input +131 I$ = InKey$: If I$ = "" Then 131 +If I$ = "A" Or I$ = "a" Then 132 +If I$ = "N" Or I$ = "n" Then 133 +If I$ = "I" Or I$ = "i" Then 134 +If I$ = "O" Or I$ = "o" Then 135 +If I$ = "R" Or I$ = "r" Then 136 +If I$ = "E" Or I$ = "e" Then 137 +If I$ = "M" Or I$ = "m" Then 138 +GoTo 131 + +'And Gate +132 V$ = "D3 G6 D3 R2 D3 U3 R8 D3 U3 R2 U3 H6 L1 U3" +H$ = "R6 U2 R10 F3 R6 L6 D1 G3 L10 U2 L6 R6 U3" +GoTo 58 + +'Nand Gate +133 V$ = "BD5 G6 D3 R2 D3 U3 R8 D3 U3 R2 U3 H6 L2 U2 R4 D2 L2 U5" +H$ = "R6 U2 R10 F3 R2 U1 R4 D2 L4 U1 BR4 R6 BL12 D1 G3 L10 U2 L6 R6 U3" +GoTo 58 + +'Inverter +134 V$ = "D3 L2 D2 R4 U2 L2 BD2 G6 R6 D3 U3 R6 H6" +H$ = "" +GoTo 58 + +'Or Gate +135 V$ = "D3 G8 D3 U2 R4 D3 U3 R8 D3 U3 R4 D2 U3 H8 L1 U3" +H$ = "R6 U2 L3 R3 R10 F3 R6 L6 D1 G3 L10 L3 R3 U2 L6 R6 U3" +GoTo 58 + +'Nor Gate +136 V$ = "D3 L2 D2 R4 U2 L2 BD2 G8 D3 U2 R4 D3 U3 R8 D3 U3 R4 D2 U3 H8" +H$ = "R6 U2 L3 R13 F3 R3 U2 R2 D2 R6 L6 D2 L2 U2 L3 D1 G3 L13 R3 U4 D2 L6" +GoTo 58 + +'Ex-or Gate +137 V$ = "D3 L2 D2 R4 U2 L2 BD2 G8 D3 U2 R4 D7 U3 L3 D2 U2 R14 D2 U2 L11 U4 R8 D7 U7 R4 D2 U3 H8" +H$ = "R6 U2 L3 R3 D7 L3 R3 U5 R6 U2 L3 R13 F3 R3 U2 R2 D4 L2 U2 BR2 R6 BL11 D1 G3 L13 R3 U2 L12 R12 U3" +GoTo 58 + +'Main Menu +138 GoSub 11 +GoTo 1 + +'****************************TUBES + +'Print Menu +142 Print "F-Filament C-Cathode P-Plate G-Grid M-Main Menu" +Print + +'Accept Input +143 I$ = InKey$: If I$ = "" Then 143 +If I$ = "F" Or I$ = "f" Then 144 +If I$ = "P" Or I$ = "p" Then 145 +If I$ = "C" Or I$ = "c" Then 146 +If I$ = "G" Or I$ = "g" Then 147 +If I$ = "M" Or I$ = "m" Then 148 + +'Filament +144 V$ = "U6 E3 F3 D6" +H$ = "R12 F3 G3 L12" +GoTo 58 + +'Cathode +145 V$ = "U6 R12 D2" +H$ = "L12 U6 R2" +GoTo 58 + +'Plate +146 V$ = "D6 L6 R12" +H$ = "L12 U3 D6" +GoTo 58 + +'Grid +147 V$ = "R2 BR4 R2 BR4 R2" +H$ = "D3 BD3 D3 BD3 D3" +GoTo 58 + +'Main Menu +148 GoSub 11 +GoTo 1 + +'*****************************PHOTONIC +44 V$ = "G2 E2 F2 E2 F2 H2 D5 BL4 U5" +H$ = "F2 G2 F2 G2 E2 L10 BU4 R10" +GoTo 58 + +'*****************************CONNECTION +45 Circle (SX, SY), 4 +GoTo 1 + +'*****************************DRAW SHAPE +58 If P$ = "Hor" Then + Draw "BM " + Str$(SX) + ", " + Str$(SY) + " BD3 BR3 X" + VarPtr$(H$) +Else + Draw "BM " + Str$(SX) + ", " + Str$(SY) + " BD3 BR3 X" + VarPtr$(V$) +End If +GoSub 11 +GoTo 1 + +'*****************************Display Component Not Availiable In This Polarization +59 Print: Print "Sorry, this component isn't available in this mode." +' FOR A = 1 to 450 : NEXT A 'QUICK BASIC +_Delay 7 'QB64 +GoSub 11 +GoTo 1 + +'**************************** HELP *************************** + +'***************************** FUNCTION KEYS + +' print choices +110 Cls +Locate 10, 1 +Print " Would you like " +Print " irections or a" +Print " ey List" +Print +Print " Type the letter in the <> of your choice " +112 I$ = InKey$ +If I$ = "D" Or I$ = "d" Then 113 +If I$ = "K" Or I$ = "k" Then 115 +GoTo 112 +113 Cls +Print " ****************************************************************************" +Print " * HELP *" +Print " * FUNCTION KEYS MACROS *" +Print " ****************************************************************************" +Print " By setting function key macros, you can save time by only having" +Print " press one key for things that usually take more." +Print " The computer will ask you to enter the number of the key you would" +Print " like to set. Next it will ask you for the key sequence. This is the" +Print " keys you would normally have to type for whatever you want the key to" +Print " do." +Print " Next you will be asked for a drive letter. This is to tell the" +Print " computer what drive to save the macros on, so that tyhey will be ready" +Print " the next time you run the program. This must be on the same disk as" +Print " Schemat." +Print " The chart at the top tells you what the macros are already set at." +Locate 23, 1 +Print " Press when done reading." +114 I$ = InKey$ +If I$ = "D" Or I$ = "d" Then 115 +GoTo 114 + +'Key List +115 Cls +Print " Main Menu" +Print " " +Print "T-Transistor U-IC A-Passive D-Diode P-Photonic C-Connection M-Misc I-Misc2" +Print "B-Tubes O-Logic F-File W-Write S-Step H-Hor V-Vert" +Print +Print " Transistor Menu" +Print " " +Print "N-NPN P-PNP C-CUJT D-PUT S-SCR R-CSR W-WCS O-SUS B-SBS T-Triac J-N JFET" +Print "F-P JFET G-N MOSFET E-P MOSFET" +Print +Print " Passive Component Menu" +Print " " +Print " C-Capacitor R-Resistor O-Coil" +Print +Print " Miscellaneous" +Print " " +Print "V-Variable Arrow A-Antenna B-Box G-Ground C-Chassis Ground S-Switch X-XTAL" +Print "L-Left Arrow R-Right Arrow U-Up Arrow P-Push Button" +Print +Print " FILE" +Print " " +Print "N-New O-Open S-Save A-Save As P-Print M-Main Menu H-Shell E-End" +Print " Press when done reading." +116 I$ = InKey$: If I$ = "" Then 116 +If I$ = "d" Or I$ = "d" Then 140 +GoTo 116 +140 Cls +Print +Print " Miscellaneous 2" +Print " " +Print "A-Ac Plug E-Meter L-Lamp B-Battery S-Speaker P-Piezo Buzzer O-Op Amp" +Print +Print " LOGIC" +Print " " +Print " A-And N-Nand I-Inverter O-Or R-Nor E-Ex-or" +Print +Print " TUBES" +Print " " +Print " F-Filament C-Cathode P-Plate G-Grid" +Print +Print " ASCII SYMBOLS" +Print " " +Print +Print "Press and hold the button, and type the numberr of the character" +Print "that you would like to type." +Print +Print " Some usefull caracters are:" +Print " 234 179 180 " +Print " 191 192 193 " +Print " 194 195 196 " +Print " 197 " +Locate 23, 50: Print "Press when done reading." +141 I$ = InKey$: If I$ = "" Then 141 +If I$ = "D" Or I$ = "d" Then 99 +GoTo 141 + +' FROM https://www.qb64.org/wiki/SAVEIMAGE +' License: "This SUB program can also be Included with any program!" +Sub SaveImage (image As Long, filename As String) + bytesperpixel& = _PixelSize(image&) + If bytesperpixel& = 0 Then Print "Text modes unsupported!": End + If bytesperpixel& = 1 Then bpp& = 8 Else bpp& = 24 + x& = _Width(image&) + y& = _Height(image&) + b$ = "BM????QB64????" + MKL$(40) + MKL$(x&) + MKL$(y&) + MKI$(1) + MKI$(bpp&) + MKL$(0) + "????" + String$(16, 0) 'partial BMP header info(???? to be filled later) + If bytesperpixel& = 1 Then + For c& = 0 To 255 ' read BGR color settings from JPG image + 1 byte spacer(CHR$(0)) + cv& = _PaletteColor(c&, image&) ' color attribute to read. + b$ = b$ + Chr$(_Blue32(cv&)) + Chr$(_Green32(cv&)) + Chr$(_Red32(cv&)) + Chr$(0) 'spacer byte + Next + End If + Mid$(b$, 11, 4) = MKL$(Len(b$)) ' image pixel data offset(BMP header) + lastsource& = _Source + _Source image& + If ((x& * 3) Mod 4) Then padder$ = String$(4 - ((x& * 3) Mod 4), 0) + For py& = y& - 1 To 0 Step -1 ' read JPG image pixel color data + r$ = "" + For px& = 0 To x& - 1 + c& = Point(px&, py&) 'POINT 32 bit values are large LONG values + If bytesperpixel& = 1 Then r$ = r$ + Chr$(c&) Else r$ = r$ + Left$(MKL$(c&), 3) + Next px& + d$ = d$ + r$ + padder$ + Next py& + _Source lastsource& + 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) + If LCase$(Right$(filename$, 4)) <> ".bmp" Then ext$ = ".BMP" + f& = FreeFile + Open filename$ + ext$ For Output As #f&: Close #f& ' erases an existing file + Open filename$ + ext$ For Binary As #f& + Put #f&, , b$ + Close #f& +End Sub + diff --git a/samples/schemat/src/schemat.zip b/samples/schemat/src/schemat.zip new file mode 100644 index 0000000..00bfcb7 Binary files /dev/null and b/samples/schemat/src/schemat.zip differ diff --git a/samples/schematics.md b/samples/schematics.md new file mode 100644 index 0000000..573a4d0 --- /dev/null +++ b/samples/schematics.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: SCHEMATICS + +**[Schemat](schemat/index.md)** + +[🐝 Leif J. Burrow](leif-j.-burrow.md) 🔗 [circuits](circuits.md), [schematics](schematics.md) + +# Schemat An old DOS QuickBasic schematic design editor updated for QB64. **What is it good for?... diff --git a/samples/screenblanker.md b/samples/screenblanker.md index cf65e18..017edf2 100644 --- a/samples/screenblanker.md +++ b/samples/screenblanker.md @@ -10,7 +10,7 @@ **[Binary Clock](binary-clock/index.md)** -[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... @@ -34,25 +34,25 @@ **[Lightning One](lightning-one/index.md)** -[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... **[Lightning Two](lightning-two/index.md)** -[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... **[Multi-Mill](multi-mill/index.md)** -[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... **[Mystify](mystify/index.md)** -[🐝 RhoSigma](rhosigma.md) 🔗 [screenblanker](screenblanker.md) +[🐝 Rho Sigma](rho-sigma.md) 🔗 [screenblanker](screenblanker.md) '+---------------+---------------------------------------------------+ '|_######_######_|_____.--... diff --git a/samples/screensaver.md b/samples/screensaver.md index a9fe43a..faeefe2 100644 --- a/samples/screensaver.md +++ b/samples/screensaver.md @@ -44,12 +44,24 @@ Created by QB community member darokin. '///Non Palette rotated plasma '///Relsoft 2003 '///Compile and see the speed. Didn't optimize i... +**[Rockets](rockets/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [screensaver](screensaver.md), [particles](particles.md) + +Screensaver with rocket-like particles. + **[Rotozoomer](rotozoomer/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [9 lines](9-lines.md) ' OPTIMIZED :) rotozoomer in 9 lines by Antoni Gual 'for Rel's 9 LINER contest at QBASICNEWS.COM... +**[Saver](saver/index.md)** + +[🐝 David Ferrier](david-ferrier.md) 🔗 [screensaver](screensaver.md), [dos world](dos-world.md) + +1 ' SAVER.BAS by David Ferrier 2 ' Copyright (C) 1992 DOS Resource Guide 3 ' Published in Issu... + **[Twirl](twirl/index.md)** [🐝 Antoni Gual](antoni-gual.md) 🔗 [screensaver](screensaver.md), [9 lines](9-lines.md) diff --git a/samples/shooter.md b/samples/shooter.md index 534dd33..d0a2730 100644 --- a/samples/shooter.md +++ b/samples/shooter.md @@ -2,6 +2,12 @@ ## SAMPLES: SHOOTER +**[Hunters Revenge](hunters-revenge/index.md)** + +[🐝 Ashish Kushwaha](ashish-kushwaha.md) 🔗 [game](game.md), [shooter](shooter.md) + +# Hunter-Revenge A shooting game created in QB64 + **[Shooter](shooter/index.md)** [🐝 *missing*](author-missing.md) 🔗 [game](game.md), [shooter](shooter.md) diff --git a/samples/simulation.md b/samples/simulation.md new file mode 100644 index 0000000..28dcfa8 --- /dev/null +++ b/samples/simulation.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: SIMULATION + +**[Integrators](integrators/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [physics](physics.md), [simulation](simulation.md) + +Demonstrates the efficacy of various integration methods in physics. diff --git a/samples/sine-wave-explorer/index.md b/samples/sine-wave-explorer/index.md index dff0370..d810b00 100644 --- a/samples/sine-wave-explorer/index.md +++ b/samples/sine-wave-explorer/index.md @@ -14,9 +14,9 @@ Sine Wave Explorer > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "sinewave.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/sine-wave-explorer/src/sinewave.bas) -* [RUN "sinewave.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/sine-wave-explorer/src/sinewave.bas) -* [PLAY "sinewave.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/sine-wave-explorer/src/sinewave.bas) +* [LOAD "sinewave.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/sine-wave-explorer/src/sinewave.bas) +* [RUN "sinewave.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/sine-wave-explorer/src/sinewave.bas) +* [PLAY "sinewave.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/sine-wave-explorer/src/sinewave.bas) ### File(s) diff --git a/samples/sinecube/index.md b/samples/sinecube/index.md index 022a608..7bffdab 100644 --- a/samples/sinecube/index.md +++ b/samples/sinecube/index.md @@ -19,9 +19,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "sinecube.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/sinecube/src/sinecube.bas) -* [RUN "sinecube.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/sinecube/src/sinecube.bas) -* [PLAY "sinecube.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/sinecube/src/sinecube.bas) +* [LOAD "sinecube.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/sinecube/src/sinecube.bas) +* [RUN "sinecube.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/sinecube/src/sinecube.bas) +* [PLAY "sinecube.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/sinecube/src/sinecube.bas) ### File(s) diff --git a/samples/sort-demo/index.md b/samples/sort-demo/index.md index cc58d9f..c9c4f70 100644 --- a/samples/sort-demo/index.md +++ b/samples/sort-demo/index.md @@ -32,9 +32,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "sortdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/sort-demo/src/sortdemo.bas) -* [RUN "sortdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/sort-demo/src/sortdemo.bas) -* [PLAY "sortdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/sort-demo/src/sortdemo.bas) +* [LOAD "sortdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/sort-demo/src/sortdemo.bas) +* [RUN "sortdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/sort-demo/src/sortdemo.bas) +* [PLAY "sortdemo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/sort-demo/src/sortdemo.bas) ### File(s) diff --git a/samples/space64/index.md b/samples/space64/index.md index aeb613b..1abbba4 100644 --- a/samples/space64/index.md +++ b/samples/space64/index.md @@ -18,9 +18,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "space64.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/space64/src/space64.bas) -* [RUN "space64.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/space64/src/space64.bas) -* [PLAY "space64.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/space64/src/space64.bas) +* [LOAD "space64.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/space64/src/space64.bas) +* [RUN "space64.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/space64/src/space64.bas) +* [PLAY "space64.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/space64/src/space64.bas) ### File(s) diff --git a/samples/spiral.md b/samples/spiral.md new file mode 100644 index 0000000..173785c --- /dev/null +++ b/samples/spiral.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: SPIRAL + +**[Fibonacci Variations](fibonacci-variations/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [fibonacci](fibonacci.md), [spiral](spiral.md) + +The Fibonacci sequence is "seeded" with the golden ratio, but what if we change that? diff --git a/samples/splines/index.md b/samples/splines/index.md index 6995114..ee4acf6 100644 --- a/samples/splines/index.md +++ b/samples/splines/index.md @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "splines.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/splines/src/splines.bas) -* [RUN "splines.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/splines/src/splines.bas) -* [PLAY "splines.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/splines/src/splines.bas) +* [LOAD "splines.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/splines/src/splines.bas) +* [RUN "splines.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/splines/src/splines.bas) +* [PLAY "splines.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/splines/src/splines.bas) ### File(s) diff --git a/samples/starfield-torus/index.md b/samples/starfield-torus/index.md index 2727bdb..a60377c 100644 --- a/samples/starfield-torus/index.md +++ b/samples/starfield-torus/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "starfild.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/starfield-torus/src/starfild.bas) -* [RUN "starfild.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/starfield-torus/src/starfild.bas) -* [PLAY "starfild.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/starfield-torus/src/starfild.bas) +* [LOAD "starfild.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/starfield-torus/src/starfild.bas) +* [RUN "starfild.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/starfield-torus/src/starfild.bas) +* [PLAY "starfild.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/starfield-torus/src/starfild.bas) ### File(s) diff --git a/samples/starfield/index.md b/samples/starfield/index.md index 4024983..c37a899 100644 --- a/samples/starfield/index.md +++ b/samples/starfield/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "strfld.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/starfield/src/strfld.bas) -* [RUN "strfld.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/starfield/src/strfld.bas) -* [PLAY "strfld.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/starfield/src/strfld.bas) +* [LOAD "strfld.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/starfield/src/strfld.bas) +* [RUN "strfld.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/starfield/src/strfld.bas) +* [PLAY "strfld.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/starfield/src/strfld.bas) ### File(s) diff --git a/samples/stock-watcher/img/screenshot.png b/samples/stock-watcher/img/screenshot.png new file mode 100644 index 0000000..f2acd59 Binary files /dev/null and b/samples/stock-watcher/img/screenshot.png differ diff --git a/samples/stock-watcher/index.md b/samples/stock-watcher/index.md new file mode 100644 index 0000000..b6e4dae --- /dev/null +++ b/samples/stock-watcher/index.md @@ -0,0 +1,18 @@ +[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: STOCK WATCHER + +![screenshot.png](img/screenshot.png) + +### Description + +```text +Stock Watcher program. +``` + +### File(s) + +* [qb64stocks.bas](src/qb64stocks.bas) +* [qb64stocks.zip](src/qb64stocks.zip) + +🔗 [money](../money.md), [stocks](../stocks.md) diff --git a/samples/stock-watcher/src/qb64stocks.bas b/samples/stock-watcher/src/qb64stocks.bas new file mode 100644 index 0000000..5370407 --- /dev/null +++ b/samples/stock-watcher/src/qb64stocks.bas @@ -0,0 +1,868 @@ +'STOCK WATCHER v1.1 +'QB64 Version +$Resize:Smooth + +DefInt A-Z + +Dim Shared TOTALINVEST As Single +Dim Shared TOTALPROFIT As Single +Dim Shared Stocks + +Dim Shared S.Symbol(15) As String +Dim Shared S.Name(15) As String +Dim Shared S.Date(15) As String +Dim Shared S.CurVal(15) As Single +Dim Shared S.Shares(15) As Single +Dim Shared S.Cost(15) As Single +Dim Shared Changed% +Changed% = 0 + +Init + +Top: + +TOTALINVEST = 0 +TOTALPROFIT = 0 + +DrawScreen + +COL = 73 + +Color 9 + +For d = 1 To Stocks + If S.Symbol(d) <> "" Then + If COL = 73 Then COL = 9 Else COL = 73 + Color COL + '=== print info + Locate 6 + d, 2: Print S.Symbol(d); + Locate 6 + d, 6: Print Using "###.##"; S.CurVal(d); + Locate 6 + d, 13: Print Using "####"; S.Shares(d); + + 'original cost per share + Locate 6 + d, 18: Print Using "##.##"; S.Cost(d); + + 'compute original total cost.. + Dim c As Single + c = S.Cost(d) * S.Shares(d) + Cost$ = LTrim$(Str$(c)) + 'LOCATE 6 + d, 25: PRINT USING "####.##"; c; + TOTALINVEST = TOTALINVEST + c + + 'compute total worth now... + Dim CV As Single + CV = S.CurVal(d) * S.Shares(d) + Locate 6 + d, 24: Print Using "#####.##"; CV; + + + 'compute profit + Dim PROFIT As Single + PROFIT = (CV - c) + PROF$ = "$" + LTrim$(RTrim$(Str$(Int(PROFIT)))) 'FIXED <<<<<< + If PROFIT <= 0 Then Color 249 Else Color 250 + + 'Fix PROF$ so it don't go next line + Locate 6 + d, 34 + + 'PRINT "$"; + 'PRINT USING "####.##"; PROFIT; + + Print PROF$; + + Color 9 + + TOTALPROFIT = TOTALPROFIT + PROFIT + End If +Next + +Locate 21, 8: Print "TOTAL INVEST: $"; +Print Using "##,###.##"; TOTALINVEST; + +Locate 22, 8: Print "TOTAL PROFIT: "; + +If TOTALPROFIT >= 0 Then Color 250 Else Color 249 + +Print "$";: Print Using "##,###.##"; TOTALPROFIT; + +Color 9 + +Do + A$ = "": A$ = UCase$(Input$(1)) + Select Case A$ + Case "A": Call AddSTOCK + Case "D": Call DelStock + Case "E": Call EditSTOCK + Case "I": Call InfoStock + Case "M": Call MenuScreen + Case Chr$(27): Exit Do + End Select + GoTo Top: +Loop + + +If Changed% = 1 Then + Line (0, 40)-(320, 190), 0, BF + Locate 13, 10: Print "Save Changes? (Y/N)" + A$ = UCase$(Input$(1)) + If A$ = "Y" Then + Open "STOCKS.INI" For Output As 1 + + Print #1, Str$(Stocks) + For d = 1 To Stocks + Print #1, S.Symbol(d) + Print #1, S.Name(d) + Print #1, S.Date(d) + Print #1, S.CurVal(d) + Print #1, S.Shares(d) + Print #1, S.Cost(d) + Next + Close 1 + End If +End If + +Sub AddSTOCK + + Line (0, 40)-(320, 190), 0, BF + + If Stocks > 15 Then + Locate 7, 1: Print "STOCK LIMIT REACHED. 15 MAX!" + A$ = Input$(1): Exit Sub + End If + + Locate 7, 2: Print "ADD A STOCK..." + Locate 10, 2 + + Locate 9, 2: Input "STOCK SYMBOL : ", sym$ + If sym$ = "" Or Len(sym$) > 4 Then Exit Sub + + Locate 10, 2: Input "NAME OF STOCK : ", nam$ + If nam$ = "" Then Exit Sub + + Locate 11, 2: Input "PURCHASE DATE : ", dat$ + If dat$ = "" Then Exit Sub + + Dim CurVal As Single + + Locate 12, 2: Input "COST PER SHARE: ", CurVal + + Locate 13, 2: Input "TOTAL SHARES : ", shares + + Stocks = Stocks + 1 + + S.Symbol(Stocks) = sym$ + S.Name(Stocks) = nam$ + S.Date(Stocks) = dat$ + S.CurVal(Stocks) = CurVal + S.Shares(Stocks) = shares + S.Cost(Stocks) = CurVal + + Changed% = 1 + + A$ = Input$(1) + +End Sub + +Sub DelStock + + Line (0, 40)-(320, 190), 0, BF + + For d = 1 To Stocks + A$ = S.Symbol(d) + If Len(A$) = 2 Then A$ = A$ + " " + If Len(A$) = 1 Then A$ = A$ + " " + + If d > 9 Then + Locate 6 + d, 2 + Else + Locate 6 + d, 3 + End If + + spacr$ = " - " + If Len(S.Symbol(d)) = 3 Then spacr$ = " " + spacr$ + Print Str$(d); ") "; A$; spacr$; S.Name(d) + + Next + + + Locate 22, 3: Input "DELETE WHICH STOCK>", S + + If S < 1 Or S > Stocks Then Exit Sub + + S.Name(S) = "" 'erase name + + Dim tempS.Symbol(15) As String + Dim tempS.Name(15) As String + Dim tempS.Date(15) As String + Dim tempS.CurVal(15) As Single + Dim tempS.Shares(15) As Single + Dim tempS.Cost(15) As Single + + add = 0 + + For d = 1 To Stocks + If S.Name(d) <> "" Then + add = add + 1 + tempS.Symbol(add) = S.Symbol(d) + tempS.Name(add) = S.Name(d) + tempS.Date(add) = S.Date(d) + tempS.CurVal(add) = S.CurVal(d) + tempS.Shares(add) = S.Shares(d) + tempS.Cost(add) = S.Cost(d) + End If + Next + + Stocks = add + + For d = 1 To Stocks + S.Symbol(d) = tempS.Symbol(d) + S.Name(d) = tempS.Name(d) + S.Date(d) = tempS.Date(d) + S.CurVal(d) = tempS.CurVal(d) + S.Shares(d) = tempS.Shares(d) + S.Cost(d) = tempS.Cost(d) + Next + + Line (0, 40)-(320, 190), 0, BF + + Locate 7, 2: Print "Stock Deleted." + + A$ = Input$(1) + + Changed% = 1 + +End Sub + +Sub DrawScreen + + Screen 13 + _FullScreen _SquarePixels , _Smooth + Cls + + A$ = "" + + '=== Set pallette.... + A$ = "00000020000000200020200000002020002000202030303030373029323C" + A$ = A$ + "00040600000200000600000A00001000020400020600020A00020E000214" + A$ = A$ + "00040600040800040A00041600060A00060C00060E000612000614000621" + A$ = A$ + "00080C00080E00081000081200081A000A10000A12000A14000A16000A18" + A$ = A$ + "000C14000C16000C18000C1A000C21000C23000C27000E18000E1C000E23" + A$ = A$ + "000E27000E2B00102100102300102500102700122700122D00142900142B" + A$ = A$ + "00142D00163100182D00183502102302102702142902163502182F021C37" + A$ = A$ + "04142D04183506142908233708253D3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F" + A$ = A$ + "3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3E3C2828292020203F0000" + A$ = A$ + "003F003F3F0000003F3F003F003F3F3F3F3F" + c% = 0 + For i% = 1 To Len(A$) Step 6 + Out 968, c%: c% = c% + 1 + Out 969, Val("&H" + Mid$(A$, i%, 2)) + Out 969, Val("&H" + Mid$(A$, i% + 2, 2)) + Out 969, Val("&H" + Mid$(A$, i% + 4, 2)) + Next: A$ = "" + '================== + '=== Draw screen... + + PSet (0, 0): Draw "C37R2C25R1C21R1C25R1C15R1C21R1C40R1C37R1C21R1C15R1C21R1C15R1C0R2C15R3 " + Draw "C21R1C15R1C0R1C15R1C21R1C15R1C0R1C15R3C25R1C21R1C15R2C21R1C30R1C21R1 " + Draw "C0R2C15R1C21R1C15R1C0R2C15R1C22R1C15R1C16R1C18R2C23R1C42R1C23R1C18R2 " + Draw "C25R1C21R2C15R2C0R2C15R1C21R1C33R1C34R1C42R3C34R1C37R1C18R1C25R1C22R1 " + Draw "C35R1C40R1C22R1C15R1C22R1C40R1C35R1C15R1C0R2C21R1C33R1C21R1C15R1C25R1 " + Draw "C15R1C0R5C15R1C25R2C32R1C21R3C15R2C32R1C40R1C35R1C21R1C0R4C21R1C25R1 " + Draw "C15R1C0R3C21R1C33R1C25R1C0R2C15R1C32R1C37R1C21R2C33R1C25R2C15R2C25R1 " + Draw "C15R1C0R4C15R1C21R1C32R1C25R1C32R2C21R2C37R2C15R1C0R5C15R3C0R3C15R1 " + Draw "C25R1C15R1C0R3C15R1C37R2C25R1C32R1C21R1C0R2C15R1C18R1C21R2C32R1C25R1 " + Draw "C37R2C15R1C0R2C15R1C37R1C47R1C37R1C25R1C37R1C52R1C37R1C15R1C0R2C21R1 " + Draw "C40R1C37R1C15R1C0R2C15R1C25R1C47R1C40R1C37R2C21R1C15R1C32R3C15R2C25R1 " + Draw "C18R1C37R1C48R1C53R1C55R1C56R1C53R1C44R1C37R1C25R1C23R1C42R1C23R1C25R1 " + Draw "C33R1C37R1C40R1C44R1C49R1C40R1C25R1C18R1C25R1C33R1C25R1C21R1C23R1C34R2 " + Draw "C23R1C33R2C21R1C25R1C40R1C44R2C40R1C18R1C33R1C42R1C40R1C21R2C32R1C37R1 " + Draw "C48R1C40R1C32R2C21R1C0R3C21R1C40R1C42R1C21R1C16R1C32R1C37R1C40R1C35R1 " + Draw "C18R1C35R1C40R1C37R1C40R1C48R2C40R1C32R1C33R1C37R3C33R1C32R1C40R1C48R3 " + Draw "C52R1C53R2C48R1C37R1C40R1C48R1C53R2C49R1C53R2C49R1C44R1C49R1C51R1C56R1 " + Draw "C49R1C40R1C37R1C48R1C59R1C48R1" + PSet (0, 1): Draw "C37R3C33R1C32R1C21R1C33R1C40R1C37R1C25R1C33R2C25R1C21R1C15R1C25R2C15R2 " + Draw "C0R2C15R1C21R1C15R2C25R1C21R1C15R1C21R1C25R3C21R1C25R2C15R8C16R1C15R2 " + Draw "C18R2C22R1C33R1C18R1C22R1C21R5C25R1C21R1C15R1C21R3C18R1C33R2C37R1C33R1 " + Draw "C22R1C25R2C22R1C33R1C34R1C35R1C21R1C18R1C33R1C22R1C21R2C15R1C21R1C25R1 " + Draw "C15R1C0R1C15R2C0R6C15R1C25R1C37R1C32R1C15R2C0R2C15R1C21R3C15R1C0R2 " + Draw "C15R1C21R2C0R4C21R1C40R1C35R1C21R1C15R3C21R3C18R1C25R1C15R1C0R2C15R1 " + Draw "C0R4C15R1C21R1C25R1C32R1C25R1C21R2C15R1C21R2C15R1C0R5C21R4C15R1C0R2 " + Draw "C15R1C21R1C15R1C0R1C15R1C0R2C15R2C21R1C32R1C21R1C15R1C0R2C21R3C25R1 " + Draw "C21R3C0R2C15R2C21R1C32R1C21R1C15R1C21R1C32R1C21R1C0R3C15R1C32R1C21R1 " + Draw "C0R2C15R1C32R1C35R1C37R2C32R1C25R1C15R1C0R1C21R1C32R1C25R1C15R2C21R2 " + Draw "C18R1C37R1C34R1C44R1C53R1C49R1C23R1C22R2C33R1C37R1C25R1C16R1C21R1C33R3 " + Draw "C37R1C22R1C15R2C22R1C18R1C25R1C16R1C15R1C22R1C18R1C23R2C22R1C21R1C33R1 " + Draw "C18R1C33R1C40R2C37R3C25R1C15R2C25R1C37R1C40R1C32R1C21R1C15R1C0R3C15R2 " + Draw "C25R1C33R1C21R1C0R1C25R1C40R1C37R1C21R1C15R1C16R1C25R1C32R1C33R1C25R1 " + Draw "C21R2C15R1C21R1C32R1C33R1C40R1C33R1C21R3C25R1C32R1C37R1C40R1C48R1C53R1 " + Draw "C48R1C40R1C33R1C37R1C42R1C40R1C33R5C42R2C18R1C21R1C37R1C53R1C59R1C53R1" + PSet (0, 2): Draw "C37R1C32R1C33R3C25R1C32R1C37R3C33R1C21R3C15R1C21R1C33R1C21R1C0R1C15R2 " + Draw "C21R2C15R1C21R2C15R1C0R1C15R1C25R1C32R1C25R1C15R2C21R1C15R3C21R1C18R1 " + Draw "C22R1C16R2C15R2C0R1C15R1C16R2C22R1C16R1C15R1C21R3C15R2C21R8C25R1C37R1 " + Draw "C33R1C22R1C18R1C37R1C40R2C34R1C35R1C21R2C22R1C25R1C33R1C37R1C33R1C21R2 " + Draw "C15R1C0R1C15R1C21R1C15R1C0R4C15R2C32R1C40R1C32R1C15R1C0R1C15R1C0R2 " + Draw "C15R3C0R4C15R3C0R2C15R1C21R1C40R1C35R1C21R2C15R1C0R2C15R2C21R2C15R2 " + Draw "C0R6C15R1C21R2C25R1C21R2C15R5C0R2C15R1C0R1C15R1C21R2C15R2C0R3C15R1 " + Draw "C21R1C15R2C21R1C15R1C0R1C15R1C0R1C21R1C32R1C25R1C21R1C15R2C21R4C25R1 " + Draw "C32R1C15R1C0R1C15R1C21R1C15R1C0R1C15R2C0R2C15R1C0R5C15R1C21R2C15R2 " + Draw "C25R1C32R1C25R3C21R1C15R1C0R1C15R1C25R2C15R1C25R1C32R1C25R2C37R1C33R1 " + Draw "C23R1C34R1C42R1C23R1C18R1C33R1C40R2C37R1C22R1C16R1C25R2C16R1C15R1C0R2 " + Draw "C21R1C18R1C33R1C18R1C15R1C0R1C15R1C18R1C23R1C33R1C15R2C18R1C15R1C21R1 " + Draw "C40R1C34R1C18R1C21R1C15R2C21R1C25R1C15R2C25R1C33R1C21R1C0R1C15R1C0R1 " + Draw "C15R1C21R4C0R2C21R1C37R2C21R1C15R3C21R1C25R1C15R1C0R3C21R2C25R1C40R1 " + Draw "C37R1C15R1C0R1C15R1C21R1C37R1C32R1C25R1C37R1C48R1C42R1C40R1C37R1C32R1 " + Draw "C37R1C33R1C16R1C21R1C33R1C18R1C21R2C25R1C15R1C21R1C40R1C53R1C56R1C48R1" + PSet (0, 3): Draw "C33R1C25R1C32R1C25R1C21R3C33R3C21R1C15R4C21R1C32R1C21R1C15R1C21R2C15R3 " + Draw "C21R1C15R1C0R3C15R3C0R1C15R4C21R1C33R1C37R1C18R1C16R1C15R4C16R1C17R1 " + Draw "C33R1C32R1C15R1C16R1C22R1C15R1C0R3C15R1C21R6C22R1C37R1C48R1C37R1C40R1 " + Draw "C48R2C29R1C34R1C40R1C35R1C0R1C15R1C23R1C48R1C23R1C42R1C37R1C15R1C21R1 " + Draw "C0R2C15R1C22R1C21R1C0R3C15R1C21R1C15R1C25R1C48R1C37R1C21R3C15R2C21R1 " + Draw "C15R1C0R6C15R1C21R1C15R1C21R1C32R1C23R1C37R1C15R1C0R9C15R1C21R1C15R1 " + Draw "C0R5C15R1C21R3C15R1C0R1C15R1C21R1C15R2C25R1C21R2C37R1C15R1C0R1C15R1 " + Draw "C0R7C15R3C22R1C21R1C15R1C21R1C15R1C21R1C32R1C15R2C21R1C40R1C37R1C21R2 " + Draw "C32R1C40R1C35R1C15R2C25R1C15R1C0R2C21R1C32R1C15R1C0R5C15R1C0R1C15R1 " + Draw "C18R1C40R1C18R1C15R1C0R3C15R3C0R2C15R1C32R1C15R1C16R1C42R1C40R1C21R1 " + Draw "C25R1C33R1C34R2C21R2C40R1C34R1C29R2C40R1C42R1C23R1C25R1C33R1C21R1C0R2 " + Draw "C16R1C32R1C42R1C37R2C18R1C21R1C15R1C16R1C22R1C21R1C0R2C15R1C22R1C0R1 " + Draw "C15R1C34R1C23R1C0R3C15R1C32R1C21R1C0R2C21R1C37R1C21R2C25R1C15R1C0R1 " + Draw "C16R1C25R1C18R1C21R1C0R2C15R1C25R1C18R1C25R1C21R2C15R2C21R1C15R1C0R2 " + Draw "C21R1C32R1C21R2C33R1C25R1C0R1C15R1C21R1C25R1C40R2C25R3C21R1C18R1C33R1 " + Draw "C21R1C16R2C0R1C15R1C25R1C21R1C0R1C21R1C33R1C21R2C40R3C32R1" + PSet (0, 4): Draw "C21R2C25R1C21R1C15R2C21R2C15R2C0R1C15R1C21R1C15R2C25R1C32R1C25R1C15R2 " + Draw "C21R1C15R1C0R1C15R1C25R1C21R1C15R1C0R5C15R2C21R1C15R2C18R1C23R1C22R1 " + Draw "C16R1C15R1C0R2C15R1C22R1C23R1C18R1C74R9C25R3C22R1C74R6C73R1C74R2C73R5 " + Draw "C74R1C33R1C50R1C48R1C18R1C33R1C15R1C74R8C16R2C15R3C21R1C40R1C37R1C32R1 " + Draw "C25R1C21R1C74R8C0R3C15R1C21R1C74R4C0R6C74R2C16R2C15R2C0R7C15R2C74R5 " + Draw "C0R1C15R1C32R1C25R1C21R1C18R1C15R2C0R3C74R3C16R1C0R1C16R1C33R3C18R1 " + Draw "C21R2C0R2C15R1C16R1C74R3C15R1C0R1C21R1C32R1C21R1C0R2C37R1C42R1C74R3 " + Draw "C21R1C32R1C0R3C15R1C0R1C15R1C21R1C15R1C74R15C0R1C25R1C40R1C21R1C15R1 " + Draw "C25R1C74R6C73R2C34R1C23R1C18R1C22R1C33R1C74R4C37R1C47R1C40R1C37R1C74R2 " + Draw "C18R1C74R10C15R1C74R10C21R2C15R1C0R3C15R1C25R1C18R1C25R1C15R1C0R1C15R1 " + Draw "C21R4C15R2C21R1C25R1C15R1C0R1C15R1C21R1C32R1C21R1C0R1C15R6C25R1C37R2 " + Draw "C25R1C15R1C0R1C15R1C21R1C15R1C0R1C15R1C0R1C15R1C25R1C21R1C0R1C21R1 " + Draw "C33R1C21R2C40R1C37R1C21R2" + PSet (0, 5): Draw "C15R1C21R1C15R5C0R5C15R1C0R2C15R8C21R1C25R1C15R1C0R5C15R1C21R4C15R1 " + Draw "C22R1C18R1C16R3C15R1C0R1C16R1C18R1C29R1C74R2C68R1C0R1C15R1C0R4C68R2 " + Draw "C25R1C18R1C40R1C74R1C68R14C18R1C48R1C35R1C18R1C74R3C68R3C0R2C15R1C68R2 " + Draw "C74R1C22R2C21R1C15R3C0R1C74R3C68R8C74R1C0R1C15R1C21R1C74R1C68R3C0R5 " + Draw "C74R2C0R2C32R1C15R1C0R3C15R1C0R6C74R1C68R4C0R1C16R1C25R1C15R1C0R3 " + Draw "C21R1C15R1C0R2C74R1C68R3C15R1C25R1C47R1C37R1C21R1C0R2C21R1C0R2C15R1 " + Draw "C18R1C74R1C68R1C0R8C25R1C32R1C74R1C68R3C15R1C0R2C21R1C35R1C15R2C25R1 " + Draw "C21R1C74R1C68R14C0R1C32R1C15R1C0R1C74R3C68R8C73R1C21R1C15R1C21R1C74R1 " + Draw "C68R3C0R1C25R1C37R1C33R1C74R1C68R1C15R1C74R1C68R9C0R1C74R1C68R4C0R4 " + Draw "C68R2C0R6C15R3C0R3C15R1C21R1C25R1C21R1C0R1C15R1C25R2C21R1C25R2C21R2 " + Draw "C15R1C0R2C15R1C21R1C15R1C0R3C25R1C37R1C25R1C0R2C25R1C37R1C25R1C21R1 " + Draw "C25R1C21R1C15R1C21R1C25R1C16R1C21R1C25R1C15R1C21R1C42R1C37R1C25R1C33R1" + PSet (0, 6): Draw "C25R1C21R1C15R3C0R9C15R8C0R1C15R1C21R1C15R1C0R2C15R1C0R2C21R1C25R1 " + Draw "C15R3C0R1C15R1C22R1C16R3C15R1C16R1C22R1C18R1C74R2C68R2C0R1C25R1C18R1 " + Draw "C42R1C35R1C15R1C21R1C68R2C25R1C18R1C16R1C0R3C68R7C19R1C18R1C15R1C16R2 " + Draw "C18R1C21R1C74R2C68R5C0R2C21R1C33R1C25R1C68R2C30R1C21R1C0R2C15R1C74R2 " + Draw "C68R4C0R6C68R2C32R2C74R1C68R3C0R4C74R2C0R2C15R2C0R3C15R1C21R1C15R2 " + Draw "C0R4C74R1C68R5C15R2C0R4C15R1C0R2C74R2C68R3C0R1C22R1C21R1C0R3C15R2 " + Draw "C21R1C15R2C74R2C68R1C0R6C15R1C0R2C74R2C68R3C0R2C15R1C25R1C37R1C21R1 " + Draw "C15R1C35R1C32R1C0R4C68R7C0R5C15R1C0R1C74R2C68R4C0R5C18R1C68R2C21R1 " + Draw "C16R1C74R1C68R3C0R1C25R1C37R2C74R1C68R1C0R1C74R1C68R5C0R5C74R1C68R4 " + Draw "C0R1C21R1C15R1C0R2C68R2C0R6C15R1C0R2C15R1C0R2C21R1C18R1C21R1C0R1 " + Draw "C21R3C18R1C37R1C32R1C21R2C15R1C0R2C15R1C21R1C15R1C0R2C21R1C32R1C37R1 " + Draw "C21R1C0R1C15R1C37R1C53R1C42R1C18R1C25R1C18R1C21R1C15R1C16R1C18R1C33R1 " + Draw "C23R1C25R1C18R1C40R1C37R1C25R1C33R1" + PSet (0, 7): Draw "C25R1C32R1C33R1C21R2C15R1C0R7C15R1C21R3C15R8C0R2C15R1C25R1C21R1C15R1 " + Draw "C21R1C15R1C0R4C15R1C21R1C22R1C16R1C15R2C18R2C22R1C74R1C68R4C33R1C42R1 " + Draw "C35R1C0R2C15R1C21R1C68R2C21R2C22R1C15R1C21R1C74R1C68R6C15R1C32R1C21R1 " + Draw "C0R1C16R1C35R1C74R2C68R6C0R2C16R1C25R1C37R1C33R1C68R2C0R2C15R1C74R2 " + Draw "C68R5C0R1C15R1C25R1C21R1C0R2C15R1C68R2C18R1C74R1C68R3C0R3C74R2C0R9 " + Draw "C15R2C21R1C15R1C0R4C68R5C0R6C15R1C0R2C74R1C68R5C0R3C15R1C22R1C21R1 " + Draw "C15R1C33R1C18R1C15R1C74R1C68R1C0R6C15R1C21R1C15R1C0R1C74R1C68R5C15R1 " + Draw "C32R1C25R1C21R2C15R2C0R5C74R1C68R6C0R4C21R2C74R2C68R5C0R3C15R1C21R1 " + Draw "C33R1C15R1C68R2C0R1C74R1C68R3C0R1C32R1C25R1C37R1C74R1C68R1C0R1C74R1 " + Draw "C68R5C0R1C21R1C22R2C15R1C74R1C68R4C0R6C68R2C0R4C15R1C21R1C15R2C21R1 " + Draw "C15R1C0R1C16R2C0R1C15R1C21R1C15R1C0R1C21R1C25R2C21R4C0R1C15R1C21R1 " + Draw "C15R1C0R1C15R1C32R1C37R1C25R1C21R1C0R1C15R1C33R1C48R1C42R1C23R1C25R2 " + Draw "C18R1C21R1C16R1C33R3C37R1C40R1C37R2C25R2" + PSet (0, 8): Draw "C25R1C33R1C32R1C21R2C15R1C0R2C15R1C0R4C15R1C21R1C25R1C18R1C15R1C0R2 " + Draw "C15R1C21R2C15R1C0R3C15R1C32R2C21R1C15R1C0R5C15R1C21R1C18R1C22R1C15R1 " + Draw "C16R1C33R1C18R1C21R1C74R1C68R5C37R1C0R4C15R1C0R1C68R1C0R1C37R2C25R1 " + Draw "C21R1C74R1C68R6C0R1C33R1C37R1C0R1C21R1C74R2C68R7C0R1C15R1C25R1C22R1 " + Draw "C25R1C32R1C25R1C68R2C15R2C74R1C68R6C0R2C21R2C0R3C15R1C0R2C74R1C68R3 " + Draw "C0R2C74R2C0R7C15R1C0R2C15R3C0R5C74R1C68R5C15R3C0R1C15R1C21R1C15R1 " + Draw "C74R2C68R5C0R3C16R1C22R1C21R1C15R2C0R1C74R2C68R1C0R1C15R1C0R3C15R1 " + Draw "C21R1C25R1C21R1C74R2C68R5C0R1C21R4C0R5C21R2C74R1C68R6C0R1C15R1C0R1 " + Draw "C15R1C35R1C32R1C74R1C68R6C0R4C15R1C21R1C0R4C74R1C68R3C0R3C25R1C74R1 " + Draw "C68R1C0R1C74R1C68R5C0R1C15R1C0R3C74R1C68R4C0R6C15R1C68R2C0R4C15R1 " + Draw "C0R2C15R1C0R1C15R1C21R1C15R1C0R2C15R1C0R4C21R2C25R1C33R1C32R1C15R1 " + Draw "C0R1C21R4C32R2C25R1C32R1C21R1C15R1C25R2C21R1C18R1C37R1C18R2C33R1C21R1 " + Draw "C16R2C15R1C25R1C33R1C18R1C33R1C25R2" + PSet (0, 9): Draw "C33R1C25R1C15R4C0R1C15R1C21R1C15R1C0R4C15R2C21R1C15R1C0R2C15R3C0R5 " + Draw "C21R1C32R1C25R1C15R1C0R3C15R1C0R2C15R1C21R3C22R1C18R1C25R1C21R1C74R1 " + Draw "C68R6C0R2C16R2C15R2C21R1C15R1C40R1C25R2C22R1C74R1C68R6C0R1C40R1C37R1 " + Draw "C0R1C21R1C74R1C68R8C0R2C21R2C25R1C32R2C74R1C68R1C0R1C74R2C68R6C0R1 " + Draw "C15R2C0R7C74R1C68R3C0R1C74R2C0R7C15R1C21R1C15R2C25R1C15R1C0R5C15R1 " + Draw "C21R1C68R5C0R1C21R2C15R1C0R1C15R1C0R1C74R1C68R1C0R1C68R5C15R1C25R2 " + Draw "C15R1C0R4C74R1C68R1C0R2C40R1C15R1C0R1C15R1C21R2C32R1C40R1C74R1C68R7 " + Draw "C0R2C15R1C21R1C0R3C15R1C21R1C37R1C18R1C74R1C68R6C15R2C0R1C15R1C35R1 " + Draw "C74R2C68R6C0R3C17R1C18R2C16R2C22R1C16R1C74R1C68R3C0R3C33R1C74R1C68R1 " + Draw "C0R1C74R1C68R5C0R1C22R1C0R3C74R1C68R4C0R5C15R1C25R1C74R1C68R1C0R10 " + Draw "C15R1C0R8C21R1C37R2C32R1C25R1C15R1C0R1C15R1C32R2C21R1C32R2C25R1C32R1 " + Draw "C21R4C0R1C21R1C37R2C23R1C33R1C21R1C0R4C15R4C15R1" + PSet (0, 10): Draw "C21R2C15R2C21R1C15R1C0R2C21R1C25R1C15R1C0R5C15R1C0R2C15R3C0R5C15R2 " + Draw "C21R3C15R1C0R1C15R1C21R1C15R1C0R1C15R2C21R1C22R1C18R1C22R1C15R2C74R1 " + Draw "C68R7C25R2C22R1C21R2C18R1C40R1C16R1C0R1C25R1C21R1C74R1C68R6C0R1C33R1 " + Draw "C37R1C16R1C21R1C74R1C68R8C0R2C15R1C21R1C25R1C23R1C22R1C74R1C68R1C0R1 " + Draw "C74R1C68R7C0R1C21R1C15R1C0R7C74R1C68R4C74R1C0R4C15R5C21R1C15R1C21R1 " + Draw "C33R1C21R1C0R5C16R1C15R1C74R1C68R5C21R2C15R1C0R2C74R2C68R1C0R1C18R1 " + Draw "C68R4C0R1C23R1C21R1C0R4C74R2C68R1C0R1C25R2C0R3C15R1C0R1C21R1C74R2 " + Draw "C68R7C0R3C15R2C0R1C15R1C21R1C15R2C0R1C74R1C68R6C15R1C0R2C21R1C37R1 " + Draw "C74R1C68R7C0R1C15R1C16R1C37R1C40R1C25R1C21R4C74R1C68R4C74R4C68R1C0R1 " + Draw "C74R1C68R6C74R3C15R1C74R1C68R4C0R6C15R1C74R1C68R1C0R9C15R1C0R6C15R1 " + Draw "C0R2C21R1C40R1C32R1C21R2C15R1C0R1C21R1C25R1C32R3C21R1C15R2C21R1C25R1 " + Draw "C32R1C25R1C15R1C0R1C21R1C25R1C23R2C21R1C15R1C0R3C15R1C0R3C0R1" + PSet (0, 11): Draw "C15R5C0R3C15R1C25R1C21R1C0R2C15R1C0R6C15R1C0R5C15R1C25R2C15R1C21R1 " + Draw "C25R1C21R1C15R2C21R1C15R2C22R2C21R1C22R3C16R1C15R1C74R1C68R8C21R3C15R1 " + Draw "C21R1C25R1C16R1C22R1C33R1C22R1C74R1C68R6C0R1C18R1C37R1C22R2C74R1C68R8 " + Draw "C0R2C15R1C21R1C25R1C32R1C21R1C74R1C68R1C0R1C74R1C68R7C0R1C15R1C0R8 " + Draw "C74R1C68R3C0R1C68R2C0R2C25R2C21R7C25R1C15R1C0R3C15R1C16R1C21R1C15R1 " + Draw "C0R1C68R5C0R1C18R1C22R1C15R1C0R1C74R1C68R1C0R2C15R1C74R1C68R4C18R1 " + Draw "C15R1C0R4C74R1C68R1C0R10C74R1C68R1C0R2C68R6C0R2C15R1C21R1C15R1C0R1 " + Draw "C15R1C0R3C74R1C68R6C0R2C21R1C15R1C25R1C74R1C68R7C0R1C18R1C22R1C21R1 " + Draw "C22R1C16R1C15R1C0R3C74R1C68R9C0R1C74R1C68R9C0R1C74R1C68R4C0R1C21R2 " + Draw "C0R4C74R1C68R1C0R1C15R1C0R4C15R1C0R1C15R1C21R1C15R1C0R3C21R1C25R2 " + Draw "C15R1C0R1C21R1C32R1C21R1C15R1C21R3C25R1C21R1C32R1C37R1C32R1C21R1C15R1 " + Draw "C0R2C21R1C32R1C21R1C15R3C21R2C16R1C21R2C15R1C0R1C15R1C25R1C21R1C0R3" + PSet (0, 12): Draw "C15R3C21R1C15R1C0R1C15R1C0R1C15R1C21R2C15R2C21R1C15R1C0R2C15R2C0R2 " + Draw "C15R3C0R2C15R1C25R1C21R1C15R4C0R2C15R1C0R1C15R1C18R1C22R1C16R2C15R1 " + Draw "C16R1C22R1C16R1C0R1C68R9C21R2C0R2C21R1C25R2C22R1C25R1C74R1C68R6C0R1 " + Draw "C22R1C21R1C15R1C21R1C74R1C68R8C0R2C15R1C22R1C18R1C25R1C16R1C74R1C68R1 " + Draw "C0R1C74R1C68R7C0R5C15R1C0R4C74R1C68R3C0R1C74R1C68R1C0R1C15R1C25R1 " + Draw "C21R3C15R6C0R3C15R1C21R1C15R2C0R2C74R1C68R5C18R1C15R1C0R1C74R2C68R1 " + Draw "C0R2C15R1C0R1C68R4C0R2C21R1C15R1C0R1C74R2C68R1C0R9C74R2C68R1C0R2 " + Draw "C74R1C68R5C0R3C15R1C0R6C74R1C68R6C0R2C15R1C0R1C15R1C74R1C68R7C0R1 " + Draw "C18R1C22R1C15R1C16R1C15R1C0R4C74R1C68R3C15R1C0R3C68R2C0R1C74R1C68R5 " + Draw "C0R5C74R1C68R4C0R1C35R1C33R1C15R1C0R3C74R1C68R1C0R4C15R1C21R2C15R1 " + Draw "C0R1C15R1C0R3C15R1C18R1C32R1C21R1C15R4C0R1C15R1C21R2C25R1C21R1C15R1 " + Draw "C21R4C25R1C21R1C15R1C21R2C0R1C15R1C25R1C32R1C25R1C21R1C15R1C21R3C15R2 " + Draw "C21R1C25R1C15R1C0R1C15R1" + PSet (0, 13): Draw "C15R5C21R2C15R2C21R2C15R1C0R1C15R1C0R2C15R1C21R2C15R2C21R2C15R2C0R2 " + Draw "C15R1C0R10C15R1C16R1C21R1C22R1C16R1C15R1C16R2C0R2C68R9C15R1C0R3C15R2 " + Draw "C21R1C22R1C74R1C68R6C0R1C21R2C18R2C74R1C68R8C0R2C15R1C32R1C18R1C21R1 " + Draw "C15R1C74R1C68R1C0R1C74R1C68R7C0R4C15R1C21R1C15R1C0R3C74R1C68R3C0R2 " + Draw "C68R2C0R1C15R2C25R2C0R10C15R1C0R5C68R5C0R3C74R1C68R1C0R2C15R1C21R1 " + Draw "C15R1C74R1C68R4C0R1C15R1C0R2C74R1C68R1C0R2C21R1C0R7C74R1C68R1C0R4 " + Draw "C68R6C0R9C74R1C68R6C0R2C15R1C0R1C15R1C74R1C68R7C0R1C15R1C21R2C22R1 " + Draw "C21R1C0R1C15R1C0R2C74R1C68R3C0R1C15R2C21R1C74R1C68R1C0R1C74R1C68R5 " + Draw "C0R1C25R1C22R1C32R1C21R1C74R1C68R4C0R1C15R1C0R4C74R2C0R4C15R1C21R2 " + Draw "C15R1C0R7C21R2C0R1C15R1C21R1C15R1C0R3C15R3C0R2C21R4C32R1C37R1C32R1 " + Draw "C25R1C15R1C0R2C25R1C37R1C25R1C21R3C25R1C18R2C21R1C15R2C0R1C15R1C21R1" + PSet (0, 14): Draw "C15R1C0R2C15R1C21R1C25R1C15R1C0R1C15R1C21R2C15R1C0R3C15R3C21R1C15R1 " + Draw "C21R1C25R1C15R2C0R6C15R1C0R2C15R1C0R5C15R1C21R1C22R1C16R1C15R2C16R1 " + Draw "C0R2C15R1C68R9C0R1C15R1C0R2C15R1C23R1C18R1C74R1C68R6C0R1C21R2C23R1 " + Draw "C37R1C74R1C68R8C0R1C15R1C16R1C21R1C15R1C21R2C74R1C68R1C0R1C74R1C68R7 " + Draw "C0R1C15R6C0R3C74R1C68R3C0R1C15R1C74R1C68R1C0R3C15R2C0R16C74R1C68R5 " + Draw "C0R1C74R2C68R1C0R3C15R1C0R2C68R4C0R2C15R1C74R2C68R1C0R1C21R2C0R6 " + Draw "C74R2C68R1C0R1C21R1C0R2C74R1C68R5C0R5C15R1C0R2C15R1C74R1C68R6C0R1 " + Draw "C21R2C15R1C0R1C74R1C68R7C0R1C15R1C21R1C16R1C21R1C25R1C21R1C22R1C16R1 " + Draw "C15R1C74R1C68R3C0R3C33R1C74R1C68R1C0R1C74R1C68R5C0R1C15R1C22R1C37R1 " + Draw "C18R1C74R1C68R4C0R1C15R2C0R2C74R2C0R2C15R1C0R3C15R1C0R2C15R1C0R10 " + Draw "C15R2C21R2C0R5C15R1C32R1C37R2C32R4C21R1C0R2C15R1C21R1C18R1C21R1C15R1 " + Draw "C21R1C16R1C21R1C18R1C33R1C37R1C21R1C0R3C15R1" + PSet (0, 15): Draw "C0R4C15R2C0R2C15R1C21R2C0R3C15R1C21R1C15R4C21R2C15R1C0R6C15R1C21R1 " + Draw "C15R4C0R1C15R7C0R1C15R1C16R1C0R1C15R1C16R2C68R9C37R1C15R1C0R1C25R1 " + Draw "C40R1C21R1C74R1C68R6C0R1C21R3C15R1C74R1C68R8C0R1C21R1C22R2C21R1C25R1 " + Draw "C21R1C74R1C68R1C0R1C74R1C68R7C0R1C21R3C15R2C21R1C15R1C0R2C74R1C68R3 " + Draw "C0R2C15R1C68R2C15R1C0R5C15R1C0R14C68R5C0R1C74R1C68R1C0R6C15R1C74R1 " + Draw "C68R4C15R1C21R1C74R1C68R1C0R10C74R1C68R1C0R1C15R1C37R1C21R1C0R2C68R6 " + Draw "C0R3C15R1C21R1C15R2C32R1C74R1C68R6C0R1C15R2C0R2C74R1C68R7C0R2C16R2 " + Draw "C0R4C16R1C21R1C74R1C68R3C0R3C16R1C74R1C68R1C0R1C74R1C68R5C0R1C15R1 " + Draw "C22R2C0R1C74R1C68R5C74R5C0R2C15R1C0R6C15R1C21R1C15R1C0R1C15R1C0R6 " + Draw "C15R1C0R1C21R1C37R2C21R1C0R5C21R2C32R1C37R1C25R1C15R2C0R2C15R1C21R1 " + Draw "C16R1C15R1C0R1C15R1C21R1C16R3C21R1C18R1C21R1C0R3C0R1" + PSet (0, 16): Draw "C0R8C15R2C0R5C15R1C0R2C15R6C0R4C15R1C21R1C15R1C0R2C15R1C0R1C15R1 " + Draw "C16R2C15R2C0R5C15R1C0R2C15R1C0R2C68R9C21R1C0R1C16R1C22R1C0R1C74R1 " + Draw "C68R6C0R1C15R1C21R1C22R1C21R1C74R1C68R8C0R1C21R1C25R1C37R2C21R1C0R1 " + Draw "C74R1C68R1C0R1C74R1C68R7C0R1C15R1C0R4C15R2C0R2C74R1C68R3C0R3C74R1 " + Draw "C68R1C0R1C15R1C0R3C15R1C21R1C15R1C0R13C74R1C68R5C74R1C68R1C0R5C15R1 " + Draw "C21R1C15R1C68R4C0R1C74R2C68R1C0R9C74R2C68R2C74R6C68R5C0R4C15R3C35R1 " + Draw "C74R1C68R6C0R5C74R1C68R7C0R1C25R1C18R1C22R1C0R6C74R1C68R3C0R4C74R1 " + Draw "C68R1C0R1C74R1C68R5C0R2C15R1C0R2C74R1C68R4C0R2C68R2C0R12C15R1C0R1 " + Draw "C15R1C21R1C15R1C0R4C15R1C21R1C15R1C21R1C32R2C25R1C15R1C0R6C21R1C32R1 " + Draw "C21R1C0R1C15R5C0R2C15R1C16R1C21R3C15R1C0R1C15R1C0R4C0R1" + PSet (0, 17): Draw "C0R7C15R1C21R1C15R1C0R3C15R1C0R7C15R2C0R5C15R2C0R6C15R3C0R7C15R1 " + Draw "C16R1C0R4C68R8C0R2C15R1C21R1C0R1C74R1C68R6C0R1C15R1C22R1C18R2C74R1 " + Draw "C68R8C0R1C21R2C25R1C15R1C0R2C74R1C68R1C0R2C68R7C0R1C15R1C0R4C15R1 " + Draw "C74R2C0R1C74R1C68R3C0R4C68R2C0R5C15R1C0R15C68R6C0R7C15R1C0R1C74R1 " + Draw "C68R4C74R1C68R1C0R2C15R1C0R7C74R1C68R1C0R8C68R6C0R3C15R1C21R2C25R1 " + Draw "C74R1C68R6C0R4C15R1C18R1C68R7C15R1C40R2C25R1C0R3C74R2C0R1C74R1C68R3 " + Draw "C0R1C17R1C0R1C15R1C74R1C68R1C0R1C74R1C68R5C0R5C74R1C68R4C0R3C68R2 " + Draw "C0R10C21R2C0R1C15R1C21R1C15R1C0R5C15R1C0R2C15R5C0R6C15R1C0R1C15R1 " + Draw "C25R1C18R1C25R1C15R1C0R2C15R1C25R1C18R2C25R1C21R1C16R1C0R2C15R1C0R3 " + Draw "C0R1" + PSet (0, 18): Draw "C0R8C15R1C21R1C15R1C0R1C15R1C21R1C15R1C0R5C15R3C0R4C15R3C0R15C15R1 " + Draw "C74R1C33R1C16R1C15R1C0R3C68R7C0R1C15R2C22R1C21R1C74R1C68R6C0R1C15R1 " + Draw "C23R1C37R1C18R1C21R1C68R8C0R1C21R1C15R1C0R3C74R2C0R3C74R1C68R6C0R1 " + Draw "C21R1C15R1C0R3C74R2C0R2C74R1C68R3C0R4C74R1C68R1C0R11C15R3C0R7C74R1 " + Draw "C68R5C0R9C15R1C68R6C0R1C15R1C0R7C74R2C68R1C0R9C68R5C0R4C15R1C0R2 " + Draw "C74R1C68R6C0R5C15R1C74R1C68R6C0R1C15R1C16R2C0R2C74R2C0R2C74R1C68R3 " + Draw "C0R1C33R1C0R2C74R1C68R1C0R1C74R1C68R5C0R5C74R1C68R4C0R4C68R2C0R8 " + Draw "C15R1C18R2C15R2C21R1C15R1C0R4C15R1C0R4C21R2C25R1C32R1C21R1C0R3C15R1 " + Draw "C0R4C21R1C18R1C21R1C0R3C16R1C25R1C33R1C37R1C18R1C21R2C15R2C25R1C21R1 " + Draw "C0R3" + PSet (0, 19): Draw "C0R9C15R2C0R2C15R1C0R7C15R1C0R2C15R1C0R3C15R1C0R8C15R1C0R7C15R1 " + Draw "C74R1C68R1C21R2C15R1C0R1C16R2C68R6C0R1C22R1C21R1C22R1C18R1C74R1C68R6 " + Draw "C0R1C15R1C23R1C33R1C0R3C68R7C0R1C22R1C21R1C0R2C74R2C0R3C15R1C25R1 " + Draw "C68R6C0R1C15R1C0R3C74R2C0R3C74R1C68R3C0R5C68R2C0R9C15R1C21R3C15R1 " + Draw "C0R7C68R4C0R9C15R1C21R1C74R1C68R4C0R10C74R1C68R1C0R4C15R1C0R3C15R1 " + Draw "C21R1C74R1C68R5C0R6C74R1C68R6C0R3C15R1C0R3C68R6C0R5C74R2C0R2C15R1 " + Draw "C74R1C68R3C0R1C21R1C0R2C74R1C68R1C0R1C74R1C68R5C0R2C15R1C0R2C74R1 " + Draw "C68R4C0R1C15R1C0R3C68R2C0R8C21R2C0R2C15R1C0R3C15R1C16R1C25R1C21R1 " + Draw "C0R2C15R1C32R1C37R1C33R1C32R1C25R1C15R1C0R1C15R1C25R1C21R1C0R4C15R1 " + Draw "C0R3C25R1C33R1C21R1C25R1C23R1C25R1C16R1C21R1C15R1C0R1C21R1C25R1C15R1 " + Draw "C0R2" + PSet (0, 20): Draw "C0R1C15R1C0R7C15R1C21R1C15R2C0R10C15R3C0R10C15R3C0R6C15R1C18R1C68R2 " + Draw "C16R1C15R1C16R1C33R1C22R1C15R1C68R4C0R2C40R1C22R1C21R1C22R1C74R1C68R6 " + Draw "C0R1C15R1C21R2C0R3C15R1C68R6C0R1C25R2C15R1C74R2C0R3C15R2C21R2C68R5 " + Draw "C0R4C74R2C0R4C74R1C68R3C0R5C74R1C68R1C0R10C15R1C0R5C15R1C0R4C74R1 " + Draw "C68R3C0R4C15R1C0R5C15R1C0R1C68R4C0R9C74R2C68R1C0R3C15R1C21R1C15R1 " + Draw "C0R1C15R1C21R1C15R1C21R1C68R5C0R4C15R1C0R1C74R1C68R6C0R2C15R1C21R1 " + Draw "C15R1C0R3C68R5C0R1C18R1C15R1C0R1C74R2C0R4C74R1C68R3C0R3C15R1C74R1 " + Draw "C68R1C0R1C74R1C68R5C0R1C15R1C25R1C15R1C0R1C74R1C68R4C0R6C68R2C25R1 " + Draw "C0R3C15R1C0R5C15R1C0R3C15R1C21R1C16R1C21R1C25R1C15R1C0R2C21R3C15R2 " + Draw "C0R3C25R1C37R1C21R1C0R6C15R1C33R1C23R1C16R2C18R1C16R1C15R1C21R1C15R1 " + Draw "C0R2C15R1C0R2C15R1" + PSet (0, 21): Draw "C15R3C0R7C15R2C21R1C15R1C0R6C15R1C0R3C15R1C0R5C15R1C0R3C15R1C0R2 " + Draw "C15R1C0R6C15R1C22R1C18R1C0R1C68R2C74R6C68R2C0R2C21R1C33R1C21R1C15R1 " + Draw "C0R1C74R1C68R6C0R1C15R1C21R4C15R2C21R1C68R6C74R4C0R3C15R1C21R1C15R1 " + Draw "C0R3C68R5C74R4C0R5C74R1C68R3C0R6C68R2C0R14C15R1C21R1C15R1C0R2C15R1 " + Draw "C0R1C68R2C0R4C15R1C21R1C15R1C0R6C74R1C68R2C0R10C74R1C68R1C0R3C15R3 " + Draw "C0R3C15R1C0R2C74R1C68R5C0R2C15R1C21R1C15R1C74R1C68R6C0R3C15R1C0R5 " + Draw "C68R5C74R4C0R2C15R1C0R2C74R1C68R3C0R2C15R1C25R1C74R1C68R1C0R1C74R1 " + Draw "C68R6C74R3C0R1C74R1C68R4C0R4C15R1C0R1C15R1C68R2C0R2C15R1C25R1C15R1 " + Draw "C0R3C15R1C21R1C15R1C0R3C15R1C0R2C15R1C0R9C15R1C0R1C21R1C37R1C25R1 " + Draw "C0R5C15R2C16R2C15R1C16R2C0R2C15R3C0R3C21R1C25R1" + PSet (0, 22): Draw "C15R2C0R10C15R1C0R5C15R4C0R2C15R1C0R4C15R3C0R1C15R3C0R7C15R1C18R2 " + Draw "C15R1C0R12C18R1C21R1C15R3C0R9C18R1C22R1C21R2C15R1C0R1C15R1C32R1C15R1 " + Draw "C0R10C21R1C0R2C15R1C0R27C25R1C32R1C0R2C15R1C0R13C15R1C0R2C15R1C21R1 " + Draw "C15R2C0R6C15R1C0R24C15R1C21R1C15R1C0R16C15R1C0R16C25R1C35R1C0R12C15R1 " + Draw "C25R1C0R6C15R1C0R22C25R1C32R1C15R1C0R1C21R1C0R4C15R1C0R4C16R2C15R2 " + Draw "C0R14C15R1C21R1C15R1C0R1C21R1C25R1C21R1C15R1C0R2C15R1C21R1C15R1C0R1 " + Draw "C15R1C16R1C21R1C16R1C15R1C0R2C15R1C21R1C15R1C0R1C15R1C33R2" + PSet (0, 23): Draw "C15R1C0R16C15R1C25R1C15R2C0R2C15R1C21R1C15R1C0R4C15R1C0R3C15R1C0R8 " + Draw "C17R1C18R1C16R1C0R5C15R1C25R1C15R1C0R1C33R1C35R1C15R1C25R1C23R1C0R2 " + Draw "C15R1C21R1C15R1C0R1C16R1C32R1C15R2C32R1C19R1C56R1C48R1C0R2C21R1C0R2 " + Draw "C32R1C53R1C0R3C15R1C0R3C15R1C0R2C15R1C25R1C0R9C15R1C0R17C16R1C0R1 " + Draw "C16R1C37R1C25R1C16R1C25R2C15R1C0R3C16R2C15R2C0R9C15R1C0R2C15R1C0R14 " + Draw "C16R1C32R1C15R1C0R14C15R1C0R9C16R1C32R1C15R1C0R2C16R1C0R6C16R1C25R1 " + Draw "C0R10C16R1C23R1C21R1C0R1C16R1C23R1C17R1C0R8C16R1C18R1C0R7C15R1C18R1 " + Draw "C15R1C0R4C16R1C17R1C37R1C15R1C0R10C16R1C37R1C21R1C0R11C15R1C25R1C0R2 " + Draw "C22R1C15R1C0R14C15R1C0R4C15R1C21R1C15R1C0R2C15R1C0R1C15R1C25R1C16R1 " + Draw "C15R1C16R1C21R1C15R1C0R1C17R1C16R1C0R3C33R1C37R1" + PSet (0, 24): Draw "C21R1C0R5C15R1C0R10C15R1C22R1C0R5C15R1C0R17C15R1C17R1C16R1C0R3C16R1 " + Draw "C0R3C15R1C0R1C15R1C35R1C21R1C0R1C21R1C23R1C0R3C15R3C17R1C15R1C0R2 " + Draw "C15R1C18R1C37R1C0R3C15R2C0R1C17R1C23R1C0R2C16R1C32R1C15R1C0R1C33R1 " + Draw "C37R1C15R1C0R2C15R1C0R7C16R1C0R16C16R1C0R1C16R1C32R1C15R1C0R1C15R1 " + Draw "C0R7C15R1C32R2C22R1C32R1C15R1C0R14C16R3C0R6C16R1C0R3C15R1C0R26C15R1 " + Draw "C0R2C16R1C32R1C15R1C0R3C16R1C0R2C15R1C0R11C15R1C0R2C17R1C40R1C15R1 " + Draw "C0R6C16R1C0R1C16R1C22R1C0R8C15R1C0R4C16R1C37R1C15R1C0R2C15R1C0R10 " + Draw "C15R1C0R11C15R3C0R2C15R1C0R25C16R1C0R2C15R1C0R3C21R2C33R1C37R1C15R1 " + Draw "C0R3C21R1C37R1" + PSet (0, 25): Draw "C21R1C0R4C15R1C21R1C15R1C0R10C15R1C0R10C15R1C0R13C15R1C0R2C15R1C16R1 " + Draw "C21R1C15R1C0R5C21R1C15R1C0R1C16R1C22R1C0R1C15R2C21R1C22R1C21R1C22R1 " + Draw "C21R1C0R2C15R1C22R1C15R1C0R3C15R1C21R1C15R2C33R2C15R1C0R1C15R1C0R1 " + Draw "C15R1C25R1C21R1C15R2C0R2C15R1C0R5C15R1C21R2C0R14C15R1C25R1C21R1C15R2 " + Draw "C0R11C15R3C25R1C15R1C0R13C15R1C21R3C15R1C0R4C15R1C21R1C15R1C0R3C15R1 " + Draw "C0R29C15R1C0R3C25R1C32R1C15R1C0R2C15R1C0R4C15R1C0R4C15R1C0R3C21R1 " + Draw "C15R1C0R1C21R1C15R1C0R2C15R1C17R1C25R1C15R1C0R1C15R1C0R10C15R1C0R2 " + Draw "C16R1C15R1C0R2C15R1C22R1C15R1C0R20C15R1C25R1C15R1C0R6C15R1C0R7C15R1 " + Draw "C0R3C25R2C0R5C15R1C0R2C16R1C25R1C15R1C0R5C16R1C40R1C53R1C37R1C0R4 " + Draw "C16R1C21R1" + PSet (0, 26): Draw "C56R1C54R1C56R6C54R1C56R4C66R3C56R2C54R3C56R3C66R1C56R3C66R2C56R1C54R1 " + Draw "C56R18C54R1C56R8C66R1C56R1C66R4C54R1C66R2C56R2C66R1C56R1C54R1C56R7C59R2 " + Draw "C54R4C56R2C54R1C66R2C56R2C66R1C56R1C54R1C56R4C66R2C56R1C54R1C56R11C66R4 " + Draw "C56R1C54R3C56R9C54R2C56R2C54R2C56R17C54R1C56R7C66R3C56R1C54R1C56R27C54R3 " + Draw "C66R1C58R1C66R1C54R2C66R2C56R1C54R1C56R1C66R2C56R1C54R1C56R1C66R2C56R1 " + Draw "C54R1C66R2C56R4C54R1C66R1C58R1C56R3C54R4C56R7C66R1C58R1C56R2C58R1C56R1 " + Draw "C54R2C66R2C54R2C56R8C66R1C56R13C54R1C56R4C66R1C58R1C56R1C54R1C56R4C66R1 " + Draw "C58R1C56R1C54R1C66R1C61R1C59R1C66R1C56R3C66R2C56R2C66R2C54R1C56R5C66R1 " + Draw "C59R1C58R1C66R1C54R2C56R1C66R2C43R1" + PSet (0, 27): Draw "C37R199C37R120C37R1" + PSet (0, 28): Draw "C37R199C37R120C37R1" + PSet (0, 29): Draw "C37R199C37R120C37R1" + PSet (0, 30): Draw "C37R12C71R4C37R1C71R5C37R2C71R3C37R3C71R4C37R2C71R1C37R2C71R1C37R9C71R4 " + Draw "C37R2C71R4C37R3C71R3C37R3C71R4C37R1C71R5C37R12C71R4C37R1C71R1C37R3C71R1 " + Draw "C37R2C71R3C37R2C71R4C37R2C71R5C37R2C71R4C37R15C71R4C37R2C71R3C37R3C71R4 " + Draw "C37R1C71R5C37R31C71R1C37R3C71R1C37R2C71R3C37R2C71R4C37R2C71R5C37R1C71R1 " + Draw "C37R3C71R1C37R44C71R4C37R2C71R4C37R3C71R3C37R2C71R5C37R2C71R3C37R2C71R5 " + Draw "C37R19C37R1" + PSet (0, 31): Draw "C37R11C71R1C37R1C24R4C37R1C24R1C66R1C24R3C71R1C37R1C24R2C66R1C37R1C71R1 " + Draw "C37R1C24R4C37R1C71R1C24R1C71R1C37R1C24R1C37R8C71R1C24R3C66R1C37R1C71R1 " + Draw "C24R3C66R1C37R3C66R1C24R2C37R1C71R1C37R1C24R4C71R1C24R5C37R10C71R1C37R1 " + Draw "C24R4C71R1C24R1C37R2C71R1C24R1C71R1C37R1C24R2C66R1C37R1C71R1C24R3C66R1 " + Draw "C37R1C71R1C24R5C71R1C37R1C24R4C37R13C71R1C37R1C24R4C71R1C37R1C24R2C66R1 " + Draw "C37R1C71R1C37R1C24R4C37R1C24R1C66R1C24R3C37R30C71R1C24R1C37R2C71R1C24R1 " + Draw "C71R1C37R1C24R2C66R1C37R1C71R1C24R3C66R1C37R2C24R1C66R1C24R3C71R1C24R1 " + Draw "C37R2C71R1C24R1C37R43C71R1C24R3C66R1C37R1C71R1C24R3C66R1C37R1C71R1C37R1 " + Draw "C24R2C66R1C37R1C71R1C24R5C37R2C66R1C24R2C37R2C24R1C66R1C24R3C37R18C37R1" + PSet (0, 32): Draw "C37R12C66R1C71R2C37R4C71R1C24R1C37R2C71R1C24R1C37R2C71R1C24R1C71R1C24R1 " + Draw "C37R5C71R1C66R1C37R1C24R1C37R9C71R1C66R1C71R2C37R1C24R1C71R1C66R1C71R2 " + Draw "C37R1C24R1C37R2C71R1C24R1C37R2C71R1C24R1C37R4C71R1C66R1C71R2C37R13C66R1 " + Draw "C71R2C37R2C71R1C66R1C71R3C24R1C71R1C66R1C71R3C24R1C71R1C66R1C71R2C37R1 " + Draw "C24R1C71R1C66R1C71R2C37R3C66R1C71R2C37R15C71R1C24R1C37R4C71R1C24R1C37R2 " + Draw "C71R1C24R1C37R1C66R1C71R2C37R4C71R1C24R1C37R32C71R1C24R1C71R1C37R1C71R1 " + Draw "C24R1C71R1C24R1C37R2C71R1C24R1C71R1C66R1C71R2C37R1C24R1C37R2C71R1C24R1 " + Draw "C37R2C71R1C66R1C71R3C24R1C37R43C71R1C66R1C71R2C37R1C24R1C71R1C66R1C71R2 " + Draw "C37R1C24R1C71R1C24R1C37R2C71R1C24R1C71R1C66R1C71R2C37R4C71R1C24R1C37R4 " + Draw "C71R1C24R1C37R20C37R1" + PSet (0, 33): Draw "C37R13C24R2C66R1C37R3C71R1C24R1C37R2C71R1C24R1C37R2C71R1C24R1C71R1C24R1 " + Draw "C37R5C71R1C24R1C66R1C37R10C71R1C24R4C37R1C71R1C24R1C66R1C24R2C37R3C71R1 " + Draw "C24R1C37R2C71R1C24R1C37R4C71R1C24R4C37R13C24R2C66R1C37R1C71R1C24R3C66R1 " + Draw "C24R1C71R1C24R3C66R1C24R1C71R1C24R1C66R1C24R2C37R1C71R1C24R4C37R3C24R2 " + Draw "C66R1C37R14C71R1C24R1C37R4C71R1C24R1C37R2C71R1C24R1C37R2C24R2C66R1C37R3 " + Draw "C71R1C24R1C37R32C71R1C66R1C37R1C66R1C71R1C24R1C71R1C24R1C37R2C71R1C24R1 " + Draw "C71R1C24R1C66R1C24R2C37R3C71R1C24R1C37R2C71R1C24R3C66R1C24R1C37R43C71R1 " + Draw "C24R4C37R1C71R1C24R1C66R1C24R2C37R1C71R1C24R1C37R2C71R1C24R1C71R1C24R4 " + Draw "C37R3C71R1C24R1C37R4C71R1C24R1C37R20C37R1" + PSet (0, 34): Draw "C37R11C71R4C37R1C24R1C37R2C71R1C24R1C37R3C66R1C71R2C37R1C24R1C37R1C66R1 " + Draw "C71R3C37R2C71R1C24R1C37R1C66R1C37R9C71R1C24R1C37R4C71R1C24R1C37R1C66R1 " + Draw "C71R1C37R2C71R2C66R1C37R3C66R1C71R3C37R1C71R1C66R1C71R3C37R11C71R4C37R1 " + Draw "C24R1C71R1C24R1C37R2C71R1C24R1C71R1C24R1C37R2C71R1C24R1C71R1C24R1C37R1 " + Draw "C66R1C71R1C37R1C71R1C66R1C71R3C37R1C71R4C37R1C24R1C37R14C66R1C71R3C37R2 " + Draw "C66R1C71R2C37R1C24R1C71R4C37R1C24R1C37R2C71R1C24R1C37R32C71R1C24R2C37R1 " + Draw "C66R1C24R1C37R1C66R1C71R2C37R1C24R1C71R1C24R1C37R1C66R1C71R1C37R3C71R1 " + Draw "C24R1C37R2C71R1C24R1C37R2C71R1C24R1C37R43C71R1C24R1C37R4C71R1C24R1C37R1 " + Draw "C66R1C71R1C37R2C66R1C71R2C37R1C24R1C71R1C24R1C37R5C71R2C66R1C37R4C71R1 " + Draw "C24R1C37R20C37R1" + PSet (0, 35): Draw "C37R12C24R4C37R4C24R1C37R4C24R3C37R3C24R4C37R2C24R1C37R2C24R1C37R9C24R1 " + Draw "C37R5C24R1C37R2C24R2C37R2C24R3C37R3C24R4C37R1C24R5C37R11C24R4C37R2C24R1 " + Draw "C37R3C24R1C37R1C24R1C37R3C24R1C37R1C24R1C37R2C24R2C37R1C24R5C37R1C24R4 " + Draw "C37R16C24R4C37R2C24R3C37R2C24R4C37R4C24R1C37R33C24R1C37R3C24R1C37R2C24R3 " + Draw "C37R2C24R1C37R2C24R2C37R3C24R1C37R3C24R1C37R3C24R1C37R44C24R1C37R5C24R1 " + Draw "C37R2C24R2C37R2C24R3C37R2C24R1C37R6C24R3C37R4C24R1C37R20C37R1" + PSet (0, 36): Draw "C37R199C37R120C37R1" + PSet (0, 37): Draw "C37R199C37R120C37R1" + PSet (0, 38): Draw "C37R199C37R120C37R1" + PSet (0, 39): Draw "C52R199C52R120C37R1" + + PSet (0, 193): Draw "C48R199C48R120C48R1" + PSet (0, 194): Draw "C37R19C74R3C37R2C71R1C37R3C71R1C37R1C71R5C37R2C71R3C37R10C71R2C37R8C74R5 " + Draw "C37R1C71R4C37R3C71R3C37R2C71R5C37R9C71R2C37R9C74R3C37R2C71R4C37R2C71R4 " + Draw "C37R10C71R2C37R8C74R4C37R2C71R5C37R2C71R1C37R4C71R5C37R1C71R5C37R1C71R5 " + Draw "C37R9C71R2C37R8C74R1C37R3C74R1C37R1C71R5C37R1C71R1C37R3C71R1C37R1C71R1 " + Draw "C37R3C71R1C37R9C71R2C37R8C74R5C37R2C74R4C37R2C74R4C37R7C71R5C37R2C71R3 " + Draw "C37R9C71R3C37R2C71R1C37R3C71R1C37R2C71R3C37R2C71R5C37R20C37R1" + PSet (0, 195): Draw "C37R20C74R1C0R2C37R1C71R1C66R1C37R2C71R1C24R1C71R1C24R5C71R1C37R1C24R2 " + Draw "C66R1C37R9C71R1C66R1C24R1C37R7C74R1C0R5C71R1C24R3C66R1C37R3C66R1C24R2 " + Draw "C37R2C24R1C66R1C24R3C37R8C71R1C66R1C24R1C37R7C74R1C37R1C0R2C74R1C37R1 " + Draw "C71R1C24R3C66R1C37R1C71R1C24R3C66R1C37R9C71R1C66R1C24R1C37R7C74R1C0R3 " + Draw "C74R1C37R1C71R1C24R5C37R1C71R1C24R1C37R3C71R1C24R5C37R1C24R1C66R1C24R3 " + Draw "C71R1C24R5C37R8C71R1C66R1C24R1C37R7C74R2C37R1C74R2C0R1C71R1C24R5C71R1 " + Draw "C66R1C37R2C71R1C24R1C71R1C24R1C37R2C71R1C24R1C37R8C71R1C66R1C24R1C37R7 " + Draw "C74R1C0R5C74R1C37R1C0R4C74R1C37R1C0R4C37R7C24R1C66R1C24R3C71R1C37R1 " + Draw "C24R2C66R1C37R7C71R1C37R1C24R2C66R1C37R1C71R1C24R1C37R2C71R1C24R1C37R2 " + Draw "C66R1C24R2C37R2C24R1C66R1C24R3C37R19C37R1" + PSet (0, 196): Draw "C37R20C74R1C0R1C37R2C71R1C24R1C66R1C37R1C71R1C24R1C71R1C66R1C71R2C37R2 " + Draw "C71R1C24R1C37R2C71R1C24R1C37R8C71R1C66R1C24R1C37R7C74R4C37R2C71R1C24R1 " + Draw "C37R2C71R1C24R1C37R2C71R1C24R1C37R4C71R1C24R1C37R10C71R1C66R1C24R1C37R7 " + Draw "C74R5C0R1C71R1C24R1C37R2C71R1C24R1C71R1C24R1C37R2C71R1C24R1C37R8C71R1 " + Draw "C66R1C24R1C37R7C74R1C0R1C37R2C74R1C0R1C71R1C66R1C71R2C37R3C71R1C24R1 " + Draw "C37R3C71R1C66R1C71R2C37R4C71R1C24R1C37R2C71R1C66R1C71R2C37R10C71R1C66R1 " + Draw "C24R1C37R7C74R1C0R1C74R1C37R1C74R1C0R1C71R1C66R1C71R2C37R2C71R1C24R1 " + Draw "C66R1C37R1C71R1C24R1C71R1C24R1C37R2C71R1C24R1C37R8C71R1C66R1C24R1C37R7 " + Draw "C74R4C37R3C74R3C37R2C74R1C0R1C37R12C71R1C24R1C37R2C71R1C24R1C37R2C71R1 " + Draw "C24R1C37R6C71R1C24R1C37R2C71R1C24R1C71R1C24R1C37R2C71R1C24R1C37R2C71R1 " + Draw "C24R1C37R4C71R1C24R1C37R21C37R1" + PSet (0, 197): Draw "C37R20C74R1C0R1C37R2C71R1C24R1C37R1C66R1C71R1C24R1C71R1C24R4C37R1C71R1 " + Draw "C24R1C37R2C71R1C24R1C37R8C71R1C66R1C24R1C37R7C74R1C0R4C37R1C71R1C24R1 " + Draw "C37R2C71R1C24R1C37R2C71R1C24R1C37R4C71R1C24R1C37R10C71R1C66R1C24R1C37R7 " + Draw "C74R1C0R3C74R1C0R1C71R1C24R1C37R2C71R1C24R1C71R1C24R1C37R2C71R1C24R1 " + Draw "C37R8C71R1C66R1C24R1C37R7C74R1C0R1C37R2C74R1C0R1C71R1C24R4C37R2C71R1 " + Draw "C24R1C37R3C71R1C24R4C37R3C71R1C24R1C37R2C71R1C24R4C37R9C71R1C66R1C24R1 " + Draw "C37R7C74R1C0R1C37R1C0R1C74R1C0R1C71R1C24R4C37R1C71R1C24R1C37R1C66R1 " + Draw "C71R1C24R1C71R1C24R1C37R2C71R1C24R1C37R8C71R1C66R1C24R1C37R7C74R1C0R4 " + Draw "C37R3C0R2C74R1C37R1C74R1C0R1C37R12C71R1C24R1C37R2C71R1C24R1C37R2C71R1 " + Draw "C24R1C37R6C71R1C24R1C37R2C71R1C24R1C71R1C24R1C37R2C71R1C24R1C37R2C71R1 " + Draw "C24R1C37R4C71R1C24R1C37R21C37R1" + PSet (0, 198): Draw "C37R19C74R3C37R2C71R1C24R1C37R2C66R1C24R1C71R1C24R1C37R5C66R1C71R2C37R1 " + Draw "C24R1C37R8C71R1C66R1C24R1C37R7C74R5C37R1C71R1C66R1C71R2C37R1C24R1C37R1 " + Draw "C71R2C66R1C37R4C71R1C24R1C37R10C71R1C66R1C24R1C37R7C74R1C0R1C37R2C74R1 " + Draw "C0R1C71R1C66R1C71R2C37R1C24R1C71R1C66R1C71R2C37R1C24R1C37R8C71R1C66R1 " + Draw "C24R1C37R7C74R4C37R1C0R1C71R1C66R1C71R3C37R2C71R1C66R1C71R2C37R1C71R1 " + Draw "C66R1C71R3C37R3C71R1C24R1C37R2C71R1C66R1C71R3C37R9C71R1C66R1C24R1C37R7 " + Draw "C74R1C0R1C37R2C74R1C0R1C71R1C66R1C71R3C37R1C71R1C24R1C37R2C66R1C24R1 " + Draw "C37R1C66R1C71R3C24R1C37R8C71R1C66R1C24R1C37R7C74R5C37R1C74R4C37R1C0R1 " + Draw "C37R1C74R4C37R9C71R1C24R1C37R3C66R1C71R2C37R1C24R1C37R7C66R1C71R2C37R1 " + Draw "C24R1C37R1C66R1C71R3C24R1C37R1C71R2C66R1C37R4C71R1C24R1C37R21C37R1" + PSet (0, 199): Draw "C37R20C0R3C37R2C24R1C37R3C24R1C37R1C24R1C37R6C24R3C37R9C71R1C66R1C24R1 " + Draw "C37R8C0R5C37R1C24R4C37R3C24R3C37R4C24R1C37R10C71R1C66R1C24R1C37R8C0R1 " + Draw "C37R3C0R1C37R1C24R4C37R2C24R4C37R9C71R1C66R1C24R1C37R8C0R4C37R2C24R5 " + Draw "C37R2C24R4C37R1C24R5C37R3C24R1C37R3C24R5C37R8C71R1C66R1C24R1C37R8C0R1 " + Draw "C37R3C0R1C37R1C24R5C37R1C24R1C37R3C24R1C37R2C24R4C37R8C71R1C66R1C24R1 " + Draw "C37R8C0R5C37R1C0R4C37R3C0R4C37R9C24R1C37R4C24R3C37R9C24R1C66R2C37R3 " + Draw "C24R4C37R2C24R3C37R4C24R1C37R21C37R1" + +End Sub + +Sub EditSTOCK + + Line (0, 40)-(320, 190), 0, BF + + For d = 1 To Stocks + A$ = S.Symbol(d) + If Len(A$) = 2 Then A$ = A$ + " " + If Len(A$) = 1 Then A$ = A$ + " " + + If d > 9 Then + Locate 6 + d, 2 + Else + Locate 6 + d, 3 + End If + + spacr$ = " - " + If Len(S.Symbol(d)) = 3 Then spacr$ = " " + spacr$ + Print Str$(d); ") "; A$; spacr$; S.Name(d) + + Next + + + Locate 22, 3: Input "EDIT WHICH STOCK>", S + + If S < 1 Or S > Stocks Then Exit Sub + + + Line (0, 40)-(320, 190), 0, BF + + Locate 7, 2 + + '=== Edit Current value of share + + Dim CV As Single + Print "Stock "; S.Symbol(S); " - "; S.Name(S) + Print + Input " Current value of share> ", CV + If CV = 0 Then Exit Sub + + S.CurVal(S) = CV + + Changed% = 1 + +End Sub + +Sub InfoStock + + Line (0, 40)-(320, 190), 0, BF + + + For d = 1 To Stocks + A$ = S.Symbol(d) + If Len(A$) = 2 Then A$ = A$ + " " + If Len(A$) = 1 Then A$ = A$ + " " + + If d > 9 Then + Locate 6 + d, 2 + Else + Locate 6 + d, 3 + End If + + spacr$ = " - " + If Len(S.Symbol(d)) = 3 Then spacr$ = " " + spacr$ + Print Str$(d); ") "; A$; spacr$; S.Name(d) + + + 'LOCATE 2 + d, 5: PRINT STR$(d); ") "; a$; " - "; S.Name(d) + Next + + + Locate 23, 2: Input "GET INFO ON WHAT STOCK>", S + + If S < 1 Or S > Stocks Then Exit Sub + + Dim CV As Single + + + Line (0, 40)-(320, 190), 0, BF + + Locate 7, 2: Print "Symbol: "; S.Symbol(S) + Locate 8, 2: Print "Name : "; S.Name(S) + Locate 9, 2: Print "Bought: "; S.Date(S) + + Dim c As Single + c = S.Cost(S) * S.Shares(S) + + Locate 11, 2: Print "Shares:"; S.Shares(S); "at"; S.Cost(S); "= $";: Print Using "####.##"; c; + + CV = S.Shares(S) * S.CurVal(S) + + Locate 13, 2: Print "Valued:"; S.Shares(S); "at"; S.CurVal(S); "= $";: Print Using "####.##"; CV; + Locate 14, 25: Print "--------"; + + Locate 15, 2: Print "Profit:"; + + Locate 15, 23: Print "= $"; + If CV - c >= 0 Then Color 250 Else Color 249 + Print Using "####.##"; (CV - c) + + Color 6 + Locate 19, 2: Print "After Commissions" + Locate 20, 2: Print "($9.95 x 2) = $"; + Print Using "####.##"; (CV - c) - (9.95 * 2) + + A$ = Input$(1) + +End Sub + +Sub Init + + '== Test for INI file. If not found, make one. + Open "STOCKS.INI" For Binary As #1 + If LOF(1) = 0 Then + Close #1 + Open "STOCKS.INI" For Output As #1 + Print #1, " 0" + End If + Close #1 + + Open "STOCKS.INI" For Input As 1 + + Line Input #1, S$ + + Stocks = Val(S$) + For d = 1 To Stocks + Line Input #1, S.Symbol(d) + Line Input #1, S.Name(d) + Line Input #1, S.Date(d) + Line Input #1, A$: S.CurVal(d) = Val(A$) + Line Input #1, A$: S.Shares(d) = Val(A$) + Line Input #1, A$: S.Cost(d) = Val(A$) + Next + + Close #1 + +End Sub + +Sub MenuScreen + + Line (0, 40)-(320, 190), 0, BF + + Locate 9, 5: Print "A = Add stock to list" + Locate 11, 5: Print "D = Delete stock from list" + Locate 13, 5: Print "E = Edit (update) stock value" + Locate 15, 5: Print "I = Get detailed info of stock" + Locate 17, 5: Print "M = This menu, of course" + Locate 21, 5: Print "ESC = Exits Stock Watcher" + + A$ = Input$(1) + +End Sub + diff --git a/samples/stock-watcher/src/qb64stocks.zip b/samples/stock-watcher/src/qb64stocks.zip new file mode 100644 index 0000000..5efa571 Binary files /dev/null and b/samples/stock-watcher/src/qb64stocks.zip differ diff --git a/samples/stocks.md b/samples/stocks.md new file mode 100644 index 0000000..83c492f --- /dev/null +++ b/samples/stocks.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: STOCKS + +**[Stock Watcher](stock-watcher/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [money](money.md), [stocks](stocks.md) + +Stock Watcher program. diff --git a/samples/stxaxtic.md b/samples/stxaxtic.md index b0331ba..2c25922 100644 --- a/samples/stxaxtic.md +++ b/samples/stxaxtic.md @@ -2,12 +2,30 @@ ## SAMPLES BY STXAXTIC +**[3D Engine Prototypes](3d-engine-prototypes/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [3d](3d.md), [graph](graph.md) + +Various experiments in software 3D graphics. Warning: Uses no functions or subs! + +**[3D Grapher](3d-grapher/index.md)** + +[🐝 Ashish Kushwaha](ashish-kushwaha.md) [🐝 STxAxTIC](stxaxtic.md) 🔗 [3d](3d.md), [gl](gl.md) + +3D Grapher made in QB64. + **[Circle Intersecting Circle](circle-intersecting-circle/index.md)** [🐝 bplus](bplus.md) [🐝 STxAxTIC](stxaxtic.md) 🔗 [geometry](geometry.md), [intersections](intersections.md) Here we present two (equivalent) methods for calculating the intersection points between any two ... +**[Curve Smoother](curve-smoother/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) [🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [curve](curve.md), [interpolation](interpolation.md) + +This program demonstrates (i) linear interpolation to create a curve between points, (ii) a relax... + **[Ellipse Intersecting Line](ellipse-intersecting-line/index.md)** [🐝 STxAxTIC](stxaxtic.md) 🔗 [geometry](geometry.md), [intersections](intersections.md) @@ -16,6 +34,42 @@ Here we present two (equivalent) methods for calculating the intersection points **[Fibonacci Variations](fibonacci-variations/index.md)** -[🐝 STxAxTIC](stxaxtic.md) 🔗 [fibonacci](fibonacci.md) +[🐝 STxAxTIC](stxaxtic.md) 🔗 [fibonacci](fibonacci.md), [spiral](spiral.md) The Fibonacci sequence is "seeded" with the golden ratio, but what if we change that? + +**[Integrators](integrators/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [physics](physics.md), [simulation](simulation.md) + +Demonstrates the efficacy of various integration methods in physics. + +**[Lens Simulator](lens-simulator/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [2d](2d.md), [ray tracer](ray-tracer.md) + +This program simulates light rays passing through a lens with a given index of refraction and con... + +**[Lines Intersecting](lines-intersecting/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [geometry](geometry.md), [intersections](intersections.md) + +Line segments intersecting. + +**[Parabolas](parabolas/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [zen](zen.md) + +Parabola-based screensaver by STxAxTIC. + +**[Trig Demo](trig-demo/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [trigonometry](trigonometry.md) + +Trivial trigonometry demo. + +**[Vector Field](vector-field/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [2d](2d.md), [vectors](vectors.md) + +Vector field demonstration. diff --git a/samples/super-mario-jump/img/screenshot.png b/samples/super-mario-jump/img/screenshot.png new file mode 100644 index 0000000..7104912 Binary files /dev/null and b/samples/super-mario-jump/img/screenshot.png differ diff --git a/samples/super-mario-jump/index.md b/samples/super-mario-jump/index.md new file mode 100644 index 0000000..3c20dda --- /dev/null +++ b/samples/super-mario-jump/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: SUPER MARIO JUMP + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Terry Ritchie](../terry-ritchie.md) + +### Description + +```text +Super Mario Jump! +``` + +### File(s) + +* [supermariojump.bas](src/supermariojump.bas) +* [supermariojump.zip](src/supermariojump.zip) + +🔗 [game](../game.md), [mario](../mario.md) diff --git a/samples/super-mario-jump/src/supermariojump.bas b/samples/super-mario-jump/src/supermariojump.bas new file mode 100644 index 0000000..0a65dbb --- /dev/null +++ b/samples/super-mario-jump/src/supermariojump.bas @@ -0,0 +1,757 @@ +$Resize:Smooth + +'$INCLUDE:'spritetop.bi' + +'***** +'* +'* Super Mario Jump! - Work in progress - by Terry Ritchie +'* +'***** + +Const FALSE = 0, TRUE = Not FALSE + +Type ENEMYINFO + sprite As Integer ' the assigned sprite number + kind As Integer ' the type of sprite character (1 - 13) + action As Integer ' the current sprite action (1=scrolling, 2=falling, 3=dead) +End Type + +Type DIFFICULTYINFO + world As Integer ' current game world + level As Integer ' current game level + fps As Integer ' frames per second + rowspeed As Integer ' maximum row speed + trampoffset As Integer ' trampoline x offset + tremaining As Integer ' time remaining + springs As Integer ' number of springs +End Type + +Dim Difficulty As DIFFICULTYINFO +Dim EnemySprite%(13) ' the various scrolling sprites to choose from +Dim Enemy(24) As ENEMYINFO ' the 24 scrolling sprites +Dim Castle& ' the game background +Dim SpriteSheet% ' the spritesheet containing game sprites +Dim Mario% ' the mario sprite +Dim Row% ' used to hold row calculations +Dim Column% ' used to hold column calculations +Dim RowSpeed%(3) ' the random speed of each row +Dim RandomEnemy% ' used to select a random sprite +Dim Flag% ' the flag sprite +Dim LeftTurtleTop% ' the top of left turtle sprite +Dim LeftTurtleBot% ' the bottom of left turtle sprite +Dim RightTurtleTop% ' the top of right turtle sprite +Dim RightTurtleBot% ' the bottom of right turtle sprite +Dim Trampx% ' x location of trampoline +Dim Spring%(3) +Dim Mariox% +Dim Marioy% +Dim MarioXVel! +Dim MarioYVel! +Dim Count% +Dim MarioIsDead% +Dim Players% +Dim LevelComplete% +Dim EnemyCount% +Dim MarioLanded% +Dim Score% +Dim GameFont& +Dim UserExits% + +Dim snd1Up& +Dim sndBreakBlock& +Dim sndBump& +Dim sndCoin& +Dim sndDie& +Dim sndFireworks& +Dim sndGameOver& +Dim sndKick& +Dim sndLevelComplete& +Dim sndMainTheme& +Dim sndPowerUp& +Dim sndPowerUpAppears& +Dim sndJump& +Dim sndStageClear& +Dim sndStarMan& +Dim sndStomp& +Dim sndVine& +Dim sndWarning& +Dim sndWorldClear& +Dim sndDead& + + +Screen _NewImage(320, 240, 32) +_Title "Super Mario Jump!" +_ScreenMove _Middle +_FullScreen _SquarePixels , _Smooth +_MouseHide +_Delay 2 + +LOADSPRITES +LOADSOUNDS +Do ' come back here until user exits game + 'TITLESCREEN + Players% = 3 + Difficulty.world = 1 + Difficulty.level = 0 + Score% = 0 + Do ' come back here until game is over + DRAWSCREEN + Do ' come back here until level completed or no players left + STARTLEVEL + Do ' come back here until level completed mario is dead + _Limit Difficulty.fps + MOVECHARACTERS + UPDATESCORE + MOVEMARIO + CHECKFORCOLLISIONS + UPDATETRAMPOLINE + _Display + Loop Until MarioIsDead% Or LevelComplete% + If MarioIsDead% Then KILLMARIO + Loop Until LevelComplete% Or Players% = 0 + If LevelComplete% Then + _SndStop sndMainTheme& + _SndPlay sndLevelComplete& + Do + _Limit Difficulty.fps + MOVECHARACTERS + UPDATESCORE + UPDATETRAMPOLINE + MOVEMARIO + _Display + Loop Until _SndPlaying(sndLevelComplete&) = 0 + End If + MarioLanded% = FALSE + For Count% = 1 To 24 + SPRITEFREE Enemy(Count%).sprite + Next Count% + Loop Until Players% = 0 + _SndPlay sndGameOver& + UserExits% = TRUE +Loop Until UserExits% + + +'--------------------------------------------------------------------------------------------------- +Sub UPDATESCORE () + '****************************************************************************** + ' Display the score on screen * + '****************************************************************************** + + Shared Difficulty As DIFFICULTYINFO + Shared Score% + + _PrintString (80, 1), LTrim$(Str$(Difficulty.world)) + "-" + LTrim$(Str$(Difficulty.level)) + _PrintString (136, 1), Right$("000" + LTrim$(Str$(Score%)), 4) + _PrintString (200, 1), Right$("00" + LTrim$(Str$(Difficulty.tremaining)), 3) + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub CHECKFORCOLLISIONS () + '****************************************************************************** + '* Check for Mario colliding into enemies * + '****************************************************************************** + + Shared Enemy() As ENEMYINFO + Shared Mario% + Shared MarioXVel! + Shared MarioYVel! + Shared sndStomp& + Shared sndKick& + Shared sndPowerUp& + Shared snd1Up& + Shared sndPowerUpAppears& + Shared sndBreakBlock& + Shared sndFireworks& + Shared EnemyCount% + Shared LevelComplete% + Shared Difficulty As DIFFICULTYINFO + Shared Score% + + Dim Count% + Dim Xoffset! + Dim Yoffset! + + For Count% = 1 To 24 + If Enemy(Count%).action = 1 Then + If SPRITECOLLIDE(Mario%, Enemy(Count%).sprite) Then + EnemyCount% = EnemyCount% + 1 + If EnemyCount% = 24 Then LevelComplete% = TRUE + Enemy(Count%).action = 2 + SPRITEANIMATION Enemy(Count%).sprite, NOANIMATE, FORWARDLOOP + SPRITEMOTION Enemy(Count%).sprite, DONTMOVE + Score% = Score% + SPRITESCORE(Enemy(Count%).sprite) + Yoffset! = SPRITEAY(Enemy(Count%).sprite) - SPRITEAY(Mario%) ' change difficulty here *** need to do *** + Xoffset! = SPRITEAX(Enemy(Count%).sprite) - SPRITEAX(Mario%) + If Yoffset! > 0 Then MarioYVel! = -MarioYVel! + MarioXVel! = MarioXVel! - (Xoffset! / 4) + Select Case Enemy(Count%).kind + Case 1 + SPRITESET Enemy(Count%).sprite, 12 + _SndPlayCopy sndStomp& + Case 2 + SPRITESET Enemy(Count%).sprite, 15 + _SndPlayCopy sndStomp& + Case 3 + SPRITESET Enemy(Count%).sprite, 18 + _SndPlayCopy sndStomp& + Case 4 + SPRITEFLIP Enemy(Count%).sprite, VERTICAL + _SndPlayCopy sndKick& + Case 5 + SPRITEFLIP Enemy(Count%).sprite, VERTICAL + _SndPlayCopy sndKick& + Case 6 + SPRITEFLIP Enemy(Count%).sprite, VERTICAL + _SndPlayCopy sndKick& + Case 7 + SPRITEFLIP Enemy(Count%).sprite, VERTICAL + _SndPlayCopy sndKick& + Case 8 + 'SPRITESPINSET Enemy(Count%).sprite, 45 + _SndPlayCopy sndPowerUp& + Case 9 + 'SPRITESPINSET Enemy(Count%).sprite, 45 + _SndPlayCopy snd1Up& + Case 10 + 'SPRITESPINSET Enemy(Count%).sprite, 45 + _SndPlayCopy sndPowerUpAppears& + Case 11 + 'SPRITESPINSET Enemy(Count%).sprite, 45 + _SndPlayCopy sndPowerUp& + Case 12 + 'SPRITESPINSET Enemy(Count%).sprite, 45 + _SndPlayCopy sndBreakBlock& + Case 13 + 'SPRITESPINSET Enemy(Count%).sprite, 10 + _SndPlayCopy sndFireworks& + End Select + Exit For + End If + End If + Next Count% + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub KILLMARIO () + '****************************************************************************** + '* Sadly Mario has died * + '****************************************************************************** + + Shared Difficulty As DIFFICULTYINFO + Shared Castle& + Shared sndMainTheme& + Shared sndDead& + Shared Mario% + Shared Players% + + Dim Count% + Dim Rotation% + + _SndStop sndMainTheme& + _SndPlay sndDead& + SPRITESET Mario%, 7 + SPRITEPUT SPRITEX(Mario%), 232, Mario% + For Count% = 1 To 3 + For Rotation% = 0 To 359 Step 45 + _Limit Difficulty.fps + _PutImage , Castle& + MOVECHARACTERS + UPDATESCORE + UPDATETRAMPOLINE + SPRITEROTATE Mario%, Rotation% + SPRITEPUT SPRITEX(Mario%), SPRITEY(Mario%), Mario% + _Display + Next Rotation% + Next Count% + SPRITEROTATE Mario%, 180 + Do + _Limit Difficulty.fps + _PutImage , Castle& + MOVECHARACTERS + UPDATESCORE + UPDATETRAMPOLINE + SPRITEPUT SPRITEX(Mario%), SPRITEY(Mario%), Mario% + _Display + Loop Until _SndPlaying(sndDead&) = 0 + SPRITEROTATE Mario%, 0 + Players% = Players% - 1 + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub MOVEMARIO () Static + '****************************************************************************** + '* Move mario on the screen * + '****************************************************************************** + + Shared Mario% + Shared MarioIsDead% + Shared Spring%() + Shared MarioXVel! + Shared MarioYVel! + Shared sndBump& + Shared sndMainTheme& + Shared sndJump& + Shared LevelComplete% + Shared MarioLanded% + Shared Difficulty As DIFFICULTYINFO + + Dim FrameCount% + Dim ScoreCount% + + If MarioLanded% Then + SPRITEPUT SPRITEX(Mario%), 232, Mario% + Exit Sub + Else + ScoreCount% = ScoreCount% + 1 + If ScoreCount% >= Difficulty.fps Then + ScoreCount% = 0 + Difficulty.tremaining = Difficulty.tremaining - 1 + End If + End If + If SPRITEX(Mario%) < 8 Or SPRITEX(Mario%) > 311 Then + _SndPlayCopy sndBump& + MarioXVel! = -MarioXVel! + End If + MarioYVel! = MarioYVel! - .5 + Select Case Abs(MarioYVel!) + Case Is < 3 + If LevelComplete% Then + SPRITESET Mario%, 1 + Else + SPRITESET Mario%, 7 + End If + Case 3 To 5.9999999 + SPRITESET Mario%, 6 + Case 6 To 8.9999999 + SPRITESET Mario%, 5 + Case 9 To 12 + SPRITESET Mario%, 4 + Case Is > 12 + SPRITESET Mario%, 3 + End Select + If Sgn(MarioXVel!) = 1 Then + SPRITEFLIP Mario%, NONE + Else + SPRITEFLIP Mario%, HORIZONTAL + End If + If MarioYVel! > 15 Then MarioYVel! = 15 + SPRITEPUT SPRITEAX(Mario%) + MarioXVel!, SPRITEAY(Mario%) - MarioYVel!, Mario% + FrameCount% = FrameCount% + 1 + If FrameCount% = 2 Then + SPRITESET Spring%(1), 50 + SPRITESET Spring%(2), 50 + SPRITESET Spring%(3), 50 + End If + If Not LevelComplete% Then + If FrameCount% > 4 Then + FrameCount% = 4 + For Count% = 1 To 3 + If SPRITECOLLIDE(Mario%, Spring%(Count%)) Then + _SndPlayCopy sndJump& + MarioYVel! = Abs(MarioYVel! * 1.1) + Offset! = -(SPRITEAX(Spring%(2)) - SPRITEAX(Mario%)) + MarioXVel! = MarioXVel! + (Offset! / Difficulty.trampoffset) ' change difficult here + FrameCount% = 1 + SPRITESET Spring%(1), 51 + SPRITESET Spring%(2), 51 + SPRITESET Spring%(3), 51 + Exit Sub + End If + Next Count% + End If + End If + If SPRITEY(Mario%) > 232 Then + If LevelComplete% Then + MarioLanded% = TRUE + MarioXVel! = 0 + MarioYVel! = 0 + SPRITESET Mario%, 1 + SPRITEPUT SPRITEX(Mario%), 232, Mario% + Else + MarioIsDead% = TRUE + End If + End If + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub LOADSOUNDS () + '****************************************************************************** + '* Load the game sounds * + '****************************************************************************** + + Shared snd1Up& + Shared sndBreakBlock& + Shared sndBump& + Shared sndCoin& + Shared sndDie& + Shared sndFireworks& + Shared sndGameOver& + Shared sndKick& + Shared sndLevelComplete& + Shared sndMainTheme& + Shared sndPowerUp& + Shared sndPowerUpAppears& + Shared sndJump& + Shared sndStageClear& + Shared sndStarMan& + Shared sndStomp& + Shared sndVine& + Shared sndWarning& + Shared sndWorldClear& + Shared sndDead& + + snd1Up& = _SndOpen("mario1up.ogg", "VOL,SYNC") + sndBreakBlock& = _SndOpen("mariobreakblock.ogg", "VOL,SYNC") + sndBump& = _SndOpen("mariobump.ogg", "VOL,SYNC") + sndCoin& = _SndOpen("mariocoin.ogg", "VOL,SYNC") + sndDie& = _SndOpen("mariodie.ogg", "VOL,SYNC") + sndFireworks& = _SndOpen("mariofireworks.ogg", "VOL,SYNC") + sndGameOver& = _SndOpen("mariogameover.ogg", "VOL,SYNC") + sndKick& = _SndOpen("mariokick.ogg", "VOL,SYNC") + sndLevelComplete& = _SndOpen("mariolevelcomplete.ogg", "VOL,SYNC") + sndMainTheme& = _SndOpen("mariomaintheme.ogg", "VOL,SYNC") + sndPowerUp& = _SndOpen("mariopowerup.ogg", "VOL,SYNC") + sndPowerUpAppears& = _SndOpen("mariopowerupappears.ogg", "VOL,SYNC") + sndJump& = _SndOpen("mariosmalljump.ogg", "VOL,SYNC") + sndStageClear& = _SndOpen("mariostageclear.ogg", "VOL,SYNC") + sndStarMan& = _SndOpen("mariostarman.ogg", "VOL,SYNC") + sndStomp& = _SndOpen("mariostomp.ogg", "VOL,SYNC") + sndVine& = _SndOpen("mariovine.ogg", "VOL,SYNC") + sndWarning& = _SndOpen("mariowarning.ogg", "VOL,SYNC") + sndWorldClear& = _SndOpen("marioworldclear.ogg", "VOL,SYNC") + sndDead& = _SndOpen("marioyouredead.ogg", "VOL,SYNC") + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub STARTLEVEL () + '****************************************************************************** + '* Mario climbing sequence * + '****************************************************************************** + + Shared Difficulty As DIFFICULTYINFO + Shared MarioXVel! + Shared MarioYVel! + Shared Mario% + Shared Castle& + Shared sndWorldClear& + Shared sndMainTheme& + Shared sndVine& + Shared sndBump& + Shared MarioIsDead% + + Dim Mariox% + Dim Marioy% + Dim Door% + + _SndPlayCopy sndWorldClear& + MarioIsDead% = FALSE + Door% = Int(Rnd(1) * 2) + 1 + Marioy% = 232 + If Door% = 1 Then + SPRITEFLIP Mario%, HORIZONTAL + Mariox% = 41 + MarioXVel! = 2 + SPRITESPEEDSET Mario%, 1 + SPRITEDIRECTIONSET Mario%, 270 + Else + SPRITEFLIP Mario%, NONE + Mariox% = 279 + MarioXVel! = -2 + SPRITESPEEDSET Mario%, 1 + SPRITEDIRECTIONSET Mario%, 90 + End If + MarioYVel! = 3 + SPRITEPUT Mariox%, Marioy%, Mario% + SPRITEMOTION Mario%, MOVE + SPRITEANIMATESET Mario%, 2, 4 + SPRITEANIMATION Mario%, ANIMATE, FORWARDLOOP + For Count% = 1 To 28 + _Limit Difficulty.fps + _PutImage , Castle& + MOVECHARACTERS + UPDATETRAMPOLINE + UPDATESCORE + SPRITEPUT MOVE, MOVE, Mario% + _Display + Next Count% + SPRITESET Mario%, 8 + SPRITEANIMATESET Mario%, 8, 9 + SPRITEDIRECTIONSET Mario%, 0 + SPRITESPEEDSET Mario%, 2 + _SndPlayCopy sndVine& + For Count% = 1 To 96 + _Limit Difficulty.fps + _PutImage , Castle& + MOVECHARACTERS + UPDATETRAMPOLINE + UPDATESCORE + SPRITEPUT MOVE, MOVE, Mario% + _Display + Next Count% + SPRITEANIMATION Mario%, NOANIMATE, FORWARDLOOP + SPRITEMOTION Mario%, DONTMOVE + SPRITESET Mario%, 6 + If Door% = 1 Then SPRITEFLIP Mario%, NONE + _SndPlayCopy sndBump& + _SndLoop sndMainTheme& + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub MOVECHARACTERS () + '****************************************************************************** + '* Move thge enemy characters around the screen * + '****************************************************************************** + + Shared Enemy() As ENEMYINFO ' the 24 scrolling sprites + Shared RowSpeed%() + Shared Castle& + + Dim Row% ' used to hold row calculations + Dim Count% + Dim Dir% + Dim Rot! + + _PutImage , Castle& + For Count% = 1 To 24 + If Enemy(Count%).action = 1 Then + If SPRITEX(Enemy(Count%).sprite) < 24 Then + SPRITEMOTION Enemy(Count%).sprite, DONTMOVE + SPRITEPUT 294, SPRITEY(Enemy(Count%).sprite), Enemy(Count%).sprite + SPRITEMOTION Enemy(Count%).sprite, MOVE + ElseIf SPRITEX(Enemy(Count%).sprite) > 294 Then + SPRITEMOTION Enemy(Count%).sprite, DONTMOVE + SPRITEPUT 24, SPRITEY(Enemy(Count%).sprite), Enemy(Count%).sprite + SPRITEMOTION Enemy(Count%).sprite, MOVE + Else + SPRITEPUT MOVE, MOVE, Enemy(Count%).sprite + End If + ElseIf Enemy(Count%).action = 2 Then ' falling + If SPRITEY(Enemy(Count%).sprite) > 250 Then + Enemy(Count%).action = 3 + Else + Row% = Int((Count% - 1) / 8) + 1 + If Row% = 1 Or Row% = 3 Then Dir% = -1 Else Dir% = 1 + If Enemy(Count%).kind > 7 Then + Rot! = SPRITEROTATION(Enemy(Count%).sprite) + Rot! = Rot! + (Dir% * 45) + If Rot! > 359 Then Rot! = Rot! - 360 + If Rot! < 0 Then Rot! = Rot! + 360 + SPRITEROTATE Enemy(Count%).sprite, Rot! + End If + SPRITEPUT SPRITEX(Enemy(Count%).sprite) + (RowSpeed%(Row%) * Dir%), SPRITEAY(Enemy(Count%).sprite) * 1.1, Enemy(Count%).sprite + End If + End If + Next Count% + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub DRAWSCREEN () + '****************************************************************************** + '* Draw the play screen * + '****************************************************************************** + + Shared EnemySprite%() ' the various scrolling sprites to choose from + Shared Enemy() As ENEMYINFO ' the 24 scrolling sprites + Shared RowSpeed%() ' the random speed of each row + Shared Castle& ' the game background + Shared Trampx% ' x location of trampoline + Shared UserExits% + Shared LevelComplete% + Shared EnemyCount% + Shared Difficulty As DIFFICULTYINFO + + Dim Count% ' generic counter + Dim Row% ' used to hold row calculations + Dim Column% ' used to hold column calculations + + Randomize Timer + + Difficulty.level = Difficulty.level + 1 + If Difficulty.level = 4 Then + Difficulty.level = 1 + Difficulty.world = Difficulty.world + 1 + End If + Difficulty.fps = 14 + (Difficulty.world * Difficulty.level) + If Difficulty.fps > 30 Then Difficulty.fps = 30 + Difficulty.rowspeed = (Difficulty.world * Difficulty.level) - 1 + If Difficulty.rowspeed > 10 Then Difficulty.rowspeed = 10 + Difficulty.trampoffset = 13 - (Difficulty.world * Difficulty.level) + If Difficulty.trampoffset < 3 Then Difficulty.trampoffset = 3 + Difficulty.tremaining = 120 + + UserExits% = FALSE + LevelComplete% = FALSE + EnemyCount% = 0 + _PutImage , Castle& + For Count% = 1 To 24 + If Count% < 4 Then RowSpeed%(Count%) = Int(Rnd(1) * Difficulty.rowspeed) + 1 ' change difficulty here + Enemy(Count%).kind = Int(Rnd(1) * 13) + 1 + Enemy(Count%).sprite = SPRITECOPY(EnemySprite%(Enemy(Count%).kind)) + Enemy(Count%).action = 1 + If Enemy(Count%).kind = 12 Then + SPRITESCORESET Enemy(Count%).sprite, Int(Rnd(1) * 10) + 1 + Else + SPRITESCORESET Enemy(Count%).sprite, 1 + End If + Row% = Int((Count% - 1) / 8) + 1 + Column% = Count% - ((Row% - 1) * 8) + SPRITESPEEDSET Enemy(Count%).sprite, RowSpeed%(Row%) + If Row% = 2 Then + If Enemy(Count%).kind <> 12 Then SPRITEFLIP Enemy(Count%).sprite, HORIZONTAL + SPRITEDIRECTIONSET Enemy(Count%).sprite, 90 + Else + SPRITEFLIP Enemy(Count%).sprite, NONE + SPRITEDIRECTIONSET Enemy(Count%).sprite, 270 + End If + SPRITEPUT (32 * Column%) + 16, (32 * Row%) - 8, Enemy(Count%).sprite + SPRITEMOTION Enemy(Count%).sprite, MOVE + Next Count% + Trampx% = 128 + UPDATETRAMPOLINE + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub UPDATETRAMPOLINE () Static + '****************************************************************************** + '* Draw the trampoline * + '****************************************************************************** + + Shared LeftTurtleTop% ' the top of left turtle sprite + Shared LeftTurtleBot% ' the bottom of left turtle sprite + Shared RightTurtleTop% ' the top of right turtle sprite + Shared RightTurtleBot% ' the bottom of right turtle sprite + Shared Spring%() ' the trampoline springs + Shared Trampx% + + Dim OldTrampx% + + While _MouseInput: Wend + Trampx% = Int(_MouseX * .85) - 8 + If OldTrampx% = Trampx% Then + SPRITEANIMATION LeftTurtleTop%, NOANIMATE, FORWARDLOOP + SPRITEANIMATION LeftTurtleBot%, NOANIMATE, FORWARDLOOP + SPRITEANIMATION RightTurtleTop%, NOANIMATE, FORWARDLOOP + SPRITEANIMATION RightTurtleBot%, NOANIMATE, FORWARDLOOP + Else + SPRITEANIMATION LeftTurtleTop%, ANIMATE, FORWARDLOOP + SPRITEANIMATION LeftTurtleBot%, ANIMATE, FORWARDLOOP + SPRITEANIMATION RightTurtleTop%, ANIMATE, FORWARDLOOP + SPRITEANIMATION RightTurtleBot%, ANIMATE, FORWARDLOOP + OldTrampx% = Trampx% + End If + SPRITEPUT Trampx%, 216, LeftTurtleTop% + SPRITEPUT Trampx%, 232, LeftTurtleBot% + SPRITEPUT Trampx% + 16, 232, Spring%(1) + SPRITEPUT Trampx% + 32, 232, Spring%(2) + SPRITEPUT Trampx% + 48, 232, Spring%(3) + SPRITEPUT Trampx% + 64, 216, RightTurtleTop% + SPRITEPUT Trampx% + 64, 232, RightTurtleBot% + +End Sub + +'-------------------------------------------------------------------------------------------------- + +Sub LOADSPRITES () + '****************************************************************************** + '* Load sprites and set up animation characteristics of each * + '****************************************************************************** + + Shared EnemySprite%() + Shared Castle& + Shared SpriteSheet% + Shared Mario% + Shared Flag% + Shared LeftTurtleTop% + Shared LeftTurtleBot% + Shared RightTurtleTop% + Shared RightTurtleBot% + Shared Spring%() + Shared GameFont& + + Dim Count% + + GameFont& = _LoadFont("pressstart2p.ttf", 12, "MONOSPACE") + _PrintMode _KeepBackground + _Font GameFont& + Castle& = _LoadImage("castle.png", 32) + SpriteSheet% = SPRITESHEETLOAD("sprites.png", 16, 16, _RGB32(0, 255, 0)) + Mario% = SPRITENEW(SpriteSheet%, 1, DONTSAVE) ' mario + SPRITECOLLIDETYPE Mario%, PIXELDETECT + Flag% = SPRITENEW(SpriteSheet%, 45, DONTSAVE) ' flag + Spring%(1) = SPRITENEW(SpriteSheet%, 50, DONTSAVE) ' left spring + SPRITECOLLIDETYPE Spring%(1), BOXDETECT + Spring%(2) = SPRITECOPY(Spring%(1)) ' middle spring + SPRITECOLLIDETYPE Spring%(2), BOXDETECT + Spring%(3) = SPRITECOPY(Spring%(1)) ' right spring + SPRITECOLLIDETYPE Spring%(3), BOXDETECT + LeftTurtleTop% = SPRITENEW(SpriteSheet%, 37, DONTSAVE) ' top of left turtle + SPRITEANIMATESET LeftTurtleTop%, 37, 38 + SPRITEANIMATION LeftTurtleTop%, ANIMATE, FORWARDLOOP + LeftTurtleBot% = SPRITENEW(SpriteSheet%, 46, DONTSAVE) ' bottom of left turtle + SPRITEANIMATESET LeftTurtleBot%, 46, 47 + SPRITEANIMATION LeftTurtleBot%, ANIMATE, FORWARDLOOP + RightTurtleTop% = SPRITENEW(SpriteSheet%, 39, DONTSAVE) ' top of right turtle + SPRITEANIMATESET RightTurtleTop%, 39, 40 + SPRITEANIMATION RightTurtleTop%, ANIMATE, FORWARDLOOP + RightTurtleBot% = SPRITENEW(SpriteSheet%, 48, DONTSAVE) ' bottom of right turtle + SPRITEANIMATESET RightTurtleBot%, 48, 49 + SPRITEANIMATION RightTurtleBot%, ANIMATE, FORWARDLOOP + EnemySprite%(1) = SPRITENEW(SpriteSheet%, 10, DONTSAVE) ' brown mushroom + SPRITEANIMATESET EnemySprite%(1), 10, 11 + SPRITEANIMATION EnemySprite%(1), ANIMATE, FORWARDLOOP + EnemySprite%(2) = SPRITENEW(SpriteSheet%, 13, DONTSAVE) ' blue mushroom + SPRITEANIMATESET EnemySprite%(2), 13, 14 + SPRITEANIMATION EnemySprite%(2), ANIMATE, FORWARDLOOP + EnemySprite%(3) = SPRITENEW(SpriteSheet%, 16, DONTSAVE) ' gray mushroom + SPRITEANIMATESET EnemySprite%(3), 16, 17 + SPRITEANIMATION EnemySprite%(3), ANIMATE, FORWARDLOOP + EnemySprite%(4) = SPRITENEW(SpriteSheet%, 19, DONTSAVE) ' black helmet + SPRITEANIMATESET EnemySprite%(4), 19, 20 + SPRITEANIMATION EnemySprite%(4), ANIMATE, FORWARDLOOP + EnemySprite%(5) = SPRITENEW(SpriteSheet%, 21, DONTSAVE) ' blue helmet + SPRITEANIMATESET EnemySprite%(5), 21, 22 + SPRITEANIMATION EnemySprite%(5), ANIMATE, FORWARDLOOP + EnemySprite%(6) = SPRITENEW(SpriteSheet%, 23, DONTSAVE) ' gray helmet + SPRITEANIMATESET EnemySprite%(6), 23, 24 + SPRITEANIMATION EnemySprite%(6), ANIMATE, FORWARDLOOP + EnemySprite%(7) = SPRITENEW(SpriteSheet%, 25, DONTSAVE) ' spikey + SPRITEANIMATESET EnemySprite%(7), 25, 26 + SPRITEANIMATION EnemySprite%(7), ANIMATE, FORWARDLOOP + EnemySprite%(8) = SPRITENEW(SpriteSheet%, 27, DONTSAVE) ' red mushroom + EnemySprite%(9) = SPRITENEW(SpriteSheet%, 28, DONTSAVE) ' star + SPRITEANIMATESET EnemySprite%(9), 28, 31 + SPRITEANIMATION EnemySprite%(9), ANIMATE, BACKFORTHLOOP + EnemySprite%(10) = SPRITENEW(SpriteSheet%, 32, DONTSAVE) ' flower + SPRITEANIMATESET EnemySprite%(10), 32, 35 + SPRITEANIMATION EnemySprite%(10), ANIMATE, BACKFORTHLOOP + EnemySprite%(11) = SPRITENEW(SpriteSheet%, 36, DONTSAVE) ' green mushroom + EnemySprite%(12) = SPRITENEW(SpriteSheet%, 41, DONTSAVE) ' question box + SPRITEANIMATESET EnemySprite%(12), 41, 43 + SPRITEANIMATION EnemySprite%(12), ANIMATE, BACKFORTHLOOP + EnemySprite%(13) = SPRITENEW(SpriteSheet%, 44, DONTSAVE) ' bullet bill + For Count% = 1 To 13 + SPRITECOLLIDETYPE EnemySprite%(Count%), PIXELDETECT + Next Count% + +End Sub + +'-------------------------------------------------------------------------------------------------- + +'$INCLUDE:'sprite.bi' + diff --git a/samples/super-mario-jump/src/supermariojump.zip b/samples/super-mario-jump/src/supermariojump.zip new file mode 100644 index 0000000..7e637b9 Binary files /dev/null and b/samples/super-mario-jump/src/supermariojump.zip differ diff --git a/samples/tag-cloud.md b/samples/tag-cloud.md index 809ba95..d9e4d09 100644 --- a/samples/tag-cloud.md +++ b/samples/tag-cloud.md @@ -2,4 +2,4 @@ ## TAGS -[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 +[game:58](game.md) • [dos world:14](dos-world.md) • [screensaver:12](screensaver.md) • [3d:11](3d.md) • [screenblanker:11](screenblanker.md) • [fractal:10](fractal.md) • [9 lines:8](9-lines.md) • [graphics:8](graphics.md) • [data management:6](data-management.md) • [geometry:5](geometry.md) • [mandelbrot:5](mandelbrot.md) • [art:4](art.md) • [intersections:4](intersections.md) • [2d:3](2d.md) • [breakout:3](breakout.md) • [drawing:3](drawing.md) • [maze:3](maze.md) • [physics:3](physics.md) • [snake:3](snake.md) • [space shooter:3](space-shooter.md) • [starfield:3](starfield.md) • [tetris:3](tetris.md) • [trigonometry:3](trigonometry.md) • [artillery:2](artillery.md) • [ascii:2](ascii.md) • [bad boxes:2](bad-boxes.md) • [clock:2](clock.md) • [collisions:2](collisions.md) • [fire:2](fire.md) • [image processing:2](image-processing.md) • [julia set:2](julia-set.md) • [legacy:2](legacy.md) • [particles:2](particles.md) • [pendulum:2](pendulum.md) • [plasma:2](plasma.md) • [pong:2](pong.md) • [puzzle:2](puzzle.md) • [ray tracer:2](ray-tracer.md) • [ray tracing:2](ray-tracing.md) • [shooter:2](shooter.md) • [tic tac toe:2](tic-tac-toe.md) • [tui:2](tui.md) • [zen:2](zen.md) • [2 player:1](2-player.md) • [abacus:1](abacus.md) • [ai:1](ai.md) • [arithmetic:1](arithmetic.md) • [automata:1](automata.md) • [binary:1](binary.md) • [biorhythms:1](biorhythms.md) • [bitmap:1](bitmap.md) • [calculator:1](calculator.md) • [calendar:1](calendar.md) • [chess:1](chess.md) • [circuits:1](circuits.md) • [color picker:1](color-picker.md) • [conway:1](conway.md) • [counter:1](counter.md) • [cube:1](cube.md) • [curve:1](curve.md) • [defense:1](defense.md) • [desktop:1](desktop.md) • [digger:1](digger.md) • [draw:1](draw.md) • [editor:1](editor.md) • [eliza:1](eliza.md) • [ellipse:1](ellipse.md) • [fern:1](fern.md) • [fibonacci:1](fibonacci.md) • [filled circle:1](filled-circle.md) • [finance:1](finance.md) • [flappy bird:1](flappy-bird.md) • [flight:1](flight.md) • [floorscape:1](floorscape.md) • [frogger:1](frogger.md) • [frostbite:1](frostbite.md) • [gl:1](gl.md) • [graph:1](graph.md) • [gravity:1](gravity.md) • [hangman:1](hangman.md) • [hex:1](hex.md) • [image manipulation:1](image-manipulation.md) • [interface:1](interface.md) • [interpolation:1](interpolation.md) • [interpreter:1](interpreter.md) • [isometric:1](isometric.md) • [jpeg:1](jpeg.md) • [lander:1](lander.md) • [letter:1](letter.md) • [lights:1](lights.md) • [lisp:1](lisp.md) • [lorenz:1](lorenz.md) • [maptriangle:1](maptriangle.md) • [mario:1](mario.md) • [math:1](math.md) • [matrix:1](matrix.md) • [measure:1](measure.md) • [minecraft:1](minecraft.md) • [money:1](money.md) • [mosaic:1](mosaic.md) • [multiplayer:1](multiplayer.md) • [music:1](music.md) • [pdf:1](pdf.md) • [platform:1](platform.md) • [platformer:1](platformer.md) • [raycaster:1](raycaster.md) • [reflections:1](reflections.md) • [ripple:1](ripple.md) • [roguelike:1](roguelike.md) • [rotations:1](rotations.md) • [rpg:1](rpg.md) • [schematics:1](schematics.md) • [simulation:1](simulation.md) • [sort:1](sort.md) • [sound:1](sound.md) • [sphere:1](sphere.md) • [spiral:1](spiral.md) • [stocks:1](stocks.md) • [tank:1](tank.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) • [vectors:1](vectors.md) • [wave motion:1](wave-motion.md) • [wireframe:1](wireframe.md) \ No newline at end of file diff --git a/samples/tank.md b/samples/tank.md new file mode 100644 index 0000000..0e1efc3 --- /dev/null +++ b/samples/tank.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: TANK + +**[QB Tank Commander](qb-tank-commander/index.md)** + +[🐝 Matthew River Knight](matthew-river-knight.md) 🔗 [game](game.md), [tank](tank.md) + +'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ' ' ±± ±... diff --git a/samples/terry-ritchie.md b/samples/terry-ritchie.md new file mode 100644 index 0000000..a5773bc --- /dev/null +++ b/samples/terry-ritchie.md @@ -0,0 +1,27 @@ +[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 TERRY RITCHIE + +**[Bad Box Revenge](bad-box-revenge/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [bad boxes](bad-boxes.md) + +'** '** Revenge of the Bad Boxes! V1.0 '** '** by Terry Ritchie 02/11/13 '** + +**[Bad Boxes](bad-boxes/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [bad boxes](bad-boxes.md) + +'** '** Program Name: Bad Boxes '** Version : 1.0 '** Author : Terry Ritchie '** Date ... + +**[Flappy Bird](flappy-bird/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [flappy bird](flappy-bird.md) + +' ----------------------------------------------- ' QB64 FlappyBird Clone by Terry Ritchie 02/28/... + +**[Super Mario Jump](super-mario-jump/index.md)** + +[🐝 Terry Ritchie](terry-ritchie.md) 🔗 [game](game.md), [mario](mario.md) + +Super Mario Jump! diff --git a/samples/tetris.md b/samples/tetris.md index 16be392..ed5f3bd 100644 --- a/samples/tetris.md +++ b/samples/tetris.md @@ -2,6 +2,18 @@ ## SAMPLES: TETRIS +**[Didris](didris/index.md)** + +[🐝 Dietmar Moritz](dietmar-moritz.md) 🔗 [game](game.md), [tetris](tetris.md) + +'________________________This_is_the_unbelievable '________ÜÜÜ___ÜÜ_________ÜÜÜ____________ÜÜ '__... + +**[Future Blocks](future-blocks/index.md)** + +[🐝 Michael Fogleman](michael-fogleman.md) 🔗 [game](game.md), [tetris](tetris.md) + +Tetris clone by Michael Fogleman. + **[QBlocks](qblocks/index.md)** [🐝 Microsoft](microsoft.md) 🔗 [game](game.md), [tetris](tetris.md) diff --git a/samples/texel-raytracer/index.md b/samples/texel-raytracer/index.md index 7749a9c..52289b6 100644 --- a/samples/texel-raytracer/index.md +++ b/samples/texel-raytracer/index.md @@ -18,9 +18,9 @@ Pure QB Realtime Raytracer Demo. Translated to/optimized for QB by Antoni Gual a > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "raytra1b.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/texel-raytracer/src/raytra1b.bas) -* [RUN "raytra1b.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/texel-raytracer/src/raytra1b.bas) -* [PLAY "raytra1b.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/texel-raytracer/src/raytra1b.bas) +* [LOAD "raytra1b.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/texel-raytracer/src/raytra1b.bas) +* [RUN "raytra1b.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/texel-raytracer/src/raytra1b.bas) +* [PLAY "raytra1b.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/texel-raytracer/src/raytra1b.bas) ### File(s) diff --git a/samples/tic-tac-toe-3d/img/screenshot.png b/samples/tic-tac-toe-3d/img/screenshot.png new file mode 100644 index 0000000..cb5e4c3 Binary files /dev/null and b/samples/tic-tac-toe-3d/img/screenshot.png differ diff --git a/samples/tic-tac-toe-3d/index.md b/samples/tic-tac-toe-3d/index.md new file mode 100644 index 0000000..b27bbd5 --- /dev/null +++ b/samples/tic-tac-toe-3d/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: TIC TAC TOE 3D + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 qbguy](../qbguy.md) + +### Description + +```text +The goal is to get four in a row while preventing the computer from doing the same. Move by clicking the mouse. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "tictactoe3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/tic-tac-toe-3d/src/tictactoe3d.bas) +* [RUN "tictactoe3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/tic-tac-toe-3d/src/tictactoe3d.bas) +* [PLAY "tictactoe3d.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/tic-tac-toe-3d/src/tictactoe3d.bas) + +### File(s) + +* [tictactoe3d.bas](src/tictactoe3d.bas) + +🔗 [game](../game.md), [tic tac toe](../tic-tac-toe.md) diff --git a/samples/tic-tac-toe-3d/src/tictactoe3d.bas b/samples/tic-tac-toe-3d/src/tictactoe3d.bas new file mode 100644 index 0000000..6b93b95 --- /dev/null +++ b/samples/tic-tac-toe-3d/src/tictactoe3d.bas @@ -0,0 +1,261 @@ +DECLARE SUB SHOWWIN (C%, R%, p%, COLOUR%) +DECLARE SUB MAKEMOVE (X%, Y%, Z%, COLOUR%) +DECLARE SUB GETMOVE (X%, Y%, Z%) +DefInt A-Z +Dim E(7), PEEKB(1999) +Randomize Timer +Cls +GoSub INIT +E(1) = 254: E(2) = 18: E(3) = 2: E(4) = 1: E(5) = 2: E(6) = 66: E(7) = 255 +Q = 564: G = 628: L = 768 +For K = G To G + 63 + PEEKB(K) = 128 +Next +For K = S To S + 75 + PEEKB(K) = 128 +Next +100 Call GETMOVE(C, R, p) +X = 16 * (p - 1) + 4 * (R - 1) + C - 1 +If PEEKB(G + X) <> 128 Then GoTo 100 +Call MAKEMOVE(C, R, p, 1) +M = -1: GoSub 1000 +GoSub 2000 +If W Then Call SHOWWIN(C, R, p, 1): End +If T Then Locate 15, 33: Print " --- Tie game --- ": End +GoSub 3000 +M = 1: GoSub 1000 +GoSub 2000 +GoSub 7000 +If W Then Call SHOWWIN(C, R, p, 4): End +If T Then Locate 15, 33: Print " --- Tie game --- ": End +GoTo 100 + +1000 +PEEKB(G + X) = 128 + M +For K = L To L + 303 + If PEEKB(K) <> X Then GoTo 1001 + Y = S + (K - L) \ 4: V = PEEKB(Y) + If V = 0 Then GoTo 1001 + V = V - 128 + If V = 0 Then + V = M + 128 + Else + If (Sgn(V) = Sgn(M)) Then + V = V + M + 128 + Else + V = 0 + End If + End If + PEEKB(Y) = V +1001 Next +Return + +2000 +W = 0: T = 1 +For K = S To S + 75 + V = PEEKB(K) + If V Then T = 0 + If Abs(V - 128) = 4 Then W = 1 +Next +Return + +3000 +For K = Q To Q + 63 + PEEKB(K) = 0 +Next +For K = S To S + 75 + N = PEEKB(K) - 128 + If N = -128 Then GoTo 3002 + Z = E(N + 4) + F = L + 4 * (K - S) + For J = F To F + 3 + X = PEEKB(J) + If PEEKB(G + X) <> 128 Then GoTo 3001 + V = PEEKB(Q + X) + If V >= 254 Then GoTo 3001 + V = V + Z: If Z >= 254 Then V = Z + If V > 255 Then V = 255 + PEEKB(Q + X) = V + 3001 Next +3002 Next +V9 = 0 +For K = 0 To 63 + V = PEEKB(Q + K) + If V > 64 And V < 128 Then V = V - 64 + If V > 16 And V < 32 Then V = V - 16 + If V > V9 Then V9 = V + PEEKB(Q + K) = V +Next +If V9 < 32 Then GoTo 4000 +3800 X = 0 +Do + If PEEKB(Q + X) = V9 Then Return + X = X + 1 +Loop +4000 P4 = 16 +For K = L To L + 287 Step 16 + p = 0 + For J = K To K + 15 + p = p + PEEKB(PEEKB(J) + G) - 128 + Next + If p > P4 Then GoTo 4002 + If p < P4 Then + P4 = p: V4 = 0: N4 = 0 + End If + For J = K To K + 15 + X1 = PEEKB(J) + V = PEEKB(Q + X1) + If V = 0 Then GoTo 4001 + If V < V4 Then GoTo 4001 + If V > V4 Then + V4 = V: N4 = 1 + Else + N4 = N4 + 1 + If Int(Rnd(1) * N4) <> 0 Then GoTo 4001 + End If + X = X1 + 4001 Next +4002 Next +If V4 = 0 Then GoTo 3800 +Return + +7000 +p = X \ 16 + 1 +X = X - 16 * (p - 1) +R = X \ 4 + 1 +C = (X Mod 4) + 1 +Call MAKEMOVE(C, R, p, 4) +Return + + +INIT: +L = 768 +For K = 0 To 63 + PEEKB(L + K) = K +Next +L = L + 64 +a = 4: B = 16 +For S = 1 To 4 + GoSub 19000 +Next +a = 16: B = 1 +For S = 1 To 13 Step 4 + GoSub 19000 +Next +S = 1: a = 5: B = 16: GoSub 19000 +S = 13: a = -3: B = 16: GoSub 19000 +S = 1: a = 20: B = 1: GoSub 19000 +S = 49: a = -12: B = 1: GoSub 19000 +S = 1: a = 17: B = 4: GoSub 19000 +S = 49: a = -15: B = 4: GoSub 19000 +S = 1: D = 21: GoSub 18000 +S = 16: D = 11: GoSub 18000 +S = 4: D = 19: GoSub 18000 +S = 13: D = 13: GoSub 18000 +GoSub DRAWBD +Return + +18000 +For K = S To S + 3 * D Step D + PEEKB(L) = K - 1: L = L + 1 +Next +Return + +19000 +For J = S To S + 3 * B Step B + For K = J To J + 3 * a Step a + PEEKB(L) = K - 1: L = L + 1 + Next +Next +Return + +DRAWBD: +Screen 12 +Line (0, 0)-(639, 479), 7, BF +Line (23, 23)-(616, 456), 0, B +Line (24, 24)-(615, 455), 14, BF +Y = 130: GoSub GRID +Y = 230: GoSub GRID +Y = 330: GoSub GRID +Y = 430: GoSub GRID +Paint (24, 24), 3, 0 +Return + +GRID: +For K = 0 To 4 + Line (120 + 20 * K, Y - 20 * K)-(440 + 20 * K, Y - 20 * K), 0 + Line (120 + 80 * K, Y)-(200 + 80 * K, Y - 80), 0 + Line (117 - K, Y + 2)-(201 - K, Y - 82), 0 + Line (437 + K, Y + 2)-(521 + K, Y - 82), 0 +Next +For K = 0 To 1 + Line (117 - K, Y + K + 1)-(437 + K, Y + K + 1), 0 + Line (201 - K, Y - 81 - K)-(521 + K, Y - 81 - K), 0 +Next +Return + +Sub GETMOVE (X, Y, Z) + GETPOS: + If InKey$ = Chr$(27) Then End + Call getmouse(XX, YY, ZZ) + Z = (YY - 30) \ 100 + 1 + If Z < 1 Or Z > 4 Then GoTo GETPOS + Y = ((YY - 30) \ 20) Mod 5 + If Y < 1 Or Y > 4 Then GoTo GETPOS + If XX + YY - 150 - 100 * Z < 0 Then GoTo GETPOS + X = (XX + YY - 150 - 100 * Z) \ 80 + 1 + If X < 1 Or X > 4 Then GoTo GETPOS + If ZZ = 0 Then GoTo GETPOS +End Sub + +Sub MAKEMOVE (X, Y, Z, COLOUR) + Circle (80 * X - 20 * Y + 170, 100 * Z + 20 * Y - 60), 35, 8, , , 4 * (8 / 35) / 3 + Paint Step(0, 0), COLOUR, 8 + Circle (80 * X - 20 * Y + 170, 100 * Z + 20 * Y - 60), 15, 8, , , 4 * (3 / 15) / 3 + Paint Step(0, 0), COLOUR + 8, 8 +End Sub + +Sub SHOWWIN (C, R, p, COLOUR) + Dim CC(0 To 3), RR(0 To 3), PP(0 To 3) + For DC = -1 To 1 + For DR = -1 To 1 + For DP = -1 To 1 + If DC <> 0 Or DR <> 0 Or DP <> 0 Then + NDX = 0 + For K = -3 To 3 + If C + K * DC < 1 Or C + K * DC > 4 Then GoTo 1 + If R + K * DR < 1 Or R + K * DR > 4 Then GoTo 1 + If p + K * DP < 1 Or p + K * DP > 4 Then GoTo 1 + ID = Point(80 * (C + K * DC) - 20 * (R + K * DR) + 170, 100 * (p + K * DP) + 20 * (R + K * DR) - 60) + If ID <> COLOUR + 8 Then Exit For + CC(NDX) = C + K * DC + RR(NDX) = R + K * DR + PP(NDX) = p + K * DP + NDX = NDX + 1 + If NDX = 4 Then GoTo SHOW + 1 Next + End If + Next + Next + Next + SHOW: + For K = 0 To 3 + Circle (80 * CC(K) - 20 * RR(K) + 170, 100 * PP(K) + 20 * RR(K) - 60), 35, COLOUR + 8, , , 4 * (8 / 35) / 3 + Paint Step(0, 0), COLOUR + 8 + Circle Step(0, 0), 15, 15, , , 4 * (3 / 15) / 3 + Paint Step(0, 0), 15 + Next +End Sub + +Sub getmouse (x%, y%, b%) + b% = 0 + wheel% = 0 + Do + If _MouseButton(1) Then b% = b% Or 1 + If _MouseButton(2) Then b% = b% Or 2 + If _MouseButton(3) Then b% = b% Or 4 + Loop Until _MouseInput = 0 + x% = _MouseX + y% = _MouseY +End Sub + diff --git a/samples/tic-tac-toe.md b/samples/tic-tac-toe.md index 1c2a429..6591702 100644 --- a/samples/tic-tac-toe.md +++ b/samples/tic-tac-toe.md @@ -7,3 +7,9 @@ [🐝 Paul Meyer](paul-meyer.md) 🔗 [game](game.md), [tic tac toe](tic-tac-toe.md) Tic tac toe game by Paul Meyer. + +**[Tic Tac Toe 3D](tic-tac-toe-3d/index.md)** + +[🐝 qbguy](qbguy.md) 🔗 [game](game.md), [tic tac toe](tic-tac-toe.md) + +The goal is to get four in a row while preventing the computer from doing the same. Move by click... diff --git a/samples/tic-tac-toe/index.md b/samples/tic-tac-toe/index.md index 5dc1d4e..9914da2 100644 --- a/samples/tic-tac-toe/index.md +++ b/samples/tic-tac-toe/index.md @@ -18,9 +18,9 @@ Tic tac toe game by Paul Meyer. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "tictac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/tic-tac-toe/src/tictac.bas) -* [RUN "tictac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/tic-tac-toe/src/tictac.bas) -* [PLAY "tictac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/tic-tac-toe/src/tictac.bas) +* [LOAD "tictac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/tic-tac-toe/src/tictac.bas) +* [RUN "tictac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/tic-tac-toe/src/tictac.bas) +* [PLAY "tictac.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/tic-tac-toe/src/tictac.bas) ### File(s) diff --git a/samples/tor-myklebust.md b/samples/tor-myklebust.md new file mode 100644 index 0000000..9fac1a9 --- /dev/null +++ b/samples/tor-myklebust.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 TOR MYKLEBUST + +**[Mandelbrot Zoomer](mandelbrot-zoomer/index.md)** + +[🐝 Tor Myklebust](tor-myklebust.md) 🔗 [fractal](fractal.md), [mandelbrot](mandelbrot.md) + +'QBDEMO (C) 2002 Tor Myklebust 'The fractal zoomer should run at 60FPS on a 500MHz machine. I d... diff --git a/samples/torus-demo/index.md b/samples/torus-demo/index.md index c8a1640..8b3090c 100644 --- a/samples/torus-demo/index.md +++ b/samples/torus-demo/index.md @@ -23,9 +23,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "torus.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/torus-demo/src/torus.bas) -* [RUN "torus.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/torus-demo/src/torus.bas) -* [PLAY "torus.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/torus-demo/src/torus.bas) +* [LOAD "torus.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/torus-demo/src/torus.bas) +* [RUN "torus.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/torus-demo/src/torus.bas) +* [PLAY "torus.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/torus-demo/src/torus.bas) ### File(s) diff --git a/samples/tower-of-hanoi/index.md b/samples/tower-of-hanoi/index.md index c465f4f..d9f4ff4 100644 --- a/samples/tower-of-hanoi/index.md +++ b/samples/tower-of-hanoi/index.md @@ -16,9 +16,9 @@ Print "The puzzle starts with the discs stacked in order of size on one peg." > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "tower.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/tower-of-hanoi/src/tower.bas) -* [RUN "tower.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/tower-of-hanoi/src/tower.bas) -* [PLAY "tower.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/tower-of-hanoi/src/tower.bas) +* [LOAD "tower.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/tower-of-hanoi/src/tower.bas) +* [RUN "tower.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/tower-of-hanoi/src/tower.bas) +* [PLAY "tower.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/tower-of-hanoi/src/tower.bas) ### File(s) diff --git a/samples/trig-demo/img/screenshot.png b/samples/trig-demo/img/screenshot.png new file mode 100644 index 0000000..d65dd75 Binary files /dev/null and b/samples/trig-demo/img/screenshot.png differ diff --git a/samples/trig-demo/index.md b/samples/trig-demo/index.md new file mode 100644 index 0000000..cb7afbb --- /dev/null +++ b/samples/trig-demo/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: TRIG DEMO + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 STxAxTIC](../stxaxtic.md) + +### Description + +```text +Trivial trigonometry demo. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "trig-demo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/trig-demo/src/trig-demo.bas) +* [RUN "trig-demo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/trig-demo/src/trig-demo.bas) +* [PLAY "trig-demo.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/trig-demo/src/trig-demo.bas) + +### File(s) + +* [trig-demo.bas](src/trig-demo.bas) + +🔗 [trigonometry](../trigonometry.md) diff --git a/samples/trig-demo/src/trig-demo.bas b/samples/trig-demo/src/trig-demo.bas new file mode 100644 index 0000000..d1a5345 --- /dev/null +++ b/samples/trig-demo/src/trig-demo.bas @@ -0,0 +1,175 @@ +Screen 12 + +' Origin in Cartesian coordinates. (Changes when mouse is clicked.) +OriginX = -100 +OriginY = -100 + +' Point of interest in Cartesian coordinates. (Changes while mouse moves.) +x = _MouseX +y = _MouseY +If x > 0 And x < 640 And y > 0 And y < 480 Then + GoSub unconvert + OriginX = x + OriginY = y +Else + ThePointX = 100 + ThePointY = 100 +End If + +' Main loop. +Do + Do While _MouseInput + x = _MouseX + y = _MouseY + Loop + If x > 0 And x < 640 And y > 0 And y < 480 Then + + GoSub unconvert + ThePointX = x + ThePointY = y + + If _MouseButton(1) Then + x = _MouseX + y = _MouseY + GoSub unconvert + OriginX = x + OriginY = y + End If + + End If + + GoSub DrawEverything + +Loop + +End + +DrawEverything: +Cls +' Make Cartesian grid. +For x = OriginX To 640 Step 10 + Line (x, 0)-(x, 480), 8 +Next +For x = OriginX To 0 Step -10 + Line (x, 0)-(x, 480), 8 +Next +For y = OriginY To 480 Step 10 + Line (0, -y + 240)-(640, -y + 240), 8 +Next +For y = OriginY To -240 Step -10 + Line (0, -y + 240)-(640, -y + 240), 8 +Next +x = OriginX +y = OriginY +GoSub convert +Line (0, y)-(640, y), 7 +Line (x, 0)-(x, 480), 7 +_PrintString (640 - 8 * 6, y), "X-axis" +_PrintString (x, 0), "Y-axis" +_PrintString (x, y), "Origin" +' Draw the circle on which the position vector lives. +Radius = Sqr((ThePointX - OriginX) ^ 2 + (ThePointY - OriginY) ^ 2) +x = OriginX +y = OriginY +GoSub convert +Circle (x, y), Radius, 7 +' Draw the vertical component. +x = OriginX +y = OriginY +GoSub convert +x1 = x +y1 = y +x = ThePointX +y = OriginY +GoSub convert +x2 = x +y2 = y +Line (x1, y1)-(x2, y2), 9 +Line (x1, y1 + 1)-(x2, y2 + 1), 9 +Line (x1, y1 - 1)-(x2, y2 - 1), 9 +' Draw the horizontal component. +x = ThePointX +y = OriginY +GoSub convert +x1 = x +y1 = y +x = ThePointX +y = ThePointY +GoSub convert +x2 = x +y2 = y +Line (x1, y1)-(x2, y2), 4 +Line (x1 - 1, y1)-(x2 - 1, y2), 4 +Line (x1 + 1, y1)-(x2 + 1, y2), 4 +' Draw position vector (aka the Hypotenuse). +x = OriginX +y = OriginY +GoSub convert +x1 = x +y1 = y +x = ThePointX +y = ThePointY +GoSub convert +x2 = x +y2 = y +Line (x1, y1)-(x2, y2), 10 +Line (x1 + 1, y1)-(x2 + 1, y2), 10 +Line (x1, y1 + 1)-(x2, y2 + 1), 10 +' Write text. +Color 7 +Locate 3, 60: Print "-------Origin-------" +Locate 4, 60: Print "Cartesian/Polar/Qb64:" +'Locate 3, 61: Print "X=0 , Y=0" +'Locate 4, 61: Print "R=0 , Ang=undef" +Locate 5, 61: Print "x="; OriginX + 320; ", "; "y="; -OriginY + 240 +Locate 7, 60: Print "-------Cursor-------" +Locate 8, 60: Print "Cartesian/Polar/Qb64:" +Locate 9, 61: Print "X="; ThePointX - OriginX; ", "; "Y="; ThePointY - OriginY +' Deal with radius calculation. +Radius = Sqr((ThePointX - OriginX) ^ 2 + (ThePointY - OriginY) ^ 2) +If Radius < .0001 Then Radius = .0001 +Locate 10, 61: Print "R="; Int(Radius); ", "; "Ang="; TheAngle +' Deal with the anlge calculation. +xdiff = ThePointX - OriginX +ydiff = ThePointY - OriginY +If xdiff > 0 And ydiff > 0 Then ' First quadrant + TheAngle = Int((180 / 3.14159) * Atn(ydiff / xdiff)) +End If +If xdiff < 0 And ydiff > 0 Then ' Second quadrant + TheAngle = 180 + Int((180 / 3.14159) * Atn(ydiff / xdiff)) +End If +If xdiff < 0 And ydiff < 0 Then ' Third quadrant + TheAngle = 180 + Int((180 / 3.14159) * Atn(ydiff / xdiff)) +End If +If xdiff > 0 And ydiff < 0 Then ' Fourth quadrant + TheAngle = 360 + Int((180 / 3.14159) * Atn(ydiff / xdiff)) +End If +If Sqr(ydiff ^ 2) < .0001 Then ydiff = .0001 +If Sqr(xdiff ^ 2) < .0001 Then xdiff = .0001 +Locate 11, 61: Print "x="; ThePointX + 320; ", "; "y="; -ThePointY + 240 +Locate 13, 60: Print "--------Trig--------" +Locate 14, 61: Print "sin(Ang)=";: Color 4: Print "Opp";: Color 7: Print "/";: Color 10: Print "Hyp";: Color 7 +Locate 15, 61: Print " ="; Using "##.###"; ydiff / Radius +Locate 16, 61: Print "cos(Ang)=";: Color 9: Print "Adj";: Color 7: Print "/";: Color 10: Print "Hyp";: Color 7 +Locate 17, 61: Print " ="; Using "##.###"; xdiff / Radius +Locate 18, 61: Print "tan(Ang)=";: Color 4: Print "Opp";: Color 7: Print "/";: Color 9: Print "Adj";: Color 7 +Locate 19, 61: Print " ="; Using "####.###"; ydiff / xdiff +_Display +Return + +convert: +' Converts Cartesian coordinates to QB64 coordinates. +x0 = x: y0 = y +x = x0 + 320 +y = -y0 + 240 +Return + +unconvert: +' Converts QB64 coordinates to Cartesian coordinates. +x0 = x: y0 = y +x = x0 - 320 +y = -y0 + 240 +Return + + + diff --git a/samples/trigonometry.md b/samples/trigonometry.md index ec8e186..7e68c0b 100644 --- a/samples/trigonometry.md +++ b/samples/trigonometry.md @@ -13,3 +13,9 @@ Graphical Lissajou's Figures. For added eye-candy-ness, I've changed the plot l [🐝 *missing*](author-missing.md) 🔗 [trigonometry](trigonometry.md) Sine Wave Explorer + +**[Trig Demo](trig-demo/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [trigonometry](trigonometry.md) + +Trivial trigonometry demo. diff --git a/samples/tui.md b/samples/tui.md new file mode 100644 index 0000000..2a0ef33 --- /dev/null +++ b/samples/tui.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: TUI + +**[Bar Demo](bar-demo/index.md)** + +[🐝 Douglas Park](douglas-park.md) 🔗 [tui](tui.md), [dos world](dos-world.md) + +' BARDEMO.BAS ' by Douglas Park ' Copyright (C) 1995 DOS World Magazine ' Published in Issue #19,... + +**[TUI](tui/index.md)** + +[🐝 Fellippe Heitor](fellippe-heitor.md) 🔗 [interface](interface.md), [tui](tui.md) + +Text User Interface for QB64 projects diff --git a/samples/tui/img/screenshot.png b/samples/tui/img/screenshot.png new file mode 100644 index 0000000..27c8bc1 Binary files /dev/null and b/samples/tui/img/screenshot.png differ diff --git a/samples/tui/index.md b/samples/tui/index.md new file mode 100644 index 0000000..0a73552 --- /dev/null +++ b/samples/tui/index.md @@ -0,0 +1,25 @@ +[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: TUI + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Fellippe Heitor](../fellippe-heitor.md) + +### Description + +```text +Text User Interface for QB64 projects +``` + +### File(s) + +* [tui.bas](src/tui.bas) +* [tui.zip](src/tui.zip) + +🔗 [interface](../interface.md), [tui](../tui.md) + + +Reference: [github.com](https://github.com/FellippeHeitor/tui) diff --git a/samples/tui/src/tui.bas b/samples/tui/src/tui.bas new file mode 100644 index 0000000..b539561 --- /dev/null +++ b/samples/tui/src/tui.bas @@ -0,0 +1,1282 @@ +Option _Explicit +On Error GoTo oops +$Resize:On + +Dim As String temp +Dim As Long form, closebutton, button1, check1, label1, label2, label3 +Dim As Long filemenu, filemenunew, filemenuexit +Dim As Long editmenu, editmenuundo, editmenuredo, editmenuproperties +Dim As Long viewmenu, viewmenusubs, viewmenulinenumbers, viewmenuwarnings +Dim As Long viewmenulinenumbersshowhide, viewmenulinenumbersshowbackground, viewmenulinenumbersshowseparator +Dim As Long statusbar + +tui "set highintensity=true" +statusbar = tui("add type=label;name=statusbar;caption= Ready.;x=1;y=25;w=80;h=1;fg=0;bg=3") + +tui "set defaults;fg=0;bg=7;fghover=7;bghover=0;fghotkey=15" + +filemenu = tui("add type=menubar;parent=0;name=filemenu;caption=&File") +tui "set defaults;parent=filemenu" +filemenunew = tui("add type=menuitem;name=filemenunew;caption=&New Ctrl+N") +tui "add type=menuitem;caption=-" +filemenuexit = tui("add type=menuitem;name=filemenuexit;caption=E&xit") + +editmenu = tui("add type=menubar;parent=0;name=editmenu;caption=&Edit") +tui "set defaults;parent=editmenu" +editmenuundo = tui("add type=menuitem;name=editmenuundo;caption=&Undo Ctrl+Z") +editmenuredo = tui("add type=menuitem;name=editmenuredo;caption=&Redo Ctrl+Y;disabled=true") +tui "add type=menuitem;caption=-" +editmenuproperties = tui("add type=menuitem;name=editmenuproperties;caption=&Properties...") + +viewmenu = tui("add type=menubar;parent=0;name=viewmenu;caption=&View") +tui "set defaults;parent=viewmenu" +viewmenusubs = tui("add type=menuitem;name=viewmenusubs;caption=&SUBs... F2") +viewmenulinenumbers = tui("add type=menuitem;name=viewmenulinenumbers;caption=&Line Numbers;special=submenu") +tui "add type=menuitem;caption=-" +viewmenuwarnings = tui("add type=menuitem;name=viewmenuwarnings;caption=Compiler &Warnings... Ctrl+W") + +tui "set defaults;parent=viewmenulinenumbers" +viewmenulinenumbersshowhide = tui("add type=menuitem;name=viewmenulinenumbersshowhide;caption=&Show Line Numbers") +viewmenulinenumbersshowbackground = tui("add type=menuitem;name=viewmenulinenumbersshowbackground;caption=&Background Color;special=submenu") +viewmenulinenumbersshowseparator = tui("add type=menuitem;name=viewmenulinenumbersshowseparator;caption=Sho&w Separator") + +tui "set defaults;parent=viewmenulinenumbersshowbackground" +tui "add type=menuitem;name=viewmenubgbright;caption=&Bright mode" +tui "add type=menuitem;name=viewmenubgdark;caption=&Dark side of the moon" + +Dim As _Byte updateLabel +Dim As Long i +updateLabel = -1 +Do + While _Resize + Dim As Integer newWidth, newHeight + Dim As _Byte willResize + newWidth = _ResizeWidth + newHeight = _ResizeHeight + willResize = -1 + Wend + + If willResize Then + willResize = 0 + Width newWidth \ 8, newHeight \ 16 + tui "set control=statusbar;y=" + Str$(_Height) + ";w=" + Str$(_Width) + End If + + Color 25, 0 + Cls + For i = 1 To _Height + _PrintString (1, i), String$(_Width, 176) + Next + + If updateLabel Then + If tui("get control=check1;value") Then + tui "set control=label1;caption=The box is checked.;color=inherit" + Else + tui "set control=label1;caption=The box is unchecked.;color=inherit" + End If + End If + + temp$ = "get hover" + tui temp$ + tui "set control=label2;caption=Hover: " + temp$ + ";color=inherit" + + temp$ = "get focus" + tui temp$ + tui "set control=label3;caption=Focus: " + temp$ + ";color=inherit" + + If tui("clicked") Then + tui "set control=statusbar;caption= Ready." + Select Case tui("control") + Case button1 + If tui("get control=editmenu;disabled") Then + tui "set control=editmenu;disabled=false" + Else + tui "set control=editmenu;disabled=true" + End If + Case check1 + updateLabel = -1 + Case filemenuexit + System + Case closebutton + tui "delete control=form1" + Case filemenunew + '--------------------------------------- + tui "set defaults;parent=0" + form = tui("add type=form;name=form1;caption=Hello, world!;align=center;fghover=16;bghover=7;w=50;h=11") + + tui "set defaults;parent=form1" + closebutton = tui("add type=button;name=closebutton;caption=[X];fg=20;fghover=28;y=0;align=top-right;shadow=false;canreceivefocus=false") + check1 = tui("add type=checkbox;value=-1;name=check1;caption=&I'm a check box.;x=2;y=2") + label1 = tui("add type=label;name=label1;caption=Nothing to show;x=2;y=3;bghover=-1;special=autosize") + label2 = tui("add type=label;name=label2;caption=Hover:;x=2;y=4;bghover=-1;special=autosize") + label3 = tui("add type=label;name=label3;caption=Focus:;x=2;y=5;bghover=-1;special=autosize") + button1 = tui("add type=button;name=button1;caption=Click &me;align=center;y=8;w=20;fg=31;bg=9;fghover=16;bghover=7") + + 'tui "set modal;control=form1" + tui "set focus;control=check1" + '--------------------------------------- + Case label1 + tui "set control=label1;caption=This is not a button!;fg=4;fghover=20" + updateLabel = 0 + Case viewmenusubs + tui "reset" + Case Else + temp$ = "get control=" + Str$(tui("control")) + ";name" + tui temp$ + tui "set control=statusbar;caption= This control has no action assigned to it: " + temp$ + End Select + End If + _Display + _Limit 30 +Loop + +oops: +Resume Next + +Sub tui (action As String) + Dim As Long result + result = tui&(action) +End Sub + +Function tui& (action As String) Static + Type newControl + As Long type, parent, x, y, w, h, value, keybind + As Integer fg, bg, fghover, bghover, fghotkey, hotkeypos + As String name, special, caption, text, hotkey + As _Byte canReceiveFocus, active, disabled, hidden, shadow + End Type + + Dim As String result, temp + Dim As Long i, j, this, k, modalForm + Dim As Long menuPanel(100), totalMenuPanels, totalMenuPanelItems + Dim As String menuPanelParents + Dim As Long x, y, mx, my, oldmx, oldmy, mb, hover, mouseDownOn, clicked, lastClickedControl, focus, prevFocus + Dim As Long mouseDownX, mouseDownY, hotkeyX, hotkeyY + Dim As Integer prevFG, prevBG + Dim As _Byte setup, mouseDown, fetchMouse, showFocus, fetchedKeyboard + Dim As _Byte draggingForm, highIntensity, captionSet, hasMenuBar + Dim As _Byte keyboardControl, showHotKey, prevShowHotKey, willActivateMenu + + If setup = 0 Then + ReDim control(100) As newControl + Dim defaults As newControl + defaults.shadow = -1 + defaults.fg = -1 + defaults.bg = -1 + defaults.fghover = -1 + defaults.bghover = -1 + fetchMouse = -1 + showFocus = -1 + hasMenuBar = 0 + setup = -1 + End If + + Select Case getAction$(action) + Case "reset" + ReDim control(100) As newControl + modalForm = 0 + hasMenuBar = 0 + Case "add" + this = 0 + For i = 1 To UBound(control) + If control(i).active = 0 Then this = i: Exit For + Next + + If this = 0 And i > UBound(control) Then + ReDim _Preserve control(UBound(control) + 100) As newControl + this = i + End If + + control(this) = defaults + + If passed(action, "type") Then control(this).type = controlType(getParam(action, "type")) + Select Case getParam(action, "type") + Case "button", "checkbox", "textbox" + control(this).canReceiveFocus = -1 + End Select + + If passed(action, "name") Then control(this).name = getParam(action, "name") + If passed(action, "parent") Then + temp = getParam(action, "parent") + GoSub getParentID + control(i).parent = j + End If + If passed(action, "shadow") Then control(this).shadow = (LCase$(getParam(action, "shadow")) = "true") + If passed(action, "canreceivefocus") Then control(this).canReceiveFocus = (LCase$(getParam(action, "canreceivefocus")) = "true") + If passed(action, "hidden") Then control(this).hidden = (LCase$(getParam(action, "hidden")) = "true") + If passed(action, "disabled") Then control(this).disabled = (LCase$(getParam(action, "disabled")) = "true") + If passed(action, "caption") Then + temp = getParam(action, "caption") + control(this).caption = temp + If control(this).type <> controlType("form") Then + control(this).hotkeypos = InStr(control(this).caption, "&") + If control(this).hotkeypos Then + control(this).caption = Left$(control(this).caption, control(this).hotkeypos - 1) + Mid$(control(this).caption, control(this).hotkeypos + 1) + control(this).hotkey = Mid$(control(this).caption, control(this).hotkeypos, 1) + End If + End If + End If + If passed(action, "text") Then control(this).text = getParam(action, "text") + + If passed(action, "special") Then control(this).special = getParam(action, "special") + Select Case control(this).special + Case "autosize" + control(this).w = Len(control(this).caption) + End Select + + If passed(action, "w") Then + temp = getParam(action, "w") + If temp = "auto" Then + GoSub setAutoWidth + ElseIf Val(temp) > 0 Then + control(this).w = Val(temp) + End If + Else + GoSub setAutoWidth + End If + + If passed(action, "h") Then + control(this).h = Val(getParam(action, "h")) + Else + control(this).h = 1 + End If + + result = getParam(action, "align") + Select Case result + Case "center" + If control(this).parent = 0 Then + control(this).x = (_Width - control(this).w) \ 2 + control(this).y = (_Height - control(this).h) \ 2 + Else + control(this).x = (control(control(this).parent).w - control(this).w) \ 2 + control(this).y = (control(control(this).parent).h - control(this).h) \ 2 + End If + While control(this).x < 1 + control(this).x = control(this).x + 1 + Wend + While control(this).y < 1 + control(this).y = control(this).y + 1 + Wend + Case "bottom-center" + If control(this).parent = 0 Then + control(this).x = (_Width - control(this).w) \ 2 + control(this).y = (_Height - control(this).h) + Else + control(this).x = (control(control(this).parent).w - control(this).w) \ 2 + control(this).y = (control(control(this).parent).h - control(this).h) - 2 + End If + Case "bottom-right" + If control(this).parent = 0 Then + control(this).x = (_Width - control(this).w) + control(this).y = (_Height - control(this).h) + Else + control(this).x = (control(control(this).parent).w - control(this).w) - 2 + control(this).y = (control(control(this).parent).h - control(this).h) - 2 + End If + Case "bottom-left" + control(this).x = 2 + If control(this).parent = 0 Then + control(this).y = (_Height - control(this).h) + Else + control(this).y = (control(control(this).parent).h - control(this).h) - 2 + End If + Case "top-center" + control(this).y = 1 + If control(this).parent = 0 Then + control(this).x = (_Width - control(this).w) \ 2 + Else + control(this).x = (control(control(this).parent).w - control(this).w) \ 2 + End If + Case "top-right" + control(this).y = 1 + If control(this).parent = 0 Then + control(this).x = (_Width - control(this).w) + Else + control(this).x = (control(control(this).parent).w - control(this).w) - 2 + End If + Case "top-left" + control(this).x = 2 + control(this).y = 1 + End Select + + If passed(action, "x") Then control(this).x = Val(getParam(action, "x")) + If passed(action, "y") Then control(this).y = Val(getParam(action, "y")) + + result = getParam(action, "color") + If result = "inherit" And control(this).parent > 0 Then + control(this).fg = control(control(this).parent).fg + control(this).bg = control(control(this).parent).bg + control(this).fghover = control(control(this).parent).fghover + control(this).bghover = control(control(this).parent).bghover + ElseIf result = "defaults" Then + control(this).fg = defaults.fg + control(this).bg = defaults.bg + control(this).fghover = defaults.fghover + control(this).bghover = defaults.bghover + control(this).fghotkey = defaults.fghotkey + End If + + If passed(action, "fg") Then control(this).fg = Val(getParam(action, "fg")) + If passed(action, "bg") Then control(this).bg = Val(getParam(action, "bg")) + If passed(action, "fghover") Then control(this).fghover = Val(getParam(action, "fghover")) + If passed(action, "bghover") Then control(this).bghover = Val(getParam(action, "bghover")) + + If passed(action, "value") Then control(this).value = Val(getParam(action, "value")) + If passed(action, "keybind") Then control(this).keybind = Val(getParam(action, "keybind")) + + If control(this).type = controlType("menubar") Then + If hasMenuBar = 0 Then + hasMenuBar = -1 + Dim As Long lastMenuBarX, lastMenuBarLen + lastMenuBarX = 3 + End If + control(this).y = 1 + control(this).x = lastMenuBarX + lastMenuBarLen + lastMenuBarX = control(this).x + lastMenuBarLen = Len(control(this).caption) + 2 + End If + + control(this).active = -1 + tui& = this + Case "clicked" + PCopy 0, 127 + Do + PCopy 127, 0 + If fetchMouse Or (control(focus).type = controlType("menubar") Or control(menuPanel(totalMenuPanels)).active) Then + While _MouseInput: Wend + End If + mx = _MouseX + my = _MouseY + + If keyboardControl Then + If mx <> oldmx Or my <> oldmy Then + keyboardControl = 0 + End If + End If + + mb = _MouseButton(1) + clicked = 0 + hover = 0 + fetchedKeyboard = 0 + prevFG = _DefaultColor + prevBG = _BackgroundColor + showHotKey = _KeyDown(100308) Or _KeyDown(100307) + + If showHotKey Then + If prevShowHotKey = 0 Then + prevShowHotKey = -1 + willActivateMenu = -1 + End If + Else + prevShowHotKey = 0 + If willActivateMenu = -1 And modalForm = 0 Then + willActivateMenu = 0 + If control(focus).type = controlType("menubar") Then + If control(prevFocus).type <> controlType("menubar") Then focus = prevFocus + ElseIf control(focus).type <> controlType("menupanel") And control(focus).type <> controlType("menuitem") Then + For i = 1 To UBound(control) + If control(i).type = controlType("menubar") Then + If control(focus).type <> controlType("menubar") Then prevFocus = focus + focus = i + Exit For + End If + Next + ElseIf control(focus).type = controlType("menuitem") Then + GoSub closeMenuPanel + focus = control(menuPanel(totalMenuPanels)).parent + End If + End If + End If + + For i = 1 To UBound(control) + If control(i).active = 0 Then _Continue + + If modalForm > 0 Then + 'modal forms and their controls are drawn exclusively + If control(i).type = controlType("form") And i <> modalForm Then _Continue + If control(i).type <> controlType("form") And control(i).parent <> modalForm Then _Continue + End If + + Select Case control(i).type + Case controlType("menubar"), controlType("menuitem") + 'deal with menus last + _Continue + End Select + + x = 0 + y = 0 + hotkeyX = 0 + hotkeyY = 0 + this = i + Do + x = x + control(this).x + y = y + control(this).y + this = control(this).parent + Loop While this > 0 + + If control(i).parent > 0 Then + tuiSetColor control(control(i).parent).fg, control(control(i).parent).bg + End If + + tuiSetColor control(i).fg, control(i).bg + + If keyboardControl = 0 And mx >= x And mx <= x + control(i).w - 1 And my >= y And my <= y + control(i).h - 1 Then + If Not draggingForm And Not control(menuPanel(totalMenuPanels)).active Then + hover = i + Select Case control(i).type + Case controlType("form") + Case Else + tuiSetColor control(i).fghover, control(i).bghover + End Select + End If + End If + + Select Case control(i).type + Case controlType("form") + If control(i).shadow Then + boxShadow x, y, control(i).w, control(i).h + Else + box x, y, control(i).w, control(i).h + End If + If Len(control(i).caption) Then + tuiSetColor control(i).fghover, control(i).bghover + _PrintString (control(i).x, control(i).y), Space$(control(i).w) + _PrintString (x + (control(i).w - (Len(control(i).caption)) + 2) \ 2, y), " " + control(i).caption + " " + End If + If focus = i Then Locate , , 0 + showFocus = -1 'if a form is up, focus is always shown + k = _KeyHit 'read keyboard input if a form is up + fetchedKeyboard = -1 + Case controlType("button") + If control(i).shadow And ((focus = i And _KeyDown(32)) Or (mouseDownOn = i And hover = i)) Then + x = x + 1 + End If + _PrintString (x, y), Space$(control(i).w) + temp = Left$(control(i).caption, control(i).w) + _PrintString (x + (control(i).w - Len(temp)) \ 2, y), temp + hotkeyX = (x + (control(i).w - Len(temp)) \ 2) + control(i).hotkeypos - 1 + hotkeyY = y + If control(i).shadow And (hover <> i Or (hover = i And mouseDownOn <> i)) And (focus <> i Or (focus = i And _KeyDown(32) = 0)) Then + If control(i).parent > 0 Then + tuiSetColor 0, control(control(i).parent).bg + Else + tuiSetColor 0, prevBG + End If + _PrintString (x + control(i).w, y), Chr$(220) + _PrintString (x + 1, y + 1), String$(control(i).w, 223) + End If + If showFocus And focus = i Then Locate y, x + (control(i).w - Len(control(i).caption)) \ 2, 1 + Case controlType("checkbox") + If control(i).value Then + temp = "[X] " + Else + temp = "[ ] " + End If + _PrintString (x, y), temp + Left$(control(i).caption, control(i).w - 4) + hotkeyX = x + Len(temp) + control(i).hotkeypos - 1 + hotkeyY = y + If showFocus And focus = i Then Locate y, x + 1, 1 + Case controlType("label") + _PrintString (x, y), Space$(control(i).w) + _PrintString (x, y), Left$(control(i).caption, control(i).w) + hotkeyX = x + control(i).hotkeypos - 1 + hotkeyY = y + Case controlType("textbox") + If focus = i And fetchedKeyboard = 0 Then + k = _KeyHit 'read keyboard input for textbox control + fetchedKeyboard = -1 + End If + End Select + + If control(i).hotkeypos > 0 And showHotKey And control(menuPanel(totalMenuPanels)).active = 0 Then + tuiSetColor control(i).fghotkey, -1 + _PrintString (hotkeyX, hotkeyY), control(i).hotkey + End If + Next + + If hasMenuBar Then + Dim firstMenuFound As _Byte + firstMenuFound = 0 + For i = 1 To UBound(control) + If control(i).type = controlType("menubar") Then + If control(i).hidden Or control(i).active = 0 Then _Continue + If focus = i Then Locate , , 0 + If firstMenuFound = 0 Then + x = control(i).x + tuiSetColor control(i).fg, control(i).bg + _PrintString (1, 1), Space$(_Width) + firstMenuFound = -1 + Else + x = x + control(i).w + 2 + control(i).x = x + End If + If modalForm Then + tuiSetColor 8, control(i).bg + Else + If keyboardControl = 0 And (modalForm = 0 And my = 1 And mx >= control(i).x And mx < control(i).x + Len(control(i).caption) + 2) Then + If draggingForm = 0 And control(i).disabled = 0 Then + tuiSetColor control(i).fghover, control(i).bghover + hover = i + If control(focus).type = controlType("menubar") Then focus = i + If totalMenuPanels > 0 And control(menuPanel(totalMenuPanels)).parent <> focus Then GoSub openMenuPanel + ElseIf control(i).disabled Then + tuiSetColor 8, control(i).bg + End If + If focus = i Then Locate , , 0 + ElseIf focus = i Or InStr(menuPanelParents, MKL$(i) + MKL$(-1)) > 0 Then + tuiSetColor control(i).fghover, control(i).bghover + Else + If control(menuPanel(totalMenuPanels)).parent <> i Or control(menuPanel(totalMenuPanels)).active = 0 Then + If control(i).disabled Then + tuiSetColor 8, control(i).bg + Else + tuiSetColor control(i).fg, control(i).bg + End If + ElseIf totalMenuPanels Then + tuiSetColor control(i).fghover, control(i).bghover + End If + End If + End If + _PrintString (x, 1), " " + control(i).caption + " " + If (control(focus).type = controlType("menubar") And control(i).disabled = 0) Or (modalForm = 0 And control(i).hotkeypos > 0 And showHotKey And totalMenuPanels = 0 And control(i).disabled = 0) Then + tuiSetColor control(i).fghotkey, -1 + _PrintString (x + control(i).hotkeypos, 1), control(i).hotkey + End If + End If + Next + End If + + If totalMenuPanels > 0 Then + Dim As String menuCaption, menuShortcut + Dim As Long willActivateMenuPanel + Dim As Single activateMenuPanelTimer + + For this = 1 To totalMenuPanels + tuiSetColor control(menuPanel(this)).fg, control(menuPanel(this)).bg + boxShadow control(menuPanel(this)).x, control(menuPanel(this)).y, control(menuPanel(this)).w, control(menuPanel(this)).h + If keyboardControl = 0 And mx >= control(menuPanel(this)).x And mx <= control(menuPanel(this)).x + control(menuPanel(this)).w - 1 And my >= control(menuPanel(this)).y And my <= control(menuPanel(this)).y + control(menuPanel(this)).h - 1 Then + hover = menuPanel(this) + End If + For i = 1 To UBound(control) + If control(i).type = controlType("menuitem") And control(i).parent = control(menuPanel(this)).parent Then + If focus = i Then Locate , , 0 + If control(i).caption = "-" Then + tuiSetColor control(menuPanel(this)).fg, control(menuPanel(this)).bg + _PrintString (control(i).x - 2, control(i).y), Chr$(195) + String$(control(menuPanel(this)).w - 2, 196) + Chr$(180) + Else + menuShortcut = "" + j = InStr(control(i).caption, Space$(2)) + If j > 0 And control(i).special <> "submenu" Then + menuCaption = Left$(control(i).caption, j - 1) + menuShortcut = Mid$(control(i).caption, j + 2) + ElseIf control(i).special = "submenu" Then + menuCaption = control(i).caption + menuShortcut = Chr$(16) + Else + menuCaption = control(i).caption + End If + + If keyboardControl = 0 And (mx >= control(i).x - 1 And mx <= control(menuPanel(this)).x + control(menuPanel(this)).w - 2 And my = control(i).y) Then + hover = i + focus = i + End If + + If (focus = i And control(i).parent = control(menuPanel(totalMenuPanels)).parent) Or InStr(menuPanelParents, MKL$(i) + MKL$(-1)) > 0 Then + tuiSetColor control(menuPanel(this)).fghover, control(menuPanel(this)).bghover + _PrintString (control(i).x - 1, control(i).y), Space$(control(menuPanel(this)).w - 2) + If focus = i And control(i).special = "submenu" And willActivateMenuPanel = 0 Then + willActivateMenuPanel = i: activateMenuPanelTimer = Timer + ElseIf focus = i And control(i).special <> "submenu" And willActivateMenuPanel > 0 Then + willActivateMenuPanel = 0 + End If + Else + If control(i).disabled Then + tuiSetColor 8, control(menuPanel(this)).bg + Else + tuiSetColor control(menuPanel(this)).fg, control(menuPanel(this)).bg + End If + End If + _PrintString (control(i).x, control(i).y), menuCaption + If Len(menuShortcut) Then + _PrintString (control(menuPanel(this)).x + control(menuPanel(this)).w - Len(menuShortcut) - 2, control(i).y), menuShortcut + End If + If control(i).hotkeypos > 0 And control(i).disabled = 0 Then + Color control(i).fghotkey + _PrintString (control(i).x + control(i).hotkeypos - 1, control(i).y), control(i).hotkey + End If + End If + End If + Next + Next + End If + + If timeElapsedSince(activateMenuPanelTimer) >= .5 And willActivateMenuPanel > 0 And InStr(menuPanelParents, MKL$(willActivateMenuPanel) + MKL$(-1)) = 0 And keyboardControl = 0 Then + focus = willActivateMenuPanel + GoSub openMenuPanel + willActivateMenuPanel = 0 + ElseIf timeElapsedSince(activateMenuPanelTimer) >= .5 And willActivateMenuPanel > 0 Then + willActivateMenuPanel = 0 + End If + + If control(focus).type = controlType("menuitem") Then + While totalMenuPanels > 0 And control(menuPanel(totalMenuPanels)).parent <> control(focus).parent And control(menuPanel(totalMenuPanels)).parent <> focus + GoSub closeMenuPanel + Wend + End If + + Color prevFG, prevBG + + If k Then GoSub enableKeyboardControl + Select EveryCase k + Case -9, -25 + this = focus + If _KeyDown(100304) Or _KeyDown(100303) Then + Do + focus = focus - 1 + If focus < 1 Then focus = UBound(control) + If focus = this Then Exit Do + Loop While control(focus).canReceiveFocus = 0 + Else + Do + focus = focus + 1 + If focus > UBound(control) Then focus = 1 + If focus = this Then Exit Do + Loop While control(focus).canReceiveFocus = 0 + End If + Case -13 + Select Case control(focus).type + Case controlType("button"), controlType("menuitem") + If control(focus).disabled = 0 Then clicked = focus Else Exit Case + If control(focus).type = controlType("menuitem") Then + If control(focus).special = "submenu" Then + clicked = 0 + GoSub openMenuPanel + Else + While totalMenuPanels + GoSub closeMenuPanel + Wend + End If + End If + Case controlType("menubar") + GoSub openMenuPanel + End Select + Case -32 + Select Case control(focus).type + Case controlType("button") + clicked = focus + Case controlType("checkbox") + control(focus).value = Not control(focus).value + clicked = focus + End Select + Case 27 + If totalMenuPanels Then focus = control(menuPanel(totalMenuPanels)).parent: GoSub closeMenuPanel + k = 0 + Case 18432 'up + Select Case control(focus).type + Case controlType("menubar") + GoSub openMenuPanel + Case controlType("menuitem") + this = focus + Do + this = this - 1 + If this < 1 Then this = UBound(control) + If this = focus Then Exit Do + If control(this).type = controlType("menuitem") And control(this).parent = control(focus).parent And control(this).caption <> "-" And control(this).hidden = 0 Then + focus = this + Exit Do + End If + Loop + End Select + Case 20480 'down + Select Case control(focus).type + Case controlType("menubar") + GoSub openMenuPanel + Case controlType("menuitem") + this = focus + Do + this = this + 1 + If this > UBound(control) Then this = 1 + If this = focus Then Exit Do + If control(this).type = controlType("menuitem") And control(this).parent = control(focus).parent And control(this).caption <> "-" And control(this).hidden = 0 Then + focus = this + Exit Do + End If + Loop + End Select + Case 19200 'left + Select EveryCase control(focus).type + Case controlType("menubar"), controlType("menuitem") + If control(focus).type = controlType("menuitem") Then + If control(control(menuPanel(totalMenuPanels)).parent).type = controlType("menuitem") Then + focus = control(menuPanel(totalMenuPanels)).parent + GoSub closeMenuPanel + Exit Case + Else + focus = control(focus).parent + End If + End If + this = focus + Do + this = this - 1 + If this < 1 Then this = UBound(control) + If this = focus Then Exit Do + If control(this).type = controlType("menubar") And control(this).disabled = 0 And control(this).hidden = 0 Then + focus = this + If control(menuPanel(totalMenuPanels)).active Then GoSub openMenuPanel + Exit Do + End If + Loop + End Select + Case 19712 'right + Select Case control(focus).type + Case controlType("menubar"), controlType("menuitem") + If control(focus).type = controlType("menuitem") Then + If control(focus).special = "submenu" Then + GoSub openMenuPanel + Exit Case + Else + focus = control(focus).parent + End If + End If + this = focus + Do + this = this + 1 + If this > UBound(control) Then this = 1 + If this = focus Then Exit Do + If control(this).type = controlType("menubar") And control(this).disabled = 0 And control(this).hidden = 0 Then + focus = this + If control(menuPanel(totalMenuPanels)).active Then GoSub openMenuPanel + Exit Do + End If + Loop + End Select + Case 65 To 90, 97 To 122 'A-Z, a-z + If showHotKey Or control(menuPanel(totalMenuPanels)).active Or control(focus).type = controlType("menubar") Then + Dim As String hotkeySearch + hotkeySearch = UCase$(Chr$(k)) + For i = 1 To UBound(control) + If UCase$(control(i).hotkey) = hotkeySearch Then + If control(menuPanel(totalMenuPanels)).active = 0 Or (control(menuPanel(totalMenuPanels)).active And control(i).parent = control(menuPanel(totalMenuPanels)).parent) Or (control(menuPanel(totalMenuPanels)).active And control(i).type = controlType("menubar")) Then + 'alt+hotkey emulates click on control + If control(i).type = controlType("menubar") Then + If control(i).disabled = 0 And control(i).hidden = 0 Then + mb = 0 + mouseDown = -1 + mouseDownOn = i + hover = i + prevFocus = focus + GoSub openMenuPanel + End If + Else + mb = 0 + mouseDown = -1 + mouseDownOn = i + hover = i + focus = i + End If + willActivateMenu = 0 + Exit For + End If + End If + Next + End If + Case Else + If k > 0 Then + For i = 1 To UBound(control) + If control(i).keybind = k Then + 'hitting a control's keybind emulates click + mb = 0 + mouseDown = -1 + mouseDownOn = i + hover = i + focus = i + Exit For + End If + Next + End If + End Select + + If mb Then + If mouseDown Then + 'drag + If draggingForm Then + control(mouseDownOn).x = control(mouseDownOn).x - (mouseDownX - mx) + control(mouseDownOn).y = control(mouseDownOn).y - (mouseDownY - my) + If control(mouseDownOn).x < 1 Then control(mouseDownOn).x = 1 + If hasMenuBar Then + If control(mouseDownOn).y < 2 Then control(mouseDownOn).y = 2 + Else + If control(mouseDownOn).y < 1 Then control(mouseDownOn).y = 1 + End If + If control(mouseDownOn).x + control(mouseDownOn).w > _Width Then control(mouseDownOn).x = _Width - control(mouseDownOn).w + 1 + If control(mouseDownOn).y + control(mouseDownOn).h > _Height Then control(mouseDownOn).y = _Height - control(mouseDownOn).h + 1 + mouseDownX = mx + mouseDownY = my + End If + Else + mouseDown = -1 + mouseDownOn = hover + If hover = 0 Then + While totalMenuPanels + GoSub closeMenuPanel + Wend + ElseIf control(hover).type = controlType("form") Then + If my = control(hover).y Then draggingForm = -1 + ElseIf control(hover).type = controlType("menubar") Then + If control(menuPanel(totalMenuPanels)).active And hover = control(menuPanel(totalMenuPanels)).parent Then + While totalMenuPanels + GoSub closeMenuPanel + Wend + Else + GoSub openMenuPanel + End If + Else + draggingForm = 0 + If control(mouseDownOn).canReceiveFocus Then focus = hover + End If + mouseDownX = mx + mouseDownY = my + End If + Else + If mouseDown Then + If mouseDownOn > 0 And mouseDownOn = hover Then + If control(mouseDownOn).disabled = 0 Then + clicked = mouseDownOn + + Select Case control(clicked).type + Case controlType("checkbox") + control(clicked).value = Not control(clicked).value + Case controlType("menuitem") + If control(clicked).special <> "submenu" Then + While totalMenuPanels + GoSub closeMenuPanel + Wend + Else + GoSub openMenuPanel + End If + End Select + End If + ElseIf mouseDownOn = 0 Then + focus = 0 + End If + If focus = 0 And control(menuPanel(totalMenuPanels)).active Then GoSub closeMenuPanel + End If + mouseDown = 0 + mouseDownOn = 0 + draggingForm = 0 + End If + + If clicked Then + lastClickedControl = clicked + tui& = -1 + Exit Function + Else + If modalForm = 0 And control(focus).type <> controlType("menubar") And control(menuPanel(totalMenuPanels)).active = 0 Then + Exit Function + End If + End If + _Display + _Limit 30 + Loop + Case "control" + tui& = lastClickedControl + Case "get" + temp = getParam(action, "control") + + If Len(temp) = 0 Then + Select Case getNextParam(action) + Case "hover" + tui = hover + action = control(hover).name + Exit Function + Case "focus" + tui = focus + action = control(focus).name + Exit Function + End Select + End If + + GoSub getControlID + + For i = 1 To 2 + temp = getNextParam(action) + Next + + Select Case temp + Case "parent": tui& = control(this).parent + Case "x": tui& = control(this).x + Case "y": tui& = control(this).y + Case "w": tui& = control(this).w + Case "h": tui& = control(this).h + Case "value": tui& = control(this).value + Case "fg": tui& = control(this).fg + Case "bg": tui& = control(this).bg + Case "fghover": tui& = control(this).fghover + Case "bghover": tui& = control(this).bghover + Case "shadow": tui& = control(this).shadow + Case "disabled": tui& = control(this).disabled + Case "hidden": tui& = control(this).hidden + Case "canreceivefocus": tui& = control(this).canReceiveFocus + Case "name": action = control(this).name + Case "caption": action = control(this).caption + Case "text": action = control(this).text + End Select + Case "set" + Do + temp = getNextParam(action) + If Len(temp) = 0 Then Exit Do + result = getParam(action, temp) + Select Case temp + Case "fetchmouse" + fetchMouse = (LCase$(result) = "true") + Case "showfocus" + showFocus = (LCase$(result) = "true") + Case "highintensity" + highIntensity = (LCase$(result) = "true") + If highIntensity Then _Blink Off Else _Blink On + Case "focus" + temp = getParam(action, "control") + GoSub getControlID + focus = this + Case "modal" + temp = getParam(action, "control") + GoSub getControlID + If this = 0 Then + modalForm = 0 + ElseIf control(this).type = controlType("form") Then + modalForm = this + End If + Case "defaults" + temp = getParam(action, "parent") + If Len(temp) Then + GoSub getParentID + defaults.parent = j + End If + + If passed(action, "w") Then defaults.w = Val(getParam(action, "w")) + If passed(action, "h") Then defaults.h = Val(getParam(action, "h")) + If passed(action, "x") Then defaults.x = Val(getParam(action, "x")) + If passed(action, "y") Then defaults.y = Val(getParam(action, "y")) + If passed(action, "value") Then defaults.value = Val(getParam(action, "value")) + + If passed(action, "fg") Then defaults.fg = Val(getParam(action, "fg")) + If passed(action, "bg") Then defaults.bg = Val(getParam(action, "bg")) + If passed(action, "fghover") Then defaults.fghover = Val(getParam(action, "fghover")) + If passed(action, "bghover") Then defaults.bghover = Val(getParam(action, "bghover")) + If passed(action, "fghotkey") Then defaults.fghotkey = Val(getParam(action, "fghotkey")) + + If passed(action, "shadow") Then defaults.shadow = (LCase$(getParam(action, "shadow")) = "true") + Case "control" + temp = getParam(action, temp) + GoSub getControlID + + captionSet = 0 + If passed(action, "caption") Then + control(this).caption = getParam(action, "caption") + captionSet = -1 + End If + + If passed(action, "text") Then + control(this).text = getParam(action, "text") + End If + + If passed(action, "w") Then + control(this).w = Val(getParam(action, "w")) + ElseIf captionSet And control(this).special = "autosize" Then + Select Case control(this).type + Case controlType("label") + control(this).w = Len(control(this).caption) + Case controlType("button") + control(this).w = Len(control(this).caption) + 2 + Case controlType("checkbox") + control(this).w = Len(control(this).caption) + 4 + End Select + End If + + If passed(action, "h") Then control(this).h = Val(getParam(action, "h")) + If passed(action, "x") Then control(this).x = Val(getParam(action, "x")) + If passed(action, "y") Then control(this).y = Val(getParam(action, "y")) + + result = getParam(action, "color") + If result = "inherit" And control(this).parent > 0 Then + control(this).fg = control(control(this).parent).fg + control(this).bg = control(control(this).parent).bg + control(this).fghover = control(control(this).parent).fghover + control(this).bghover = control(control(this).parent).bghover + ElseIf result = "defaults" Then + control(this).fg = defaults.fg + control(this).bg = defaults.bg + control(this).fghover = defaults.fghover + control(this).bghover = defaults.bghover + control(this).fghotkey = defaults.fghotkey + End If + + If passed(action, "fg") Then control(this).fg = Val(getParam(action, "fg")) + If passed(action, "bg") Then control(this).bg = Val(getParam(action, "bg")) + If passed(action, "fghover") Then control(this).fghover = Val(getParam(action, "fghover")) + If passed(action, "bghover") Then control(this).bghover = Val(getParam(action, "bghover")) + + If passed(action, "value") Then control(this).value = Val(getParam(action, "value")) + If passed(action, "keybind") Then control(this).keybind = Val(getParam(action, "keybind")) + + If passed(action, "shadow") Then control(this).shadow = (LCase$(getParam(action, "shadow")) = "true") + If passed(action, "disabled") Then control(this).disabled = (LCase$(getParam(action, "disabled")) = "true") + If passed(action, "hidden") Then control(this).hidden = (LCase$(getParam(action, "hidden")) = "true") + If passed(action, "canreceivefocus") Then control(this).canReceiveFocus = (LCase$(getParam(action, "canreceivefocus")) = "true") + End Select + Loop + Case "delete" + temp = getParam(action, "control") + If Len(temp) Then + GoSub getControlID + If this Then + control(this).active = 0 + If modalForm = this Then modalForm = 0 + For i = this + 1 To UBound(control) + If control(i).parent = this Then control(i).active = 0 + Next + End If + End If + Case Else + Cls + Print "unknown action: "; getAction(action) + End + End Select + + Exit Function + + getParentID: + 'temp contains the name of the parent control + For j = 1 To UBound(control) + If control(j).name = temp Then + Return + End If + Next + j = 0 + Return + + getControlID: + 'temp contains the name of the control we're looking for + If Val(temp) > 0 Then + this = Val(temp) + Else + this = 0 + For j = 1 To UBound(control) + If control(j).name = temp Then + this = j + Return + End If + Next + End If + Return + + setAutoWidth: + control(this).w = Len(control(this).caption) + If control(this).type = controlType("checkbox") Then control(this).w = control(this).w + 4 + Return + + openMenuPanel: + If control(hover).type <> controlType("menubar") And control(hover).type <> controlType("menuitem") Then hover = focus + If control(hover).type <> controlType("menubar") And control(hover).type <> controlType("menuitem") Then Return + If modalForm Then Return + + If control(menuPanel(totalMenuPanels)).parent = hover Then Return + If control(hover).type = controlType("menuitem") And control(hover).special <> "submenu" Then Return + + If control(hover).type = controlType("menubar") Then + While totalMenuPanels + GoSub closeMenuPanel + Wend + End If + + totalMenuPanels = totalMenuPanels + 1 + menuPanel(totalMenuPanels) = tui("add type=menupanel;name=tuimenupanel" + Str$(totalMenuPanels)) + menuPanelParents = menuPanelParents + MKL$(hover) + MKL$(-1) + control(menuPanel(totalMenuPanels)).fg = control(hover).fg + control(menuPanel(totalMenuPanels)).bg = control(hover).bg + control(menuPanel(totalMenuPanels)).fghover = control(hover).fghover + control(menuPanel(totalMenuPanels)).bghover = control(hover).bghover + + If control(hover).type = controlType("menuitem") Then + control(menuPanel(totalMenuPanels)).x = control(hover).x + control(menuPanel(totalMenuPanels - 1)).w - 2 + control(menuPanel(totalMenuPanels)).y = control(hover).y - 1 + Else + control(menuPanel(totalMenuPanels)).x = control(hover).x + control(menuPanel(totalMenuPanels)).y = control(hover).y + 1 + End If + + control(menuPanel(totalMenuPanels)).active = -1 + control(menuPanel(totalMenuPanels)).w = 4 + control(menuPanel(totalMenuPanels)).parent = hover + + totalMenuPanelItems = 0 + focus = 0 + For j = 1 To UBound(control) + If control(j).type = controlType("menuitem") And control(j).parent = hover Then + If focus = 0 Then focus = j + totalMenuPanelItems = totalMenuPanelItems + 1 + control(j).x = control(menuPanel(totalMenuPanels)).x + 2 + control(j).y = control(menuPanel(totalMenuPanels)).y + totalMenuPanelItems + If control(j).special = "submenu" And Right$(control(j).caption, 3) <> Space$(3) Then + control(j).caption = control(j).caption + Space$(3) + End If + If control(menuPanel(totalMenuPanels)).w < Len(control(j).caption) + 4 Then control(menuPanel(totalMenuPanels)).w = Len(control(j).caption) + 4 + End If + Next + control(menuPanel(totalMenuPanels)).h = totalMenuPanelItems + 2 + + While control(menuPanel(totalMenuPanels)).x + control(menuPanel(totalMenuPanels)).w > _Width + control(menuPanel(totalMenuPanels)).x = control(menuPanel(totalMenuPanels)).x - 1 + If control(menuPanel(totalMenuPanels)).x < 1 Then + Color 7, 0 + Cls + Print "Error positioning menu on screen." + End + End If + For j = 1 To UBound(control) + If control(j).type = controlType("menuitem") And control(j).parent = control(menuPanel(totalMenuPanels)).parent Then control(j).x = control(j).x - 1 + Next + Wend + Return + + closeMenuPanel: + If totalMenuPanels > 0 Then + control(menuPanel(totalMenuPanels)).active = 0 + totalMenuPanels = totalMenuPanels - 1 + menuPanelParents = Left$(menuPanelParents, Len(menuPanelParents) - 8) + If totalMenuPanels = 0 Then focus = prevFocus + End If + Return + + enableKeyboardControl: + keyboardControl = -1 + oldmx = mx + oldmy = my + Return + +End Function + +Sub tuiSetColor (fg As Integer, bg As Integer) + If fg > -1 Then Color fg + If bg > -1 Then Color , bg +End Sub + +Function controlType& (__a$) + Dim typeList$ + typeList$ = "@form@button@checkbox@label@textbox@menubar@menuitem@menupanel@" + + controlType& = InStr(typeList$, LCase$("@" + __a$ + "@")) +End Function + +Function getAction$ (__a$) + Dim As Long position + Dim As String result, sep + + sep = " " + position = InStr(__a$, sep) + If position = 0 Then + getAction$ = __a$ + __a$ = "" + Else + result = LCase$(Left$(__a$, position - 1)) + If InStr(result, "=") > 0 Then Exit Function + __a$ = Mid$(__a$, position + 1) + getAction$ = result + End If +End Function + +Function passed%% (__action$, __parameter$) + Dim As String s, p, os, sep + Dim As Long position + + sep = ";" + os = sep + __action$ + sep + s = LCase$(os) + p = sep + LCase$(__parameter$) + "=" + + position = _InStrRev(s, p) + passed%% = position > 0 +End Function + +Function getParam$ (__action$, __parameter$) + Dim As String s, p, os, result, sep + Dim As Long position + + sep = ";" + os = sep + __action$ + sep + s = LCase$(os) + p = sep + LCase$(__parameter$) + "=" + + position = _InStrRev(s, p) + If position = 0 Then Exit Function + + result = Mid$(os, position + Len(p)) + getParam$ = Left$(result, InStr(result, sep) - 1) +End Function + +Function getNextParam$ (__action$) Static + Dim As String lastAction, thisAction, sep, temp + Dim As Long position, prevPosition, findEqual + + sep = ";" + + If __action$ <> lastAction Then + lastAction = __action$ + thisAction = sep + __action$ + sep + position = 1 + End If + + prevPosition = position + position = InStr(prevPosition + 1, thisAction, sep) + If position Then + temp = Mid$(thisAction, prevPosition + 1, position - prevPosition - 1) + findEqual = InStr(temp, "=") + If findEqual Then + getNextParam$ = Left$(temp, findEqual - 1) + Else + getNextParam$ = temp + End If + End If +End Function + + +Sub box (x As Long, y As Long, w As Long, h As Long) + Dim As Long y2 + + _PrintString (x, y), Chr$(218) + String$(w - 2, 196) + Chr$(191) + For y2 = y + 1 To y + h - 2 + _PrintString (x, y2), Chr$(179) + Space$(w - 2) + Chr$(179) + Next + _PrintString (x, y + h - 1), Chr$(192) + String$(w - 2, 196) + Chr$(217) +End Sub + +Sub boxShadow (x As Long, y As Long, w As Long, h As Long) + box x, y, w, h + + Dim As Long y2, x2 + + 'shadow + Color 8, 0 + For y2 = y + 1 To y + h - 1 + For x2 = x + w To x + w + 1 + If x2 <= _Width And y2 <= _Height Then + _PrintString (x2, y2), Chr$(Screen(y2, x2)) + End If + Next + Next + + y2 = y + h + If y2 <= _Height Then + For x2 = x + 2 To x + w + 1 + If x2 <= _Width Then + _PrintString (x2, y2), Chr$(Screen(y2, x2)) + End If + Next + End If +End Sub + +Function timeElapsedSince! (startTime!) + If startTime! > Timer Then startTime! = startTime! - 86400 + timeElapsedSince! = Timer - startTime! +End Function + diff --git a/samples/tui/src/tui.zip b/samples/tui/src/tui.zip new file mode 100644 index 0000000..7993acc Binary files /dev/null and b/samples/tui/src/tui.zip differ diff --git a/samples/turtle-graphics/index.md b/samples/turtle-graphics/index.md index 8e7c442..f621e5c 100644 --- a/samples/turtle-graphics/index.md +++ b/samples/turtle-graphics/index.md @@ -18,9 +18,9 @@ Basic "turtle graphics" setup. Draws a Koch snowflake by default. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "turtle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/turtle-graphics/src/turtle.bas) -* [RUN "turtle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/turtle-graphics/src/turtle.bas) -* [PLAY "turtle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/turtle-graphics/src/turtle.bas) +* [LOAD "turtle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/turtle-graphics/src/turtle.bas) +* [RUN "turtle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/turtle-graphics/src/turtle.bas) +* [PLAY "turtle.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/turtle-graphics/src/turtle.bas) ### File(s) diff --git a/samples/twirl/index.md b/samples/twirl/index.md index 743c86e..8242564 100644 --- a/samples/twirl/index.md +++ b/samples/twirl/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "twirl2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/twirl/src/twirl2.bas) -* [RUN "twirl2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/twirl/src/twirl2.bas) -* [PLAY "twirl2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/twirl/src/twirl2.bas) +* [LOAD "twirl2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/twirl/src/twirl2.bas) +* [RUN "twirl2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/twirl/src/twirl2.bas) +* [PLAY "twirl2.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/twirl/src/twirl2.bas) ### File(s) diff --git a/samples/vector-field/img/vectorfield.png b/samples/vector-field/img/vectorfield.png new file mode 100644 index 0000000..1cf3239 Binary files /dev/null and b/samples/vector-field/img/vectorfield.png differ diff --git a/samples/vector-field/index.md b/samples/vector-field/index.md new file mode 100644 index 0000000..d359bfb --- /dev/null +++ b/samples/vector-field/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: VECTOR FIELD + +![vectorfield.png](img/vectorfield.png) + +### Author + +[🐝 STxAxTIC](../stxaxtic.md) + +### Description + +```text +Vector field demonstration. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "vector-field.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/vector-field/src/vector-field.bas) +* [RUN "vector-field.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/vector-field/src/vector-field.bas) +* [PLAY "vector-field.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/vector-field/src/vector-field.bas) + +### File(s) + +* [vector-field.bas](src/vector-field.bas) + +🔗 [2d](../2d.md), [vectors](../vectors.md) diff --git a/samples/vector-field/src/vector-field.bas b/samples/vector-field/src/vector-field.bas new file mode 100644 index 0000000..63b36d3 --- /dev/null +++ b/samples/vector-field/src/vector-field.bas @@ -0,0 +1,216 @@ +OPTION _EXPLICIT + +DO UNTIL _SCREENEXISTS: LOOP +_TITLE "Vector Field" + +' Meta +RANDOMIZE TIMER + +CONST Aquamarine = _RGB32(127, 255, 212) +CONST Lime = _RGB32(0, 255, 0) + +DIM SHARED XSize +DIM SHARED YSize +DIM SHARED XCells +DIM SHARED YCells +DIM SHARED NPC +XSize = 30 +YSize = 30 +XCells = 30 +YCells = 30 +NPC = .1 * SQR(XCells * YCells) +SCREEN _NEWIMAGE(XSize * XCells, YSize * YCells, 32) + + +TYPE Vector + x AS DOUBLE + y AS DOUBLE +END TYPE + +TYPE FieldLine + Center AS Vector + Tangent AS Vector +END TYPE + +TYPE Particle + Displacement AS Vector + Velocity AS Vector + Shade AS _UNSIGNED LONG +END TYPE + +TYPE Charge + Center AS Vector + Radial AS Vector + Angular AS Vector +END TYPE + +DIM SHARED VectorField(XCells, YCells) AS FieldLine +DIM SHARED Particles(XCells, YCells, NPC) AS Particle +DIM SHARED Charges(100) AS Charge +DIM SHARED ChargeCount + +ChargeCount = 1 +Charges(ChargeCount).Center.x = 0 +Charges(ChargeCount).Center.y = 0 +Charges(ChargeCount).Radial.x = .05 +Charges(ChargeCount).Radial.y = .05 +Charges(ChargeCount).Angular.x = 0 +Charges(ChargeCount).Angular.y = 0 + +DIM i AS INTEGER +DIM j AS INTEGER +DIM k AS INTEGER + +FOR i = 1 TO XCells + FOR j = 1 TO YCells + VectorField(i, j).Center.x = (1 / 2) * XSize * (2 * i - XCells) - XSize / 2 + VectorField(i, j).Center.y = (1 / 2) * YSize * (2 * j - YCells) - YSize / 2 + FOR k = 1 TO NPC + Particles(i, j, k).Shade = Lime + Particles(i, j, k).Displacement.x = XSize * (RND - .5) + Particles(i, j, k).Displacement.y = YSize * (RND - .5) + NEXT + NEXT +NEXT + +CALL CalculateField + +DIM x AS DOUBLE +DIM y AS DOUBLE + +DO + DO WHILE _MOUSEINPUT + x = _MOUSEX + y = _MOUSEY + IF ((x > 0) AND (x < _WIDTH) AND (y > 0) AND (y < _HEIGHT)) THEN + Charges(ChargeCount).Center.x = (x - _WIDTH / 2) + Charges(ChargeCount).Center.y = (-y + _HEIGHT / 2) + CALL CalculateField + END IF + LOOP + + k = _KEYHIT + SELECT CASE k + CASE 49 + Charges(ChargeCount).Radial.x = .05 + Charges(ChargeCount).Radial.y = .05 + Charges(ChargeCount).Angular.x = 0 + Charges(ChargeCount).Angular.y = 0 + CASE 50 + Charges(ChargeCount).Radial.x = -.05 + Charges(ChargeCount).Radial.y = -.05 + Charges(ChargeCount).Angular.x = 0 + Charges(ChargeCount).Angular.y = 0 + CASE 51 + Charges(ChargeCount).Radial.x = .05 + Charges(ChargeCount).Radial.y = -.05 + Charges(ChargeCount).Angular.x = 0 + Charges(ChargeCount).Angular.y = 0 + CASE 52 + Charges(ChargeCount).Radial.x = -.05 + Charges(ChargeCount).Radial.y = .05 + Charges(ChargeCount).Angular.x = 0 + Charges(ChargeCount).Angular.y = 0 + CASE 53 + Charges(ChargeCount).Radial.x = 0 + Charges(ChargeCount).Radial.y = 0 + Charges(ChargeCount).Angular.x = .05 + Charges(ChargeCount).Angular.y = -.05 + CASE 54 + Charges(ChargeCount).Radial.x = 0 + Charges(ChargeCount).Radial.y = 0 + Charges(ChargeCount).Angular.x = -.05 + Charges(ChargeCount).Angular.y = .05 + CASE 48 + ChargeCount = 1 + CASE 32 + ChargeCount = ChargeCount + 1 + Charges(ChargeCount).Center.x = Charges(ChargeCount - 1).Center.x + Charges(ChargeCount).Center.y = Charges(ChargeCount - 1).Center.y + Charges(ChargeCount).Radial.x = Charges(ChargeCount - 1).Radial.x + Charges(ChargeCount).Radial.y = Charges(ChargeCount - 1).Radial.y + Charges(ChargeCount).Angular.x = Charges(ChargeCount - 1).Angular.x + Charges(ChargeCount).Angular.y = Charges(ChargeCount - 1).Angular.y + END SELECT + IF (k <> 0) THEN + CALL CalculateField + END IF + _KEYCLEAR + + LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, 20), BF + + DIM xc AS DOUBLE + DIM yc AS DOUBLE + DIM xd AS DOUBLE + DIM yd AS DOUBLE + DIM xx AS DOUBLE + DIM yy AS DOUBLE + + LOCATE 1, 1: PRINT "Press 1-6 to change charge type. Press space to fix charge, 0 to clear." + FOR i = 1 TO XCells + FOR j = 1 TO YCells + xc = VectorField(i, j).Center.x + yc = VectorField(i, j).Center.y + FOR k = 1 TO NPC + xd = 0 + yd = 0 + xx = Particles(i, j, k).Displacement.x + .1 * Particles(i, j, k).Velocity.x + yy = Particles(i, j, k).Displacement.y + .1 * Particles(i, j, k).Velocity.y + IF (xx < -XSize / 2) THEN + xd = -xx + XSize / 2 + END IF + IF (xx > XSize / 2) THEN + xd = -xx - XSize / 2 + END IF + IF (yy < -YSize / 2) THEN + yd = -yy + YSize / 2 + END IF + IF (yy > YSize / 2) THEN + yd = -yy + -YSize / 2 + END IF + Particles(i, j, k).Displacement.x = xx + xd + Particles(i, j, k).Displacement.y = yy + yd + CALL cpset(xc + Particles(i, j, k).Displacement.x, yc + Particles(i, j, k).Displacement.y, Particles(i, j, k).Shade) + NEXT + NEXT + NEXT + _LIMIT 60 + _DISPLAY +LOOP + +END + +SUB CalculateField + DIM i AS INTEGER + DIM j AS INTEGER + DIM k AS INTEGER + DIM dx AS DOUBLE + DIM dy AS DOUBLE + DIM d2 AS DOUBLE + DIM xx AS DOUBLE + DIM yy AS DOUBLE + FOR i = 1 TO XCells + FOR j = 1 TO YCells + xx = 0 + yy = 0 + FOR k = 1 TO ChargeCount + dx = VectorField(i, j).Center.x - Charges(k).Center.x + dy = VectorField(i, j).Center.y - Charges(k).Center.y + d2 = 5000 / (dx * dx + dy * dy) + xx = xx + (Charges(k).Radial.x * dx * d2) + (Charges(k).Angular.x * dy * d2) + yy = yy + (Charges(k).Radial.y * dy * d2) + (Charges(k).Angular.y * dx * d2) + NEXT + VectorField(i, j).Tangent.x = xx + VectorField(i, j).Tangent.y = yy + FOR k = 1 TO NPC + Particles(i, j, k).Velocity.x = VectorField(i, j).Tangent.x + Particles(i, j, k).Velocity.y = VectorField(i, j).Tangent.y + NEXT + NEXT + NEXT +END SUB + +SUB cpset (x1, y1, col AS _UNSIGNED LONG) + PSET (_WIDTH / 2 + x1, -y1 + _HEIGHT / 2), col +END SUB + diff --git a/samples/vectors.md b/samples/vectors.md new file mode 100644 index 0000000..03a0bc6 --- /dev/null +++ b/samples/vectors.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: VECTORS + +**[Vector Field](vector-field/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [2d](2d.md), [vectors](vectors.md) + +Vector field demonstration. diff --git a/samples/vortex/index.md b/samples/vortex/index.md index a02c471..98cfe79 100644 --- a/samples/vortex/index.md +++ b/samples/vortex/index.md @@ -20,9 +20,9 @@ > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "vortex.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/vortex/src/vortex.bas) -* [RUN "vortex.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/vortex/src/vortex.bas) -* [PLAY "vortex.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/vortex/src/vortex.bas) +* [LOAD "vortex.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/vortex/src/vortex.bas) +* [RUN "vortex.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/vortex/src/vortex.bas) +* [PLAY "vortex.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/vortex/src/vortex.bas) ### File(s) diff --git a/samples/water/index.md b/samples/water/index.md index 2cb54f6..84fd9c3 100644 --- a/samples/water/index.md +++ b/samples/water/index.md @@ -14,9 +14,9 @@ Water wave demonstration. > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "water.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/water/src/water.bas) -* [RUN "water.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/water/src/water.bas) -* [PLAY "water.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/water/src/water.bas) +* [LOAD "water.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/water/src/water.bas) +* [RUN "water.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/water/src/water.bas) +* [PLAY "water.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/water/src/water.bas) ### File(s) diff --git a/samples/william-loughner.md b/samples/william-loughner.md new file mode 100644 index 0000000..b4decf5 --- /dev/null +++ b/samples/william-loughner.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 WILLIAM LOUGHNER + +**[Calc](calc/index.md)** + +[🐝 William Loughner](william-loughner.md) 🔗 [calculator](calculator.md), [dos world](dos-world.md) + +' CALC.BAS ' by William Loughner ' Copyright (c) 1994 DOS Resource Guide ' Published i... diff --git a/samples/wireframe.md b/samples/wireframe.md new file mode 100644 index 0000000..cf8bdeb --- /dev/null +++ b/samples/wireframe.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: WIREFRAME + +**[3DS Viewer](3ds-viewer/index.md)** + +[🐝 *missing*](author-missing.md) 🔗 [3d](3d.md), [wireframe](wireframe.md), [legacy](legacy.md) + +3D Grapher made in QB64. diff --git a/samples/worms/index.md b/samples/worms/index.md index 7e7ac4d..3729ed8 100644 --- a/samples/worms/index.md +++ b/samples/worms/index.md @@ -42,9 +42,9 @@ Sorry, I've no idea how to do it on MacOS or Linux, any info about it from peopl > Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! -* [LOAD "worms.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?src=https://qb64.com/samples/worms/src/worms.bas) -* [RUN "worms.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=auto&src=https://qb64.com/samples/worms/src/worms.bas) -* [PLAY "worms.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5953810/index.html?mode=play&src=https://qb64.com/samples/worms/src/worms.bas) +* [LOAD "worms.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/worms/src/worms.bas) +* [RUN "worms.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/worms/src/worms.bas) +* [PLAY "worms.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/worms/src/worms.bas) ### File(s) diff --git a/samples/xe-hex-editor/img/screenshot.png b/samples/xe-hex-editor/img/screenshot.png new file mode 100644 index 0000000..6c57ea6 Binary files /dev/null and b/samples/xe-hex-editor/img/screenshot.png differ diff --git a/samples/xe-hex-editor/index.md b/samples/xe-hex-editor/index.md new file mode 100644 index 0000000..3d911f7 --- /dev/null +++ b/samples/xe-hex-editor/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: XE HEX EDITOR + +![screenshot.png](img/screenshot.png) + +### Author + +[🐝 Dav](../dav.md) + +### Description + +```text +'============ +'XE.BAS v1.10 +'============ +'A simple Binary File (HEX) editor. +'Coded by Dav on AUG 25, 2011 using QB64. +'Visit my website for more sourcecode at: +'http://www.qbasicnews.com/dav +' +'========================================================================== +'* * * * USE THIS PROGRAM AT YOUR OWN RISK ONLY!! * * * * +'========================================================================== +' +' New in XE v1.10: +' ~~~~~~~~~~~~~~~ +' +' * ADDED: Now can View/Edit files in TWO modes - HEX (default) or ASCII. +' ASCII mode allows for faster browsing through the file. +' Toggle between HEX/ASCII mode by pressing ENTER while viewing. +' * ADDED: Shows Usage information when starting, added help in source. +' * ADDED: Now shows currently opened file in the TITLE menu (full name). +' Short filename (8.3) is shown at top left line, after FILE: +' * ADDED: Now Uses Win API to test for file instead of using TEMP files. +' * ADDED: Can open file on READ-ONLY medium like CD's (because of above). +' * FIXED: Fixed error in FILTER that prevented letters from showing. +' * FIXED: Fixed several display bugs, and tweaked the layout more. +``` + +### QBjs + +> Please note that QBjs is still in early development and support for these examples is extremely experimental (meaning will most likely not work). With that out of the way, give it a try! + +* [LOAD "xe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?src=https://qb64.com/samples/xe-hex-editor/src/xe.bas) +* [RUN "xe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=auto&src=https://qb64.com/samples/xe-hex-editor/src/xe.bas) +* [PLAY "xe.bas"](https://v6p9d9t4.ssl.hwcdn.net/html/5963335/index.html?mode=play&src=https://qb64.com/samples/xe-hex-editor/src/xe.bas) + +### File(s) + +* [xe.bas](src/xe.bas) + +🔗 [editor](../editor.md), [hex](../hex.md) diff --git a/samples/xe-hex-editor/src/xe.bas b/samples/xe-hex-editor/src/xe.bas new file mode 100644 index 0000000..355dae2 --- /dev/null +++ b/samples/xe-hex-editor/src/xe.bas @@ -0,0 +1,716 @@ +'============ +'XE.BAS v1.10 +'============ +'A simple Binary File (HEX) editor. +'Coded by Dav on AUG 25, 2011 using QB64. +'Visit my website for more sourcecode at: +'http://www.qbasicnews.com/dav +' +'========================================================================== +'* * * * USE THIS PROGRAM AT YOUR OWN RISK ONLY!! * * * * +'========================================================================== +' +' New in XE v1.10: +' ~~~~~~~~~~~~~~~ +' +' * ADDED: Now can View/Edit files in TWO modes - HEX (default) or ASCII. +' ASCII mode allows for faster browsing through the file. +' Toggle between HEX/ASCII mode by pressing ENTER while viewing. +' * ADDED: Shows Usage information when starting, added help in source. +' * ADDED: Now shows currently opened file in the TITLE menu (full name). +' Short filename (8.3) is shown at top left line, after FILE: +' * ADDED: Now Uses Win API to test for file instead of using TEMP files. +' * ADDED: Can open file on READ-ONLY medium like CD's (because of above). +' * FIXED: Fixed error in FILTER that prevented letters from showing. +' * FIXED: Fixed several display bugs, and tweaked the layout more. +' +' THINGS TO DO: +' Add HEX Searching too. +' EAdd TEXT view for reading text files? +' Add a Create File option? +' Add (I) Info - Display File Information +' Add a File Copy to location... +' Highlight found text when searching +' +'========================================================================== +' +' ABOUT: +' ~~~~~ +' +' XE is a simple Binary File Editor (also called a HEX editor) that lets +' you view and edit raw data bytes of a file. With XE you can peek inside +' EXE/DLL files and see what information they may contain. XE also has the +' capacity to change bytes by either typing in ASCII characters or entering +' the HEX value for each byte. +' +' Since the very nature of XE is to alter file data you should always use +' EXTREME caution when editing file - AND ALWAYS MAKE BACKUPS FIRST! +' +'========================================================================== +' +' HOW TO USE: +' ~~~~~~~~~~ +' +' XE accepts command line arguments. You can drag/drop a file onto XE or +' specify a file to load from the command prompt, like "XE.EXE file.ext". +' If you don't specify a filename on startup, XE will ask you for one. +' +' There are TWO ways to View & Edit files - in HEX (default) or ASCII mode. +' +' Files are first opened in HEX mode displaying 2 windows of data. The +' right window shows the charaters while the larger left window shows HEX +' values for them. HEX mode is best for patching and is the only way to +' edit the HEX values of bytes. +' +' +' Pressing ENTER switches to ASCII (non-HEX) mode, showing a larger page +' of raw data bytes - the ASCII chracter data only. This mode is best for +' skimming through files faster. ENTER toggles view mode back and forth. +' +' While viewing a file you can browse through the file using the ARROWS, +' PAGEUP/DOWN, HOME and the END key to scroll up and down. +' +' The currently opened filename is shown with full path in the title bar, +' and its short filename (8.3) is displayed in the FILE: area just below. +' +' While viewing a file, press E to enter into EDIT mode and begin editing +' bytes at the current position. If you're in HEX mode (2 windows), you can +' edit bytes either by typing characters on the right side or entering HEX +' values on the left window. Press TAB to switch windows to edit in. +' Press ESC to save or disgard changes and to exit editing mode. +' +' Press M for a complete MENU listing all of the Key COMMANDS. +' +'========================================================================== +' +' COMMAND: +' ~~~~~~~~ +' +' E = Enters EDIT MODE. Only the displayed bytes can be edited. +' +' TAB = Switchs panes (the cursor) while editing in HEX mode. +' +' S = Searches file for a string starting at the current byte. +' A Match-Case option is available. A high beep alerts you +' when match is found. A Low beep sounds when EOF reached. +' +' N = Finds NEXT Match after a do a string search. +' +' F = Toggles FILTERING of all non-standard-text characters. +' A flashing "F" is at the top-left corner when FILTER ON. +' +' G = GOTO a certain byte position (number) in the file. +' +' L = GOTO a specified location (Hex value) of the file. +' +' ENTER = Toggles HEX and ASCII view modes. The ASCII mode lets +' you browse more data per page. You can EDIT in both +' modes but can only enter in HEX vaules in HEX mode. +' +' ESC = EXITS out of editing mode, and also EXITS the program. +' +' ALT+ENTER = Toggle FULLSCREEN/WINDOWED mode of the XE program. +' +'========================================================================== +'========================================================================== + +Declare Library + Function GetShortPathNameA (lpszLongPath As String, lpszShortPath As String, Byval cchBuffer As Long) +End Declare + +_Title "XE v1.10" + +If Command$ = "" Then + Print + Print " ============" + Print " XE.EXE v1.10" + Print " ============" + Print " A Simple Binary File (HEX) Editor." + Print " Coded by Dav AUG 25th, 2011 using QB64" + Print " Website: http://www.qbasicnews.com/dav" + Print + Print " USAGE: Drag & Drop a file on the XE program to open it." + Print " Or feed XE a file from the command prompt: XE.EXE filename.ext" + Print " You can also specify the file below (you must give full path)." + Print " Read XE.TXT or the XE.BAS Source for detailed help." + Print + Line Input " FILE TO OPEN> ", File$ + If File$ = "" Then End +Else + File$ = Command$ +End If + +ShortFileName$ = Space$(260) +Result = GetShortPathNameA(File$ + Chr$(0), ShortFileName$, Len(ShortFileName$)) + +If Result = 0 Then + Print " File not found!" + End +End If + +'=== trim off any spaces... +ShortFileName$ = LTrim$(RTrim$(ShortFileName$)) + +'=== Just get the 8.3 name, removing any path name +ts$ = "" +For q = Len(ShortFileName$) To 1 Step -1 + t$ = Mid$(ShortFileName$, q, 1) + If t$ = "/" Or t$ = "\" Then Exit For + ts$ = t$ + ts$ +Next +ShortFileName$ = ts$ + + +Open File$ For Binary As 7 + +_Title "XE v1.10 - " + File$ + +DisplayView% = 1 'Default to 2-PANE view + +Screen 0: Width 80, 25: Def Seg = &HB800 + +Color 15, 1: Cls: Locate 1, 1, 0 + +BC& = 1 + +If DisplayView% = 1 Then + Buff% = (16 * 24) +Else + Buff% = (79 * 24) +End If + +If Buff% > LOF(7) Then Buff% = LOF(7) + +'====================== +' MAIN DISPLAY ROUTINE +'====================== + +Do + Seek #7, BC& + PG$ = Input$(Buff%, 7) + + If DisplayView% = 1 Then + If Len(PG$) < (16 * 24) Then + Pflag% = 1: Plimit% = Len(PG$) + PG$ = PG$ + String$(16 * 24 - Len(PG$), Chr$(0)) + End If + + '=== right window + y% = 2: x% = 63 + For c% = 1 To Len(PG$) + tb% = Asc(Mid$(PG$, c%, 1)) + '=== show . instead of a null + If tb% = 0 Then tb% = 46 + If Filter% = 1 Then + Select Case tb% + Case 0 To 31, 123 To 255: tb% = 32 + End Select + End If + Poke (y% - 1) * 160 + (x% - 1) * 2, tb% + x% = x% + 1: If x% = 79 Then x% = 63: y% = y% + 1 + Next + + '=== show left side + y% = 2: x% = 15 + For c% = 1 To Len(PG$) + tb% = Asc(Mid$(PG$, c%, 1)) + tb$ = Hex$(tb%): If Len(tb$) = 1 Then tb$ = "0" + tb$ + Locate y%, x%: Print tb$; " "; + x% = x% + 3: If x% >= 62 Then x% = 15: y% = y% + 1 + Next + + Else + + '...DisplayView% = 0, Full view... + + If Len(PG$) < (79 * 24) Then 'Enough to fill screen? + Pflag% = 1: Plimit% = Len(PG$) 'No? Mark this and pad + PG$ = PG$ + Space$(79 * 24 - Len(PG$)) 'data with spaces. + End If + y% = 2: x% = 1 'Screen location where data begins displaying + For c% = 1 To Len(PG$) 'Show all the bytes. + tb% = Asc(Mid$(PG$, c%, 1)) 'Check the ASCII value. + If Filter% = 1 Then 'If Filter is turned on, + Select Case tb% 'changes these values to spaces + Case 0 To 32, 123 To 255: tb% = 32 + End Select + End If + Poke (y% - 1) * 160 + (x% - 1) * 2, tb% 'Poke bytes on screen + 'This line calculates when to go to next row. + x% = x% + 1: If x% = 80 Then x% = 1: y% = y% + 1 + Next + + End If + + GoSub DrawTopBar + + '=== Get user input + Do + Do Until L$ <> "": L$ = InKey$: Loop + K$ = L$: L$ = "" + GoSub DrawTopBar + Select Case UCase$(K$) + Case Chr$(27): Exit Do + Case "M": GoSub Menu: + Case "N" + If s$ <> "" Then + GoSub Search + GoSub DrawTopBar + End If + Case "E" + If DisplayView% = 1 Then + GoSub EditBIN + Else + GoSub EditBin3 + End If + GoSub DrawTopBar + Case "F" + If Filter% = 0 Then Filter% = 1 Else Filter% = 0 + Case "G" + Locate 1, 1: Print String$(80 * 3, 32); + Locate 1, 3: Print "TOTAL BYTES>"; LOF(7) + Input " GOTO BYTE# > ", GB$ + If GB$ <> "" Then + TMP$ = "" + For m% = 1 To Len(GB$) + G$ = Mid$(GB$, m%, 1) 'to numerical vales + Select Case Asc(G$) + Case 48 To 57: TMP$ = TMP$ + G$ + End Select + Next: GB$ = TMP$ + If Val(GB$) < 1 Then GB$ = "1" + If Val(GB$) > LOF(7) Then GB$ = Str$(LOF(7)) + If GB$ <> "" Then BC& = 0 + Val(GB$) + End If + Case "L" + Locate 1, 1: Print String$(80 * 3, 32); + Locate 1, 3: 'PRINT "TOTAL BYTES>"; LOF(7) + Input " GOTO HEX LOCATION-> ", GB$ + If GB$ <> "" Then + GB$ = "&H" + GB$ + If Val(GB$) < 1 Then GB$ = "1" + If Val(GB$) > LOF(7) Then GB$ = Str$(LOF(7)) + If GB$ <> "" Then BC& = 0 + Val(GB$) + End If + Case "S": s$ = "" + Locate 1, 1: Print String$(80 * 3, 32); + Locate 1, 3: Input "Search for> ", s$ + If s$ <> "" Then + Print " CASE sensitive (Y/N)? "; + I$ = Input$(1): I$ = UCase$(I$) + If I$ = "Y" Then CaseOn% = 1 Else CaseOn% = 0 + GoSub Search + End If + GoSub DrawTopBar + Case Chr$(13) + If DisplayView% = 1 Then + DisplayView% = 0 + Buff% = (79 * 24) + Else + DisplayView% = 1 + Buff% = (16 * 24) + End If + GoSub DrawTopBar + Case Chr$(0) + Chr$(72) + If DisplayView% = 1 Then + If BC& > 15 Then BC& = BC& - 16 + Else + If BC& > 78 Then BC& = BC& - 79 + End If + Case Chr$(0) + Chr$(80) + If DisplayView% = 1 Then + If BC& < LOF(7) - 15 Then BC& = BC& + 16 + Else + If BC& < LOF(7) - 78 Then BC& = BC& + 79 + End If + Case Chr$(0) + Chr$(73): BC& = BC& - Buff%: If BC& < 1 Then BC& = 1 + Case Chr$(0) + Chr$(81): If BC& < LOF(7) - Buff% Then BC& = BC& + Buff% + Case Chr$(0) + Chr$(71): BC& = 1 + Case Chr$(0) + Chr$(79): If Not EOF(7) Then BC& = LOF(7) - Buff% + End Select + Loop Until K$ <> "" +Loop Until K$ = Chr$(27) 'OR K$ = CHR$(13) + +Close 7 +Def Seg + +System + +'============================================================================== +' GOSUB ROUTINES +'============================================================================== + +'============= +Search: +'============= + +'==== A work-a-round for the EOF bug +'CLOSE 7 +'OPEN File$ FOR BINARY AS #7 +'SEEK 7, BC& +'=================================== + +If Not EOF(7) Then + Do + B$ = Input$(Buff%, 7): BC& = BC& + Buff% + If CaseOn% = 0 Then B$ = UCase$(B$): s$ = UCase$(s$) + d$ = InKey$: If d$ <> "" Then Exit Do + If InStr(1, B$, s$) Then Sound 4000, .5: Exit Do + Loop Until InStr(1, B$, s$) Or EOF(7) + If EOF(7) Then Sound 2000, 1: Sound 1000, 1 + BC& = BC& - Len(s$) +End If +Return + + +'============= +EditBIN: +'============= + +Pane% = 1 + +x% = 63: If rightx% Then y% = CsrLin Else y% = 2 +leftx% = 15 + +test% = Pos(0) + +If test% = 15 Or test% = 16 Then x% = 63: leftx% = 15 +If test% = 18 Or test% = 19 Then x% = 64: leftx% = 18 +If test% = 21 Or test% = 22 Then x% = 65: leftx% = 21 +If test% = 24 Or test% = 25 Then x% = 66: leftx% = 24 +If test% = 27 Or test% = 28 Then x% = 67: leftx% = 27 +If test% = 30 Or test% = 31 Then x% = 68: leftx% = 30 +If test% = 33 Or test% = 34 Then x% = 69: leftx% = 33 +If test% = 36 Or test% = 37 Then x% = 70: leftx% = 36 +If test% = 39 Or test% = 40 Then x% = 71: leftx% = 39 +If test% = 42 Or test% = 43 Then x% = 72: leftx% = 42 +If test% = 45 Or test% = 46 Then x% = 73: leftx% = 45 +If test% = 48 Or test% = 49 Then x% = 74: leftx% = 48 +If test% = 51 Or test% = 52 Then x% = 75: leftx% = 51 +If test% = 54 Or test% = 55 Then x% = 76: leftx% = 54 +If test% = 57 Or test% = 58 Then x% = 77: leftx% = 57 +If test% = 60 Or test% = 61 Then x% = 78: leftx% = 60 + +GoSub DrawEditBar: + +Locate y%, x%, 1, 1, 30 + +Do + Do + E$ = InKey$ + If E$ <> "" Then + Select Case E$ + Case Chr$(9) + If Pane% = 1 Then + Pane% = 2: GoTo EditBin2 + Else + Pane% = 1: GoTo EditBIN + End If + Case Chr$(27): Exit Do + Case Chr$(0) + Chr$(72): If y% > 2 Then y% = y% - 1 + Case Chr$(0) + Chr$(80): If y% < 25 Then y% = y% + 1 + Case Chr$(0) + Chr$(75): If x% > 63 Then x% = x% - 1: leftx% = leftx% - 3 + Case Chr$(0) + Chr$(77): If x% < 78 Then x% = x% + 1: leftx% = leftx% + 3 + Case Chr$(0) + Chr$(73), Chr$(0) + Chr$(71): y% = 2 + Case Chr$(0) + Chr$(81), Chr$(0) + Chr$(79): y% = 25 + Case Else + 'IF (BC& + (y% - 2) * 16 + x% - 1) <= LOF(7) AND E$ <> CHR$(8) THEN + If (BC& + ((y% - 2) * 16 + x% - 1) - 62) <= LOF(7) And E$ <> Chr$(8) Then + changes% = 1 + + '=== new color for changed bytes... + Color 1, 15: Locate y%, x%: Print " "; + Locate y%, leftx% + tb$ = Hex$(Asc(E$)): If Len(tb$) = 1 Then tb$ = "0" + tb$ + Print tb$; + + Poke (y% - 1) * 160 + (x% - 1) * 2, Asc(E$) + Mid$(PG$, ((y% - 2) * 16 + x% * 1) - 62) = E$ + If x% < 78 Then x% = x% + 1: leftx% = leftx% + 3 'skip space + End If + End Select + End If + Loop Until E$ <> "" + Locate y%, x% +Loop Until E$ = Chr$(27) + +'=========== +SaveChanges: +'=========== + +If changes% = 1 Then + Sound 4500, .2: Color 15, 4: Locate , , 0 + Locate 10, 29: Print Chr$(201); String$(21, 205); Chr$(187); + Locate 11, 29: Print Chr$(186); " Save Changes (Y/N)? "; Chr$(186); + Locate 12, 29: Print Chr$(200); String$(21, 205); Chr$(188); + N$ = Input$(1): Color 15, 1 + If UCase$(N$) = "Y" Then + If Pflag% = 1 Then PG$ = Left$(PG$, Plimit%) + Put #7, BC&, PG$: + End If +End If +Color 15, 1: Cls: Locate 1, 1, 0 +Return + +'=========== +EditBin2: +'=========== + +Color 1, 7 +x% = 15: 'y% = 2 +rightx% = 63 + +test% = Pos(0) +If test% = 63 Then x% = 15: rightx% = 63 +If test% = 64 Then x% = 18: rightx% = 64 +If test% = 65 Then x% = 21: rightx% = 65 +If test% = 66 Then x% = 24: rightx% = 66 +If test% = 67 Then x% = 27: rightx% = 67 +If test% = 68 Then x% = 30: rightx% = 68 +If test% = 69 Then x% = 33: rightx% = 69 +If test% = 70 Then x% = 36: rightx% = 70 +If test% = 71 Then x% = 39: rightx% = 71 +If test% = 72 Then x% = 42: rightx% = 72 +If test% = 73 Then x% = 45: rightx% = 73 +If test% = 74 Then x% = 48: rightx% = 74 +If test% = 75 Then x% = 51: rightx% = 75 +If test% = 76 Then x% = 54: rightx% = 76 +If test% = 77 Then x% = 57: rightx% = 77 +If test% = 78 Then x% = 60: rightx% = 78 + +GoSub DrawEditBar: + +Locate y%, x%, 1, 1, 30 + +Do + Do + E$ = InKey$ + If E$ <> "" Then + Select Case E$ + Case Chr$(9) + If Pane% = 1 Then + Pane% = 2: GoTo EditBin2 + Else + Pane% = 1: GoTo EditBIN + End If + Case Chr$(27): Exit Do + Case Chr$(0) + Chr$(72): If y% > 2 Then y% = y% - 1 + Case Chr$(0) + Chr$(80): If y% < 25 Then y% = y% + 1 + Case Chr$(0) + Chr$(75) 'right arrow.... + If x% > 15 Then + Select Case x% + Case 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 38, 39, 41, 42, 44, 45, 47, 48, 50, 51, 53, 54, 56, 57, 59, 60, 62, 63 + x% = x% - 2 + rightx% = rightx% - 1 + Case Else: x% = x% - 1 + End Select + End If + 'IF rightx% > 63 THEN rightx% = rightx% - 1 + Case Chr$(0) + Chr$(77) + If x% < 61 Then + Select Case x% + Case 16, 17, 19, 20, 22, 23, 25, 26, 28, 29, 31, 32, 34, 35, 37, 38, 40, 41, 43, 44, 46, 47, 49, 50, 52, 53, 55, 56, 58, 59, 61, 62 + x% = x% + 2 + rightx% = rightx% + 1 + Case Else: x% = x% + 1 + End Select + End If + 'IF rightx% < 78 THEN rightx% = rightx% + 1 + Case Chr$(0) + Chr$(73), Chr$(0) + Chr$(71): y% = 2 + Case Chr$(0) + Chr$(81), Chr$(0) + Chr$(79): y% = 25 + Case Else + If (BC& + ((y% - 2) * 16 + rightx% - 1) - 62) <= LOF(7) And E$ <> Chr$(8) Then + Select Case UCase$(E$) + Case "A", "B", "C", "D", "E", "F", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0" + E$ = UCase$(E$) + changes% = 1 + Color 1, 15: Locate y%, x%: Print " "; + Poke (y% - 1) * 160 + (x% - 1) * 2, Asc(E$) + If x% < 62 Then + + Select Case x% + Case 16, 17, 19, 20, 22, 23, 25, 26, 28, 29, 31, 32, 34, 35, 37, 38, 40, 41, 43, 44, 46, 47, 49, 50, 52, 53, 55, 56, 58, 59, 61, 62 + e2$ = Chr$(Val("&H" + Chr$(Screen(y%, x% - 1)) + Chr$(Screen(y%, x%)))) + 'locate 1,1 : print e2$ + '===== reflect changes on right panel + Color 1, 15: Locate y%, rightx%: Print " "; + Poke (y% - 1) * 160 + (rightx% - 1) * 2, Asc(e2$) + Mid$(PG$, ((y% - 2) * 16 + rightx% * 1) - 62) = e2$ + '=== dont advance cursor if at last place + If x% < 61 Then + rightx% = rightx% + 1 + x% = x% + 2 + End If + Case Else: x% = x% + 1 + End Select + End If + End Select + + End If + End Select + End If + Loop Until E$ <> "" + Locate y%, x% +Loop Until E$ = Chr$(27) + +GoTo SaveChanges: + + +'=========== +EditBin3: +'=========== + +Color 1, 7 +x% = 1: y% = 2 +changes% = 0 + +GoSub DrawEditBar + +Locate 2, 1, 1, 1, 30 + +Do + Do + E$ = InKey$ + If E$ <> "" Then + Select Case E$ + Case Chr$(27): Exit Do + Case Chr$(0) + Chr$(72): If y% > 2 Then y% = y% - 1 + Case Chr$(0) + Chr$(80): If y% < 25 Then y% = y% + 1 + Case Chr$(0) + Chr$(75): If x% > 1 Then x% = x% - 1 + Case Chr$(0) + Chr$(77): If x% < 79 Then x% = x% + 1 + Case Chr$(0) + Chr$(73), Chr$(0) + Chr$(71): y% = 2 + Case Chr$(0) + Chr$(81), Chr$(0) + Chr$(79): y% = 25 + Case Else + If (BC& + (y% - 2) * 79 + x% - 1) <= LOF(7) And E$ <> Chr$(8) Then + changes% = 1 + '=== new color for changed bytes + Color 1, 15: Locate y%, x%: Print " "; + Locate y%, x% + + Poke (y% - 1) * 160 + (x% - 1) * 2, Asc(E$) + Mid$(PG$, (y% - 2) * 79 + x% * 1) = E$ + If x% < 79 Then x% = x% + 1 + End If + End Select + End If + Loop Until E$ <> "" + GoSub DrawEditBar + Locate y%, x% +Loop Until E$ = Chr$(27) + +GoTo SaveChanges: + +'=========== +DrawEditBar: +'=========== + +If DisplayView% = 1 Then + Locate 1, 1: + Color 31, 4: Print " EDIT MODE: "; + Color 15, 4 + Print " Press TAB to switch editing sides "; Chr$(179); " Arrows move cursor "; Chr$(179); " ESC=Exit "; +Else + Locate 1, 1 + Color 31, 4: Print " EDIT MODE "; + Color 15, 4 + Print Chr$(179); " Arrows move cursor "; Chr$(179); " ESC=Exit "; Chr$(179); + Locate 1, 45: Print String$(35, " "); + + Locate 1, 46 + CurrentByte& = BC& + (y% - 2) * 79 + x% - 1 + CurrentValue% = Asc(Mid$(PG$, (y% - 2) * 79 + x% * 1, 1)) + If CurrentByte& > LOF(7) Then + Print Space$(9); "PAST END OF FILE"; + Else + Print "Byte:"; LTrim$(Str$(CurrentByte&)); + Print ", ASC:"; LTrim$(Str$(CurrentValue%)); + Print ", HEX:"; RTrim$(Hex$(CurrentValue%)); + End If +End If + +Return + + +'============ +DrawTopBar: +'============ + +Locate 1, 1: Color 1, 15: Print String$(80, 32); +Locate 1, 1 +If Filter% = 1 Then + Color 30, 4: Print "F";: Color 1, 15 +Else + Print " "; +End If + +Print "FILE: "; ShortFileName$; + +Print " "; Chr$(179); " Bytes:"; LOF(7); +EC& = BC& + Buff%: If EC& > LOF(7) Then EC& = LOF(7) +Print Chr$(179); " Viewing:"; RTrim$(Str$(BC&)); "-"; LTrim$(Str$(EC&)); +Locate 1, 70: Print Chr$(179); " M = Menu"; +Color 15, 1 +'== Draw bar on right side of screen +For d% = 2 To 25 + Locate d%, 80: Print Chr$(176); +Next + +If DisplayView% = 1 Then + '== Draw lines down screen + For d% = 2 To 25 + Locate d%, 79: Print Chr$(179); + Locate d%, 62: Print Chr$(179); + 'add space around numbers... + '(full screen messes it...) + Locate d%, 13: Print " " + Chr$(179); + Locate d%, 1: Print Chr$(179) + " "; + Next + + '=== Draw location + For d% = 2 To 25 + Locate d%, 3 + nm$ = Hex$(BC& - 32 + (d% * 16)) + If Len(nm$) = 9 Then nm$ = "0" + nm$ + If Len(nm$) = 8 Then nm$ = "00" + nm$ + If Len(nm$) = 7 Then nm$ = "000" + nm$ + If Len(nm$) = 6 Then nm$ = "0000" + nm$ + If Len(nm$) = 5 Then nm$ = "00000" + nm$ + If Len(nm$) = 4 Then nm$ = "000000" + nm$ + If Len(nm$) = 3 Then nm$ = "0000000" + nm$ + If Len(nm$) = 2 Then nm$ = "00000000" + nm$ + If Len(nm$) = 1 Then nm$ = "000000000" + nm$ + Print nm$; + Next +End If + +Marker% = CInt(BC& / LOF(7) * 23) +Locate Marker% + 2, 80: Print Chr$(178); +Return + +'======== +Menu: +'======== + +Sound 4500, .2: Color 15, 0: Locate , , 0 +Locate 5, 24: Print Chr$(201); String$(34, 205); Chr$(187); +For m = 6 To 20 + Locate m, 24: Print Chr$(186); Space$(34); Chr$(186); +Next +Locate 21, 24: Print Chr$(200); String$(34, 205); Chr$(188); + +Locate 6, 26: Print "Use the arrow keys, page up/down"; +Locate 7, 26: Print "and Home/End keys to navigate."; +Locate 9, 26: Print "E = Enter into file editing mode"; +Locate 10, 26: Print "F = Toggles the filter ON or OFF"; +Locate 11, 26: Print "G = Goto a certain byte position"; +Locate 12, 26: Print "L = Goto a certain HEX location"; +Locate 13, 26: Print "S = Searches for string in file"; +Locate 14, 26: Print "N = Find next match after search"; +Locate 16, 26: Print "ENTER = Toggle HEX/ASCII modes"; +Locate 17, 26: Print "TAB = switch window (HEX mode)"; +Locate 18, 26: Print "ESC = EXITS this program"; +Locate 20, 26: Print "ALT+ENTER for full screen window"; +Pause$ = Input$(1) +Color 15, 1: Cls: Locate 1, 1, 0 +Return + diff --git a/samples/zack-johnson.md b/samples/zack-johnson.md new file mode 100644 index 0000000..867737c --- /dev/null +++ b/samples/zack-johnson.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 ZACK JOHNSON + +**[Ghost Wizard](ghost-wizard/index.md)** + +[🐝 Zack Johnson](zack-johnson.md) 🔗 [game](game.md), [roguelike](roguelike.md) + +' ' Ghost Wizard ' Zack Johnson ' 7DRL 2019 (Mar 2 - Mar 7) ' diff --git a/samples/zen.md b/samples/zen.md index 91618d6..f564e0f 100644 --- a/samples/zen.md +++ b/samples/zen.md @@ -2,6 +2,12 @@ ## SAMPLES: ZEN +**[Parabolas](parabolas/index.md)** + +[🐝 STxAxTIC](stxaxtic.md) 🔗 [zen](zen.md) + +Parabola-based screensaver by STxAxTIC. + **[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/zom-b.md b/samples/zom-b.md index 0b11c1e..3d8d712 100644 --- a/samples/zom-b.md +++ b/samples/zom-b.md @@ -13,3 +13,9 @@ This is [...] a series of fractal artworks that I ported from Ultra Fractal to Q [🐝 Zom-B](zom-b.md) 🔗 [fractal](fractal.md), [julia set](julia-set.md) The longer you hold your mouse at one position, the more it starts to glow. + +**[Ray Tracer Z](ray-tracer-z/index.md)** + +[🐝 Zom-B](zom-b.md) 🔗 [3d](3d.md), [ray tracer](ray-tracer.md) + +This is a ray tracer I've been working on for the past 6 years. Well, on and off of course :) It'...