Welcome, Guest |
You have to register before you can post on our site.
|
Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,032
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
OldMoses' Ark of the Codenant |
Posted by: OldMoses - 04-24-2022, 09:00 PM - Forum: Programs
- Replies (9)
|
|
Given this new clean slate fresh start, I envision this as a place to repost some of my programs and/or links from the old forum. Maybe someone can get some ideas, or at least be amused by my random toddlings. Keeping things neat and contained in one thread to reduce clutter on the new forum.
This first one is my passion/obsession, years in the crafting and stumbling, which has grown in scope and support files/directories beyond just posting a code block. Made possible by QB64 as QBasic/4.5 just couldn't do it. While mostly still a work in progress, it's complete enough to call a "program".
CT Vector, is my turn based space flight vector tracker, a utility attempting to rescue the old Traveller RPG tabletop spaceship combat rules from obscurity. Likely no one who plays the game cares as no one bothered to use them for long, but I always wanted this sort of tool back in the day, and thought it would work, so I wrote one anyway. I'm funny that way... Even used it over the holidays, with somewhat mixed results. Many of the coding concepts I regularly use arose out of this mess, and many folks here will find their influence in it too.
A gamemaster can create and edit stellar systems [sysinput042.bas], whereupon the players can fly spacecraft through them. The system creator is still rather cryptic to use with some knowledge of the game and its canon concepts being helpful, but it does function with a few minor boogers. In lieu of that the tracker will default to the Sol system for demo purposes and the editor ap can be skipped. That's the easiest way to just "play around" with it. There are a couple of other systems included in the systems\ directory. I give a big "thank you" to Spriggsy for his pipecom API for making the loading process much more intuitive.
The tracker [CTvector052.bas] models game rules and is in no way an actual astrophysics or gravity simulator. "Damn it Jim, I'm a farmer, not an astrophysicist!" That said, large planets will attract nearby ships, so you gotta keep 'em flying or they'll crash. It can also take maneuvers to 3D, and resize and zoom in/out, which tabletop plotting could not do. Dates can optionally be input to track planetary ephemeris as the planets will move dynamically during play.
It's been a very long time since I posted any updates to it. My pièce de la résistance, which I have moved to Github. I added some OS metacommands to (hopefully) allow it to skip those commands that are not supported in Mac and Linux. Maybe it will run under those platforms now as well, with only a slight loss in mouse functionality. If anyone does try that, I'd appreciate a shout as to how it went.
In the tracker application, left click actuates controls, while right click & hold opens a context bubble explaining the controls function and hotkey access or moves ships in the sensor display. There is a badly "dated" user guide pdf included.
https://github.com/OldMoses/CT-Vector
|
|
|
QuadDraw revisited - drawing program work in progress |
Posted by: Dav - 04-24-2022, 05:57 PM - Forum: Works in Progress
- Replies (26)
|
|
Browsing through the old forum @luke put up temporarily I found a drawing program I forgot about, QuadDraw, and decided to reawaken it. It would not work in our current QB64 version so I had to rewrite how it draws (it was using a recursive function that worked in QB64 v1.5 but not v2). Used a drawing method @bplus helped me with with another drawing project (doodle dandy).
I'm going to start working on this again and add more features. Here's where it's at so far. Draw on the screen by left clicking the mouse. Right clicking will fill spaces with a random color. U will undo last change. Brush size can be changed with -/+ keys. You can change how many section to draw at once by pressing numbers 1 to 4. Current drawing settings are visible in the title bar. I probably add a menu system and drawing color selector to it next.
Testers and suggestions are welcomed. Example drawing is attached.
- Dav
Code: (Select All) '============
'QuadDraw.bas v1.3
'============
'An odd little drawing program.
'Draws/paints in 4 sections of the screen at same time.
'Coded by Dav for QB64 APR/2022
'NEW FOR v1.3: Fixed it to run in QB64 v2 and higher.
' (had to remove recursive drawing function)
' Screen size now adjusts to users desktop resolution.
' (size not hard coded - should look good on most desktops)
'CREDITS: SPAINT SUB was made by Petr. Thanks Petr!
' And bplus helped me figure out a way to draw lines without gaps
' in another program (doodle dandy). I used that new method here.
'----------
'HOW TO USE:
'----------
'Use the mouse to draw/color on screen.
'Left click = draws on screen.
'Right click = fills areas with color.
'Use the +/- keys to change brush size (1 to 50 allowed)
'Press 1,2,3 or 4 to set how many areas to draw in, default is 4.
'Press U to undo last change.
'Space = clears screen and starts over.
'ESC = Ends program
'Current drawing settings are shown in title bar
DIM SHARED quads, brushsize
SCREEN _NEWIMAGE(_DESKTOPWIDTH * .75, _DESKTOPHEIGHT * .85, 32)
_DELAY .25
centerx = _WIDTH / 2: centery = _HEIGHT / 2 'center point of screen
wht& = _RGB(255, 255, 255) 'used often, so variable it
blk& = _RGB(0, 0, 0)
brushsize = 5 'size of drawing circle (brush)
quads = 4 'start with 4 drawing sections
CLS , wht& 'start with white screen
undo& = _COPYIMAGE(_DISPLAY)
'====
main:
'====
_TITLE "QuadDraw - Quads:" + STR$(quads) + " BrushSize:" + STR$(brushsize)
DO
WHILE _MOUSEINPUT: WEND
mx = _MOUSEX: my = _MOUSEY
IF _MOUSEBUTTON(1) THEN
IF stilldown = 0 THEN
_FREEIMAGE undo&
undo& = _COPYIMAGE(_DISPLAY)
END IF
IF stilldown = 1 THEN
stepx = lastmx - mx
stepy = lastmy - my
length = INT((stepx ^ 2 + stepy ^ 2) ^ .5)
dx = stepx / length
dy = stepy / length
FOR i = 0 TO length
FOR d = 1 TO brushsize
newx = mx + dx * i: newy = my + dy * i
CIRCLE (newx, newy), d, blk&: PAINT (newx, newy), blk&, blk&
IF quads > 1 THEN
CIRCLE (centerx - newx + centerx, centery - newy + centery), d, blk&
PAINT (centerx - newx + centerx, centery - newy + centery), blk&, blk&
END IF
IF quads > 2 THEN
CIRCLE (newx, centery - newy + centery), d, blk&
PAINT (newx, centery - newy + centery), blk&, blk&
END IF
IF quads > 3 THEN
CIRCLE (centerx - newx + centerx, newy), d, blk&
PAINT (centerx - newx + centerx, newy), blk&, blk&
END IF
NEXT
NEXT
ELSE
FOR d = 1 TO brushsize STEP .2
CIRCLE (mx, my), d, blk&&
NEXT
END IF
lastmx = mx: lastmy = my
stilldown = 1
ELSE
stilldown = 0
END IF
'if right click, fill sections with random color
IF _MOUSEBUTTON(2) THEN
_FREEIMAGE undo&
undo& = _COPYIMAGE(_DISPLAY)
r = RND * 255: g = RND * 255: b = RND * 255
SPAINT mx, my, _RGB(r, g, b) ', blk&
IF quads > 1 THEN
SPAINT centerx - mx + centerx, centery - my + centery, _RGB(r, g, b) ', blk&
END IF
IF quads > 2 THEN
SPAINT mx, centery - my + centery, _RGB(r, g, b) ', blk&
END IF
IF quads > 3 THEN
SPAINT centerx - mx + centerx, my, _RGB(r, g, b) ', blk&
END IF
WHILE _MOUSEBUTTON(2) <> 0: n = _MOUSEINPUT: WEND
END IF
'get keyboard input
key$ = UCASE$(INKEY$)
IF key$ <> "" THEN
SELECT CASE key$
CASE CHR$(32): CLS , wht& 'scpace clears screen again
CASE "1": quads = 1
CASE "2": quads = 2
CASE "3": quads = 3
CASE "4": quads = 4
CASE "+"
brushsize = brushsize + 1: IF brushsize > 50 THEN brushsize = 50
CASE "-"
brushsize = brushsize - 1: IF brushsize < 1 THEN brushsize = 1
CASE "U": _PUTIMAGE (0, 0), undo&
CASE CHR$(27): END
END SELECT
DO UNTIL INKEY$ = "": LOOP
GOTO main
END IF
LOOP
END
SUB SPAINT (x AS INTEGER, y AS INTEGER, clr~&) 'Color everything in the X, Y position regardless of the border color.
'SUB by Petr
DIM m AS _MEM, m2 AS _MEM
m = _MEMIMAGE(_DEST)
W = _WIDTH(_DEST)
H = _HEIGHT(_DEST)
P = _PIXELSIZE(_DEST)
SELECT CASE P
CASE 4 ' image is 32 bit image
Virtual = _NEWIMAGE(W, H, 32)
m2 = _MEMIMAGE(Virtual)
Back~& = POINT(x, y)
Back2~& = _RGB32(1, 1, 1)
Empty~& = _RGBA32(0, 0, 0, 0)
DO UNTIL a& = m.SIZE - 4
a& = a& + 4
IF _MEMGET(m, m.OFFSET + a&, _UNSIGNED LONG) = Back~& THEN _MEMPUT m2, m2.OFFSET + a&, Back~& ELSE _MEMPUT m2, m2.OFFSET + a&, Back2~&
LOOP
d = _DEST
_DEST Virtual
PAINT (x, y), clr~&, Back2~&
_DEST d
a& = 0
DO UNTIL a& = m.SIZE - 4
a& = a& + 4
IF _MEMGET(m2, m2.OFFSET + a&, _UNSIGNED LONG) <> clr~& THEN _MEMPUT m2, m2.OFFSET + a&, Empty~&
LOOP
_CLEARCOLOR Back2~&, Virtual
_PUTIMAGE (0, 0), Virtual
_MEMFREE m
_MEMFREE m2
_FREEIMAGE Virtual
CASE 1 ' image is 8 bit image (256 colors)
Virtual = _NEWIMAGE(W, H, 32)
m2 = _MEMIMAGE(Virtual)
Back~& = POINT(x, y)
Back2~& = _RGB(1, 1, 1)
Empty~& = _RGBA(0, 0, 0, 0)
DO UNTIL a& = m.SIZE - 1
a& = a& + 1
IF _MEMGET(m, m.OFFSET + a&, _UNSIGNED _BYTE) = Back~& THEN _MEMPUT m2, m2.OFFSET + a&, Back~& ELSE _MEMPUT m2, m2.OFFSET + a&, Back2~&
LOOP
d = _DEST
_DEST Virtual
PAINT (x, y), clr~&, Back2~&
_DEST d
a& = 0
DO UNTIL a& = m.SIZE - 1
a& = a& + 1
IF _MEMGET(m2, m2.OFFSET + a&, _UNSIGNED _BYTE) <> clr~& THEN _MEMPUT m2, m2.OFFSET + a&, Empty~&
LOOP
_CLEARCOLOR Back2~&, Virtual
_PUTIMAGE (0, 0), Virtual
_MEMFREE m
_MEMFREE m2
_FREEIMAGE Virtual
END SELECT
END SUB
|
|
|
Whatever happened to TheBOB's White Cake? |
Posted by: Pete - 04-24-2022, 05:37 PM - Forum: Programs
- No Replies
|
|
Whenever we had a graphics emergency at The QBasic Forum, we always put up the Bat Signal ^^0^^ to call on TheBOB (aka The Batman) for help. One of Bob's creations, a recipe for White cake, and his Page Flipping Screen 9 demo were combined in the following code, but something went amiss that day in Gotham City...
Code: (Select All) DEFINT A-Y
TYPE RockTYPE 'establish data TYPE for meteors
Mx AS INTEGER 'meteor x coordinate
My AS INTEGER 'meteor y coordinate
Mr AS INTEGER 'meteor radius (fixed)
Ms AS INTEGER 'meteor speed (fixed)
END TYPE
SCREEN 12, 0, 0, 0
_FULLSCREEN
FOR n = 1 TO 9
READ Attribute: OUT &H3C8, Attribute
FOR Reps = 1 TO 3
READ Intensity: OUT &H3C9, Intensity
NEXT Reps
NEXT n
PRINT
PRINT
COLOR 15
PRINT SPACE$(4); "W H I T E"; SPACE$(3); "C A K E"; SPACE$(3); "R E C I P E"
LINE (16, 60)-(620, 60), 9
LINE (16, 62)-(620, 62), 9
LINE (418, 60)-(542, 62), 0, BF
PRINT
PRINT
COLOR 12
PRINT SPACE$(4); "Heat oven to 350 degrees"
PRINT SPACE$(4); "Grease and flour 2 circular pans (8-9 inches)"
PRINT
COLOR 15
PRINT SPACE$(4); "CAKE:";
COLOR 11
PRINT SPACE$(9); "Flour: 2-1/4 cups"
PRINT SPACE$(18); "Sugar: 1-2/3 cups"
PRINT SPACE$(13); "Shortening: 2/3 cup"
PRINT SPACE$(19); "Milk: 1-1/4 cups"
PRINT SPACE$(10); "Baking powder: 3-1/2 tsps"
PRINT SPACE$(19); "Salt: 1 tsp"
PRINT SPACE$(16); "Vanilla: 1 tsp"
PRINT SPACE$(13); "Egg whites: 5 (reserve yolks for icing)"
PRINT
COLOR 12
PRINT SPACE$(4);
PRINT "Combine all ingredients except the egg whites in a bowl. Beat for 1/2"
PRINT SPACE$(4);
PRINT "minute at low speed, scraping bowl constantly, then 2 minutes at high"
PRINT SPACE$(4);
PRINT "speed, scraping bowl occasionally. Beat in egg whites, 2 minutes at"
PRINT SPACE$(4);
PRINT "high speed. Pour into pans. Bake until a toothpick inserted comes out"
PRINT SPACE$(4);
PRINT "clean or cake springs back when touched lightly (30 - 35 minutes)."
PRINT
COLOR 15
PRINT SPACE$(4); "ICING:";
COLOR 11
PRINT SPACE$(3); "Shortening: 2/3 cup"
PRINT SPACE$(17); "Butter: 2/3 cup"
PRINT SPACE$(14); "Egg yolks: 5"
PRINT SPACE$(16); "Vanilla: 1-1/2 tsps"
PRINT SPACE$(12); "Icing sugar: 3/4 cup or to taste"
CIRCLE (480, 86), 74, 1, , , .4
PAINT STEP(0, 0), 1
CIRCLE (480, 80), 72, 15, , , .4
PAINT STEP(0, 0), 15
CIRCLE (480, 79), 67, 9, , , .4
PAINT STEP(0, 0), 9
CIRCLE (480, 80), 72, 14, , , .4
CIRCLE (480, 78), 48, 15, , , .4
CIRCLE (480, 40), 60, 7, -4.5, -3.5, .4
PSET (423, 46), 7: DRAW "F2"
PAINT STEP(0, -10), 7
CIRCLE (480, 80), 60, 7, -4.5, -3.5, .4
PSET (423, 86), 7: DRAW "F2"
PAINT STEP(0, -10), 7
LINE (540, 40)-STEP(0, 40), 7
LINE (420, 40)-STEP(0, 40), 7
PAINT (430, 60), 7
PAINT (530, 60), 7
LINE (420, 40)-STEP(0, 40), 7
LINE STEP(4, -33)-STEP(0, 40), 7
LINE STEP(43, -24)-STEP(0, 40), 7
PAINT STEP(8, -18), 7
CIRCLE (480, 40), 60, 15, -4.5, -3.5, .4
LINE (540, 40)-STEP(0, 40), 15
LINE (420, 40)-STEP(0, 40), 15
LINE (420, 40)-STEP(0, 40), 15
LINE STEP(4, -33)-STEP(0, 40), 15
LINE STEP(43, -24)-STEP(0, 40), 15
PSET (430, 52), 4
DRAW "M+47,-7 M-9,+14 M-38,+6 U12 BR12 P4,4 BL13 D12 LU13Ld13"
PSET (427, 70), 4
DRAW "M+40,-7 D19 M-40,+7 U19 BF8 P4,4"
DIM Box(1000)
GET (427, 53)-(467, 78), Box()
PUT (427, 55), Box(), PSET
PSET (481, 40), 15
DRAW "M-13,+21"
PAINT (470, 30), 13, 15
FOR Reps = 1 TO 1200
X = FIX(RND * 60) + 420
y = FIX(RND * 54) + 40
IF POINT(X, y) = 4 THEN PSET (X, y), 15
NEXT Reps
PSET (427, 70), 2
DRAW "bM+40,-7 bD19 M-40,+7"
PSET (427, 70), 2
DRAW "bM+40,-7 bD20 M-30,+5"
CIRCLE (480, 80), 60, 2, 4.5, 6, .4
LINE (4, 4)-(635, 475), 9, B
FOR X = 524 TO 525
FOR y = 30 TO 100
IF POINT(X, y) = 7 THEN PSET (X, y), 13
NEXT y
NEXT X
FOR X = 528 TO 540
FOR y = 30 TO 100
IF POINT(X, y) = 7 THEN PSET (X, y), 13
NEXT y
NEXT X
CALL BSU
CALL SPACE
SYSTEM
PaletteDATA:
DATA 0,0,0,36,1,0,0,24,2,48,36,44,4,54,54,63,7,63,48,48,8
DATA 54,54,54,9,60,48,63,12,42,42,42,13,63,52,52,14,63,42,24
DEFSNG Z
SUB BSU
LOCATE 27, 60: PRINT CHR$(24);
LOCATE 28, 60: PRINT CHR$(219);: FIREPIN = 1
_DELAY 1
DO
b$ = INKEY$
_LIMIT 30
LOCATE 28, 62
PRINT "Press arrow up.";
LOCATE 28, 62
IF b$ = CHR$(0) + "H" THEN EXIT DO
_DELAY .45
PRINT " ";
IF b$ = CHR$(0) + "H" THEN EXIT DO
_DELAY .45
IF b$ = CHR$(27) THEN SYSTEM
LOOP UNTIL b$ = CHR$(0) + "H"
b$ = CHR$(13)
LOCATE 28, 60: PRINT " ";
FIREMISSILE:
FOR I = 1 TO 25
LOCATE 28 - I, 60: PRINT " ";
LOCATE CSRLIN - 1, 60: PRINT CHR$(24);
Z = TIMER
DO
LOOP UNTIL ABS(Z - TIMER) >= .02: 'DELAY LOOP
NEXT
FOR I = 1 TO 5
SOUND 2000, 2: SOUND 500, 2
WAIT &H3DA, 8
WAIT &H3DA, 8, 8
OUT &H3C8, 12
IF I >= 3 THEN
IF I / 2 <> I \ 2 THEN OUT &H3C8, 33 ELSE OUT &H3C8, 0
ELSE
OUT &H3C8, 0
OUT &H3C9, 63 'set background (briefly) to bright red
OUT &H3C9, 0
OUT &H3C9, 0
END IF
NEXT I
Z = TIMER
DO
LOOP UNTIL ABS(Z - TIMER) >= 1.5: 'DELAY LOOP
END SUB
SUB SPACE
SCREEN 9
'Set all attributes to black to hide draw/GET process
FOR n = 1 TO 15
PALETTE n, 0
NEXT n
'Ships differ in that the ship 2 rocket blasts are slightly larger
'Draw and GET ship 1 and mask
X = 0: Y = 0
MaxWIDTH = 83
MaxDEPTH = 60
DIM Rocks(1 TO 100) AS RockTYPE 'holds the location, size
'and speed of 100 meteors
IF X < 326 THEN
FOR n = 1 TO 100 'loop to initialize meteor array
Rocks(n).Mx = FIX(RND * 640) 'initial x coordinates
Rocks(n).My = FIX(RND * 350) 'initial y coordinates
Rocks(n).Mr = FIX(RND * 5) + 2 'permanent radius (2-6 pixels)
SELECT CASE n 'speed variations create perspective
CASE 1 TO 30: Rocks(n).Ms = 12 'background meteors
CASE 31 TO 65: Rocks(n).Ms = 18 'midground meteors
CASE 66 TO 100: Rocks(n).Ms = 24 'foreground meteors
END SELECT
NEXT n
Rocks(50).Mr = 10 'meteor 50 specially sized (large)
Rocks(100).Mr = 16 'meteor 100 specially sized (larger)
ELSE
Z = TIMER: DO: IF ABS(Z - TIMER) > .1 THEN EXIT DO
LOOP
END IF
ActivePAGE = 0: VisualPAGE = 1 'establish page variables for SWAP
SCREEN 9, , ActivePAGE, VisualPAGE 'page 0 active, page 1 visual
PALETTE
PALETTE 10, 0 'set palette values for attributes
PALETTE 12, 35 'which do not respond to OUT
'set palette values for attributes
'that respond to OUT
OUT &H3C8, 0
OUT &H3C9, 0
OUT &H3C9, 0 'background: midnight blue
OUT &H3C9, 12
OUT &H3C8, 1
OUT &H3C9, 16
OUT &H3C9, 8 'meteor: dark brown
OUT &H3C9, 2
OUT &H3C8, 2
OUT &H3C9, 32
OUT &H3C9, 32 'medium ship gray
OUT &H3C9, 32
OUT &H3C8, 3
OUT &H3C9, 22
OUT &H3C9, 12 'meteor highlight brown
OUT &H3C9, 5
OUT &H3C8, 4
OUT &H3C9, 63
OUT &H3C9, 0 'bright red
OUT &H3C9, 0
OUT &H3C8, 5
OUT &H3C9, 52
OUT &H3C9, 52 'ship light gray
OUT &H3C9, 52
'MAIN LOOP BEGINS -------------------------------
Count = 0
FOR X = 6 TO 546 STEP 2 'main loop wherein ship will
_DELAY .115 ' Reading speed
'travel 540 pixels in steps
'of two
CLS 'active screen cleared
OUT &H3C8, 0 'background color reestablished
OUT &H3C9, 0 'in case "space lightning" has
OUT &H3C9, 0 'flashed
OUT &H3C9, 12
'The following loop draws/updates x/y's of first 80 meteors
IF X < 326 THEN
FOR n = 1 TO 80
GOSUB DrawMETEORS 'see DrawMETEORS subroutine
NEXT n
'Second meteor-drawing loop draws last 20 meteors so that they *may*
'overdraw the ship (creating sense of its 'involvement' in meteor storm)
FOR n = 81 TO 100
GOSUB DrawMETEORS 'see DrawMETEORS subroutine
NEXT n
ELSE
''Z = TIMER: DO: IF ABS(Z - TIMER) > .1 THEN EXIT DO
''LOOP
END IF
Z = TIMER: DO: IF ABS(Z - TIMER) > .05 THEN EXIT DO
LOOP
'PRINT section -------------------------------------
'Blurbs are printed (with gaps) based on the ship's x location
COLOR 13: A1 = 30
SELECT CASE X
CASE 10 + A1 TO 100 + A1
LOCATE 21, 19: PRINT "Kirk to Spock. What are those strange looking"
LOCATE 22, 31: PRINT "blobs on the screen?"
CASE 101 + A1 TO 170 + A1
LOCATE 21, 21: PRINT "Sensors indicate they are the remains of"
LOCATE 22, 23: PRINT "TheBob's White Cake Recipe, Captain."
CASE 171 + A1 TO 240 + A1
LOCATE 21, 15: PRINT "Kirk to Scottie. Beam those pieces of cake on board!"
CASE 241 + A1 TO 317 + A1
LOCATE 21, 19: PRINT "Aye Captain, I'll get right on it, as soon as"
LOCATE 22, 28: PRINT "I finish my Dunkin Donuts."
CASE 336 + A1 TO 435 + A1
LOCATE 21, 15: PRINT "Kirk to Sick Bay. Bones, MEDICAL EMERGENCY! Report to"
LOCATE 22, 13: PRINT "the Transporter Room and put TheBob's cake back together!"
CASE IS > 440 + A1
LOCATE 21, 19: PRINT "Dammit Jim. I'm a doctor, not Martha Stewart!"
END SELECT
'-----------------------------------------------------
'Border line
LINE (0, 0)-(639, 349), 8, B
'"Space lightning" flash (1 chance in 25)
'Flash = FIX(RND * 25)
IF X = 326 THEN
SOUND 1000, .5: SOUND 2000, .5: SOUND 3000, .5: SOUND 4000, .5: SOUND 5000, .5: SOUND 6000, .5
SOUND 6000, .5: SOUND 7000, .5: SOUND 8000, .5: SOUND 4000, .5: SOUND 9000, .5
OUT &H3C8, 0
OUT &H3C9, 63 'set background (briefly) to bright red
OUT &H3C9, 0
OUT &H3C9, 0
END IF
'PAGING SECTION --------------------------------
SWAP ActivePAGE, VisualPAGE 'SWAP values of page variables...
SCREEN 9, , ActivePAGE, VisualPAGE 'which toggles active/visual page
'-----------------------------------------------
WAIT &H3DA, 8
WAIT &H3DA, 8, 8
NEXT X 'main loop ends
SCREEN 9, 0, 0, 0
LOCATE 21, 5: PRINT SPACE$(70);
LOCATE 22, 5: PRINT SPACE$(70);
_DELAY 1
LEVEL1 = 10
A1$ = " [Sometimes The Joker Wins!]"
REDIM BAT$(3)
BAT$(3) = "^^o^^"
BAT$(2) = "--o--"
BAT$(1) = "vvovv"
LOCATE LEVEL1, 2
_DELAY 1
FOR I = 1 TO 12
FOR J = 1 TO 3
IF I = 1 AND J = 1 THEN LOCATE , 3 ELSE PRINT " ";
PRINT BAT$(J);
LOCATE , POS(1) - 5
Z = TIMER
DO: IF ABS(Z - TIMER) > .1 THEN EXIT DO
LOOP
NEXT J
NEXT I
_DELAY 1
FOR I = 2 TO LEVEL1
IF I = LEVEL1 - 1 THEN SOUND 3000, .7: SOUND 358, 1.5: SOUND 5000, 1
IF I <> 2 THEN LOCATE I - 1, 27: PRINT SPACE$(28);
LOCATE I, 27: PRINT A1$;
Z = TIMER
DO: IF ABS(Z - TIMER) > .1 THEN EXIT DO
LOOP
NEXT
_DELAY 4
SYSTEM
'- SUBROUTINE SECTION BEGINS -------------------------
DrawMETEORS:
'If the meteor's x coordinate has moved off-screen to the left, it is as-
'signed a new random y coordinate, then reset to the right of the screen
IF Rocks(n).Mx < 0 THEN
Rocks(n).My = FIX(RND * 350)
Rocks(n).Mx = 642
END IF
'Meteors are drawn with lighter highlight circle offset +1/-1 pixel
CIRCLE (Rocks(n).Mx, Rocks(n).My), Rocks(n).Mr, 1
PAINT STEP(0, 0), 1
CIRCLE (Rocks(n).Mx + 1, Rocks(n).My - 1), Rocks(n).Mr - 2, 3
PAINT STEP(0, 0), 3
'Establish new location for each meteor by subtracting their
'individual speed (Ms) from their current x coordinate (Mx) ...
Rocks(n).Mx = Rocks(n).Mx - Rocks(n).Ms
RETURN
Mask:
FOR xx = 0 TO 83
FOR yy = 0 TO 60
IF POINT(xx, yy) = 0 THEN PSET (xx, yy), 15 ELSE PSET (xx, yy), 0
NEXT yy
NEXT xx
RETURN
END SUB
|
|
|
Proggies |
Posted by: bplus - 04-24-2022, 04:02 PM - Forum: bplus
- Replies (93)
|
|
Update: Retitle this thread "Proggies" for very short snippets to demo some method or just a fun little ditty, from me, probably a graphics thingy.
Refining what a Proggie is, I would say 100 lines more or less and only one bas source file, images graphically drawn and sound not from a 2nd file either.
Fell free to join in if you have a mod, that's my MO! Please include: "Mod Your_Avatar_Name" in the _Title at start and a date would not be unwelcome.
_________________________________________________________________________________________________________________________
Light up your balls: Double color shifting with balls example. I modified my regular drawBall sub for this demo.
MidInk is a very, very handy Function for getting a color somewhere between two colors using a fraction between 0 = the first color and 1 the 2nd color so .5 would be halfway between them.
Code: (Select All) _Title "Light up your balls" 'b+ 2022-04-24
Screen _NewImage(800, 600, 32)
_ScreenMove 300, 40
Randomize Timer
balls = 25
Dim r(balls), x(balls), y(balls), c~&(balls)
For i = 1 To balls
r(i) = Rnd * 80 + 15
x(i) = Rnd * _Width
y(i) = Rnd * _Height
c~&(i) = _RGB32(Rnd * 100, Rnd * 100, Rnd * 100)
Next
For f## = 0 To 1 Step .01
Cls
For b = 0 To balls
rr = _Red32(c~&(b)): gg = _Green32(c~&(b)): bb = _Blue32(c~&(b))
m~& = midInk~&(rr, gg, bb, 255, 255, 255, f##)
drawBall x(b), y(b), r(b), m~&
Next
Print f##
_Display
_Limit 10
Next
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = .5 * (1 - rr / r) + .5
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
'from Steve Gold standard
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
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
|
|
|
So why is the color change "permanent"? |
Posted by: James D Jarvis - 04-24-2022, 01:55 PM - Forum: Help Me!
- Replies (11)
|
|
In the sample program attached I use a function to brighten the color of drawn elements. I noticed the color change is permanent even though I am not returning the color value to the color handle itself. Am I doing this wrong or is there something buggy in how color handles are passed that I don't understand? I figured out a work arround for the situation but I don't care for it. Any suggestions of comments would be welcome.
Code: (Select All) Sc& = _NewImage(800, 500, 32)
Screen Sc&
Dim klr&, klr2&, klr3&
klr& = _RGB(27, 27, 128)
klr2& = _RGB(27, 27, 128)
klr3& = _RGB(150, 26, 28)
For n = 1 To 40
Cls
_Limit 20
klr& = _RGB(27, 27, 128) 'if this line is commented out the color is permanently changed by the brighter function
orb 400, 250, n * 2, klr&, 1.5
' klr2& = _RGB(128, 227, 128) this one is commented out to show what would happen as above
orb 200, 250, n * 2, klr2&, 1.5
klr3& = _RGB(227, 26, 28) 'comment this out and the color changes
orb 600, 250, 40, klr3&, 7 'an orb that is the same size to serve as an example without the scaling to distract with the viewer
_Display
Next n
Function brighter& (ch&&, p)
r = _Red(ch&&)
b = _Blue(ch&&)
g = _Green(ch&&)
If p < 0 Then p = 0
If p > 100 Then p = 100
p = p / 100
rdif = 255 - r: rc = rdif * p: brr = Int(r + rc): If brr > 255 Then brr = 255
gdif = 255 - g: gc = gdif * p: bgg = Int(g + gc): If bgg > 255 Then bgg = 255
bdif = 255 - b: bc = bdif * p: bbb = Int(b + bc): If bbb > 255 Then bbb = 255
brighter& = _RGB(brr, bgg, bbb)
End Function
Sub orb (XX As Long, YY As Long, Rd As Long, KK As Long, brt As Integer)
'for false shaded 3-D look
'XX,YY arer screen position Rd is outermost radius of the orb KK is the startign color
'brt is the factor by which color will chnage it is the diffeence from KK to RGB(255,255,255)
'brt is applied each step so your orb will go to white if it is large or the brt value is high
ps = _Pi
p3 = _Pi / 3
p4 = _Pi / 4
rdc = p4 / Rd
If Rd < 10 Then ps = _Pi / 3 'so small radius orbs look cool too
For c = 0 To Int(Rd * .87) Step ps
KK = brighter&(KK, brt)
CircleFill XX, YY, Rd - (c), KK
XX = XX + rdc * (c * p3) ' could be fiddled with to move the center of the gradient
YY = YY - rdc * (c * 2 * p4) ' could be fiddled with to move the center of the gradient
Next c
End Sub
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
'sub by SMcNeill makes a filled circle without worrying about using the paint command to fill an empty circle
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
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
|
|
|
What are libraries |
Posted by: bplus - 04-24-2022, 01:07 PM - Forum: Help Me!
- Replies (6)
|
|
Form https://staging.qb64phoenix.com/showthread.php?tid=59
PhilOfPerth asks, "Being something of a novice myself (what are "libraries"?),..."
Good question.
Libraries are code that can be used in several different apps or programs without having to rewrite same set of Constants, Types, Subs or Functions, no need to Copy/Paste into your programs.
You just put an Include statement,
syntax: '$Include: 'MyLibrary.extension'
Note the comment at the start and the single quotes around the filename, these are for the compiler.
in the proper place(s) of you program to reuse code from a special "BI" file. It use to be one .BI file in older versions of QB when you had to Declare all your Subs and Functions.
Now in QB64 there are 2 places to insert code from another file in an Include statement:
An Include statement for Constants and Types goes at the beginning of your program and typically uses the old .BI extension but not mandatory.
The Include statement for all the Subs and Functions should go at the very bottom of your code, like you are just adding more Subs and Function in. This code file contains just Subs and Functions and the file extension is typically .BM again just a convention so people know what kind of file it is compared to a .BAS file.
Here is an example of a library I made for Arrays of Floats Type:
Here is just a normal looking Bas program dealing with Arrays of Floats
Code: (Select All) 'OPTION _EXPLICIT
' Build a set of Floats Array tools for handling Tomaaz challenge
' Build Floats Array Tools.bm from these
Randomize Timer
Dim i As Long, test$, TomaazTest$
TomaazTest$ = "120 135 345 345 1890 12 120 12 135 712 78 120"
'FOR i = 1 TO 500
' test$ = test$ + LTRIM$(STR$(INT(RND * 100))) + " "
'NEXT
'test$ = RTRIM$(test$)
test$ = TomaazTest$
Print "Test string: "; test$
ReDim temp(0) As _Float
Split2Floats test$, " ", temp()
uniqueFloats temp()
qSortFloats LBound(temp), UBound(temp), temp()
reverseFloats temp()
Print "Output: "; JoinFloats$(temp(), 0, 10, " ")
'''''$include: 'Floats Array Tools.bm'
'a() must be initialized as redim a(lb to ub)
Sub uniqueFloats (a() As _Float) 'make all the items in the a array unique like a proper set
Dim i As Long, ti As Long, j As Long, u As Integer, lba As Long
lba = LBound(a)
ReDim t(lba To lba) As _Float 'rebuild container
t(lba) = a(lba): ti = lba
For i = lba + 1 To UBound(a) 'for each element in array
u = -1
For j = lba To ti 'check if not already in new build
If a(i) = t(j) Then u = 0: Exit For 'oh it is unique is false
Next
If u Then 'OK add it to rebuild
ti = ti + 1
ReDim _Preserve t(lba To ti) As _Float
t(ti) = a(i)
End If
Next
ReDim a(lba To ti) As _Float 'goodbye old array
For i = lba To ti 'now copy the unique elements into array
a(i) = t(i)
Next
End Sub
Sub qSortFloats (start As Long, finish As Long, a() As _Float)
Dim Hi As Long, Lo As Long, Middle As _Float
Hi = finish: Lo = start
Middle = a((Lo + Hi) / 2) 'find middle of array
Do
Do While a(Lo) < Middle: Lo = Lo + 1: Loop
Do While a(Hi) > Middle: Hi = Hi - 1: Loop
If Lo <= Hi Then
Swap a(Lo), a(Hi)
Lo = Lo + 1: Hi = Hi - 1
End If
Loop Until Lo > Hi
If Hi > start Then qSortFloats start, Hi, a()
If Lo < finish Then qSortFloats Lo, finish, a()
End Sub
Sub reverseFloats (a() As _Float)
Dim i As Long, ti As Long
ReDim t(LBound(a) To UBound(a)) As _Float
ti = LBound(a)
For i = UBound(a) To LBound(a) Step -1 'load t from top to bottom of a
t(ti) = a(i)
ti = ti + 1
Next
For i = LBound(a) To UBound(a) 'reload a from t
a(i) = t(i)
Next
End Sub
'notes: REDIM the a(0) as _float to be loaded before calling Split '<<<<<<<<<<<<<<<<<<<<<<< IMPORTANT!!!!
Sub Split2Floats (mystr As String, delim As String, a() As _Float)
' I am hoping _floats will cover any number type
' bplus modifications of Galleon fix of Bulrush Split reply #13
' http://www.qb64.net/forum/index.php?topic=1612.0
' this sub further developed and tested here: \test\Strings\Split test.bas
Dim copy As String, p As Long, curpos As Long, arrpos As Long, lc As Long, dpos As Long
copy = mystr 'make copy since we are messing with mystr
'special case if delim is space, probably want to remove all excess space
If delim = " " Then
copy = RTrim$(LTrim$(copy))
p = InStr(copy, " ")
While p > 0
copy = Mid$(copy, 1, p - 1) + Mid$(copy, p + 1)
p = InStr(copy, " ")
Wend
End If
curpos = 1
arrpos = 0
lc = Len(copy)
dpos = InStr(curpos, copy, delim)
Do Until dpos = 0
a(arrpos) = Val(Mid$(copy, curpos, dpos - curpos))
arrpos = arrpos + 1
ReDim _Preserve a(arrpos + 1) As _Float
curpos = dpos + Len(delim)
dpos = InStr(curpos, copy, delim)
Loop
a(arrpos) = Val(Mid$(copy, curpos))
ReDim _Preserve a(arrpos) As _Float
End Sub
Function JoinFloats$ (a() As _Float, aStart As Long, aStop As Long, delimiter As String)
Dim i As Long, iStart, iStop, b As String
If aStart < LBound(a) Then iStart = LBound(a) Else iStart = aStart
If aStop > UBound(a) Then iStop = UBound(a) Else iStop = aStop
For i = iStart To iStop
If i = iStop Then
b = b + LTrim$(Str$(a(i)))
Else
b = b + LTrim$(Str$(a(i))) + delimiter
End If
Next
JoinFloats$ = b
End Function
Dang I must have run out of room couldn't continue in last post, so
What are libraries Part 2:
Now just copy all the Subs and Functions from this code, paste it into a New File in IDE, I named this file,
"Floats Array Tools.bm"
Now you can select all those subs and functions in bas code file and delete it! Then just put one ' single quote before the Include:
Like this now:
Code: (Select All) 'OPTION _EXPLICIT
' Build a set of Floats Array tools for handling Tomaaz challenge
' Build Floats Array Tools.bm from these
Randomize Timer
Dim i As Long, test$, TomaazTest$
TomaazTest$ = "120 135 345 345 1890 12 120 12 135 712 78 120"
'FOR i = 1 TO 500
' test$ = test$ + LTRIM$(STR$(INT(RND * 100))) + " "
'NEXT
'test$ = RTRIM$(test$)
test$ = TomaazTest$
Print "Test string: "; test$
ReDim temp(0) As _Float
Split2Floats test$, " ", temp()
uniqueFloats temp()
qSortFloats LBound(temp), UBound(temp), temp()
reverseFloats temp()
Print "Output: "; JoinFloats$(temp(), 0, 10, " ")
'$include: 'Floats Array Tools.bm'
Keep the .bm file in same folder as the bas code or worry about paths to the .bm when you include it.
Now here is the beauty of libraries, you can use that same .bm file for another program that also works with Arrays of Floats (I am keeping in same folder as .BM file)
Here I am testing a new fancy Function that will work with the Arrays of Floats that employs already developed tools in my Include file Floats Array Tools.bm
Code: (Select All) 'Test Floats Array Tools Library.bas for QB64
Print UniqueSortSlice$("120 135 345 345 1890 12 120 12 135 712 78 120", "descend", 0, 3)
Print UniqueSortSlice$("120 135 345 345 1890 12 120 12 135 712 78 120", "ascend", -10, 5) 'test join tolerance
Print UniqueSortSlice$("120 135 345 345 1890 12 120 12 135 712 78 120", "descend", 3, 16)
Print UniqueSortSlice$("1 1.1 1.11 1.1 1.11 1. 1.0 1.111 .999999999999999999999999999999999999999", "ascend", 0, 2) 'oh that's nice!!!
Function UniqueSortSlice$ (NumberStr$, ascendDescend$, SliceStart As Long, SliceEnd As Long)
ReDim temp(0) As _Float
Split2Floats NumberStr$, " ", temp()
uniqueFloats temp()
qSortFloats LBound(temp), UBound(temp), temp()
If ascendDescend$ <> "ascend" Then reverseFloats temp()
UniqueSortSlice$ = JoinFloats$(temp(), SliceStart, SliceEnd, " Tomaaz ")
End Function
'$include: 'Floats Array Tools.bm'
Keep in same folder and everything should work.
|
|
|
Help with Select Case |
Posted by: PhilOfPerth - 04-24-2022, 05:26 AM - Forum: Help Me!
- Replies (5)
|
|
Anyone help with a Select Case problem I have?
I want to select from text, using their ASCII codes, all the letters (A-Z and a-z) in two cases, and all other chars (spaces, punctuation etc.) in another case.
I've tried Case is >=65,<=90 (for the capitals) and Case is >=97, <=122 (for lower case) but it doesn't work - I think it sees all chars above and including A, then adds all letters below and including Z, so it grabs everything.
I think it needs an AND in there somewhere but I can't find a way.
|
|
|
Steve, your chicken got loose again! |
Posted by: Pete - 04-24-2022, 03:18 AM - Forum: Programs
- Replies (5)
|
|
It ended up at TheBOB's place...
Code: (Select All) '*****************************************************
'
'------------------- EGGTIMER.BAS --------------------
'
'----- Freeware by Bob Seguin Copyright (C) 2004 -----
'
'*****************************************************
DEFINT A-Z
DECLARE SUB Interval (Length!)
DECLARE SUB SetPALETTE (OnOFF)
DECLARE SUB Lay ()
DIM SHARED Box(1 TO 1900)
SCREEN 12
SetPALETTE 0
GOSUB GetSPRITES
'Borders
LINE (100, 100)-(539, 379), 8, B
LINE (110, 110)-(529, 369), 8, B
SetPALETTE 1
COLOR 8: LOCATE 20, 34: PRINT "PRESS ANY KEY..."
a$ = INPUT$(1)
Lay
COLOR 8: LOCATE 20, 30: PRINT "PRESS ANY KEY TO EXIT..."
a$ = INPUT$(1)
SYSTEM
GetSPRITES:
'Draw sprites using compressed data
MaxWIDTH = 54
MaxDEPTH = 120
x = 0: y = 0
DO
READ Count, Colr
FOR Reps = 1 TO Count
PSET (x, y), Colr
x = x + 1
IF x > MaxWIDTH THEN
x = 0
y = y + 1
END IF
NEXT Reps
LOOP UNTIL y > MaxDEPTH
'Get sprite images to array
GET (0, 54)-(54, 120), Box()
GET (0, 0)-(13, 14), Box(941)
GET (20, 1)-(34, 11), Box(1003)
GET (40, 0)-(53, 14), Box(1049)
GET (0, 15)-(32, 50), Box(1111)
LINE (0, 0)-(54, 120), 0, BF
PUT (290, 200), Box()
GET (280, 200)-(315, 234), Box(1500) 'Neck in
PUT (280, 200), Box(1111), PSET
PUT (280, 200), Box(1500), PSET
RETURN
DATA 1,15,1,7,3,15,1,7,5,15,29,0,1,15,1,7,3,15,1,7,3,15,1,7
DATA 5,0,7,15,1,7,3,15,1,8,11,0,1,8,2,3,3,7,2,3,1,8,8,0
DATA 6,15,1,7,2,15,1,7,5,0,5,15,1,7,4,15,1,7,1,8,10,0,1,3
DATA 3,7,5,15,1,7,1,3,7,0,5,15,1,7,3,15,1,7,5,0,3,15,3,7
DATA 4,15,2,3,9,0,1,3,2,7,9,15,1,3,6,0,3,15,3,7,3,15,1,7
DATA 5,0,2,7,2,15,2,7,3,15,2,3,1,7,1,15,1,8,6,0,1,8,2,7
DATA 11,15,1,8,5,0,2,7,2,15,2,7,3,15,1,3,5,0,1,15,3,7,1,15
DATA 1,7,3,15,2,3,2,15,1,3,6,0,1,3,2,7,11,15,1,3,5,0,1,15
DATA 3,7,1,15,1,7,2,15,1,7,1,8,5,0,5,7,3,15,2,3,1,7,2,15
DATA 1,7,6,0,1,3,2,7,11,15,1,3,5,0,5,7,3,15,1,7,6,0,4,7
DATA 3,15,2,3,1,7,4,15,6,0,1,3,3,7,10,15,1,3,5,0,4,7,3,15
DATA 1,7,7,0,3,7,4,15,2,3,3,15,1,7,1,3,6,0,1,8,4,7,8,15
DATA 1,7,1,8,5,0,3,7,3,15,1,7,8,0,3,7,3,15,2,3,4,7,1,3
DATA 8,0,1,3,5,7,4,15,2,7,1,3,6,0,3,7,3,15,1,8,8,0,2,7
DATA 3,15,2,3,4,7,1,3,10,0,1,3,9,7,1,3,7,0,2,7,3,15,1,7
DATA 9,0,4,15,2,3,2,7,2,3,1,8,12,0,1,8,2,3,3,7,2,3,1,8
DATA 8,0,3,15,1,7,1,8,10,0,3,15,1,3,36,0,1,15,2,7,12,0,1,7
DATA 1,15,1,3,37,0,1,7,1,8,13,0,1,7,1,8,175,0,1,4,2,0,1,4
DATA 4,0,1,4,45,0,2,4,1,0,2,4,3,0,2,4,45,0,5,4,2,0,3,4
DATA 42,0,2,4,1,0,5,4,1,0,4,4,42,0,17,4,39,0,17,4,39,0,13,4
DATA 42,0,5,15,6,4,43,0,7,15,3,4,37,0,1,14,6,0,9,15,1,4,39,0
DATA 3,14,2,0,3,15,1,4,7,15,1,8,38,0,6,14,1,15,1,4,1,0,1,4
DATA 7,15,1,8,38,0,5,14,2,15,1,4,9,15,1,8,37,0,6,14,12,15,1,8
DATA 37,0,5,14,13,15,1,8,37,0,4,14,14,15,1,8,36,0,3,14,1,7,16,15
DATA 1,8,33,0,3,14,1,6,2,7,17,15,1,8,30,0,3,14,2,0,1,4,1,3
DATA 1,7,18,15,1,7,1,3,1,8,26,0,2,14,3,0,2,4,1,3,1,7,21,15
DATA 25,0,1,14,4,0,4,4,1,7,20,15,24,0,1,14,5,0,5,4,1,7,19,15
DATA 30,0,6,4,1,7,18,15,30,0,6,4,1,8,1,7,17,15,30,0,2,4,1,0
DATA 3,4,1,0,1,8,1,7,16,15,31,0,1,4,1,0,3,4,2,0,1,8,16,15
DATA 33,0,2,4,4,0,1,7,15,15,39,0,1,8,1,7,14,15,40,0,1,8,1,7
DATA 13,15,41,0,1,7,13,15,41,0,1,8,1,7,12,15,42,0,2,7,2,15,1,7
DATA 8,15,42,0,1,3,1,7,2,15,1,7,8,15,42,0,1,8,1,7,2,15,1,7
DATA 8,15,198,0,1,4,3,0,1,4,47,0,2,4,2,0,1,4,2,0,2,4,47,0
DATA 2,4,1,0,2,4,1,0,3,4,46,0,5,4,1,0,3,4,43,0,2,4,1,0
DATA 9,4,43,0,13,4,43,0,12,4,44,0,10,4,44,0,1,8,5,15,1,3,4,4
DATA 43,0,1,8,7,15,1,3,2,4,43,0,1,8,9,15,1,3,44,0,3,15,1,4
DATA 7,15,1,8,42,0,2,14,1,15,1,4,1,0,1,4,6,15,1,7,40,0,4,14
DATA 2,15,1,4,8,15,1,8,38,0,6,14,10,15,1,7,37,0,7,14,11,15,1,8
DATA 28,0,6,8,3,0,6,14,11,15,1,7,26,0,1,8,8,15,1,8,3,0,3,14
DATA 1,7,12,15,1,8,23,0,1,8,3,15,1,7,2,15,1,7,4,15,5,0,1,14
DATA 2,7,11,15,1,7,21,0,1,8,4,15,2,7,1,15,1,7,4,15,1,8,6,0
DATA 1,4,2,7,11,15,1,7,5,0,2,7,5,15,1,7,1,3,1,8,1,0,1,8
DATA 3,7,4,15,1,7,2,15,1,7,4,15,1,8,7,0,2,4,2,7,11,15,1,7
DATA 1,3,1,0,1,7,18,15,2,7,2,15,1,7,5,15,8,0,4,4,1,7,31,15
DATA 1,7,3,15,1,7,5,15,1,8,8,0,5,4,34,15,1,7,5,15,1,3,9,0
DATA 5,4,32,15,2,7,6,15,1,8,9,0,5,4,31,15,1,7,7,15,1,3,10,0
DATA 2,4,1,0,2,4,30,15,1,7,2,15,1,7,5,15,12,0,4,4,35,15,1,7
DATA 2,15,1,3,12,0,3,4,35,15,1,7,3,15,1,8,13,0,1,4,35,15,1,7
DATA 4,15,15,0,1,7,5,15,1,7,27,15,1,7,2,15,1,7,2,15,1,8,14,0
DATA 1,7,5,15,1,7,26,15,1,7,2,15,1,7,3,15,1,3,15,0,1,7,4,15
DATA 1,7,25,15,1,7,8,15,15,0,2,7,2,15,1,7,25,15,1,7,3,15,2,7
DATA 4,15,15,0,1,3,1,7,2,15,1,7,27,15,1,7,2,15,1,7,4,15,15,0
DATA 1,8,1,7,2,15,1,7,26,15,1,7,3,15,1,7,3,15,1,7,15,0,1,8
DATA 1,7,2,15,1,7,19,15,3,7,1,15,2,7,6,15,1,7,2,15,1,7,16,0
DATA 2,7,1,15,3,7,28,15,1,7,3,15,1,7,16,0,1,3,1,7,2,15,3,7
DATA 25,15,3,7,3,15,1,7,16,0,1,8,1,7,2,15,6,7,14,15,2,7,1,15
DATA 4,7,2,15,2,7,3,15,1,3,16,0,1,8,1,7,2,15,9,7,14,15,1,7
DATA 2,15,3,7,1,15,1,7,2,15,1,7,1,8,17,0,1,3,1,7,2,15,11,7
DATA 11,15,7,7,3,15,1,7,19,0,2,7,2,15,27,7,3,15,1,7,21,0,1,7
DATA 3,15,25,7,3,15,1,7,23,0,1,7,2,15,25,7,3,15,1,8,24,0,1,7
DATA 2,15,23,7,3,15,1,7,26,0,1,7,4,15,17,7,4,15,1,7,1,8,28,0
DATA 2,7,4,15,9,7,3,14,1,7,4,15,2,7,31,0,1,3,2,7,5,15,4,7
DATA 6,14,1,15,3,7,1,8,34,0,1,3,4,7,6,15,6,14,2,7,38,0,1,8
DATA 2,3,7,7,6,14,42,0,5,14,4,0,5,14,42,0,3,14,6,0,5,14,40,0
DATA 3,14,8,0,4,14,39,0,3,14,9,0,3,14,39,0,3,14,9,0,3,14,39,0
DATA 3,14,9,0,3,14,39,0,3,14,9,0,3,14,37,0,5,14,9,0,3,14,34,0
DATA 8,14,9,0,3,14,33,0,13,14,2,0,6,14,33,0,1,14,7,0,13,14,41,0
DATA 2,14,2,0,13,14,37,0,2,14,2,0,1,14,7,0,8,14,34,0,1,14,11,0
DATA 2,14,40,0,1,14,11,0,2,14,52,0,1,14,53,0,1,14,28,0
PaletteDATA:
DATA 0,0,12,0,0,42,0,42,0,45,42,42
DATA 63,0,0,42,0,42,42,21,0,56,56,52
DATA 21,21,21,21,21,63,21,63,21,21,63,63
DATA 63,21,21,63,21,63,63,40,0,63,63,63
DropDATA:
DATA 342,236,344,237,346,238,348,239
DATA 350,241,351,244,352,248,352,252
SUB Interval (Length!)
StartTIME# = TIMER
DO
LOOP WHILE TIMER < StartTIME# + Length!
END SUB
SUB Lay
FOR Reps = 1 TO 3
PUT (280, 200), Box(1111), PSET
PLAY "MBT255O1L64cde"
Interval .1
PUT (280, 200), Box(1500), PSET
Interval .1
NEXT Reps
PUT (330, 234), Box(941), PSET
WAIT &H3DA, 8
PUT (330, 234), Box(1049), PSET
WAIT &H3DA, 8
RESTORE DropDATA
FOR Reps = 1 TO 8
READ x, y
PUT (x, y), Box(1003), PSET
WAIT &H3DA, 8
PAINT STEP(5, 3), 0
NEXT Reps
PUT (x, y), Box(1003), PSET
PLAY "MBT255L64O3a"
Interval .4
PUT (280, 200), Box(1111), PSET
PLAY "MBT255O1L64cde"
Interval .1
PUT (280, 200), Box(1500), PSET
Interval .5
END SUB
SUB SetPALETTE (OnOFF)
SELECT CASE OnOFF
CASE 0
OUT &H3C8, 0
FOR n = 1 TO 48
OUT &H3C9, 0
NEXT n
CASE 1
RESTORE PaletteDATA
OUT &H3C8, 0
FOR n = 1 TO 48
READ Intensity
OUT &H3C9, Intensity
NEXT n
END SELECT
END SUB
Pete
|
|
|
Pentacle Flux Capaciter Mod 2: Dancing Man |
Posted by: bplus - 04-23-2022, 11:01 PM - Forum: Programs
- Replies (4)
|
|
Code: (Select All) 'Pentacle Flux Capacitor 2.bas for QB64 fork 2017-08-23
'translated from: Pentacle Flux Capacitor 2.txt for JB (B+=MGA) 2017-08-23
' updated 2019-09-05 with cleaner more random blackouts, er..., ah, drama!
Randomize Timer
Const xmax = 800
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
_Title "Pentacle Flux Capacitor #2: Dancing Man"
Common Shared xc, yc, dist, tp(), tp2()
xc = xmax / 2
yc = ymax / 2 + 20
Dim tp(4, 1), tp2(4, 1)
blackout& = _NewImage(xmax, ymax, 32)
_Dest blackout&
Line (0, 0)-(xmax, ymax), &H99000000, BF
PFC& = _NewImage(xmax, ymax, 32)
_Dest PFC&
drawPFC
_Dest 0
While 1
_PutImage , PFC&, 0
_Display
_PutImage , blackout&, 0
_Display
_Delay Rnd * 80 / 1000
Lightning xc, yc - 90, xc, yc + 10, 135
For i = 0 To 4
xe = tp2(i, 0)
ye = tp2(i, 1)
d = rand(.1 * dist, .7 * dist)
Select Case i
Case 0
Lightning xc, yc - 90, xe, ye, d
Lightning xc, yc - 90, xe, ye, d
Case 1, 4
Lightning xc, yc - 70, xe, ye, d
Case 2, 3
Lightning xc, yc + 10, xe, ye, d
End Select
Next
_Display
_Delay Rnd * 40 / 1000 + 20 / 1000
Wend
Sub drawPFC
'3 main points for array tp()
pRadius = 40: cRadius = 1.5 * pRadius
a3 = _Pi(2 / 5): r = ymax / 2 - cRadius
ao = _Pi(-1 / 2): a = ao
For rr = r To 0 Step -10
midInk 255, 255, 255, 0, 0, 128, rr / r
CircleFill xc, yc, rr
Next
For i = 0 To 4
tp(i, 0) = xc + r * Cos(a)
tp(i, 1) = yc + r * Sin(a)
For rr = cRadius To pRadius Step -1
Color _RGB((rr - pRadius) / (cRadius - pRadius) * 255 * (cRadius - rr + pRadius) / cRadius, 0, 0)
xx = tp(i, 0): yy = tp(i, 1)
CircleFill xx, yy, rr
Next
a = a + a3
Next
xx = tp(0, 0): yy = tp(0, 1)
dist = distance##(xx, yy, xc, yc)
For pnt = 0 To 4
For dis = 0 To .5 * dist Step 10
dGray = 255 * dis / dist
xx = tp(pnt, 0): yy = tp(pnt, 1)
midpoint xx, yy, xc, yc, dis / dist, midx, midy
For r = pRadius * (dist - dis) / dist To 0 Step -1
midInk dGray, dGray, dGray, 255, 255, 255, (pRadius - r) / pRadius
CircleFill midx, midy, r
Next
Next
tp2(pnt, 0) = midx
tp2(pnt, 1) = midy
Next
End Sub
Sub Lightning (x1, y1, x2, y2, d)
If d < 5 Then
Color _RGB(225, 225, 245)
Line (x1, y1)-(x2, y2)
Else
mx = (x2 + x1) / 2
my = (y2 + y1) / 2
mx = mx + -.5 * Rnd * d * .4 * rand&&(-2, 2)
my = my + -.5 * Rnd * d * .4 * rand&&(-2, 2)
Lightning x1, y1, mx, my, d / 2
Lightning x2, y2, mx, my, d / 2
End If
End Sub
'Steve McNeil's
Sub CircleFill (CX As Long, CY As Long, R As Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , 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), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
Sub midpoint (x1, y1, x2, y2, fraction, midx, midy)
midx = (x2 - x1) * fraction + x1
midy = (y2 - y1) * fraction + y1
End Sub
Sub midInk (r1, g1, b1, r2, g2, b2, fr)
Color _RGB(r1 + (r2 - r1) * fr, g1 + (g2 - g1) * fr, b1 + (b2 - b1) * fr)
End Sub
Function distance## (x1##, y1##, x2##, y2##)
distance## = ((x1## - x2##) ^ 2 + (y1## - y2##) ^ 2) ^ .5
End Function
Function rand&& (lo&&, hi&&)
rand&& = Int(Rnd * (hi&& - lo&& + 1)) + lo&&
End Function
|
|
|
|