Can anyone make this program shorter and smoother? I played with it for a while and it's pretty good, but I'm wondering if there's a simpler, better approach to using the ASPECT value. (bplus, I'm looking at you. )
Code: (Select All)
Option_Explicit' A Spinning Circle Screen_NewImage(600, 400, 32) DimAsInteger b, c, counter ' Playing with Aspects DimAsSingle aspect, adder DimAs_UnsignedLong col $Color:32
counter = 0: col = Red Do
aspect = 1: adder = .015' initial values ' ASPECTS 1 TO 70 For c = 1To9 For b = 1To10' redraw circle 10 times adding to the aspect each loop Cls
aspect = aspect + adder ' increase the aspect by adder Circle (_Width / 2, _Height / 2), 100, White, , , aspect Paint (_Width / 2, _Height / 2), col, White _Limit110 _Display Next b If aspect >= 70ThenExit For' @ ~90 degrees drop thru to reverse loops
adder = adder * 2' adder amounts have to double after each 10-loop cycle to look right-ish Next c ' * now reverse the process *
counter = counter + 1 If counter Mod2 <> 0ThenIf col = Red Then col = Green Else col = Red ' flip colors on odd cycles
I was intrigued by his sphere mapping routine. In that thread you can see the process I went through modifying the code attempting to make it faster. Here is what I believe to be the final modified version of bplus' code squeezing as much speed as I could out of it.
The routines use the QB64pe _MEM statements for outright speed. Pay particular attention to the rendering subroutine, RenderSphere. It uses the metacommands $CHECKING:OFF and $CHECKING:ON for an even greater boost in speed. If you are uncomfortable with these metacommands simply REM or remove them.
Documentation on how to use this little library is contained at the top of the code. A demo is also included in the code showing the simplicity of its use.
The .ZIP file below contains the world map image for the demo.
Update: The code below has been modified per NakedApe's discovery of an issue with Mac systems.
Code: (Select All)
'+----------------------------------------------------------------------------------------------------------------------------------+
'| Fake Sphere Mapping |
'| v2.0 |
'| Terry Ritchie |
'| |
'| Adapted from code by bplus: https://qb64phoenix.com/forum/showthread.php?tid=272&pid=2647#pid2647 |
'| Which was adapted from code by Paul Dunn: https://www.youtube.com/watch?v=0EGDJybA_HE |
'| I contacted Paul Dunn and confirmed that the code in the video above is his original work. |
'| Quote from Paul, "yep, this one is mine, worked out from an algorithm for mapping lat/long to a rectangle." |
'| Furthermore, the idea of using a longitude map came from here: http://fredericgoset.ovh/informatique/oldschool/en/spheremap.html |
'| |
'| DOCUMENTATION: |
'| |
'| STEP 1: Create a structure to hold a sphere. |
'| -------------------------------------------- |
'| DIM Mars AS D2SPHERE ' a sphere structure to contain Mars |
'| |
'| |
'| STEP 2: Create the sphere from the structure to be used in later renderings. |
'| ---------------------------------------------------------------------------- |
'| MakeSphere Sphere, Radius, SphereImage |
'| |
'| Sphere - a variable declared as TYPE D2SPHERE |
'| Radius - the desired radius of the rendered output image |
'| Note: passing a value of zero for radius results in the sphere height equaling the height of the texture image |
'| SphereImage - the texture image used to map the surface of the sphere |
'| |
'| Example: MakeSphere Mars, 0, MarsImage ' create a sphere with a height equaling the texture image |
'| |
'| |
'| STEP 3: Render the sphere output image. |
'| --------------------------------------- |
'| RenderSphere Sphere, xOffset |
'| |
'| Sphere - a variable declared as TYPE D2SPHERE and previously processed through the MakeSphere subroutine |
'| xOffset - the x coordinate offset within the texture map image to start rendering |
'| Note: the RenderSphere subroutine will modify xOffset and return the result as needed |
'| |
'| Example: RenderSphere Mars, 0 ' render an output image of the sphere |
'| |
'| |
'| STEP 4: Utilize the rendered image. |
'| ----------------------------------- |
'| The rendered output image will be contained in the sub-variable .Sphere of the variable declared as TYPE D2SPHERE. |
'| |
'| Example: _PUTIMAGE(0, 0), Mars.Sphere ' displayed the rendered sphere |
'| |
'| |
'| STEP 5: Clean up after yourself by removing all memory and image assets associated with the sphere when finished with it. |
'| ------------------------------------------------------------------------------------------------------------------------- |
'| FreeSphere Sphere |
'| |
'| Sphere - a variable declared as TYPE D2SPHERE and previously processed through the MakeSphere subroutine |
'| |
'| Example: FreeSphere Mars ' the sphere is no longer needed |
'| |
'| You can create as many sphere objects as memory allows, that's why it's important to remove unused spheres. |
'| |
'+----------------------------------------------------------------------------------------------------------------------------------+
OPTION _EXPLICIT ' declare those variables son
TYPE D2SPHERE ' 2D MAPPED SPHERE PROPERTIES
Image AS LONG ' texture image to map onto sphere
Sphere AS LONG ' rendered output image
ImageWidth AS INTEGER ' width of image
ImageHeight AS INTEGER ' height of image
mImage AS _MEM ' memory contents of texture image
mSphere AS _MEM ' memory contents of output image
mMap AS _MEM ' memory contents of longitude map
END TYPE
' --------------------------
'| Begin demonstration code |
' --------------------------
DIM Earth AS D2SPHERE ' a sphere structure to display Earth
DIM EarthImage AS LONG ' Earth's texture map
DIM EarthOffset AS INTEGER ' x location of texture map to begin drawing
EarthImage = _LOADIMAGE("worldmap3.png", 32) ' load texture map
MakeSphere Earth, 0, EarthImage ' create the Earth sphere structure
_FREEIMAGE EarthImage ' texture map no longer needed
SCREEN _NEWIMAGE(_WIDTH(Earth.Sphere), _HEIGHT(Earth.Sphere), 32) ' graphics screen same size as output image
EarthOffset = 0 ' reset texture map x offset
DO ' begin demo loop
RenderSphere Earth, EarthOffset ' render the sphere image at x offset
_PUTIMAGE (0, 0), Earth.Sphere ' display the output image
EarthOffset = EarthOffset + 1 ' increment texture map x offset
_DISPLAY ' update screen with changes
LOOP UNTIL _KEYDOWN(27) ' leave when ESC key pressed
FreeSphere Earth ' free all sphere assets
SYSTEM ' return to the operating system
' ------------------------
'| End demonstration code |
' ------------------------
'------------------------------------------------------------------------------------------------------------------------------------------+
SUB FreeSphere (Sphere AS D2SPHERE) ' |
'+-------------------------------------------------------------------------------------------------------------------------------------+
'| Frees all memory and image assets associated with a sphere. Very important to use this to free assets before exiting program! |
'| |
'| Sphere - a user defined type variable as SPHERE |
'+-------------------------------------------------------------------------------------------------------------------------------------+
'------------------------------------------------------------------------------------------------------------------------------------------+
SUB RenderSphere (Sphere AS D2SPHERE, xOffset AS INTEGER) ' |
'+-------------------------------------------------------------------------------------------------------------------------------------+
'| Renders a sphere's output image (.Sphere) |
'| |
'| Sphere - a user defined type variable as SPHERE |
'| xOffset - x location within texture image to begin (note that this value can be changed by the subroutine and passed back) |
'+-------------------------------------------------------------------------------------------------------------------------------------+
DIM x AS INTEGER ' horizontal counter
DIM y AS INTEGER ' vertical counter
DIM Mapx AS INTEGER ' longitude map x coordinate
DIM Pixel AS _UNSIGNED LONG ' image pixel
DIM MapOffset AS _OFFSET ' memory location within longitude map
DIM SphereOffset AS _OFFSET ' memory location within output image
DIM ImageOffset AS _OFFSET ' memory location within texture image
$CHECKING:OFF
IF xOffset > Sphere.ImageWidth - 1 THEN xOffset = 0 ' reset x offset if needed
y = 0 ' reset vertical counter
DO ' begin vertical loop
MapOffset = Sphere.mMap.OFFSET + (y * Sphere.ImageHeight * 2) ' start of horizontal line within longitude map
SphereOffset = Sphere.mSphere.OFFSET + (y * Sphere.ImageHeight * 4) ' start of horizontal line within output image
ImageOffset = Sphere.mImage.OFFSET + (y * Sphere.ImageWidth * 8) ' start of horizontal line within texture image
x = 0 ' reset horizontal counter
DO ' begin horizontal loop
_MEMGET Sphere.mMap, MapOffset + (x * 2), Mapx ' get x texture coordinate
IF Mapx <> -1 THEN ' valid coordinate?
_MEMGET Sphere.mImage, ImageOffset + (Mapx + xOffset) * 4, Pixel ' yes, get pixel from image
_MEMPUT Sphere.mSphere, SphereOffset + (x * 4), Pixel ' apply pixel to output image
END IF
x = x + 1 ' increment horizontal counter
LOOP UNTIL x = Sphere.ImageHeight ' leave when entire horizontal line processed
y = y + 1 ' increment vertical counter
LOOP UNTIL y = Sphere.ImageHeight ' leave when entire vertical line processed
$CHECKING:ON
END SUB
'------------------------------------------------------------------------------------------------------------------------------------------+
SUB MakeSphere (Sphere AS D2SPHERE, UserRadius AS INTEGER, Image AS LONG) ' |
'+-------------------------------------------------------------------------------------------------------------------------------------+
'| Create a sphere structure to be used later when rendering the sphere. |
'| |
'| Sphere - a user defined type variable as SPHERE |
'| UserRadius - the desired sphere radius (supply a value of zero to use the radius of the image) |
'| BaseImage - the image to be mapped onto the sphere |
'| |
'| Example: MakeSphere Earth, 0, WorldMap ' define sphere using radius of image |
'| |
'| Note: NakedApe on the QB64pe forum noted a change was needed in the code below. |
'| BaseImage = _COPYIMAGE(Image) needed to be changed to _COPYIMAGE(Image, 32) |
'| Without this change the code would not run on a Mac. Thanks to NakedApe for pointing this out. |
'+-------------------------------------------------------------------------------------------------------------------------------------+
CONST HALFPI = 1.570796326794897 ' half of Pi
CONST rPI = .318309891613572 ' Pi reciprocated
DIM TempImage AS LONG ' temporary resizing image if modifying radius
DIM BaseImage AS LONG ' final image to map to sphere
DIM Radius AS SINGLE ' sphere radius
DIM Index AS _UNSIGNED LONG ' array memory offset for each value
DIM sLongitude AS SINGLE ' sine longitude calculation
DIM Longitude AS SINGLE ' longitude calculation
DIM x AS INTEGER ' horizontal counter
DIM y AS INTEGER ' vertical counter
IF UserRadius <> 0 THEN ' use the radius of the base image?
' ------------------------------------------------------------
'| Resize base image to fit passed in radius supplied by user |
' ------------------------------------------------------------
TempImage = _NEWIMAGE((_WIDTH(Image) * UserRadius * 2) / _HEIGHT(Image), UserRadius * 2, 32) ' no, create resized temp image
_PUTIMAGE (0, 0)-(_WIDTH(TempImage) - 1, _HEIGHT(TempImage) - 1), Image, TempImage ' resize base image into temp image
BaseImage = _COPYIMAGE(TempImage) ' copy temp image to base image
_FREEIMAGE TempImage ' remove temp image
ELSE ' yes
BaseImage = _COPYIMAGE(Image, 32) ' copy image to base image
END IF
Sphere.ImageWidth = _WIDTH(BaseImage) ' get width of base image
Sphere.ImageHeight = _HEIGHT(BaseImage) ' get height of base image
Sphere.Image = _NEWIMAGE(Sphere.ImageWidth * 2, Sphere.ImageHeight * 2, 32) ' create texture image
_PUTIMAGE (0, 0), BaseImage, Sphere.Image ' draw base image left justified on texture image
_PUTIMAGE (Sphere.ImageWidth, 0), BaseImage, Sphere.Image ' draw base image right justified on texture image
Sphere.mImage = _MEMIMAGE(Sphere.Image) ' get memory contents of texture image
Sphere.Sphere = _NEWIMAGE(Sphere.ImageHeight, Sphere.ImageHeight, 32) ' create output image
Sphere.mSphere = _MEMIMAGE(Sphere.Sphere) ' get memory contents of output image
Sphere.mMap = _MEMNEW(Sphere.ImageHeight * Sphere.ImageHeight * 2) ' create longitude array in memory
' -------------------------------------------------------------------
'| Create a longitude map of sphere |
'| The idea of using a translation array comes from this site: |
'| http://fredericgoset.ovh/informatique/oldschool/en/spheremap.html |
' -------------------------------------------------------------------
Radius = Sphere.ImageHeight * .5 ' calculate sphere radius
y = 0 ' reset vertical counter
DO ' begin vetical loop
x = 0 ' reset horizontal counter
DO ' begin horizontal loop
Index = (y * Sphere.ImageHeight + x) * 2 ' memory location within nMap
' -----------------------------------------------------------------
'| (x - radius) = centered x position |
'| (y - radius) = centered y position |
'| (y - radius) / radius = sine latitude |
'| _ASIN((y - radius) / radius) = latitude |
'| radius * COS(_ASIN((y - radius) / radius) = sphere radius |
' -----------------------------------------------------------------
sLongitude = (x - Radius) / (Radius * COS(_ASIN((y - Radius) / Radius))) ' calculate sine longitude of pixel
IF ABS(sLongitude) <= 1 THEN ' is pixel inside the circle?
Longitude = _ASIN(sLongitude) + HALFPI ' yes, complete longitude calculation
_MEMPUT Sphere.mMap, Sphere.mMap.OFFSET + Index, (Longitude * Sphere.ImageWidth * .5) * rPI AS INTEGER ' store image x coor
ELSE ' no, pixel is outside of circle
_MEMPUT Sphere.mMap, Sphere.mMap.OFFSET + Index, -1 AS INTEGER ' mark x coordinate as outside of circle
END IF
x = x + 1 ' increment horizontal counter
LOOP UNTIL x = Sphere.ImageHeight ' leave when entire horizontal line processed
y = y + 1 ' increment vertical counter
LOOP UNTIL y = Sphere.ImageHeight ' leave when entire vertical line processed
Posted by: Petr - 09-10-2024, 12:14 PM - Forum: Petr
- Replies (7)
I wrote my own version of inputbox. Its limitation is that it is only intended for a resolution of 1920x1080 (my default), so it was satisfactory for the program for which it was intended.
It supports marking and deleting part of the text, the clipboard and scrolling on the monitor if the dialog is caught by the mouse by the upper edge. Maybe it could be of interest to someone.
Code: (Select All)
Screen _NewImage(1920, 1080, 32)
Cls 'need for black with alpha 255 in background (or can be used image)
_FullScreen
D$ = "programmer"
N = Val(InputBoxZ("Window title", "This program now tests:", D$, 1, 0))
_Display
Print N, D$ 'N = buttons status, D$ = text inserted in box
_Display
End
Function InputBoxZ$ (Tit As String, Message As String, Default As String, DefaultVal, BoxType)
'designated for 1920 x 1080 resolution only!
'ESC = -1; OK = 1; CANCEL = 0
B.Height = 125
B.Width = 351
B.X = B.Width \ 2 - _Width \ 2
If B.X < 0 Then
B.X = _Width \ 2 - B.Width \ 2
End If
B.Y = B.Height \ 2 - _Height \ 2
If B.Y < 0 Then
B.Y = _Height \ 2 - B.Height \ 2
End If
'It saves the background in ram during the dialog, nothing
'else happens until it is confirmed or finished, it is not a pass-through function
Backgr& = _CopyImage(0, 32) '
GPos = _PrintWidth(Default)
t$ = Default$
Do Until Done
_PutImage , Backgr&, _Dest
K& = _KeyHit
Select Case K&
Case 27: InputBoxZ$ = "-1": Exit Function 'After Esc return -1
Case 13: InputBoxZ$ = Str$(DefaultVal): Exit Function 'After Enter is returned defaultval (is changed by user)
'OK = 1, Cancel = 0,
End Select
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
'solution for moving dialog on the screen by mouse
If PLock Then GoTo Shift 'GoTo enables scrolling for as long as the button is pressed, even if you escape from the dialog's coordinates
If MX >= B.X And MX <= B.Width + B.X Then
If MY >= B.Y And MY <= B.Y + 24 Then
Shift:
If LB = -1 Then
PLock = 1
If DoX = 0 Then
DoX = MX - B.X
DoY = MY - B.Y
End If
B.X = MX - DoX
B.Y = MY - DoY
Else
DoX = 0
PLock = 0
End If
End If
End If
Line (B.X, B.Y)-(B.Width + B.X, B.Height + B.Y), _RGB32(240), BF 'whole box area
Line (B.X, B.Y)-(B.Width + B.X, B.Y + 24), _RGB32(255), BF ' title area
Select Case BoxType
Case 0
'defaultVal set, which button is after run set as default
Buttons = 2
B1$ = "OK"
B2$ = "Cancel"
'Right button: Cancel
BoxButtonZ LHx, LDy, PHx, Lhy ' cancel
BoxButtonZ LHx1, LDy, PHx1, Lhy 'OK
' If DefaultVal = 0 Then Color _RGB32(0) Else Color _RGB32(188, 153, 171) 'original ma oba popisky cerne,
_PrintString (T1, TY), B2$ ' pri kliknuti na volbu zustane text cerny,
' If DefaultVal = 1 Then Color _RGB32(0) Else Color _RGB32(188, 153, 171) ' oramovani se ale zmeni z BoxButtonZ na BoxZ
_PrintString (T2, TY), B1$ ' a okolo textu se udela jeste binarni Line B
If LB = -1 And MX > LHx1 And MX < PHx1 And MY > LDy And MY < Lhy Then DefaultVal = 1: ButtonActive$ = "OK"
If LB = -1 And MX > LHx And MX < PHx And MY > LDy And MY < Lhy Then DefaultVal = 0: ButtonActive$ = "Cancel"
If MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y + 57 And MY < B.Y + 77 Then _MouseShow "Text" Else _MouseShow "default"
If LB = -1 And MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y + 57 And MY < B.Y + 77 Or DialogAct = 1 Then
DialogAct = 1
'logika vkladani textu do textoveho pole
' If LB = -1 And MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y And MY < B.Height Then
If Dialog& = 0 Then
Dialog& = _NewImage(B.Width, B.Height, 32)
_PutImage (B.X, B.Y)-(B.Width + B.X, B.Height + B.Y), 0, Dialog&
End If
Do Until K$ = Chr$(13) Or ButtonActive$ <> ""
K$ = InKey$
'urcit grafickou polohu kurzoru pri kliknuti do textu - uz ok
If MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y + 57 And MY < B.Y + 77 Then
If LB = -1 Then
If ShiftStart > 0 And Len(K$) = 0 Then
ShiftStart = 0
ShiftEnd = 0
ShiftLock = 0
_Continue
End If
If MX - (B.X + 12) < _PrintWidth(t$) + 12 And MX > B.X + 12 Then
UPGI = _FontWidth * ((MX - (B.X + 12)) \ _FontWidth)
GPos = UPGI - _FontWidth
End If
If GPos < 0 Then GPos = 0
If MemG = 0 Then MemG = GPos + _FontWidth
End If
'support for select text with mouse
If LB = -1 And MemG <> GPos + _FontWidth Then
ShiftStart = MemG
ShiftEnd = GPos + _FontWidth
GoTo ppp
End If
If LB = 0 And MemG > 0 Then
MemG = 0
End If
End If 'end condition for locking window when is moved on the screen with mouse
'Shift press support for text select
ShiftLeft& = _KeyDown(100303)
ShiftRight& = _KeyDown(100304)
If ShiftLeft& Or ShiftRight& Then
If Len(K$) = 1 Then ShiftLock = 0: GoTo DoNotShift
If ShiftStart = 0 Then ShiftStart = GPos + _FontWidth
If ShiftStart > 0 Then ShiftEnd = GPos + _FontWidth
ppp: 'whin selecting text with mouse, use block for selecting with keyboard by there
ShiftLock = 1
ITLS = ShiftStart \ _FontWidth
ITLR = ShiftEnd \ _FontWidth - ShiftStart \ _FontWidth
If ITLR < 0 Then
ITLR = ShiftStart \ _FontWidth - ShiftEnd \ _FontWidth
ITLS = ShiftEnd \ _FontWidth
End If
InsertedText$ = Mid$(t$, ITLS, ITLR)
Else
ShiftLock = ShiftStart 'Delete / Shift logic blocking
End If
'Clipboard support
'ShifStart is reseted after sopmething is pressed on the keyboard
If K$ = Chr$(3) Then _Clipboard$ = InsertedText$ 'insert to clipboard
If ShiftLeft& = 0 And ShiftRight& = 0 And K$ <> "" Then
If Len(InsertedText$) And Len(K$) = 1 Then
If Asc(K$) > 31 And Asc(K$) < 127 Then 'limit for text characters
' If part of the text is marked and you press a letter,
'Delete the marked part and write from its original left side
If ShiftStart > ShiftEnd Then Swap ShiftStart, ShiftEnd
kk$ = ""
tA$ = Left$(t$, ShiftStart \ _FontWidth - 1)
tB$ = Right$(t$, Len(t$) - ShiftEnd \ _FontWidth + 1)
If Asc(K$) > 31 And Asc(K$) < 127 Then kk$ = K$
t$ = tA$ + kk$ + tB$
GPos = ShiftStart
'Print "Ta a Tb:"; tA$, tB$, ShiftStart, ShiftEnd: _Display
tA$ = ""
tB$ = ""
ShiftStart = 0
InsertedText$ = ""
_Continue
End If
End If
DoNotShift:
tA$ = ""
tB$ = ""
ShiftStart = 0
InsertedText$ = ""
'Sound 299, .1 'every character can do sound
End If
'last upgrade: 2024-24-02
If K$ = Chr$(0) + Chr$(75) Then
If GPos > 0 Then GPos = GPos - _FontWidth 'arrow left
End If
If K$ = Chr$(0) + Chr$(77) Then
If GPos < _PrintWidth(t$) Then GPos = GPos + _FontWidth 'arrow right
End If
If K$ = Chr$(22) Then 'clipboard inserting is supported (Ctrl+V)
t$ = Left$(_Clipboard$, 30)
GPos = _FontWidth * Len(t$)
End If
If LB = -1 Then AllowText = 0 Else AllowText = 1 'when textbox is moved on the screen, text inserting is blocked
If AllowText = 1 Then
If Len(t$) < 30 And Len(K$) Then
If Asc(K$) > 31 And Asc(K$) < 177 Then
TextPos = GPos \ _FontWidth
TextA$ = Mid$(t$, 1, TextPos)
TextB$ = Mid$(t$, TextPos + 1, Len(t$) - TextPos)
t$ = TextA$ + K$ + TextB$
GPos = GPos + _FontWidth
K$ = ""
End If
End If
Else
K$ = ""
End If
If K$ = Chr$(8) Then 'Backspace support
If ShiftLock Then GoTo ShiftedLock
If Len(t$) > 0 Then
T1$ = Mid$(t$, 1, (GPos - 1) \ _FontWidth) 'the left part of the string according to GPos shortened by one character
T2$ = Right$(t$, Len(t$) - Len(T1$) - 1) 'right part of the string
If GPos <= 0 Then _Continue 'if GPos (cursor position) is 0
t$ = T1$ + T2$
Default$ = t$
GPos = GPos - _FontWidth
Color _RGB32(255)
_PrintMode _FillBackground
_PrintString (B.X + 24 + GPos, B.Y + 60), Chr$(255)
_PrintMode _KeepBackground
Rem ----------------------------------
End If
'if piece of the text is inserted, delete it
ShiftedLock:
Kpocet = ITLR
Kstart = ITLS
If ShiftLock Then
LeftT$ = Mid$(t$, 1, Kstart - 1)
RightT$ = Mid$(t$, Kstart + Kpocet)
t$ = LeftT$ + RightT$
ShiftLock = 0
GPos = _PrintWidth(t$)
End If
End If
If K$ = Chr$(0) + Chr$(83) Then 'delete support
If ShiftLock Then GoTo ShiftedLockB
If Len(t$) > 0 Then
T1d$ = Left$(t$, GPos \ _FontWidth) 'left part of the string by GPos minus one character
T2d$ = Right$(t$, Len(t$) - Len(T1d$) - 1) 'right part of the string
t$ = T1d$ + T2d$
Default$ = t$
Color _RGB32(255)
_PrintMode _FillBackground
_PrintString (B.X + 24 + GPos, B.Y + 60), Chr$(255)
_PrintMode _KeepBackground
Rem LINE----------------------------------
End If
ShiftedLockB:
Kpocet = ITLR
Kstart = ITLS
If ShiftLock Then
LeftT$ = Mid$(t$, 1, Kstart - 1)
RightT$ = Mid$(t$, Kstart + Kpocet)
t$ = LeftT$ + RightT$
Default$ = t$
GPos = _PrintWidth(t$)
ShiftLock = 0
End If
End If
If K$ = Chr$(0) + Chr$(71) Then GPos = 0 'Home key
If K$ = Chr$(0) + Chr$(79) Then GPos = _PrintWidth(t$) 'Home key
'if part of the text is selected, colorize it
If ShiftStart Then
Line (B.X + 16 + ShiftStart, B.Y + 57)-(B.X + 16 + ShiftEnd, B.Y + 77), _RGBA32(0, 0, 127, 117), BF
End If
If Timer * 10 Mod 10 < 5 Then 'cursor blicking
Line (B.X + 24 + GPos, B.Y + 60)-(B.X + 24 + GPos, B.Y + 72), _RGB32(255)
Else
Line (B.X + 24 + GPos, B.Y + 60)-(B.X + 24 + GPos, B.Y + 72), _RGB32(0)
End If
Color _RGB32(0), _RGB32(255)
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
If LB = -1 And MX > LHx1 And MX < PHx1 And MY > LDy And MY < Lhy Then
DefaultVal = 1
ButtonActive$ = "OK"
Default$ = t$
End If
If LB = -1 And MX > LHx And MX < PHx And MY > LDy And MY < Lhy Then
DefaultVal = 0
ButtonActive$ = "Cancel"
End If
If MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y + 57 And MY < B.Y + 77 Then
_MouseShow "Text"
Else
_MouseShow "default"
Exit Do
End If
_Display
Loop
Else
DialogAct = 0
End If
Default$ = t$
End Select
If Len(ButtonActive$) Then
Do Until LB = 0
While _MouseInput: Wend
LB = _MouseButton(1)
Select Case ButtonActive$
Case "OK"
BoxZ LHx1, LDy, PHx1, Lhy 'for OK
Line (LHx1, LDy)-(PHx1, Lhy), _RGB32(240), BF
Color _RGB32(0)
_PrintString (T2, TY), B1$
InputBoxZ$ = "1"
Case "Cancel"
BoxZ LHx, LDy, PHx, Lhy ' for cancel
Line (LHx, LDy)-(PHx, Lhy), _RGB32(240), BF
Color _RGB32(0)
_PrintString (T1, TY), B2$
InputBoxZ$ = "0"
End Select
_Display
_Limit 100
Loop
Done = 1
LB = 0
End If
_Display
_Limit 120
Color _RGB32(255)
If K$ = Chr$(13) Then Exit Do
Loop
_PutImage , Backgr&, _Dest
_FreeImage Backgr&
Color _RGB32(255), _RGB32(0)
_PrintMode _FillBackground
Default$ = t$
End Function
Sub BoxZ (Xs, Ys, Xe, Ye) 'imitation of the appearance of buttons for concrete resolution according to windows buttons
Line (Xs, Ys)-(Xe, Ye), _RGB32(255), BF
'bootm lines:
Line (Xs - 1, Ye + 1)-(Xe + 1, Ye + 1), _RGB32(227)
Line (Xs - 1, Ye + 2)-(Xe + 1, Ye + 2), _RGB32(255)
'right lines
Line (Xe + 1, Ys - 1)-(Xe + 1, Ye + 1), _RGB32(227)
Line (Xe + 2, Ys - 1)-(Xe + 2, Ye + 1), _RGB32(255)
'upper two lines
Line (Xs - 2, Ys - 2)-(Xe + 1, Ys - 2), _RGB32(105)
Line (Xs - 1, Ys - 1)-(Xe + 1, Ys - 1), _RGB32(160)
'left two lines
Line (Xs - 2, Ys - 2)-(Xs - 2, Ye + 2), _RGB32(105)
Line (Xs - 1, Ys - 1)-(Xs - 1, Ye + 1), _RGB32(160)
End Sub
Sub BoxButtonZ (Xs, Ys, Xe, Ye) 'test - ok
Rem compared to BoxZ what's on the right will be on the left, what's up will be down
'One button description BoxButtonZ or ButtonZ is applied to the button in the unclicked state
'and the other description is applied to the button when it is pressed
Line (Xs, Ys)-(Xe, Ye), _RGB32(240), BF
'bottom lines
Line (Xs - 1, Ye + 1)-(Xe + 1, Ye + 1), _RGB32(160)
Line (Xs - 1, Ye + 2)-(Xe + 1, Ye + 2), _RGB32(105)
'right lines
Line (Xe + 1, Ys - 1)-(Xe + 1, Ye + 1), _RGB32(160) 'tyto 2 prohozeny barvy
Line (Xe + 2, Ys - 1)-(Xe + 2, Ye + 1), _RGB32(105)
I was curious as to what all the default MIDI soundfont patches sounded like, and I also wanted to put together a way of grabbing those sounds somehow in code to use, so this function is the result. It just grabs 1 midi note. I don't think I'm calculating the ticks and duration right, but at least I can hear the sound patches available. There's some real neat ones. I'm probably not making a valid MIDI data file here, but at least it loads/plays.
- Dav
NOTE: Get the lastest version, now called MidiNotes, HERE
Code: (Select All)
'Exploring QB64-PE default soundfont patches.
'Makes MIDI a note and play's it from memory.
'Dav, SEP/2024
'Cycles throuh all default sound patchs 127-0
$Unstable:Midi
$MidiSoundFont: Default
'cycle through all sounds, press any key to quit.
For patch = 127 To 0 Step -1
Print "Patch#"; patch
note$ = MidiNote$(60, patch, 60, 1)
midisound& = _SndOpen(note$, "memory")
_SndPlay midisound&
_Delay 1
_SndStop midisound&
_SndClose midisound&
If InKey$ <> "" Then End
Next
Function MidiNote$ (tempo&, patch, note, duration&)
Anyone else experiment with different ways to have multiple screens open at a time using QB64? I've experimented with using The clipboard to send data from one QB64 app to another and it generally works but is of course prone to issues if there are other apps running that use the clipboard. Reading and writing to the same files as a way to get it done as well. What I've seen but am not apt with at all is sending data through networking schemes. Anyone have any tips or tricks they've used to do this?
Posted by: Petr - 09-07-2024, 07:35 PM - Forum: Petr
- Replies (5)
I started working on another project, and part of it is the need to have a window on the screen where it will be possible to move the text up and down and left and right. The attached program does this, but in this version you can use arrows with a rectangle showing the position between them for only one window. This is for greater simplicity. In the next version, the program will already include arrows with a slider in such a way that they can be used on multiple windows. (the OldMy variable which is now STATIC would cause problems and will have to be custom for each dialog).
The program supports PgUp and PgDown for scrolling up and down, Home and End are for jumping in the line to the beginning and end of the line, then of course arrows on the keyboard, arrows on the monitor and also by dragging the rectangle between the arrows. After pressing Enter, the function returns the line number where the yellow bar is.
Note the structure of the program. The arrows to control the position of the text in the window can be easily placed anywhere.
Code: (Select All)
'This program will be part of a larger project for SoundEditor.
'The task of this small program is to display a text field in a
'window that allows text to be scrolled left, right, up and down.
'When Enter is pressed, function return row number.
'Note the structure of the program. Arrows with stripes, which are located
'here on the sides of the text window, can be placed independently anywhere.
'Just modify the call to the Arrow function.
'
Dim Shared Samples(1000) As String
For gensamp = 0 To 1000
For char = 1 To 300 + 125 * Rnd
a$ = a$ + Chr$(32 + 64 * Rnd)
Next
Samples(gensamp) = a$
a$ = ""
Next
Screen _NewImage(1024, 768, 32)
Cls , _RGB32(240)
Do
SelectSample = ViewSamples(40, 30, 760, 705, 1, "Samples list:", Samples())
Locate 1
If SelectSample > -1 Then Print "Function return record number:"; SelectSample
_Display
_Limit 20
Loop
Function ViewSamples (xs As Integer, ys As Integer, xe As Integer, ye As Integer, Mode As _Byte, Title As String, a() As String)
' Xs: upper left corner X position
' Ys: upper left corner Y position
' Xe: bottom right corner X position
' Ye: bottom right corner Y position
' Mode: if it is zero, no text movement is allowed in the X-axis, and text that would go outside the window
' is terminated by three dots, if is 1, is allowed text movement in the X-axis.
' Title: Window title
' A() is array which contains text
ViewSamples = -1
Static VS_Pos 'selector position VERTICAL
Static ListStart, ListEnd
Static HS_POS, HS_MAX 'selector position HORIZONTAL
If HS_MAX = 0 Then
For t = 0 To UBound(a)
CurrentLen = Len(a(t))
If HS_MAX < CurrentLen Then HS_MAX = CurrentLen
Next t
End If
If HS_POS < 1 Then HS_POS = 1
If xe < xs Then Swap xe, xs
If ye < ys Then Swap ye, ys
'----
'There are two options to jump right to the last position in the text.
'left it set to always jump to the position of the longest string. Other
'options (commented out/disallowed here) are that they jump to the end based
'on the length of a particular string.
' If HS_POS > Len(a(VS_Pos)) - ((xe - xs) \ _FontWidth) + 2 Then HS_POS = Len(a(VS_Pos)) - ((xe - xs) \ _FontWidth) + 2
' If HS_POS > HS_MAX Then HS_POS = HS_MAX
If HS_POS > HS_MAX - (xe - xs) \ _FontWidth Then HS_POS = HS_MAX - (xe - xs) \ _FontWidth
VS_Wdth = xe - xs
VS_Hght = ye - ys
Line (xs, ys)-(xe, ye), _RGB32(200), BF
Line (xs, ys)-(xe, ye), _RGB32(120), B
If Len(_Trim$(Title$)) > VS_Wdth \ _FontWidth Then
Title$ = Mid$(Title$, 1, VS_Wdth \ _FontWidth - 3) + "..."
End If
_PrintMode _KeepBackground
Color _RGB32(0)
_PrintString (xs + VS_Wdth \ 2 - _PrintWidth(Title$) \ 2, ys), Title$
Line (xs, ys + _FontHeight)-(xe, ys + _FontHeight), _RGB32(120)
If VS_Pos > ListEnd - 1 Then
Nr_lines = (ye - ys) \ _FontHeight
ListStart = VS_Pos - Nr_lines + 3
End If
If ListStart > 3 + UBound(a) - VS_Hght \ _FontHeight Then ListStart = 3 + UBound(a) - VS_Hght \ _FontHeight
If VS_Pos < ListStart Then ListStart = VS_Pos
If ListStart < 0 Then ListStart = 0
ListEnd = ListStart + VS_Hght \ _FontHeight
If VS_Hght \ _FontHeight Mod _FontHeight Then ListEnd = ListEnd - 3
If ListEnd > UBound(a) Then ListEnd = UBound(a)
i = 0
_PrintMode _FillBackground
For s = ListStart To ListEnd
If VS_Pos = s Then Color _RGB32(0), _RGB32(255, 255, 0) Else Color _RGB32(0), _RGB32(200)
Select Case Mode
Case 0
If Len(a(s)) > VS_Wdth \ _FontWidth - 1 Then
a$ = Mid$(a(s), 1, VS_Wdth \ _FontWidth - 4) + "..."
Else
a$ = a(s)
End If
Case 1
' If Len(a(s)) > VS_Wdth \ _FontWidth - 1 Then 'if is used this conditon so rows, which lenght is not bigger than window width, are not scrolled to left
b$ = a(s) + String$(HS_MAX - Len(_Trim$(a(s))), Chr$(32))
a$ = Mid$(b$, HS_POS, VS_Wdth \ _FontWidth - 1)
' Else
' a$ = a(s)
' End If
End Select
_PrintString (xs + 5, 5 + ys + _FontHeight + i * _FontHeight), a$
i = i + 1
Next
'Keyboard support
k& = _KeyHit
If Mode Then
XArrow = Arrow(xs + 2, ye + 4, xe - xs - 2, 1, HS_MAX, HS_POS) 'modify this two lines (XArrow and YArrow) and move scrooll bars
End If ' and arrows to other place on the screen
Select Case k&
Case 18432: VS_Pos = VS_Pos - 1 'arrow up
Case 20480: VS_Pos = VS_Pos + 1 'arrow down
Case 13: ViewSamples = VS_Pos: Exit Function
Case 18688: VS_Pos = VS_Pos - (ye - ys) \ _FontHeight 'PgUp
Case 20736: VS_Pos = VS_Pos + (ye - ys) \ _FontHeight 'PgDn
Case 19200: HS_POS = HS_POS - 1 'arrow left
Case 19712: HS_POS = HS_POS + 1 'arrow right
Case 18176: HS_POS = 1 ' home
Case 20224: HS_POS = HS_MAX ' end
End Select
If VS_Pos < 0 Then VS_Pos = 0
If VS_Pos > UBound(a) Then VS_Pos = UBound(a)
End Function
Function Arrow (Xs As Integer, Ys As Integer, Lenght As Integer, Typ As _Byte, SizeOf As Long, SizeNow As Long)
Arrow = 0
Static OldMy
'function draw a rectangular field on the axis with arrows at the end.
'SizeOf: maximum size (number of total records in array or lenght of the longest string)
'SizeNow: current position number (number of the record in the field or number of the position in the string from the left)
'Xs: left upper corner X axis position
'Ys: left upper corner Y axis position
'Lenght: lenght (width for Typ = 1 or height for typ = -1) for scroll bar with arrows in pixels
'Typ: 1 is for horizontal dialog (scrollbar in X axis)
' -1 is for vertical dialog (scrollbar in Y axis)
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
MB = _MouseButton(1)
Select Case Typ
Case -1 ' this is for Y axis (vertical dialog)
X1 = Xs: X2 = Xs + 7 'up arrow
Y1 = Ys: Y2 = Ys + 12
'logic - up arrow
MouseInUP = 0
UpArrowColor~& = _RGB32(96)
If MX > X1 And MX < X2 Then
If MY > Y1 And MY < Y2 Then
If MB Then Arrow = -1
UpArrowColor~& = _RGB32(75)
Line (X1, Y1)-(X2, Y2), _RGB32(190), BF
MouseInUP = 1
End If
End If
If MouseInUP = 0 Then Line (X1, Y1)-(X2, Y2), _RGB32(250), BF
'end for logic up arrow
'logic down arrow
MouseInDN = 0
DnArrowColor~& = _RGB32(96)
If MX > X3 And MX < X4 Then
If MY > Y3 And MY < y4 Then
If MB Then Arrow = 1
DnArrowColor~& = _RGB32(75)
Line (X3, Y3)-(X4, y4), _RGB32(190), BF
MouseInDN = 1
End If
End If
If MouseInDN = 0 Then Line (X3, Y3)-(X4, y4), _RGB32(250), BF
'end for logic down arrow
'arrow size: 7x6 pixels
Restore arrbin
For X = 0 To 6
For Y = 0 To 5
Read Z
If Z Then
PSet (Xs + X, Ys + Y), UpArrowColor~& 'sipka nahoru
PSet (Xs + X, Ys - Y + Lenght), DnArrowColor~& 'sipka dolu
End If
Next Y, X
Line (Xs - 2, Ys - 2)-(Xs + 9, Ys + Lenght + 2), _RGB32(100), B 'outter line
'Description of the inner rectangle:
'If you can see all the lines of text in the window, the rectangle is over the entire slider.
'If you can only see 50 percent of the text in the window, the rectangle is exactly halfway up the slider.
'The length of the rectangle is determined by calculating percentages.
'If you see 10 percent of the text in the window (100 percent is the maximum size of the field
'passed - we are talking about scrolling up and down), then the length of the displayed rectangle will be
'exactly 10 percent of the length between the arrows of the dialog box. However, arrows are also drawn
'in this length, therefore the length between the upper and lower border of the dialog is reduced
'by 16 pixels (8 pixels for one arrow). This length is then the basis of 100 percent in pixels for calculating
'the length of the rectangle between the arrows.
arrbin: 'arrow image descriptor point by point
Data 0,0,0,1,1,1,0,0,1,1,1,0,0,1,1,1,0,0,1,1,1,0,0,0,0,1,1,1,0,0,0,0,1,1,1,0,0,0,0,1,1,1
Visible = (Lenght \ _FontHeight) - 2
PointerLenPercent = Visible / SizeOf
If PointerLenPercent > 1 Then PointerLenPercent = 1
'To increase the speed, the percentage of the height that the mouse click came from
' is calculated here. This will determine which record in the field it corresponds
' to (for example, in a dialog with a height of 100 pixels, you click on a position
' 20 pixels from the top, that is 20 percent. The passed field has a thousand records.
' 20 percents of a thousand records is 200, so you want to see position 200 Because the
'dialog knows which position you are in, it will return the difference between the current
'position in the field and the calculated position in the field (for example, if you are at
' position 50 when you click the mouse in the bar, the program will return the value 150 )
'condition for move by clicking to rectangle in scrollbar
If MX > Xs - 70 And MX < Xs + 70 Then
If MY >= RectanglePos - 20 And MY <= RectanglePos + RectangleSize + 20 Then
RecTangleColor~& = _RGB32(75)
If MB Then
'logic - left arrow
MouseInUP = 0
LeftArrowColor~& = _RGB32(96)
If MX > X1 And MX < X2 Then
If MY > Y1 And MY < Y2 Then
If MB Then Arrow = -1
LeftArrowColor~& = _RGB32(75)
Line (X1, Y1)-(X2, Y2), _RGB32(190), BF
MouseInUP = 1
End If
End If
If MouseInUP = 0 Then Line (X1, Y1)-(X2, Y2), _RGB32(250), BF
'logic left arrow - end
'logic right arrow
MouseInDN = 0
RightArrowColor~& = _RGB32(96)
If MX > X3 And MX < X4 Then
If MY > Y3 And MY < y4 Then
If MB Then Arrow = 1
RightArrowColor~& = _RGB32(75)
Line (X3, Y3)-(X4, y4), _RGB32(190), BF
MouseInDN = 1
End If
End If
If MouseInDN = 0 Then Line (X3, Y3)-(X4, y4), _RGB32(250), BF
'logic right arrow - end
'arrow size is 7x6 pixels
Restore arrbin2
For X = 0 To 5
For Y = 0 To 6
Read Z1
If Z1 Then
PSet (Xs + X, Ys + Y), LeftArrowColor~& 'arrow up
PSet (Xs + Lenght - X, Ys + Y), RightArrowColor~& 'arrow down
End If
Next Y, X
Line (Xs - 2, Ys - 2)-(Xs + Lenght + 2, Ys + 9), _RGB32(100), B 'outter line
'The calculation of the size of the rectangle inside the slider is similar to the previous case:
'First, the length of the longest string in the array is determined (see line 46 for the calculation of
'the variable HS_MAX which is then passed to the function as a parameter) and then the same procedure
'is followed. You click the mouse in the rectangle, it calculates how many percent from the left edge
'it is, the same number of percent in the length of the chain is calculated, the default shift from
'left to right is taken into account, and that is subtracted.
'Example. You are on third posiiton from the left. You click in the rectangle.
'According to the position of the mouse in the Y axis, it is calculated that you
'click 11 percent away from the position Ys + 8 (8 pixels occupied by the arrow).
'So you want to get to the 11 percent position on the X axis in the string text.
'This means that if, for example, the variable HS_MAX, which is passed to the function
'by the SizeOf parameter, is 250, then the longest string has 250 characters. 11 percents
'of 250 characters is 28 characters after rounding. Since you are at position 3, the function
'returns an offset of 25 characters.
'arrow image data point by point
arrbin2:
Data 0,0,0,1,0,0,0,0,0,1,1,1,0,0,0,1,1,1,1,1,0,1,1,1,0,1,1,1,1,1,0,0,0,1,1,1,0,0,0,0,0,1
Visible = ((Lenght - 16) \ _FontWidth) ' how much characters is visible in window
PointerLenPercent = Visible \ (SizeOf / 100) ' how much percents it is (SizeOf is longest string lenght)
PointerLenPercent = PointerLenPercent / 100
If PointerLenPercent > 1 Then PointerLenPercent = 1
If MX >= RectanglePos - RectangleSize - 16 And MX <= RectanglePos + RectangleSize + 16 Then
If MY > Ys - 5 And MY < Ys + 16 Then
RecTangleColor~& = _RGB32(75)
If MB Then
PercentAm = (MX - Xs - 8) / (Lenght - 16)
Iam = PercentAm * SizeOf
arr = Iam - SizeNow
Arrow = Int(arr)
End If
End If
End If
Line (Xs + 8, Ys - 1)-(Xs + Lenght - 8, Ys + 8), _RGB32(255), BF 'clear area before draw new rectangle to new position
Line (RectanglePos, Ys)-(RectanglePos + RectangleSize, Ys + 8), RecTangleColor~&, BF
End Select
End Function
Here's an old program I made at the old forum before I knew PLAY could play more than one note at a time. It used _SNDRAW to build notes and play them from the sound buffer. Now that QB64PE has _SNDNEW,_MEMSOUND, etc. I wondered if this program can be used with those somehow.
Instead of playing with _SNDRAW like this, Is it possible to feed the data to a _SNDNEW memory instead so I could have the song with a handle for using it with _SNDPLAY controls?
I thought perhaps this music generator can be useful again for making background songs and play them using _SNDPLAY, and also still have PLAY & SOUND available too for sounds as well, like sound effects.
- Dav
Code: (Select All)
'==============
'SNDRAWPLAY.BAS v2.0
'==============
'Attempting a PLAY-like song format using _SNDRAW
'Plays notes and allows more than one note to sound at the same time.
'Can play notes in the background.
'Coded By Dav, JAN/2021
'All 88 notes are available.
'Regular notes are lowercase (d4), Sharp notes are upper (D4).
'You can play a notes like this: f3 g3 a3 A3 cf d4 e4 f4
'Play a chord of notes by grouping inside (), like: (c4 e4 g4)
'Assign current note/rest length values like this...
'WN = Whole note, HN = Half note, DQ = Dotted quarter note
'QN = Quarter note, EN = Eighth note, SN = Sixteenth note
'Rests - nothing played, but time continues
'RN = Rest note. Uses current note length value set.
'For example, to rest a quarter note, do this:
'QN RN
'Assign Tempos like this (always must be in 4 characters):
'T120 ... or T060 ... or T100
'Assign current meter (for whole length value to work)
'M3 (thats for 3/4).... M4 (Thats for 4/4)
'=== Playing two octaves of all notes c3 to c5...
'Set tempo 120, meter 4/4, set sixteen note value
SPLAY "t160 m4 sn c3C3d3D3e3f3F3g3G3a3A3b3c4C4d4D4e4f4F4g4G4a4A4b4c5"
Do
Color Rnd * 16
Print "Testing all notes...c3 to c5..."
Loop While _SndRawLen
_SndRawDone
'=== Playing a background song.... Silent Night.,,,
Do
Color Rnd * 16
Print "Silent Night ";
If InKey$ <> "" Then Exit Do
Loop While _SndRawLen
_SndRawDone
End
Sub SPLAY (Music$)
rate = _SndRate
'Set Defaults, just in case empty
If Tempo = 0 Then Tempo = 60
If Meter = 0 Then Meter = 3
If NoteValue = 0 Then NoteValue = 1
cur = 1
Do
'skip any spaces
If Mid$(Music$, cur, 1) = " " Then cur = cur + 1
'Check for tempo
If UCase$(Mid$(Music$, cur, 1)) = "T" Then
cur = cur + 1
Tempo = Val(Mid$(Music$, cur, 3)): cur = cur + 3
End If
'Check for Meter
If UCase$(Mid$(Music$, cur, 1)) = "M" Then
cur = cur + 1
Meter = Val(Mid$(Music$, cur, 1)): cur = cur + 1
End If
'Get notevalue
Select Case UCase$(Mid$(Music$, cur, 2))
Case Is = "DQ": cur = cur + 2: NoteValue = 1.5
Case Is = "EN": cur = cur + 2: NoteValue = .5
Case Is = "QN": cur = cur + 2: NoteValue = 1
Case Is = "HN": cur = cur + 2: NoteValue = 2
Case Is = "WN": cur = cur + 2
If Meter = 3 Then NoteValue = 3 Else NoteValue = 4
Case Is = "SN": cur = cur + 2: NoteValue = .25
End Select
'If regular note/rest found (not a group)
Select Case Mid$(Music$, cur, 2)
Case Is = "a0": note = 27.50: cur = cur + 2: GoSub LoadNote
Case Is = "A0": note = 29.14: cur = cur + 2: GoSub LoadNote
Case Is = "b0": note = 30.87: cur = cur + 2: GoSub LoadNote
Case Is = "c1": note = 32.70: cur = cur + 2: GoSub LoadNote
Case Is = "C1": note = 34.65: cur = cur + 2: GoSub LoadNote
Case Is = "d1": note = 36.71: cur = cur + 2: GoSub LoadNote
Case Is = "D1": note = 38.89: cur = cur + 2: GoSub LoadNote
Case Is = "e1": note = 41.20: cur = cur + 2: GoSub LoadNote
Case Is = "f1": note = 43.65: cur = cur + 2: GoSub LoadNote
Case Is = "F1": note = 46.25: cur = cur + 2: GoSub LoadNote
Case Is = "g1": note = 49.00: cur = cur + 2: GoSub LoadNote
Case Is = "G1": note = 51.91: cur = cur + 2: GoSub LoadNote
Case Is = "a1": note = 55.00: cur = cur + 2: GoSub LoadNote
Case Is = "A1": note = 58.27: cur = cur + 2: GoSub LoadNote
Case Is = "b1": note = 61.74: cur = cur + 2: GoSub LoadNote
Case Is = "c2": note = 65.41: cur = cur + 2: GoSub LoadNote
Case Is = "C2": note = 69.30: cur = cur + 2: GoSub LoadNote
Case Is = "d2": note = 73.42: cur = cur + 2: GoSub LoadNote
Case Is = "D2": note = 77.78: cur = cur + 2: GoSub LoadNote
Case Is = "e2": note = 82.41: cur = cur + 2: GoSub LoadNote
Case Is = "f2": note = 87.31: cur = cur + 2: GoSub LoadNote
Case Is = "F2": note = 92.50: cur = cur + 2: GoSub LoadNote
Case Is = "g2": note = 98.00: cur = cur + 2: GoSub LoadNote
Case Is = "G2": note = 103.83: cur = cur + 2: GoSub LoadNote
Case Is = "a2": note = 110.00: cur = cur + 2: GoSub LoadNote
Case Is = "A2": note = 116.54: cur = cur + 2: GoSub LoadNote
Case Is = "b2": note = 123.47: cur = cur + 2: GoSub LoadNote
Case Is = "c3": note = 130.81: cur = cur + 2: GoSub LoadNote
Case Is = "C3": note = 138.59: cur = cur + 2: GoSub LoadNote
Case Is = "d3": note = 146.83: cur = cur + 2: GoSub LoadNote
Case Is = "D3": note = 155.56: cur = cur + 2: GoSub LoadNote
Case Is = "e3": note = 164.81: cur = cur + 2: GoSub LoadNote
Case Is = "f3": note = 174.61: cur = cur + 2: GoSub LoadNote
Case Is = "F3": note = 185.00: cur = cur + 2: GoSub LoadNote
Case Is = "g3": note = 196.00: cur = cur + 2: GoSub LoadNote
Case Is = "G3": note = 207.65: cur = cur + 2: GoSub LoadNote
Case Is = "a3": note = 220.00: cur = cur + 2: GoSub LoadNote
Case Is = "A3": note = 233.08: cur = cur + 2: GoSub LoadNote
Case Is = "b3": note = 246.94: cur = cur + 2: GoSub LoadNote
Case Is = "c4": note = 261.63: cur = cur + 2: GoSub LoadNote
Case Is = "C4": note = 277.18: cur = cur + 2: GoSub LoadNote
Case Is = "d4": note = 293.66: cur = cur + 2: GoSub LoadNote
Case Is = "D4": note = 311.13: cur = cur + 2: GoSub LoadNote
Case Is = "e4": note = 329.63: cur = cur + 2: GoSub LoadNote
Case Is = "f4": note = 349.23: cur = cur + 2: GoSub LoadNote
Case Is = "F4": note = 369.99: cur = cur + 2: GoSub LoadNote
Case Is = "g4": note = 392.00: cur = cur + 2: GoSub LoadNote
Case Is = "G4": note = 415.30: cur = cur + 2: GoSub LoadNote
Case Is = "a4": note = 440.00: cur = cur + 2: GoSub LoadNote
Case Is = "A4": note = 466.16: cur = cur + 2: GoSub LoadNote
Case Is = "b4": note = 493.88: cur = cur + 2: GoSub LoadNote
Case Is = "c5": note = 523.25: cur = cur + 2: GoSub LoadNote
Case Is = "C5": note = 554.37: cur = cur + 2: GoSub LoadNote
Case Is = "d5": note = 587.33: cur = cur + 2: GoSub LoadNote
Case Is = "D5": note = 622.25: cur = cur + 2: GoSub LoadNote
Case Is = "e5": note = 659.25: cur = cur + 2: GoSub LoadNote
Case Is = "f5": note = 698.46: cur = cur + 2: GoSub LoadNote
Case Is = "F5": note = 739.99: cur = cur + 2: GoSub LoadNote
Case Is = "g5": note = 783.99: cur = cur + 2: GoSub LoadNote
Case Is = "G5": note = 830.61: cur = cur + 2: GoSub LoadNote
Case Is = "a5": note = 880.00: cur = cur + 2: GoSub LoadNote
Case Is = "A5": note = 932.33: cur = cur + 2: GoSub LoadNote
Case Is = "b5": note = 987.77: cur = cur + 2: GoSub LoadNote
Case Is = "c6": note = 1046.50: cur = cur + 2: GoSub LoadNote
Case Is = "C6": note = 1108.73: cur = cur + 2: GoSub LoadNote
Case Is = "d6": note = 1174.66: cur = cur + 2: GoSub LoadNote
Case Is = "D6": note = 1244.51: cur = cur + 2: GoSub LoadNote
Case Is = "e6": note = 1318.51: cur = cur + 2: GoSub LoadNote
Case Is = "f6": note = 1396.91: cur = cur + 2: GoSub LoadNote
Case Is = "F6": note = 1479.98: cur = cur + 2: GoSub LoadNote
Case Is = "g6": note = 1567.98: cur = cur + 2: GoSub LoadNote
Case Is = "G6": note = 1661.22: cur = cur + 2: GoSub LoadNote
Case Is = "a6": note = 1760.00: cur = cur + 2: GoSub LoadNote
Case Is = "A6": note = 1864.66: cur = cur + 2: GoSub LoadNote
Case Is = "b6": note = 1975.53: cur = cur + 2: GoSub LoadNote
Case Is = "c7": note = 2093.00: cur = cur + 2: GoSub LoadNote
Case Is = "C7": note = 2217.46: cur = cur + 2: GoSub LoadNote
Case Is = "d7": note = 2349.32: cur = cur + 2: GoSub LoadNote
Case Is = "D7": note = 2489.02: cur = cur + 2: GoSub LoadNote
Case Is = "e7": note = 2637.02: cur = cur + 2: GoSub LoadNote
Case Is = "f7": note = 2793.83: cur = cur + 2: GoSub LoadNote
Case Is = "F7": note = 2959.96: cur = cur + 2: GoSub LoadNote
Case Is = "g7": note = 3135.96: cur = cur + 2: GoSub LoadNote
Case Is = "G7": note = 3322.44: cur = cur + 2: GoSub LoadNote
Case Is = "a7": note = 3520.00: cur = cur + 2: GoSub LoadNote
Case Is = "A7": note = 3729.31: cur = cur + 2: GoSub LoadNote
Case Is = "b7": note = 3951.07: cur = cur + 2: GoSub LoadNote
Case Is = "c8": note = 4186.01: cur = cur + 2: GoSub LoadNote
Case Is = "RN", "rn": note = 0: cur = cur + 2: GoSub LoadNote
End Select
'if group of notes found
If Mid$(Music$, cur, 1) = "(" Then
cur = cur + 1
'Grab up until ')' found
Group$ = ""
Do
a$ = Mid$(Music$, cur, 1): cur = cur + 1
If a$ = ")" Then Exit Do
If a$ <> " " Then Group$ = Group$ + a$
Loop
NumOfNotes = Len(Group$) / 2
Length = (60 * NoteValue / Tempo)
For L = 0 To Length * rate Step NumOfNotes
For N = 1 To Len(Group$) Step 2
'fade = EXP(-L / rate * 8)
note$ = Mid$(Group$, N, 2)
If note$ = "a0" Then _SndRaw Sin((L / rate) * 27.50 * Atn(1) * 8) '* fade.
If note$ = "A0" Then _SndRaw Sin((L / rate) * 29.14 * Atn(1) * 8) '* fade.
If note$ = "b0" Then _SndRaw Sin((L / rate) * 30.87 * Atn(1) * 8) '* fade.
If note$ = "c1" Then _SndRaw Sin((L / rate) * 32.70 * Atn(1) * 8) '* fade.
If note$ = "C1" Then _SndRaw Sin((L / rate) * 34.65 * Atn(1) * 8) '* fade.
If note$ = "d1" Then _SndRaw Sin((L / rate) * 36.71 * Atn(1) * 8) '* fade.
If note$ = "D1" Then _SndRaw Sin((L / rate) * 38.89 * Atn(1) * 8) '* fade.
If note$ = "e1" Then _SndRaw Sin((L / rate) * 41.20 * Atn(1) * 8) '* fade.
If note$ = "f1" Then _SndRaw Sin((L / rate) * 43.65 * Atn(1) * 8) '* fade.
If note$ = "F1" Then _SndRaw Sin((L / rate) * 46.25 * Atn(1) * 8) '* fade.
If note$ = "g1" Then _SndRaw Sin((L / rate) * 49.00 * Atn(1) * 8) '* fade.
If note$ = "G1" Then _SndRaw Sin((L / rate) * 51.91 * Atn(1) * 8) '* fade.
If note$ = "a1" Then _SndRaw Sin((L / rate) * 55.00 * Atn(1) * 8) '* fade.
If note$ = "A1" Then _SndRaw Sin((L / rate) * 58.27 * Atn(1) * 8) '* fade.
If note$ = "b1" Then _SndRaw Sin((L / rate) * 61.74 * Atn(1) * 8) '* fade.
If note$ = "c2" Then _SndRaw Sin((L / rate) * 65.41 * Atn(1) * 8) '* fade.
If note$ = "C2" Then _SndRaw Sin((L / rate) * 69.30 * Atn(1) * 8) '* fade.
If note$ = "d2" Then _SndRaw Sin((L / rate) * 73.42 * Atn(1) * 8) '* fade.
If note$ = "D2" Then _SndRaw Sin((L / rate) * 77.78 * Atn(1) * 8) '* fade.
If note$ = "e2" Then _SndRaw Sin((L / rate) * 82.41 * Atn(1) * 8) '* fade.
If note$ = "f2" Then _SndRaw Sin((L / rate) * 87.31 * Atn(1) * 8) '* fade.
If note$ = "F2" Then _SndRaw Sin((L / rate) * 92.50 * Atn(1) * 8) '* fade.
If note$ = "g2" Then _SndRaw Sin((L / rate) * 98.00 * Atn(1) * 8) '* fade.
If note$ = "G2" Then _SndRaw Sin((L / rate) * 103.83 * Atn(1) * 8) '* fade.
If note$ = "a2" Then _SndRaw Sin((L / rate) * 110.00 * Atn(1) * 8) '* fade.
If note$ = "A2" Then _SndRaw Sin((L / rate) * 116.54 * Atn(1) * 8) '* fade.
If note$ = "b2" Then _SndRaw Sin((L / rate) * 123.47 * Atn(1) * 8) '* fade.
If note$ = "c3" Then _SndRaw Sin((L / rate) * 130.81 * Atn(1) * 8) '* fade.
If note$ = "C3" Then _SndRaw Sin((L / rate) * 138.59 * Atn(1) * 8) '* fade.
If note$ = "d3" Then _SndRaw Sin((L / rate) * 146.83 * Atn(1) * 8) '* fade.
If note$ = "D3" Then _SndRaw Sin((L / rate) * 155.56 * Atn(1) * 8) '* fade.
If note$ = "e3" Then _SndRaw Sin((L / rate) * 164.81 * Atn(1) * 8) '* fade.
If note$ = "f3" Then _SndRaw Sin((L / rate) * 174.61 * Atn(1) * 8) '* fade.
If note$ = "F3" Then _SndRaw Sin((L / rate) * 185.00 * Atn(1) * 8) '* fade.
If note$ = "g3" Then _SndRaw Sin((L / rate) * 196.00 * Atn(1) * 8) '* fade.
If note$ = "G3" Then _SndRaw Sin((L / rate) * 207.65 * Atn(1) * 8) '* fade.
If note$ = "a3" Then _SndRaw Sin((L / rate) * 220.00 * Atn(1) * 8) '* fade.
If note$ = "A3" Then _SndRaw Sin((L / rate) * 233.08 * Atn(1) * 8) '* fade.
If note$ = "b3" Then _SndRaw Sin((L / rate) * 246.94 * Atn(1) * 8) '* fade.
If note$ = "c4" Then _SndRaw Sin((L / rate) * 261.63 * Atn(1) * 8) '* fade.
If note$ = "C4" Then _SndRaw Sin((L / rate) * 277.18 * Atn(1) * 8) '* fade.
If note$ = "d4" Then _SndRaw Sin((L / rate) * 293.66 * Atn(1) * 8) '* fade.
If note$ = "D4" Then _SndRaw Sin((L / rate) * 311.13 * Atn(1) * 8) '* fade.
If note$ = "e4" Then _SndRaw Sin((L / rate) * 329.63 * Atn(1) * 8) '* fade.
If note$ = "f4" Then _SndRaw Sin((L / rate) * 349.23 * Atn(1) * 8) '* fade.
If note$ = "F4" Then _SndRaw Sin((L / rate) * 369.99 * Atn(1) * 8) '* fade.
If note$ = "g4" Then _SndRaw Sin((L / rate) * 392.00 * Atn(1) * 8) '* fade.
If note$ = "G4" Then _SndRaw Sin((L / rate) * 415.30 * Atn(1) * 8) '* fade.
If note$ = "a4" Then _SndRaw Sin((L / rate) * 440.00 * Atn(1) * 8) '* fade.
If note$ = "A4" Then _SndRaw Sin((L / rate) * 466.16 * Atn(1) * 8) '* fade.
If note$ = "b4" Then _SndRaw Sin((L / rate) * 493.88 * Atn(1) * 8) '* fade.
If note$ = "c5" Then _SndRaw Sin((L / rate) * 523.25 * Atn(1) * 8) '* fade.
If note$ = "C5" Then _SndRaw Sin((L / rate) * 554.37 * Atn(1) * 8) '* fade.
If note$ = "d5" Then _SndRaw Sin((L / rate) * 587.33 * Atn(1) * 8) '* fade.
If note$ = "D5" Then _SndRaw Sin((L / rate) * 622.25 * Atn(1) * 8) '* fade.
If note$ = "e5" Then _SndRaw Sin((L / rate) * 659.25 * Atn(1) * 8) '* fade.
If note$ = "f5" Then _SndRaw Sin((L / rate) * 698.46 * Atn(1) * 8) '* fade.
If note$ = "F5" Then _SndRaw Sin((L / rate) * 739.99 * Atn(1) * 8) '* fade.
If note$ = "g5" Then _SndRaw Sin((L / rate) * 783.99 * Atn(1) * 8) '* fade.
If note$ = "G5" Then _SndRaw Sin((L / rate) * 830.61 * Atn(1) * 8) '* fade.
If note$ = "a5" Then _SndRaw Sin((L / rate) * 880.00 * Atn(1) * 8) '* fade.
If note$ = "A5" Then _SndRaw Sin((L / rate) * 932.33 * Atn(1) * 8) '* fade.
If note$ = "b5" Then _SndRaw Sin((L / rate) * 987.77 * Atn(1) * 8) '* fade.
If note$ = "c6" Then _SndRaw Sin((L / rate) * 1046.50 * Atn(1) * 8) '* fade.
If note$ = "C6" Then _SndRaw Sin((L / rate) * 1108.73 * Atn(1) * 8) '* fade.
If note$ = "d6" Then _SndRaw Sin((L / rate) * 1174.66 * Atn(1) * 8) '* fade.
If note$ = "D6" Then _SndRaw Sin((L / rate) * 1244.51 * Atn(1) * 8) '* fade.
If note$ = "e6" Then _SndRaw Sin((L / rate) * 1318.51 * Atn(1) * 8) '* fade.
If note$ = "f6" Then _SndRaw Sin((L / rate) * 1396.91 * Atn(1) * 8) '* fade.
If note$ = "F6" Then _SndRaw Sin((L / rate) * 1479.98 * Atn(1) * 8) '* fade.
If note$ = "g6" Then _SndRaw Sin((L / rate) * 1567.98 * Atn(1) * 8) '* fade.
If note$ = "G6" Then _SndRaw Sin((L / rate) * 1661.22 * Atn(1) * 8) '* fade.
If note$ = "a6" Then _SndRaw Sin((L / rate) * 1760.00 * Atn(1) * 8) '* fade.
If note$ = "A6" Then _SndRaw Sin((L / rate) * 1864.66 * Atn(1) * 8) '* fade.
If note$ = "b6" Then _SndRaw Sin((L / rate) * 1975.53 * Atn(1) * 8) '* fade.
If note$ = "c7" Then _SndRaw Sin((L / rate) * 2093.00 * Atn(1) * 8) '* fade.
If note$ = "C7" Then _SndRaw Sin((L / rate) * 2217.46 * Atn(1) * 8) '* fade.
If note$ = "d7" Then _SndRaw Sin((L / rate) * 2349.32 * Atn(1) * 8) '* fade.
If note$ = "D7" Then _SndRaw Sin((L / rate) * 2489.02 * Atn(1) * 8) '* fade.
If note$ = "e7" Then _SndRaw Sin((L / rate) * 2637.02 * Atn(1) * 8) '* fade.
If note$ = "f7" Then _SndRaw Sin((L / rate) * 2793.83 * Atn(1) * 8) '* fade.
If note$ = "F7" Then _SndRaw Sin((L / rate) * 2959.96 * Atn(1) * 8) '* fade.
If note$ = "g7" Then _SndRaw Sin((L / rate) * 3135.96 * Atn(1) * 8) '* fade.
If note$ = "G7" Then _SndRaw Sin((L / rate) * 3322.44 * Atn(1) * 8) '* fade.
If note$ = "a7" Then _SndRaw Sin((L / rate) * 3520.00 * Atn(1) * 8) '* fade.
If note$ = "A7" Then _SndRaw Sin((L / rate) * 3729.31 * Atn(1) * 8) '* fade.
If note$ = "b7" Then _SndRaw Sin((L / rate) * 3951.07 * Atn(1) * 8) '* fade.
If note$ = "c8" Then _SndRaw Sin((L / rate) * 4186.01 * Atn(1) * 8) '* fade.
Next
Next
End If
If cur >= Len(Music$) Then Exit Do
'IF INKEY$ <> "" THEN EXIT SUB
Loop
Exit Sub
'=========================================================
LoadNote:
'========
Length = (60 * NoteValue / Tempo)
For L = 0 To Length * rate
'fade = Exp(-L / rate * 8)
If note = 0 Then
_SndRaw 0
Else
_SndRaw Sin((L / rate) * note * Atn(1) * 8) '* fade
End If
Next
Return
)
