Posted by: Petr - 03-04-2023, 08:28 PM - Forum: Petr
- Replies (2)
On purpose. Who remembers my first program, back on the old
Galleon forum?
Hey guys, don't expect any physics! This was written purely for the show, for the joy of writing! Forget about any calculations! This is just total crap I love! PBF file is need!
Code: (Select All)
'programmed Petr Preclik. Contains none graphics orgy.
'DATE: 04/2018
start:
SmerY = 1
start = 0
BalonX = 125: BalonY = 10
If left = 0 And right = 0 And autostarted = 0 Then menu
Cls: _AutoDisplay
If _FileExists("voll.pbf") Then
Do While I$ <> Chr$(27)
_PrintMode _KeepBackground
' COLOR 0, 2
If oldleft <> left Then oldleft = left: score$ = Str$(left) + "-" + Str$(right): Locate 23, (80 - Len(score$)) / 2: Print score$
If oldright <> right Then oldright = right: Locate 23, 17: Print left; " - "; right
If autostarted = 0 Then I$ = InKey$
Color 15, 0
'============================================
If vs And autostarted Then
l = l + 1
Select Case l
Case 1
j$ = InKey$
If j$ = Chr$(27) Then
autostarted = 0: vs = 0: ODPOCET = Timer: j$ = "": GoTo start
Else I$ = j$
End If
Case 2
AUTOSTART 1: l = 0
End Select
End If
'=============================================
If Timer > ODPOCET And vs = 0 Then AUTOSTART 0
TestSmeru
If rest Then rest = 0: GoTo start
Select Case I$
Case "S", "s": start = 1: ODPOCET = 99999: pisk
Case Chr$(0) + Chr$(77)
pravysmer = 1
VidP = VidP + 1: If VidP > 13 Then VidP = 10
PravyX = PravyX + 1
If PravyX > 270 Then
PravyX = 270
doraz
End If
Case "D", "d"
levysmer = 1
VidL = VidL + 1: If VidL > 4 Then VidL = 1
LevyX = LevyX + 1
If LevyX > 100 Then
LevyX = 100
doraz
End If
Case Chr$(0) + Chr$(75)
pravysmer = 2
VidP = VidP - 1: If VidP < 10 Then VidP = 13
PravyX = PravyX - 1
If PravyX < 150 Then
PravyX = 150
doraz
End If
Case "A", "a"
levysmer = 2
VidL = VidL - 1: If VidL < 1 Then VidL = 4
LevyX = LevyX - 1
If LevyX < 10 Then
LevyX = 10
doraz
End If
Case Chr$(13)
If delkaskoku = 0 Then delkaskoku = Timer + .50
While delkaskoku > 0
Vyskok = 1
TestBalonu
TestSmeru
Select Case delkaskoku - Timer
Case Is > .25: PravyY = PravyY - 2
' TestBalonu
If PravyY < 20 Then PravyY = 20
If pravysmer = 1 Then
VidP = VidP + 1: If VidP > 13 Then VidP = 10
PravyX = PravyX + 1
If PravyX > 270 Then
PravyX = 270
doraz
End If
End If
If pravysmer = 2 Then
VidP = VidP - 1: If VidP < 10 Then VidP = 13
PravyX = PravyX - 1
If PravyX < 150 Then
PravyX = 150
doraz
End If
End If
Case Is < .25
' TestBalonu
PravyY = PravyY + 2
If PravyY >= 101 Then
PravyY = 101
delkaskoku = 0
I$ = ""
End If
End Select
okoli
rozpis VidP, PravyX, PravyY
rozpis Balon, BalonX, BalonY
rozpis VidL, LevyX, LevyY
rozpis 9, 130, 100
Line (0, 163)-(320, 163)
_Display
_Limit 30
Cls
Wend
Case Chr$(32)
If delkaskokuL = 0 Then delkaskokuL = Timer + .50
While delkaskokuL > 0
Vyskok = 1
TestBalonu
TestSmeru
Select Case delkaskokuL - Timer
Case Is > .25
' TestBalonu
LevyY = LevyY - 2
If LevyY < 20 Then levy = 20
If levysmer = 1 Then
VidL = VidL + 1: If VidL > 4 Then VidL = 1
LevyX = LevyX + 1
If LevyX > 100 Then
LevyX = 100
doraz
End If
End If
If levysmer = 2 Then
VidL = VidL - 1: If VidL < 1 Then VidL = 4
LevyX = LevyX - 1
If LevyX < 10 Then
LevyX = 10
doraz
End If
End If
Case Is < .25
'TestBalonu
LevyY = LevyY + 2
If LevyY >= 102 Then
LevyY = 102
delkaskokuL = 0
I$ = ""
End If
End Select
okoli
rozpis VidP, PravyX, PravyY
rozpis Balon, BalonX, BalonY
rozpis VidL, LevyX, LevyY
rozpis 9, 130, 100
Line (0, 163)-(320, 163)
_Display
_Limit 30
Cls
Wend
End Select
TestBalonu
If Timer > BalonTime Then BalonTime = Timer + .5: Balon = Balon + 1: If Balon > 8 Then Balon = 5
okoli
rozpis VidP, PravyX, PravyY ' right player frame, coordinate X, coordinate Y
rozpis Balon, BalonX, BalonY ' ball frame, coordinate X, coordinate Y
rozpis VidL, LevyX, LevyY ' left player frame, coordinate X, coordinate Y
rozpis 9, 130, 100
Line (0, 163)-(320, 163)
_Display
_Limit 30
Cls
Loop
left = 0: right = 0: autostarted = 0: vs = 0
GoTo start
Else
Print "voll.pbf not found!": Sleep 2: System
End If
Sub menu
Shared netiskni
netiskni = 0
_AutoDisplay: _KeyClear
I$ = ""
If Not vs Then ODPOCET = Timer + 30
SmerY = 1
start = 0
BalonX = 125: BalonY = 10
fto& = _NewImage(60, 60, 256)
_Dest fto&
rozpis 7, 0, 0
_Dest 0
netiskni = 1
po = 50
Do While I$ <> Chr$(27)
Cls
uhel = uhel + 3: If uhel > 360 Then uhel = 1
rotation fto&, 80, po, uhel, 1.5
I$ = InKey$
If Timer > ODPOCET And vs = 0 Then I$ = "3"
center 10, "Volleyball - B/W"
center 25, "Press keys 1 - 6 or arrows and enter"
_PrintString (100, 50), "1: 1 player and computer"
_PrintString (100, 70), "2: 2 players"
_PrintString (100, 90), "3: demo"
_PrintString (100, 110), "4: About"
_PrintString (100, 130), "5: Sound setup"
_PrintString (100, 150), "6: End"
Select Case I$
Case Chr$(0) + Chr$(80): po = po + 20
Case Chr$(0) + Chr$(72): po = po - 20
Case Chr$(13): I$ = Str$(((po + 10) / 20) - 2)
End Select
Select Case Val(I$)
Case 3: ODPOCET = Timer: Exit Sub ' AUTOSTART 2 PLRS
Case 2: autostarted = 0: Exit Sub ' PLAY GAME 2 PLRS
Case 4: about: menu ' ABOUT
Case 5: If snd = 0 Then snd = 1: _PrintString (100, 180), "Sound ON": _Display: Sleep 2 Else snd = 0: _PrintString (100, 180), "Sound OFF": _Display: Sleep 2 ' SOUND
Case 6: _FreeImage fto&: _MouseShow: System ' QUIT
Case 1: AUTOSTART 1: ODPOCET = Timer: Exit Sub ' CLS: menu ' PLAY GAME 1 PLR VS PC
End Select
If po > 150 Then po = 150
If po < 50 Then po = 50
If Len(I$) And I$ <> "3" Then ODPOCET = Timer + 30 'NYNI
_Display
_Limit 20
I$ = ""
Loop
End Sub
Sub about
Cls
Locate 2
Print "About:"
Locate 5
Print "This is game for 0 or 1 or 2 players. "
Print "Its shared so as it is, without hiscore."
Print "Contains automatic demo start after 30 sec."
Print
Locate 12
Print "Use A, D for move left player, S for "
Print "Ball, space for jump left."
Print "Use arrows left and right for move right"
Print "player, enter for jump right."
Print
Locate 20
Print "Writed Petr P."
Print
Print "Press key...."
_Display
Sleep
End Sub
Sub center (lin As Integer, text As String)
centr = (_Width / 2 - _PrintWidth(text) / 2)
_PrintString (centr, lin), text$
End Sub
Sub AUTOSTART (mode)
Shared tah
Select Case mode
Case 0 ' this is call if plays PC vs PC
autostarted = 1
If start = 0 Then start = 1
tah = tah + 1
Select Case tah
Case 1: If BalonX - 30 > LevyX Then I$ = "d" ' on coordinates based computer "intelligence"
Case 2: If BalonX - 30 < LevyX Then I$ = "a"
Case 3: If BalonX + 60 > PravyX Then I$ = Chr$(0) + LTrim$(Chr$(77))
Case 4: If BalonX + 30 < PravyX Then I$ = Chr$(0) + LTrim$(Chr$(75))
Case 5: If BalonX + 60 > 220 Then I$ = Chr$(13)
Case 6: If BalonX - 30 < 40 Then I$ = " "
tah = 0
End Select
If InKey$ <> "" Then autostarted = 0: ODPOCET = Timer + 20: left = 0: right = 0: restart 3
Case 1 ' this run, if plays human vs computer.
vs = 1
autostarted = 1
If start = 0 Then start = 1
tah = tah + 1
ODPOCET = Timer
' SHARED j$
Select Case tah
Case 5: If BalonX - 30 > LevyX Then I$ = "d" ' computer drive one player.
Case 6: If BalonX - 30 < LevyX Then I$ = "a"
Case 7: If BalonX - 30 < 90 Then I$ = Chr$(32)
End Select
If tah > 9 Then tah = 0
End Select
End Sub
Sub TestSmeru ' sub for testing how player go. If to right or to left.
Select Case pravysmer
Case 1
VidP = VidP + 1: If VidP > 13 Then VidP = 10
PravyX = PravyX + 1
If PravyX > 270 Then
PravyX = 270: pravysmer = 0
doraz
End If
Case 2
VidP = VidP - 1: If VidP < 10 Then VidP = 13
PravyX = PravyX - 1
If PravyX < 150 Then
doraz
PravyX = 150: pravysmer = 0
End If
End Select
Select Case levysmer
Case 1
VidL = VidL + 1: If VidL > 4 Then VidL = 1
LevyX = LevyX + 1
If LevyX > 100 Then
LevyX = 100: levysmer = 0
doraz
End If
Case 2
VidL = VidL - 1: If VidL < 1 Then VidL = 4
LevyX = LevyX - 1
If LevyX < 10 Then
LevyX = 10: levysmer = 0
doraz
End If
End Select
End Sub
Sub TestBalonu ' sub for testing ball fly
If start = 1 Then
If Timer Mod 5 = 0 And Sgn(SmerY) = 1 Then SmerY = SmerY + .0981
If Timer Mod 5 = 0 And Sgn(SmerY) = -1 Then SmerY = SmerY + -0.0981
If Abs(SmerY) > 3 Then SmerY = 3 * Sgn(SmerY)
If Abs(SmerX) > 3 Then SmerX = 3 * Sgn(SmerX)
If Vyskok And inCircle(BalonX + 33, BalonY + 37, 20, LevyX + 20, LevyY + 20, 23) Or skok And inCircle(BalonX + 33, BalonY + 37, 20, PravyX + 35, PravyY + 22, 20) Then
klep
Vyskok = 0 'resi kolizi ve vyskoku ball collision on the fly if player skip
SmerX = Rnd + SmerX * -1: SmerY = Rnd + SmerY * -1
While inCircle(BalonX + 33, BalonY + 37, 20, LevyX + 20, LevyY + 20, 23) Or inCircle(BalonX + 33, BalonY + 37, 20, PravyX + 35, PravyY + 22, 20)
BalonX = BalonX + SmerX
BalonY = BalonY - (1 + Rnd * 10)
SmerY = SmerY - .0990
BalonX = BalonX + SmerX
If BalonY < 10 Then SmerY = SmerY * -1: Do While BalonY < 30: BalonY = BalonY + SmerY: Loop
Wend
'EXIT SUB
GoTo sut
End If
' ball collision if player go
If inCircle(BalonX + 33, BalonY + 37, 20, LevyX + 20, LevyY + 20, 23) Then SmerX = Rnd / 2 + SmerX * -1: SmerY = SmerY * -1: BalonX = BalonX + 10 * SmerX: BalonY = BalonY + 10 * SmerY: klep
If inCircle(BalonX + 33, BalonY + 37, 20, PravyX + 35, PravyY + 22, 20) Then SmerX = Rnd / 2 + SmerX * -1: SmerY = SmerY * -1: BalonX = BalonX + 10 * SmerX: BalonY = BalonY + 10 * SmerY: klep
sut:
If SmerX = 0 Then sm = Rnd * 10: If sm <= 5 Then SmerX = 1 Else SmerX = -1
If SmerY = 0 Then sm = Rnd * 10: If sm <= 5 Then SmerY = 1 Else SmerY = -1
If BalonY < 10 Then SmerY = SmerY * -1: BalonY = 10
If BalonY > 80 And BalonX < 160 Then right = right + 1: start = 0: pad: restart 1 ' left player fail
If BalonY > 80 And BalonX > 160 Then left = left + 1: start = 0: pad: restart 2 ' right player fail
BalonX = BalonX + SmerX: BalonY = BalonY + SmerY
End If
End Sub
Sub klep
If snd Then Sound 550, .2
End Sub
Sub restart (who As _Unsigned _Byte)
Select Case who
Case 1: LeftPlayer = LeftPlayer - 1
Case 2: RightPlayer = RightPlayer - 1
End Select
BalonX = 125: BalonY = 10
rest = 1
End Sub
Function reader (file As String) ' Read PBF file. This is my own new format contains graphics or characters. Its based on the BIT image representing.
Shared frames
kx = 0: ky = 1
If _FileExists(file$) Then Open file$ For Binary As #1 Else Beep: Print "Error opening file "; file$: _Display: Sleep 3: System
ident$ = Space$(4)
ReDim big As Integer
Get #1, , ident$
If ident$ <> "Petr" Then Print "This is not my file format": Sleep 2: Exit Function
Get #1, , big
frames = (LOF(1) - 6) / (big ^ 2 / 8)
ReDim udaj As _Unsigned _Byte
ReDim sn(frames) As String
While Not EOF(1)
Get #1, , udaj
binar$ = DECtoBIN$(udaj)
sn(snindex) = sn(snindex) + binar$
For rozklad = 1 To Len(binar$)
inSeek = inSeek + 1 'vnitrni pocitadlo pozice
povel = Val(Mid$(binar$, rozklad, 1))
kx = kx + 1: If kx > big Then kx = 1: ky = ky + 1
Next rozklad
If inSeek Mod (big ^ 2) = 0 Then ky = ky + 10: snindex = snindex + 1
If _Height - ky < big Then ky = 1: posun = posun + 60
Wend
Cls
reader = big
End Function
Sub rozpis (snimek As Integer, posX As Integer, posY As Integer) ' Draw frames from PBF read by function READER
Shared netiskni
If autostarted And Not vs Then Color 2: Locate 23, 1: Print "Demo": Color 15
If autostarted And vs Then Color 2: Locate 23, 1: Print "PC vs Human": Color 15
If netiskni Then Locate 23, 17: Print left; " - "; right
big = bigs ' je typu shared, udava delku strany
binar$ = sn(snimek)
For rozklad = 1 To Len(binar$)
povel = Val(Mid$(binar$, rozklad, 1))
kx = kx + 1: If kx > big Then kx = 1: ky = ky + 1
If povel = 1 Then PSet (posX + kx, posY + ky) 'ELSE PRESET (posX + kx, posY + ky)
Next rozklad
End Sub
' modifiation original code from CIRCLE help.
Function inCircle (cx As Integer, cy As Integer, cr As Integer, x As Integer, y As Integer, r As Integer) 'detect circle to circle contact. Return 1 if is contact, else return 0
r = r + 1
For Crc = 0 To 1.6 * _Pi Step .1
pseudocircleX = (Sin(Crc) * r) + x
pseudocircleY = (Cos(Crc) * r) + y
xy& = ((pseudocircleX - cx) ^ 2) + ((pseudocircleY - cy) ^ 2) ' Pythagorean theorem
If cr ^ 2 >= xy& Then inCircle = 1: Ic = 1 Else inCircle = 0
If Ic = 1 Then Exit For
Next
End Function
Function DECtoBIN$ (vstup) ' decimal to binary number convertor
For rj = 7 To 0 Step -1
If vstup And 2 ^ rj Then BINtoDE$ = BINtoDE$ + "1" Else BINtoDE$ = BINtoDE$ + "0"
Next rj
DECtoBIN$ = BINtoDE$
End Function
Sub doraz
If snd And Not autostarted Then
For e = .1 To .15 Step .01
Sound e * 500, e
Sound (500 * .6) - e, e
Sound e * 10000, e / 2
Next
For e = .15 To .1 Step -.01
Sound e * 500, e
Sound (500 * .6) - e, e
Sound e * 10000, e / 2
Next
End If
End Sub
Sub pisk
If snd Then
For e = .1 To .5 Step .1
Sound Sqr(e * 100 ^ 2 * 5000), e * 3
Next
End If
End Sub
Sub pad
If snd Then
For e = 2 To .1 Step -.1
Sound e * 200, .5
Next
End If
End Sub
Sub rotation (image As Long, x As Integer, y As Integer, angle As Integer, zoom As Integer) ' inspired by demo from somewhere in the forum, rotate image in menu.
_Source image&
_Dest 0
wide% = _Width(image&): deep% = _Height(image&)
TLC$ = "BL" + Str$(wide% / 2) + "BU" + Str$(deep% / 2)
RET$ = "BD BL" + Str$(wide%)
Draw "BM" + Str$(x) + ", " + Str$(y) + "TA=" + VarPtr$(angle%) + "S" + Str$(zoom) + TLC$
For y = 0 To deep% - 1
For x = 0 To wide% - 1
Draw "C" + Str$(Point(x, y)) + "R1"
Next x
Draw RET$
Next y
End Sub
Sub okoli
Line (0, 164)-(319, 200), 2, BF 'travnik pozadi
End Sub
After downloading file voll.zip do not try extract it, just rename it as voll.pbf, forum allow not add this file directly, then copy it to the same folder with source code.
Does anyone have a sorting algorithm laying around I could use? Nothing fancy but something faster than a bubble sort.
I have the following I need to sort:
TYPE DATATYPE
a AS INTEGER
b AS INTEGER
c AS INTEGER
END TYPE
REDIM SortedList(0) AS DATATYPE
The sort will only be done on the value of 'a' (SortedList().a) and the values can range from 1 to 32767.
The Index of SortedList() can also be from 1 to 32767.
The first thing you're probably thinking is why not have the index value equal the value in 'a'... There can be multiple duplicate values in 'a'.
A bubble sort will probably do fine for the array if less than 1000 indexes but I need a sort that will be faster than bubble for cases where the index surpasses 32000+
Sometimes I actually plan a project before I start coding. That can involve actual diagrams and notes for myself. Here's a planner sheet for just one tiny part of a project; the attached image is the firing arc options for a spaceship combat game somewhat like super-trek but using hexes for a different look.
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
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.
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?
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.
![[Image: voll.png]](https://i.ibb.co/yskGcvM/voll.png)
![[Image: firing-arc-chart.png]](https://i.ibb.co/GF7W8Mf/firing-arc-chart.png)
![[Image: 1.png]](https://i.ibb.co/yfnw6Nq/1.png)
![[Image: 2.png]](https://i.ibb.co/BNJbHG3/2.png)
