| 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,034
|
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
|
|
|
| Program to calculate pi |
|
Posted by: Kernelpanic - 02-26-2023, 10:18 PM - Forum: Programs
- Replies (8)
|
 |
Pete would love the program. For others, one or the other might be of interest.
Code: (Select All) '===========================================================================
' Subject: CALCULATE PI Date: 01-05-97 (07:59)
' Author: Jason Stratos Papadopoulos Code: QB, QBasic, PDS
' Origin: comp.lang.basic.misc Packet: ALGOR.ABC
' Mit Locate und mit Color Ausgabe angepasst - 26. Feb. 2023
'===========================================================================
DECLARE SUB PrintOut (sum%(), words%)
DECLARE SUB Multiply (term%(), words%, mult&, firstword%)
DECLARE SUB Divide (term%(), words%, denom&, firstword%)
DECLARE SUB Add (sum%(), term%(), words%, sign%, firstword%)
DECLARE SUB FastDivide (term%(), words%, denom&)
'Program to calculate pi, version 2.0
'The algorithm used is Gregory's series with Euler acceleration.
'This program uses the optimal Euler 2/3 rule: rather than use Euler's
'series for all the terms, compute instead 1/3 of the terms using
'Gregory's series and the rest using Euler's. It can be shown that
'each term in this compound series cuts the error by a factor of 3,
'while using only Euler's series has each term cut the error by a
'factor of 2. This is a major timesaver: it reduces the number of terms
'to be added up by over 35%, and of the terms that remain 1/3 can
'be crunched out faster than normal! The code also includes some tricks
'to speed things up (like reducing the size of the arrays Euler's series
'works on).
'
'Converging faster also means more digits can be computed. Some tests
'show the program is capable of computing about 51,000 digits of pi,
'and is quite fast if compiled (5000 digits in about 90 seconds on
'a 486 66MHz computer). I'd be grateful if someone can help me code
'the Divide and FastDivide SUBs in assembly, which can probably make
'the program twice as fast. Comments or questions to jasonp@wam.umd.edu
DefInt A-Z
'----------- Intro Screen by (c) Marc Antoni, Oct. 2, 2000 -----------------
Color 7, 0
Cls
Locate 10: Print " Pi-Berechnung nach Euler (1707 - 1783)"
Locate 12: Print " (Pi^2)/8 = 1/1^2 + 1/3^2 + 1/5^2 + 1/7^2 + ..."
Locate 20: Print " Programming by Jason Stratos Papadopoulos"
Locate 24: Print " ... weiter mit beliebiger Taste"
Do: Loop While InKey$ = ""
'----------- End of Intro Screen -------------------------------------------
Cls
Locate 2, 2
Input "How many digits: ", digits&
words = digits& \ 4 + 4
terms& = CLng(digits& / .477) \ 3 + 1
If terms& Mod 2 > 0 Then terms& = terms& + 1
Dim sum(words), term(words)
'Gregory's Series-------
Locate CsrLin + 1, 2
Print Time$: sum(1) = 1: denom& = 3: sign = -1
For x& = 1 To terms& - 1
Call FastDivide(term(), words, denom&)
Call Add(sum(), term(), words, sign, 2)
denom& = denom& + 2: sign = -sign
Next x&
'Euler's Acceleration---
firstword = 2: x& = 1
Call FastDivide(term(), words, 2 * denom&)
Do Until firstword = words
denom& = denom& + 2
Call Add(sum(), term(), words, sign, firstword)
Call Divide(term(), words, denom&, firstword)
Call Multiply(term(), words, x&, firstword)
If term(firstword) = 0 Then firstword = firstword + 1
x& = x& + 1
Loop
'Finish up--------------
Call Add(sum(), term(), words, sign, firstword)
Call Multiply(sum(), words, 4, 1)
Call PrintOut(sum(), words)
Do: Loop While InKey$ = ""
End
'--------------------------------------------------------------------
Sub Add (sum(), term(), words, sign, firstword)
If sign = 1 Then
'add it on
For x = words To firstword Step -1
sum(x) = sum(x) + term(x)
If sum(x) >= 10000 Then
sum(x - 1) = sum(x - 1) + 1
sum(x) = sum(x) - 10000
End If
Next x
Else
'subtract it off
For x = words To firstword Step -1
sum(x) = sum(x) - term(x)
If sum(x) < 0 Then
sum(x - 1) = sum(x - 1) - 1
sum(x) = sum(x) + 10000
End If
Next x
End If
End Sub
'-------------------------------------------------------------------
Sub Divide (term(), words, denom&, firstword)
For x = firstword To words
dividend& = remainder& * 10000 + term(x)
quotient = dividend& \ denom&
term(x) = quotient
remainder& = dividend& - quotient * denom&
Next x
End Sub
'------------------------------------------------------------------------
Sub FastDivide (term(), words, denom&)
'not really a fast divide, but there are fewer operations
'since dividend& below doesn't have term(x) added on (always 0)
remainder& = 1
For x = 2 To words
dividend& = remainder& * 10000
quotient = dividend& \ denom&
term(x) = quotient
remainder& = dividend& - quotient * denom&
Next x
End Sub
'---------------------------------------------------------------------
Sub Multiply (term(), words, mult&, firstword)
For x = words To firstword Step -1
product& = mult& * term(x) + carry&
term(x) = product& Mod 10000
carry& = (product& - term(x)) \ 10000
Next x
End Sub
'------------------------------------------------------------------
Sub PrintOut (sum(), words)
'Print:
Locate CsrLin + 1, 2
Color 4, 0
Print "pi=3."
'Wieder zuruecksetzen
Color 7, 0
i = 2
Do Until i = words - 1
j = sum(i)
If j > 999 Then
Print " " + Right$(Str$(j), 4);
ElseIf j > 99 Then
Print " 0" + Right$(Str$(j), 3);
ElseIf j > 9 Then
Print " 00" + Right$(Str$(j), 2);
Else
Print " 000" + Right$(Str$(j), 1);
End If
If (i - 1) Mod 15 = 0 Then Print
i = i + 1
Loop
'Print: Print:
Locate CsrLin + 2, 2
Print Time$
End Sub
|
|
|
| Atomic Heart |
|
Posted by: DANILIN - 02-26-2023, 07:13 PM - Forum: Programs
- Replies (2)
|
 |
Atomic Heart
Day before, I transferred my program to qb64
originally created in C#
Visualization helps to understand
how is desired unusual color formed
depending on the parameters Red Green Blue
Code: (Select All) e = 50: d = -e: p = .001 ' atomicheart.bas
w = 400: h = 630: Screen _NewImage(w, h, 32)
d = d + e: For x = 90 To 256: For y = d To d + e
PSet (x - 90, y), _RGB32(x, 0, 0):
Next: _Delay p: Next
d = d + e: For x = 90 To 256: For y = d To d + e
PSet (x - 90, y), _RGB32(0, x, 0):
Next: _Delay p: Next
d = d + e: For x = 90 To 256: For y = d To d + e
PSet (x - 90, y), _RGB32(0, 0, x):
Next: _Delay p: Next
'//////////////
d = d + e: For x = 255 To 90 Step -1: For y = d To d + e
PSet (x - 90, y), _RGB32(0, x, x):
Next: _Delay p: Next
d = d + e: For x = 255 To 90 Step -1: For y = d To d + e
PSet (x - 90, y), _RGB32(x, 0, x):
Next: _Delay p: Next
d = d + e: For x = 255 To 90 Step -1: For y = d To d + e
PSet (x - 90, y), _RGB32(x, x, 0):
Next: _Delay p: Next
'//////////////
d = d + e: For y = d + e To d Step -1: For x = 40 To 206
PSet (x - 40, y), _RGB32(205 - x, x, 0):
Next: _Delay p * 2: Next
d = d + e: For y = d + e To d Step -1: For x = 40 To 206
PSet (x - 40, y), _RGB32(x, 205 - x, 0):
Next: _Delay p * 3: Next
d = d + e: For y = d + e To d Step -1: For x = 40 To 206
PSet (x - 40, y), _RGB32(205 - x, 0, x):
Next: _Delay p * 5: Next
d = d + e: For y = d To d + e: For x = 205 To 40 Step -1
PSet (x - 40, y), _RGB32(0, x, 205 - x)
Next: _Delay p * 7: Next
d = d + e: For y = d To d + e: For x = 205 To 40 Step -1
PSet (x - 40, y), _RGB32(x, 0, 205 - x)
Next: _Delay p * 5: Next
d = d + e: For y = d To d + e: For x = 205 To 40 Step -1
PSet (x - 40, y), _RGB32(0, 205 - x, x)
Next: _Delay p * 8: Next
e = 206: d = -e
d = d + e: For x = 30 To 256: For y = 50 To 256
PSet (136 + x, d + y - 50), _RGB32(x, 0, y)
Next: _Delay p * 5: Next
d = d + e: For x = 255 To 30 Step -1: For y = 50 To 256
PSet (136 + x, d + y - 50), _RGB32(0, x, y)
Next: _Delay p * 3: Next
d = d + e: For y = 255 To 50 Step -1: For x = 255 To 30 Step -1
PSet (136 + x, d + y - 50), _RGB32(x, y, 0)
Next: _Delay p * 2: Next
Plus, I urge to include name
in first lines of program or in title
![[Image: colorcs.gif]](http://kenokeno.ucoz.ru/gif/colorcs.gif) 57 kB
|
|
|
|
| Get Next Filename into a string (or array) |
|
Posted by: GTC - 02-26-2023, 12:38 PM - Forum: Programs
- Replies (2)
|
 |
I need to open each of the files present in a given folder/directory and process them one by one.
A crude way would be to use DIR to create a text file containing all of the file names, then read that to obtain each of the filenames, line by line.
However, I'm wondering if QB64 has a function to Get Next Filename into a string that can be called in a loop until there are no more files in the directory?
|
|
|
|
| Paint 2 (for coloring) |
|
Posted by: Petr - 02-26-2023, 10:25 AM - Forum: Petr
- Replies (1)
|
 |
As you know, if you need to color an object, for example a rectangle, but it have its borders not colored with the same color, you cannot use the Paint statement because the color will spread everywhere. This version solves this and with this program you can color solids even though they have different colored borders. This problem is solved using mask image, this version is just for 32 bit images.
Code: (Select All) Screen _NewImage(1024, 768, 32)
$Color:32
Do
Cls , Red
For c = 1 To 40
Circle (Rnd * 980, Rnd * 740), Rnd * 100 + 10, _RGB32(25 * Rnd, 75 * Rnd, 127 * Rnd)
X = Rnd * 1024
Y = Rnd * 768
Lwidth = Rnd * 100
Lheight = Rnd * 100
Line (X, Y)-(X + Lwidth, Y + Lheight), _RGB32(55 * Rnd, 145 * Rnd, 255 * Rnd), BF
Next
_Delay .1
_MouseMove 512, 384
Do Until K& = 27
K& = _KeyHit
While _MouseInput: Wend
If _MouseButton(1) Then Paint2 _MouseX, _MouseY, DarkBlue
Loop
K& = 0
Loop
Sub Paint2 (x, y, c~&)
W = _Width: H = _Height
Virtual = _NewImage(W, H, 32)
Dim m As _MEM, n As _MEM, Bck As _Unsigned Long
m = _MemImage(_Source)
n = _MemImage(Virtual)
'create mask (2 color image)
position& = (y * W + x) * 4
_MemGet m, m.OFFSET + position&, Bck
Clr2~& = _RGB32(_Red32(Bck) - 1, _Green32(Bck) - 1, _Blue32(Bck) - 1)
D& = 0
Do Until D& = n.SIZE
CLR~& = _MemGet(m, m.OFFSET + D&, _Unsigned Long)
If CLR~& = Bck~& Then _MemPut n, n.OFFSET + D&, CLR~& Else _MemPut n, n.OFFSET + D&, Clr2~&
D& = D& + 4
Loop
d = _Dest
_Dest Virtual
Paint (x, y), c~&, Clr2~&
_Dest d
_ClearColor Clr2~&, Virtual
_PutImage , Virtual, d
_MemFree m
_MemFree n
_FreeImage Virtual
End Sub
|
|
|
|
| ZBLIST -- Buerg's LIST reincarnated |
|
Posted by: GTC - 02-26-2023, 08:25 AM - Forum: Utilities
- Replies (3)
|
|
I'm dating myself here. Those who were programming during the DOS era will likely recall Vern Buerg's fantastic shareware directory and file utility called LIST. Once you used it you could not live without it.
Over the years many people petitioned VB to create a 32-bit version of it, but he was disinclined to do that. Vern died in December 2009 at the age of 62.
Anyway, thankfully for those of us who love LIST, circa 2016 Clark Woodworth wrote a new incarnation of it called ZBLIST.
It has a similar look and feel to the classic LIST and includes new features:
http://www.bizer.com/zblist/zblistd/
|
|
|
|
| Fixup 2 Gears |
|
Posted by: bplus - 02-25-2023, 06:34 PM - Forum: Programs
- Replies (7)
|
 |
As posted at BASIC4ALL:
Code: (Select All) Screen 12: For N = 0 To 15: Palette N, N * 263172: Next N
For Z = 0 To 100 Step .25: For A = 0 To 6.2831853 Step .001
R = 100 + Cos(20 * A + Z / 20) * 15
X1 = Cos(A) * R + 220: Y1 = Sin(A) * R / 3 + 240 - Z / 2
R = 50 + Sin(-10 * A + Z / 20) * 15
X2 = Cos(A) * R + 370: Y2 = Sin(A) * R / 3 + 240 - Z / 2
PSet (X1, Y1), Z * .125 + 2.5: PSet (X2, Y2), Z * .125 + 2.5
If Z = 100 Then Line (220, 240 - Z / 2)-(X1, Y1), 8: Line (370, 240 - Z / 2)-(X2, Y2), 5
Next A: Next Z
B+ Mods
Code: (Select All) _Title "Fixed 2 Turning Gears mod B+ 2023-02-25"
Screen 12: For N = 0 To 15: Palette N, N * 263172: Next N
Do: Cls: For Z = 0 To 20 Step .5: For A = 0 To 6.2831853 Step .001
R = 100 + Cos(20 * A) * 15: X1 = Cos(A + ao) * R + 220: Y1 = Sin(A + ao) * R / 3 + 240 - Z / 2
R = 50 + Sin(-10 * A) * 15: X2 = Cos(A - 2 * ao) * R + 390: Y2 = Sin(A - 2 * ao) * R / 3 + 240 - Z / 2
PSet (X1, Y1), Z * .125 + 2.5: PSet (X2, Y2), Z * .125 + 2.5
If Z = 20 Then Line (220, 240 - Z / 2)-(X1, Y1), 8: Line (370, 240 - Z / 2)-(X2, Y2), 5
Next A: Next Z: _Display: _Limit 200: ao = ao + .04: Loop
|
|
|
|
| Tokenizer in QB64 |
|
Posted by: aurel - 02-25-2023, 02:52 PM - Forum: Programs
- Replies (12)
|
 |
I am trying to modify my tokenizer written in FB to QB64
and i am getting error ..what i am doing wrong ?
Code: (Select All) 'tokenizer in QB (fb) by Aurel
'INT startTime ,endTime: float procTime ' GetTickCount -timer init
declare function tokenizer( src as string) as integer
declare function run_tokenizer(inputCode as string) as integer
const tkNULL=0, tkPLUS=1, tkMINUS=2, tkMULTI=3, tkDIVIDE=4
const tkCOLON=5, tkCOMMA=6, tkLPAREN=7, tkRPAREN=8, tkLBRACKET=9, tkRBRACKET=10
const tkIDENT = 11 , tkNUMBER = 12 , tkQSTRING = 13, tkCOMMAND =14 ,tkEOL = 15
const tkEQUAL = 16, tkMORE = 17, tkLESS = 18, tkAND = 19, tkOR = 20, tkNOT = 21
const tkHASH=22 , tkSSTR=23, tkMOD=24 , tkSEMI=25, tkDOT=26, tkLBRACE=27, tkRBRACE=28
const tkQUEST=29, tkMONKEY=30 , tkBACKSLAH=31, tkPOWUP=32 ,tkAPOSTR=33 , tkTILDA=34
Dim shared tokList(1024) As string 'token array
Dim shared typList(1024) As integer 'token type array
Dim shared p As Long : p=1
Dim shared start as Long : start = 1
Dim shared tp as long
Dim shared tn as long
Dim shared n as long
Dim shared ltp as long : lpt = 1
Dim shared nTokens As long 'nTokens -> number of tokens
Dim shared lineCount As integer
Dim shared Lpar as integer
Dim shared Rpar as integer
Dim shared Lbrk as integer
Dim shared Rbrk as integer
Dim shared tokerr as integer
Dim shared codeLen as integer
Dim shared code As String
Dim shared chs As String
Dim shared tch As String
Dim shared tk As String
Dim shared crlf As String
Dim shared bf As String
Dim shared ntk As String
crlf = chr$(13) + chr$(10)
'test string .......................................
Dim test as string : test = "func tokenizer in QB64"
'...................................................
'call fn tokenizer()
call tokenizer(test)
' *** MAIN TOKENIZER FUNCTION ***
FUNCTION tokenizer& (src as string)
print "tokenizer run:" + src
lineCount=0:ltp=start : nTokens = 0
tokenizer& = 0
END FUNCTION
do
loop until multikey(27)
|
|
|
|
|
