Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 308
» Latest member: Donaldvem
» Forum threads: 1,741
» Forum posts: 17,901

Full Statistics

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...Wink 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

Print this item

  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


   

Print this item

  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

Print this item

  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

Print this item

  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

Print this item

  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.

Print this item

  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.

Print this item

  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

Print this item

  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

Print this item

  QB64-lite
Posted by: Keybone - 04-23-2022, 10:57 PM - Forum: Works in Progress - Replies (16)

QB64-lite:

For the past 7-8 hours or so I have been working at creating a minimal version of qb64.
I can't even count how many recompiles ive done. It recompiles itself, so it works.

45644 lines of code (down from 52662).

It only works on linux. no mac or windows support.
it has no debug, or wiki, or help system.
it has none of the built in tools.

it may still have traces left of those things but they will be deleted.

this is all one big .bas file. put it in your qb64/sources folder along side qb64.bas, and compile.
It might be a little faster since there is less in it, i cant back that up though.

Well enjoy. and give me feedback!  Smile



Attached Files
.bas   qb64o2.bas (Size: 1.82 MB / Downloads: 77)
Print this item