Welcome, Guest |
You have to register before you can post on our site.
|
Latest Threads |
лучшие песни медляки слуш...
Forum: Petr
Last Post: WillieTop
Today, 02:21 AM
» Replies: 0
» Views: 14
|
пинк слушать онлайн беспл...
Forum: SMcNeill
Last Post: WillieTop
Today, 02:20 AM
» Replies: 0
» Views: 15
|
скачать музыку российскую...
Forum: madscijr
Last Post: WillieTop
Today, 02:18 AM
» Replies: 0
» Views: 15
|
нежная музыка mp3 скачать
Forum: Keybone
Last Post: WillieTop
Today, 02:17 AM
» Replies: 0
» Views: 14
|
лучшая песня слушать онла...
Forum: bplus
Last Post: WillieTop
Today, 02:16 AM
» Replies: 0
» Views: 16
|
пикник слушать онлайн луч...
Forum: Spriggsy
Last Post: WillieTop
Today, 02:15 AM
» Replies: 0
» Views: 15
|
какая сейчас популярная м...
Forum: RhoSigma
Last Post: WillieTop
Today, 02:14 AM
» Replies: 0
» Views: 13
|
хит лета 2019 музыка на т...
Forum: Christmas Code
Last Post: WillieTop
Today, 02:12 AM
» Replies: 0
» Views: 15
|
бесплатная музыка mp3 рег...
Forum: Works in Progress
Last Post: WillieTop
Today, 02:11 AM
» Replies: 0
» Views: 14
|
лучшие хиты музыка 2018 2...
Forum: Utilities
Last Post: WillieTop
Today, 02:10 AM
» Replies: 0
» Views: 16
|
|
|
If Print |
Posted by: Dimster - 03-03-2023, 06:33 PM - Forum: Help Me!
- Replies (13)
|
 |
Was there a time in Basic when IF was simply followed by a Print statement? Seems to me I did see some code like :
If A Print "...." but the wiki indicates the only time an IF condition is not followed by THEN is the use of GOTO.
|
|
|
_SndOpenRaw bug? SOLVED! |
Posted by: Petr - 03-03-2023, 06:30 PM - Forum: Announcements
- Replies (2)
|
 |
Hello. Working with the new excellent _SndNew command, I discovered that _SndGetPos can't find the time in the track that is created by the _SndNew command, so I played that field with the _SndRaw command, which already has a perfectly fixed stereo. On this occasion, I discovered that the SndLen command works as it should only if _SndRaw does not have a third parameter used for a pointer to _SndOpenRaw. If the third parameter is used, then _SndLen does not work as it should and in that case the sound will be stored in memory faster than expected. I also found that when using the third parameter of the _SndRaw command, the difficulty increases sharply, and then (on my weak laptop, it is enough in the attached program on line 53 to disable the condition of printing to the screen at every thousandth step, and the sound is played as jerking and tearing, simply unlistenable ). But if the third parameter of _SndRaw is not used, you can print to the screen at every step and everything runs perfectly.
Code: (Select All) 'example show _SNDOPENRAW bug
Screen _NewImage(800, 600, 32)
test& = _SndOpen("0.mp3")
Print "Track lenght:"; _SndLen(test&)
Dim As Long RawS
RawS = _SndOpenRaw
Print "In this source code: First try this, PlaySound calculate correct time and _SndRawLen works correctly."
Print "Then comment row 10, 45, 48 and uncomment row 11, 46, 49 and run program again."
PlaySound test&, 1 '
'PlaySound test&, RawS
Sub PlaySound (handle As Long, RAWSND As Long)
Dim SampleData As _MEM
Dim channels As _Unsigned _Byte
Dim sampL As Single, sampR As Single
Dim i As _Offset
channels = SndChannels(handle)
SampleData = _MemSound(handle, 0)
If SampleData.SIZE = 0 Then
Print "PlaySound: Sample data array is empty."
Exit Sub
End If
Do Until i = SampleData.SIZE - SampleData.ELEMENTSIZE
Select Case channels
Case 1
Select Case SampleData.TYPE
Case 260: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Single) ' 32-bit floating point
Case 132: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Long) / 2147483648 ' 32-bit integer
Case 130: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Integer) / 32768 ' 16-bit integer
Case 1153: sampL = (_MemGet(SampleData, SampleData.OFFSET + i, _Unsigned _Byte) - 128) / 128 ' 8-bit unsigned integer
End Select
Case 2
Select Case SampleData.TYPE
Case 260: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Single): sampR = _MemGet(SampleData, SampleData.OFFSET + i + SampleData.ELEMENTSIZE / 2, Single) ' 32-bit floating point
Case 132: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Long) / 2147483648: sampR = _MemGet(SampleData, SampleData.OFFSET + i + SampleData.ELEMENTSIZE / 2, Long) / 2147483648 ' 32-bit integer
Case 130: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Integer) / 32768: sampR = _MemGet(SampleData, SampleData.OFFSET + i + SampleData.ELEMENTSIZE / 2, Integer) / 32768 ' 16-bit integer
Case 1153: sampL = (_MemGet(SampleData, SampleData.OFFSET + i, _Unsigned _Byte) - 128) / 128: sampR = (_MemGet(SampleData, SampleData.OFFSET + i + SampleData.ELEMENTSIZE / 2, _Unsigned _Byte) - 128) / 128 ' 8-bit unsigned integer
End Select
End Select
If channels Mod 2 = 0 Then
_SndRaw sampL, sampR 'stereo
'_SndRaw sampL, sampR, RAWSND 'stereo
Else
_SndRaw sampL, sampL 'mono = left channel in both speakers
' _SndRaw sampL, sampL, RAWSND 'mono = left channel in both speakers
End If
i = i + SampleData.ELEMENTSIZE
Locate 20
If i Mod 1000 = 0 Then Print "PlaySound: Track time:"; CSng(ConvertOffset(i / SampleData.ELEMENTSIZE) / _SndRate); "[sec] "
Do Until _SndRawLen < 0.1: Loop
Loop
_MemFree SampleData
End Sub
Function ConvertOffset&& (value As _Offset)
$Checking:Off
Dim m As _MEM 'Define a memblock
m = _Mem(value) 'Point it to use value
$If 64BIT Then
'On 64 bit OSes, an OFFSET is 8 bytes in size. We can put it directly into an Integer64
_MEMGET m, m.OFFSET, ConvertOffset&& 'Get the contents of the memblock and put the values there directly into ConvertOffset&&
$Else
'However, on 32 bit OSes, an OFFSET is only 4 bytes. We need to put it into a LONG variable first
_MemGet m, m.OFFSET, temp& 'Like this
ConvertOffset&& = temp& 'And then assign that long value to ConvertOffset&&
$End If
_MemFree m 'Free the memblock
$Checking:On
End Function
' This function returns the number of sound channels for a valid sound "handle"
' Note that we are assuming that the sound can have at most 2 channels
' In reality miniaudio can handle sounds with more than 2 channels
' 2 = stereo, 1 = mono, 0 = error
Function SndChannels~%% (handle As Long)
Dim SampleData As _MEM
' Check if the sound is valid
SampleData = _MemSound(handle, 0)
If SampleData.SIZE = 0 Then
Print "SndChannels: MemSound return ZERO for audio data size!"
Exit Function
End If
' Check the data type and then decide if the sound is stereo or mono
Select Case SampleData.TYPE
Case 260 ' 32-bit floating point
If SampleData.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf SampleData.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 132 ' 32-bit integer
If SampleData.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf SampleData.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 130: ' 16-bit integer
If SampleData.ELEMENTSIZE = 2 Then
SndChannels = 1
ElseIf SampleData.ELEMENTSIZE = 4 Then
SndChannels = 2
End If
Case 1153: ' 8-bit unsigned integer
If SampleData.ELEMENTSIZE = 1 Then
SndChannels = 1
ElseIf SampleData.ELEMENTSIZE = 2 Then
SndChannels = 2
End If
End Select
_MemFree SampleData
End Function
|
|
|
The Hypotrochoid-ISH Show |
Posted by: CharlieJV - 03-03-2023, 02:00 PM - Forum: QBJS, BAM, and Other BASICs
- Replies (6)
|
 |
https://basicanywheremachine.neocities.o...choid_show
At first I was going to try a little something for alpha blending to make the thing look more like a transparent tube.
Then I got more interested in the "parts" of the tube than in the tube itself. Seeing as I particularly enjoy seeing the details of the whole, I had to add a little space between the circles to see them.
Then I was getting a sense of elongation of the tube, and I wanted to see the elongation motion. The randomness of the circles gives a little bit of an illusion of the circles moving, so that was good enough for this kid.
|
|
|
date type? |
Posted by: madscijr - 02-28-2023, 08:14 AM - Forum: General Discussion
- Replies (20)
|
 |
Do we have a native date/time type, with all the associated functions (dateadd, datediff, date to UNIX epoch & vice-versa, timezone operations, etc.) or has anyone built an equivalent library in QB64PE or related?
|
|
|
Why is in this loop memory leak? |
Posted by: Petr - 02-27-2023, 02:55 PM - Forum: Announcements
- Replies (13)
|
 |
Code: (Select All) img& = _ScreenImage
Dim P(320, 240) As Long
Dim C As _Unsigned Long, W As Long
V& = _NewImage(320, 240, 32)
_PutImage , img&, V&
For Y = 0 To 239
For X = 0 To 319
_Source V&
C = Point(X, Y)
W& = _NewImage(1, 1, 32)
_Dest W&
_Source W&
PSet (0, 0), C
P(X, Y) = _CopyImage(W&, 33)
_Dest 0
_FreeImage W&
Next X, Y
'creating hardware pixels done...
Beep
Screen _NewImage(320, 240, 32)
_FullScreen
'Do
'Loop
'if is my program stop here, in neverending loop, memory leak not occur.
Do
For yy = 0 To 239
For xx = 0 To 319
X3D = ((xx - 160) / 160) * 3
Y3D = ((yy - 120) / 120) * 3
_PutImage (xx, yy), P(xx, yy)
Next
_Display
Next
' _Display
' _Limit 20
Loop
'RUN THIS UNCOMPLETE PROGRAM
'look at the task manager, how our free memory is disappearing beautifully, despite the fact that this loop has no other task than to use the memory that was previously allocated.
|
|
|
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
57 kB
|
|
|
|