Function RoundText& (text As String, InternalRadius As Integer, StartRadius As Single)
D = _Dest: So = _Source
VImg& = _NewImage(_PrintWidth(text) + 1, _FontHeight + 1, 32)
Ob = (InternalRadius + _FontHeight)
Ol = InternalRadius
_Dest VImg&: _PrintString (0, 0), text$: _Dest D
R& = _NewImage((InternalRadius + _FontHeight) * 2, (InternalRadius + _FontHeight) * 2, 32)
U = _Width(R&) / 2
Dim X(4), Y(4), sX(4), sY(4)
S = 200
PW = _PrintWidth(text)
p2 = CInt(PW / S)
For C = StartRadius To StartRadius + _Pi(2) Step (_Pi(2) / S) ' 200 steps
'dest
X(1) = U + Cos(C) * Ob
Y(1) = U + Sin(C) * Ob
X(2) = U + Cos(C) * Ol
Y(2) = U + Sin(C) * Ol
X(3) = U + Cos(C + _Pi(2) / S) * Ob
Y(3) = U + Sin(C + _Pi(2) / S) * Ob
X(4) = U + Cos(C + _Pi(2) / S) * Ol
Y(4) = U + Sin(C + _Pi(2) / S) * Ol
'source
sX(1) = (PW / S) * n
sY(1) = 0
sX(2) = sX(1)
sY(2) = _FontHeight
sX(3) = sX(1) + PW / S
sY(3) = 0
sX(4) = sX(3)
sY(4) = sY(2)
n = n + p2
If n > S Then Exit For
_MapTriangle (sX(1), sY(1))-(sX(2), sY(2))-(sX(3), sY(3)), VImg& To(X(1), Y(1))-(X(2), Y(2))-(X(3), Y(3)), R&
_MapTriangle (sX(2), sY(2))-(sX(3), sY(3))-(sX(4), sY(4)), VImg& To(X(2), Y(2))-(X(3), Y(3))-(X(4), Y(4)), R&
Next
RoundText& = R&
End Function
Very simply, this little program will count the lines in your code and output the results
to a file. You specify the code file and output file, then it scans and counts. It ignores
whitespace and comments, and gives a line count for each sub and function, as well as a total
for the whole program.
Not terribly useful, but gives more exact and detailed info than just copypasting your code
into something like pastebin.
Code: (Select All)
$noprefix
const true = -1
const false = 0
screen 12
cls , 15
color 0, 15
do
input "Code file: ", f1$
loop until fileexists(f1$) = true
do
input "Output file: ", f2$
loop until fileexists(f2$) = false
open f1$ for input as #1
line_count = 0
dim l$(line_count)
do until eof(1)
line_count = line_count + 1
redim preserve l$(line_count)
line input #1, l$(line_count)
loop
close #1
total_lines = 0
sub_count = 0
for n = 1 to line_count
if processed_left$(l$(n), 4) = "sub " or processed_left$(l$(n), 9) = "function " then sub_count = sub_count + 1
if processed_left$(l$(n), 1) = "'" or trim$(l$(n)) = "" then continue
total_lines = total_lines + 1
next n
dim sub_lines(sub_count)
dim sub_name$(sub_count)
sub_name$(0) = "[Main]"
current_sub = 0
for n = 1 to line_count
if processed_left$(l$(n), 1) = "'" or trim$(l$(n)) = "" then continue
if processed_left$(l$(n), 4) = "sub " or processed_left$(l$(n), 9) = "function " then
current_sub = current_sub + 1
sub_name$(current_sub) = before$(ltrim$(lcase$(l$(n))), "(")
end if
sub_lines(current_sub) = sub_lines(current_sub) + 1
next n
print
total_test = 0
open f2$ for output as #1
for n = 0 to sub_count
double_print sub_name$(n) + ":" + str$(sub_lines(n))
total_test = total_test + sub_lines(n)
next n
double_print ""
double_print "Total by count:" + str$(total_lines)
double_print "Total by sum:" + str$(total_test)
close #1
function processed_left$(t$, c)
processed_left$ = left$(ltrim$(lcase$(t$)), c)
end function
sub double_print(t$)
print t$
print #1, t$
end sub
function before$(t$, c$)
p = instr(t$, c$)
if p = false then p = len(t$) + 1
before$ = left$(t$, p - 1)
end function
This routine will apply a desaturation effect to a graphics surface. You pass the handle
and a number from 0 to 1, where 0 does not desaturate at all, and 1 turns everything to greyscale.
Code: (Select All)
sub desaturate(d~&, rate)
' Desaturate image surface d~& at a rate of 0 (no desaturation) to 1 (full greyscale)
preserve1& = source
preserve2& = dest
_source d~&
_dest d~&
for y = 0 to _width: for x = 0 to _height
h& = point(x, y)
r = _red(h&): g = _green(h&): b = _blue(h&)
grey = int((r + g + b) * 0.333)
r = r + ((grey - r) * rate)
g = g + ((grey - g) * rate)
b = b + ((grey - b) * rate)
pset(x, y), _rgb(r, g, b)
next x: next y
_source preserve1&
_dest preserve2&
end sub
Limitations:
- The desaturation is rather expensive, so you may have performance issues if you are doing this
many times per second. The way I've used this in my own project is to desaturate a background
that isn't going to change, then store the desaturated version for use in redrawing the screen,
so the desaturation effect only needs to be applied once.
- This is currently using _rgb(), which means it's not accounting for alpha values. I haven't
tested extensively how point() interacts with alpha, and I seem to remember having some issues
in the past, so I have no plans to update this to use _rgba() or _rgba32(). So if you use this
on a graphics surface, expect to lose any transparency.
Posted by: Petr - 02-24-2023, 07:22 PM - Forum: Petr
- Replies (5)
Hello. I wrote a function that you just push a music file, set the echo length and volume (in the range from 0 to 1) and the program will generate a new sound straight away. I used _SndNew for this.
Print "Program create new sound handle ("; news&; " )"
Print " This new handle is not full compatible:"
Print "_SndLen return: "; _SndLen(news&)
Sleep 2
Print "_SndGetPos return: "; _SndGetPos(news&)
Sleep 4
Print "Trying use _SndSetPos to begin this track..."
_SndSetPos news&, 0
Function MakeEcho& (InputSound As Long, SoundDelay As Single, EchoVolume As Single)
If SoundDelay < 0 Then Print "Error: EchoDelay must be higher than zero.": Exit Function
'EchoVolume in range 0 to 1!
Dim SourceSound As _MEM
SourceSound = _MemSound(InputSound&, 0)
Select Case GetBites(SourceSound)
Case 1, 2: Multiply = 4
Case 3: Multiply = 2
Case 4: Multiply = 1
End Select
Select Case SourceSound.TYPE
Case 260 ' 32-bit floating point
If SourceSound.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf SourceSound.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 132 ' 32-bit integer
If SourceSound.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf SourceSound.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 130: ' 16-bit integer
If SourceSound.ELEMENTSIZE = 2 Then
SndChannels = 1
ElseIf SourceSound.ELEMENTSIZE = 4 Then
SndChannels = 2
End If
Case 1153: ' 8-bit unsigned integer
If SourceSound.ELEMENTSIZE = 1 Then
SndChannels = 1
ElseIf SourceSound.ELEMENTSIZE = 2 Then
SndChannels = 2
End If
End Select
Dim As Long i, BB
Dim As Double sampL, sampL2, sampR, sampR2
Select Case SndChannels
Case 1
Select Case ME.TYPE
Case 260: _MemPut ME, ME.OFFSET + i, LeftOut As SINGLE ' 32-bit floating point
Case 132: _MemPut ME, ME.OFFSET + i, LeftOut * 2147483648 As LONG ' 32-bit integer
Case 130: _MemPut ME, ME.OFFSET + i, LeftOut * 32768 As INTEGER ' 16-bit integer
Case 1153: _MemPut ME, ME.OFFSET + i, 128 - (LeftOut * 128) As _UNSIGNED _BYTE ' 8-bit unsigned integer
End Select
Case 2
Select Case ME.TYPE
Case 260: _MemPut ME, ME.OFFSET + i, LeftOut As SINGLE: _MemPut ME, ME.OFFSET + i + ME.ELEMENTSIZE \ 2, RightOut As SINGLE ' 32-bit floating point
Case 132: _MemPut ME, ME.OFFSET + i, LeftOut * 2147483648 As LONG: _MemPut ME, ME.OFFSET + i + ME.ELEMENTSIZE \ 2, RightOut * 2147483648 As LONG ' 32-bit integer
Case 130: _MemPut ME, ME.OFFSET + i, LeftOut * 32768 As INTEGER: _MemPut ME, ME.OFFSET + i + ME.ELEMENTSIZE \ 2, RightOut * 32768 As INTEGER ' 16-bit integer
Case 1153: _MemPut ME, ME.OFFSET + i, 128 - (LeftOut * 128) As _UNSIGNED _BYTE: _MemPut ME, ME.OFFSET + i + ME.ELEMENTSIZE \ 2, 128 - (128 * RightOut) As _UNSIGNED _BYTE ' 8-bit unsigned integer
End Select
End Select
i = i + Multiply * 2
Loop
MakeEcho& = _SndCopy(MakeEch&)
_SndClose MakeEch&
If ME.SIZE Then _MemFree ME
If SourceSound.SIZE Then _MemFree SourceSound
End Function
Function GetBites (handle As _MEM)
Select Case handle.TYPE
Case 260: GetBites = 1 ' 32-bit floating point SINGLE
Case 132: GetBites = 2 ' 32-bit integer LONG
Case 130: GetBites = 3 ' 16-bit integer INTEGER
Case 1153: GetBites = 4 ' 8-bit unsigned integer
End Select
End Function
Sub PlaySound (handle As Long, rs 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, rs 'stereo
Else
_SndRaw sampL, sampL, rs 'mono = left channel in both speakers
End If
i = i + SampleData.ELEMENTSIZE
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
I have written a small test using _loadimage and _FreeImage, and all goes well except when I try to clear the images (as I believe is necessary after using them).
I get an Illegal function call message at that point. Why is it so???
Code: (Select All)
Screen _NewImage(1500, 800, 32)
GetGridSize:
Locate 15, 66
Print "Choose a grid size, 1 to 4 (for 12, 20, 30 or 42 tiles)"
Play move$
Getsize:
_KeyClear: k = 0
While k < 1
_Limit 30
k = _KeyHit
Wend
Select Case k
Case Is = 49
numtiles = 12 ' numtiles is number of tiles for that size grid
numcols = 3 ' numcols is number of columns in the grid
Case Is = 50
numtiles = 20
numcols = 5
Case Is = 51
numtiles = 30
numcols = 5
Case Is = 52
numtiles = 42
numcols = 7
Case Else
GoTo Getsize
End Select
DisplayTiles: '
numrows = numtiles / numcols ' set number of rows needed for the numtiles and numcols
Dim tiles(numtiles) As Long
For a = 1 To numtiles
tiles(a) = _LoadImage("RecPics/test.jpg", 32) ' set tiles array with numpics copies of test.jpg
Next
For a = 1 To numtiles / 2
_PutImage (60 * a, 60), tiles(a) ' display first half of tiles array
Next
For a = numtiles / 2 + 1 To numtiles
_PutImage (60 * (a - numtiles / 2), 120), tiles(a) ' display second half of tiles array
Next
Sleep 2
For a = 1 To numtiles
_FreeImage (a) ' free all of the images from memory
Next
Print "I get an error message here: Illegal function call line 45 (the _FreeImage line)"
Sleep
' Set up the camera position
cx = 0 ' Camera X coordinate
cy = 0 ' Camera Y coordinate
cz = -10 ' Camera Z coordinate
' Set up the projection parameters
near_plane = 1 ' Distance to near plane
far_plane = 100 ' Distance to far plane
fov = 90 ' Field of view in degrees
' Calculate the projection matrix
f = 1 / TAN(fov / 2 * PI / 180) ' Calculate focal length
a = f * 640 / 480 ' Calculate aspect ratio
proj_matrix(1, 1) = a: proj_matrix(2, 2) = f
proj_matrix(3, 3) = far_plane / (far_plane - near_plane)
proj_matrix(3, 4) = -far_plane * near_plane / (far_plane - near_plane)
proj_matrix(4, 3) = 1
' Apply the projection matrix to the 3D coordinates and convert to 2D screen coordinates
FOR i = 1 TO 8
' Apply the projection matrix
x_proj = x(i) * proj_matrix(1, 1) + y(i) * proj_matrix(2, 1) + z(i) * proj_matrix(3, 1) + proj_matrix(4, 1)
y_proj = x(i) * proj_matrix(1, 2) + y(i) * proj_matrix(2, 2) + z(i) * proj_matrix(3, 2) + proj_matrix(4, 2)
w_proj = x(i) * proj_matrix(1, 4) + y(i) * proj_matrix(2, 4) + z(i) * proj_matrix(3, 4) + proj_matrix(4, 4)
' Convert to 2D screen coordinates
x_screen = 320 + x_proj / w_proj * 320 ' Center the X coordinate and scale to screen size
y_screen = 240 - y_proj / w_proj * 240 ' Center the Y coordinate and flip the Y axis
' Draw a point on the screen at the converted coordinates
PSET (x_screen, y_screen), 15
NEXT i
' Wait for the user to press a key
DO
SLEEP
LOOP UNTIL INKEY$ <> ""
![[Image: screenshot-todo-half.png]](https://i.ibb.co/ZzKwRx6/screenshot-todo-half.png)
![[Image: 122.png]](https://i.ibb.co/4th2Z1Q/122.png)
