Posts: 306
Threads: 19
Joined: Apr 2022
Reputation:
57
tranny kpop matrix mod
Code: (Select All)
deflng a-z
'Option _Explicit bubu
'$Console
$VersionInfo:Comments=Avicap32 webcam to memory test
'Using $VersionInfo so we get modern controls
'------------------------------------------------------------------------------------------------------------------------------
'Capture Driver Constants
Const WM_CAP_START = &H0400
Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10
Const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11
Const WM_CAP_SET_SCALE = WM_CAP_START + 53
Const WM_CAP_SET_PREVIEW = WM_CAP_START + 50
Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42
Const WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61
Const WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44
Const WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45
Const WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41
Const WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START + 5
Const CF_DIB = &H0008
Const PM_REMOVE = &H0001
Const WS_EX_NOACTIVATE = &H08000000
Const FPS = 60 'Not recommended to set this higher than frame rate of webcam/video device
Const VIDWIDTH = 640
Const VIDHEIGHT = 480
type ptype
c as string * 1
d as long
img as long
end type
n = 126-32
dim p(n) as ptype
dim z as _unsigned long
Type BITMAPINFOHEADER
As _Unsigned Long biSize
As Long biWidth, biHeight
As _Unsigned Integer biPlanes, biBitCount
As _Unsigned Long biCompression, biSizeImage
As Long biXPelsPerMeter, biYPelsPerMeter
As _Unsigned Long biClrUsed, biClrImportant
End Type
Type BITMAPINFO
As BITMAPINFOHEADER bmiHeader
End Type
Type POINT
As Long x, y
End Type
Type MSG
As _Offset hwnd
As _Unsigned Long message
$If 64BIT Then
As String * 4 padding1
$End If
As _Unsigned _Offset wParam
As _Offset lParam
As _Unsigned Long time
$If 64BIT Then
As String * 4 padding2
$End If
As POINT pt
As _Unsigned Long lPrivat
End Type
Declare Dynamic Library "Avicap32"
Function CreateCaptureWindow& Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As _Offset, ByVal dwStyle As _Unsigned Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As _Offset, ByVal nId As Long)
End Declare
Declare CustomType Library
Sub SendMessage Alias "SendMessageA" (ByVal hWnd As _Offset, ByVal Msg As _Unsigned Long, ByVal wParam As _Offset, ByVal lParam As _Offset)
Function SendMessage& Alias "SendMessageA" (ByVal hWnd As _Offset, ByVal Msg As _Unsigned Long, ByVal wParam As _Offset, ByVal lParam As _Offset)
Function PeekMessage& Alias "PeekMessageA" (ByVal lpMsg As _Offset, ByVal hWnd As _Offset, ByVal wMsgFilterMin As _Unsigned Long, ByVal wMsgFilterMax As _Unsigned Long, ByVal wRemoveMsg As _Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As _Offset)
Sub DispatchMessage (ByVal lpMsg As _Offset)
Sub DestroyWindow (ByVal hWnd As _Offset)
Function mmioStringToFOURCC& (sz As String, ByVal uFlags As _Unsigned Long)
Function OpenClipboard& (ByVal hWndNewOwner As _Offset)
Function GetClipboardData%& (ByVal uFormat As _Unsigned Long)
Sub CloseClipboard ()
Function GlobalLock%& (ByVal hMem As _Offset)
Function GlobalUnlock& (ByVal hMem As _Offset)
Function LoadLibrary%& (lpLibFileName As String)
Function GetProcAddress%& (ByVal hModule As _Offset, lpProcName As String)
End Declare
Declare Library ".\internal\c\c_compiler\include\vfw"
End Declare
Declare Library "framecallback"
End Declare
Dim Shared As Single SATURATION_LEVEL: SATURATION_LEVEL = 1.00 '0.00 for greyscale, 1.00 for normal, and >1.00 for oversaturation
Dim Shared As Single BRIGHTNESS_LEVEL: BRIGHTNESS_LEVEL = 1.00
Dim Shared As _Byte NEGATIVE: NEGATIVE = _FALSE
Dim Shared As _Byte FLIPPED_H: FLIPPED_H = _FALSE
Dim Shared As _Byte FLIPPED_V: FLIPPED_V = _FALSE
Dim Shared As Single COLOR_TEMP_WARM: COLOR_TEMP_WARM = 1.00
Dim Shared As Single COLOR_TEMP_COOL: COLOR_TEMP_COOL = 1.00
Dim Shared As Single COLOR_GREEN: COLOR_GREEN = 1.00
Dim Shared As _Unsigned _Byte PALETTE_SWAP: PALETTE_SWAP = 0
Dim Shared As _Byte EVERY_OTHER_H: EVERY_OTHER_H = _FALSE
Dim Shared As _Byte EVERY_OTHER_V: EVERY_OTHER_V = _FALSE
Dim Shared As _Byte GHOST: GHOST = _FALSE
Screen _NewImage(VIDWIDTH, VIDHEIGHT, 32)
_Delay 0.2 'Just in case
''''''''''''
for i=0 to n
p(i).img = _newimage(8, 16, 32)
_dest p(i).img
_source p(i).img
_printstring (0,0), chr$(i + 32)
p(i).c = chr$(i + 32)
sum = 0
for y=0 to 16-1
for x=0 to 8-1
z = point(x, y)
'pset (x, y), z
if point(x,y)=_rgb(255,255,255) then sum = sum + 1
next
next
p(i).d = sum
next
for i=1 to ubound(p)
j = i
do while (j>0 and p(j-1).d > p(j).d)
swap p(j), p(j-1)
j = j - 1
loop
next
_dest 0
_source 0
'''''''''''''
_ScreenMove (_DesktopWidth / 2) - VIDWIDTH / 2, (_DesktopHeight / 2) - VIDHEIGHT / 2
Dim As String captureWinText: captureWinText = "Webcam API Test - Child" + Chr$(0)
Dim As _Offset childID
Dim As _Offset childWin: childWin = CreateCaptureWindow(_Offset(captureWinText), WS_EX_NOACTIVATE, 0, 0, VIDWIDTH, VIDHEIGHT, _WindowHandle, childID)
If childWin = 0 Then
Print "Couldn't create capture window."
End
End If
_Title "Webcam API Test - Parent"
SetupDriver childWin, _TRUE 'change _FALSE to _TRUE to use default settings
Print "Previewing... Press Space bar to stop"
Print "Press escape to kill the window"
Dim As _Integer64 k
Dim As MSG msg
'Dim As Long i
Dim Shared As _MEM frame
'$Checking:Off
Do
k = _KeyHit
If PeekMessage(_Offset(msg), 0, 0, 0, PM_REMOVE) Then
TranslateMessage _Offset(msg)
DispatchMessage _Offset(msg)
Else
GrabFrame childWin
End If
'Screen frame.IMAGE
w = _width(0)
h = _height(0)
_source 0
for y=0 to h/16 - 1
for x=0 to w/8 - 1
'0.299r + 0.587g + 0.114b
z = point(x*8 + 4, y*16 + 8)
'z2 = point(x*8 + 4, y*16 + 4)
r = _red(z)
g = _blue(z)
b = _green(z)
c = 0.299*r + 0.587*g + 0.114*b
c = (c/255)*n
'circle (x*8 + 4, y*16 + 8), 3, z
color z ', z2
'if c > 1*n/4 then
_printstring (x*8, y*16), p(c).c
'end if
next
next
_Display
Select Case k
Case 32 'Space bar
Exit Do
Case 27 'Escape - Reset
BRIGHTNESS_LEVEL = 1.00
SATURATION_LEVEL = 1.00
NEGATIVE = _FALSE
FLIPPED_H = _FALSE
FLIPPED_V = _FALSE
COLOR_TEMP_WARM = 1.00
COLOR_TEMP_COOL = 1.00
COLOR_GREEN = 1.00
PALETTE_SWAP = 0
EVERY_OTHER_H = _FALSE
EVERY_OTHER_V = _FALSE
GHOST = _FALSE
Cls
Case 43 'numpad plus key
If SATURATION_LEVEL < 2.00 Then
SATURATION_LEVEL = SATURATION_LEVEL + .10
End If
Case 45 'numpad minus key
If SATURATION_LEVEL > 0.00 Then
SATURATION_LEVEL = SATURATION_LEVEL - .10
End If
Case 18432 'arrow key up
If BRIGHTNESS_LEVEL < 2 Then
BRIGHTNESS_LEVEL = BRIGHTNESS_LEVEL + .10
End If
Case 20480 'arrow key down
If BRIGHTNESS_LEVEL > 0.00 Then
BRIGHTNESS_LEVEL = BRIGHTNESS_LEVEL - .10
End If
Case Asc("N"), Asc("n") 'negative filter toggle
NEGATIVE = Not NEGATIVE
Case Asc("P"), Asc("p")
If _FileExists("capture(" + _ToStr$(i) + ").png") Then
While _FileExists("capture(" + _ToStr$(i) + ").png")
i = i + 1
Wend
End If
_SaveImage "capture(" + _ToStr$(i) + ").png", _Display, "PNG"
i = i + 1
Case Asc("C"), Asc("c")
_ClipboardImage = _Display
Case Asc("H"), Asc("h")
FLIPPED_H = Not FLIPPED_H
Case Asc("V"), Asc("v")
FLIPPED_V = Not FLIPPED_V
Case Asc("R")
If COLOR_TEMP_WARM < 2.00 Then
COLOR_TEMP_WARM = COLOR_TEMP_WARM + .10
End If
Case Asc("r")
If COLOR_TEMP_WARM > 0 Then
COLOR_TEMP_WARM = COLOR_TEMP_WARM - .10
End If
Case Asc("G")
If COLOR_GREEN < 2.00 Then
COLOR_GREEN = COLOR_GREEN + .10
End If
Case Asc("g")
If COLOR_GREEN > 0 Then
COLOR_GREEN = COLOR_GREEN - .10
End If
Case Asc("B")
If COLOR_TEMP_COOL < 2.00 Then
COLOR_TEMP_COOL = COLOR_TEMP_COOL + .10
End If
Case Asc("b")
If COLOR_TEMP_COOL > 0 Then
COLOR_TEMP_COOL = COLOR_TEMP_COOL - .10
End If
Case Asc("1")
PALETTE_SWAP = 1
Case Asc("2")
PALETTE_SWAP = 2
Case Asc("3")
PALETTE_SWAP = 3
Case Asc("4")
PALETTE_SWAP = 4
Case Asc("5")
PALETTE_SWAP = 5
Case Asc("6")
PALETTE_SWAP = 6
Case Asc("Z"), Asc("z")
SendMessage childWin, WM_CAP_DLG_VIDEOSOURCE, 0, 0
Case Asc("\")
EVERY_OTHER_V = Not EVERY_OTHER_V
Cls
Case Asc("/")
EVERY_OTHER_H = Not EVERY_OTHER_H
Cls
Case Asc(";")
EVERY_OTHER_V = _TRUE
EVERY_OTHER_H = _TRUE
Case Asc("T"), Asc("t")
GHOST = Not GHOST
End Select
_Limit FPS
Loop
'$Checking:On
Print "Disconnecting Driver"
KillDriver childWin
Sub SetupDriver (hwnd As _Offset, defaultSource As _Byte)
Dim As _Offset libload: libload = LoadLibrary(Command$(0))
Dim As _Offset myCallback: myCallback = GetProcAddress(libload, "CapVideoCallback")
If myCallback = 0 Then
Print "Can't find callback pointer"
End
End If
Dim As BITMAPINFO format
SendMessage hwnd, WM_CAP_DRIVER_CONNECT, 0, 0
SendMessage hwnd, WM_CAP_SET_SCALE, _FALSE, 0
SendMessage hwnd, WM_CAP_SET_PREVIEW, _FALSE, 0
Dim As _Unsigned Long formatSize: formatSize = SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0)
If Len(format) <> formatSize Then
KillDriver hwnd
Print "Wrong size"
Print formatSize, Len(format)
End
End If
If SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, Len(format), _Offset(format)) = 0 Then
KillDriver hwnd
Print "Couldn't get format"
End
End If
format.bmiHeader.biSize = Len(format)
format.bmiHeader.biWidth = VIDWIDTH
format.bmiHeader.biHeight = VIDHEIGHT
format.bmiHeader.biPlanes = 1
format.bmiHeader.biBitCount = 16 'yuy2 format
format.bmiHeader.biSizeImage = VIDWIDTH * VIDHEIGHT * 2
format.bmiHeader.biCompression = mmioStringToFOURCC("YUY2" + Chr$(0), &H00000010) 'MUST BE YUY2 FORMAT
If SendMessage(hwnd, WM_CAP_SET_VIDEOFORMAT, Len(format), _Offset(format)) = 0 Then
KillDriver hwnd
Print "Failed to set video format"
End
End If
If defaultSource = _FALSE Then
SendMessage hwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0 'PICK YUY2!!!
SendMessage hwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0
End If
SendMessage hwnd, WM_CAP_GET_VIDEOFORMAT, 0, _Offset(format)
SendMessage hwnd, WM_CAP_SET_CALLBACK_FRAME, 0, myCallback
End Sub
Sub KillDriver (hwnd As _Offset)
SendMessage hwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0
DestroyWindow hwnd
End Sub
Sub GrabFrame (hwnd As _Offset)
SendMessage hwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0
End Sub
Function CapVideoCallback%& (hWnd As _Offset, lpVHdr As _Offset)
Type VIDEOHDR
As _Offset lpData
As _Unsigned Long dwBufferLength, dwBytesUsed, dwTimeCaptured
As String * 4 padding1
As _Unsigned _Offset dwUser
As _Unsigned Long dwFlags
As String * 4 padding2
As _Offset dwReserved1, dwReserved2, dwReserved3, dwReserved4
End Type
Dim As VIDEOHDR vhdr
Dim As _MEM pVhdr: pVhdr = _Mem(lpVHdr, Len(vhdr))
_MemGet pVhdr, pVhdr.OFFSET, vhdr
_MemFree pVhdr
Dim As _Unsigned Long frameSize: frameSize = SendMessage(hWnd, WM_CAP_GET_VIDEOFORMAT, 0, 0)
If frameSize = 0 Then
Print "Failed to get video format size"
'KillDriver hWnd
'End
End If
Dim As BITMAPINFO bi
SendMessage hWnd, WM_CAP_GET_VIDEOFORMAT, frameSize, _Offset(bi)
'Print bi.bmiHeader.biHeight
Dim As _MEM lpData: lpData = _Mem(vhdr.lpData, vhdr.dwBufferLength)
Dim As Long bitsPerPixel: bitsPerPixel = bi.bmiHeader.biBitCount
Dim As Long bytesPerPixel: bytesPerPixel = (bitsPerPixel + 7) \ 8
Dim As _Unsigned Long stride: stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8
Dim As Long y, x
Dim As _Unsigned _Byte yuy2(0 To 3)
Dim As _Offset pScanLine
Dim As _Unsigned _Integer64 converted
Dim As _Unsigned _Byte r, g, b
Dim As _Offset pixelOffset
If _MemExists(frame) Then _MemFree frame
'Dim As Long i: i = _NewImage(bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 32)
frame = _MemImage(0)
Dim As _Offset o: o = frame.OFFSET
For y = 0 To bi.bmiHeader.biHeight - 1
If o >= frame.OFFSET + frame.SIZE Then Exit For
pScanLine = lpData.OFFSET + (y * stride)
For x = 0 To bi.bmiHeader.biWidth - bytesPerPixel Step bytesPerPixel
pixelOffset = pScanLine + (x * bytesPerPixel)
_MemGet lpData, pixelOffset, yuy2()
converted = ConvertYUY2toRGB(yuy2())
_MemPut frame, o, _Blue32(converted) As _UNSIGNED _BYTE
_MemPut frame, o + 1, _Green32(converted) As _UNSIGNED _BYTE
_MemPut frame, o + 2, _Red32(converted) As _UNSIGNED _BYTE
'PSet (x, y), converted And &HFFFFFFFF
o = o + bytesPerPixel + 2
If Not EVERY_OTHER_V Then
'PSet (x + 1, y), _ShR(converted, 32) And &HFFFFFFFF
_MemPut frame, o, _Blue32(_ShR(converted, 32) And &HFFFFFFFF) As _UNSIGNED _BYTE
_MemPut frame, o + 1, _Green32(_ShR(converted, 32) And &HFFFFFFFF) As _UNSIGNED _BYTE
_MemPut frame, o + 2, _Red32(_ShR(converted, 32) And &HFFFFFFFF) As _UNSIGNED _BYTE
o = o + bytesPerPixel + 2
Else
o = o + 4
End If
Next
Next
'If FLIPPED_H Then
' Dim As Long hi: hi = _CopyImage(i)
' _PutImage , hi, i, (bi.bmiHeader.biWidth - 1, 0)-(0, bi.bmiHeader.biHeight - 1)
' _FreeImage hi
'End If
'If FLIPPED_V Then
' Dim As Long vi: vi = _CopyImage(i)
' _PutImage , vi, i, (bi.bmiHeader.biWidth - 1, bi.bmiHeader.biHeight - 1)-(0, 0)
' _FreeImage vi
'End If
End Function
Function ConvertYUY2toRGB~&& (yuy2() As _Unsigned _Byte)
Dim As _Unsigned _Byte r1, g1, b1, r2, g2, b2, r3, g3, b3
Dim As Double Y1, Y2, U, V
' Extract values
Y1 = yuy2(0) * BRIGHTNESS_LEVEL
Y2 = yuy2(2) * BRIGHTNESS_LEVEL
U = (yuy2(1) - 128) * SATURATION_LEVEL
V = (yuy2(3) - 128) * SATURATION_LEVEL
' Convert first pixel
r1 = _Clamp((Y1 + 1.13983 * V) * COLOR_TEMP_WARM, 0, 255)
g1 = _Clamp((Y1 - 0.39465 * U - 0.58060 * V) * COLOR_GREEN, 0, 255)
b1 = _Clamp((Y1 + 2.03211 * U) * COLOR_TEMP_COOL, 0, 255)
' Convert second pixel
r2 = _Clamp((Y2 + 1.13983 * V) * COLOR_TEMP_WARM, 0, 255)
g2 = _Clamp((Y2 - 0.39465 * U - 0.58060 * V) * COLOR_GREEN, 0, 255)
b2 = _Clamp((Y2 + 2.03211 * U) * COLOR_TEMP_COOL, 0, 255)
If NEGATIVE Then
r1 = 255 - r1: g1 = 255 - g1: b1 = 255 - b1
r2 = 255 - r2: g2 = 255 - g2: b2 = 255 - b2
End If
If PALETTE_SWAP > 0 Then
Select Case PALETTE_SWAP
Case 1
''Dobra
r3 = _Clamp(r1 * 0.989 + g1 * 1.000 + b1 * 0.510, 0, 255)
g3 = _Clamp(r1 * 0.157 + g1 * 0.500 + b1 * 0.400, 0, 255)
b3 = _Clamp(r1 * 0.278 + g1 * 0.000 + b1 * 0.267, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp(r2 * 0.989 + g2 * 1.000 + b2 * 0.510, 0, 255)
g3 = _Clamp(r2 * 0.157 + g2 * 0.500 + b2 * 0.400, 0, 255)
b3 = _Clamp(r2 * 0.278 + g2 * 0.000 + b2 * 0.267, 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 2
''Roden
r3 = _Clamp(r1 * 0.545 + g1 * 0.0902 + b1 * 0.804, 0, 255)
g3 = _Clamp(r1 * 0.412 + g1 * 0.502 + b1 * 0.522, 0, 255)
b3 = _Clamp(r1 * 0.412 + g1 * 0.427 + b1 * 0.247, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp(r2 * 0.545 + g2 * 0.0902 + b2 * 0.804, 0, 255)
g3 = _Clamp(r2 * 0.412 + g2 * 0.502 + b2 * 0.522, 0, 255)
b3 = _Clamp(r2 * 0.412 + g2 * 0.427 + b2 * 0.247, 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 3
''Flowers
r3 = _Clamp(r1 * 0.753 + g1 * 1.000 + b1 * 0.000, 0, 255)
g3 = _Clamp(r1 * 0.000 + g1 * 1.000 + b1 * 0.000, 0, 255)
b3 = _Clamp(r1 * 0.000 + g1 * 1.000 + b1 * 1.000, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp(r2 * 0.753 + g2 * 1.000 + b2 * 0.000, 0, 255)
g3 = _Clamp(r2 * 0.000 + g2 * 1.000 + b2 * 0.000, 0, 255)
b3 = _Clamp(r2 * 0.000 + g2 * 1.000 + b2 * 1.000, 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 4
''GBR
r3 = _Clamp(r1 * 0 + g1 * 0 + b1 * 1, 0, 255)
g3 = _Clamp(r1 * 1 + g1 * 0 + b1 * 0, 0, 255)
b3 = _Clamp(r1 * 0 + g1 * 1 + b1 * 0, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp(r2 * 0 + g2 * 0 + b2 * 1, 0, 255)
g3 = _Clamp(r2 * 1 + g2 * 0 + b2 * 0, 0, 255)
b3 = _Clamp(r2 * 0 + g2 * 1 + b2 * 0, 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 5
''Sepia
r3 = _Clamp((r1 * 0.393) + (g1 * 0.769) + (b1 * 0.189), 0, 255)
g3 = _Clamp((r1 * 0.349) + (g1 * 0.686) + (b1 * 0.168), 0, 255)
b3 = _Clamp((r1 * 0.272) + (g1 * 0.534) + (b1 * 0.131), 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp((r2 * 0.393) + (g2 * 0.769) + (b2 * 0.189), 0, 255)
g3 = _Clamp((r2 * 0.349) + (g2 * 0.686) + (b2 * 0.168), 0, 255)
b3 = _Clamp((r2 * 0.272) + (g2 * 0.534) + (b2 * 0.131), 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 6
''High contrast
r3 = _Clamp((r1 - 128) * 1.5 + 128, 0, 255)
g3 = _Clamp((g1 - 128) * 1.5 + 128, 0, 255)
b3 = _Clamp((b1 - 128) * 1.5 + 128, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp((r2 - 128) * 1.5 + 128, 0, 255)
g3 = _Clamp((g2 - 128) * 1.5 + 128, 0, 255)
b3 = _Clamp((b2 - 128) * 1.5 + 128, 0, 255)
r2 = r3
g2 = g3
b2 = b3
End Select
End If
' Pack pixels into a single return value
If GHOST Then
ConvertYUY2toRGB = _RGBA32(r1, g1, b1, 175) Or _ShL(_RGBA32(r2, g2, b2, 175), 32)
Else
ConvertYUY2toRGB = _RGB32(r1, g1, b1) Or _ShL(_RGB32(r2, g2, b2), 32)
End If
End Function
Posts: 869
Threads: 122
Joined: Apr 2022
Reputation:
21
(03-05-2025, 04:39 AM)vince Wrote: tranny kpop matrix mod
...
I look forward to giving this a try, thanks for sharing!
PS are you sure this won't violate the president's no-DEI order? 
PPS that was a joke, I am not looking to talk politics! LoL
Posts: 869
Threads: 122
Joined: Apr 2022
Reputation:
21
8 hours ago
(This post was last modified: 8 hours ago by madscijr.)
(03-05-2025, 04:39 AM)vince Wrote: tranny kpop matrix mod
I did give this a try, nice! Video to ASCII in realtime! That was on my "to do" list!
Question - did you assign a brightness value to the different ASCII characters, or are they just arbitrarily selected?
I have been meaning to write a simple prog to go through the printable ASCII characters and for each, _PRINTSTRING it to the screen and count the pixels, the # being its "brightness", and save that score, then at the end sort them by score. Then the picture-to-ascii matches the brightness of each pixel (or a given block of pixels) to be approximated by an ASCII char, and does a lookup in the array to find a character with the corresponding brightness.
In the time it took me to write that explanation I could have finished the code, LOL, but it did help clarify it in my mind.
Posts: 869
Threads: 122
Joined: Apr 2022
Reputation:
21
And here's that proggie to determine the brightness of all the ASCII characters of the current font, and sort them in order of darkest to brightest...
Code: (Select All) Option _Explicit
' HOLDS RGB VALUES FOR A PIXEL
Type PixelType
r As Long
g As Long
b As Long
a As Long
End Type ' PixelType
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' =============================================================================
' START THE MAIN ROUTINE
GetCharBrightness
' =============================================================================
' FINISH
System ' return control to the operating system
' /////////////////////////////////////////////////////////////////////////////
Sub GetCharBrightness
Dim iStartX, iStartY, iEndX, iEndY, iX, iY As Integer
Dim myPoint As Long
Dim px As PixelType
Dim iChar As Integer
Dim sChar As String
Dim sngPercent As Single
Dim sngScore As Single
Dim iScore As Integer
Dim iPixelCount As Integer
Dim iTotal As Integer
Dim iTotalPixels As Integer
Dim iPercent As Integer
Dim arrValues(0 To 255) As Integer
Dim arrKeys(0 To 255) As Integer
' variables for sorting:
Dim arrSortedValues(0 To 255) As Integer
Dim arrSortedKeys(0 To 255) As Integer
Dim iLoop1 As Integer
Dim bFinished As Integer
Dim iSortIndex As Integer
Dim iMinValue As Long
Dim iMaxValue As Long
Dim iNextMinValue As Long
Dim iIndex As Integer
' variables for dislaying
Dim arrRows(0 To 31) As String ' holds rows of text
Dim RowNum As Integer
Dim ColNum As Integer
'Dim iCols, iRows As Integer
' ================================================================================================================================================================
' INITIALIZE
' ================================================================================================================================================================
Screen _NewImage(1024, 768, 32)
_ScreenMove 0, 0
Color cCyan, cBlack: Cls
'iCols = _Width(0) \ _FontWidth
'iRows = _Height(0) \ _FontHeight
For iIndex = 0 To 255
arrValues(iIndex) = 0
arrKeys(iIndex) = -1
arrSortedValues(iIndex) = 0
arrSortedKeys(iIndex) = -1
Next iIndex
' ================================================================================================================================================================
' BEGIN GET BRIGHTNESS OF EACH CHARACTER
' ================================================================================================================================================================
Print "Determining brightness of ascii characters 32-127..."
_Display
iTotalPixels = _FontWidth * _FontHeight
iStartX = 0
iEndX = iStartX + (_FontWidth - 1)
iStartY = 0
iEndY = iStartY + (_FontHeight - 1)
iIndex = 0
For iChar = 32 To 255
sChar = Chr$(iChar)
Color cCyan, cBlack: Cls
Color cWhite, cBlack: PrintString1 1, 1, sChar
iTotal = 0: iPixelCount = 0
For iY = iStartY To iEndY
For iX = iStartX To iEndX
iPixelCount = iPixelCount + 1
myPoint = Point(iX, iY)
px.r = _Red32(myPoint)
px.g = _Green32(myPoint)
px.b = _Blue32(myPoint)
px.a = _Alpha32(myPoint)
sngPercent = px.a / 255
sngScore = (px.r + px.g + px.b) * sngPercent
sngPercent = (sngScore / 765) * 100
iScore = SngToInt%(sngPercent)
iTotal = iTotal + iScore
Next iX
Next iY
sngPercent = (iTotal / (iTotalPixels * 100)) * 100
iPercent = SngToInt%(sngPercent)
arrValues(iIndex) = iPercent
arrKeys(iIndex) = iChar
iIndex = iIndex + 1
Next iChar
' ================================================================================================================================================================
' END GET BRIGHTNESS OF EACH CHARACTER
' ================================================================================================================================================================
' ================================================================================================================================================================
' DISPLAY RESULTS (BEFORE SORTING)
' ================================================================================================================================================================
For RowNum = 0 To 31: arrRows(RowNum) = "": Next RowNum
RowNum = 0
For iIndex = 0 To 255
' Ignore char values < 31
If arrKeys(iIndex) > 31 Then
iChar = arrKeys(iIndex)
arrRows(RowNum) = arrRows(RowNum) + _
right$( " " + _TRIM$(str$(iChar)) , 3) + _
" " + _
chr$(34) + chr$(iChar) + chr$(34) + _
" = " + _
right$( " " + _TRIM$(str$(arrValues(iIndex) )), 3) + _
" "
RowNum = RowNum + 1
If RowNum > 31 Then RowNum = 0
End If
Next iIndex
Color cCyan, cBlack: Cls
_AutoDisplay
Print "Character brightness levels 0-100:"
For RowNum = 0 To 31: Print arrRows(RowNum): Next RowNum
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' WAIT FOR KEY
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Print "press any key to sort results"
_Display
Sleep: _KeyClear: '_DELAY 1
' ================================================================================================================================================================
' BEGIN SORT RESULTS
' ================================================================================================================================================================
' FIND MAXIMUM VALUE
iMaxValue = 0
For iIndex = 0 To 255 ' LBound(arrFlags) To UBound(arrFlags)
If arrValues(iIndex) > iMaxValue Then iMaxValue = arrValues(iIndex)
Next iIndex
' SORT RESULTS
bFinished = _FALSE
iSortIndex = LBound(arrSortedValues) - 1
iMinValue = iMaxValue + 1 ' reset min value to find
Do
' Reset compare
iNextMinValue = iMaxValue + 1 ' reset temp min value to find
iIndex = LBound(arrValues) - 1 ' Set iIndex outside of array bounds, next smallest not found (yet)
' Find smallest empty
For iLoop1 = LBound(arrValues) To UBound(arrValues)
' Ignore already sorted
If arrKeys(iLoop1) > -1 Then
' Is this the smallest yet?
If arrValues(iLoop1) < iMinValue Then
iMinValue = arrValues(iLoop1) ' update minimum
End If
' Is this the smallest of the ones left so far?
If arrValues(iLoop1) < iNextMinValue Then
iNextMinValue = arrValues(iLoop1) ' update minimum
iIndex = iLoop1 ' remember this layout
End If
End If
Next iLoop1
' Add smallest to sorted
' As long as iIndex is within array bounds, we found next smallest
If iIndex >= LBound(arrValues) Then
iSortIndex = iSortIndex + 1
If iSortIndex <= UBound(arrSortedValues) Then
arrSortedValues(iSortIndex) = arrValues(iIndex)
arrSortedKeys(iSortIndex) = arrKeys(iIndex)
arrKeys(iIndex) = -1 ' remove this from sort pool
Else
' Exceeded sorted array size, quit sorting
Exit Do
End If
Else
' Finished sorting
Exit Do
End If
Loop
' ================================================================================================================================================================
' END SORT RESULTS
' ================================================================================================================================================================
' ================================================================================================================================================================
' DISPLAY SORTED RESULTS
' ================================================================================================================================================================
Color cCyan, cBlack: Cls
Print "Sorted character brightness levels 0-100:"
For RowNum = 0 To 31: arrRows(RowNum) = "": Next RowNum
RowNum = 0
For iIndex = 0 To 255
' Ignore char values < 31
If arrSortedKeys(iIndex) > 31 Then
iChar = arrSortedKeys(iIndex)
arrRows(RowNum) = arrRows(RowNum) + _
right$( " " + _TRIM$(str$(iChar)) , 3) + _
" " + _
chr$(34) + chr$(iChar) + chr$(34) + _
" = " + _
right$( " " + _TRIM$(str$(arrSortedValues(iIndex) )), 3) + _
" "
RowNum = RowNum + 1
If RowNum > 31 Then RowNum = 0
End If
Next iIndex
Color cCyan, cBlack: Cls
_AutoDisplay
Print "Character brightness levels 0-100:"
For RowNum = 0 To 31: Print arrRows(RowNum): Next RowNum
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' WAIT FOR KEY
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Print "press any key to continue"
_AutoDisplay
Sleep: _KeyClear: '_DELAY 1
End Sub ' GetCharBrightness
' ################################################################################################################################################################
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
Function AppendString$ (MyString As String, NewString As String, MyDelimiter As String)
Dim sResult As String: sResult = MyString
If Len(MyString) > 0 Then
sResult = sResult + MyDelimiter
End If
sResult = sResult + NewString
AppendString$ = sResult
End Function ' AppendString$
' /////////////////////////////////////////////////////////////////////////////
Sub AppendToStringArray (MyStringArray$(), MyString$)
ReDim _Preserve MyStringArray$(LBound(MyStringArray$) To UBound(MyStringArray$) + 1)
MyStringArray$(UBound(MyStringArray$)) = MyString$
End Sub ' AppendToStringArray
' /////////////////////////////////////////////////////////////////////////////
' See also StringTo2dArray
Function Array2dToString$ (MyArray() As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
MyString = MyString + sLine + Chr$(13)
Next iY
Array2dToString$ = MyString
End Function ' Array2dToString$
' /////////////////////////////////////////////////////////////////////////////
$If Then
Function Array2dToStringTest$ (MyArray() As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
MyString = MyString + " 11111111112222222222333" + Chr$(13)
MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
sLine = sLine + Right$(" " + cstr$(iY), 2)
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
sLine = sLine + Right$(" " + cstr$(iY), 2)
MyString = MyString + sLine + Chr$(13)
Next iY
MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
MyString = MyString + " 11111111112222222222333" + Chr$(13)
Array2dToStringTest$ = MyString
End Function ' Array2dToStringTest$
$End If
' /////////////////////////////////////////////////////////////////////////////
' use angles in degrees units instead of radians (converted inside sub)
' Note this function uses whatever the default type is, better not be some Integer Type.
Function CosD (degrees)
CosD = Cos(_D2R(degrees))
End Function ' CosD
' /////////////////////////////////////////////////////////////////////////////
' Integer to string
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Long to string
Function cstrl$ (myValue As Long)
cstrl$ = _Trim$(Str$(myValue))
End Function ' cstrl$
' /////////////////////////////////////////////////////////////////////////////
' Single to string
Function cstrs$ (myValue As Single)
''cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstrs$ = _Trim$(Str$(myValue))
End Function ' cstrs$
' /////////////////////////////////////////////////////////////////////////////
' Unsigned Long to string
Function cstrul$ (myValue As _Unsigned Long)
cstrul$ = _Trim$(Str$(myValue))
End Function ' cstrul$
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' use angles in degrees units instead of radians (converted inside sub)
' Note this function uses whatever the default type is, better not be some Integer Type.
Function DAtan2 (x1, y1, x2, y2) ' The angle in degrees a 2nd point (x2, y2) makes to a first point (x1, y1)
Dim deltaX As Integer
Dim deltaY As Integer
Dim rtn
' Delta means change between 1 measure and another for example x2 - x1
deltaX = x2 - x1
deltaY = y2 - y1
' To find the angle point(x2, y2) makes to (x1, y1) in Degrees
' Take DegreeAngle = DAtan2(y2 - y1, x2 - x1)
rtn = _R2D(_Atan2(deltaY, deltaX))
If rtn < 0 Then
DAtan2 = rtn + 360
Else
DAtan2 = rtn
End If
End Function ' DAtan2
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
dblNew = RoundDouble#(dblOld, 0)
'sValue = _Trim$(Str$(dblNew))
sValue = DblToStr$(dblNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' DblToInt% = Val(Left$(sValue, iPos - 1))
'Else
' DblToInt% = Val(sValue)
'End If
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Receives an {sDelim} delimited list {sInput}
' returns the list with all duplicate entries removed.
Function DedupeDelimList$ (sInput As String, sDelim As String)
ReDim arrLines(-1) As String
Dim sOutput As String
Dim iLoop As Integer
split sInput, sDelim, arrLines()
sOutput = sDelim
For iLoop = LBound(arrLines) To UBound(arrLines)
If InStr(1, sOutput, sDelim + arrLines(iLoop) + sDelim) = 0 Then
sOutput = sOutput + arrLines(iLoop) + sDelim
End If
Next iLoop
DedupeDelimList$ = sOutput
End Function ' DedupeDelimList$
' /////////////////////////////////////////////////////////////////////////////
Function DoubleABS# (dblValue As Double)
If Sgn(dblValue) = -1 Then
DoubleABS# = 0 - dblValue
Else
DoubleABS# = dblValue
End If
End Function ' DoubleABS#
' /////////////////////////////////////////////////////////////////////////////
' bplus: The Gold Standard is even better than THE QB64 CIRCLE sub in this respect!
' https://forum.qb64.org/index.php?topic=1044.135
' from Steve Gold standard
' Renamed fcirc to DrawCircleSolid
' Not as fast as DrawCircleTopLeft but pretty fast.
' Example:
' Screen _NewImage(800, 600, 32)
' _ScreenMove 250, 60
' For r = 250 To 0 Step -60
' DrawCircleSolid 400, 300, r, _RGBA(255, 255, 255, 100)
' Next r
Sub DrawCircleSolid (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub ' DrawCircleSolid
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (OUTLINE)
Sub DrawRectOutline (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + iSizeW, iY + iSizeH), fgColor, B ' Draw rectangle outline
End Sub ' DrawRectOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + iSizeW, iY + iSizeH), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid
' /////////////////////////////////////////////////////////////////////////////
' Draws scaled + rotated text to screen
' by BPlus
' Scale rotate font text strings by B+
' https://qb64phoenix.com/forum/showthread.php?tid=414&highlight=rotate+text
' INPUT:
' S$ is the string to display
' c is the color (will have a transparent background)
' midX and midY is the center of where you want to display the string
' xScale would multiply 8 pixel width of default font
' yScale would multiply the 16 pixel height of the default font
' Rotation is in Radian units, use _D2R to convert Degree units to Radian units
' DEPENDENCIES:
' drwString needs sub RotoZoom2, intended for graphics screens using the default font.
Sub drwString (storeDest&, S$, c As _Unsigned Long, midX, midY, xScale, yScale, Rotation As Single)
Dim I&
I& = _NewImage(_PrintWidth(S$), _FontHeight, 32)
_Dest I&
Color c, _RGBA32(0, 0, 0, 0)
_PrintString (0, 0), S$
_Dest storeDest&
RotoZoom2 midX, midY, I&, xScale, yScale, Rotation
_FreeImage I&
End Sub ' drwString
' /////////////////////////////////////////////////////////////////////////////
Sub DumpScreenAndFontSize ()
Dim iCols As Integer
Dim iRows As Integer
'Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
End Sub ' DumpScreenAndFontSize
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill
' More efficient version of ExtendedTimer.
' This stores our day values and only updates them when necessary.
' We really don't need to figure out how many seconds are in today over and over endlessly
' -- just count them once, and when the clock swaps back to 0:0:0, add 24*60*60 seconds to the count.
' Re: how to time something (ie do loop for n seconds)
' https://forum.qb64.org/index.php?topic=4682.0
Function ExtendedTimer##
'modified extendedtimer to store the old day's count, and not have to recalculate it every time the routine is called.
Static olds As _Float, old_day As _Float
Dim m As Integer, d As Integer, y As Integer
Dim s As _Float, day As String
Dim oldt
If olds = 0 Then 'calculate the day the first time the extended timer runs
day = Date$
m = Val(Left$(day, 2))
d = Val(Mid$(day, 4, 2))
y = Val(Right$(day, 4)) - 1970
Select Case m 'Add the number of days for each previous month passed
Case 2: d = d + 31
Case 3: d = d + 59
Case 4: d = d + 90
Case 5: d = d + 120
Case 6: d = d + 151
Case 7: d = d + 181
Case 8: d = d + 212
Case 9: d = d + 243
Case 10: d = d + 273
Case 11: d = d + 304
Case 12: d = d + 334
End Select
If (y Mod 4) = 2 And m > 2 Then d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
old_day = s
End If
If Timer < oldt Then 'we went from 23:59:59 (a second before midnight) to 0:0:0 (midnight)
old_day = s + 83400 'add another worth of seconds to our counter
End If
oldt = Timer
olds = old_day + oldt
ExtendedTimer## = olds
End Function ' ExtendedTimer##
' /////////////////////////////////////////////////////////////////////////////
Function FloatRoundedToStr$ (fValue As _Float, intNumPlaces As Integer)
Dim fNew As _Float
fNew = Round##(fValue, intNumPlaces)
FloatRoundedToStr$ = FloatToStr$(fNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function FloatToStr$ (n##)
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n As Integer
Dim num$
value$ = UCase$(LTrim$(Str$(n##)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then
num$ = num$ + Mid$(valu$, n, 1)
End If
Next n
Else
FloatToStr$ = value$
Exit Function
End If
FloatToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' FloatToStr$
' /////////////////////////////////////////////////////////////////////////////
' TODO: find the newer formatting function?
Function FormatNumber$ (myValue, iDigits As Integer)
Dim strValue As String
strValue = DblToStr$(myValue) + String$(iDigits, " ")
If myValue < 1 Then
If myValue < 0 Then
strValue = Replace$(strValue, "-.", "-0.")
ElseIf myValue > 0 Then
strValue = "0" + strValue
End If
End If
FormatNumber$ = Left$(strValue, iDigits)
End Function ' FormatNumber$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the 8-bit binary representation
' of an integer iInput where 0 <= iInput <= 255
Function GetBinary$ (iInput1 As Integer)
Dim sResult As String
Dim iLoop As Integer
Dim iInput As Integer: iInput = iInput1
sResult = ""
If iInput >= 0 And iInput <= 255 Then
For iLoop = 1 To 8
sResult = LTrim$(RTrim$(Str$(iInput Mod 2))) + sResult
iInput = iInput \ 2
'If iLoop = 4 Then sResult = " " + sResult
Next iLoop
End If
GetBinary$ = sResult
End Function ' GetBinary$
' /////////////////////////////////////////////////////////////////////////////
' wonderfully inefficient way to read if a bit is set
' ival = GetBit256%(int we are comparing, int containing the bits we want to read)
' See also: GetBit256%, SetBit256%
Function GetBit256% (iNum1 As Integer, iBit1 As Integer)
Dim iResult As Integer
Dim sNum As String
Dim sBit As String
Dim iLoop As Integer
Dim bContinue As Integer
'DIM iTemp AS INTEGER
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
iResult = _FALSE
bContinue = _TRUE
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
'if any of the bits in iBit are _FALSE, return _FALSE
If Mid$(sNum, iLoop, 1) = "0" Then
iResult = _FALSE
bContinue = _FALSE
Exit For
End If
End If
Next iLoop
If bContinue = _TRUE Then
iResult = _TRUE
End If
End If
GetBit256% = iResult
End Function ' GetBit256%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text character at positon x%, y%
' Does the same as:
' Locate y%, x%
' GetCharXY% = Screen(CsrLin, Pos(0))
' See also: GetColorXY&
Function GetCharXY% (x%, y%)
GetCharXY% = Screen(y%, x%, 0) ' when 3rd parameter = 0 returns character code
End Function ' GetCharXY%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text color at positon x%, y%
' See also: GetCharXY%
Function GetColorXY& (x%, y%)
GetColorXY& = Screen(y%, x%, 1) ' when 3rd parameter = 1 returns character color
End Function ' GetColorXY
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
Function GetFileExt$ (FilePath$)
Dim iPos%
iPos% = _InStrRev(FilePath$, ".")
If iPos% > 0 Then
GetFileExt$ = Right$(FilePath$, Len(FilePath$) - iPos%)
Else
GetFileExt$ = ""
End If
End Function ' GetFileExt$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the integer that corresponds to a binary string of length 8
Function GetIntegerFromBinary% (sBinary1 As String)
Dim iResult As Integer
Dim iLoop As Integer
Dim strBinary As String
Dim sBinary As String: sBinary = sBinary1
iResult = 0
strBinary = Replace$(sBinary, " ", "") ' Remove any spaces
For iLoop = 0 To Len(strBinary) - 1
iResult = iResult + 2 ^ iLoop * Val(Mid$(strBinary, Len(strBinary) - iLoop, 1))
Next iLoop
GetIntegerFromBinary% = iResult
End Function ' GetIntegerFromBinary%
' /////////////////////////////////////////////////////////////////////////////
' Receives a {sDelimeter} delimited list of numbers {MyString}
' and splits it up into an integer array arrInteger()
' beginning at index {iMinIndex}.
Sub GetIntegerArrayFromDelimList (MyString As String, sDelimiter As String, iMinIndex As Integer, arrInteger() As Integer)
ReDim arrString(-1) As String
Dim CleanString As String
Dim iLoop As Integer
Dim iCount As Integer: iCount = iMinIndex - 1
ReDim arrInteger(-1) As Integer
'DebugPrint "GetIntegerArrayFromDelimList " + _
' "MyString=" + chr$(34) + MyString + chr$(34) + ", " + _
' "sDelimiter=" + chr$(34) + sDelimiter + chr$(34) + ", " + _
' "iMinIndex=" + cstr$(iMinIndex) + ", " + _
' "arrInteger()"
If Len(sDelimiter) > 0 Then
CleanString = MyString
If sDelimiter <> " " Then
CleanString = Replace$(CleanString, " ", "")
End If
split CleanString, sDelimiter, arrString()
iCount = iMinIndex - 1
For iLoop = LBound(arrString) To UBound(arrString)
If IsNum%(arrString(iLoop)) = _TRUE Then
iCount = iCount + 1
ReDim _Preserve arrInteger(iMinIndex To iCount) As Integer
arrInteger(iCount) = Val(arrString(iLoop))
'DebugPrint "5633 arrInteger(" + cstr$(iCount) + ") = VAL(arrString(" + cstr$(iLoop) + ")) = " + cstr$(arrInteger(iCount))
End If
Next iLoop
Else
If IsNum%(MyString) = _TRUE Then
ReDim _Preserve arrInteger(iMinIndex To iMinIndex) As Integer
arrInteger(iMinIndex) = Val(MyString)
End If
End If
'CleanString=""
'for iLoop=lbound(arrInteger) to ubound(arrInteger)
'CleanString = CleanString + iifstr$(iLoop=lbound(arrInteger), "", ",") + cstr$(arrInteger(iLoop))
'next iLoop
'DebugPrint "arrInteger=(" + CleanString + ")"
End Sub ' GetIntegerArrayFromDelimList
' /////////////////////////////////////////////////////////////////////////////
Function GetMaxInIntArray% (MyArray() As Integer)
Dim iMax%
Dim iLoop%
Print " GetMaxInIntArray% (MyArray(" + _
_Trim$(Str$( LBound(MyArray) ) ) + " To " + _
_Trim$(Str$( uBound(MyArray) ) ) + ")"
iMax% = MyArray(LBound(MyArray))
Print " INITIALIZE iMax% = MyArray(LBound(MyArray)) = " + _Trim$(Str$(iMax%))
For iLoop% = LBound(MyArray) To UBound(MyArray)
If MyArray(iLoop%) > iMax% Then
iMax% = MyArray(iLoop%)
Print " iMax% = MyArray(" + _Trim$(Str$(iLoop%)) + ") = " + _Trim$(Str$(iMax%))
End If
Next iLoop%
Print " FINAL GetMaxInIntArray% = iMax% = " + _Trim$(Str$(iMax%))
GetMaxInIntArray% = iMax%
End Function ' GetMaxInIntArray%
' /////////////////////////////////////////////////////////////////////////////
Function GetMaxInLongArray& (MyArray() As Long)
Dim iMax&
Dim iLoop%
Print " GetMaxInLongArray& (MyArray(" + _
_Trim$(Str$( LBound(MyArray) ) ) + " To " + _
_Trim$(Str$( uBound(MyArray) ) ) + ")"
iMax& = MyArray(LBound(MyArray))
Print " INITIALIZE iMax& = MyArray(LBound(MyArray)) = " + _Trim$(Str$(iMax&))
For iLoop% = LBound(MyArray) To UBound(MyArray)
If MyArray(iLoop%) > iMax& Then
iMax& = MyArray(iLoop%)
Print " iMax% = MyArray(" + _Trim$(Str$(iLoop%)) + ") = " + _Trim$(Str$(iMax&))
End If
Next iLoop%
Print " FINAL GetMaxInIntArray% = iMax& = " + _Trim$(Str$(iMax&))
GetMaxInLongArray& = iMax&
End Function ' GetMaxInLongArray&
' /////////////////////////////////////////////////////////////////////////////
' Gets the # of seconds so far today
Function GetTimeSeconds& ()
Dim result&: result& = 0
Dim sTime$: sTime$ = Time$
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
result& = result& + Val(sSS$)
result& = result& + (Val(sMI$) * 60)
result& = result& + ((Val(sHH24$) * 60) * 60)
' RETURN RESULT
GetTimeSeconds& = result&
End Function ' GetTimeSeconds&
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFS$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFS$ = IfTrue$ Else IIFS$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
Function IntPadLeft$ (iValue As Integer, iWidth As Integer)
IntPadLeft$ = Right$(String$(iWidth, " ") + _Trim$(Str$(iValue)), iWidth)
End Function ' IntPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function IntPadRight$ (iValue As Integer, iWidth As Integer)
IntPadRight$ = Left$(_Trim$(Str$(iValue)) + String$(iWidth, " "), iWidth)
End Function ' IntPadRight$
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsOdd%
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = _TRUE
Else
IsEven% = _FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if value text$ is numeric.
Function IsNum% (text$)
IsNum% = IsNumber%(text$)
End Function ' IsNum%
'' NOTE: THIS FAILS FOR NUMBERS LIKE "002" AND "2.000":
'' from https://www.qb64.org/forum/index.php?topic=896.0
'Function IsNum% (text$)
' Dim a$
' Dim b$
' a$ = _Trim$(text$)
' b$ = _Trim$(Str$(Val(text$)))
' If a$ = b$ Then
' IsNum% = _TRUE
' Else
' IsNum% = _FALSE
' End If
'End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns _TRUE (-1) if string is an integer, _FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = _FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = _FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = _TRUE
Else
TestString$ = OriginalString$
'bNegative% = _FALSE
End If
If Len(TestString$) > 0 Then
bResult% = _TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = _FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = _FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
'Sub IsNumberTest
' Dim in$
' Cls
' IsNumberTest1 "1"
' IsNumberTest1 "01"
' IsNumberTest1 "001"
' IsNumberTest1 "-1"
' IsNumberTest1 "-01"
' IsNumberTest1 "-001"
' IsNumberTest1 "+1"
' IsNumberTest1 "+01"
' IsNumberTest1 "+001"
' IsNumberTest1 ".1"
' IsNumberTest1 ".01"
' IsNumberTest1 ".001"
' IsNumberTest1 ".10"
' IsNumberTest1 ".100"
' IsNumberTest1 "..100"
' IsNumberTest1 "100."
' Input "PRESS ENTER TO CONTINUE TEST";in$
' Cls
' IsNumberTest1 "0.10"
' IsNumberTest1 "00.100"
' IsNumberTest1 "000.1000"
' IsNumberTest1 "000..1000"
' IsNumberTest1 "000.1000.00"
' IsNumberTest1 "+1.00"
' IsNumberTest1 "++1.00"
' IsNumberTest1 "+-1.00"
' IsNumberTest1 "-1.00"
' IsNumberTest1 "-+1.00"
' IsNumberTest1 " 1"
' IsNumberTest1 "1 "
' IsNumberTest1 "1. 01"
' IsNumberTest1 "+1 "
'End Sub ' IsNumberTest
'Sub IsNumberTest1(MyString As String)
' Const cWidth = 16
' Dim sInput As String : sInput = left$(Chr$(34) + MyString + Chr$(34) + String$(cWidth, " "), cWidth)
' Dim sResult As String : sResult = right$(String$(2, " ") + _Trim$(Str$(IsNumber%(MyString))), 2)
' Print "IsNumber%(" + sInput + ") returns " + sResult
'End Sub ' IsNumberTest1
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if number n is odd
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsEven%
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = _TRUE
Else
IsOdd% = _FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim i As Long
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
Function LeftPadString$ (myString$, toWidth%, padChar$)
LeftPadString$ = Right$(String$(toWidth%, padChar$) + myString$, toWidth%)
End Function ' LeftPadString$
' /////////////////////////////////////////////////////////////////////////////
' ABS was returning strange values with type LONG
' so I created this which does not.
Function LongABS& (lngValue As Long)
If Sgn(lngValue) = -1 Then
LongABS& = 0 - lngValue
Else
LongABS& = lngValue
End If
End Function ' LongABS&
' /////////////////////////////////////////////////////////////////////////////
Function NameOnly$ (FilePath$)
Dim iPos%
iPos% = _InStrRev(FilePath$, "\")
If iPos% > 0 Then
NameOnly$ = Right$(FilePath$, Len(FilePath$) - iPos%)
Else
NameOnly$ = FilePath$
End If
End Function ' NameOnly$
' /////////////////////////////////////////////////////////////////////////////
' remove scientific Notation to String (~40 LOC)
' SMcNeill Jan 7, 2020
' https://www.qb64.org/forum/index.php?topic=1555.msg112989#msg112989
' Last Function in code marked Best Answer (removed debug comments and
' blank lines added these 2 lines.)
Function N2S$ (EXP$)
ReDim t$, sign$, l$, r$, r&&
ReDim dp As Long, dm As Long, ep As Long, em As Long, check1 As Long, l As Long, i As Long
t$ = LTrim$(RTrim$(EXP$))
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
If check1 < 1 Or check1 > 1 Then N2S = _Trim$(EXP$): Exit Function ' If no scientic notation is found, or if we find more than 1 type, it's not SN!
Select Case l ' l now tells us where the SN starts at.
Case Is < dp: l = dp
Case Is < dm: l = dm
Case Is < ep: l = ep
Case Is < em: l = em
End Select
l$ = Left$(t$, l - 1) ' The left of the SN
r$ = Mid$(t$, l + 1): r&& = Val(r$) ' The right of the SN, turned into a workable long
If InStr(l$, ".") Then ' Location of the decimal, if any
If r&& > 0 Then
r&& = r&& - Len(l$) + 2
Else
r&& = r&& + 1
End If
l$ = Left$(l$, 1) + Mid$(l$, 3)
End If
Select Case r&&
Case 0 ' what the heck? We solved it already?
' l$ = l$
Case Is < 0
For i = 1 To -r&&
l$ = "0" + l$
Next
l$ = "." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
l$ = l$
End Select
N2S$ = sign$ + l$
End Function ' N2S$
' /////////////////////////////////////////////////////////////////////////////
' Pauses for iDS deciseconds (iDS * 100 ms)
Sub PauseDecisecond (iDS As Integer)
Dim iCount As Integer
iCount = 0
Do
iCount = iCount + 1
_Limit 10 ' run 10x every second
Loop Until iCount = iDS
End Sub ' PauseDecisecond
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if point (x1%, y1%) is adjacent to point (x2%, y2%)
Function PointsAreAdjacent% (x1%, y1%, x2%, y2%)
Dim bResult%: bResult% = _FALSE
' x or y can be the same, but not both
If (x1% <> x2%) Or (y1% <> y2%) Then
If (x1% = x2%) Or ((x1% = (x2% + 1)) Or (x2% = (x1% + 1))) Then
If (y1% = y2%) Or ((y1% = (y2% + 1)) Or (y2% = (y1% + 1))) Then
bResult% = _TRUE
End If
End If
End If
PointsAreAdjacent% = bResult%
End Function ' PointsAreAdjacent%
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
'
' iRow% and iCol% are 0-based in this version
'
' See also: PrintString, PrintString1, PutCharXY
Sub PrintAt (iRow%, iCol%, sText$)
'_PrintString (iCol% * 8, iRow% * 16), sText$
_PrintString (iCol% * 8, iRow% * 16), sText$
'_PrintString (iCol%, iRow%), sText$
End Sub ' PrintAt
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to a debug file in the EXE folder.
' Debug file is named the same thing as the program EXE name with ".txt" at the end.
' For example the program "C:\QB64\MyProgram.BAS" running as
' "C:\QB64\MyProgram.EXE" would have an output file "C:\QB64\MyProgram.EXE.txt".
' If the file doesn't exist, it is created, otherwise it is appended to.
' If in debug mode, show the user the debug path that they can copy/paste
' using _INPUTBOX$:
' result$ = _INPUTBOX$(m_ProgramName$, "Current debug filename is:", m_ProgramPath$ + m_ProgramName$ + ".txt")
Sub PrintDebugFile (sText As String)
Dim sFileName As String
Dim sError As String
Dim sOut As String
Dim sTimestamp As String
sFileName = m_ProgramPath$ + m_ProgramName$ + ".txt"
sError = ""
sTimestamp = CurrentDateTime$
If _FileExists(sFileName) = _FALSE Then
sOut = ""
'sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
'sOut = sOut + "PROGRAM : " + m_ProgramName$ + Chr$(13) + Chr$(10)
'sOut = sOut + "RUN DATE: " + sTimestamp + Chr$(13) + Chr$(10)
'sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sError = PrintFile$(sFileName, sOut, _FALSE)
End If
If Len(sError) = 0 Then
sError = PrintFile$(sFileName, sText, _TRUE)
End If
If Len(sError) <> 0 Then
Print sTimestamp + " PrintDebugFile FAILED"
Print String$(Len(sTimestamp) + 1, " ") + "sFileName = " + Chr$(34) + sFileName + Chr$(34)
Print String$(Len(sTimestamp) + 1, " ") + "ERROR = " + sError
End If
End Sub ' PrintDebugFile
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=_TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
' Example:
' m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = m_ProgramPath$ + m_ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, _FALSE)
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = _TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString1
' /////////////////////////////////////////////////////////////////////////////
' iNum% = PromptForIntegerInRange%("Please type a number between {min} and {max} (or blank to quit).", 1, 4, 0) ' prompt, min, max, default
Function PromptForIntegerInRange% (sPrompt$, iMin%, iMax%, iDefault%)
Dim iValue%
Dim bFinished%
Dim sPrompt1$
Dim in$
If Len(sPrompt$) > 0 Then
sPrompt1$ = sPrompt$
Else
sPrompt1$ = "Please type a number between {min} and {max} (or blank to quit)."
End If
sPrompt1$ = Replace$(sPrompt1$, "{min}", cstr$(iMin%))
sPrompt1$ = Replace$(sPrompt1$, "{max}", cstr$(iMax%))
bFinished% = _FALSE
Do
Print sPrompt1$
Input in$
in$ = _Trim$(in$)
If Len(in$) > 0 Then
If IsNumber(in$) Then
iValue% = Val(in$)
If iValue% >= iMin% And iValue% <= iMax% Then
'bFinished% = _TRUE
Exit Do
Else
Print "Number out of range."
Print
End If
Else
Print "Not a valid number."
Print
End If
Else
iValue% = iDefault%
Exit Do
'bFinished% = _TRUE
End If
Loop Until bFinished% = _TRUE
PromptForIntegerInRange% = iValue%
End Function ' PromptForIntegerInRange%
' /////////////////////////////////////////////////////////////////////////////
' Prints text character char$ at positoin x%,y% in color myColor&.
Sub PutCharXY (x%, y%, char$, myColor&)
Color myColor&
Locate y%, x%
Print char$;
End Sub ' PutCharXY
' /////////////////////////////////////////////////////////////////////////////
' Initializes random number generator seed
' NOTE:
' using # of seconds so far in the day
' may be slightly more random than Randomize Timer
' unless user runs program at exact same time every day
Sub InitializeRandom
'Dim iSeed As Integer
'Dim t9#
'iSeed = GetTimeSeconds& MOD 32767
't9# = (Timer * 1000000) Mod 32767
Randomize Timer
'Randomize iSeed
'print "Randomize " + cstr$(iSeed)
'Sleep
End Sub ' InitializeRandom
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with
' InitializeRandom or Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub RandomNumberTest
Dim iCols As Integer: iCols = 10
Dim iRows As Integer: iRows = 20
Dim iLoop As Integer
Dim iX As Integer
Dim iY As Integer
Dim sError As String
Dim sFileName As String
Dim sText As String
Dim bAppend As Integer
Dim iMin As Integer
Dim iMax As Integer
Dim iNum As Integer
Dim iErrorCount As Integer
Dim sInput$
sFileName = "c:\temp\maze_test_1.txt"
sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
bAppend = _FALSE
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) = 0 Then
bAppend = _TRUE
iErrorCount = 0
iMin = 0
iMax = iCols - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
iMin = 0
iMax = iRows - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
Else
Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
Print sError
End If
Input "Press <ENTER> to continue", sInput$
End Sub ' RandomNumberTest
$End If
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ReplaceTest
Dim in$
Print "-------------------------------------------------------------------------------"
Print "ReplaceTest"
Print
Print "Original value"
in$ = "Thiz iz a teZt."
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "Z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "ReplaceTest finished."
End Sub ' ReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
Function RightPadString$ (myString$, toWidth%, padChar$)
RightPadString$ = Left$(myString$ + String$(toWidth%, padChar$), toWidth%)
End Function ' RightPadString$
' /////////////////////////////////////////////////////////////////////////////
' This sub gives really nice control over displaying an Image.
' by BPlus
' Scale rotate font text strings by B+
' https://qb64phoenix.com/forum/showthread.php?tid=414&highlight=rotate+text
' USED BY: drwString
Sub RotoZoom2 (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, Rotation As Single)
Dim px(3) As Single
Dim py(3) As Single
Dim W&
Dim H&
Dim sinr!
Dim cosr!
Dim i&
Dim x2&
Dim y2&
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = Sin(-Rotation): cosr! = Cos(-Rotation)
For i& = 0 To 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub ' RotoZoom2
'' /////////////////////////////////////////////////////////////////////////////
'' https://qb64phoenix.com/forum/showthread.php?tid=644
'' From: bplus
'' Date: 07-18-2022, 03:16 PM
'' Here is a Round$ that acts the way you'd expect in under 100 LOC
'' b = b + ...
'
'Function Round$ (anyNumber, dp As Long)
' ' 5 and up at decimal place dp+1 > +1 at decimal place 4 and down > +0 at dp
' ' 2 1 0.-1 -2 -3 -4 ... pick dp like this for this Round$ Function
' sn$ = N2S$(Str$(anyNumber + .5 * 10 ^ dp)) ' get rid of sci notation, steve trims it so next find dot
' dot = InStr(sn$, ".")
' If dot Then
' predot = dot - 1
' postdot = Len(sn$) - (dot + 1)
' Else
' predot = Len(sn$)
' postdot = 0
' End If
' ' xxx.yyyyyy dp = -2
' ' ^ dp
' If dp >= 0 Then
' Rtn$ = Mid$(sn$, 1, predot - dp) + String$(dp, "0")
' Else
' Rtn$ = Mid$(sn$, 1, predot) + "." + Mid$(sn$, dot + 1, -dp)
' End If
' If Rtn$ = "" Then
' Round$ = "0"
' Else
' Round$ = Rtn$
' End If
'End Function ' Round$
'
'' /////////////////////////////////////////////////////////////////////////////
''
''Sub RoundTest
'' Print Round$(.15, 0) ' 0
'' Print Round$(.15, -1) ' .2
'' Print Round$(.15, -2) ' .15
'' Print Round$(.15, -3) ' .150
'' Print
'' Print Round$(3555, 0) ' 3555
'' Print Round$(3555, 1) ' 3560
'' Print Round$(3555, 2) ' 3600 'good
'' Print Round$(3555, 3) ' 4000
'' Print
'' Print Round$(23.149999, -1) ' 23.1
'' Print Round$(23.149999, -2) ' 23.15
'' Print Round$(23.149999, -3) ' 23.150
'' Print Round$(23.149999, -4) ' 23.1500
'' Print
'' Print Round$(23.143335, -1) ' 23.1 OK?
'' Print Round$(23.143335, -2) ' 23.14
'' Print Round$(23.143335, -3) ' 23.143
'' Print Round$(23.143335, -4) ' 23.1433
'' Print Round$(23.143335, -5) ' 23.14334
'' Print
'' Dim float31 As _Float
'' float31 = .310000000000009
'' Print Round$(.31, -2) ' .31
'' Print Round$(.31##, -2)
'' Print Round$(float31, -2)
''End Sub ' RoundTest
' /////////////////////////////////////////////////////////////////////////////
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on Today at 03:53:48 PM
'
' Sometimes, you guys make things entirely too complicated.
' There ya go! Three functions to either round naturally,
' always round down, or always round up, to whatever number of digits you desire.
' EDIT: Modified to add another option to round scientific,
' since you had it's description included in your example.
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
' old name: RoundNatural##
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' old name: Round_Scientific##
Function RoundScientific## (num##, digits%)
RoundScientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
Function RoundDouble# (num#, digits%)
RoundDouble# = Int(num# * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownDouble# (num#, digits%)
RoundDownDouble# = Int(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _Round(num# * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE SINGLE
Function RoundSingle! (num!, digits%)
RoundSingle! = Int(num! * 10 ^ digits% + .5) / 10 ^ digits%
End Function
' NOTE: not sure this one works: when digits%=3, it rounds .31 to .32
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownSingle! (num!, digits%)
RoundDownSingle! = Int(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificSingle! (num!, digits%)
RoundScientificSingle! = _Round(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' fantastically inefficient way to set a bit
' example use: arrMaze(iX, iY) = SetBit256%(arrMaze(iX, iY), cS, _FALSE)
' See also: GetBit256%, SetBit256%
' newint=SetBit256%(oldint, int containing the bits we want to set, value to set them to)
Function SetBit256% (iNum1 As Integer, iBit1 As Integer, bVal1 As Integer)
Dim sNum As String
Dim sBit As String
Dim sVal As String
Dim iLoop As Integer
Dim strResult As String
Dim iResult As Integer
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
Dim bVal As Integer: bVal = bVal1
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
If bVal = _TRUE Then
sVal = "1"
Else
sVal = "0"
End If
strResult = ""
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
strResult = strResult + sVal
Else
strResult = strResult + Mid$(sNum, iLoop, 1)
End If
Next iLoop
iResult = GetIntegerFromBinary%(strResult)
Else
iResult = iNum
End If
SetBit256% = iResult
End Function ' SetBit256%
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ShowDegreesAndRadians
Dim iDegree As Integer
Dim sngRadian As Single
DebugPrint "Degree Radian"
DebugPrint "------ ------"
For iDegree = 0 To 360
sngRadian = _D2R(iDegree)
'DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + LeftPadString$(cstr$(iRadian), 3, " ")
DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + SngToStr$(sngRadian)
'Print "SngToStr$(MyValue) =" + SngToStr$(MyValue)
'Print "SngRoundedToStr$(MyValue, 12)=" + SngRoundedToStr$(MyValue, 12)
Next iDegree
End Sub ' ShowDegreesAndRadians
$End If
' /////////////////////////////////////////////////////////////////////////////
' use angles in degrees units instead of radians (converted inside sub)
' Note this function uses whatever the default type is, better not be some Integer Type.
Function SinD (degrees)
SinD = Sin(_D2R(degrees))
End Function ' SinD
' /////////////////////////////////////////////////////////////////////////////
Function SmallestOf3% (i1%, i2%, i3%)
Dim iMin%
iMin% = i1%
If i2% < iMin% Then iMin% = i2%
If i3% < iMin% Then iMin% = i3%
SmallestOf3% = iMin%
End Function ' SmallestOf3
' /////////////////////////////////////////////////////////////////////////////
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function SngToInt% (sngOld As Single)
Dim sngNew As Single
Dim sValue As String
Dim iPos As Integer
sngNew = RoundSingle!(sngOld, 0)
'sValue = _Trim$(Str$(sngNew))
sValue = SngToStr$(sngNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' SngToInt% = Val(Left$(sValue, iPos - 1))
'Else
' SngToInt% = Val(sValue)
'End If
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
value$ = UCase$(LTrim$(Str$(n!)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
' for some reason it puts a space where a decimal point should be
result$ = Replace$(result$, " ", ".")
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitTest
Dim in$
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
delim$ = Chr$(10)
in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
split in$, delim$, arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
Print "arrTest$(" + LTrim$(RTrim$(Str$(iLoop%))) + ") = " + Chr$(34) + arrTest$(iLoop%) + Chr$(34)
Next iLoop%
Print
Print "Split test finished."
End Sub ' SplitTest
$End If
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitAndReplaceTest
Dim in$
Dim out$
Dim iLoop%
ReDim arrTest$(0)
Print "-------------------------------------------------------------------------------"
Print "SplitAndReplaceTest"
Print
Print "Original value"
in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Fixing linebreaks..."
in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
in$ = Replace$(in$, Chr$(10), Chr$(13))
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Splitting up..."
split in$, Chr$(13), arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
out$ = arrTest$(iLoop%)
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
Print "SplitAndReplaceTest finished."
End Sub ' SplitAndReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
' Converts a chr$(13) delimited string
' into a 2-dimensional array.
' Usage:
' Dim StringArray(1 To 48, 1 To 128) As String
' StringTo2dArray StringArray(), GetMap$
' Version 2 with indexed array(row, columm)
' Renamed StringToArray to StringTo2dArray.
' See also: Array2dToString$
Sub StringTo2dArray (MyArray() As String, MyString As String)
Dim sDelim As String
ReDim arrLines(0) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim iDim1 As Integer
Dim iDim2 As Integer
Dim iIndex1 As Integer
Dim iIndex2 As Integer
iDim1 = LBound(MyArray, 1)
iDim2 = LBound(MyArray, 2)
sDelim = Chr$(13)
split MyString, sDelim, arrLines()
For iRow = LBound(arrLines) To UBound(arrLines)
If iRow <= UBound(MyArray, 1) Then
For iCol = 1 To Len(arrLines(iRow))
If iCol <= UBound(MyArray, 2) Then
sChar = Mid$(arrLines(iRow), iCol, 1)
If Len(sChar) > 1 Then
sChar = Left$(sChar, 1)
Else
If Len(sChar) = 0 Then
sChar = "."
End If
End If
iIndex1 = iRow + iDim1
iIndex2 = (iCol - 1) + iDim2
MyArray(iIndex1, iIndex2) = sChar
'DebugPrint "MyArray(" + cstr$(iIndex1) + ", " + cstr$(iIndex2) + " = " + chr$(34) + sChar + chr$(34)
Else
' Exit if out of bounds
Exit For
End If
Next iCol
Else
' Exit if out of bounds
Exit For
End If
Next iRow
End Sub ' StringTo2dArray
' /////////////////////////////////////////////////////////////////////////////
Function StrPadLeft$ (sValue As String, iWidth As Integer)
StrPadLeft$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
' /////////////////////////////////////////////////////////////////////////////
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
Function StrJustifyCenter$ (sValue As String, iWidth As Integer)
Dim iLen0 As Integer
Dim iLen1 As Integer
Dim iLen2 As Integer
Dim iExtra As Integer
iLen0 = Len(sValue)
If iWidth = iLen0 Then
' no extra space: return unchanged
StrJustifyCenter$ = sValue
ElseIf iWidth > iLen0 Then
If IsOdd%(iWidth) Then
iWidth = iWidth - 1
End If
' center
iExtra = iWidth - iLen0
iLen1 = iExtra \ 2
iLen2 = iLen1 + (iExtra Mod 2)
StrJustifyCenter$ = String$(iLen1, " ") + sValue + String$(iLen2, " ")
Else
' string is too long: truncate
StrJustifyCenter$ = Left$(sValue, iWidth)
End If
End Function ' StrJustifyCenter$
' /////////////////////////////////////////////////////////////////////////////
' Use to pretty print _TRUE and _FALSE values.
Function TrueFalse$ (myValue)
If myValue = _TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' /////////////////////////////////////////////////////////////////////////////
' ################################################################################################################################################################
' END GENERAL PURPOSE ROUTINES @GEN
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN COLOR FUNCTIONS #COLOR
' ################################################################################################################################################################
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ################################################################################################################################################################
' END COLOR FUNCTIONS @COLOR
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
Posts: 306
Threads: 19
Joined: Apr 2022
Reputation:
57
(8 hours ago)madscijr Wrote: (03-05-2025, 04:39 AM)vince Wrote: tranny kpop matrix mod
I did give this a try, nice! Video to ASCII in realtime! That was on my "to do" list!
Question - did you assign a brightness value to the different ASCII characters, or are they just arbitrarily selected?
I have been meaning to write a simple prog to go through the printable ASCII characters and for each, _PRINTSTRING it to the screen and count the pixels, the # being its "brightness", and save that score, then at the end sort them by score. Then the picture-to-ascii matches the brightness of each pixel (or a given block of pixels) to be approximated by an ASCII char, and does a lookup in the array to find a character with the corresponding brightness.
In the time it took me to write that explanation I could have finished the code, LOL, but it did help clarify it in my mind. it does all of the above, yes
I have been meaning to write a simple prog to go through the printable ASCII characters and for each, _PRINTSTRING it to the screen and count the pixels, the # being its "brightness", and save that score,
Code: (Select All)
for i=0 to n
p(i).img = _newimage(8, 16, 32)
_dest p(i).img
_source p(i).img
_printstring (0,0), chr$(i + 32)
p(i).c = chr$(i + 32)
sum = 0
for y=0 to 16-1
for x=0 to 8-1
z = point(x, y)
'pset (x, y), z
if point(x,y)=_rgb(255,255,255) then sum = sum + 1
next
next
p(i).d = sum
next
then at the end sort them by score.
Code: (Select All)
for i=1 to ubound(p)
j = i
do while (j>0 and p(j-1).d > p(j).d)
swap p(j), p(j-1)
j = j - 1
loop
next
Then the picture-to-ascii matches the brightness of each pixel (or a given block of pixels) to be approximated by an ASCII char, and does a lookup in the array to find a character with the corresponding brightness.
Code: (Select All)
z = point(x*8 + 4, y*16 + 8)
'z2 = point(x*8 + 4, y*16 + 4)
r = _red(z)
g = _blue(z)
b = _green(z)
c = 0.299*r + 0.587*g + 0.114*b
c = (c/255)*n
also, madsci, i did not forget about the 3D glasses stuff, i'll get around to it one of these days -- it turned out to be truly mad science
|
