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

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 325
» Latest member: WillieTop
» Forum threads: 1,757
» Forum posts: 17,918

Full Statistics

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.

Print this item

  _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

Print this item

  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.

Print this item

  Blending two images
Posted by: Ikerkaz - 02-28-2023, 09:21 AM - Forum: Help Me! - Replies (9)

Hi to all Smile

I would like to blend two identical images. I am doing a space game, and I want to show some kind of warp flash in the ship engines Wink

I have a flash sprite (PNG with transparency), and I want to paint two of them, one very close to the other.

But the image blending is not showing the way I like... Sad

This is what QB64 does:
[Image: 1.png]

I would like to paint something like this (I made the example in photoshop):
[Image: 2.png]

Is there any way to paint this images as the second example?

Thank yoy very much Smile

Print this item

  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?

Print this item

  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.

Print this item

  INSTR bug?
Posted by: GTC - 02-27-2023, 12:48 PM - Forum: Help Me! - Replies (3)

Edit: Bah, never mind

Print this item

  Scramble (arcade game remake)
Posted by: RokCoder - 02-26-2023, 10:56 PM - Forum: Programs - Replies (74)

Having finished Galaga I decided to try converting my all time favourite arcade game, Scramble. It's gone pretty well I think!

Controls are arrow keys to move and A/Z to fire and bomb.

The ZIP file contains scramble.bas along with a subfolder called assets which contains all the sound effects, graphics, etc. After building the project, the EXE must reside in the same folder as the BAS file. It accesses the assets folder relatively so won't find it if the EXE is in the wrong place.

.zip   scramble.zip (Size: 156.55 KB / Downloads: 92)

Hope you have fun!

               

Print this item

  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

Print this item

  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] 57 kB

Print this item