| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 714
» Latest member: HenryG
» Forum threads: 3,569
» Forum posts: 31,909
Full Statistics
|
| Latest Threads |
QB64PE v 4.4.0
Forum: Announcements
Last Post: madscijr
5 hours ago
» Replies: 8
» Views: 682
|
4x4 Square Elimination Pu...
Forum: bplus
Last Post: bplus
9 hours ago
» Replies: 12
» Views: 414
|
Container Data Structure
Forum: Utilities
Last Post: bplus
9 hours ago
» Replies: 3
» Views: 131
|
Accretion Disk
Forum: Programs
Last Post: bplus
9 hours ago
» Replies: 11
» Views: 295
|
QBJS v0.10.0 - Release
Forum: QBJS, BAM, and Other BASICs
Last Post: Unseen Machine
Today, 04:14 AM
» Replies: 13
» Views: 1,300
|
Arrays inside Types?
Forum: General Discussion
Last Post: hsiangch_ong
Today, 03:24 AM
» Replies: 47
» Views: 1,451
|
Has anybody experience wi...
Forum: Help Me!
Last Post: Rudy M
Yesterday, 08:47 AM
» Replies: 31
» Views: 1,940
|
Sorting numbers - FiliSor...
Forum: Utilities
Last Post: PhilOfPerth
03-11-2026, 12:48 AM
» Replies: 11
» Views: 378
|
Quick Sort for variable l...
Forum: Utilities
Last Post: SMcNeill
03-10-2026, 03:14 PM
» Replies: 3
» Views: 110
|
Ready for Easter!
Forum: Holiday Code
Last Post: bplus
03-10-2026, 12:15 PM
» Replies: 0
» Views: 61
|
|
|
| Proggies |
|
Posted by: bplus - 04-24-2022, 04:02 PM - Forum: bplus
- Replies (243)
|
 |
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://qb64phoenix.com/forum/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'
|
|
|
|
| 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
|
|
|
|
| Vote on the default theme! |
|
Posted by: admin - 04-23-2022, 10:25 PM - Forum: General Discussion
- Replies (27)
|
 |
Down at the bottom right corner of a page, you'll see a little box and a GO button. Those are all the themes available for the forums here, and are all I ever plan to have for the forums here. There's plenty for folks to choose from to choose one that suits them best. The question is: Which one does everyone like best? Let me know in the poll, and I'll set the most popular as the default, while everyone else can set their personal theme to whatever they like the most.
|
|
|
|
|
