QB64/QB64-website
QB64/QB64-website
1
1
Fork 0
mirror of https://github.com/DualBrain/QB64.git synced 2023-11-19 13:10:13 +00:00
Code Issues Releases Wiki Activity

Adding content for existing samples catalog.

Browse source
This commit is contained in:
Cory Smith 2022-06-09 18:15:28 -05:00
parent 340bda72fd
commit 0e91ae966a
286 changed files with 37690 additions and 82 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

162
samples.md
View file

@ -2,84 +2,84 @@
## SAMPLES
- **[Julia Rings](samples/3D-Cube/index.md)** <sup>🐝 [Relsoft](samples/relsoft.md) 🔗 [3d](samples/3d.md), [cube](samples/cube.md)</sup>
- **[Abacus](samples/Abacus/index.md)** <sup>🐝 [Bob Seguin](samples/bob-seguin.md) 🔗 [abacus](samples/abacus.md), [arithmetic](samples/arithmetic.md)</sup>
- **[Amongst](samples/Amongst/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [multiplayer](samples/multiplayer.md)</sup>
- **[Animax](samples/Animax/index.md)** <sup>🐝 [Bob Seguin](samples/bob-seguin.md) 🔗 [art](samples/art.md), [drawing](samples/drawing.md)</sup>
- **[ArcDemo](samples/Arc-Demo/index.md)** <sup>🐝 [Tsiplacov Sergey](samples/tsiplacov-sergey.md) 🔗 [game](samples/game.md), [platformer](samples/platformer.md)</sup>
- **[Assault](samples/Assault/index.md)** <sup>🐝 [Glenn Powell](samples/glenn-powell.md) 🔗 [game](samples/game.md)</sup>
- **[Bezier](samples/Bezier/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Binary Clock](samples/Binary-Clock/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Blockout](samples/Blockout/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [breakout](samples/breakout.md)</sup>
- **[Can't Contain Me](samples/Cant-Contain-Me/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md)</sup>
- **[Castle](samples/Castle/index.md)** <sup>🐝 [Microsoft](samples/microsoft.md) 🔗 [game](samples/game.md), [2 player](samples/2-player.md)</sup>
- **[Chaotic Scattering - Gaspard-Rice system](samples/Chaotic-Scattering/index.md)** <sup>🐝 [vince](samples/vince.md) 🔗 [ray tracing](samples/ray-tracing.md), [reflections](samples/reflections.md)</sup>
- **[Circle Intersecting Circle](samples/Circle-Intersecting-Circle/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🐝 [STxAxTIC](samples/stxaxtic.md) 🔗 [geometry](samples/geometry.md), [intersections](samples/intersections.md)</sup>
- **[Circle Intersecting Line](samples/Circle-Intersecting-Line/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🔗 [geometry](samples/geometry.md), [intersections](samples/intersections.md)</sup>
- **[Colliding Ball Simulation](samples/Colliding-Ball-Simulation/index.md)** <sup>🐝 [Timothy Baxendale](samples/timothy-baxendale.md) 🔗 [physics](samples/physics.md), [collisions](samples/collisions.md)</sup>
- **[Connect Circles](samples/Connect-Circles/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🔗 [screensaver](samples/screensaver.md), [mosaic](samples/mosaic.md)</sup>
- **[Convert BMP to Dominoes](samples/Convert-BMP-to-Dominoes/index.md)** <sup>🐝 [Richard Frost](samples/richard-frost.md) 🔗 [image processing](samples/image-processing.md)</sup>
- **[Darokin](samples/Darokin/index.md)** <sup>🐝 [darokin](samples/darokin.md) 🔗 [screensaver](samples/screensaver.md), [starfield](samples/starfield.md)</sup>
- **[Dragon Warrior 64](samples/Dragon-Warrior/index.md)** <sup>🐝 [Cobalt](samples/cobalt.md) 🔗 [game](samples/game.md), [rpg](samples/rpg.md)</sup>
- **[Dropping Balls](samples/Dropping-Balls/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🔗 [gravity](samples/gravity.md), [collisions](samples/collisions.md)</sup>
- **[Ellipse Intersecting Line](samples/Ellipse-Intersecting-Line/index.md)** <sup>🐝 [STxAxTIC](samples/stxaxtic.md) 🔗 [geometry](samples/geometry.md), [intersections](samples/intersections.md)</sup>
- **[Fibonacci Variations](samples/Fibonacci-Variations/index.md)** <sup>🐝 [STxAxTIC](samples/stxaxtic.md) 🔗 [fibonacci](samples/fibonacci.md)</sup>
- **[Filled Circles and Ellipses](samples/Filled-Circles-and-Ellipses/index.md)** <sup>🐝 [QB64 Team 2018](samples/qb64-team-2018.md) 🔗 [filled circle](samples/filled-circle.md), [ellipse](samples/ellipse.md)</sup>
- **[Fire](samples/Fire/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [fire](samples/fire.md), [graphics](samples/graphics.md)</sup>
- **[Floormaper](samples/Floormaper/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [graphics](samples/graphics.md), [floorscape](samples/floorscape.md)</sup>
- **[4 Player Pong](samples/Four-Player-Pong/index.md)** <sup>🐝 [Matthew](samples/matthew.md) 🔗 [game](samples/game.md), [pong](samples/pong.md)</sup>
- **[Bezier](samples/Fractal/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Fractal Art](samples/Fractal-Art/index.md)** <sup>🐝 [Zom-B](samples/zom-b.md) 🔗 [fractal](samples/fractal.md), [art](samples/art.md)</sup>
- **[Fractal Fern](samples/Fractal-Fern/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [fractal](samples/fractal.md), [fern](samples/fern.md)</sup>
- **[Globe](samples/Globe/index.md)** <sup>🐝 [Glen Jeh](samples/glen-jeh.md) 🐝 [8/12/1994](samples/8/12/1994.md) 🐝 [William Yu (05-28-96)](samples/william-yu-(05-28-96).md) 🔗 [3d](samples/3d.md), [sphere](samples/sphere.md)</sup>
- **[GUJERO2](samples/Gujero2/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [tunnel](samples/tunnel.md)</sup>
- **[Helicopter Rescue](samples/Helicopter-Rescue/index.md)** <sup>🐝 [TrialAndTerror](samples/trialandterror.md) 🔗 [game](samples/game.md), [3d](samples/3d.md), [flight](samples/flight.md)</sup>
- **[Inverse Julia Fractal Explorer](samples/Inverse-Julia-Fractal-Explorer/index.md)** <sup>🐝 [Zom-B](samples/zom-b.md) 🔗 [fractal](samples/fractal.md), [julia set](samples/julia-set.md)</sup>
- **[Julia Rings](samples/Julia-Rings/index.md)** <sup>🐝 [Relsoft](samples/relsoft.md) 🔗 [fractal](samples/fractal.md), [julia set](samples/julia-set.md)</sup>
- **[Bezier](samples/Kaleidoscope/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Bezier](samples/Kaleidoscope-Mill/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Bezier](samples/Lightning-One/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Bezier](samples/Lightning-Two/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Lissajous Curve Table](samples/Lissajous-Curve-Table/index.md)** <sup>🐝 [FellippeHeitor](samples/fellippeheitor.md) 🔗 [graphics](samples/graphics.md), [trigonometry](samples/trigonometry.md)</sup>
- **[Lissajous Screensaver](samples/Lissajous-Screensaver/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Rotating Lorenz Attractor](samples/Lorenz-Attractor/index.md)** <sup>🐝 [Vince](samples/vince.md) 🔗 [lorenz](samples/lorenz.md), [rotations](samples/rotations.md)</sup>
- **[Mandala 9 Line](samples/Manadla/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Mandelbrot Animator](samples/Mandelbrot-Animator/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md)</sup>
- **[Mandelbrot](samples/Mandelbrot-Set-2003/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md), [9 lines](samples/9-lines.md)</sup>
- **[Mandelbrot Set](samples/Mandelbrot-Set-2008/index.md)** <sup>🐝 [qbguy](samples/qbguy.md) 🔗 [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md)</sup>
- **[Tor Myklebust](samples/Mandelbrot-Zoomer/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md)</sup>
- **[Maptriangle in 3D](samples/Maptriangle-in-3D/index.md)** <sup>🐝 [Petr](samples/petr.md) 🔗 [3d](samples/3d.md), [maptriangle](samples/maptriangle.md)</sup>
- **[Matrix Effect](samples/Matrix-Effect/index.md)** <sup>🐝 [TylerDarko](samples/tylerdarko.md) 🔗 [ascii](samples/ascii.md), [matrix](samples/matrix.md)</sup>
- **[Mini Clock](samples/Mini-Clock/index.md)** <sup>🐝 [Folker Fritz](samples/folker-fritz.md) 🔗 [clock](samples/clock.md), [desktop](samples/desktop.md)</sup>
- **[Bezier](samples/Multi-Mill/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Bezier](samples/Mystify/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Particle Fountain](samples/Particle-Fountain/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🔗 [particles](samples/particles.md)</sup>
- **[Mandala 9 Line](samples/Pattern/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Pendulum Game](samples/Pendulum-Game/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [pendulum](samples/pendulum.md)</sup>
- **[Pipes Puzzle (Maze Connect)](samples/Pipes-Puzzle/index.md)** <sup>🐝 [Dav](samples/dav.md) 🔗 [game](samples/game.md), [puzzle](samples/puzzle.md)</sup>
- **[Non-Palette Rotated Plasma](samples/Plasma-Non-Pal/index.md)** <sup>🐝 [Relsoft](samples/relsoft.md) 🔗 [screensaver](samples/screensaver.md), [plasma](samples/plasma.md)</sup>
- **[Ray Tracer Demo](samples/Ray-Tracer-Demo/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [ray tracer](samples/ray-tracer.md)</sup>
- **[Ripples](samples/Ripples/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [image processing](samples/image-processing.md), [ripple](samples/ripple.md)</sup>
- **[Rotozoomer](samples/Rotozoomer/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Set Fire to Rain](samples/Set-Fire-to-Rain/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [zen](samples/zen.md)</sup>
- **[Shooter](samples/Shooter/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [game](samples/game.md), [shooter](samples/shooter.md)</sup>
- **[Sine Wave Explorer](samples/Sine-Wave-Explorer/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [trigonometry](samples/trigonometry.md)</sup>
- **[SineCube](samples/SineCube/index.md)** <sup>🐝 [Mennonite](samples/mennonite.md) 🔗 [graphics](samples/graphics.md)</sup>
- **[Snake Basic](samples/Snake-Basic/index.md)** <sup>🐝 [pcluddite](samples/pcluddite.md) 🔗 [game](samples/game.md), [snake](samples/snake.md)</sup>
- **[Sokoban](samples/Sokoban/index.md)** <sup>🐝 [David Joffe](samples/david-joffe.md) 🔗 [game](samples/game.md), [puzzle](samples/puzzle.md)</sup>
- **[Sort demo](samples/Sort-Demo/index.md)** <sup>🐝 [Microsoft](samples/microsoft.md) 🔗 [sort](samples/sort.md)</sup>
- **[Space64](samples/Space64/index.md)** <sup>🐝 [Cyperium](samples/cyperium.md) 🔗 [game](samples/game.md), [space shooter](samples/space-shooter.md)</sup>
- **[Spaceship](samples/Spaceship/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [space shooter](samples/space-shooter.md)</sup>
- **[Bezier](samples/Splines/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Starfield 9 Line](samples/Starfield/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [starfield](samples/starfield.md), [9 lines](samples/9-lines.md)</sup>
- **[Starfield Torus](samples/Starfield-Torus/index.md)** <sup>🐝 [JKC](samples/jkc.md) 🔗 [starfield](samples/starfield.md)</sup>
- **[Texel Raytracer](samples/Texel-Raytracer/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [3d](samples/3d.md), [ray tracing](samples/ray-tracing.md)</sup>
- **[Tic Tac Toe](samples/Tic-Tac-Toe/index.md)** <sup>🐝 [Paul Meyer](samples/paul-meyer.md) 🔗 [game](samples/game.md), [tic tac toe](samples/tic-tac-toe.md)</sup>
- **[Tic Tac Toe Rings](samples/Tic-Tac-Toe-Rings/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [tic tac toe rings](samples/tic-tac-toe-rings.md)</sup>
- **[Torus Demo](samples/Torus-Demo/index.md)** <sup>🐝 [Microsoft](samples/microsoft.md) 🔗 [geometry](samples/geometry.md), [torus](samples/torus.md)</sup>
- **[Tower of Hanoi](samples/Tower-of-Hanoi/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [game](samples/game.md), [tower](samples/tower.md)</sup>
- **[Turtle Graphics](samples/Turtle-Graphics/index.md)** <sup>🐝 [triggered](samples/triggered.md) 🔗 [fractal](samples/fractal.md), [turtle graphics](samples/turtle-graphics.md)</sup>
- **[Twirl](samples/Twirl/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Vortex](samples/Vortex/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Water](samples/Water/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [wave motion](samples/wave-motion.md)</sup>
- **[Bezier](samples/Worms/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Julia Rings](samples/3d-cube/index.md)** <sup>🐝 [Relsoft](samples/relsoft.md) 🔗 [3d](samples/3d.md), [cube](samples/cube.md)</sup>
- **[Abacus](samples/abacus/index.md)** <sup>🐝 [Bob Seguin](samples/bob-seguin.md) 🔗 [abacus](samples/abacus.md), [arithmetic](samples/arithmetic.md)</sup>
- **[Amongst](samples/amongst/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [multiplayer](samples/multiplayer.md)</sup>
- **[Animax](samples/animax/index.md)** <sup>🐝 [Bob Seguin](samples/bob-seguin.md) 🔗 [art](samples/art.md), [drawing](samples/drawing.md)</sup>
- **[ArcDemo](samples/arc-demo/index.md)** <sup>🐝 [Tsiplacov Sergey](samples/tsiplacov-sergey.md) 🔗 [game](samples/game.md), [platformer](samples/platformer.md)</sup>
- **[Assault](samples/assault/index.md)** <sup>🐝 [Glenn Powell](samples/glenn-powell.md) 🔗 [game](samples/game.md)</sup>
- **[Bezier](samples/bezier/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Binary Clock](samples/binary-clock/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Blockout](samples/blockout/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [breakout](samples/breakout.md)</sup>
- **[Can't Contain Me](samples/cant-contain-me/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md)</sup>
- **[Castle](samples/castle/index.md)** <sup>🐝 [Microsoft](samples/microsoft.md) 🔗 [game](samples/game.md), [2 player](samples/2-player.md)</sup>
- **[Chaotic Scattering - Gaspard-Rice system](samples/chaotic-scattering/index.md)** <sup>🐝 [vince](samples/vince.md) 🔗 [ray tracing](samples/ray-tracing.md), [reflections](samples/reflections.md)</sup>
- **[Circle Intersecting Circle](samples/circle-intersecting-circle/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🐝 [STxAxTIC](samples/stxaxtic.md) 🔗 [geometry](samples/geometry.md), [intersections](samples/intersections.md)</sup>
- **[Circle Intersecting Line](samples/circle-intersecting-line/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🔗 [geometry](samples/geometry.md), [intersections](samples/intersections.md)</sup>
- **[Colliding Ball Simulation](samples/colliding-ball-simulation/index.md)** <sup>🐝 [Timothy Baxendale](samples/timothy-baxendale.md) 🔗 [physics](samples/physics.md), [collisions](samples/collisions.md)</sup>
- **[Connect Circles](samples/connect-circles/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🔗 [screensaver](samples/screensaver.md), [mosaic](samples/mosaic.md)</sup>
- **[Convert BMP to Dominoes](samples/convert-bmp-to-dominoes/index.md)** <sup>🐝 [Richard Frost](samples/richard-frost.md) 🔗 [image processing](samples/image-processing.md)</sup>
- **[Darokin](samples/darokin/index.md)** <sup>🐝 [darokin](samples/darokin.md) 🔗 [screensaver](samples/screensaver.md), [starfield](samples/starfield.md)</sup>
- **[Dragon Warrior 64](samples/dragon-warrior/index.md)** <sup>🐝 [Cobalt](samples/cobalt.md) 🔗 [game](samples/game.md), [rpg](samples/rpg.md)</sup>
- **[Dropping Balls](samples/dropping-balls/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🔗 [gravity](samples/gravity.md), [collisions](samples/collisions.md)</sup>
- **[Ellipse Intersecting Line](samples/ellipse-intersecting-line/index.md)** <sup>🐝 [STxAxTIC](samples/stxaxtic.md) 🔗 [geometry](samples/geometry.md), [intersections](samples/intersections.md)</sup>
- **[Fibonacci Variations](samples/fibonacci-variations/index.md)** <sup>🐝 [STxAxTIC](samples/stxaxtic.md) 🔗 [fibonacci](samples/fibonacci.md)</sup>
- **[Filled Circles and Ellipses](samples/filled-circles-and-ellipses/index.md)** <sup>🐝 [QB64 Team 2018](samples/qb64-team-2018.md) 🔗 [filled circle](samples/filled-circle.md), [ellipse](samples/ellipse.md)</sup>
- **[Fire](samples/fire/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [fire](samples/fire.md), [graphics](samples/graphics.md)</sup>
- **[Floormaper](samples/floormaper/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [graphics](samples/graphics.md), [floorscape](samples/floorscape.md)</sup>
- **[4 Player Pong](samples/four-player-pong/index.md)** <sup>🐝 [Matthew](samples/matthew.md) 🔗 [game](samples/game.md), [pong](samples/pong.md)</sup>
- **[Bezier](samples/fractal/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Fractal Art](samples/fractal-art/index.md)** <sup>🐝 [Zom-B](samples/zom-b.md) 🔗 [fractal](samples/fractal.md), [art](samples/art.md)</sup>
- **[Fractal Fern](samples/fractal-fern/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [fractal](samples/fractal.md), [fern](samples/fern.md)</sup>
- **[Globe](samples/globe/index.md)** <sup>🐝 [Glen Jeh](samples/glen-jeh.md) 🐝 [8/12/1994](samples/8/12/1994.md) 🐝 [William Yu (05-28-96)](samples/william-yu-(05-28-96).md) 🔗 [3d](samples/3d.md), [sphere](samples/sphere.md)</sup>
- **[GUJERO2](samples/gujero2/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [tunnel](samples/tunnel.md)</sup>
- **[Helicopter Rescue](samples/helicopter-rescue/index.md)** <sup>🐝 [TrialAndTerror](samples/trialandterror.md) 🔗 [game](samples/game.md), [3d](samples/3d.md), [flight](samples/flight.md)</sup>
- **[Inverse Julia Fractal Explorer](samples/inverse-julia-fractal-explorer/index.md)** <sup>🐝 [Zom-B](samples/zom-b.md) 🔗 [fractal](samples/fractal.md), [julia set](samples/julia-set.md)</sup>
- **[Julia Rings](samples/julia-rings/index.md)** <sup>🐝 [Relsoft](samples/relsoft.md) 🔗 [fractal](samples/fractal.md), [julia set](samples/julia-set.md)</sup>
- **[Bezier](samples/kaleidoscope/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Bezier](samples/kaleidoscope-mill/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Bezier](samples/lightning-one/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Bezier](samples/lightning-two/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Lissajous Curve Table](samples/lissajous-curve-table/index.md)** <sup>🐝 [FellippeHeitor](samples/fellippeheitor.md) 🔗 [graphics](samples/graphics.md), [trigonometry](samples/trigonometry.md)</sup>
- **[Lissajous Screensaver](samples/lissajous-screensaver/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Rotating Lorenz Attractor](samples/lorenz-attractor/index.md)** <sup>🐝 [Vince](samples/vince.md) 🔗 [lorenz](samples/lorenz.md), [rotations](samples/rotations.md)</sup>
- **[Mandala 9 Line](samples/manadla/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Mandelbrot Animator](samples/mandelbrot-animator/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md)</sup>
- **[Mandelbrot](samples/mandelbrot-set-2003/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md), [9 lines](samples/9-lines.md)</sup>
- **[Mandelbrot Set](samples/mandelbrot-set-2008/index.md)** <sup>🐝 [qbguy](samples/qbguy.md) 🔗 [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md)</sup>
- **[Tor Myklebust](samples/mandelbrot-zoomer/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [fractal](samples/fractal.md), [mandelbrot](samples/mandelbrot.md)</sup>
- **[Maptriangle in 3D](samples/maptriangle-in-3d/index.md)** <sup>🐝 [Petr](samples/petr.md) 🔗 [3d](samples/3d.md), [maptriangle](samples/maptriangle.md)</sup>
- **[Matrix Effect](samples/matrix-effect/index.md)** <sup>🐝 [TylerDarko](samples/tylerdarko.md) 🔗 [ascii](samples/ascii.md), [matrix](samples/matrix.md)</sup>
- **[Mini Clock](samples/mini-clock/index.md)** <sup>🐝 [Folker Fritz](samples/folker-fritz.md) 🔗 [clock](samples/clock.md), [desktop](samples/desktop.md)</sup>
- **[Bezier](samples/multi-mill/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Bezier](samples/mystify/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Particle Fountain](samples/particle-fountain/index.md)** <sup>🐝 [bplus](samples/bplus.md) 🔗 [particles](samples/particles.md)</sup>
- **[Mandala 9 Line](samples/pattern/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Pendulum Game](samples/pendulum-game/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [pendulum](samples/pendulum.md)</sup>
- **[Pipes Puzzle (Maze Connect)](samples/pipes-puzzle/index.md)** <sup>🐝 [Dav](samples/dav.md) 🔗 [game](samples/game.md), [puzzle](samples/puzzle.md)</sup>
- **[Non-Palette Rotated Plasma](samples/plasma-non-pal/index.md)** <sup>🐝 [Relsoft](samples/relsoft.md) 🔗 [screensaver](samples/screensaver.md), [plasma](samples/plasma.md)</sup>
- **[Ray Tracer Demo](samples/ray-tracer-demo/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [ray tracer](samples/ray-tracer.md)</sup>
- **[Ripples](samples/ripples/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [image processing](samples/image-processing.md), [ripple](samples/ripple.md)</sup>
- **[Rotozoomer](samples/rotozoomer/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Set Fire to Rain](samples/set-fire-to-rain/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [zen](samples/zen.md)</sup>
- **[Shooter](samples/shooter/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [game](samples/game.md), [shooter](samples/shooter.md)</sup>
- **[Sine Wave Explorer](samples/sine-wave-explorer/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [trigonometry](samples/trigonometry.md)</sup>
- **[SineCube](samples/sinecube/index.md)** <sup>🐝 [Mennonite](samples/mennonite.md) 🔗 [graphics](samples/graphics.md)</sup>
- **[Snake Basic](samples/snake-basic/index.md)** <sup>🐝 [pcluddite](samples/pcluddite.md) 🔗 [game](samples/game.md), [snake](samples/snake.md)</sup>
- **[Sokoban](samples/sokoban/index.md)** <sup>🐝 [David Joffe](samples/david-joffe.md) 🔗 [game](samples/game.md), [puzzle](samples/puzzle.md)</sup>
- **[Sort demo](samples/sort-demo/index.md)** <sup>🐝 [Microsoft](samples/microsoft.md) 🔗 [sort](samples/sort.md)</sup>
- **[Space64](samples/space64/index.md)** <sup>🐝 [Cyperium](samples/cyperium.md) 🔗 [game](samples/game.md), [space shooter](samples/space-shooter.md)</sup>
- **[Spaceship](samples/spaceship/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [space shooter](samples/space-shooter.md)</sup>
- **[Bezier](samples/splines/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>
- **[Starfield 9 Line](samples/starfield/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [starfield](samples/starfield.md), [9 lines](samples/9-lines.md)</sup>
- **[Starfield Torus](samples/starfield-torus/index.md)** <sup>🐝 [JKC](samples/jkc.md) 🔗 [starfield](samples/starfield.md)</sup>
- **[Texel Raytracer](samples/texel-raytracer/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [3d](samples/3d.md), [ray tracing](samples/ray-tracing.md)</sup>
- **[Tic Tac Toe](samples/tic-tac-toe/index.md)** <sup>🐝 [Paul Meyer](samples/paul-meyer.md) 🔗 [game](samples/game.md), [tic tac toe](samples/tic-tac-toe.md)</sup>
- **[Tic Tac Toe Rings](samples/tic-tac-toe-rings/index.md)** <sup>🐝 [Fellippe Heitor](samples/fellippe-heitor.md) 🔗 [game](samples/game.md), [tic tac toe rings](samples/tic-tac-toe-rings.md)</sup>
- **[Torus Demo](samples/torus-demo/index.md)** <sup>🐝 [Microsoft](samples/microsoft.md) 🔗 [geometry](samples/geometry.md), [torus](samples/torus.md)</sup>
- **[Tower of Hanoi](samples/tower-of-hanoi/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [game](samples/game.md), [tower](samples/tower.md)</sup>
- **[Turtle Graphics](samples/turtle-graphics/index.md)** <sup>🐝 [triggered](samples/triggered.md) 🔗 [fractal](samples/fractal.md), [turtle graphics](samples/turtle-graphics.md)</sup>
- **[Twirl](samples/twirl/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Vortex](samples/vortex/index.md)** <sup>🐝 [Antoni Gual](samples/antoni-gual.md) 🔗 [screensaver](samples/screensaver.md), [9 lines](samples/9-lines.md)</sup>
- **[Water](samples/water/index.md)** <sup>🐝 [*missing*](samples/author-missing.md) 🔗 [wave motion](samples/wave-motion.md)</sup>
- **[Bezier](samples/worms/index.md)** <sup>🐝 [Rho Sigma](samples/rho-sigma.md) 🔗 [screenblanker](samples/screenblanker.md)</sup>

BIN
samples/3d-cube/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 7.5 KiB

23
samples/3d-cube/index.md Normal file
View file

@ -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: JULIA RINGS
![screenshot.png](img/screenshot.png)
### Author
[🐝 Relsoft](../relsoft.md)
### Description
3d cube
polygon filled using paint. ;*)
I could probably shorten the code in less than 20 lines but
I'd rather make another 25 liner. ;*)
Relsoft 2003
### File(s)
* [3dcube25.bas](src/3dcube25.bas)
🔗 [3d](../3d.md), [cube](../cube.md)

42
samples/3d-cube/src/3dcube25.bas Normal file
View file

@ -0,0 +1,42 @@
'3d cube
'polygon filled using paint. ;*)
'I could probably shorten the code in less than 20 lines but
'I'd rather make another 25 liner. ;*)
'Relsoft 2003
$NoPrefix
$Resize:Smooth
Screen 9, , 1, 0
FullScreen SquarePixels , Smooth
Dim CubeM!(8, 7), CubeV(12, 2)
For V = 1 To 8 + 12
If V < 9 Then Read CubeM!(V, 0), CubeM!(V, 1), CubeM!(V, 2) Else Read CubeV(V - 8, 0), CubeV(V - 8, 1), CubeV(V - 8, 2)
Next
Do
ax! = (ax! + .01) * -(ax! < 6.283186)
ay! = (ay! + .01) * -(ay! < 6.283186)
az! = (az! + .01) * -(az! < 6.283186)
For I = 1 To 8
CubeM!(I, 6) = (256 * ((CubeM!(I, 0) * (Cos(ay!) * Cos(az!)) + CubeM!(I, 1) * (Cos(ax!) * -Sin(az!) + Sin(ax!) * Sin(ay!) * Cos(az!)) + CubeM!(I, 2) * (-Sin(ax!) * -Sin(az!) + Cos(ax!) * Sin(ay!) * Cos(az!)))) \ (256 - ((CubeM!(I, 0) * (-Sin(ay!)) + CubeM!(I, 1) * (Sin(ax!) * Cos(ay!)) + CubeM!(I, 2) * (Cos(ax!) * Cos(ay!)))))) + 320
CubeM!(I, 7) = -(256 * ((CubeM!(I, 0) * (Cos(ay!) * Sin(az!)) + CubeM!(I, 1) * (Cos(ax!) * Cos(az!) + Sin(ax!) * Sin(ay!) * Sin(az!)) + CubeM!(I, 2) * (-Sin(ax!) * Cos(az!) + Cos(az!) * Sin(ay!) * Sin(az!)))) \ (256 - ((CubeM!(I, 0) * (-Sin(ay!)) + CubeM!(I, 1) * (Sin(ax!) * Cos(ay!)) + CubeM!(I, 2) * (Cos(ax!) * Cos(ay!)))))) + 175
Next
Line (0, 0)-(639, 350), 0, BF
For I = 1 To 12
If (CubeM!(CubeV(I, 2), 6) - CubeM!(CubeV(I, 0), 6)) * (CubeM!(CubeV(I, 1), 7) - CubeM!(CubeV(I, 0), 7)) - (CubeM!(CubeV(I, 1), 6) - CubeM!(CubeV(I, 0), 6)) * (CubeM!(CubeV(I, 2), 7) - CubeM!(CubeV(I, 0), 7)) < -256 Then
Line (CubeM!(CubeV(I, 0), 6), CubeM!(CubeV(I, 0), 7))-(CubeM!(CubeV(I, 1), 6), CubeM!(CubeV(I, 1), 7)), I + 2
Line (CubeM!(CubeV(I, 1), 6), CubeM!(CubeV(I, 1), 7))-(CubeM!(CubeV(I, 2), 6), CubeM!(CubeV(I, 2), 7)), I + 2
Line (CubeM!(CubeV(I, 2), 6), CubeM!(CubeV(I, 2), 7))-(CubeM!(CubeV(I, 0), 6), CubeM!(CubeV(I, 0), 7)), I + 2
Paint ((CubeM!(CubeV(I, 0), 6) + CubeM!(CubeV(I, 1), 6) + CubeM!(CubeV(I, 2), 6)) \ 3, (CubeM!(CubeV(I, 0), 7) + CubeM!(CubeV(I, 1), 7) + CubeM!(CubeV(I, 2), 7)) \ 3), I + 2
End If
Next
PCopy 1, 0
Limit 60
Loop Until InKey$ <> ""
System 0
Data -80,-80,-80,80,-80,-80,80,80,-80,-80,80,-80,-80,-80,80,80,-80,80,80,80,80,-80,80,80
Data 5,1,8,1,4,8,6,5,7,5,8,7,2,6,3,6,7,3,1,2,4,2,3,4,4,3,8,3,7,8,5,6,1,6,2,1

2
samples/8-12-1994.md
View file

@ -1,6 +1,6 @@
[Home](https://qb64.com) • [News](../news.md) • [GitHub](../github.md) • [Wiki](../wiki.md) • [Samples](../samples.md) • [Media](../media.md) • [Community](../community.md) • [Rolodex](../rolodex.md) • [More...](../more.md)
## SAMPLES BY 8-12-1994
## SAMPLES BY 8/12/1994
**[Globe](globe/index.md)**

BIN
samples/abacus/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 25 KiB

30
samples/abacus/index.md Normal file
View file

@ -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: ABACUS
![screenshot.png](img/screenshot.png)
### Author
[🐝 Bob Seguin](../bob-seguin.md)
### Description
Abacus app by Bob Seguin.
NOTE: This game requires graphics files created by any accompanying .bas programs in the zip file. If two or more accompanying .bas files are present, run the first on only. It will automatically chain (run) the second file. After you run the accompanying .bas file, the main program ready to use!
### File(s)
* [a12gfx.bas](src/a12gfx.bas)
* [abacus.zip](src/abacus.zip)
* [abacus1.bsv](src/abacus1.bsv)
* [abacus12.bas](src/abacus12.bas)
* [abacus2.bsv](src/abacus2.bsv)
* [abacus3.bsv](src/abacus3.bsv)
* [abamenu.bsv](src/abamenu.bsv)
* [abanums.bsv](src/abanums.bsv)
* [abasets.bsv](src/abasets.bsv)
* [readme.txt](src/readme.txt)
🔗 [abacus](../abacus.md), [arithmetic](../arithmetic.md)

387
samples/abacus/src/a12gfx.bas Normal file
View file

@ -0,0 +1,387 @@
'****************************************************************************'
'
'--------------------------- A 1 2 G F X . B A S ----------------------------'
'------------------ Creates graphics files for ABACUS12.BAS -----------------'
'
'---------------- Copyright (C) 2007 by Bob Seguin (Freeware) ---------------'
'
'****************************************************************************'
DefInt A-Z
DECLARE SUB PutBEAD (col, row, Index)
Dim Shared Box(26000)
Dim Shared Beads(450)
Dim NumBOX(1 To 250)
Dim MenuBOX(400)
Screen 12
GoSub SetPALETTE
MaxWIDTH = 397
MaxDEPTH = 86
x = 0: y = 0
Restore PixDATA
Do
Read DataSTRING$
For n = 1 To Len(DataSTRING$)
Char$ = Mid$(DataSTRING$, n, 1)
Select Case Char$
Case "!"
n = n + 1
a$ = Mid$(DataSTRING$, n, 1)
Count = Asc(a$) + 68
Case "#"
n = n + 1
B$ = Mid$(DataSTRING$, n)
For i = 1 To Len(B$)
t$ = Mid$(B$, i, 1)
If t$ = "#" Then Exit For
c$ = c$ + t$
Next i
Count = Val("&H" + c$)
n = n + Len(c$)
c$ = ""
Case Else
Count = Asc(Char$) - 60
End Select
n = n + 1
Colr = Val("&H" + Mid$(DataSTRING$, n, 1))
For Reps = 1 To Count
PSet (x, y), Colr
x = x + 1
If x > MaxWIDTH Then x = 0: y = y + 1
Next Reps
Next n
Loop Until y > MaxDEPTH 'DATA drawing loop ends here --------------------
Get (10, 60)-(22, 72), Box(): Put (10, 60), Box()
Get (23, 60)-(35, 73), Box(100): Put (23, 60), Box(100)
Get (36, 60)-(48, 73), Box(200): Put (36, 60), Box(200)
Get (49, 60)-(61, 73), Box(300): Put (49, 60), Box(300)
Get (62, 60)-(79, 71), Box(400): Put (62, 60), Box(400)
Get (80, 60)-(97, 71), Box(500): Put (80, 60), Box(500)
Get (0, 0)-(116, 54), Box(1000): Put (0, 0), Box(1000)
Get (120, 0)-(388, 48), Box(3000): Put (120, 0), Box(3000)
Index = 1
For x = 158 To 260 Step 11
If x < 180 Then Hop = 2 Else Hop = 0
Get (x + Hop, 50)-(x + 5 + Hop, 60), NumBOX(Index)
Put (x + Hop, 50), NumBOX(Index)
Index = Index + 25
Next x
Def Seg = VarSeg(NumBOX(1))
BSave "abanums.bsv", VarPtr(NumBOX(1)), 500
Def Seg
Get (105, 60)-(123, 74), Beads(): Put (105, 60), Beads()
Get (127, 60)-(145, 74), Beads(150): Put (127, 60), Beads(150)
Get (150, 64)-(200, 75), Box(8000): Put (150, 64), Box(8000)
Get (210, 64)-(239, 75), MenuBOX(): Get (245, 64)-(265, 75), MenuBOX(100)
For x = 210 To 265
For y = 64 To 75
If Point(x, y) = 7 Then PSet (x, y), 15
Next y
Next x
Get (210, 64)-(239, 75), MenuBOX(200): Get (245, 64)-(265, 75), MenuBOX(300)
Put (210, 64), MenuBOX(200): Put (245, 64), MenuBOX(300)
Def Seg = VarSeg(MenuBOX(0))
BSave "abamenu.bsv", VarPtr(MenuBOX(0)), 800
Def Seg
Get (271, 64)-(400, 75), Box(9000): Put (271, 64), Box(9000)
Put (398, 76), Box(9000)
Get (0, 76)-(524, 88), Box(9000): Put (0, 76), Box(9000)
'Abacus drawing begins -------
View Screen(200, 149)-(443, 295)
Line (200, 149)-(443, 295), 6, BF
For Reps = 1 To 120
x = Fix(Rnd * 250) + 200
y = Fix(Rnd * 164) + 149
Size = Fix(Rnd * 30) + 1
Hop = Fix(Rnd * 5) + 2
For Radius = 1 To Size Step Hop
Circle (x, y), Radius, 12
Next Radius
Next Reps
For Reps = 1 To 1200
x = Fix(Rnd * 250) + 200
y = Fix(Rnd * 200) + 108
Grain = Fix(Rnd * 20) + 1
For xx = x To x + Grain
If Point(xx, y) = 6 Then PSet (xx, y), 12
Next xx
Next Reps
View
Put (200, 149), Box(), PSet
Put (431, 149), Box(100), PSet
Put (200, 282), Box(200), PSet
Put (431, 282), Box(300), PSet
Put (202, 193), Box(400), PSet
Put (425, 193), Box(500), PSet
Line (212, 161)-(431, 193), 0, BF
Line (212, 203)-(431, 283), 0, BF
Line (213, 160)-(430, 160), 8
Line (213, 203)-(430, 203), 8
Line (214, 149)-(429, 149), 4
Line (200, 163)-(200, 281), 4
Line (212, 194)-(431, 194), 4
Line (212, 284)-(431, 284), 4
Line (432, 161)-(432, 193), 4
Line (432, 203)-(432, 283), 4
Line (443, 163)-(443, 281), 8
Line (214, 295)-(429, 295), 8
For x = 256 To 410 Step 44
Line (x - 1, 197)-(x + 1, 199), 14, BF
Line (x - 1, 200)-(x + 1, 200), 8
PSet (x - 1, 197), 15
Next x
For x = 223 To 435 Step 22
For y = 157 To 283
If Point(x, y) = 0 Then PSet (x, y), 7
Next y
Next x
View
For x = 214 To 412 Step 22
For y = 220 To 268 Step 16
Put (x, y), Beads(), PSet
Next y
Next x
For x = 214 To 412 Step 22
Put (x, 162), Beads(150), PSet
Next x
Line (5, 5)-(634, 474), 10, B
Line (7, 7)-(632, 472), 10, B
Put (186, 48), Box(3000), PSet
For x = 186 To 460
If Point(x, 66) <> 0 Then PSet (x, 66), 7
If Point(x, 70) <> 0 Then PSet (x, 70), 15
If Point(x, 74) <> 0 Then PSet (x, 74), 15
If Point(x, 78) <> 0 Then PSet (x, 78), 7
Next x
Put (296, 96), Box(8000)
Put (210, 124), MenuBOX()
Put (412, 124), MenuBOX(100)
For x = 44 To 476 Step 432
For y = 42 To 372 Step 110
Put (x, y), Box(1000)
Next y
Next x
Put (188, 372), Box(1000)
Put (331, 372), Box(1000)
Put (58, 446), Box(9000)
For x = 220 To 418 Step 22
Put (x, 320), NumBOX()
Next x
Line (200, 316)-(443, 334), 10, B
For x = 221 To 419 Step 22
Line (x, 298)-(x + 3, 316), 10, BF
Next x
Line (200, 120)-(443, 138), 10, B
Get (324, 204)-(342, 218), Beads(300)
Get (212, 161)-(431, 330), Box()
PutBEAD 6, 3, 0: PutBEAD 6, 7, 2
Get (324, 204)-(342, 283), Box(14000)
PutBEAD 6, 6, 2: PutBEAD 6, 7, 0
Get (324, 204)-(342, 283), Box(13000)
PutBEAD 6, 5, 2: PutBEAD 6, 6, 0
Get (324, 204)-(342, 283), Box(12000)
PutBEAD 6, 4, 2: PutBEAD 6, 5, 0
Get (324, 204)-(342, 283), Box(11000)
PutBEAD 6, 3, 2: PutBEAD 6, 4, 0
Get (324, 204)-(342, 283), Box(10000)
Get (324, 161)-(342, 193), Box(15000)
PutBEAD 6, 1, 2: PutBEAD 6, 2, 1
Get (324, 161)-(342, 193), Box(16000)
Put (324, 161), Box(15000), PSet
Def Seg = VarSeg(Box(0))
BSave "abasets.bsv", VarPtr(Box(0)), 34002
For y = 0 To 320 Step 160
Get (0, y)-(639, y + 159), Box()
FileCOUNT = FileCOUNT + 1
FileNAME$ = "ABACUS" + LTrim$(RTrim$(Str$(FileCOUNT))) + ".BSV"
BSave FileNAME$, VarPtr(Box(0)), 52000
Put (0, y), Box()
Next y
Def Seg
Color 11
Locate 14, 23: Print "The graphics files for ABACUS12.BAS"
Locate 15, 26: Print "have been successfully created."
Locate 17, 27: Print "You can now run the program."
Line (120, 140)-(520, 340), 10, B
Line (124, 144)-(516, 336), 10, B
a$ = Input$(1)
System
SetPALETTE:
Data 20,0,24,0,0,42,0,0,45,10,0,50
Data 55,0,0,50,0,0,40,0,0,42,42,42
Data 30,0,0,20,10,55,25,5,29,40,30,63
Data 45,0,0,63,0,0,60,45,20,63,63,63
Restore SetPALETTE
Out &H3C8, 0
For n = 1 To 48
Read Intensity
Out &H3C9, Intensity
Next n
Return
PixDATA:
Data "#21F#0=9>B=9–0=9>B=9}0=3?9=3@0=3?9=3H0?9=3@0=3?9!0=3AB=3V0UB=9_0=3AB=3"
Data "b0=9JB=3E0=3IB=9G0=9IB=3T0=9GB=9!W0=9CBT0=3YB=9=3Z0=9CB_0=9NBD0=3KBG0=9"
Data "JB=3P0=3MB=3R0@AN0@A`0BAx0=3EB=9S0]B=3V0=3EB=9\0=9PB=9C0KB=9G0=9KBO0=9"
Data "OBQ0BAM0@A`0BAw0=9GBS0^B=9T0=9GBZ0=9SB=3B0KB=9G0=9KBN0QBQ0CAL0@A`0@AJ0"
Data "JA[0=3JBR0LB=9OBQ0=3JBX0VBB0KB=9G0=3JB=9M0RB=3O0EAK0@A`0@AJ0JAZ0=9KB=3"
Data "Q0=9JB=9?0=3LB=9O0=9KB=3V0WB=3A0=9JB=9H0JB=9L0=9LB=9>0?9=3N0kAF0PAB0JA"
Data "Z0MBQ0=9JB=9A0=3KB=3N0MBT0=3NB=9=3>0=3=9@B=3A0=9JB=9H0JB=9K0=3KB=3U0lA"
Data "F0PAB0JAZ0=9LB=9P0=9JB=9C0KBN0=9LB=9S0LB=3N0=9JB=9H0JB=9K0KB=3V0lAF0PA"
Data "B0@AB0@A[0MB=3O0=9JB=9C0=3JBO0MB=3Q0KB=3P0=9JB=9H0JB=9J0=3KBV0mAF0PAB0"
Data "@AB0@A[0=3MBO0=9JB=3D0JBO0=3MBP0=9JBR0=9JB=3H0JB=9J0KB=3U0FA>0@AD0DA=0"
Data "CAP0@A@0>AB0@AB0@AB0@AA0AAR0=9LB=9N0=9JBE0=3IBP0=9LB=9N0=3JBS0=9JBI0JB"
Data "=9J0KBV0EA?0@AC0DA?0BAP0@A@0>AB0@AB0@AB0@A@0BAS0MB=3M0=9JBF0IBQ0MB=3M0"
Data "JBT0=9JBI0JB=3I0=3KBU0EA@0BA@0DA@0BAP0@A>0BA@0@AB0@AB0@A?0AAU0NBM0=3JB"
Data "F0IBQ0NBL0=3IB=9T0=3JBI0JBJ0LBT0EAA0BA@0CAB0AAP0@A>0BA@0@AA0AAB0@A>0BA"
Data "T0=9NB=9M0JBE0=3IBP0=9NB=9K0JBV0JBI0JBJ0KB=9T0DAJ0DA\0@A@0@A@0@A?0CAB0"
Data "HAT0PB=3L0JBE0IB=9P0PB=3J0JBV0JBI0JBJ0KB=3T0CAJ0DA]0@A@0@A@0@A>0DAB0HA"
Data "S0RBL0JBD0=3IBP0RBI0=3JBV0JBI0JBJ0KBU0fAP0@AH0JAD0FAR0=3RB=9K0JBD0IB=3"
Data "O0=3RB=9H0JB=9V0JBI0JBJ0KBU0fAP0@AH0IAE0FAR0TBK0JBB0=3IB=3P0TBH0JBW0JB"
Data "I0JBJ0KB]0^AJ0ZAi0VBJ0JB@0=3JBQ0VBG0JBW0JBI0JBJ0KB]0^AJ0YAi0=3VB=9I0JB"
Data "=9LB=3Q0=3VB=9F0JBW0JBI0JBJ0KB]0@AX0>AJ0VA@0PAT0FB=0MB=3H0YB=9S0FB=0MB"
Data "=3E0JBW0JBI0JBJ0KB]0@AX0>AJ0VA@0PAS0=9EB=3=0=3MBH0\B=3O0=9EB=3=0=3MBE0"
Data "JB=9V0JBI0JBJ0KB]0@AX0>AP0@A@0@A@0@A@0RAP0=3EB=9?0MB=9G0^B=3L0=3EB=9?0"
Data "MB=9D0KBV0JBI0JBJ0KB]0@AX0>AP0@A@0@A@0@A@0RAP0FB@0=3MB=3F0_B=9K0FB@0=3"
Data "MB=3C0KBV0JBI0JBJ0KB]0^AP0@A@0@A@0@AD0@AB0DAO0=9EB=3A0=9MBF0JB=9QB=9I0"
Data "=9EB=3A0=9MBC0KBV0JBI0JBJ0KB]0^AP0@A@0@A@0@AD0@AB0CAO0=3EB=9C0MB=9E0JB"
Data "@0=3=9MB=9G0=3EB=9C0MB=9B0KB=9U0JBI0JBJ0KB]0^AP0@A@0@A@0@AD0LAP0FB>0?B"
Data "=9>0=3MB=3D0JBC0=9LBG0FB>0?B=9>0=3MB=3A0LBU0JB=3H0JBJ0KB]0^AP0@A@0@A@0"
Data "@AD0KAP0=9EB=3=0AB=3>0NBD0JBD0=3KB=9E0=9EB=3=0AB=3>0NBA0MBT0JB=9H0JBJ0"
Data "KB]0@AX0>AP0@A@0@A@0@AF0FAR0=3EB=9=0=9BB>0=3MB=9C0JBE0=3KBD0=3EB=9=0=9"
Data "BB>0=3MB=9@0MB=9S0KBH0JBJ0KB]0@AX0>AP0@A@0@A@0@AF0FAR0FB=0=9DB>0=9MB=3"
Data "B0JBF0KBD0FB=0=9DB>0=9MB=3?0=3MB=9R0KBH0JBJ0KB]0^AO0AAH0@AD0HAQ0=9EB=3"
Data "=9FB>0NBB0JBF0=3JBC0=9EB=3=9FB>0NB@0NB=9Q0KBH0JBJ0KB]0^AN0BAH0@AD0HAP0"
Data "=3EB>9HB=0=9NB@0=3JBG0JBB0=3EB>9HB=0=9NB?0PB=3O0KB=3G0JBI0=9KB]0^AM0CA"
Data "D0bAF0FB=9JB=0NB=9?0=9JBG0JBB0FB=9JB=0NB=9>0=3QB=9M0LBF0=3JB=3H0KB=9]0"
Data "^AL0DAD0bAE0=9VB=3NB?0=9JBF0=9JBA0=9VB=3NB?0UB=9=3?0=3>9=3A0MBC0=3LB=9"
Data "H0KB=3]0@AX0>AL0CAE0NAF0DAF0=3kB>0=9JB=3E0KB@0=3kB>0=3]BA0OB=3=0=3OB=9"
Data "H0KB^0@AX0>AL0BAF0NAF0DAF0YB=0NB=9=0=9JB=9D0=3JB=9@0YB=0NB=9>0=9[B=9A0"
Data "eB=9G0=9JB=9^0^AL0BAs0FB=9=3MB=9=0=9NB=0=9JB=9C0=3KB=3?0FB=9=3MB=9=0=9"
Data "NB?0[BB0=3dB=9F0=3KB_0^AL0AAs0=3FB?0KB=3?0MB=9=0=9JB=9B0=9KB=9?0=3FB?0"
Data "KB=3?0MB=9@0YBD0dB=9E0=3KB=9_0^AR0dAJ0FB=3@0=9HBA0=3KB=9>0=9JB=9?0=3=9"
Data "MB@0FB=3@0=9HBA0=3KB=9B0WB=3D0dB=9>0?9>3=9LB=9`0^AR0dAJ0EB=9B0=9FBC0JB"
Data "=3?0aBA0EB=9B0=9FBC0JB=3D0=9TB=9E0=3SB=9=0JB=9>0RBi0@AF0BAX0dAJ0=9DBD0"
Data "=3DBD0=3GB=9A0`BB0=9DBD0=3DBD0=3GB=9G0=9SBG0=9QB=3=0=3KB>0PB=9j0@AF0BA"
Data "X0dAK0CB=3F0AB=9F0=9EB=9B0^B=3D0CB=3F0AB=9F0=9EB=9J0=9PBI0OB=3?0=9KB>0"
Data "=3NB=9k0@AF0BAX0@AD0@AD0@AD0@AK0=9BBH0?B=9H0DB=3C0=3[B=3F0=9BBH0?B=9H0"
Data "DB=3M0=9MB=3J0=9KB=3A0=9JB=3?0LB=9m0@AF0BAX0@AD0@AD0@AD0@AL0ABY0=9BBF0"
Data "=3VB=9K0ABY0=9BBR0=3IB=9M0=9FB=3D0=3IBB0=3HB=3]0tAF0@AD0@AD0@AD0@AL0=3"
Data "?B=9Z0ABr0=3?B=9Z0AB!J0tAF0@AD0@AD0@AD0@AM0?B[0=3?Bt0?B[0=3?B!K0tAF0@A"
Data "D0@AD0@AD0@A#124#0tAF0@AD0@AD0@AD0@A#134#0BAF0BAX0@AD0@AD0@AD0@A#134#0"
Data "BAF0BAX0@AD0@AD0@AD0@Aq0@FD0>FB0@FC0@FE0>FB0BFB0@FB0BFB0@FC0@F!T0DAF0BA"
Data "X0@AD0@AD0@AD0@Ap0>F>0>FA0@FA0>F>0>FA0>F>0>FC0?FB0>FE0>F>0>FE0>FA0>F>0"
Data ">FA0>F>0>F!S0DAF0BAX0@AD0@AD0@AD0@Ap0>F>0>FC0>FE0>FE0>FC0?FB0>FE0>FH0>F"
Data "B0>F>0>FA0>F>0>F#127#0>F>0>FC0>FE0>FE0>FB0@FB0AFB0>FH0>FB0>F>0>FA0>F>0"
Data ">F#127#0>F>0>FC0>FD0>FD0?FC0@FB0>F>0>FA0AFD0>FD0@FC0AF#127#0>F>0>FC0>F"
Data "C0>FG0>FA0>F=0>FF0>FA0>F>0>FC0>FC0>F>0>FE0>F#127#0>F>0>FC0>FB0>FH0>FA0"
Data "BFE0>FA0>F>0>FB0>FD0>F>0>FE0>F#127#0>F>0>FC0>FA0>FE0>F>0>FD0>FB0>F>0>F"
Data "A0>F>0>FB0>FD0>F>0>FA0>F>0>F#128#0@FD0>FA0BFB0@FE0>FC0@FC0@FC0>FE0@FC0"
Data "@F!N0VF=EG6>0@6@C?6=E?6>FA6K0B6>F?6H0=6>5A4=6I0=1>3A9=1#10B#0HE>8JE>6=C"
Data "=6AC=6>0F6>E>6BE>6K4?6=FAE>6F0=6=C>5D4=6E0=1=2>3D9=1#109#0?E>8BE=8>6=8"
Data "BE>8BEH6BC>6=F>E>6@E>8=EN6=F>8@E>6E0>6=C>5@4=D=F=D>4=6C0>1=2>3@9=B=F=B"
Data ">9=1#108#0>E@6=E@8@6@8=E@6AEECG6?E=6AE=6=F>E>6=F>EB6=F>E>6=F=E=6=FAE=6"
Data "D0>6>C=5A4?F?4=6A0>1>2=3A9?F?9=1#107#0>E@6=EB6AC=6=E@6AEA6=F=EB6=F=E>6"
Data ">C=6AE>8EE=8>E@6>E=8EE>8>ED0=6>C>5A4=D=F=D?4=CA0=1>2>3A9=B=F=B?9=2#107#0"
Data "?E>6=F>EACA6?E>6=FAE?6@EB6@E?6AE>6DE?6BE?6DE>6>EC0>6>C>5H4=C?0>1>2>3H9"
Data "=2A0=B@0=Bf0=BF0A7>0A7>0?7>0A7=0A7B0@7>0=7@0=7=0=7=0A7f0=BC0=B[0=B\0=B"
Data "V0BE>8=E@6>C>6=E>8EE>6=E>8=E=8AC=6=8=E>8=E>6AE=6=FEE=6=F=E@8>E=6=FDE>6"
Data ">EC0>6>C?5F4>C?0>1>2?3F9>2@0=BA0=Bg0=BE0=7@0=7=0=7A0=7?0=7=0=7C0=7C0=7"
Data "@0=7=0=7@0=7=0=7?0=7D0>B>0=B=0=BD0=B>0=BM0=BC0=B[0=B\0=BA0=BP0?E>8=E>6"
Data "=ED6=E>6=E>8EE>6=ED6=E>6BE=8AE>8>E>8?E=8@6=8?E>8>E>8AE=8C0=C=6?C>5G4=C"
Data "?0=2=1?2>3G9=2@0=BA0=Bg0=BE0=7@0=7=0=7A0=7A0=7C0=7C0=7@0=7=0=7@0=7=0=7"
Data "?0=7C0=B>0>B>0=BD0=B>0=BM0=BC0=B[0=B\0=BA0=BP0?E>6=8>E=F=EAC=6=F?E=8>6"
Data "BE>8?E=8=6>C=6=C=6=C=6=8?E>8?E>8@E=6=F=E=8>6?8>C@6?8>6=8=E=6=F@E=8=6C0"
Data "=5>6>C>5E4=5>C?0=3>1>2>3E9=3>2@0=BA0=B>0?B>0@B?0?B>0=B=0>B?0?B?0>B?0?B"
Data "?0=BE0=7@0=7=0=7A0=7A0=7C0=7C0=7@0=7=0=7@0=7=0=7?0=7J0>B>0?B>0>B=0>B>0"
Data "?B>0=B=0>B@0=B?0?B>0@B?0?B?0?B>0=B?0=B>0>B@0=B>0@B?0?B?0@B>0?B?0>B@0=B"
Data "=0>B>0>B=0?B=0>BH0?E?6>8>EB6>E>8>C=6AE@6=E=8FC=8=E@6>E>6BE=8N6=8BE>6C0"
Data "=C?6>C>5=4=5A4=5>C=6?0=2?1>2>3=9=3A9=3>2=1@0=BA0=BA0=B=0=B?0=BA0=B=0>B"
Data ">0=B=0=B?0=B=0=B>0=B=0=B?0=B>0=BE0A7>0@7?0?7>0@7@0=7C0=7@0=7=0=7@0=7=0"
Data "=7?0=7J0=B>0=B?0=B=0=B>0=B>0=B?0=B=0>B>0=B?0=BB0=B=0=B?0=BA0=B=0=B?0=B"
Data "=0=B?0=B=0=B>0=B?0=B>0=B?0=BA0=B=0=B?0=B=0=B?0=B=0=B>0=B?0>B>0=B=0=B>0"
Data "=B>0=B>0=BG0?E>C?6>8?6=C>6>8A6AE@6=EH6=E@6>E>6=8>E?8>CK8?6?8>E=8>6D0=5"
Data "?6>C>5=4=5=4@5=C=6A0=3?1>2>3=9=3=9@3=2=1A0=BA0=B>0@B=0=B?0=B>0@B=0=B?0"
Data "=B=0AB>0=B?0AB>0=BE0=7@0=7=0=7E0=7=0=7C0=7C0=7@0=7=0=7@0=7=0=7?0=7J0=B"
Data ">0=B?0=B=0=B>0=B>0=B?0=B=0=B?0=B>0=B@0@B=0=B?0=B>0@B=0=BA0=B?0=B>0=B@0"
Data "=B?0=B?0=B>0@B=0=B?0=B=0AB>0=BA0=B?0=B=0=B>0=B>0=B>0=BG0>E=8I6CCBE>6=F"
Data "BE>6=FBE>6=F>E?6>8A6K0B6>8?6D0=6=C?6?C?5=C=5?C=6A0=1=2?1?2?3=2=3?2=1A0"
Data "=B>0=B>0=B=0=B?0=B=0=B?0=B=0=B?0=B=0=B?0=B=0=BC0=B>0=BB0=BE0=7@0=7=0=7"
Data "E0=7=0=7C0=7C0=7>0=7=0=7=0=7@0=7=0=7?0=7J0=B>0=B?0=B=0=B>0=B>0=B?0=B=0"
Data "=B?0=B>0=B?0=B?0=B=0=B?0=B=0=B?0=B=0=BA0=B?0=B?0=B?0=B?0=B?0=B=0=B?0=B"
Data "=0=B?0=B=0=BC0=B@0=B?0=B=0=B>0=B>0=B>0=BG0=E=8@C>6=C=6>C>8E6=8XEi0=5=C"
Data "@6=C=6BC=6C0=3=2@1=2=1B2=1B0=B>0=B>0=B=0=B?0=B=0=B?0=B=0=B?0=B=0=B?0=B"
Data "=0=B?0=B=0=B>0=B=0=B?0=B>0=BE0=7@0=7=0=7A0=7?0=7=0=7C0=7C0=7?0>7=0=7@0"
Data "=7=0=7?0=7J0=B>0=B?0=B=0=B>0=B>0=B?0=B=0=B?0=B=0=B@0=B?0=B=0=B?0=B=0=B"
Data "?0=B=0=B?0=B=0=B>0>B=0=B>0=B=0=B@0=B?0=B=0=B?0=B=0=B?0=B=0=B?0=B=0=B>0"
Data "=B?0=B?0=B=0=B>0=B>0=B>0=BU0F6=8=EV8j0=6=5=CF6E0=1=3=2F1C0=B?0>B?0@B=0"
Data "@B?0@B=0=B?0=B>0?B?0>B?0?B?0=BE0=7@0=7=0A7>0?7>0A7?0=7D0@7?0@7>0=7?0=7"
Data "K0=B>0?B?0=B>0=B>0?B>0=B?0=B=0=BA0@B=0@B?0@B>0?B?0>B=0=B>0>B>0=B@0@B?0"
Data "@B>0@B>0?B?0>B>0=B=0=B?0=B>0=B=0=B>0=B>0=B«0=6>C?6=C>6I0=1>2?1=2>1E0=B"
Data "I0=B_0=Bm0=7Ÿ0=BK0=B!r0=BH0=B^0=B!R0=BG0@B#1AE#0ABn0=Be0=BC0=BQ0=B‹0=B"
Data "e0=BB0=BD0=BR0=B@0=BK0=BA0=BW0=BA0=B=0=Bh0=B=0=Br0=BC0=BH0=BD0=BO0=BQ0"
Data "=BS0=Bs0=Bn0=BB0=BA0=B>0=BI0=B@0=BK0=BA0=B]0=BN0=BW0=B=0=Br0=BC0=BH0=B"
Data "D0=BO0=BQ0=BS0=Bs0=Bn0=BB0=BA0=B>0=BI0=B@0=BK0=BA0=B]0=BN0=BW0=B=0=BB0"
Data "?B>0>BB0?BC0?B?0?B>0?B=0>B>0@B>0=B>0?B>0>B>0?BB0>B=0=B?0=B=0>B>0?B>0>B"
Data "=0=B>0?B>0=BB0?B>0=B=0>BB0=B=0>B?0?B>0=B>0=B>0=BA0>B>0?BB0=B?0=B>0>B?0"
Data "?BC0?B>0=B=0>BC0?B>0@B?0?B?0?B>0=B?0=B>0>BE0=B?0=B=0=B>0>B>0=B=0>BA0=B"
Data "=0>B>0>B=0>B=0@B>0=B?0=B@0=B>0=B>0=B>0=B>0?B>0@B>0=B=0>B?0?B>0?B=0>B?0"
Data "?B@0=B>0@B=0=B=0>B>0?B?0?B>0>B@0?B?0?B>0?B=0>B@0=B>0@B>0=B?0=B=0=BF0=B"
Data "A0=B?0=B=0=B?0=B=0=B>0=B>0=B=0=B?0=B=0=B=0=B?0=B=0=B>0=B?0=BA0=B>0=B?0"
Data "=B=0=B>0=B?0=B=0=B>0=BA0=B=0=BA0=B?0=B=0>B>0=BA0>B>0=B=0=B?0=B=0=B>0=B"
Data ">0=BA0=B>0=B?0=BA0=B?0=B=0=B>0=B=0=B?0=BE0=B=0>B>0=BE0=B=0=B?0=BA0=B=0"
Data "=B?0=B=0=B?0=B=0=B>0=BD0=B?0=B=0=B=0=B>0=B=0=B=0=BB0>B>0=B=0=B>0=B>0=B"
Data "?0=BA0=B@0=B>0=B>0=B>0=B=0=B?0=B=0=B?0=B=0>B>0=B=0=B?0=B=0=B>0=B>0=B=0"
Data "=B?0=B?0=B=0=B?0=B=0=B=0=B>0=B?0=B=0=B?0=B=0=B@0=B?0=B=0=B?0=B=0=B>0=B"
Data ">0=B?0=B>0=BA0=B?0=B=0=BC0@BA0=BA0=B?0=B=0=B>0=B>0=B=0=B?0=B=0=B=0AB=0"
Data "=B>0ABA0=B>0=B?0=B=0=B>0=B?0=B=0=B>0=B>0@B=0=BA0=B?0=B=0=B?0=BA0=B?0=B"
Data "=0=B?0=B=0=B=0=B=0=B=0=BA0=B>0=B?0=BA0=B?0=B>0=B?0ABB0@B=0=B?0=BB0@B=0"
Data "=B?0=B>0@B=0=BA0=B?0=B>0=BG0=B=0=B>0=B>0=B?0=B=0=BB0=B?0=B=0=B>0=B>0=B"
Data "?0=B@0=B@0=B?0=B=0=B=0=B=0=B=0AB=0=B?0=B=0=B?0=B=0=B?0=B=0=B>0=B>0=B=0"
Data "AB?0=B=0=B?0=B=0=B=0=B>0AB=0=BA0=B@0=BA0=B?0=B=0=B>0=B>0=B>0=B?0=BA0=B"
Data "?0=B=0=BB0=B?0=BA0=BA0=B?0=B=0=B>0=B>0=B=0=B?0=B=0=B=0=BA0=B>0=BE0=B>0"
Data "=B?0=B=0=B>0=B?0=B=0=B>0=B=0=B?0=B=0=BA0=B?0=B=0=B?0=BA0=B?0=B=0=B?0=B"
Data "=0=B=0=B=0=B=0=BA0=B>0=B?0=BA0=B?0=B?0=B>0=BE0=B?0=B=0=B?0=BA0=B?0=B=0"
Data "=B?0=B=0=B?0=B=0=BA0=B?0=B?0=BF0=B=0=B>0=B?0=B>0=B=0=BB0=B?0=B=0=B>0=B"
Data ">0=B?0=B@0=B@0=B?0=B=0=B=0=B=0=B=0=BA0=B?0=B=0=B?0=B=0=B?0=B=0=B>0=B>0"
Data "=B=0=BC0=B=0=B?0=B=0=B=0=B>0=BA0=BA0=B@0=BA0=B?0=B=0=B>0=B>0=B>0=B?0=B"
Data "A0=B?0=B=0=BB0=B?0=BA0=B?0=B=0=B?0=B=0=B>0=B>0=B=0=B?0=B=0=B=0=B?0=B=0"
Data "=B>0=B?0=BA0=B>0=B>0>B=0=B>0=B?0=B=0=B>0=B=0=B?0=B=0=BA0=B?0=B=0=B?0=B"
Data "A0=B?0=B=0=B?0=B>0=B?0=BB0=B>0=B?0=BA0=B>0>B=0=B>0=B=0=B?0=BA0=B?0=B=0"
Data "=B?0=BA0=B?0=B=0=B?0=B=0=B?0=B=0=B?0=B=0=B>0>B=0=B>0=BF0=B?0=B=0=B>0=B"
Data "=0=B=0=BB0=B?0=B=0=B>0=B>0=B?0=B?0=B@0=BA0=B?0=B>0=B?0=B=0=B?0=B=0=B?0"
Data "=B=0=B?0=B=0=B>0=B>0=B=0=B?0=B?0=B=0=B?0=B=0=B=0=B>0=B?0=B=0=B?0=B=0=B"
Data "@0=B?0=B=0=B?0=B=0=B>0=B>0=B=0=B@0=BB0?B>0=BC0@BB0?B?0?B>0=B>0=B>0=B=0"
Data "@B>0=B>0?B?0=B>0?BC0=B>0>B=0=B>0=B>0?B>0=B>0=B>0@B=0=BB0?B>0=B?0=BA0=B"
Data "?0=B>0?B?0=B?0=BC0=B>0?BC0>B=0=B>0>B?0?BC0@B=0=B?0=BB0@B=0@B?0@B>0?B?0"
Data ">B=0=B>0>B?0=BC0=B?0=B>0>B>0=B>0=BA0=B?0=B>0=B>0=B=0@B>0=B=0=B@0=BA0=B"
Data "?0=B?0?B>0@B>0=B?0=B>0?B>0=B>0=B>0=B>0?B>0=B=0=B>0@B=0=B=0=B?0?B?0?B?0"
Data "=B=0=B>0?B?0?B>0=B>0=B>0=B=0=Bq0=B!v0=Bd0=B´0"
Sub PutBEAD (col, row, Index)
If row < 3 Then Hop = 0 Else Hop = 10
PutCOL = col * 22 + 192
PutROW = row * 16 + 146 + Hop
PutINDEX = Index * 150
Put (PutCOL, PutROW), Beads(PutINDEX), PSet
End Sub

BIN
samples/abacus/src/abacus.zip Normal file
View file

Binary file not shown.

BIN
samples/abacus/src/abacus1.bsv Normal file
View file

Binary file not shown.

280
samples/abacus/src/abacus12.bas Normal file
View file

@ -0,0 +1,280 @@
'****************************************************************************'
'
'------------------------- A B A C U S 1 2. B A S ---------------------------'
'--------------- Copyright (C) 2007 by Bob Seguin (Freeware) ----------------'
'
'****************************************************************************'
DefInt A-Z
DECLARE FUNCTION InitMOUSE ()
DECLARE SUB MouseSTATUS (LB, RB, MouseX, MouseY)
DECLARE SUB ShowMOUSE ()
DECLARE SUB HideMOUSE ()
DECLARE SUB ClearMOUSE ()
DECLARE SUB MouseDRIVER (LB, RB, MX, MY)
DECLARE SUB Graphics ()
DECLARE SUB PutBEADS (col, OneVAL)
DECLARE SUB PutNUM (col)
DECLARE SUB Menu (InOUT)
DECLARE SUB ResetABACUS ()
Dim Shared Box(26000)
Dim Shared NumBOX(1 To 250)
Dim Shared MenuBOX(600)
Def Seg = VarSeg(NumBOX(1))
BLoad "abanums.bsv", VarPtr(NumBOX(1))
Def Seg = VarSeg(MenuBOX(0))
BLoad "abamenu.bsv", VarPtr(MenuBOX(0))
Def Seg
Dim Shared Abacus(1 To 10, 1 To 2)
Dim Shared MouseDATA$
Dim Shared LB, RB
'Create and load MouseDATA$ for CALL ABSOLUTE routines
Cheddar:
Data 55,89,E5,8B,5E,0C,8B,07,50,8B,5E,0A,8B,07,50,8B,5E,08,8B
Data 0F,8B,5E,06,8B,17,5B,58,1E,07,CD,33,53,8B,5E,0C,89,07,58
Data 8B,5E,0A,89,07,8B,5E,08,89,0F,8B,5E,06,89,17,5D,CA,08,00
MouseDATA$ = Space$(57)
Restore Cheddar
For i = 1 To 57
Read h$
Hexxer$ = Chr$(Val("&H" + h$))
Mid$(MouseDATA$, i, 1) = Hexxer$
Next i
Moused = InitMOUSE
If Not Moused Then
Print "Sorry, cat must have got the mouse."
Sleep 2
System
End If
Screen 12
GoSub SetPALETTE
Graphics
ShowMOUSE
Do
k$ = InKey$
If k$ = Chr$(27) Then System
MouseSTATUS LB, RB, MouseX, MouseY
Select Case MouseX
Case 212 TO 233: col = 1
Case 234 TO 255: col = 2
Case 256 TO 277: col = 3
Case 278 TO 299: col = 4
Case 300 TO 321: col = 5
Case 322 TO 343: col = 6
Case 344 TO 365: col = 7
Case 366 TO 387: col = 8
Case 388 TO 409: col = 9
Case 410 TO 431: col = 10
Case Else: col = 0
End Select
Select Case MouseY
Case 124 TO 133: Menu 1
Case 161 TO 176: row = 1
Case 177 TO 192: row = 2
Case 202 TO 218: row = 3
Case 219 TO 234: row = 4
Case 235 TO 250: row = 5
Case 251 TO 266: row = 6
Case 267 TO 282: row = 7
Case Else: row = 0: Menu 0
End Select
If LB = -1 Then
If col <> 0 Then
Select Case row
Case 1: PutBEADS col, 6: Abacus(col, 1) = 5
Case 2: PutBEADS col, 5: Abacus(col, 1) = 0
Case 3 TO 7: Sum = row - 3: Abacus(col, 2) = Sum: PutBEADS col, Sum
End Select
PutNUM col
End If
ClearMOUSE
End If
Loop
System
SetPALETTE:
Data 20,0,24,0,0,42,0,0,45,10,0,50
Data 55,0,0,50,0,0,40,0,0,42,42,42
Data 30,0,0,20,10,55,25,5,29,40,30,63
Data 45,0,0,63,0,0,60,45,20,63,63,63
Restore SetPALETTE
Out &H3C8, 0
For n = 1 To 48
Read Intensity
Out &H3C9, Intensity
Next n
Return
Sub ClearMOUSE
While LB Or RB
MouseSTATUS LB, RB, MouseX, MouseY
Wend
End Sub
Sub Graphics
Def Seg = VarSeg(Box(0))
For y = 0 To 320 Step 160
FileCOUNT = FileCOUNT + 1
FileNAME$ = "ABACUS" + LTrim$(RTrim$(Str$(FileCOUNT))) + ".BSV"
BLoad FileNAME$, VarPtr(Box(0))
Put (0, y), Box()
Next y
BLoad "abasets.bsv", VarPtr(Box(0))
Def Seg
End Sub
Sub HideMOUSE
LB = 2
MouseDRIVER LB, 0, 0, 0
End Sub
Function InitMOUSE
LB = 0
MouseDRIVER LB, 0, 0, 0
InitMOUSE = LB
End Function
Sub Menu (InOUT)
Static MenuITEM
If InOUT = 0 Then GoSub CloseMENU: Exit Sub
MouseSTATUS LB, RB, MouseX, MouseY
Select Case MouseX
Case 210 TO 238
If MenuITEM <> 1 Then
GoSub CloseMENU
MenuITEM = 1
GoSub OpenMENU
End If
Case 412 TO 432
If MenuITEM <> 2 Then
GoSub CloseMENU
MenuITEM = 2
GoSub OpenMENU
End If
Case Else: GoSub CloseMENU
End Select
If LB = -1 Then
Select Case MenuITEM
Case 1: ResetABACUS
Case 2: GoSub CloseMENU: System
End Select
End If
Exit Sub
OpenMENU:
HideMOUSE
Select Case MenuITEM
Case 1: Put (210, 124), MenuBOX(200), PSet
Case 2: Put (412, 124), MenuBOX(300), PSet
End Select
ShowMOUSE
Return
CloseMENU:
If MenuITEM <> 0 Then
HideMOUSE
Select Case MenuITEM
Case 1: Put (210, 124), MenuBOX(), PSet
Case 2: Put (412, 124), MenuBOX(100), PSet
End Select
ShowMOUSE
MenuITEM = 0
End If
Return
End Sub
Sub MouseDRIVER (LB, RB, MX, MY)
Def Seg = VarSeg(MouseDATA$)
mouse = SAdd(MouseDATA$)
Call ABSOLUTE_MOUSE_EMU(LB, RB, MX, MY)
End Sub
Sub MouseSTATUS (LB, RB, MouseX, MouseY)
LB = 3
MouseDRIVER LB, RB, MX, MY
LB = ((RB And 1) <> 0)
RB = ((RB And 2) <> 0)
MouseX = MX
MouseY = MY
End Sub
Sub PutBEADS (col, BeadVAL)
PutCOL = col * 22 + 192
If BeadVAL > 4 Then Hop = -43 Else Hop = 0
HideMOUSE
Put (PutCOL, 204 + Hop), Box(BeadVAL * 1000 + 10000), PSet
ShowMOUSE
End Sub
Sub PutNUM (col)
Sum = Abacus(col, 1) + Abacus(col, 2)
HideMOUSE
Put (col * 22 + 198, 320), NumBOX(Sum * 25 + 1), PSet
ShowMOUSE
End Sub
Sub ResetABACUS
HideMOUSE
Put (212, 161), Box(), PSet
ShowMOUSE
Erase Abacus
End Sub
Sub ShowMOUSE
LB = 1
MouseDRIVER LB, 0, 0, 0
End Sub
Sub ABSOLUTE_MOUSE_EMU (AX%, BX%, CX%, DX%)
Select Case AX%
Case 0
AX% = -1
Case 1
_MouseShow
Case 2
_MouseHide
Case 3
While _MouseInput
Wend
BX% = -_MouseButton(1) - _MouseButton(2) * 2 - _MouseButton(3) * 4
CX% = _MouseX
DX% = _MouseY
Case 4
_MouseMove CX%, DX% 'Not currently supported in QB64 GL
End Select
End Sub

BIN
samples/abacus/src/abacus2.bsv Normal file
View file

Binary file not shown.

BIN
samples/abacus/src/abacus3.bsv Normal file
View file

Binary file not shown.

BIN
samples/abacus/src/abamenu.bsv Normal file
View file

Binary file not shown.

BIN
samples/abacus/src/abanums.bsv Normal file
View file

Binary file not shown.

BIN
samples/abacus/src/abasets.bsv Normal file
View file

Binary file not shown.

3
samples/abacus/src/readme.txt Normal file
View file

@ -0,0 +1,3 @@
Unzip to your QBasic folder or a different folder or make a game folder and unzip files into it.
NOTE: This game requires graphics files created by any accompanying .bas programs in the zip file. If two or more accompanying .bas files are present, run the first on only. It will automatically chain (run) the second file. After you run the accompanying .bas file, the main program ready to use!

BIN
samples/amongst/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 13 KiB

30
samples/amongst/index.md Normal file
View file

@ -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: AMONGST
![screenshot.png](img/screenshot.png)
### Author
[🐝 Fellippe Heitor](../fellippe-heitor.md)
### Description
A pretentious clone attempt of Among Us (originally by Inner Sloth)
To test:
1) Compile/run amongst_server.bas.
2) Compile/run amongst.bas, choose name and color, join local host.
3) Compile/run amongst.bas a second time, choosing another name and color, join same local host.
### File(s)
* [amongst.bas](src/amongst.bas)
* [amongst.zip](src/amongst.zip)
* [amongst_server.bas](src/amongst_server.bas)
* [amongst_updater.bas](src/amongst_updater.bas)
🔗 [game](../game.md), [multiplayer](../multiplayer.md)
<sub>Reference: [qb64.org Forum](https://github.com/FellippeHeitor/amongst) </sub>

1567
samples/amongst/src/amongst.bas Normal file
View file

File diff suppressed because it is too large Load diff

BIN
samples/amongst/src/amongst.zip Normal file
View file

Binary file not shown.

452
samples/amongst/src/amongst_server.bas Normal file
View file

@ -0,0 +1,452 @@
Option _Explicit
Dim Shared gameVersion As Integer
'this is to be increased everytime the client
'becomes incompatible with previous versions
gameVersion = 3
$Let DEBUGGING = FALSE
$If DEBUGGING = TRUE Then
$CONSOLE
$End If
$Console:Only
_Dest _Console
Const True = -1, False = 0
Const id_SERVERFULL = 1
Const id_PING = 2
Const id_ID = 3
Const id_NEWCOLOR = 4
Const id_NEWNAME = 5
Const id_COLOR = 6
Const id_POS = 7
Const id_NAME = 8
Const id_CHAT = 9
Const id_PLAYERONLINE = 10
Const id_PLAYEROFFLINE = 11
Const id_PONG = 12
Const id_PLAYERQUIT = 13
Const id_GAMEVERSION = 14
Const id_SHOOT = 15
Const id_SIZE = 16
Const id_UPDATESERVER = 17
Const id_KICK = 18
Type object
name As String
handle As Long
x As Single
xv As Single
y As Single
yv As Single
state As Integer
color As Integer
basicInfoSent As _Byte
broadcastOffline As _Byte
ping As Single
hasNewName As _Byte
hasNewColor As _Byte
hasNewPosition As String
hasNewMessage As _Byte
hasNewSize As _Byte
size As Integer
End Type
Const maxUsers = 10
Dim Shared totalClients As Integer
Dim Shared playerStream(1 To maxUsers) As String
Dim Shared player(1 To maxUsers) As object
Dim Shared colors(1 To 12) As _Unsigned Long
Dim i As Long, j As Long
Dim newClient As Long, checkUpdate As _Byte, checkUpdateRequester As Integer
Dim id As Integer, value$
Dim packet$
Dim Shared endSignal As String
endSignal = Chr$(253) + Chr$(254) + Chr$(255)
Const timeout = 20
Dim Shared host As Long
Print Time$ + " Starting server (ver. "; _Trim$(Str$(gameVersion)); ")... ";
host = _OpenHost("TCP/IP:51512")
If host = 0 Then
Print "Cannot listen on port 51512"
System
End If
Print "Listening on port 51512"
Do
newClient = 0
newClient = _OpenConnection(host)
If newClient Then
If totalClients < maxUsers Then
totalClients = totalClients + 1
For i = 1 To maxUsers
If player(i).state = False Then
playerStream(i) = ""
player(i).color = 0
player(i).handle = newClient
player(i).state = True
player(i).broadcastOffline = False
player(i).size = 15
sendData player(i), id_GAMEVERSION, MKI$(gameVersion)
sendData player(i), id_ID, MKI$(i)
'send existing players' data:
For j = 1 To maxUsers
If j = i Then _Continue
If player(j).state = True Then
sendData player(j), id_PLAYERONLINE, MKI$(i)
sendData player(i), id_PLAYERONLINE, MKI$(j)
sendData player(i), id_NAME, MKI$(j) + player(j).name
sendData player(i), id_COLOR, MKI$(j) + MKI$(player(j).color)
sendData player(i), id_POS, MKI$(j) + MKS$(player(j).x) + MKS$(player(j).y) + MKS$(player(j).xv) + MKS$(player(j).yv)
sendData player(i), id_SIZE, MKI$(j) + MKI$(player(j).size)
End If
Next
player(i).ping = Timer
Exit For
End If
Next
Print Time$ + " User at " + _ConnectionAddress$(newClient) + " connected as client #" + LTrim$(Str$(i))
Else
packet$ = MKI$(id_SERVERFULL) + endSignal
Put #newClient, , packet$
Print Time$ + " Connection from " + _ConnectionAddress$(newClient) + " refused (server full)"
Close newClient
End If
End If
For i = 1 To maxUsers
If player(i).state = False Then
If player(i).broadcastOffline = False Then
player(i).broadcastOffline = True
For j = 1 To maxUsers
If j = i Or player(j).state = False Then _Continue
sendData player(j), id_PLAYEROFFLINE, MKI$(i)
Next
End If
_Continue
End If
player(i).hasNewName = False
player(i).hasNewColor = False
player(i).hasNewPosition = ""
player(i).hasNewMessage = False
player(i).hasNewSize = False
If timeElapsedSince(player(i).ping) > timeout Then
'player inactive
player(i).state = False
Close player(i).handle
Print Time$ + " Client #" + LTrim$(Str$(i)) + " (" + player(i).name + ") lost connection."
totalClients = totalClients - 1
_Continue
End If
getData player(i), playerStream(i)
Do While parse(playerStream(i), id, value$)
player(i).ping = Timer
Select Case id
Case id_NAME
player(i).hasNewName = True
player(i).name = value$
Dim attempt As Integer, checkAgain As _Byte, m$
m$ = ""
attempt = 0
Do
checkAgain = False
For j = 1 To maxUsers
If j = i Then _Continue
If attempt Then m$ = Str$(attempt)
If player(j).name = player(i).name + m$ Then
attempt = attempt + 1
checkAgain = True
Exit For
End If
Next
Loop While checkAgain
If attempt Then
player(i).name = player(i).name + m$
sendData player(i), id_NEWNAME, player(i).name
End If
Print Time$ + " Client #" + LTrim$(Str$(i)) + " has name " + player(i).name
Case id_COLOR 'received once per player
player(i).hasNewColor = True
Dim newcolor As Integer, changed As _Byte
newcolor = CVI(value$)
changed = False
'check if this color is already in use, so another one can be assigned
For j = 1 To maxUsers
If player(j).state = True And player(j).color = newcolor Then
newcolor = newcolor + 1
If newcolor > UBound(colors) Then newcolor = 1
changed = True
j = 0 'check again
End If
Next
player(i).color = newcolor
If changed Then
sendData player(i), id_NEWCOLOR, MKI$(newcolor)
End If
Case id_SHOOT
If player(CVI(value$)).size > 5 Then
player(CVI(value$)).size = player(CVI(value$)).size - 2
End If
For j = 1 To maxUsers
If player(j).state = False Then _Continue
sendData player(j), id_SHOOT, MKI$(i) + value$
sendData player(j), id_SIZE, value$ + MKI$(player(CVI(value$)).size)
Next
Case id_POS
player(i).hasNewPosition = value$
player(i).x = getCVS(value$)
player(i).y = getCVS(value$)
player(i).xv = getCVS(value$)
player(i).yv = getCVS(value$)
Case id_SIZE
player(i).hasNewSize = True
player(i).size = CVI(value$)
Case id_GAMEVERSION
'player is signaling it will disconnect due to wrong version
player(i).x = -1
player(i).y = -1
Case id_PLAYERQUIT
player(i).state = False
Close player(i).handle
totalClients = totalClients - 1
Print Time$ + " Client #" + LTrim$(Str$(i)) + " (" + player(i).name + ") quit";
If player(i).x = -1 And player(i).y = -1 Then
Print " - wrong version."
Else
Print "."
End If
Exit Do
Case id_UPDATESERVER
'temporary solution for triggering auto-update checks
checkUpdate = True
checkUpdateRequester = i
Print Time$ + " Update check requested;"
Case id_CHAT
Dim chatMessage$
player(i).hasNewMessage = True
chatMessage$ = value$
Case id_PING
sendData player(i), id_PONG, ""
End Select
Loop
If player(i).state = False Then
_Continue
Else
'send this player's data to everybody else
For j = 1 To maxUsers
If j = i Then _Continue
If player(j).state = True Then
If player(i).hasNewName Then sendData player(j), id_NAME, MKI$(i) + player(i).name
If player(i).hasNewColor Then sendData player(j), id_COLOR, MKI$(i) + MKI$(player(i).color)
If Len(player(i).hasNewPosition) Then sendData player(j), id_POS, MKI$(i) + player(i).hasNewPosition
If player(i).hasNewMessage Then sendData player(j), id_CHAT, MKI$(i) + chatMessage$
If player(i).hasNewSize Then sendData player(j), id_SIZE, MKI$(i) + MKI$(player(i).size)
End If
Next
End If
Next
If checkUpdate Then
Dim remoteFile$, result As Integer, file$, newVersion As Integer
Dim fileHandle As Integer, updater$
remoteFile$ = "www.qb64.org/amongst/amongst_version.txt"
result = Download(remoteFile$, 30, file$)
Select Case result
Case 0 'success
checkUpdate = False
newVersion = Val(Mid$(file$, InStr(file$, "=") + 1))
If newVersion > gameVersion Then
Print Time$ + " Downloading new version ("; LTrim$(Str$(newVersion)); ")... ";
If InStr(_OS$, "WIN") Then
remoteFile$ = "server_win.exe"
updater$ = "amongst_updater.exe"
ElseIf InStr(_OS$, "MAC") Then
remoteFile$ = "server_mac"
updater$ = "./amongst_updater"
Else
remoteFile$ = "server_lnx"
updater$ = "./amongst_updater"
End If
Do
result = Download("www.qb64.org/amongst/" + remoteFile$, 30, file$)
Select Case result
Case 0 'success
Print "done."
fileHandle = FreeFile
Open remoteFile$ For Binary As #fileHandle
Put #fileHandle, , file$
Close #fileHandle
If _FileExists(updater$) Then
For j = 1 To maxUsers
If player(j).state = False Then _Continue
sendData player(j), id_KICK, "Server auto-updating; try again in a few moments."
Next
Close host
Shell _DontWait Chr$(34) + updater$ + Chr$(34) + " " + Chr$(34) + Command$(0) + Chr$(34)
System
Else
packet$ = "Unable to update - missing '" + updater$ + "'."
Print packet$
sendData player(checkUpdateRequester), id_CHAT, MKI$(0) + packet$
checkUpdate = False
Exit Do
End If
Case 2, 3 'can't connect or timed out
packet$ = "Unable to download update; try again in a few moments."
Print packet$
sendData player(checkUpdateRequester), id_CHAT, MKI$(0) + packet$
checkUpdate = False
Exit Do
End Select
_Limit 10
Loop
Else
packet$ = "No new version available."
Print packet$
sendData player(checkUpdateRequester), id_CHAT, MKI$(0) + packet$
checkUpdate = False
End If
Case 2, 3 'can't connect or timed out
packet$ = "Unable to check new versions."
Print packet$
sendData player(checkUpdateRequester), id_CHAT, MKI$(0) + packet$
checkUpdate = False
End Select
End If
_Limit 60
Loop
Sub sendData (client As object, id As Integer, value$)
Dim key$
key$ = MKI$(id) + value$ + endSignal
Put #client.handle, , key$
End Sub
Sub getData (client As object, buffer As String)
Dim incoming$
Get #client.handle, , incoming$
buffer = buffer + incoming$
End Sub
Function parse%% (buffer As String, id As Integer, value$)
Dim endMarker As Long
endMarker = InStr(buffer, endSignal)
If endMarker Then
id = CVI(Left$(buffer, 2))
value$ = Mid$(buffer, 3, endMarker - 3)
buffer = Mid$(buffer, endMarker + Len(endSignal))
parse%% = True
End If
End Function
Function Download% (url$, timelimit, contents$)
'adapted from http://www.qb64.org/wiki/Downloading_Files
'
'Usage:
' Call Download%() in a loop until one of the return codes
' bellow is returned. Contents downloaded are returned in
' the contents$ variable.
'
'Return codes:
' 0 = success
' 1 = still working
' 2 = can't connect
' 3 = timed out
Static client As Long, l As Long
Static prevUrl$, prevUrl2$, a$, a2$, url2$, url3$
Static x As Long, i As Long, i2 As Long, i3 As Long
Static e$, x$, t!, d$, fh As Integer
If url$ = "" Then
If client Then Close client: client = 0
prevUrl$ = ""
Exit Function
End If
If url$ <> prevUrl$ Then
prevUrl$ = url$
a$ = ""
url2$ = url$
x = InStr(url2$, "/")
If x Then url2$ = Left$(url$, x - 1)
If url2$ <> prevUrl2$ Then
prevUrl2$ = url2$
If client Then Close client: client = 0
client = _OpenClient("TCP/IP:80:" + url2$)
If client = 0 Then Download = 2: prevUrl$ = "": Exit Function
End If
e$ = Chr$(13) + Chr$(10) ' end of line characters
url3$ = Right$(url$, Len(url$) - x + 1)
x$ = "GET " + url3$ + " HTTP/1.1" + e$
x$ = x$ + "Host: " + url2$ + e$ + e$
Put #client, , x$
t! = Timer ' start time
End If
Get #client, , a2$
a$ = a$ + a2$
i = InStr(a$, "Content-Length:")
If i Then
i2 = InStr(i, a$, e$)
If i2 Then
l = Val(Mid$(a$, i + 15, i2 - i - 14))
i3 = InStr(i2, a$, e$ + e$)
If i3 Then
i3 = i3 + 4 'move i3 to start of data
If (Len(a$) - i3 + 1) = l Then
d$ = Mid$(a$, i3, l)
fh = FreeFile
Download = 0
contents$ = d$
prevUrl$ = ""
prevUrl2$ = ""
a$ = ""
Close client
client = 0
Exit Function
End If ' availabledata = l
End If ' i3
End If ' i2
End If ' i
If Timer > t! + timelimit Then Close client: client = 0: Download = 3: prevUrl$ = "": Exit Function
Download = 1 'still working
End Function
Function getCVS! (buffer$)
getCVS! = CVS(Left$(buffer$, 4))
buffer$ = Mid$(buffer$, 5)
End Function
Function getCVI% (buffer$)
getCVI% = CVI(Left$(buffer$, 2))
buffer$ = Mid$(buffer$, 3)
End Function
Function timeElapsedSince! (startTime!)
If startTime! > Timer Then startTime! = startTime! - 86400
timeElapsedSince! = Timer - startTime!
End Function

48
samples/amongst/src/amongst_updater.bas Normal file
View file

@ -0,0 +1,48 @@
Option _Explicit
$Console:Only
_Dest _Console
Const true = -1, false = 0
Dim remoteFile$, localFile$
Dim newContents$
localFile$ = Command$
If Left$(localFile$, 2) = "./" Then localFile$ = Mid$(localFile$, 3)
If _FileExists(localFile$) = false Then
Print "Incorrect usage."
System
Else
Print "*"; localFile$; "* found;"
End If
If InStr(_OS$, "WIN") Then
remoteFile$ = "server_win.exe"
ElseIf InStr(_OS$, "MAC") Then
remoteFile$ = "server_mac"
Else
remoteFile$ = "server_lnx"
End If
If _FileExists(remoteFile$) Then
Open remoteFile$ For Binary As #1
newContents$ = Space$(LOF(1))
Get #1, , newContents$
Close #1
Kill localFile$
Open localFile$ For Binary As #1
Put #1, , newContents$
Close #1
Kill remoteFile$
If InStr(_OS$, "LINUX") Then Shell _Hide "chmod +x " + Chr$(34) + Command$ + Chr$(34)
Shell _DontWait Chr$(34) + Command$ + Chr$(34)
Print "Update successful."
System
Else
Print "Incorrect usage."
System
End If

BIN
samples/animax/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 27 KiB

23
samples/animax/index.md Normal file
View file

@ -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: ANIMAX
![screenshot.png](img/screenshot.png)
### Author
[🐝 Bob Seguin](../bob-seguin.md)
### Description
A Graphics/Animation utility by Bob Seguin.
NOTE: This game requires graphics files created by any accompanying .bas programs in the zip file. If two or more accompanying .bas files are present, run the first on only. It will automatically chain (run) the second file. After you run the accompanying .bas file, the main program ready to use!
### File(s)
* [animax.bas](src/animax.bas)
* [animax.zip](src/animax.zip)
* [axgfx.bas](src/axgfx.bas)
🔗 [art](../art.md), [drawing](../drawing.md)

2217
samples/animax/src/animax.bas Normal file
View file

File diff suppressed because it is too large Load diff

BIN
samples/animax/src/animax.zip Normal file
View file

Binary file not shown.

1192
samples/animax/src/axgfx.bas Normal file
View file

File diff suppressed because it is too large Load diff

BIN
samples/arc-demo/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 494 KiB

23
samples/arc-demo/index.md Normal file
View file

@ -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: ARCDEMO
![screenshot.png](img/screenshot.png)
### Author
[🐝 Tsiplacov Sergey](../tsiplacov-sergey.md)
### Description
A 2D platformer game by Tsiplacov Sergey
### File(s)
* [arc-demo.zip](src/arc-demo.zip)
* [arcdemo.bas](src/arcdemo.bas)
🔗 [game](../game.md), [platformer](../platformer.md)
<sub>Reference: [Misc. archive](http://www.totaldoscollection.org/nugnugnug/allhave.txt) </sub>

BIN
samples/arc-demo/src/arc-demo.zip Normal file
View file

Binary file not shown.

454
samples/arc-demo/src/arcdemo.bas Normal file
View file

@ -0,0 +1,454 @@
$NoPrefix
$Resize:Smooth
Screen 9
FullScreen SquarePixels , Smooth
Print "It`s great demo of my VIRTUAL SCREEN engine"
Print "Press Left, Right, Up, Down to move your soldier"
Print "Press Space to shoot"
Print
Print "This program written by Tsiplacov Sergey"
Print
Print "maple@arstel.ru Sergey, Russia"
rus:
a$ = InKey$
If a$ <> "" Then GoTo beg
GoTo rus
beg:
Screen 7
Screen , , 3, 2
Restore mdat
For f = 1 To 77
Read a$
Open a$ + ".sps" For Input As #2
Input #2, r, ah, bh
Close #2
Open a$ + ".spr" For Input As #2
Dim dd(ah, bh)
For x = 1 To ah: For y = 1 To bh: Input #2, dd(x, y): PSet (x, y), dd(x, y): Next y: Next x
Close #2
If f = 1 Then Dim g1(r): Get (1, 1)-(ah, bh), g1()
If f = 2 Then Dim g2(r): Get (1, 1)-(ah, bh), g2()
If f = 3 Then Dim g3(r): Get (1, 1)-(ah, bh), g3()
If f = 4 Then Dim wc(r): Get (1, 1)-(ah, bh), wc()
If f = 5 Then Dim h1l(r): Get (1, 1)-(ah, bh), h1l()
If f = 6 Then Dim h2l(r): Get (1, 1)-(ah, bh), h2l()
If f = 7 Then Dim h1r(r): Get (1, 1)-(ah, bh), h1r()
If f = 8 Then Dim h2r(r): Get (1, 1)-(ah, bh), h2r()
If f = 9 Then Dim w1(r): Get (1, 1)-(ah, bh), w1()
If f = 10 Then Dim w2(r): Get (1, 1)-(ah, bh), w2()
If f = 11 Then Dim h1lm(r): Get (1, 1)-(ah, bh), h1lm()
If f = 12 Then Dim h2lm(r): Get (1, 1)-(ah, bh), h2lm()
If f = 13 Then Dim h1rm(r): Get (1, 1)-(ah, bh), h1rm()
If f = 14 Then Dim h2rm(r): Get (1, 1)-(ah, bh), h2rm()
If f = 15 Then Dim m1(r): Get (1, 1)-(ah, bh), m1()
If f = 16 Then Dim m2(r): Get (1, 1)-(ah, bh), m2()
If f = 17 Then Dim t1r(r): Get (1, 1)-(ah, bh), t1r()
If f = 18 Then Dim t1l(r): Get (1, 1)-(ah, bh), t1l()
If f = 19 Then Dim t1rm(r): Get (1, 1)-(ah, bh), t1rm()
If f = 20 Then Dim t1lm(r): Get (1, 1)-(ah, bh), t1lm()
If f = 21 Then Dim mr1r(r): Get (1, 1)-(ah, bh), mr1r()
If f = 22 Then Dim mr2r(r): Get (1, 1)-(ah, bh), mr2r()
If f = 23 Then Dim mr1l(r): Get (1, 1)-(ah, bh), mr1l()
If f = 24 Then Dim mr2l(r): Get (1, 1)-(ah, bh), mr2l()
If f = 25 Then Dim mr1rm(r): Get (1, 1)-(ah, bh), mr1rm()
If f = 26 Then Dim mr2rm(r): Get (1, 1)-(ah, bh), mr2rm()
If f = 27 Then Dim mr1lm(r): Get (1, 1)-(ah, bh), mr1lm()
If f = 28 Then Dim mr2lm(r): Get (1, 1)-(ah, bh), mr2lm()
If f = 29 Then Dim ff(r): Get (1, 1)-(ah, bh), ff()
If f = 30 Then Dim ffm(r): Get (1, 1)-(ah, bh), ffm()
If f = 31 Then Dim lkl(r): Get (1, 1)-(ah, bh), lkl()
If f = 32 Then Dim lkr(r): Get (1, 1)-(ah, bh), lkr()
If f = 33 Then Dim lklm(r): Get (1, 1)-(ah, bh), lklm()
If f = 34 Then Dim lkrm(r): Get (1, 1)-(ah, bh), lkrm()
If f = 35 Then Dim g4(r): Get (1, 1)-(ah, bh), g4()
If f = 36 Then Dim g5(r): Get (1, 1)-(ah, bh), g5()
If f = 37 Then Dim g6(r): Get (1, 1)-(ah, bh), g6()
If f = 38 Then Dim g7(r): Get (1, 1)-(ah, bh), g7()
If f = 39 Then Dim g8(r): Get (1, 1)-(ah, bh), g8()
If f = 40 Then Dim g9(r): Get (1, 1)-(ah, bh), g9()
If f = 41 Then Dim g10(r): Get (1, 1)-(ah, bh), g10()
If f = 42 Then Dim g11(r): Get (1, 1)-(ah, bh), g11()
If f = 43 Then Dim g12(r): Get (1, 1)-(ah, bh), g12()
If f = 44 Then Dim tr1r(r): Get (1, 1)-(ah, bh), tr1r()
If f = 45 Then Dim tr1l(r): Get (1, 1)-(ah, bh), tr1l()
If f = 46 Then Dim tr1rm(r): Get (1, 1)-(ah, bh), tr1rm()
If f = 47 Then Dim tr1lm(r): Get (1, 1)-(ah, bh), tr1lm()
If f = 48 Then Dim bl1(r): Get (1, 1)-(ah, bh), bl1()
If f = 49 Then Dim bl2(r): Get (1, 1)-(ah, bh), bl2()
If f = 50 Then Dim bl3(r): Get (1, 1)-(ah, bh), bl3()
If f = 51 Then Dim bl1m(r): Get (1, 1)-(ah, bh), bl1m()
If f = 52 Then Dim bl2m(r): Get (1, 1)-(ah, bh), bl2m()
If f = 53 Then Dim bl3m(r): Get (1, 1)-(ah, bh), bl3m()
If f = 54 Then Dim dm1(r): Get (1, 1)-(ah, bh), dm1()
If f = 55 Then Dim dm2(r): Get (1, 1)-(ah, bh), dm2()
If f = 56 Then Dim dm1m(r): Get (1, 1)-(ah, bh), dm1m()
If f = 57 Then Dim dm2m(r): Get (1, 1)-(ah, bh), dm2m()
If f = 58 Then Dim dm3(r): Get (1, 1)-(ah, bh), dm3()
If f = 59 Then Dim dm3m(r): Get (1, 1)-(ah, bh), dm3m()
If f = 60 Then Dim mdl(r): Get (1, 1)-(ah, bh), mdl()
If f = 61 Then Dim mdr(r): Get (1, 1)-(ah, bh), mdr()
If f = 62 Then Dim mdlm(r): Get (1, 1)-(ah, bh), mdlm()
If f = 63 Then Dim mdrm(r): Get (1, 1)-(ah, bh), mdrm()
If f = 64 Then Dim am1(r): Get (1, 1)-(ah, bh), am1()
If f = 65 Then Dim am2(r): Get (1, 1)-(ah, bh), am2()
If f = 66 Then Dim am3(r): Get (1, 1)-(ah, bh), am3()
If f = 67 Then Dim fc(r): Get (1, 1)-(ah, bh), fc()
If f = 68 Then Dim am3m(r): Get (1, 1)-(ah, bh), am3m()
If f = 69 Then Dim g13(r): Get (1, 1)-(ah, bh), g13()
If f = 70 Then Dim g14(r): Get (1, 1)-(ah, bh), g14()
If f = 71 Then Dim g15(r): Get (1, 1)-(ah, bh), g15()
If f = 72 Then Dim g16(r): Get (1, 1)-(ah, bh), g16()
If f = 73 Then Dim g17(r): Get (1, 1)-(ah, bh), g17()
If f = 74 Then Dim g18(r): Get (1, 1)-(ah, bh), g18()
If f = 75 Then Dim g19(r): Get (1, 1)-(ah, bh), g19()
If f = 76 Then Dim g20(r): Get (1, 1)-(ah, bh), g20()
If f = 77 Then Dim g21(r): Get (1, 1)-(ah, bh), g21()
Erase dd
Next f
Cls
Screen , , 3, 3
mdat:
Data "gr1","gr2","gr3","wcl","m11l","m12l","m11r","m12r","wod1","wod2"
Data "m11lm","m12lm","m11rm","m12rm","man1","man2","t1r","t1l","t1rm","t1lm"
Data "mr1r","mr2r","mr1l","mr2l","mr1rm","mr2rm","mr1lm","mr2lm","fir","firm"
Data "luk1l","luk1r","luk1lm","luk1rm","cfon1","cfon2","cfon3","cfon4","cfon5","cfon6","cfon7","cfon8","cfon9"
Data "tr1r","tr1l","tr1rm","tr1lm","bl1","bl2","bl3","bl1m","bl2m","bl3m"
Data "dm1","dm2","dm1m","dm2m","dm3","dm3m","mdl","mdr","mdlm","mdrm"
Data "amm1","amm2","amm3","face","amm3m","cfon10","cfon11"
Data "cfon12","cfon13","cfon14","cfon15","cfon16","cfon17","cfon18","cfon19","cfon20"
Randomize 1000
intro = 1: inhod = 1: col = 7: cc = 1
Rem LOCATE 10, 12: PRINT "Program modified": END
Dim a(200, 10)
Dim b(200, 10)
Dim x(100, 10): Dim y(100, 10)
vid = 3
vir = 2
GoSub lod
a = 7: b = 6: h = 1: s = 1: hh = 1: hj = 0: fly = 0: op = 0: hod = 0
wh = 1
bx = 10: by = 10: dx = 4: dy = -.2: fire = 0
hodd = 0
brekhod = 0
Dim aa(100): Dim bb(100): Dim u(100): Dim s(100): Dim die(100)
f = 1
pow = 3: liv = 3: amm = 3: gold = 0: bom = 0
mig = 0: mag = 0
mdm = 0
For x = 1 To 200
For y = 1 To 10
If a(x, y) = 6 Then s(f) = -2.5: u(f) = 1: bb(f) = 1: aa(f) = x * 15: GoTo jj
If a(x, y) = 7 Then s(f) = -4: u(f) = 2: bb(f) = 1: aa(f) = x * 15: GoTo jj
If a(x, y) = 8 Then s(f) = -4: u(f) = 3: aa(f) = x * 15: bb(f) = y * 15: f = f + 1
jj0:
Next y
Next x
GoTo ser
jj:
If b(aa(f) / 15, bb(f) / 15) = 1 Then bb(f) = bb(f) - 15: GoTo jj2
bb(f) = bb(f) + 15
GoTo jj
jj2:
f = f + 1
GoTo jj0
ser:
For f = 1 To 10
a$ = InKey$
Next f
gg:
Screen , , vid, vir
Screen , , vid, vir
GoSub act
Screen , vid, vid
vid = vid + 1: If vid > 4 Then vid = 2
vir = vir + 1: If vir > 4 Then vir = 2
GoTo gg
act:
If a$ = " " And intro = 1 Then intro = 0: hod = 0
If intro = 1 Then hod = hod + inhod: If hod > 91 Or hod < 1 Then inhod = -inhod
If hod < 2 And hodd < 0 Then hodd = 0
If hod > 91 And hodd > 0 Then hodd = 0: brekhod = 1
If hodd > 0 And brekhod = 0 Then hodd = hodd - 1: hod = hod + 1: a = a - 1: If fire = 1 Then bx = bx - 15
If hodd < 0 And brekhod = 0 Then hodd = hodd + 1: hod = hod - 1: a = a + 1: If fire = 1 Then bx = bx + 15
act2:
bl = Rnd
For yy = 1 To 10
Put (0, yy * 15), wc(), PSet
Put (20 * 15, yy * 15), wc(), PSet
Next yy
For x = 1 To 19
For y = 1 To 10
If a(x + Int(hod), y) = 1 Then Put (x * 15, y * 15), g1(), PSet: GoTo nn
If a(x + Int(hod), y) = 2 Then Put (x * 15, y * 15), g2(), PSet: GoTo nn
If a(x + Int(hod), y) = 3 Then Put (x * 15, y * 15), g3(), PSet: GoTo nn
If a(x + Int(hod), y) = 4 And wh = 1 Then Put (x * 15, y * 15), w1(), PSet: GoTo nn
If a(x + Int(hod), y) = 4 And wh = -1 Then Put (x * 15, y * 15), w2(), PSet: GoTo nn
If a(x + Int(hod), y) = 5 And bl <= .95 Then Put (x * 15, y * 15), m1(), PSet: GoTo nn
If a(x + Int(hod), y) = 5 And bl > .95 Then Put (x * 15, y * 15), m2(), PSet: GoTo nn
If a(x + Int(hod), y) = 9 Then Put (x * 15, y * 15), g4(), PSet: GoTo nn
If a(x + Int(hod), y) = 10 Then Put (x * 15, y * 15), g5(), PSet: GoTo nn
If a(x + Int(hod), y) = 11 Then Put (x * 15, y * 15), g6(), PSet: GoTo nn
If a(x + Int(hod), y) = 12 Then Put (x * 15, y * 15), g7(), PSet: GoTo nn
If a(x + Int(hod), y) = 13 Then Put (x * 15, y * 15), g8(), PSet: GoTo nn
If a(x + Int(hod), y) = 14 Then Put (x * 15, y * 15), g9(), PSet: GoTo nn
If a(x + Int(hod), y) = 15 Then Put (x * 15, y * 15), g10(), PSet: GoTo nn
If a(x + Int(hod), y) = 16 Then Put (x * 15, y * 15), g11(), PSet: GoTo nn
If a(x + Int(hod), y) = 17 Then Put (x * 15, y * 15), g12(), PSet: GoTo nn
If a(x + Int(hod), y) = 18 Then Put (x * 15, y * 15), am1(), PSet: GoTo nn
If a(x + Int(hod), y) = 19 Then Put (x * 15, y * 15), am2(), PSet: GoTo nn
If a(x + Int(hod), y) = 20 Then Put (x * 15, y * 15), am3(), PSet: GoTo nn
If a(x + Int(hod), y) = 21 Then Put (x * 15, y * 15), g13(), PSet: GoTo nn
If a(x + Int(hod), y) = 22 Then Put (x * 15, y * 15), g14(), PSet: GoTo nn
If a(x + Int(hod), y) = 23 Then Put (x * 15, y * 15), g15(), PSet: GoTo nn
If a(x + Int(hod), y) = 24 Then Put (x * 15, y * 15), g16(), PSet: GoTo nn
If a(x + Int(hod), y) = 25 Then Put (x * 15, y * 15), g17(), PSet: GoTo nn
If a(x + Int(hod), y) = 26 Then Put (x * 15, y * 15), g18(), PSet: GoTo nn
If a(x + Int(hod), y) = 27 Then Put (x * 15, y * 15), g19(), PSet: GoTo nn
If a(x + Int(hod), y) = 28 And bl > .7 Then Put (x * 15, y * 15), g21(), PSet: GoTo nn
If a(x + Int(hod), y) = 28 And bl <= .7 Then Put (x * 15, y * 15), g20(), PSet: GoTo nn
If a(x + Int(hod), y - 1) = 28 Or a(x + Int(hod), y - 1) = 27 Then Put (x * 15, y * 15), wc(), PSet: GoSub dddd: For ddt = 1 To 10: ddx = Rnd * 5 + 5: ddy = Rnd * ddd: PSet (x * 15 + ddx, y * 15 + ddy), 12: Next ddt: GoTo nn
Put (x * 15, y * 15), wc(), PSet
nn:
Next y
If mdm = 0 And intro = 0 Then GoSub kli
Next x
If intro = 1 Then GoSub intr: Return
If a <> hh Then h = -h: op = 1
If op1 = 1 Then op = 1
op1 = 0
hh = a
If b(a + hod, b + .9) = 0 Then fly = 1: b = b + hj: h = -1 Else fly = 0
If b(a + hod, b + .8) <> 0 Then b = b - .1: h = 1
If b(a + hod, b - .5) <> 0 Or b < 1.5 Then hj = .1
If hj < .5 Then hj = hj + .1
If a(a + hod - .2, b + .8) = 5 Then a(a + hod - .2, b + .8) = 0: gold = gold + 1: If gold > 9 Then gold = 0: liv = liv + 1
If a(a + hod - .2, b + .8) = 18 Then a(a + hod - .2, b + .8) = 0
If a(a + hod - .2, b + .8) = 19 Then a(a + hod - .2, b + .8) = 0: amm = amm + 1
If a(a + hod - .2, b + .8) = 20 Then a(a + hod - .2, b + .8) = 0: bom = bom + 1
If mdm <> 0 Then GoSub md: GoTo mf
If s = 1 And h = 1 And mig <> 1 Then Put (a * 15, b * 15), h1lm(), And: Put (a * 15, b * 15), h1l(), Xor
If s = 1 And h = -1 And mig <> 1 Then Put (a * 15, b * 15), h2lm(), And: Put (a * 15, b * 15), h2l(), Xor
If s = -1 And h = 1 And mig <> 1 Then Put (a * 15, b * 15), h1rm(), And: Put (a * 15, b * 15), h1r(), Xor
If s = -1 And h = -1 And mig <> 1 Then Put (a * 15, b * 15), h2rm(), And: Put (a * 15, b * 15), h2r(), Xor
mf:
If a > 15 Then hodd = 8
If a < 6 And hod > 1 Then hodd = -8
If fly = 1 Then GoSub ts: If t = 0 Then a = a + s / 3
wsp = wsp + 1: If wsp > 2 Then wsp = 0: wh = -wh
If fly = 0 Then op = 0
If brekhod = 0 Then GoSub mon
If fire = 1 Then If bx / 15 > 20 Or bx / 15 < 1 Then fire = 0: If bom > 0 Then bom = bom - 1
If b(bx / 15 + hod, by / 15) <> 0 And fire = 1 Then fire = 0: If bom > 0 Then bom = bom - 1
If fire = 1 And bom <= 0 Then Put (bx, by), ffm(), And: Put (bx, by), ff(), Xor: bx = bx + dx
If fire = 1 And bom > 0 Then Put (bx, by), am3m(), And: Put (bx, by), am3(), Xor: bx = bx + dx
Rem LOCATE 1, 1: PRINT mig; " "
ktm = ktm + 1
If mig <> 0 Then mig = mig + 1: If mig > 3 Then mig = 1
mag = mag - 1: If mag < 0 Then mig = 0
If mdm > 20 Then Locate 9, 14: Color 11: Print "<22>® íâ® ­¥ ª®­¥æ"
GoSub panel
Return
md:
If s = -1 Then Put (a * 15, b * 15 + 1), mdrm(), And: Put (a * 15, b * 15 + 1), mdr(), Xor
If s = 1 Then Put (a * 15, b * 15 + 1), mdlm(), And: Put (a * 15, b * 15 + 1), mdl(), Xor
mdm = mdm + 1: If mdm = 50 Then End
Return
kli:
Limit 250
a$ = InKey$
' Exit program
If a$ = Chr$(27) Then System 0
' Left & right
If a$ = Chr$(0) + Chr$(75) And fly = 0 Then ktm = 0: s = -1: GoSub ts: If t = 0 Then a = a - .2
If a$ = Chr$(0) + Chr$(77) And fly = 0 Then ktm = 0: s = 1: GoSub ts: If t = 0 Then a = a + .2
' Jump
If a$ = Chr$(0) + Chr$(72) And fly = 0 And b > 2 Then hj = -.6: b = b - .2
' Left & right?
If a$ = Chr$(0) + Chr$(75) And fly = 1 Then op1 = 1: s = -1
If a$ = Chr$(0) + Chr$(77) And fly = 1 Then op1 = 1: s = 1
' Shoot
If a$ = Chr$(32) And fire = 0 Then fire = 1: GoSub firs
Return
firs:
If s = -1 Then bx = a * 15 - 10: by = b * 15 + 5: dx = -10
If s = 1 Then bx = a * 15 + 10: by = b * 15 + 5: dx = 10
If bom > 0 Then by = b * 15
Return
ts:
t = 0
If s = 1 Then If b(a + hod + .6, b + .6) = 1 Then t = 1
If s = -1 Then If b(a + hod - .6, b + .6) = 1 Then t = 1
If s = -1 And a < 1.5 Then t = 1
If ktm > 2 And op = 0 And fly = 1 Then t = 1
Return
mon:
For f = 1 To 100
aaa = 0
If hodd > 0 Then aa(f) = aa(f) - 15: aaa = 15: For sz = 1 To 10: x(f, sz) = x(f, sz) - 15: Next sz
If hodd < 0 Then aa(f) = aa(f) + 15: aaa = -15: For sz = 1 To 10: x(f, sz) = x(f, sz) + 15: Next sz
If die(f) <> 0 Then GoSub dm: GoTo ccc2
If aa(f) / 15 > 1 And aa(f) / 15 < 19 Then GoTo ccc
GoTo ccc2
ccc:
If fire = 1 And die(f) = 0 And bx > aa(f) - 5 And bx < aa(f) + 20 And by > bb(f) - 10 And by < bb(f) + 15 Then die(f) = -1: GoSub bm: For sz = 1 To 10: x(f, sz) = aa(f) + Rnd * 15: y(f, sz) = bb(f) + Rnd * 5: Next sz: GoTo ccc2
If u(f) = 1 Then GoSub mon1
If u(f) = 2 Then GoSub mon2
If u(f) = 3 Then GoSub mon3
If mig = 0 And a > aa(f) / 15 - 1 And a < aa(f) / 15 + 1 And b > bb(f) / 15 - 1 And b < bb(f) / 15 + 1 Then mag = 50: mig = 1: pow = pow - 1: If pow <= 0 Then mdm = 1
ccc2:
If die(f) <> 0 Then die(f) = die(f) - 1: GoSub mbl
If die(f) = 0 Then x(f, 1) = aa(f): y(f, 1) = bb(f)
Next f
Return
bm:
If bom > 0 Then fire = 1 Else fire = 0
Return
dm:
If aa(f) / 15 > 1 And aa(f) / 15 < 19 Then GoTo dmm
Return
dmm:
If u(f) = 3 And bb(f) < 143 Then yu = b(aa(f) / 15 + hod + aaa / 15, bb(f) / 15 + .9)
If u(f) = 3 And bb(f) < 143 And a(aa(f) / 15 + hod + aaa / 15, bb(f) / 15) = 4 Then bb(f) = bb(f) - Rnd: GoTo dmmm
If u(f) = 3 And yu <> 1 Then bb(f) = bb(f) + 3
dmmm:
If u(f) = 1 Then Put (aa(f) + aaa, bb(f)), dm1m(), And: Put (aa(f) + aaa, bb(f)), dm1(), Xor
If u(f) = 2 Then Put (aa(f) + aaa, bb(f)), dm2m(), And: Put (aa(f) + aaa, bb(f)), dm2(), Xor
If u(f) = 3 And bb(f) < 143 Then Put (aa(f) + aaa, bb(f)), dm3m(), And: Put (aa(f) + aaa, bb(f)), dm3(), Xor
Return
mbl:
If y(f, 1) > 150 Then Return
For sz = 1 To 10
For ssz = 1 To 2
PSet (x(f, sz) + aaa + Rnd * 2, y(f, sz) + Rnd * 2 + 7), 12
PSet (x(f, sz) + aaa + Rnd * 2, y(f, sz) + Rnd * 2 + 7), 4
Next ssz
y(f, sz) = y(f, sz) - die(f) / 5 - 2
x(f, sz) = x(f, sz) + Rnd * 6 - 3
Next sz
Return
mon1:
If b(aa(f) / 15 + hod + .5 + aaa / 15, bb(f) / 15 + 1) <> 1 Then s(f) = -2.5
If b(aa(f) / 15 + hod - .5 + aaa / 15, bb(f) / 15 + 1) <> 1 Then s(f) = 2.5
If b(aa(f) / 15 + hod + .5 + aaa / 15, bb(f) / 15) = 1 Then s(f) = -2.5
If b(aa(f) / 15 + hod - .5 + aaa / 15, bb(f) / 15) = 1 Then s(f) = 2.5
aa(f) = aa(f) + s(f)
If s(f) = 2.5 And wh = 1 Then Put (aa(f) + aaa, bb(f) - 5), t1rm(), And: Put (aa(f) + aaa, bb(f) - 5), t1r(), Xor
If s(f) = 2.5 And wh = -1 Then Put (aa(f) + aaa, bb(f) - 5), tr1lm(), And: Put (aa(f) + aaa, bb(f) - 5), tr1l(), Xor
If s(f) = -2.5 And wh = 1 Then Put (aa(f) + aaa, bb(f) - 5), t1lm(), And: Put (aa(f) + aaa, bb(f) - 5), t1l(), Xor
If s(f) = -2.5 And wh = -1 Then Put (aa(f) + aaa, bb(f) - 5), tr1rm(), And: Put (aa(f) + aaa, bb(f) - 5), tr1r(), Xor
Return
mon2:
If b(aa(f) / 15 + hod + .5 + aaa / 15, bb(f) / 15 + 1) <> 1 Then s(f) = -4
If b(aa(f) / 15 + hod - .5 + aaa / 15, bb(f) / 15 + 1) <> 1 Then s(f) = 4
If b(aa(f) / 15 + hod + .5 + aaa / 15, bb(f) / 15) = 1 Then s(f) = -4
If b(aa(f) / 15 + hod - .5 + aaa / 15, bb(f) / 15) = 1 Then s(f) = 4
aa(f) = aa(f) + s(f)
If s(f) = 4 And wh = 1 Then Put (aa(f) + aaa, bb(f)), mr1rm(), And: Put (aa(f) + aaa, bb(f)), mr1r(), Xor
If s(f) = 4 And wh = -1 Then Put (aa(f) + aaa, bb(f)), mr2rm(), And: Put (aa(f) + aaa, bb(f)), mr2r(), Xor
If s(f) = -4 And wh = 1 Then Put (aa(f) + aaa, bb(f)), mr1lm(), And: Put (aa(f) + aaa, bb(f)), mr1l(), Xor
If s(f) = -4 And wh = -1 Then Put (aa(f) + aaa, bb(f)), mr2lm(), And: Put (aa(f) + aaa, bb(f)), mr2l(), Xor
Return
mon3:
If b(aa(f) / 15 + hod + .5 + aaa / 15, bb(f) / 15) = 1 Then s(f) = -4
If b(aa(f) / 15 + hod - .5 + aaa / 15, bb(f) / 15) = 1 Then s(f) = 4
If b(aa(f) / 15 + hod + .5 + aaa / 15, bb(f) / 15 + 1) = 1 Then s(f) = -4
If b(aa(f) / 15 + hod - .5 + aaa / 15, bb(f) / 15 + 1) = 1 Then s(f) = 4
If aa(f) / 15 > 18 Then s(f) = -4
If aa(f) / 15 < 2 Then s(f) = 4
aa(f) = aa(f) + s(f)
If s(f) = 4 Then Put (aa(f) + aaa, bb(f)), lkrm(), And: Put (aa(f) + aaa, bb(f)), lkr(), Xor
If s(f) = -4 Then Put (aa(f) + aaa, bb(f)), lklm(), And: Put (aa(f) + aaa, bb(f)), lkl(), Xor
Return
intr:
Locate 1, 1: Print " Press ~SPACE~"
For f = 0 To 14
For y = 0 To 10
For x = 0 + f * 8 To 7 + f * 8
aa = Point(x, y)
If aa <> 0 Then PSet (x + 105, y + 120), 4
If aa <> 0 And Rnd > y / 10 Then PSet (x + 105, y + 120), 12
Next x
Next y
Next f
Locate 1, 1: Print " * DEMO * "
For y = 0 To 10
For x = 0 To 72
aa = Point(x, y)
For vb = 1 To 6
If aa <> 0 Then PSet (x * 2 + 90 + Rnd * 2, y * 2 + 20 + Rnd * (y + 2)), 12
Next vb
Next x
Next y
Locate 1, 1: Print " ": Color 15
a$ = InKey$
Delay 0.1
Return
panel:
Put (16, 0), fc(), PSet
Locate 2, 6: Print "*"; liv
Put (76, 0), am1(), PSet
Locate 2, 13: Print "*"; pow
Put (136, 0), am3(), PSet
Locate 2, 20: Print "*"; bom
Put (196, 0), m1(), PSet
Locate 2, 28: Print "*"; gold
Put (256, 0), am2(), PSet
Locate 2, 36: Print "*"; amm
Return
dddd:
ddd = 1
ddd1:
If Rnd > .9 Then Return
ddd = ddd + 1: If ddd > 15 Then Return
GoTo ddd1
lod:
Open "demap.vir" For Input As #2
For sx = 1 To 200
For sy = 1 To 10
Input #2, a(sx, sy)
Input #2, b(sx, sy)
Next sy
Next sx
Close #2
Return

BIN
samples/assault/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 267 KiB

20
samples/assault/index.md Normal file
View file

@ -0,0 +1,20 @@
[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: ASSAULT
![screenshot.png](img/screenshot.png)
### Author
[🐝 Glenn Powell](../glenn-powell.md)
### Description
This is a game of weapons and destruction that relies upon the properties of physics as well as your skill. There can be up to 4 players on up to 4 teams playing at one time. Each player controls a tank that is equiped with various weapons. You can set the amount of ammo for each of these devices in the Configuration. You can also use the Configuration to set the amount of health you start with, player names, teams, control keys, and other options...
### File(s)
* [assault.bas](src/assault.bas)
* [assault.zip](src/assault.zip)
🔗 [game](../game.md)

3184
samples/assault/src/assault.bas Normal file
View file

File diff suppressed because it is too large Load diff

BIN
samples/assault/src/assault.zip Normal file
View file

Binary file not shown.

BIN
samples/bezier/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 26 KiB

43
samples/bezier/index.md Normal file
View file

@ -0,0 +1,43 @@
[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md)
## SAMPLE: BEZIER
![screenshot.png](img/screenshot.png)
### Author
[🐝 Rho Sigma](../rho-sigma.md)
### Description
'+---------------+---------------------------------------------------+
'|_######_######_|_____.--._._________.-.____________________________|
'|_##__##_##___#_|_____|___)|________(___)_o_________________________|
'|_##__##__##____|_____|--'_|--._.-.__`-.__.__.-...--.--._.-.________|
'|_######___##___|_____|__\_|__|(___)(___)_|_(___||__|__|(___)_______|
'|_##______##____|_____'___`'__`-`-'__`-'-'_`-`-`|'__'__`-`-'`-______|
'|_##_____##___#_|____________________________._.'___________________|
'|_##_____######_|__Sources_&_Documents_placed_in_the_Public_Domain._|
'+---------------+---------------------------------------------------+
'| |
'| === ScreenBlankers-Info.html === |
'| |
'| == Some simple screen blankers I wrote using QB64. |
'| |
'+-------------------------------------------------------------------+
'| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |
'| Find me in the QB64 Forum or mail to support@rhosigma-cw.net for |
'| any questions or suggestions. Thanx for your interest in my work. |
'+-------------------------------------------------------------------+
Screen Blankers
This is a small collection of some simple screen blanker modules. Most of them are written by myself, others were just graphic sample programs from other QB64 Forum members, which I've altered into a blanker module. Just read the header notes in each module for more information.
To install one of it (on a Windows system), simply rename the created .exe file with the new extension .scr, confirm the possible warning about changing the file extension with Yes. After that you can simply right click on the renamed file and choose Install.
Sorry, I've no idea how to do it on MacOS or Linux, any info about it from people who using these systems would be nice.
### File(s)
* [bezier.bas](src/bezier.bas)
🔗 [screenblanker](../screenblanker.md)

185
samples/bezier/src/bezier.bas Normal file
View file

@ -0,0 +1,185 @@
'+---------------+---------------------------------------------------+
'| ###### ###### | .--. . .-. |
'| ## ## ## # | | )| ( ) o |
'| ## ## ## | |--' |--. .-. `-. . .-...--.--. .-. |
'| ###### ## | | \ | |( )( ) | ( || | |( ) |
'| ## ## | ' `' `-`-' `-'-' `-`-`|' ' `-`-'`- |
'| ## ## # | ._.' |
'| ## ###### | Sources & Documents placed in the Public Domain. |
'+---------------+---------------------------------------------------+
'| |
'| === Bezier.bas === |
'| |
'| == Similar to the Spline.bas screen blanker, this one also draws |
'| == splines, Bezier curves to be exact. But it will also show the |
'| == math behind it, hence the polygons which by solving it down to |
'| == first degree result into the final spline point to draw. |
'| |
'| == See also: https://en.wikipedia.org/wiki/B%C3%A9zier_curve |
'| |
'+-------------------------------------------------------------------+
'| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |
'| Find me in the QB64 Forum or mail to support@rhosigma-cw.net for |
'| any questions or suggestions. Thanx for your interest in my work. |
'+-------------------------------------------------------------------+
Dim Shared scrX%, scrY%
di& = _ScreenImage
scrX% = _Width(di&)
scrY% = _Height(di&)
_FreeImage di&
si& = _NewImage(scrX%, scrY%, 256)
ti& = _NewImage(scrX%, scrY%, 256)
Screen si&
_Delay 0.2: _ScreenMove _Middle
_Delay 0.2: _FullScreen
Const MAX_DEGREE = 10 '2 to 20
Type point
x As Double
y As Double
s As Integer
End Type
ReDim spans(0 To 1) As point
_MouseHide
While InKey$ = "" And mx% = 0 And my% = 0
_Dest ti&: Cls
_Dest 0: Cls
Randomize Timer
np% = RangeRand%(2, MAX_DEGREE)
ReDim points(0 To np%) As point
For i% = 0 To np%
points(i%).x = RangeRand%(20, scrX% - 20)
points(i%).y = RangeRand%(20, scrY% - 20)
Next i%
f# = 0: st# = 0.0001: done% = 0
Do
_Limit 20 / st# * 0.005
If f# > 1 Then f# = 1: done% = -1
CalcFracPoints points(), spans(), f#
_Dest ti&
x# = spans(UBound(spans)).x
y# = spans(UBound(spans)).y
If c% < 32 Or c% > 56 Then c% = 32
Circle (x#, y#), 1, c%
Circle (x#, y#), 2, c%
Circle (x#, y#), 3, c%
c% = c% + 1
_Dest 0
Cls
_PutImage , ti&
DrawLines points(), &HFFFF
DrawLines spans(), &B1001100110011001
For i% = LBound(spans) To UBound(spans) - 1
Circle (spans(i%).x, spans(i%).y), 1, 14
Circle (spans(i%).x, spans(i%).y), 2, 14
Next i%
Circle (x#, y#), 1, 4
Circle (x#, y#), 2, 4
Circle (x#, y#), 3, 12
Circle (x#, y#), 4, 15
Circle (x#, y#), 5, 15
_Display
If ox# <> 0 Then
If Abs(ox# - x#) > 3 Or Abs(oy# - y#) > 3 Then
st# = st# / 2
ElseIf Abs(ox# - x#) < 2 Or Abs(oy# - y#) < 2 Then
st# = st# * 2
End If
If st# > 0.005 Then st# = 0.005
End If
ox# = x#: oy# = y#
f# = f# + st#
Do While _MouseInput
mx% = mx% + _MouseMovementX
my% = my% + _MouseMovementY
Loop
If InKey$ <> "" Or mx% + my% <> 0 Then Exit While
Loop Until done%
done% = 50: mx% = 0: my% = 0
Do
_Limit 20
Do While _MouseInput
mx% = mx% + _MouseMovementX
my% = my% + _MouseMovementY
Loop
If InKey$ <> "" Or mx% + my% <> 0 Then Exit While
done% = done% - 1
Loop While done%
_PutImage , ti&
_Display
done% = 100: mx% = 0: my% = 0
Do
_Limit 20
col~& = _PaletteColor(56)
For i% = 56 To 33 Step -1
_PaletteColor i%, _PaletteColor(i% - 1)
Next i%
_PaletteColor 32, col~&
_Display
Do While _MouseInput
mx% = mx% + _MouseMovementX
my% = my% + _MouseMovementY
Loop
If InKey$ <> "" Or mx% + my% <> 0 Then Exit While
done% = done% - 1
Loop While done%
Wend
_FullScreen _Off
_Delay 0.2: Screen 0
_Delay 0.2: _FreeImage ti&
_Delay 0.2: _FreeImage si&
System
'=====================================================================
Sub CalcFracPoints (pIn() As point, pOut() As point, frac#)
iLns% = UBound(pIn) - LBound(pIn) 'no +1 here, as lines = 1 less than points
oPts% = (iLns% * (iLns% + 1)) / 2 'sum up 1 to n, which is n*(n+1)/2
ReDim pOut(0 To oPts% - 1) As point
p% = 0
For i% = LBound(pIn) To UBound(pIn) - 1
pOut(p%).x = pIn(i%).x + frac# * (pIn(i% + 1).x - pIn(i%).x)
pOut(p%).y = pIn(i%).y + frac# * (pIn(i% + 1).y - pIn(i%).y)
p% = p% + 1
Next i%
pOut(p% - 1).s = -1 'stop flag for drawing
For j% = iLns% To 2 Step -1
For i% = p% - j% To p% - 2
pOut(p%).x = pOut(i%).x + frac# * (pOut(i% + 1).x - pOut(i%).x)
pOut(p%).y = pOut(i%).y + frac# * (pOut(i% + 1).y - pOut(i%).y)
p% = p% + 1
Next i%
pOut(p% - 1).s = -1 'stop flag for drawing
Next j%
End Sub
'=====================================================================
Sub DrawLines (pIn() As point, sty%)
col~& = 1
For i% = LBound(pIn) To UBound(pIn) - 1
Line (pIn(i%).x, pIn(i%).y)-(pIn(i% + 1).x, pIn(i% + 1).y), col~&, , sty%
If pIn(i% + 1).s Then
col~& = (col~& + 1) And 15
i% = i% + 1 'skip to next sequence
End If
Next i%
End Sub
'=====================================================================
Function RangeRand% (low%, high%)
RangeRand% = Int(Rnd(1) * (high% - low% + 1)) + low%
End Function

BIN
samples/binary-clock/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 12 KiB

43
samples/binary-clock/index.md Normal file
View file

@ -0,0 +1,43 @@
[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 CLOCK
![screenshot.png](img/screenshot.png)
### Author
[🐝 Rho Sigma](../rho-sigma.md)
### Description
'+---------------+---------------------------------------------------+
'|_######_######_|_____.--._._________.-.____________________________|
'|_##__##_##___#_|_____|___)|________(___)_o_________________________|
'|_##__##__##____|_____|--'_|--._.-.__`-.__.__.-...--.--._.-.________|
'|_######___##___|_____|__\_|__|(___)(___)_|_(___||__|__|(___)_______|
'|_##______##____|_____'___`'__`-`-'__`-'-'_`-`-`|'__'__`-`-'`-______|
'|_##_____##___#_|____________________________._.'___________________|
'|_##_____######_|__Sources_&_Documents_placed_in_the_Public_Domain._|
'+---------------+---------------------------------------------------+
'| |
'| === ScreenBlankers-Info.html === |
'| |
'| == Some simple screen blankers I wrote using QB64. |
'| |
'+-------------------------------------------------------------------+
'| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |
'| Find me in the QB64 Forum or mail to support@rhosigma-cw.net for |
'| any questions or suggestions. Thanx for your interest in my work. |
'+-------------------------------------------------------------------+
Screen Blankers
This is a small collection of some simple screen blanker modules. Most of them are written by myself, others were just graphic sample programs from other QB64 Forum members, which I've altered into a blanker module. Just read the header notes in each module for more information.
To install one of it (on a Windows system), simply rename the created .exe file with the new extension .scr, confirm the possible warning about changing the file extension with Yes. After that you can simply right click on the renamed file and choose Install.
Sorry, I've no idea how to do it on MacOS or Linux, any info about it from people who using these systems would be nice.
### File(s)
* [binclock.bas](src/binclock.bas)
🔗 [screenblanker](../screenblanker.md)

185
samples/binary-clock/src/binclock.bas Normal file
View file

@ -0,0 +1,185 @@
'+---------------+---------------------------------------------------+
'| ###### ###### | .--. . .-. |
'| ## ## ## # | | )| ( ) o |
'| ## ## ## | |--' |--. .-. `-. . .-...--.--. .-. |
'| ###### ## | | \ | |( )( ) | ( || | |( ) |
'| ## ## | ' `' `-`-' `-'-' `-`-`|' ' `-`-'`- |
'| ## ## # | ._.' |
'| ## ###### | Sources & Documents placed in the Public Domain. |
'+---------------+---------------------------------------------------+
'| |
'| === BinClock.bas === |
'| |
'| == A simple binary (BCD) clock inspired by the alien countdown |
'| == from the movie "Mission to Mars". |
'| |
'+-------------------------------------------------------------------+
'| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |
'| Find me in the QB64 Forum or mail to support@rhosigma-cw.net for |
'| any questions or suggestions. Thanx for your interest in my work. |
'+-------------------------------------------------------------------+
'get desktop sizes
di& = _ScreenImage
desX% = _Width(di&)
desY% = _Height(di&)
scrX% = _Width(di&): If scrX% < 875 Then scrX% = 875
scrY% = _Height(di&): If scrY% < 465 Then scrY% = 465
_FreeImage di&
Dim Shared scale%, timg&
If desX% <> scrX% Or desY% <> scrY% Then scale% = -1: Else scale% = 0
'setup screen
Screen _NewImage(desX%, desY%, 256)
_Delay 0.2: _ScreenMove _Middle
_Delay 0.2: _FullScreen
If scale% Then
timg& = _NewImage(scrX%, scrY%, 256)
If timg& < -1 Then _Dest timg&: Else System
End If
scrFont& = _LoadFont("C:\Windows\Fonts\timesbd.ttf", 72)
_Font scrFont&
'3D space origin is on these screen coordinates
Dim Shared dx%: dx% = (scrX% - 875) \ 2
Dim Shared dy%: dy% = (scrY% - 465) \ 2
Dim Shared cx%: cx% = 30 + dx%
Dim Shared cy%: cy% = 250 + dy%
'init BCD discs
Type Disc
x As Integer
y As Integer
z As Integer
r As Integer
a As Integer
End Type
Dim Shared Discs(23) As Disc
InitDiscs
Dim Shared curState&: curState& = 0
Dim Shared newState&: newState& = 0
'draw hour/minute/seconds separators
Line3D 175, 0, 0, 175, 440, 0, 2
Line3D 175, 0, 0, 175, 0, -110, 2
Line3D 425, 0, 0, 425, 440, 0, 2
Line3D 425, 0, 0, 425, 0, -110, 2
'main loop
_MouseHide
_Display
Do
_Limit 1
FlipDiscs
Do While _MouseInput
mx% = mx% + _MouseMovementX
my% = my% + _MouseMovementY
Loop
Loop While InKey$ = "" And mx% = 0 And my% = 0
_AutoDisplay
'cleanup
_Font 16
_FreeFont scrFont&
If scale% Then _FreeImage timg&
System
'run the clock
Sub FlipDiscs
t$ = Time$
newState& = (VAL(MID$(t$, 1, 1)) * (2 ^ 20)) + (VAL(MID$(t$, 2, 1)) * (2 ^ 16)) +_
(VAL(MID$(t$, 4, 1)) * (2 ^ 12)) + (VAL(MID$(t$, 5, 1)) * (2 ^ 8)) +_
(VAL(MID$(t$, 7, 1)) * (2 ^ 4)) + (VAL(MID$(t$, 8, 1)) * (2 ^ 0))
diff& = curState& Xor newState&
curState& = newState&
For rot% = 5 To 90 Step 5
For n% = 0 To 23
If (n% Mod 4) = 0 Then AxisSegments Discs(n%).x
If diff& And (2 ^ n%) Then
Circle3D Discs(n%).x, Discs(n%).y, Discs(n%).z, Discs(n%).r, Discs(n%).a, 0
Circle3D Discs(n%).x, Discs(n%).y, Discs(n%).z, Discs(n%).r, Discs(n%).a + 5, 15
Discs(n%).a = Discs(n%).a + 5
If Discs(n%).a = 180 Then Discs(n%).a = 0
Else
Circle3D Discs(n%).x, Discs(n%).y, Discs(n%).z, Discs(n%).r, Discs(n%).a, 15
End If
Next n%
If rot% = 60 Then
Color 1
_PrintString (50 + dx%, 280 + dy%), Mid$(t$, 1, 2)
_PrintString (300 + dx%, 280 + dy%), Mid$(t$, 4, 2)
_PrintString (550 + dx%, 280 + dy%), Mid$(t$, 7, 2)
_PrintString (300 - _PrintWidth(Left$(Date$, 4)) + dx%, 380 + dy%), Date$
End If
If scale% Then _PutImage , timg&, 0
_Display
Next rot%
End Sub
'setup start values for all discs
Sub InitDiscs
n% = 0
For i% = 600 To 500 Step -100
For j% = 70 To 370 Step 100
Discs(n%).x = i%
Discs(n%).y = j%
Discs(n%).z = 0
Discs(n%).r = 30
Discs(n%).a = 0
n% = n% + 1
Next j%
Next i%
For i% = 350 To 250 Step -100
For j% = 70 To 370 Step 100
Discs(n%).x = i%
Discs(n%).y = j%
Discs(n%).z = 0
Discs(n%).r = 30
Discs(n%).a = 0
n% = n% + 1
Next j%
Next i%
For i% = 100 To 0 Step -100
For j% = 70 To 370 Step 100
Discs(n%).x = i%
Discs(n%).y = j%
Discs(n%).z = 0
Discs(n%).r = 30
Discs(n%).a = 0
n% = n% + 1
Next j%
Next i%
End Sub
'draw rotation axis segments between discs
Sub AxisSegments (x%)
Line3D x%, 0, 0, x%, 40, 0, 4
Line3D x%, 100, 0, x%, 140, 0, 4
Line3D x%, 200, 0, x%, 240, 0, 4
Line3D x%, 300, 0, x%, 340, 0, 4
Line3D x%, 400, 0, x%, 440, 0, 4
End Sub
Sub Line3D (x1%, y1%, z1%, x2%, y2%, z2%, col%)
'x1%/y1%/z1% = start, x2%/y2%/z2% = end, col% = color pen
x1# = (x1% + (y1% * 0.5)): z1# = (z1% + (y1% * 0.5))
x2# = (x2% + (y2% * 0.5)): z2# = (z2% + (y2% * 0.5))
Line (x1# + cx% - 1, -z1# + cy%)-(x2# + cx% - 1, -z2# + cy%), col%
Line (x1# + cx%, -z1# + cy%)-(x2# + cx%, -z2# + cy%), col%
Line (x1# + cx% + 1, -z1# + cy%)-(x2# + cx% + 1, -z2# + cy%), col%
End Sub
Sub Circle3D (x%, y%, z%, r%, ba%, col%)
'x%/y%/z% = center, r% = radius, ba% = B-Axis angle, col% = color pen
mx# = (x% + (y% * 0.5)): mz# = (z% + (y% * 0.5))
zx# = r% * Cos(ba% * 0.017453292519943)
zz# = r% * Sin(ba% * 0.017453292519943)
For cir% = 0 To 359 Step 5
x# = zx# * Cos(cir% * 0.017453292519943)
y# = r% * Sin(cir% * 0.017453292519943)
z# = zz# * Cos(cir% * 0.017453292519943)
x# = (x# + (y# * 0.5)): z# = (z# + (y# * 0.5))
Line (x# + mx# + cx% - 1, -z# + -mz# + cy% - 1)-(x# + mx# + cx% + 1, -z# + -mz# + cy% + 1), col%, BF
Next cir%
End Sub

BIN
samples/blockout/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 17 KiB

22
samples/blockout/index.md Normal file
View file

@ -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: BLOCKOUT
![screenshot.png](img/screenshot.png)
### Author
[🐝 Fellippe Heitor](../fellippe-heitor.md)
### Description
A Breakout clone with DXBall aspirations.
### File(s)
* [blockout.bas](src/blockout.bas)
🔗 [game](../game.md), [breakout](../breakout.md)
<sub>Reference: [github](https://github.com/FellippeHeitor/Blockout/) </sub>

809
samples/blockout/src/blockout.bas Normal file
View file

@ -0,0 +1,809 @@
'remove before release:
'remove before release:
Const true = -1, false = 0
Randomize Timer
Dim gameArea As Long
gameArea = _NewImage(800, 600, 32)
Screen gameArea
_Title "Blockout"
_PrintMode _KeepBackground
_AllowFullScreen _Stretch , _Off
Type Block
x As Integer
y As Integer
c As _Unsigned Long
state As _Byte
special As _Byte
kind As _Byte
End Type
Type Ball
x As Single
y As Single
c As _Unsigned Long
radius As Integer
state As _Byte
xDir As _Byte
yDir As _Byte
xVel As Single
yVel As Single
End Type
Type Particle
x As Single
y As Single
xAcc As Single
yAcc As Single
xVel As Single
yVel As Single
r As _Unsigned _Byte
g As _Unsigned _Byte
b As _Unsigned _Byte
state As _Byte
size As Integer
lifeSpan As Single
birth As Single
special As _Byte
kind As _Byte
End Type
Type Special
start As Single
span As Integer
End Type
Const gravity = .03
Const blockWidth = 80
Const blockHeight = 30
Const paddleHeight = 15
Const round = 0
Const square = 1
Const specialPower = 2
Const left = -1
Const right = 1
Const up = -1
Const down = 1
Const regular = 0
Const hitTwice = 1
Const unbreakable = 2
Const bullet = 1
Dim Shared block(1 To 100) As Block, ball As Ball
Dim Shared particle(1 To 10000) As Particle
Dim Shared win As _Byte, quit As String * 1
Dim Shared paddleX As Integer, paddleY As Integer
Dim Shared paddleWidth As Single, magneticOffset As Integer
Dim Shared score As Integer, lives As Integer
Dim Shared paused As _Byte, stillImage&
Dim Shared electricColor(1 To 2) As _Unsigned Long
electricColor(1) = _RGB32(255)
electricColor(2) = _RGB32(50, 211, 255)
Const FireBall = 1
Const Shooter = 2
Const BreakThrough = 3
Const Magnetic = 4
Const StretchPaddle = 5
Const StretchPaddle2 = 6
Const totalSpecialPowers = 6
Dim Shared special(1 To totalSpecialPowers) As Special
For i = 1 To totalSpecialPowers
special(i).span = 15
Next
Const defaultPaddleWidth = 150
paddleY = _Height - blockHeight - paddleHeight - 1
Do
If lives = 0 Then score = 0: lives = 3
win = false
paused = false
generateBlocks
paddleWidth = defaultPaddleWidth
ball.state = false
ball.c = _RGB32(161, 161, 155)
ball.radius = 10
ball.xDir = right
ball.yDir = up
ball.xVel = 5
ball.yVel = 5
For i = 1 To totalSpecialPowers
special(i).start = 0
Next
magneticOffset = paddleWidth / 2
For i = 1 To UBound(particle)
resetParticle particle(i)
Next
_MouseHide
Do
k& = _KeyHit
'remove before release:
If k& = Asc("s") Then special(Shooter).start = Timer
If k& = Asc("m") Then special(Magnetic).start = Timer
If k& = Asc("b") Then special(BreakThrough).start = Timer
If k& = Asc("f") Then special(FireBall).start = Timer
If k& = Asc("p") Then special(StretchPaddle).start = Timer
If k& = Asc("P") Then special(StretchPaddle2).start = Timer
If k& = Asc("r") Then Exit Do
noFocus%% = lostFocus
If (paused = true And k& = 13) Or k& = 27 Or noFocus%% Then
If paused Then
_FreeImage stillImage&
paused = false
showFullScreenMessage%% = false
pauseDiff = Timer - pauseStart
For i = 1 To totalSpecialPowers
If special(i).start > 0 Then
special(i).start = special(i).start + pauseDiff
End If
Next
For i = 1 To UBound(particle)
If particle(i).birth > 0 Then
particle(i).birth = particle(i).birth + pauseDiff
End If
Next
Else
paused = true
If noFocus%% Then showFullScreenMessage%% = true
pauseStart = Timer
stillImage& = _CopyImage(0)
End If
End If
If paused Then
_PutImage , stillImage&
m$ = "Paused (ENTER to continue)"
Color _RGB32(0)
_PrintString ((_Width - _PrintWidth(m$)) / 2 + 1, (_Height - _FontHeight) / 2 + 1 + _FontHeight), m$
Color _RGB32(255)
_PrintString ((_Width - _PrintWidth(m$)) / 2, (_Height - _FontHeight) / 2 + _FontHeight), m$
If showFullScreenMessage%% Then
m$ = "(Hit Alt+Enter to switch to fullscreen)"
Color _RGB32(0)
_PrintString ((_Width - _PrintWidth(m$)) / 2 + 1, (_Height - _FontHeight) / 2 + 1 + _FontHeight * 2), m$
Color _RGB32(255)
_PrintString ((_Width - _PrintWidth(m$)) / 2, (_Height - _FontHeight) / 2 + _FontHeight * 2), m$
End If
Else
If Timer - special(BreakThrough).start < special(BreakThrough).span Then
alpha = map(ball.xVel, 5, 10, 80, 30)
Else
alpha = 255
End If
Line (0, 0)-(_Width, _Height), _RGBA32(0, 0, 0, alpha), BF
showBlocks
doPaddle
doBall
doParticles
m$ = "Score:" + Str$(score) + " Lives:" + Str$(lives)
Color _RGB32(0)
_PrintString (1, 1), m$
Color _RGB32(255)
_PrintString (0, 0), m$
'remove before release:
If Timer - special(FireBall).start < special(FireBall).span Then
_PrintString (0, 350), "fireball: " + Str$(Int(Timer - special(FireBall).start))
End If
If Timer - special(BreakThrough).start < special(BreakThrough).span Then
_PrintString (0, 370), "breakthrough: " + Str$(Int(Timer - special(BreakThrough).start))
End If
If Timer - special(Shooter).start < special(Shooter).span Then
_PrintString (0, 388), "shooter: " + Str$(Int(Timer - special(Shooter).start))
End If
If Timer - special(Magnetic).start < special(Magnetic).span Then
_PrintString (0, 406), "magnetic: " + Str$(Int(Timer - special(Magnetic).start))
End If
If Timer - special(StretchPaddle).start < special(StretchPaddle).span Then
'remove before release:
_PrintString (0, 422), "stretch: " + Str$(Int(Timer - special(StretchPaddle).start))
paddleWidth = defaultPaddleWidth * 1.5
Else
paddleWidth = defaultPaddleWidth
End If
If Timer - special(StretchPaddle2).start < special(StretchPaddle2).span Then
'remove before release:
_PrintString (0, 438), "stretch2: " + Str$(Int(Timer - special(StretchPaddle2).start))
paddleWidth = defaultPaddleWidth * 2
Else
If Timer - special(StretchPaddle).start > special(StretchPaddle).span Or special(StretchPaddle).start = 0 Then
paddleWidth = defaultPaddleWidth
End If
End If
End If
_Display
_Limit 60
Loop Until win Or lives = 0
_MouseShow
Cls
If win Then
Print "Good job, you win."
Print "Continue (y/n)?"
Else
Print "You lose."
Print "Restart (y/n)?"
End If
_AutoDisplay
_KeyClear
Do
quit = LCase$(Input$(1))
Loop Until quit = "y" Or quit = "n"
Loop While quit = "y"
System
Function lostFocus%%
Static Focused As _Byte
If _WindowHasFocus = false Then
If Focused Then
Focused = false
lostFocus%% = true
End If
Else
Focused = true
End If
End Function
Sub doParticles
Dim thisColor As _Unsigned Long, alpha As _Unsigned _Byte
For i = 1 To UBound(particle)
If particle(i).state = false Then _Continue
If particle(i).lifeSpan > 0 And Timer - particle(i).birth > particle(i).lifeSpan Then particle(i).state = false: _Continue
'move
particle(i).xVel = particle(i).xVel + particle(i).xAcc
particle(i).yVel = particle(i).yVel + particle(i).yAcc + gravity
particle(i).x = particle(i).x + particle(i).xVel
particle(i).y = particle(i).y + particle(i).yVel
If particle(i).kind = bullet Then
l = newParticle
If l Then
particle(l).r = 222 + (Rnd * 30)
particle(l).g = 100 + (Rnd * 70)
particle(l).x = particle(i).x
particle(l).y = particle(i).y
particle(l).lifeSpan = 0.05
End If
End If
'check visibility
If particle(i).x - particle(i).size / 2 < 0 Or particle(i).x + particle(i).size / 2 > _Width Or particle(i).y - particle(i).size / 2 < 0 Or particle(i).y + particle(i).size / 2 > _Height Then
particle(i).state = false
_Continue
End If
'show
If particle(i).lifeSpan > 0 Then
alpha = map(Timer - particle(i).birth, 0, particle(i).lifeSpan, 255, 0)
Else
alpha = 255
End If
thisColor = _RGBA32(particle(i).r, particle(i).g, particle(i).b, alpha)
If particle(i).size > 0 Then
Select Case particle(i).kind
Case round, bullet
CircleFill particle(i).x, particle(i).y, particle(i).size, thisColor
Case square
Line (particle(i).x - size / 2, particle(i).y - size / 2)-Step(particle(i).size, particle(i).size), thisColor, BF
Case specialPower
Select Case particle(i).special
'CONST FireBall = 1
'CONST Shooter = 2
'CONST BreakThrough = 3
'CONST Magnetic = 4
'CONST StretchPaddle = 5
'CONST StretchPaddle2 = 6
Case FireBall
For j = 1 To 10
l = newParticle
If l = 0 Then Exit For
particle(l).r = 222 + (Rnd * 30)
particle(l).g = 100 + (Rnd * 70)
particle(l).x = particle(i).x + Cos(Rnd * _Pi(2)) * (ball.radius * Rnd)
particle(l).y = particle(i).y + Sin(Rnd * _Pi(2)) * (ball.radius * Rnd)
particle(l).lifeSpan = .1
Next
CircleFill particle(i).x, particle(i).y, particle(i).size, _RGBA32(222 + (Rnd * 30), 100 + (Rnd * 70), 0, Rnd * 255)
specialDrawn = true
Case Shooter
Line (particle(i).x - 7, particle(i).y + 1)-Step(15, 8), _RGB32(89, 161, 255), BF
CircleFill particle(i).x - 7, particle(i).y + 5, 4, _RGB32(194, 89, 61)
CircleFill particle(i).x - 7, particle(i).y + 2, 3, _RGB32(194, 133, 61)
CircleFill particle(i).x - 7, particle(i).y, 3, _RGB32(194, 188, 61)
l = newParticle
If l > 0 Then
particle(l).r = 222 + (Rnd * 30)
particle(l).g = 100 + (Rnd * 70)
particle(l).x = particle(i).x - 7
particle(l).y = particle(i).y
particle(l).lifeSpan = .1
End If
specialDrawn = true
Case BreakThrough
CircleFill particle(i).x - 8, particle(i).y + 8, 3, _RGB32(177, 30)
CircleFill particle(i).x - 6, particle(i).y + 6, 3, _RGB32(177, 50)
CircleFill particle(i).x - 3, particle(i).y + 3, 4, _RGB32(177, 100)
CircleFill particle(i).x, particle(i).y, 4, _RGB32(177, 200)
specialDrawn = true
Case Magnetic
For j = 1 To 2
PSet (particle(i).x + Cos(0) * (particle(i).size + particle(i).size * Rnd), particle(i).y + Sin(0) * (particle(i).size + particle(i).size * Rnd)), electricColor(j)
For k = 0 To _Pi(2) Step .2
Line -(particle(i).x + Cos(k) * (particle(i).size + particle(i).size * Rnd), particle(i).y + Sin(k) * (particle(i).size + particle(i).size * Rnd)), electricColor(j)
Next
Line -(particle(i).x + Cos(0) * (particle(i).size + particle(i).size * Rnd), particle(i).y + Sin(0) * (particle(i).size + particle(i).size * Rnd)), electricColor(j)
Next
specialDrawn = true
Case StretchPaddle
Line (particle(i).x - 7, particle(i).y + 1)-Step(15, 8), _RGB32(89, 161, 255), BF
CircleFill particle(i).x - 7, particle(i).y + 5, 4, _RGB32(194, 89, 61)
_Font 8
Color _RGB32(255, 150)
_PrintString (particle(i).x - 16, particle(i).y - 10), "1.5x"
_Font 16
specialDrawn = true
Case StretchPaddle2
Line (particle(i).x - 3, particle(i).y + 1)-Step(15, 8), _RGB32(89, 161, 255), BF
CircleFill particle(i).x - 3, particle(i).y + 5, 4, _RGB32(194, 89, 61)
_Font 8
Color _RGB32(255, 150)
_PrintString (particle(i).x + 8, particle(i).y - 10), "2x"
_Font 16
specialDrawn = true
End Select
End Select
Else
PSet (particle(i).x, particle(i).y), thisColor
End If
'check collision with paddle if this particle contains a special power
If particle(i).special Then
'remove before release:
If specialDrawn = false Then
m$ = LTrim$(Str$(particle(i).special))
Color _RGB32(0)
_PrintString (particle(i).x + 1, particle(i).y + 1), m$
Color _RGB32(255)
_PrintString (particle(i).x, particle(i).y), m$
End If
If particle(i).x - particle(i).size / 2 > paddleX And particle(i).x + particle(i).size / 2 < paddleX + paddleWidth And particle(i).y + particle(i).size / 2 >= paddleY Then
particle(i).state = false
special(particle(i).special).start = Timer
End If
End If
'check collision with blocks if this particle is a bullet
If particle(i).kind = bullet Then
For j = 1 To UBound(block)
If block(j).state = false Then _Continue
If particle(i).x > block(j).x And particle(i).x < block(j).x + blockWidth And particle(i).y < block(j).y + blockHeight Then
destroyBlock j, false
If Timer - special(BreakThrough).start > special(BreakThrough).span Or special(BreakThrough).start = 0 Then
particle(i).state = false
End If
Exit For
End If
Next
End If
Next
End Sub
Sub resetParticle (this As Particle)
Dim empty As Particle
this = empty
End Sub
Sub generateBlocks
For i = 1 To 10
For j = 1 To 10
b = b + 1
block(b).x = (i - 1) * blockWidth
block(b).y = (j - 1) * blockHeight
minRGB = 50
Do
red = 255 * Rnd
green = 255 * Rnd
blue = 255 * Rnd
Loop Until red > minRGB And green > minRGB And blue > minRGB
block(b).c = _RGB32(red, green, blue)
block(b).state = Rnd
r = Rnd * 1000
If r > 150 And r < 200 Then
block(b).special = Rnd * totalSpecialPowers
End If
r = Rnd * 1000
If r > 150 And r < 200 Then
block(b).kind = Rnd * 2
End If
Next
Next
End Sub
Sub showBlocks
For i = 1 To UBound(block)
If block(i).state = false Then _Continue
activeBlocks = activeBlocks + 1
If block(i).kind <> unbreakable Then
Line (block(i).x, block(i).y)-Step(blockWidth - 1, blockHeight - 1), block(i).c, BF
End If
If block(i).kind = hitTwice Then
For x = block(i).x To block(i).x + blockWidth - 1 Step 5
Line (x, block(i).y)-(x, block(i).y + blockHeight - 1), _RGB32(188)
Next
ElseIf block(i).kind = unbreakable Then
activeBlocks = activeBlocks - 1
For x = block(i).x To block(i).x + blockWidth - 1 Step 5
Line (x, block(i).y)-(x, block(i).y + blockHeight - 1), _RGB32(72)
Next
For y = block(i).y To block(i).y + blockHeight - 1 Step 5
Line (block(i).x, y)-(block(i).x + blockWidth - 1, y), _RGB32(72)
Next
End If
Line (block(i).x, block(i).y)-Step(blockWidth - 1, blockHeight - 1), _RGB32(255), B
Line (block(i).x + 1, block(i).y + 1)-Step(blockWidth - 3, blockHeight - 3), _RGB32(0), B
If block(i).special Then
For j = 1 To 6 Step 2
Line (block(i).x + j, block(i).y + j)-Step(blockWidth - j * 2, blockHeight - j * 2), _RGB32(255, 166, 0), B
Line (block(i).x + j + 1, block(i).y + j + 1)-Step(blockWidth - j * 3, blockHeight - j * 3), _RGB32(255, 238, 0), B
Next
'remove before release:
Color _RGB32(0)
_PrintString (block(i).x + 1, block(i).y + 1), Str$(block(i).special)
Color _RGB32(255)
_PrintString (block(i).x, block(i).y), Str$(block(i).special)
End If
Next
win = (activeBlocks = 0)
End Sub
Sub doPaddle
Static lastX As Integer
While _MouseInput: Wend
If _MouseX <> lastX Then
lastX = _MouseX
paddleX = _MouseX - paddleWidth / 2
End If
If _KeyDown(19200) Then paddleX = paddleX - 5
If _KeyDown(19712) Then paddleX = paddleX + 5
If paddleX < 0 Then paddleX = 0
If paddleX + paddleWidth > _Width - 1 Then paddleX = _Width - 1 - paddleWidth
Line (paddleX + paddleHeight / 2, paddleY)-Step(paddleWidth - paddleHeight, paddleHeight), _RGB32(89, 161, 255), BF
CircleFill paddleX + paddleHeight / 2, paddleY + paddleHeight / 2, paddleHeight / 2, _RGB32(194, 89, 61)
CircleFill paddleX + paddleWidth - paddleHeight / 2, paddleY + paddleHeight / 2, paddleHeight / 2, _RGB32(194, 89, 61)
If Timer - special(Magnetic).start < special(Magnetic).span Then
For j = 1 To 2
PSet (paddleX + paddleHeight / 2, paddleY), electricColor(j)
For i = paddleX + paddleHeight To paddleX + paddleWidth - paddleHeight Step paddleWidth / 10
Line -(i, paddleY - (Rnd * 10)), electricColor(j)
Next
Line -(paddleX + paddleWidth - paddleHeight / 2, paddleY), electricColor(j)
Next
End If
If _MouseButton(1) Or _KeyDown(13) Then ball.state = true
If _MouseButton(1) Then
Static mouseWasDown As _Byte
mouseWasDown = true
End If
If Timer - special(Shooter).start < special(Shooter).span Then
CircleFill paddleX + paddleHeight / 2, paddleY, paddleHeight / 3, _RGB32(194, 133, 61)
CircleFill paddleX + paddleWidth - paddleHeight / 2, paddleY, paddleHeight / 3, _RGB32(194, 133, 61)
CircleFill paddleX + paddleHeight / 2, paddleY - paddleHeight / 4, paddleHeight / 4, _RGB32(194, 188, 61)
CircleFill paddleX + paddleWidth - paddleHeight / 2, paddleY - paddleHeight / 4, paddleHeight / 4, _RGB32(194, 188, 61)
If _MouseButton(1) = false And mouseWasDown Then
mouseWasDown = false
For i = 1 To 2
l = newParticle
particle(l).r = 100
particle(l).g = 100
particle(l).b = 100
If i = 1 Then particle(l).x = paddleX + paddleHeight / 2 Else particle(l).x = paddleX + paddleWidth - paddleHeight / 2
particle(l).y = paddleY
particle(l).yVel = -4.5
particle(l).yAcc = -gravity * 1.5
particle(l).size = 2
particle(l).kind = bullet
Next
End If
End If
End Sub
Sub doBall
If ball.state = false Then
ball.x = paddleX + magneticOffset
ball.y = paddleY - (ball.radius)
Else
ball.x = ball.x + ball.xDir * ball.xVel
ball.y = ball.y + ball.yDir * ball.yVel
ballCollision
End If
If Timer - special(FireBall).start < special(FireBall).span Then
For j = 1 To 10
l = newParticle
If l = 0 Then Exit For
particle(l).r = 222 + (Rnd * 30)
particle(l).g = 100 + (Rnd * 70)
particle(l).x = ball.x + Cos(Rnd * _Pi(2)) * (ball.radius * Rnd)
particle(l).y = ball.y + Sin(Rnd * _Pi(2)) * (ball.radius * Rnd)
particle(l).lifeSpan = Rnd
Next
End If
CircleFill ball.x, ball.y, ball.radius, ball.c
End Sub
Function newParticle&
For i = 1 To UBound(particle)
If particle(i).state = false Then
newParticle& = i
resetParticle particle(i)
particle(i).state = true
particle(i).birth = Timer
Exit Function
End If
Next
End Function
Sub ballCollision
'paddle
If ball.x > paddleX And ball.x < paddleX + paddleWidth And ball.y > paddleY And ball.y < paddleY + paddleHeight Then
If Timer - special(Magnetic).start < special(Magnetic).span Then
ball.state = false
magneticOffset = ball.x - paddleX
End If
If ball.x < paddleX + paddleWidth / 2 Then
ball.xDir = left
ball.xVel = map(ball.x, paddleX, paddleX + paddleWidth / 3, 10, 5)
Else
ball.xDir = right
ball.xVel = map(ball.x, paddleX + paddleWidth / 3, paddleX + paddleWidth, 5, 10)
End If
If ball.xVel < 5 Then ball.xVel = 5
If ball.yDir = 1 And ball.y < paddleY + paddleHeight / 2 Then ball.yDir = -1
Exit Sub
End If
'blocks
For i = 1 To UBound(block)
If block(i).state = false Then _Continue
If ball.x > block(i).x And ball.x < block(i).x + blockWidth And ball.y > block(i).y And ball.y < block(i).y + blockHeight Then
destroyBlock i, true
Exit Sub
End If
Next
'walls
If ball.x < ball.radius Then ball.xDir = right
If ball.x > _Width - ball.radius Then ball.xDir = left
If ball.y > _Height + ball.radius Then
lives = lives - 1
magneticOffset = paddleWidth / 2
ball.state = false
ball.xDir = right
ball.yDir = up
ball.xVel = 5
ball.yVel = 5
End If
If ball.y < 0 Then ball.yDir = down
End Sub
Sub destroyBlock (i As Long, ballHit As _Byte)
Select Case block(i).kind
Case regular
block(i).state = false
If Timer - special(BreakThrough).start < special(BreakThrough).span Then
maxJ = 10
maxK = 3
For j = 1 To maxJ
For k = 1 To maxK
l = newParticle
If l = 0 Then Exit For
a = Rnd * 1000
If a < 100 Then
particle(l).r = _Red32(block(i).c)
particle(l).g = _Green32(block(i).c)
particle(l).b = _Blue32(block(i).c)
Else
particle(l).r = map(a, 0, 1000, 50, 255)
particle(l).g = map(a, 0, 1000, 50, 255)
particle(l).b = map(a, 0, 1000, 50, 255)
End If
particle(l).x = block(i).x + ((blockWidth / maxJ) * (j - 1))
particle(l).y = block(i).y + ((blockHeight / maxK) * (k - 1))
a = Rnd
If ball.xDir = right And ball.yDir = up Then
particle(l).xAcc = Cos(map(a, 0, 1, _Pi(1.5), _Pi(2)))
particle(l).yAcc = Sin(map(a, 0, 1, _Pi(1.5), _Pi(2)))
ElseIf ball.xDir = right And ball.yDir = down Then
particle(l).xAcc = Cos(map(a, 0, 1, 0, _Pi(.5)))
particle(l).yAcc = Sin(map(a, 0, 1, 0, _Pi(.5)))
ElseIf ball.xDir = left And ball.yDir = up Then
particle(l).xAcc = Cos(map(a, 0, 1, _Pi, _Pi(1.5)))
particle(l).yAcc = Sin(map(a, 0, 1, _Pi, _Pi(1.5)))
ElseIf ball.xDir = left And ball.yDir = down Then
particle(l).xAcc = Cos(map(a, 0, 1, _Pi(.5), _Pi))
particle(l).yAcc = Sin(map(a, 0, 1, _Pi(.5), _Pi))
End If
particle(l).lifeSpan = .5
particle(l).size = 1
Next
Next
End If
If block(i).special Then
Static lastSpecialGiven As Single
If Timer - lastSpecialGiven > 3 Then
lastSpecialGiven = Timer
l = newParticle
If l Then
particle(l).size = 6
particle(l).x = block(i).x + blockWidth / 2
particle(l).y = block(i).y + blockHeight / 2
particle(l).r = 255
particle(l).g = 255
particle(l).b = 255
particle(l).kind = specialPower
particle(l).special = block(i).special
End If
End If
End If
points = ((_Red32(block(i).c) + _Green32(block(i).c) + _Blue32(block(i).c)) / 3) / 10
score = score + points
Case hitTwice
block(i).kind = regular
If ballHit Then
If Timer - special(FireBall).start < special(FireBall).span Then destroyBlock i, ballHit
End If
Case unbreakable
'check if the ball is trapped between two unbreakable blocks
Static lastBlock(1 To 3) As Block
lastBlock(3) = lastBlock(2)
lastBlock(2) = lastBlock(1)
lastBlock(1) = block(i)
IF (lastBlock(1).x = lastBlock(3).x AND lastBlock(1).y = lastBlock(3).y) OR _
lastBlock(1).x = lastBlock(2).x AND lastBlock(1).y = lastBlock(2).y THEN
If ball.xVel > 7.5 And ball.xVel < 10 Then
ball.xVel = 10
ElseIf ball.xVel = 10 Then
ball.xVel = 8
End If
If ball.xVel <= 7.5 And ball.xVel > 5 Then
ball.xVel = 5
ElseIf ball.xVel = 5 Then
ball.xVel = 6
End If
End If
End Select
If ballHit Then
If (block(i).kind = unbreakable Or block(i).kind = hitTwice) Then
For j = 1 To map(ball.xVel, 5, 10, 10, 30)
l = newParticle
If l = 0 Then Exit For
particle(l).r = 222 + (Rnd * 30)
particle(l).g = 100 + (Rnd * 70)
particle(l).x = ball.x + Cos(Rnd * _Pi(2)) * (ball.radius * Rnd)
particle(l).y = ball.y + Sin(Rnd * _Pi(2)) * (ball.radius * Rnd)
particle(l).lifeSpan = Rnd
a = Rnd
If ball.xDir = right And ball.yDir = up Then
particle(l).xVel = Cos(map(a, 0, 1, _Pi(1.5), _Pi(2)))
particle(l).yVel = Sin(map(a, 0, 1, _Pi(1.5), _Pi(2)))
ElseIf ball.xDir = right And ball.yDir = down Then
particle(l).xVel = Cos(map(a, 0, 1, 0, _Pi(.5)))
particle(l).yVel = Sin(map(a, 0, 1, 0, _Pi(.5)))
ElseIf ball.xDir = left And ball.yDir = up Then
particle(l).xVel = Cos(map(a, 0, 1, _Pi, _Pi(1.5)))
particle(l).yVel = Sin(map(a, 0, 1, _Pi, _Pi(1.5)))
ElseIf ball.xDir = left And ball.yDir = down Then
particle(l).xVel = Cos(map(a, 0, 1, _Pi(.5), _Pi))
particle(l).yVel = Sin(map(a, 0, 1, _Pi(.5), _Pi))
End If
Next
End If
If Timer - special(BreakThrough).start > special(BreakThrough).span Or special(BreakThrough).start = 0 Then
If ball.x < block(i).x + blockWidth / 2 Then ball.xDir = left Else ball.xDir = right
If ball.y < block(i).y + blockHeight / 2 Then ball.yDir = up Else ball.yDir = down
End If
End If
End Sub
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' R = radius
' C = fill color
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
End Function

BIN
samples/cant-contain-me/img/screenshot.jpg Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 32 KiB

26
samples/cant-contain-me/index.md Normal file
View file

@ -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: CAN'T CONTAIN ME
![screenshot.jpg](img/screenshot.jpg)
### Author
[🐝 Fellippe Heitor](../fellippe-heitor.md)
### Description
Can't Contain Me is a game developed in QB64.
The pieces are trying to escape your screen and the container that'll hold them back from leaving is in the center of the window. Drag as many fugitives as you can into the cell (even multiple at once) so you can win.
### File(s)
* [cant-contain-me.zip](src/cant-contain-me.zip)
* [ccm.bas](src/ccm.bas)
🔗 [game](../game.md)
<sub>Reference: [github](https://github.com/FellippeHeitor/cant-contain-me) </sub>

BIN
samples/cant-contain-me/src/cant-contain-me.zip Normal file
View file

Binary file not shown.

302
samples/cant-contain-me/src/ccm.bas Normal file
View file

@ -0,0 +1,302 @@
'Can't Contain Me - A game developed in QB64
'@FellippeHeitor fellippeheitor@gmail.com
CONST true = -1, false = NOT true
TYPE vector
x AS SINGLE
y AS SINGLE
z AS SINGLE
END TYPE
TYPE NewObject
pos AS vector
dir AS vector
w AS INTEGER
h AS INTEGER
dragXoff AS INTEGER
dragYoff AS INTEGER
color AS _UNSIGNED LONG
img AS LONG
selected AS _BYTE
lost AS _BYTE
added AS _BYTE
END TYPE
SCREEN _NEWIMAGE(896, 504, 32)
DO UNTIL _SCREENEXISTS: LOOP
_TITLE "Can't contain me"
RANDOMIZE TIMER
DIM icon AS LONG
icon = _NEWIMAGE(64, 64, 32)
_DEST icon
LINE (0, 0)-(63, 63), _RGB32(RND * 200, RND * 200, RND * 200), BF
CIRCLE (32, 32), 5, _RGB32(255, 255, 255)
PAINT (32, 32)
_DEST 0
_ICON icon
_FREEIMAGE icon
COLOR , 0
DIM obj(1 TO 10) AS NewObject, barn AS NewObject
DIM drag AS _BYTE, f AS LONG
DIM k AS LONG, i AS LONG
barn.w = 300
barn.h = 300
barn.pos.x = _WIDTH / 2 - barn.w / 2
barn.pos.y = _HEIGHT / 2 - barn.h / 2
GOSUB resetPieces
DO
k = _KEYHIT
IF k = 27 THEN SYSTEM
IF (_KEYDOWN(100305) OR _KEYDOWN(100306)) AND (k = ASC("a") OR k = ASC("A")) THEN
FOR i = 1 TO UBOUND(obj)
obj(i).selected = true
NEXT
END IF
WHILE _MOUSEINPUT: WEND
IF NOT Won THEN
IF _MOUSEBUTTON(1) THEN
IF NOT drag THEN
drag = true
dragSelect = true
dragx = _MOUSEX
dragy = _MOUSEY
clickedBox = false
FOR i = 1 TO UBOUND(obj)
IF hovering(obj(i)) AND obj(i).added = false THEN
dragSelect = false
clickedBox = true
obj(i).dragXoff = _MOUSEX - obj(i).pos.x
obj(i).dragYoff = _MOUSEY - obj(i).pos.y
FOR j = 1 TO UBOUND(obj)
IF j <> i THEN
IF NOT _KEYDOWN(100305) AND NOT _KEYDOWN(100306) THEN
IF obj(i).selected = false THEN obj(j).selected = false
END IF
obj(j).dragXoff = _MOUSEX - obj(j).pos.x
obj(j).dragYoff = _MOUSEY - obj(j).pos.y
END IF
NEXT
obj(i).selected = true
EXIT FOR
END IF
NEXT
END IF
ELSE
IF drag THEN
drag = false
dragSelect = false
END IF
END IF
ELSE
IF _MOUSEBUTTON(1) THEN
IF NOT mousepressed THEN
GOSUB resetPieces
ELSE
drag = false
dragSelect = false
END IF
ELSE
mousepressed = false
END IF
END IF
LINE (0, 0)-(_WIDTH - 1, _HEIGHT - 1), _RGBA32(0, 0, 0, 30), BF
FOR i = 1 TO UBOUND(obj)
IF NOT obj(i).lost THEN
obj(i).lost = obj(i).pos.x > _WIDTH OR obj(i).pos.y > _HEIGHT OR obj(i).pos.x + obj(i).w < 0 OR obj(i).pos.y + obj(i).h < 0
IF obj(i).lost THEN
'score = score - 5
END IF
END IF
IF NOT obj(i).lost THEN
IF obj(i).img < -1 THEN
ELSE
LINE (obj(i).pos.x, obj(i).pos.y)-STEP(obj(i).w - 1, obj(i).h - 1), obj(i).color, BF
CIRCLE (obj(i).pos.x + obj(i).w / 2, obj(i).pos.y + obj(i).h / 2), 2, _RGB32(255, 255, 255)
PAINT (obj(i).pos.x + obj(i).w / 2, obj(i).pos.y + obj(i).h / 2)
END IF
IF obj(i).selected THEN
IF obj(i).img < -1 THEN
ELSE
LINE (obj(i).pos.x - 2, obj(i).pos.y - 2)-STEP(obj(i).w + 3, obj(i).h + 3), _RGBA32(255, 255, 255, 150), B , 21845
END IF
ELSEIF hovering(obj(i)) AND NOT Won THEN
IF obj(i).img < -1 THEN
ELSE
LINE (obj(i).pos.x, obj(i).pos.y)-STEP(obj(i).w - 1, obj(i).h - 1), _RGBA32(255, 255, 255, 100), BF
END IF
END IF
END IF
IF drag AND obj(i).selected AND NOT dragSelect THEN
obj(i).pos.x = dragx + (_MOUSEX - dragx) - obj(i).dragXoff
obj(i).pos.y = dragy + (_MOUSEY - dragy) - obj(i).dragYoff
END IF
IF NOT isInside(obj(i), barn) THEN
vector.add obj(i).pos, obj(i).dir
IF isInside(obj(i), barn) THEN vector.mult obj(i).dir, -1
DO WHILE isInside(obj(i), barn)
vector.add obj(i).pos, obj(i).dir
LOOP
ELSE
vector.add obj(i).pos, obj(i).dir
IF NOT isInside(obj(i), barn) THEN vector.mult obj(i).dir, -1
DO WHILE NOT isInside(obj(i), barn)
vector.add obj(i).pos, obj(i).dir
LOOP
IF obj(i).added = false THEN
score = score + 10
obj(i).added = true
'pieces get agitated when contained...
obj(i).dir.x = obj(i).dir.x * 5
obj(i).dir.y = obj(i).dir.y * 5
ELSE
obj(i).selected = false
END IF
END IF
NEXT
LINE (barn.pos.x - obj(1).w / 2, barn.pos.y - obj(1).h / 2)-STEP(barn.w + obj(1).w - 1, barn.h + obj(1).h - 1), _RGBA32(255, 255, 255, 100), BF
IF dragSelect THEN
LINE (dragx, dragy)-(_MOUSEX, _MOUSEY), _RGBA32(127, 172, 255, 100), BF
LINE (dragx, dragy)-(_MOUSEX, _MOUSEY), _RGB32(127, 172, 255), B
DIM rect AS NewObject
rect.pos.x = dragx
rect.pos.y = dragy
rect.w = _MOUSEX - dragx
rect.h = _MOUSEY - dragy
FOR i = 1 TO UBOUND(obj)
IF isInside(obj(i), rect) AND obj(i).added = false THEN obj(i).selected = true ELSE obj(i).selected = false
NEXT
END IF
Won = true
LostPieces = 0
FOR i = 1 TO UBOUND(obj)
IF NOT obj(i).lost THEN
IF NOT obj(i).added THEN Won = false: EXIT FOR
ELSE
LostPieces = LostPieces + 1
END IF
NEXT
IF Won THEN
IF LostPieces = 1 THEN
m$ = "All but 1 piece contained!"
ELSEIF LostPieces = UBOUND(obj) THEN
m$ = "You lose... no pieces contained..."
ELSEIF LostPieces > 1 THEN
m$ = "All but" + STR$(LostPieces) + " pieces contained!"
ELSE
m$ = "All pieces contained!"
END IF
COLOR _RGB32(0, 0, 0)
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2 + 1, _HEIGHT / 2 - _FONTHEIGHT - 1), m$
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2 - 1, _HEIGHT / 2 - _FONTHEIGHT - 1), m$
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2 + 1, _HEIGHT / 2 - _FONTHEIGHT + 1), m$
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2 - 1, _HEIGHT / 2 - _FONTHEIGHT + 1), m$
COLOR _RGB32(255, 255, 255)
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2, _HEIGHT / 2 - _FONTHEIGHT), m$
m$ = "Your score:" + STR$(score)
COLOR _RGB32(0, 0, 0)
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2 - 1, _HEIGHT / 2 + _FONTHEIGHT - 1), m$
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2 + 1, _HEIGHT / 2 + _FONTHEIGHT + 1), m$
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2 + 1, _HEIGHT / 2 + _FONTHEIGHT - 1), m$
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2 - 1, _HEIGHT / 2 + _FONTHEIGHT + 1), m$
COLOR _RGB32(255, 255, 255)
_PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(m$) / 2, _HEIGHT / 2 + _FONTHEIGHT), m$
IF _MOUSEBUTTON(1) THEN mousepressed = true
ELSE
_PRINTSTRING (0, 0), "Score:" + STR$(score)
_PRINTSTRING (0, _FONTHEIGHT), "Time:" + STR$(INT(TIMER - start#))
END IF
_DISPLAY
_LIMIT 30
LOOP
SYSTEM
resetPieces:
FOR i = 1 TO UBOUND(obj)
obj(i).w = 40
obj(i).h = 40
obj(i).lost = false
obj(i).added = false
obj(i).selected = false
createVector obj(i).dir, p5random(-1, 1), p5random(-1, 1)
obj(i).color = _RGB32(RND * 200, RND * 200, RND * 200)
DO
createVector obj(i).pos, RND * (_WIDTH - obj(i).w), RND * (_HEIGHT - obj(i).h)
LOOP WHILE isInside(obj(i), barn)
NEXT
start# = TIMER
Won = false
score = 0
RETURN
FUNCTION hovering%% (this AS NewObject)
hovering = _MOUSEX > this.pos.x AND _MOUSEX < this.pos.x + this.w - 1 AND _MOUSEY > this.pos.y AND _MOUSEY < this.pos.y + this.h - 1
END FUNCTION
FUNCTION isInside%% (this AS NewObject, __rect AS NewObject)
DIM rect AS NewObject
rect = __rect
IF rect.w < 0 THEN rect.w = ABS(rect.w): rect.pos.x = rect.pos.x - rect.w
IF rect.h < 0 THEN rect.h = ABS(rect.h): rect.pos.y = rect.pos.y - rect.h
isInside%% = rect.pos.x < this.pos.x + this.w AND rect.pos.x + rect.w > this.pos.x AND rect.pos.y < this.pos.y + this.h AND rect.pos.y + rect.h > this.pos.y
END FUNCTION
'Elements below have been borrowed from the p5js.bas library:
FUNCTION p5random! (mn!, mx!)
IF mn! > mx! THEN
SWAP mn!, mx!
END IF
p5random! = RND * (mx! - mn!) + mn!
END FUNCTION
SUB createVector (v AS vector, x AS SINGLE, y AS SINGLE)
v.x = x
v.y = y
END SUB
SUB vector.add (v1 AS vector, v2 AS vector)
v1.x = v1.x + v2.x
v1.y = v1.y + v2.y
v1.z = v1.z + v2.z
END SUB
SUB vector.mult (v AS vector, n AS SINGLE)
v.x = v.x * n
v.y = v.y * n
v.z = v.z * n
END SUB

BIN
samples/castle/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 5.3 KiB

19
samples/castle/index.md Normal file
View file

@ -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: CASTLE
![screenshot.png](img/screenshot.png)
### Author
[🐝 Microsoft](../microsoft.md)
### Description
A turn-based artillery game by Microsoft.
### File(s)
* [castle.bas](src/castle.bas)
🔗 [game](../game.md), [2 player](../2-player.md)

536
samples/castle/src/castle.bas Normal file
View file

@ -0,0 +1,536 @@
$NoPrefix
DefInt A-Z
$Resize:Smooth
Const FALSE = 0
Const TRUE = Not FALSE
Const SHOTSELF = 1
Const BACKGROUND_COLOR = 0
Const TERRAINCOLOR = 1
Const EXPLOSIONCOLOR = 2
Const OBJECTCOLOR = 3
Dim Shared CastleX(1 To 2)
Dim Shared CastleY(1 To 2)
Dim Shared CastlePic&(1 To 40)
Dim Shared shot&(1 To 10)
Dim Shared gravity#
Dim Shared Wind
Dim Shared ScreenHeight
Dim Shared ScreenWidth
Dim Shared mode
Dim Shared MaxCol
Dim Shared BaseCol
Intro
GetInputs name1$, name2$, numGames, gravity#
GoSub InitializeVariables
PlayGame name1$, name2$, numGames
EndGame
End
CGAPic:
Data 589840,-12301,-1,-62915521,-62915521,64575
CGAShot:
Data 196614,3210288&
EGAPic:
Data 1048592,-806105101,0,-806105101,0,-1,0,-1,0,-1,0,-1,0,-62915521,0
Data -62915521,0,-62915521,0,-62915521,0,-62915521,0,-62915521,0,-62915521
Data 0,-62915521,0,-62915521,0,-62915521,0,0,0,-62915521,0,0,0
EGAShot:
Data 196611,57568,57568,57568
InitializeVariables:
On Error GoTo ScreenModeError
mode = 9
Screen mode
On Error GoTo 0
If mode = 9 Then
ScreenWidth = 640
ScreenHeight = 350
Restore EGAPic
For Counter = 1 To 39
Read CastlePic&(Counter)
Next Counter
For Counter = 1 To 4
Read shot&(Counter)
Next Counter
Color 3, 1
Palette TERRAINCOLOR, 2 'Set color for ground
Palette EXPLOSIONCOLOR, 4 'Explosion color
Palette OBJECTCOLOR, 12
BaseCol = 30
MaxCol = 80
Else
ScreenWidth = 320
ScreenHeight = 200
Restore CGAPic
For Counter = 1 To 6
Read CastlePic&(Counter)
Next Counter
For Counter = 1 To 2
Read shot&(Counter)
Next Counter
Color 3, 0
BaseCol = 10
MaxCol = 40
End If
Return
ScreenModeError:
If mode = 1 Then
Print "Sorry, You must have CGA, EGA, or VGA graphics to play Castles"
End
Else
mode = 1
Resume
End If
'Rest:
' pauses the program
Sub Rest (t#)
If (t# > 0) Then Delay t#
End Sub
Sub Center (row, text$)
Locate row, 41 - Len(text$) / 2
Print text$;
End Sub
Sub CyclePalette
If mode = 9 Then
Palette EXPLOSIONCOLOR, 38
Palette EXPLOSIONCOLOR, 44
Else
Color 12, EXPLOSIONCOLOR
Color 14, EXPLOSIONCOLOR
Color 3, EXPLOSIONCOLOR
End If
End Sub
Sub DoExplosion (x#, y#)
Play "MBO0L32EFGEFDC"
Radius = ScreenHeight / 70
If mode = 9 Then Increment# = .5 Else Increment# = 1.2
For Counter# = 0 To Radius Step Increment#
Circle (x#, y#), Counter#, EXPLOSIONCOLOR
Call CyclePalette
Next Counter#
For Counter# = Radius To 0 Step (-1 * Increment#)
Circle (x#, y#), Counter#, BACKGROUND_COLOR
Rest .005
Next Counter#
End Sub
Function DoShot (PlayerNum, XPos, YPos)
If PlayerNum = 1 Then
locateCol = 1
Else
If mode = 9 Then
locateCol = 66
Else
locateCol = 26
End If
End If
YShotPos = YPos - 3
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#
View Print 1 To 4
Cls 2
View Print 1 To 25
PlayerHit = PlotShot(XPos, YShotPos, Angle#, Velocity)
If PlayerHit = PlayerNum Then
DoShot = SHOTSELF
ElseIf PlayerHit <> 0 Then
DoShot = TRUE
Else
DoShot = FALSE
End If
End Function
Sub EndGame
Screen 0
Color 15, 0
Cls
End Sub
Function ExplodeCastle (x#)
Shared CastleX(), CastleY()
ScaleX# = ScreenWidth / 320
ScaleY# = ScreenHeight / 200
If x# < ScreenWidth / 2 Then PlayerHit = 1 Else PlayerHit = 2
Play "MBO0L16EFGEFDC"
For Blast = 1 To 8 * ScaleX#
Circle (CastleX(PlayerHit) + 3.5 * ScaleX#, CastleY(PlayerHit) + 7 * ScaleY#), Blast, EXPLOSIONCOLOR, , , -1.57
Line (CastleX(PlayerHit) + 7 * ScaleX#, CastleY(PlayerHit) + 9 * ScaleY# - Blast)-(CastleX(PlayerHit), CastleY(PlayerHit) + 9 * ScaleY# - Blast), EXPLOSIONCOLOR
If Blast Mod (10 - mode) < 3 Then Call CyclePalette
Rest .005
Next Blast
For Cloud = 1 To 16 * ScaleX#
If Cloud < (8 * ScaleX#) Then Circle (CastleX(PlayerHit) + 3.5 * ScaleX#, CastleY(PlayerHit) + 7 * ScaleY#), (8 * ScaleX# + 1) - Cloud, BACKGROUND_COLOR, , , -1.57
Circle (CastleX(PlayerHit) + 3.5 * ScaleX#, CastleY(PlayerHit)), Cloud, EXPLOSIONCOLOR, , , -1.57
If Cloud Mod (10 - mode) < 3 Then Call CyclePalette
Rest .005
Next Cloud
For Cloud = 16 * ScaleX# To 1 Step -1
Circle (CastleX(PlayerHit) + 3.5 * ScaleX#, CastleY(PlayerHit)), Cloud, BACKGROUND_COLOR, , , -1.57
Rest .01
Next Cloud
ExplodeCastle = PlayerHit
End Function
Sub GetInputs (player1$, player2$, numGames, gravity#)
Screen 0
Color 14, 1
Cls
Do
Locate 9, 30
Line Input "Name of Player 1 :"; player1$
Loop Until player1$ <> ""
Do
Locate 10, 30
Line Input "Name of Player 2 :"; player2$
Loop Until player2$ <> ""
Locate 12, 26
Input "Play to how many points"; numGames
Do
Locate 14, 22
Input "Gravity in Meters/Sec (Earth = 9.8)"; gravity#
Loop Until gravity# > 0
End Sub
Function GetNum# (row, col)
result$ = ""
finished = FALSE
Do While Not finished
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)
finished = TRUE
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
Sub Intro
Screen 0
Color 12, 1
Cls
Center 8, "Q u i c k B A S I C C A S T L E S"
Color 14
Center 10, "Your mission is to destroy your opponent's castle"
Center 11, "by varying the angle and power of your catapult"
Center 12, "taking into account wind speed, gravity and terrain."
Center 24, "Push Any Key To Continue"
Color 15
Play "T160O1L8CDEDCDL4ECC"
SparklePause
End Sub
Sub MakeBattleField (TerrainHeight())
If mode = 9 Then Increment = 2 Else Increment = 1
TerrainHeight(0) = ScreenHeight - (10 + Int((ScreenHeight / 3) * Rnd + 1))
For Counter = 1 To ScreenWidth
Motion = Int(20 * Rnd + 1)
If Counter < (ScreenWidth / 2) Then OnFirstHalfScreen = TRUE Else OnFirstHalfScreen = FALSE
If Int(4 * Rnd + 1) = 1 Then ShouldCheckScreenPos = TRUE Else ShouldCheckScreenPos = FLASE
Select Case Motion
Case 1 TO 10
If (ShouldCheckScreenPos And OnFirstHalfScreen) Then
Trend = Trend - Increment
ElseIf (ShouldCheckScreenPos And (Not OnFirstHalfScreen)) Then
Trend = Trend + Increment
ElseIf Motion < 6 Then
Trend = Trend - Increment
Else
Trend = Trend + Increment
End If
Case 11 TO 14
If (ShouldCheckScreenPos And OnFirstHalfScreen) Then
Trend = Trend - Increment * 2
ElseIf (ShouldCheckScreenPos And (Not OnFirstHalfScreen)) Then
Trend = Trend + Increment * 2
ElseIf Motion < 13 Then
Trend = Trend - Increment * 2
Else
Trend = Trend + Increment * 2
End If
Case 15
Trend = 0
Case 16
Trend = 1
Case 17
Trend = -1
Case Else
End Select
Select Case Trend
Case Is < -10
TerrainHeight(Counter) = TerrainHeight(Counter - 1) - 3
Case Is < 0
TerrainHeight(Counter) = TerrainHeight(Counter - 1) - 1
Case Is > 10
TerrainHeight(Counter) = TerrainHeight(Counter - 1) + 3
Case Is > 0
TerrainHeight(Counter) = TerrainHeight(Counter - 1) + 1
Case Else
TerrainHeight(Counter) = TerrainHeight(Counter - 1)
End Select
If TerrainHeight(Counter) > (ScreenHeight - (8 + mode)) Then
TerrainHeight(Counter) = (ScreenHeight - (8 + mode))
If OnFirstHalfScreen Then Trend = -9 Else Trend = -3
Else
If TerrainHeight(Counter) < (ScreenHeight / 2.2) Then
TerrainHeight(Counter) = (ScreenHeight / 2.2)
If OnFirstHalfScreen Then Trend = 9 Else Trend = 3
End If
End If
Line (Counter, ScreenHeight)-(Counter, TerrainHeight(Counter)), TERRAINCOLOR
Next Counter
Wind = Int(10 * Rnd + 1) - 5
If (Int(3 * Rnd + 1) = 1) Then
If Wind > 0 Then
Wind = Wind + Int(10 * Rnd + 1)
Else
Wind = Wind - Int(10 * Rnd + 1)
End If
End If
If Wind <> 0 Then
WindLineLength = Wind * (ScreenWidth / 320)
Line (ScreenWidth / 2, ScreenHeight - 15)-(ScreenWidth / 2 + WindLineLength, ScreenHeight - 15), EXPLOSIONCOLOR
If Wind > 0 Then ArrowDir = -2 Else ArrowDir = 2
Line (ScreenWidth / 2 + WindLineLength, ScreenHeight - 15)-(ScreenWidth / 2 + WindLineLength + ArrowDir, ScreenHeight - 15 - 2), EXPLOSIONCOLOR
Line (ScreenWidth / 2 + WindLineLength, ScreenHeight - 15)-(ScreenWidth / 2 + WindLineLength + ArrowDir, ScreenHeight - 15 + 2), EXPLOSIONCOLOR
End If
End Sub
Sub PlaceCastles (CastleX(), CastleY(), TerrainHeight())
ScaleX# = ScreenWidth / 320
ScaleY# = ScreenHeight / 200
For Counter = 1 To 2
CastleX(Counter) = Int((ScreenWidth / 3.2) * Rnd + ((ScreenWidth / 1.6 - 3) * (Counter - 1))) + 2
CastleY(Counter) = TerrainHeight(CastleX(Counter)) - (9 * ScaleY#)
Put (CastleX(Counter), CastleY(Counter)), CastlePic&(), PSet
For FixTerrain = CastleX(Counter) To CastleX(Counter) + (7 * ScaleX#)
Line (FixTerrain, ScreenHeight)-(FixTerrain, CastleY(Counter) + (9 * ScaleY#)), TERRAINCOLOR
Line (FixTerrain, 0)-(FixTerrain, CastleY(Counter) - 1), BACKGROUND_COLOR
Next FixTerrain
Next Counter
End Sub
Sub PlayGame (player1$, player2$, numGames)
Dim TerrainHeight(0 To 640)
Dim TotalWins(1 To 2)
Randomize (Timer)
If mode = 9 Then
Palette OBJECTCOLOR, 63
Else
Color 3, 0
End If
For Counter = 1 To numGames
Cls
Call MakeBattleField(TerrainHeight())
Call PlaceCastles(CastleX(), CastleY(), TerrainHeight())
DirectHit = FALSE
Do While DirectHit = FALSE
Locate 1, 1
Print player1$
Locate 1, (MaxCol - 1 - Len(player2$))
Print player2$
Locate 1, BaseCol + 3
Print TotalWins(1); ">Score<"; TotalWins(2)
If Counter Mod 2 Then FirstPlayer = 1 Else FirstPlayer = 2
SecondPlayer = Abs(FirstPlayer - 3)
DirectHit = DoShot(FirstPlayer, CastleX(FirstPlayer), CastleY(FirstPlayer))
If DirectHit = FALSE Then
Locate 1, 1
Print player1$
Locate 1, (MaxCol - 1 - Len(player2$))
Print player2$
DirectHit = DoShot(SecondPlayer, CastleX(SecondPlayer), CastleY(SecondPlayer))
If DirectHit <> FALSE Then Call UpdateScores(TotalWins(), SecondPlayer, DirectHit)
Else
Call UpdateScores(TotalWins(), FirstPlayer, DirectHit)
End If
Loop
Sleep 1
Next Counter
Screen 0
Color 14, 1
Cls
Locate 8, 35: Print "GAME OVER!"
Locate 10, 30: Print "Score:"
Locate 11, 34: Print player1$; Tab(30 + 20); TotalWins(1)
Locate 12, 34: Print player2$; Tab(30 + 20); TotalWins(2)
Center 24, "Push Any Key To Continue"
Color 14
SparklePause
End Sub
Function PlotShot (StartX, StartY, Angle#, Velocity)
Angle# = Angle# / 180 * Pi 'Convert degree angle to radians
Radius = mode Mod 7
InitialXVelocity# = Cos(Angle#) * Velocity
InitialYVelocity# = Sin(Angle#) * Velocity
Oldx# = StartX
Oldy# = StartY
Play "MBo0L32A-L64CL16BL64A+"
Rest .1
DirectHit = FALSE
Impact = FALSE
OnScreen = TRUE
PlayerHit = 0
NEEDERASE = FALSE
If Velocity < 2 Then 'Shot too slow - hit self
x# = StartX
y# = StartY
Impact = TRUE
DirectHit = TRUE
End If
Do While (Not Impact) And OnScreen
Rest .02
x# = StartX + (InitialXVelocity# * t#) + (.5 * (Wind / 5) * t# ^ 2)
y# = StartY + ((-1 * (InitialYVelocity# * t#)) + (.5 * gravity# * t# ^ 2)) * (ScreenHeight / 350)
If (x# >= ScreenWidth - 3) Or (x# <= 3) Or (y# >= ScreenHeight - 3) Then
OnScreen = FALSE
End If
If NEEDERASE Then
Put (Oldx#, Oldy#), shot&(), Xor
End If
For LookX = -1 To 1
For LookY = -1 To 1
If Point(x# + LookX, y# + LookY) = TERRAINCOLOR Or Point(x# + LookX, y# + LookY) = OBJECTCOLOR Then Impact = TRUE
Next
Next
If OnScreen And Not Impact And y# > 0 Then
Put (x#, y#), shot&(), PSet
NEEDERASE = TRUE
Oldx# = x#
Oldy# = y#
Else
NEEDERASE = FALSE
If Not OnScreen Or y# < 0 Then
Oldx# = 0
Oldy# = 0
Else
For LookX = -1 To 1
For LookY = -1 To 1
If Point(x# + LookX, y# + LookY) = OBJECTCOLOR Then DirectHit = TRUE
Next
Next
End If
End If
t# = t# + .1
Loop
If Impact Then Call DoExplosion(x#, y#)
If DirectHit Then PlayerHit = ExplodeCastle(x#)
PlotShot = PlayerHit
End Function
Sub SparklePause
Color 15, 1
a$ = "* * * * * * * * * * * * * * * * * "
While InKey$ = ""
For a = 1 To 5
Locate 1, 1
Print Mid$(a$, a, 80);
Locate 20, 1
Print Mid$(a$, 6 - a, 80);
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
Rest .06
Next a
Wend
End Sub
Sub UpdateScores (Record(), PlayerNum, Results)
If Results = SHOTSELF Then
Record(Abs(PlayerNum - 3)) = Record(Abs(PlayerNum - 3)) + 1
Else
Record(PlayerNum) = Record(PlayerNum) + 1
End If
End Sub

BIN
samples/chaotic-scattering/img/chaoticscattering.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 6.1 KiB

23
samples/chaotic-scattering/index.md Normal file
View file

@ -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: CHAOTIC SCATTERING - GASPARD-RICE SYSTEM
![chaoticscattering.png](img/chaoticscattering.png)
### Author
[🐝 vince](../vince.md)
### Description
Demo of the Gaspard-Rice system. Left-click to change location.
### File(s)
* [chaoticscattering.bas](src/chaoticscattering.bas)
* [scatter2.bas](src/scatter2.bas)
🔗 [ray tracing](../ray-tracing.md), [reflections](../reflections.md)
<sub>Reference: [qb64.org Forum](https://qb64forum.alephc.xyz/index.php?topic=2300.0) , [qb64.org Forum](https://en.wikipedia.org/wiki/Chaotic_scattering) </sub>

90
samples/chaotic-scattering/src/chaoticscattering.bas Normal file
View file

@ -0,0 +1,90 @@
DEFINT A-Z
sw = 640
sh = 480
DIM pi AS DOUBLE
DIM t AS DOUBLE
DIM a AS DOUBLE, b AS DOUBLE
DIM a1 AS DOUBLE, a2 AS DOUBLE
DIM x AS DOUBLE, y AS DOUBLE
DIM x0 AS DOUBLE, y0 AS DOUBLE
DIM x1 AS DOUBLE, y1 AS DOUBLE
pi = 3.141593
SCREEN _NEWIMAGE(sw, sh, 12)
r = 150
rr = 100
xx = sw / 2
yy = sh / 2
DO
DO
mx = _MOUSEX
my = _MOUSEY
mb = _MOUSEBUTTON(1)
LOOP WHILE _MOUSEINPUT
LINE (0, 0)-(sw, sh), 0, BF
FOR b = 0 TO 2 * pi STEP 2 * pi / 3
CIRCLE (r * COS(b) + sw / 2, r * SIN(b) + sh / 2), rr
NEXT
IF mb THEN
f = -1
DO WHILE mb
DO
mb = _MOUSEBUTTON(1)
LOOP WHILE _MOUSEINPUT
LOOP
FOR b = 0 TO 2 * pi STEP 2 * pi / 3
x1 = r * COS(b) + sw / 2
y1 = r * SIN(b) + sh / 2
IF (mx - x1) ^ 2 + (my - y1) ^ 2 < rr * rr THEN f = 0
NEXT
IF f THEN
xx = mx
yy = my
f = -1
END IF
END IF
x0 = xx
y0 = yy
a = _ATAN2(my - yy, mx - xx)
t = 0
DO
t = t + 1
x = t * COS(a) + x0
y = t * SIN(a) + y0
IF x < 0 OR x > sw OR y < 0 OR y > sh THEN EXIT DO
FOR b = 0 TO 2 * pi STEP 2 * pi / 3
x1 = r * COS(b) + sw / 2
y1 = r * SIN(b) + sh / 2
IF (x - x1) ^ 2 + (y - y1) ^ 2 < rr * rr THEN
a1 = _ATAN2(y - y1, x - x1)
a2 = 2 * a1 - a - pi
LINE (x0, y0)-(x, y), 14
x0 = x
y0 = y
a = a2
t = 0
EXIT FOR
END IF
NEXT
LOOP
LINE (x0, y0)-(x, y), 14
_DISPLAY
_LIMIT 50
LOOP UNTIL _KEYHIT = 27
SYSTEM

103
samples/chaotic-scattering/src/scatter2.bas Normal file
View file

@ -0,0 +1,103 @@
#lang "fblite"
dim pi as double
pi = 4*atn(1)
sw = 800
sh = 600
dim as double t, a, b, a1, a2
dim as double x, y, x0, y0, x1, y1, dx, dy
r = 150
rr0 = 110
sx = 0
sy = sh/2
screenres sw, sh, 32
do
m = getmouse(mx, my, mw, mb)
rr = rr0 + mw
if mb > 0 then
do while mb > 0
m = getmouse(mx, my, mw, mb)
loop
valid = -1
for b = 0 to 2*pi step 2*pi/3
x1 = r*cos(b) + sw/2
y1 = r*sin(b) + sh/2
dx = mx - x1
dy = my - y1
if dx*dx + dy*dy < rr*rr then
valid = 0
exit for
end if
next
if valid then
sx = mx
sy = my
end if
end if
if mx<>old_mx or my<>old_my or mw<>old_mw then
screenlock
line (0,0)-(sw,sh), rgb(0,0,0), bf
locate 1,1: ? mx, my, mw, mb
for b = 0 to 2*pi step 2*pi/3
circle (r*cos(b) + sw/2, r*sin(b) + sh/2), rr
next
a = atan2(my - sy, mx - sx)
x0 = sx
y0 = sy
for t = 0 to 1000
x = t*cos(a) + x0
y = t*sin(a) + y0
for b = 0 to 2*pi step 2*pi/3
if x >= 0 and x < sw and y >=0 and y < sh then
x1 = r*cos(b) + sw/2
y1 = r*sin(b) + sh/2
dx = x - x1
dy = y - y1
if dx*dx + dy*dy < rr*rr then
a1 = atan2(dy, dx)
a2 = 2*a1 - a - pi
line (x0, y0)-(x, y), rgb(233,205,89)
x0 = x
y0 = y
a = a2
t = 0
exit for
end if
end if
next
next
line (x0, y0)-(x, y), rgb(233,205,89)
screenunlock
screensync
end if
old_mx = mx
old_my = my
old_mw = mw
loop until inkey = chr(27)
system

BIN
samples/circle-intersecting-circle/img/circleintersectcircle.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 5.9 KiB

22
samples/circle-intersecting-circle/index.md Normal file
View file

@ -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: CIRCLE INTERSECTING CIRCLE
![circleintersectcircle.png](img/circleintersectcircle.png)
### Authors
[🐝 bplus](../bplus.md) [🐝 STxAxTIC](../stxaxtic.md)
### Description
Here we present two (equivalent) methods for calculating the intersection points between any two circles.
### File(s)
* [circleintersectcircle.bas](src/circleintersectcircle.bas)
🔗 [geometry](../geometry.md), [intersections](../intersections.md)
<sub>Reference: [qb64.org Forum](https://qb64forum.alephc.xyz/index.php?topic=2299.0) </sub>

75
samples/circle-intersecting-circle/src/circleintersectcircle.bas Normal file
View file

@ -0,0 +1,75 @@
SCREEN 12
C1x = -100
C1y = 50
C2x = 100
C2y = 100
r1 = 150
r2 = 100
DO
DO WHILE _MOUSEINPUT
IF _MOUSEBUTTON(1) THEN
C2x = _MOUSEX - 320
C2y = 240 - _MOUSEY
END IF
IF _MOUSEBUTTON(2) THEN
C1x = _MOUSEX - 320
C1y = 240 - _MOUSEY
END IF
LOOP
CLS
CIRCLE (320 + C1x, C1y * -1 + 240), r1, 8
CIRCLE (320 + C2x, C2y * -1 + 240), r2, 7
''' Toggle between the two functions here.
CALL IntersectTwoCircles(C1x, C1y, r1, C2x, C2y, r2, i1x, i1y, i2x, i2y)
'CALL intersect2circs(C1x, C1y, r1, C2x, C2y, r2, i1x, i1y, i2x, i2y)
'''
LOCATE 1, 1: PRINT i1x, i1y, i2x, i2y
IF (i1x OR i1y OR i2x OR i2y) THEN
CIRCLE (320 + i1x, i1y * -1 + 240), 3, 14
CIRCLE (320 + i2x, i2y * -1 + 240), 3, 15
END IF
_DISPLAY
_LIMIT 30
LOOP
SUB IntersectTwoCircles (c1x, c1y, r1, c2x, c2y, r2, i1x, i1y, i2x, i2y)
i1x = 0: i1y = 0: i2x = 0: i2y = 0
Dx = c1x - c2x
Dy = c1y - c2y
D2 = Dx ^ 2 + Dy ^ 2
IF (D2 ^ .5 < (r1 + r2)) THEN
F = (-D2 + r2 ^ 2 - r1 ^ 2) / (2 * r1)
a = Dx / F
b = Dy / F
g = a ^ 2 + b ^ 2
IF (g > 1) THEN
h = SQR(g - 1)
i1x = c1x + r1 * (a + b * h) / g
i1y = c1y + r1 * (b - a * h) / g
i2x = c1x + r1 * (a - b * h) / g
i2y = c1y + r1 * (b + a * h) / g
END IF
END IF
END SUB
SUB intersect2circs (c1x, c1y, r1, c2x, c2y, r2, i1x, i1y, i2x, i2y)
d = ((c1x - c2x) ^ 2 + (c1y - c2y) ^ 2) ^ .5
alpha = _ACOS((r1 ^ 2 + d ^ 2 - r2 ^ 2) / (2 * r1 * d))
x1 = r1 * COS(alpha)
l = r1 * SIN(alpha)
angle = _ATAN2(c2y - c1y, c2x - c1x)
p3x = c1x + x1 * COS(angle)
p3y = c1y + x1 * SIN(angle)
i1x = p3x + l * COS(angle - _PI / 2)
i1y = p3y + l * SIN(angle - _PI / 2)
i2x = p3x + l * COS(angle + _PI / 2)
i2y = p3y + l * SIN(angle + _PI / 2)
END SUB

BIN
samples/circle-intersecting-line/img/circleintersectline.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 8.7 KiB

22
samples/circle-intersecting-line/index.md Normal file
View file

@ -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: CIRCLE INTERSECTING LINE
![circleintersectline.png](img/circleintersectline.png)
### Author
[🐝 bplus](../bplus.md)
### Description
This is an interactive (mouse-driven) demo that calculates the intersection of any line with any circle.
### File(s)
* [circle-intersect-line.bas](src/circle-intersect-line.bas)
🔗 [geometry](../geometry.md), [intersections](../intersections.md)
<sub>Reference: [qb64.org Forum](https://qb64forum.alephc.xyz/index.php?topic=2301.0) </sub>

122
samples/circle-intersecting-line/src/circle-intersect-line.bas Normal file
View file

@ -0,0 +1,122 @@
_TITLE "Circle Intersect Line" ' b+ 2020-01-31 develop
' Find point on line perpendicular to line at another point" 'B+ 2019-12-15
' further for a Line and Circle Intersect, making full use of the information from the link below.
CONST xmax = 800, ymax = 600
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 300, 40
DO
CLS
IF testTangent = 0 THEN 'test plug in set of border conditions not easy to click
PRINT "First set here is a plug in test set for vertical lines."
mx(1) = 200: my(1) = 100: mx(2) = 200: my(2) = 400 'line x = 200
mx(3) = 400: my(3) = 300: mx(4) = 150: my(4) = 300 ' circle origin (center 400, 300) then radius test 200 tangent, 150 more than tangent, 250 short
FOR i = 1 TO 4
CIRCLE (mx(i), my(i)), 2
NEXT
IF mx(1) <> mx(2) THEN
slopeYintersect mx(1), my(1), mx(2), my(2), m, Y0 ' Y0 otherwise know as y Intersect
LINE (0, Y0)-(xmax, m * xmax + Y0), &HFF0000FF
LINE (mx(1), my(1))-(mx(2), my(2))
ELSE
LINE (mx(1), 0)-(mx(1), ymax), &HFF0000FF
LINE (mx(1), my(1))-(mx(2), my(2))
END IF
testTangent = 1
ELSE
PRINT "First 2 clicks will form a line, 3rd the circle origin and 4th the circle radius:"
WHILE pi < 4 'get 4 mouse clicks
_PRINTSTRING (20, 20), SPACE$(20)
_PRINTSTRING (20, 20), "Need 4 clicks, have" + STR$(pi)
WHILE _MOUSEINPUT: WEND
IF _MOUSEBUTTON(1) AND oldMouse = 0 THEN 'new mouse down
pi = pi + 1
mx(pi) = _MOUSEX: my(pi) = _MOUSEY
CIRCLE (mx(pi), my(pi)), 2
IF pi = 2 THEN 'draw first line segment then line
IF mx(1) <> mx(2) THEN
slopeYintersect mx(1), my(1), mx(2), my(2), m, Y0 ' Y0 otherwise know as y Intersect
LINE (0, Y0)-(xmax, m * xmax + Y0), &HFF0000FF
LINE (mx(1), my(1))-(mx(2), my(2))
ELSE
LINE (mx(1), 0)-(mx(1), ymax), &HFF0000FF
LINE (mx(1), my(1))-(mx(2), my(2))
END IF
END IF
END IF
oldMouse = _MOUSEBUTTON(1)
_DISPLAY
_LIMIT 60
WEND
END IF
p = mx(3): q = my(3)
r = SQR((mx(3) - mx(4)) ^ 2 + (my(3) - my(4)) ^ 2)
CIRCLE (p, q), r, &HFFFF0000
IF mx(1) = mx(2) THEN 'line is vertical so if r =
IF r = ABS(mx(1) - mx(3)) THEN ' one point tangent intersect
PRINT "Tangent point is "; TS$(mx(1)); ", "; TS$(my(3))
CIRCLE (mx(1), my(3)), 2, &HFFFFFF00
CIRCLE (mx(1), my(3)), 4, &HFFFFFF00
ELSEIF r < ABS(mx(1) - mx(3)) THEN 'no intersect
PRINT "No intersect, radius too small."
ELSE '2 point intersect
ydist = SQR(r ^ 2 - (mx(1) - mx(3)) ^ 2)
y1 = my(3) + ydist
y2 = my(3) - ydist
PRINT "2 Point intersect (x1, y1) = "; TS$(mx(1)); ", "; TS$(y1); " (x2, y2) = "; TS$(mx(1)); ", "; TS$(y2)
CIRCLE (mx(1), y1), 2, &HFFFFFF00 'marking intersect points yellow
CIRCLE (mx(1), y2), 2, &HFFFFFF00
CIRCLE (mx(1), y1), 4, &HFFFFFF00 'marking intersect points yellow
CIRCLE (mx(1), y2), 4, &HFFFFFF00
END IF
ELSE
'OK the calculations!
'from inserting eq ofline into eq of circle where line intersects circle see reference
' https://math.stackexchange.com/questions/228841/how-do-i-calculate-the-intersections-of-a-straight-line-and-a-circle
A = m ^ 2 + 1
B = 2 * (m * Y0 - m * q - p)
C = q ^ 2 - r ^ 2 + p ^ 2 - 2 * Y0 * q + Y0 ^ 2
D = B ^ 2 - 4 * A * C 'telling part of Quadratic formula = 0 then circle is tangent or > 0 then 2 intersect points
IF D < 0 THEN ' no intersection
PRINT "m, y0 "; TS$(m); ", "; TS$(Y0)
PRINT "(p, q) "; TS$(p); ", "; TS$(q)
PRINT "A: "; TS$(A)
PRINT "B: "; TS$(B)
PRINT "C: "; TS$(C)
PRINT "D: "; TS$(D); " negative so no intersect."
ELSEIF D = 0 THEN ' one point tangent
x1 = (-B + SQR(D)) / (2 * A)
y1 = m * x1 + Y0
PRINT "Tangent Point Intersect (x1, y1) = "; TS$(x1); ", "; TS$(y1)
CIRCLE (x1, y1), 2, &HFFFFFF00 'yellow circle should be on line perprendicular to 3rd click point
CIRCLE (x1, y1), 4, &HFFFFFF00 'yellow circle should be on line perprendicular to 3rd click point
ELSE
'2 points
x1 = (-B + SQR(D)) / (2 * A): y1 = m * x1 + Y0
x2 = (-B - SQR(D)) / (2 * A): y2 = m * x2 + Y0
PRINT "2 Point intersect (x1, y1) = "; TS$(x1); ", "; TS$(y1); " (x2, y2) = "; TS$(x2); ", "; TS$(y2)
CIRCLE (x1, y1), 2, &HFFFFFF00 'marking intersect points yellow
CIRCLE (x2, y2), 2, &HFFFFFF00
CIRCLE (x1, y1), 4, &HFFFFFF00 'marking intersect points yellow
CIRCLE (x2, y2), 4, &HFFFFFF00
END IF
END IF
_DISPLAY
INPUT "press enter to continue, any + enter to quit "; q$
IF LEN(q$) THEN SYSTEM
pi = 0 'point index
LOOP UNTIL _KEYDOWN(27)
SUB slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) ' fix for when x1 = x2
slope = (Y2 - Y1) / (X2 - X1)
Yintercept = slope * (0 - X1) + Y1
END SUB
FUNCTION TS$ (n)
TS$ = _TRIM$(STR$(n))
END FUNCTION

BIN
samples/colliding-ball-simulation/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 6.4 KiB

19
samples/colliding-ball-simulation/index.md Normal file
View file

@ -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: COLLIDING BALL SIMULATION
![screenshot.png](img/screenshot.png)
### Author
[🐝 Timothy Baxendale](../timothy-baxendale.md)
### Description
Realistic collisions between sphreres in two dimensions.
### File(s)
* [ball.bas](src/ball.bas)
🔗 [physics](../physics.md), [collisions](../collisions.md)

705
samples/colliding-ball-simulation/src/ball.bas Normal file
View file

@ -0,0 +1,705 @@
Type BALL
X As Double
Y As Double
U As Double
V As Double
XA As Double
YA As Double
End Type
Dim Shared nBall As Integer
Dim Shared balls(20) As BALL
Dim Shared dt As Double
Dim Shared radius As Integer
Dim Shared diam As Integer
Dim Shared elastic As Double
Dim Shared fric As _Float
Dim Shared isCollision As Integer
Dim Shared grav As _Float
Dim Shared attract As _Float
Dim Shared bg As Integer
Dim Shared fg As Integer
Dim Shared dela As Integer
Dim Shared gw As Integer
Dim Shared gh As Integer
Dim Shared sBall As Integer
Dim Shared isStart As Integer
gw = 640
gh = 480
radius = 15
diam = 2 * radius
dt = 1
nBall = 10
elastic = 1
fric = 0
grav = 0
attract = 0
isCollision = 0
bg = 1
fg = 15
dela = 0
sBall = 1
isStart = 1
SETUP
Screen 12
Paint (0, 0), bg
Line (0, gh + 1)-(gw, gh + 1), 0
Paint (0, gh + 2), 0
While 1
For i% = 1 To nBall
Circle (balls(i%).X, balls(i%).Y), radius, bg
REDRAW i%
If i% = sBall Then
Circle (balls(i%).X, balls(i%).Y), radius, 0
Else
Circle (balls(i%).X, balls(i%).Y), radius, fg
End If
Next
k$ = InKey$
Select Case k$
Case Chr$(27)
Cls
SETUP
Screen 12
Paint (0, 0), bg
Line (0, gh + 1)-(gw, gh + 1), 0
Paint (0, gh + 2), 0
Case "=", "+"
sBall = sBall + 1
If sBall > nBall Then sBall = 1
Case "-"
sBall = sBall - 1
If sBall < 1 Then sBall = nBall
Case " "
While InKey$ <> " ": Wend
Case Chr$(13)
balls(sBall).U = 0
balls(sBall).V = 0
Case Chr$(0) + "P"
balls(sBall).V = balls(sBall).V + 1
Case Chr$(0) + "H"
balls(sBall).V = balls(sBall).V - 1
Case Chr$(0) + "M"
balls(sBall).U = balls(sBall).U + 1
Case Chr$(0) + "K"
balls(sBall).U = balls(sBall).U - 1
End Select
_Limit 60
Wend
Sub ATTRACTION (i%)
If attract <> 0 Then
For j% = i% + 1 To nBall
xm = balls(j%).X - balls(i%).X
ym = balls(j%).Y - balls(i%).Y
dist = xm ^ 2 + ym ^ 2
If dist < (radius ^ 2) Then dist = radius ^ 2
balls(i%).U = attract * xm / dist + balls(i%).U
balls(i%).V = attract * ym / dist + balls(i%).V
balls(j%).U = attract * xm / dist + balls(j%).U
balls(j%).V = -attract * ym / dist + balls(j%).V
Next
End If
End Sub
Sub ChangeValue (selected, k$)
Select Case selected
Case 0
sBall = nBall
If k$ = Chr$(0) + "M" Then
nBall = nBall + 1
If nBall > 20 Then nBall = 1
End If
If k$ = Chr$(0) + "K" Then
nBall = nBall - 1
If nBall < 1 Then nBall = 20
End If
If nBall > 9 Then
Locate 8, 50
Else
Locate 8, 51
End If
Print nBall
If nBall <> sBall Then
Color 8, 1
Locate 16, 25
Print "{R} TO RESUME SIMULATION"
Color 15, 1
isStart = 1
End If
Case 8
If k$ = Chr$(0) + "M" Then
elastic = elastic + .1
If elastic >= 10 Then elastic = .1
End If
If k$ = Chr$(0) + "K" Then
elastic = elastic - .1
If elastic < -9.99 Then elastic = 9.9
End If
Locate 9, 46
Print " "
Locate 9, 50
If elastic >= 1 Then Locate 9, 49
Print elastic
Case 1
If k$ = Chr$(0) + "M" Then
elastic = elastic + .1
If elastic > 9.91 Then elastic = .1
End If
If k$ = Chr$(0) + "K" Then
elastic = elastic - .1
If elastic < .09 Then elastic = 9.91
End If
iattract% = (elastic - Int(elastic)) * 10
If iattract% > 9 Then
Locate 9, 50
Print iattract%
Locate 9, 50
Else
Locate 9, 51
Print iattract%
Locate 9, 51
End If
Locate 9, 49
Print Int(elastic)
Locate 9, 51
Print "."
Case 2
If k$ = Chr$(0) + "M" Then
fric = fric + .001
If fric >= 1 Then fric = -1
End If
If k$ = Chr$(0) + "K" Then
fric = fric - .001
If fric <= -1 Then fric = 1
End If
Locate 10, 46
Print " "
Locate 10, 48
If fric = 0 Then Locate 10, 51
Print fric
Case 9
If k$ = Chr$(0) + "M" Then
fric = fric + .001
If fric > .099 Then fric = 0
End If
If k$ = Chr$(0) + "K" Then
fric = fric - .001
If fric < 0 Then fric = .099
End If
ifric% = fric * 1000
If ifric% > 9 Then
Locate 10, 50
Print ifric%
Locate 10, 50
Print "0"
Else
Locate 10, 51
Print ifric%
Locate 10, 51
Print "0"
End If
Case 3
If k$ = Chr$(0) + "M" Then
grav = grav + .001
If grav >= 1 Then grav = -1
End If
If k$ = Chr$(0) + "K" Then
grav = grav - .001
If grav <= -1 Then grav = 1
End If
Locate 11, 46
Print " "
Locate 11, 48
If grav = 0 Then Locate 11, 51
Print grav
Case 10
If k$ = Chr$(0) + "M" Then
grav = grav + .001
If grav > .099 Then grav = 0
End If
If k$ = Chr$(0) + "K" Then
grav = grav - .001
If grav < 0 Then grav = .099
End If
igrav% = grav * 1000
If igrav% > 9 Then
Locate 11, 50
Print igrav%
Locate 11, 50
Print "0"
Else
Locate 11, 51
Print igrav%
Locate 11, 51
Print "0"
End If
Case 4
If k$ = Chr$(0) + "M" Then
attract = attract + .01
If attract >= 10 Then attract = -9.99
End If
If k$ = Chr$(0) + "K" Then
attract = attract - .01
If attract < -9.99 Then attract = 9.99
End If
Locate 12, 48
Print " "
Locate 12, 49
If attract = 0 Then Locate 12, 51
If attract >= 1 Or attract <= -1 Then Locate 12, 48
Print attract
Case 7
If k$ = Chr$(0) + "M" Then
attract = attract + .01
If attract >= 10 Then attract = -9.99
End If
If k$ = Chr$(0) + "K" Then
attract = attract - .01
If attract < -9.99 Then attract = 9.99
End If
iattract% = Int((attract - Int(attract)) * 100)
If iattract% > 9 Then
Locate 12, 50
Print iattract%
Else
Locate 12, 51
Print iattract%
Locate 12, 51
Print "0"
End If
Locate 12, 48
Print Int(attract)
Locate 12, 50
Print "."
Case 5
If k$ = Chr$(0) + "M" Then
dt = dt + .1
If dt > 9.9 Then dt = .1
End If
If k$ = Chr$(0) + "K" Then
dt = dt - .1
If dt <= 0 Then dt = 9.9
End If
iattract% = dt * 10
If iattract% > 9 Then
Locate 13, 50
Print iattract%
Locate 13, 50
Else
Locate 13, 51
Print iattract%
Locate 13, 51
End If
Locate 13, 49
Print Int(dt)
Locate 13, 51
Print "."
Case 6
If k$ = Chr$(0) + "M" Then
dela = dela + 1
If dela > 9 Then dela = 0
End If
If k$ = Chr$(0) + "K" Then
dela = dela - 1
If dela < 0 Then dela = 9
End If
If dela > 9 Then
Locate 14, 50
Print dela
Else
Locate 14, 51
Print dela
End If
End Select
End Sub
Sub COLLISION (i%)
For j% = i% + 1 To nBall
xi = balls(i%).X
yi = balls(i%).Y
xj = balls(j%).X
yj = balls(j%).Y
dx = xi - xj
dy = yi - yj
dist = Sqr(dx ^ 2 + dy ^ 2)
If (dist < diam) Then
isCollision = 1
Circle (balls(i%).X, balls(i%).Y), radius, bg
Circle (balls(j%).X, balls(j%).Y), radius, bg
ui = balls(i%).U
vi = balls(i%).V
uj = balls(j%).U
vj = balls(j%).V
CoefA = (ui - uj) ^ 2 + (vi - vj) ^ 2
CoefB = 2 * ((ui - uj) * (xi - xj) + (vi - vj) * (yi - yj))
CoefC = (xi - xj) ^ 2 + (yi - yj) ^ 2 - diam ^ 2
If (CoefA = 0) Then
t = -CoefC / CoefB
Else
If (dt >= 0) Then
t = (-CoefB - Sqr(CoefB ^ 2 - 4 * CoefA * CoefC)) / (2 * CoefA)
Else
t = (-CoefB + Sqr(CoefB ^ 2 - 4 * CoefA * CoefC)) / (2 * CoefA)
End If
End If
xi = xi + t * ui
yi = yi + t * vi
xj = xj + t * uj
yj = yj + t * vj
mx = (ui + uj) / 2
my = (vi + vj) / 2
ui = ui - mx
vi = vi - my
uj = uj - mx
vj = vj - my
dx = xi - xj
dy = yi - yj
dist = Sqr(dx ^ 2 + dy ^ 2)
dx = dx / dist
dy = dy / dist
foo = -(dx * ui + dy * vi)
ui = ui + 2 * foo * dx
vi = vi + 2 * foo * dy
bar = -(dx * uj + dy * vj)
uj = uj + 2 * bar * dx
vj = vj + 2 * bar * dy
e = Sqr(elastic)
ui = e * (ui + mx)
vi = e * (vi + my)
uj = e * (uj + mx)
vj = e * (vj + my)
xi = xi - t * ui
yi = yi - t * vi
xj = xj - t * uj
yj = yj - t * vj
balls(i%).U = ui
balls(i%).V = vi
balls(j%).U = uj
balls(j%).V = vj
balls(i%).X = xi
balls(i%).Y = yi
balls(j%).X = xj
balls(j%).Y = yj
End If
Next
End Sub
Sub CreateFancyBox ()
Color 15, 1
Locate 3, 23
Print Chr$(201)
Locate 18, 23
Print Chr$(200)
Locate 18, 56
Print Chr$(188)
Locate 3, 56
Print Chr$(187)
Color 1, 0
For i% = 0 To 13
For j% = 0 To 32
Locate 4 + i%, 24 + j%
Print Chr$(219)
Next
Next
Color 15, 1
For i% = 0 To 31
Locate 3, 24 + i%
Print Chr$(205)
Locate 18, 24 + i%
Print Chr$(205)
Next
For i% = 0 To 13
Locate 4 + i%, 23
Print Chr$(186)
Locate 4 + i%, 56
Print Chr$(186)
Next
End Sub
Sub CreateOtherFancyBox ()
Color 2, 0
For i% = 0 To 3
For j% = 0 To 43
Locate 20 + i%, 18 + j%
Print Chr$(219)
Next
Next
Color 15, 2
For i% = 0 To 41
Locate 20, 19 + i%
Print Chr$(205)
Locate 23, 19 + i%
Print Chr$(205)
Next
For i% = 0 To 1
Locate 21 + i%, 18
Print Chr$(186)
Locate 21 + i%, 61
Print Chr$(186)
Next
Locate 20, 18
Print Chr$(201)
Locate 23, 18
Print Chr$(200)
Locate 23, 61
Print Chr$(188)
Locate 20, 61
Print Chr$(187)
Locate 21, 20
Print "CHANGE SELECTED: +/-"
Locate 21, 46
Print "STOP: {ENTER}"
Locate 22, 46
Print "PAUSE: {SPACE}"
Locate 22, 20
Print "CHANGE VELOCITY:"
For i% = 0 To 1
Locate 22, 37 + (2 * i%)
Print Chr$(24 + i%)
Next
For i% = 1 To 0 Step -1
Locate 22, 43 - (2 * i%)
Print Chr$(26 + i%)
Next
Color 15, 1
End Sub
Sub delay (ticks%)
For i% = 1 To ticks%
st# = Timer
While Timer = st#: Wend
Next i%
End Sub
Sub GRAVITY (i%)
U = balls(i%).U
V = balls(i%).V
fricscale = (1 - fric / Sqr(1 + U ^ 2 + V ^ 2))
balls(i%).U = fricscale * U
balls(i%).V = fricscale * V + grav
End Sub
Sub PAUSE ()
While InKey$ = "": Wend
End Sub
Function Rand% (Bottom As Integer, Top As Integer)
Randomize Timer
Randomize Rnd
Rand% = Int((Top - Bottom + 1) * Rnd + Bottom)
End Function
Sub REDRAW (i%)
balls(i%).X = balls(i%).X + (balls(i%).U * dt)
balls(i%).Y = balls(i%).Y + (balls(i%).V * dt)
X = balls(i%).X
Y = balls(i%).Y
If X < radius Then
balls(i%).U = -balls(i%).U
balls(i%).X = radius
End If
If X > (gw - radius) Then
balls(i%).U = -balls(i%).U
balls(i%).X = (gw - radius)
End If
If Y < radius Then
balls(i%).V = -balls(i%).V
balls(i%).Y = radius
End If
If Y > (gh - radius) Then
balls(i%).V = -balls(i%).V
balls(i%).Y = gh - radius
End If
COLLISION i%
GRAVITY i%
ATTRACTION i%
End Sub
Sub SETUP ()
Screen 0
Cls
'LOCATE 1, 1
'PRINT sBall
CreateFancyBox
CreateOtherFancyBox
Locate 4, 28
Print "COLLIDING BALL SIMULATION"
Locate 5, 31
Print "Copyright (c) 2013"
Locate 6, 32
Print "Timothy Baxendale"
Locate 8, 25
Print "NUMBER OF BALLS"
Color 6, 1
Locate 8, 45
Print Chr$(17)
Color 15, 1
Locate 9, 25
Print "ELASTIC"
Locate 9, 45
Print Chr$(17)
Locate 10, 25
Print "FRICTION"
Locate 10, 45
Print Chr$(17)
Locate 11, 25
Print "GRAVITY"
Locate 11, 45
Print Chr$(17)
Locate 12, 25
Print "ATTRACTION"
Locate 12, 45
Print Chr$(17)
Locate 13, 25
Print "SPEED"
Locate 13, 45
Print Chr$(17)
ChangeValue 0, ""
Locate 10, 48
Print "0.000"
ChangeValue 1, ""
Locate 11, 48
Print "0.000"
ChangeValue 2, ""
ChangeValue 3, ""
ChangeValue 4, ""
ChangeValue 5, ""
Locate 15, 25
Print "{ENTER} TO RUN SIMULATION"
If isStart = 1 Then Color 8, 1
Locate 16, 25
Print "{R} TO RESUME SIMULATION"
If isStart = 1 Then Color 15, 1
Locate 17, 25
Print "{ESC} TO EXIT"
Color 6, 1
Locate 8, 54
Print Chr$(16)
Color 15, 1
Locate 9, 54
Print Chr$(16)
Locate 10, 54
Print Chr$(16)
Locate 11, 54
Print Chr$(16)
Locate 12, 54
Print Chr$(16)
Locate 13, 54
Print Chr$(16)
selected = 0
While 1
k$ = InKey$
Select Case k$
Case Chr$(27)
Color 7, 0
Cls
End
Case Chr$(0) + "P"
Locate 8 + selected, 54
Print Chr$(16)
Locate 8 + selected, 45
Print Chr$(17)
selected = selected + 1
If selected > 5 Then selected = 0
Color 6, 1
Locate 8 + selected, 54
Print Chr$(16)
Locate 8 + selected, 45
Print Chr$(17)
Color 15, 1
Case Chr$(0) + "H"
Locate 8 + selected, 54
Print Chr$(16)
Locate 8 + selected, 45
Print Chr$(17)
selected = selected - 1
If selected < 0 Then selected = 5
Color 6, 1
Locate 8 + selected, 54
Print Chr$(16)
Locate 8 + selected, 45
Print Chr$(17)
Color 15, 1
Case Chr$(0) + "K"
ChangeValue selected, k$
Case Chr$(0) + "M"
ChangeValue selected, k$
Case Chr$(13)
r = 0
isStart = 0
GoTo START
Case "r", "R"
If isStart = 0 Then
r = 1
GoTo START
End If
End Select
Wend
START:
If r = 0 Then
sBall = 1
For i% = 1 To nBall
balls(i%).X = Rand(1, gw)
balls(i%).Y = Rand(1, gh)
balls(i%).U = Rand(1, 500) / 100 - 3
balls(i%).V = Rand(1, 500) / 100 - 3
Next
End If
End Sub

BIN
samples/connect-circles/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 46 KiB

19
samples/connect-circles/index.md Normal file
View file

@ -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: CONNECT CIRCLES
![screenshot.png](img/screenshot.png)
### Author
[🐝 bplus](../bplus.md)
### Description
Created by QB64 community member bplus.
### File(s)
* [connectcircles.bas](src/connectcircles.bas)
🔗 [screensaver](../screensaver.md), [mosaic](../mosaic.md)

51
samples/connect-circles/src/connectcircles.bas Normal file
View file

@ -0,0 +1,51 @@
' Created by QB64 community member bplus
$NoPrefix
Option Explicit
Option ExplicitArray
Const xmax = 600 ' not working!!!
Const ymax = 600
Dim As Integer i, j, s, sq
Dim As Double x, y, c, d
Dim As Unsigned Long cc
Screen NewImage(xmax, ymax, 32)
Title "Connect Circles"
s = 1
sq = 5
Do
For j = 0 To ymax / sq
For i = 0 To xmax / sq
x = i * s / 600
y = j * s / 600
c = x * x + y * y
d = c / 2
d = d - Int(d)
d = Int(d * 1000)
If d < 250 Then
cc = RGB32(d, 0, 0)
ElseIf d < 500 Then
cc = RGB32(0, d - 250, 0)
ElseIf d < 750 Then
cc = RGB32(0, 0, d - 500)
Else
cc = RGB32(255, 255, 255)
End If
Line (i * sq, j * sq)-Step(sq, sq), cc, BF
Next
Next
Delay 0.5
'Color RGB32(255, 255, 255)
'Locate 1, 1
'Print s
s = s + 15
If s > 1000 Then
s = 1
End If
Loop While Len(InKey$) = 0
System 0

BIN
samples/convert-bmp-to-dominoes/img/output.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 16 KiB

24
samples/convert-bmp-to-dominoes/index.md Normal file
View file

@ -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: CONVERT BMP TO DOMINOES
![output.png](img/output.png)
### Author
[🐝 Richard Frost](../richard-frost.md)
### Description
[This] is an image converter that takes a picture a small block at a time and finds the "best fit" domino for that space. (The woman is Heather Thomas.)
### File(s)
* [bmp2dominoes.bas](src/bmp2dominoes.bas)
* [convert-bmp-to-dominoes.zip](src/convert-bmp-to-dominoes.zip)
* [heath.bmp](src/heath.bmp)
🔗 [image processing](../image-processing.md)
<sub>Reference: [qb64.org Forum](https://qb64forum.alephc.xyz/index.php?topic=4211.0) </sub>

122
samples/convert-bmp-to-dominoes/src/bmp2dominoes.bas Normal file
View file

@ -0,0 +1,122 @@
' The woman is Heather Thomas
DEFINT A-Z
SCREEN 12
DIM dots(7), x(7, 7), y(7, 7), c1(7), c2(28), pixel(7, 7), w(3), y$(30)
cps! = 12.83 ' cost per set
FOR i = 1 TO 28: READ y$(i): NEXT i
FOR n = 1 TO 7
READ dots(n)
FOR dot = 1 TO dots(n)
READ x(n, dot), y(n, dot)
NEXT dot
NEXT n
xb = 10: xe = 350 ' x begin and end
yb = 0: ye = 470 ' y begin and end
OPEN "heath.bmp" FOR RANDOM AS #1 LEN = 1: FIELD #1, 1 AS t$
FOR y1 = yb TO ye STEP 8
FOR x1 = xb TO xe STEP 8
n = 0
FOR y2 = 0 TO 7
FOR x2 = 0 TO 7
x3 = x1 + x2
y3 = y1 + y2
r& = CDBL(479 - y3) * 640 + x3 + 441
GET #1, r&
d = ASC(t$) \ 13
IF d > 15 THEN d = 15
pixel(x2, y2) = -(d > 7) ' for 3 problem
n = n + d
NEXT x2
NEXT y2
n = n / 155 ' 175
IF n > 6 THEN n = 6
x$ = x$ + CHR$(48 + n) ' for counting tiles used
IF LEN(x$) = 2 THEN ' got left & right
FOR i = 1 TO 28
IF x$ = y$(i) THEN c2(i) = c2(i) + 1: EXIT FOR
NEXT i
x$ = ""
END IF
IF n = 3 THEN ' default bottom left - top right
IF (l = 3) OR (l = 7) THEN ' can't change direction if the
n = l ' last piece was also a 3
ELSE
FOR zi = 0 TO 3
w(zi) = 0
NEXT zi
FOR y2 = 0 TO 7
FOR x2 = 0 TO 7
xi = x2 \ 4 ' 0 or 1
yi = y2 \ 4 ' 0 or 1
zi = xi * 2 + yi ' 0-3
' LOCATE zi + 1, 1: PRINT zi;
w(zi) = w(zi) + pixel(x2, y2)
NEXT x2
NEXT y2
IF (w(1) + w(2)) > (w(0) + w(3)) THEN n = 7
END IF
END IF
l = n ' save last used (for 3)
d = dots(n)
c1(n) = c1(n) + 1
FOR dot = 1 TO d
tx = (x1 + 4) + x(n, dot) * 2 - xb
ty = (y1 + 4) + y(n, dot) * 2 - yb
PSET (tx, ty), 15
NEXT dot
IF INKEY$ = CHR$(27) THEN CLOSE: SCREEN 0, 0, 0, 0: END
nd = nd + 1
NEXT x1
GOSUB Status
NEXT y1
DO: _LIMIT 10
LOOP UNTIL LEN(INKEY$)
SYSTEM
Status:
FOR i = 0 TO 7
'COLOR i
LOCATE i + 2, 49: PRINT USING "####"; i; c1(i);
NEXT i
RESTORE count
FOR i = 1 TO 28
LOCATE i + 1, 60: PRINT " ";
LOCATE i + 1, 60
IF c2(i) >= max THEN
max = c2(i)
PRINT "*";
ELSE
PRINT " ";
END IF
PRINT y$(i);
PRINT USING " #### "; c2(i);
c! = c2(i) * cps!
c! = c! + c! * .07
PRINT USING "####.##"; c!;
NEXT i
xn = (xe - xb) / 16
yn = (ye - yb) / 8
LOCATE 27, 52: PRINT xn;
LOCATE 28, 52: PRINT yn;
LOCATE 29, 52: PRINT xn * yn;
RETURN
count:
DATA 00,01,02,03,04,05,06
DATA 11,12,13,14,15,16
DATA 22,23,24,25,26
DATA 33,34,35,36
DATA 44,45,46
DATA 55,56
DATA 66
dots:
DATA 1,0,0
DATA 2,0,-1,0,1
DATA 3,-1,-1,0,0,1,1
DATA 4,-1,1,-1,-1,1,-1,1,1
DATA 5,-1,1,-1,-1,1,-1,1,1,0,0
DATA 6,-1,1,-1,0,-1,-1,1,1,1,0,1,-1
DATA 3,1,-1,0,0,-1,1

BIN
samples/convert-bmp-to-dominoes/src/convert-bmp-to-dominoes.zip Normal file
View file

Binary file not shown.

BIN
samples/convert-bmp-to-dominoes/src/heath.bmp Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 301 KiB

BIN
samples/darokin/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 2.9 KiB

19
samples/darokin/index.md Normal file
View file

@ -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: DAROKIN
![screenshot.png](img/screenshot.png)
### Author
[🐝 darokin](../darokin.md)
### Description
Created by QB community member darokin.
### File(s)
* [darokin.bas](src/darokin.bas)
🔗 [screensaver](../screensaver.md), [starfield](../starfield.md)

104
samples/darokin/src/darokin.bas Normal file
View file

@ -0,0 +1,104 @@
'simple program in qbasic
'02/01/99
'if you want to tell me something on my prog or something else
'e mail me
'darokin@infonie.fr
'darokin use it free and learn (i know you can't learn
' whith this but if that could help
' someone ....)
'darokin '99
$NoPrefix
$Resize:Smooth
Screen 13
FullScreen SquarePixels , Smooth
etoile% = 150
Dim x%(1 To etoile%)
Dim y%(1 To etoile%)
Dim c%(1 To etoile%)
Dim v%(1 To etoile%)
For i% = 1 To etoile%
x%(i%) = Int(Rnd * 320)
y%(i%) = Int(Rnd * 129) + 40
c%(i%) = Int(Rnd * 15) + 15
v%(i%) = Int(Rnd * 3) + 2
Next i%
Dim txt(97)
Print "darokin"
Get (0, 0)-(54, 6), txt()
Cls
Dim balle(120)
Data 00,00,00,00,04,04,04,00,00,00,00
Data 00,00,04,04,04,04,04,04,04,00,00
Data 00,04,04,15,15,04,04,04,04,04,00
Data 00,04,04,15,15,04,04,04,04,04,00
Data 04,04,04,04,04,04,04,04,04,04,04
Data 04,04,04,04,04,04,04,04,04,04,04
Data 00,04,04,04,04,04,04,04,04,04,00
Data 00,04,04,04,04,04,04,04,04,04,00
Data 00,00,04,04,04,04,04,04,04,00,00
Data 00,00,00,00,04,04,04,00,00,00,00
xlenght = 11
ylenght = 10
For y% = 1 To ylenght
For x% = 1 To xlenght
Read z
PSet (x%, y%), z
Next x%
Next y%
x = 15: y = 55: xtxt = 35: ytxt = 3
xmax = 305: ymax = 160: xtxtmax = 200: ytxtmax = 15
a = 1: b = 1: c = 1: d = 1: e = 1
xmin = 5: ymin = 39: xtxtmin = 30: ytxtmin = 1
Get (0, 0)-(11, 10), balle()
Cls
Put (20, 5), txt()
Randomize Timer
Do
Put (x, y), balle()
For i% = 1 To etoile%
PSet (x%(i%), y%(i%)), c%(i%)
PSet (x%(i%), y%(i%)), 0
x%(i%) = x%(i%) + v%(i%)
If x%(i%) >= 320 Then
x%(i%) = 1
y%(i%) = Int(Rnd * 129) + 40
c%(i%) = Int(Rnd * 15) + 15
v%(i%) = Int(Rnd * 3) + 2
End If
PSet (x%(i%), y%(i%)), c%(i%)
Next i%
Put (xtxt, ytxt), txt()
If c = 1 Then Cls
c = c + 1
If xtxt < xtxtmin Then d = -d
If x < xmin Then a = -a
If xtxt > xtxtmax Then d = -d
If x > xmax Then a = -a
If ytxt < ytxtmin Then e = -e
If y < ymin Then b = -b
If ytxt > ytxtmax Then e = -e
If y > ymax Then b = -b
x = x + a
y = y + b
xtxt = xtxt + d
ytxt = ytxt + e
Put (x, y), balle()
Put (xtxt, ytxt), txt()
For i = 1 To 5000
Next i
Limit 60
Loop While InKey$ = ""
System 0

BIN
samples/dragon-warrior/img/dragon-warrior-64-gameplay1-screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 16 KiB

BIN
samples/dragon-warrior/img/dragon-warrior-64-gameplay2-screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 18 KiB

BIN
samples/dragon-warrior/img/dragon-warrior-64-title-screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 12 KiB

34
samples/dragon-warrior/index.md Normal file
View file

@ -0,0 +1,34 @@
[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md)
## SAMPLE: DRAGON WARRIOR 64
![dragon-warrior-64-gameplay1-screenshot.png](img/dragon-warrior-64-gameplay1-screenshot.png)
### Author
[🐝 Cobalt](../cobalt.md)
### Description
QB64 version of Nintendo Dragon Quest (Dragon Warrior). The time has come to go on your quest to find and defeat the evil DragonLord. I hope that you have fun playing this game.
DEFAULT Controls:
It does have a better feel when playing with a Joypad but it is not required.
Start button = A (upper case)
A Button = Space bar (accept selection)
B Button = Enter (cancel action\ selection)
Arrow keys for movement
### File(s)
* [dragon-warrior-2021-08-26.zip](src/dragon-warrior-2021-08-26.zip)
### Additional Image(s)
![dragon-warrior-64-gameplay2-screenshot.png](img/dragon-warrior-64-gameplay2-screenshot.png)
![dragon-warrior-64-title-screenshot.png](img/dragon-warrior-64-title-screenshot.png)
🔗 [game](../game.md), [rpg](../rpg.md)
<sub>Reference: [qb64.org Forum](https://qb64forum.alephc.xyz/index.php?topic=2695.0) </sub>

BIN
samples/dragon-warrior/src/dragon-warrior-2021-08-26.zip Normal file
View file

Binary file not shown.

BIN
samples/dropping-balls/img/droppingballs.jpg Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 72 KiB

22
samples/dropping-balls/index.md Normal file
View file

@ -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: DROPPING BALLS
![droppingballs.jpg](img/droppingballs.jpg)
### Author
[🐝 bplus](../bplus.md)
### Description
Dropping Balls an attempt to build a pile by adjusting drop rate, elasticity, and gravity.
### File(s)
* [droppingballs.bas](src/droppingballs.bas)
🔗 [gravity](../gravity.md), [collisions](../collisions.md)
<sub>Reference: [qb64.org Forum](https://www.qb64.org/forum/index.php?topic=194.0) </sub>

93
samples/dropping-balls/src/droppingballs.bas Normal file
View file

@ -0,0 +1,93 @@
_TITLE "Dropping Balls: Pile Attempt #3" ' bplus started 2018-04-03"
' Attempt to build a pile by adjusting drop rate, elasticity, and gravity.
' Built from Dropping balls 4 w snd and STATIC created 2018-04-3
' Add STATIC's ball moving before figuring any bounce from collision
' which was a mod in Dropping Balls 2 w sound posted 2018-03-31.
' 2020-03-04 Pile Attempt #3 revive and tidy up
RANDOMIZE TIMER
CONST xmax = 750, ymax = 720, elastic = .8, gravity = .75, balls = 400, br = 15
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 20
DIM x(balls), y(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)
FOR i = 1 TO balls 'initialize balls to drop
x(i) = xmax / 2 + (i MOD 2) * 8 - 4: y(i) = 0 ' location
dx(i) = 0: dy(i) = 3 ' change on axis
rr(i) = 150 + RND * 100: gg(i) = 150 + RND * 100: bb(i) = 150 + RND * 100 ' rgb color
NEXT
WHILE 1
CLS
loopCnt = loopCnt + 1 ' drop ball every 17 loops so previous ball is clear
IF loopCnt MOD 17 = 0 THEN
IF maxBall < balls THEN maxBall = maxBall + 1
END IF
_PRINTSTRING (100, 10), "Balls:" + STR$(maxBall)
FOR i = 1 TO maxBall
'ready for collision
dy(i) = dy(i) + gravity ' gravity increase update on y axis
a(i) = _ATAN2(dy(i), dx(i)) ' angle ball is heading
imoved = 0
FOR j = i + 1 TO maxBall
' The following is STxAxTIC's adjustment of ball positions if overlapping before
' calculation of new positions from collision. Displacement vector and its magnitude:
nx = x(j) - x(i): ny = y(j) - y(i)
nm = SQR(nx ^ 2 + ny ^ 2)
IF nm < 1 + 2 * br THEN
nx = nx / nm: ny = ny / nm
' Regardless of momentum exchange, separate balls along the line connecting them.
DO WHILE nm < 1 + 2 * br
flub = .001
x(j) = x(j) + flub * nx: y(j) = y(j) + flub * ny
x(i) = x(i) - flub * nx: y(i) = y(i) - flub * ny
nx = x(j) - x(i): ny = y(j) - y(i)
nm = SQR(nx ^ 2 + ny ^ 2)
nx = nx / nm: ny = ny / nm
LOOP
imoved = 1
a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5 ' update new dx, dy for i and j balls
power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
power = elastic * (power1 + power2) / 2
dx(i) = power * COS(a(i)): dy(i) = power * SIN(a(i))
dx(j) = power * COS(a(j)): dy(j) = power * SIN(a(j))
x(i) = x(i) + dx(i): y(i) = y(i) + dy(i)
x(j) = x(j) + dx(j): y(j) = y(j) + dy(j)
END IF ' Thanks STxAxTIC
NEXT
IF imoved = 0 THEN x(i) = x(i) + dx(i): y(i) = y(i) + dy(i)
IF x(i) - br < 0 OR x(i) + br > xmax THEN ' keep balls inside sides and bottom edge
dx(i) = -dx(i)
IF x(i) - br < 0 THEN x(i) = br
IF x(i) + br > xmax THEN x(i) = xmax - br
END IF
IF y(i) + br > ymax THEN y(i) = ymax - br: dy(i) = -dy(i) * elastic
FOR rad = br TO 1 STEP -1 ' finally draw the ball
fcirc x(i), y(i), rad, _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
NEXT
NEXT
_DISPLAY
_LIMIT 20
WEND
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG) ' SMcNeill's fill circle
DIM subRadius AS LONG, RadiusError AS LONG, X AS LONG, Y AS LONG
subRadius = ABS(R): RadiusError = -subRadius: X = subRadius: Y = 0
IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
LINE (CX - X, CY)-(CX + X, CY), C, BF
WHILE X > Y
RadiusError = RadiusError + Y * 2 + 1
IF RadiusError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
END IF
X = X - 1
RadiusError = RadiusError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
WEND
END SUB

BIN
samples/ellipse-intersecting-line/img/ellipse-intersect-line.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 6.7 KiB

22
samples/ellipse-intersecting-line/index.md Normal file
View file

@ -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: ELLIPSE INTERSECTING LINE
![ellipse-intersect-line.png](img/ellipse-intersect-line.png)
### Author
[🐝 STxAxTIC](../stxaxtic.md)
### Description
... all I could think is "why stop at circles when you can do ellipses?"
### File(s)
* [ellipse-intersect-line.bas](src/ellipse-intersect-line.bas)
🔗 [geometry](../geometry.md), [intersections](../intersections.md)
<sub>Reference: [qb64.org Forum](https://qb64forum.alephc.xyz/index.php?topic=2302.0) </sub>

149
samples/ellipse-intersecting-line/src/ellipse-intersect-line.bas Normal file
View file

@ -0,0 +1,149 @@
SCREEN 12
xorig = 0
yorig = 0
CALL cline(xorig, yorig, xorig + _WIDTH, yorig, 8)
CALL cline(xorig, yorig, xorig + -_WIDTH, yorig, 8)
CALL cline(xorig, yorig, xorig, yorig + _HEIGHT, 8)
CALL cline(xorig, yorig, xorig, yorig - _HEIGHT, 8)
xzoom = 20
yzoom = 20
' Initialize line
b = -2
d = 2
lineang = .1
vx = COS(lineang)
vy = SIN(lineang)
m = vy / vx
' Initialize ellipse
x0 = 2
y0 = -2
ellipsearg = .2
amag = 10
ax = amag * COS(ellipsearg)
ay = amag * SIN(ellipsearg)
bmag = 5
bx = bmag * COS(ellipsearg + 3.14 / 2)
by = bmag * SIN(ellipsearg + 3.14 / 2)
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 = _MOUSEX
y = _MOUSEY
x0 = (x - _WIDTH / 2) / xzoom
y0 = (-y + _HEIGHT / 2) / yzoom
END IF
IF _MOUSEBUTTON(2) THEN
x = _MOUSEX
y = _MOUSEY
d = (x - _WIDTH / 2) / xzoom
b = (-y + _HEIGHT / 2) / yzoom
END IF
IF _MOUSEWHEEL > 0 THEN
lineang = lineang + .01
vx = COS(lineang)
vy = SIN(lineang)
m = vy / vx
END IF
IF _MOUSEWHEEL < 0 THEN
lineang = lineang - .01
vx = COS(lineang)
vy = SIN(lineang)
m = vy / vx
END IF
END IF
LOOP
SELECT CASE _KEYHIT
CASE 18432
bmag = bmag + .1
bx = bmag * COS(ellipsearg + 3.14 / 2)
by = bmag * SIN(ellipsearg + 3.14 / 2)
CASE 20480
bmag = bmag - .1
bx = bmag * COS(ellipsearg + 3.14 / 2)
by = bmag * SIN(ellipsearg + 3.14 / 2)
CASE 19200
ellipsearg = ellipsearg - .1
ax = amag * COS(ellipsearg)
ay = amag * SIN(ellipsearg)
bx = bmag * COS(ellipsearg + 3.14 / 2)
by = bmag * SIN(ellipsearg + 3.14 / 2)
CASE 19712
ellipsearg = ellipsearg + .1
ax = amag * COS(ellipsearg)
ay = amag * SIN(ellipsearg)
bx = bmag * COS(ellipsearg + 3.14 / 2)
by = bmag * SIN(ellipsearg + 3.14 / 2)
END SELECT
' Intersections
a2 = ax ^ 2 + ay ^ 2
b2 = bx ^ 2 + by ^ 2
av = ax * vx + ay * vy
bv = bx * vx + by * vy
rbx = d - x0
rby = b - y0
adbr = ax * rbx + ay * rby
bdbr = bx * rbx + by * rby
aa = av ^ 2 / a2 ^ 2 + bv ^ 2 / b2 ^ 2
bb = 2 * (av * adbr / a2 ^ 2 + bv * bdbr / b2 ^ 2)
cc = adbr ^ 2 / a2 ^ 2 + bdbr ^ 2 / b2 ^ 2 - 1
arg = bb ^ 2 - 4 * aa * cc
IF (arg > 0) THEN
alpha1 = (-bb + SQR(arg)) / (2 * aa)
alpha2 = (-bb - SQR(arg)) / (2 * aa)
x1 = alpha1 * vx + d
x2 = alpha2 * vx + d
y1 = alpha1 * vy + b
y2 = alpha2 * vy + b
ELSE
x1 = -999
y1 = -999
x2 = -999
y2 = -999
END IF
GOSUB draweverything
_LIMIT 60
_DISPLAY
LOOP
END
draweverything:
CLS
PAINT (1, 1), 15
COLOR 0, 15
LOCATE 1, 1: PRINT "LClick=Move ellipse, RClick=Move line, Scroll=Tilt line, Arrows=Shift ellipse"
FOR alpha = -20 TO 20 STEP .001
x = alpha * vx + d
y = alpha * vy + b
CALL ccircle(xorig + x * xzoom, yorig + y * yzoom, 1, 1)
NEXT
FOR t = 0 TO 6.284 STEP .001
x = x0 + ax * COS(t) + bx * SIN(t)
y = y0 + ay * COS(t) + by * SIN(t)
CALL ccircle(xorig + x * xzoom, yorig + y * yzoom, 1, 4)
NEXT
CALL ccircle(xorig + x1 * xzoom, yorig + y1 * yzoom, 10, 1)
CALL ccircle(xorig + x2 * xzoom, yorig + y2 * yzoom, 10, 1)
RETURN
SUB cline (x1, y1, x2, y2, col)
LINE (_WIDTH / 2 + x1, -y1 + _HEIGHT / 2)-(_WIDTH / 2 + x2, -y2 + _HEIGHT / 2), col
END SUB
SUB ccircle (x1, y1, r, col)
CIRCLE (_WIDTH / 2 + x1, -y1 + _HEIGHT / 2), r, col
END SUB

BIN
samples/fibonacci-variations/img/ss1.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 2.9 KiB

BIN
samples/fibonacci-variations/img/ss2.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 12 KiB

27
samples/fibonacci-variations/index.md Normal file
View file

@ -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)
## SAMPLE: FIBONACCI VARIATIONS
![ss1.png](img/ss1.png)
### Author
[🐝 STxAxTIC](../stxaxtic.md)
### Description
The Fibonacci sequence is "seeded" with the golden ratio, but what if we change that?
### File(s)
* [myofsequ.bas](src/myofsequ.bas)
* [myofspir.bas](src/myofspir.bas)
### Additional Image(s)
![ss2.png](img/ss2.png)
🔗 [fibonacci](../fibonacci.md)
<sub>Reference: [qb64.org Forum](https://qb64forum.alephc.xyz/index.php?topic=3370.0) </sub>

29
samples/fibonacci-variations/src/myofsequ.bas Normal file
View file

@ -0,0 +1,29 @@
Option _Explicit
Dim x As Double
Dim Coefficient(21) As Double
Dim k As Long
x = 1 / 2 + Sqr(5) / 2
'x = 1 + SQR(2)
'x = 3 / 2 + SQR(13) / 2
'x = 2 + SQR(5)
Do
Cls
If (_KeyDown(18432) = -1) Then ' Up-arrow
x = x + .01
End If
If (_KeyDown(20480) = -1) Then ' Down-arrow
x = x - .01
End If
_KeyClear
Coefficient(1) = 1
Coefficient(2) = x - 1 / x
Print "x="; x
Print "C_1="; Coefficient(1)
Print "C_2="; Coefficient(2)
For k = 3 To UBound(Coefficient)
Coefficient(k) = -1 * Coefficient(k - 2) + x ^ (k - 1) + (-1) ^ (k - 1) * 1 / (x ^ (k - 1))
Print "C_"; LTrim$(RTrim$(Str$(k))); "="; Coefficient(k) ', Coefficient(k) / Coefficient(k - 1)
Next
_Limit 60
_Display
Loop

153
samples/fibonacci-variations/src/myofspir.bas Normal file
View file

@ -0,0 +1,153 @@
OPTION _EXPLICIT
DO UNTIL _SCREENEXISTS: LOOP
_TITLE "Fibonacci Spiral Explorer"
SCREEN _NEWIMAGE(800, 600, 32)
DIM SHARED pi AS DOUBLE
pi = 4 * ATN(1)
TYPE Vector
x AS DOUBLE
y AS DOUBLE
END TYPE
DIM SHARED CompassCart AS Vector
DIM SHARED CompassTheta AS Vector
DIM SHARED p AS SINGLE
DIM SHARED zoom AS SINGLE
FOR p = 0 TO 1 - .002 STEP .002
zoom = 50 * (1.9 - .9 * p)
CALL DrawEverything
_DISPLAY
_LIMIT 60
NEXT
SLEEP 1
DO
IF (_KEYDOWN(18432) = -1) THEN ' Up-arrow
zoom = zoom * (1 + 0.01)
END IF
IF (_KEYDOWN(20480) = -1) THEN ' Down-arrow
zoom = zoom * (1 - 0.01)
END IF
IF (_KEYDOWN(19200) = -1) THEN ' Left-arrow
IF (p > 0) THEN p = p - .005
_DELAY .025
END IF
IF (_KEYDOWN(19712) = -1) THEN ' Right-arrow
p = p + .005
_DELAY .025
END IF
_KEYCLEAR
CALL DrawEverything
LOCATE 1, 50: PRINT "Adjust Parameter and Zoom with arrow keys."
_DISPLAY
_LIMIT 60
LOOP
SYSTEM
SUB DrawEverything
DIM LastPoint AS Vector
DIM x1 AS DOUBLE
DIM y1 AS DOUBLE
DIM x2 AS DOUBLE
DIM y2 AS DOUBLE
DIM j AS INTEGER
DIM Step1 AS DOUBLE
DIM Step2 AS DOUBLE
DIM StepTemp AS DOUBLE
CompassCart.x = 1
CompassCart.y = -1
CompassTheta.x = pi
CompassTheta.y = 3 * pi / 2
Step1 = 0
Step2 = 1
LastPoint.x = 0
LastPoint.y = 0
CLS
LOCATE 1, 1: PRINT "Parameter="; p
LOCATE 2, 1: PRINT "Zoom="; zoom
FOR j = 1 TO 10
CALL StepCompass
StepTemp = Step2
Step2 = p * Step2 + Step1
Step1 = StepTemp
x1 = LastPoint.x
y1 = LastPoint.y
x2 = x1 + SQR(2) * Step2 * CompassCart.x
y2 = y1 + SQR(2) * Step2 * CompassCart.y
CALL clineb(x1 * zoom, y1 * zoom, x2 * zoom, y2 * zoom, _RGBA(255, 255, 255, 155))
IF (CompassCart.x = 1) AND (CompassCart.y = 1) THEN
CALL ccircle(x1 * zoom, y2 * zoom, SQR(2) * Step2 * zoom, _RGBA(255, 0, 255, 255), CompassTheta.x, CompassTheta.y)
END IF
IF (CompassCart.x = -1) AND (CompassCart.y = 1) THEN
CALL ccircle(x2 * zoom, y1 * zoom, SQR(2) * Step2 * zoom, _RGBA(255, 0, 255, 255), CompassTheta.x, CompassTheta.y)
END IF
IF (CompassCart.x = -1) AND (CompassCart.y = -1) THEN
CALL ccircle(x1 * zoom, y2 * zoom, SQR(2) * Step2 * zoom, _RGBA(255, 0, 255, 255), CompassTheta.x, CompassTheta.y)
END IF
IF (CompassCart.x = 1) AND (CompassCart.y = -1) THEN
CALL ccircle(x2 * zoom, y1 * zoom, SQR(2) * Step2 * zoom, _RGBA(255, 0, 255, 255), CompassTheta.x, CompassTheta.y)
END IF
LastPoint.x = x2
LastPoint.y = y2
NEXT
END SUB
SUB StepCompass
DIM xx AS INTEGER
DIM yy AS INTEGER
xx = CompassCart.x
yy = CompassCart.y
IF (xx = 1) AND (yy = 1) THEN
CompassCart.x = -1
CompassCart.y = 1
CompassTheta.x = 0
CompassTheta.y = pi / 2
END IF
IF (xx = -1) AND (yy = 1) THEN
CompassCart.x = -1
CompassCart.y = -1
CompassTheta.x = pi / 2
CompassTheta.y = pi
END IF
IF (xx = -1) AND (yy = -1) THEN
CompassCart.x = 1
CompassCart.y = -1
CompassTheta.x = pi
CompassTheta.y = 3 * pi / 2
END IF
IF (xx = 1) AND (yy = -1) THEN
CompassCart.x = 1
CompassCart.y = 1
CompassTheta.x = 3 * pi / 2
CompassTheta.y = 2 * pi
END IF
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 clineb (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, B
END SUB
SUB ccircle (x1 AS DOUBLE, y1 AS DOUBLE, rad AS DOUBLE, col AS _UNSIGNED LONG, ang1 AS DOUBLE, ang2 AS DOUBLE)
CIRCLE (_WIDTH / 2 + x1, -y1 + _HEIGHT / 2), rad, col, ang1, ang2
END SUB

BIN
samples/filled-circles-and-ellipses/img/ellipses.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 10 KiB

28
samples/filled-circles-and-ellipses/index.md Normal file
View file

@ -0,0 +1,28 @@
[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md)
## SAMPLE: FILLED CIRCLES AND ELLIPSES
![ellipses.png](img/ellipses.png)
### Author
[🐝 QB64 Team 2018](../qb64-team-2018.md)
### Description
We develop four variations on the CIRCLE command in the form of four SUBs:
(i) CircleFill = Filled circle
(ii) EllipseFill = Filled ellipse
(iii) EllipseTilt = Tilted ellipse
(iv) EllipseTiltFill = Tilted and filled ellipse
These works have been optimized for speed and respect for alpha transparency.
### File(s)
* [ellipses.bas](src/ellipses.bas)
🔗 [filled circle](../filled-circle.md), [ellipse](../ellipse.md)
<sub>Reference: [qb64.org Forum](https://qb64forum.alephc.xyz/index.php?topic=4213.0) </sub>

148
samples/filled-circles-and-ellipses/src/ellipses.bas Normal file
View file

@ -0,0 +1,148 @@
Screen _NewImage(800, 600, 32)
Dim TransRed As _Unsigned Long
Dim TransGreen As _Unsigned Long
Dim TransBlue As _Unsigned Long
TransRed = _RGBA(255, 0, 0, 128)
TransGreen = _RGBA(0, 255, 0, 128)
TransBlue = _RGBA(0, 0, 255, 128)
Call CircleFill(100, 100, 75, TransRed)
Call CircleFill(120, 120, 75, TransBlue)
Call EllipseFill(550, 100, 150, 75, TransBlue)
Call EllipseFill(570, 120, 150, 75, TransGreen)
Call EllipseTilt(200, 400, 150, 75, 0, TransGreen)
Call EllipseTilt(220, 420, 150, 75, 3.14 / 4, TransRed)
Call EllipseTiltFill(0, 550, 400, 150, 75, 3.14 / 6, TransRed)
Call EllipseTiltFill(0, 570, 420, 150, 75, 3.14 / 4, TransGreen)
End
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' R = radius
' C = fill color
Dim Radius As Integer, RE As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R)
RE = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RE = RE + Y * 2 + 1
If RE >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RE = RE - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub EllipseFill (CX As Integer, CY As Integer, a As Integer, b As Integer, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' a = semimajor axis
' b = semiminor axis
' C = fill color
If a = 0 Or b = 0 Then Exit Sub
Dim h2 As _Integer64
Dim w2 As _Integer64
Dim h2w2 As _Integer64
Dim x As Integer
Dim y As Integer
w2 = a * a
h2 = b * b
h2w2 = h2 * w2
Line (CX - a, CY)-(CX + a, CY), C, BF
Do While y < b
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
Sub EllipseTilt (CX, CY, a, b, ang, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' a = semimajor axis
' b = semiminor axis
' ang = clockwise orientation of semimajor axis in radians (0 default)
' C = fill color
For k = 0 To 6.283185307179586 + .025 Step .025
i = a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = -a * Cos(k) * Sin(ang) + b * Sin(k) * Cos(ang)
i = i + CX
j = -j + CY
If k <> 0 Then
Line -(i, j), C
Else
PSet (i, j), C
End If
Next
End Sub
Sub EllipseTiltFill (destHandle&, CX, CY, a, b, ang, C As _Unsigned Long)
' destHandle& = destination handle
' CX = center x coordinate
' CY = center y coordinate
' a = semimajor axis
' b = semiminor axis
' ang = clockwise orientation of semimajor axis in radians (0 default)
' C = fill color
Dim max As Integer, mx2 As Integer, i As Integer, j As Integer
Dim prc As _Unsigned Long
Dim D As Integer, S As Integer
D = _Dest: S = _Source
prc = _RGB32(255, 255, 255, 255)
If a > b Then max = a + 1 Else max = b + 1
mx2 = max + max
tef& = _NewImage(mx2, mx2)
_Dest tef&
_Source tef&
For k = 0 To 6.283185307179586 + .025 Step .025
i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
If k <> 0 Then
Line (lasti, lastj)-(i, j), prc
Else
PSet (i, j), prc
End If
lasti = i: lastj = j
Next
Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
For y = 0 To mx2
x = 0
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
xleft(y) = x
While Point(x, y) = prc And x < mx2
x = x + 1
Wend
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
Next
_Dest destHandle&
For y = 0 To mx2
If xleft(y) <> mx2 Then Line (xleft(y) + CX - max, y + CY - max)-(xright(y) + CX - max, y + CY - max), C, BF
Next
_Dest D: _Dest S
_FreeImage tef&
End Sub

BIN
samples/fire/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 16 KiB

19
samples/fire/index.md Normal file
View file

@ -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: FIRE
![screenshot.png](img/screenshot.png)
### Author
[🐝 *missing*](../author-missing.md)
### Description
Fire dominates the lower screen.
### File(s)
* [fire.bas](src/fire.bas)
🔗 [fire](../fire.md), [graphics](../graphics.md)

124
samples/fire/src/fire.bas Normal file
View file

@ -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

BIN
samples/floormaper/img/screenshot.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 11 KiB

21
samples/floormaper/index.md Normal file
View file

@ -0,0 +1,21 @@
[Home](https://qb64.com) • [News](../../news.md) • [GitHub](../../github.md) • [Wiki](../../wiki.md) • [Samples](../../samples.md) • [Media](../../media.md) • [Community](../../community.md) • [Rolodex](../../rolodex.md) • [More...](../../more.md)
## SAMPLE: FLOORMAPER
![screenshot.png](img/screenshot.png)
### Author
[🐝 Antoni Gual](../antoni-gual.md)
### Description
Floormaper by Antoni Gual
for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003
### File(s)
* [flrmp.bas](src/flrmp.bas)
🔗 [graphics](../graphics.md), [floorscape](../floorscape.md)

Some files were not shown because too many files have changed in this diff Show more