Posted by: Petr - 03-19-2024, 09:10 PM - Forum: Petr
- Replies (2)
Code: (Select All)
Screen _NewImage(1000, 1000, 32)
cx = 500 'center x and center y
cy = 500
m = 200 'X radius
n = 100 'y radius
Dim col As _Unsigned Long
For oy = 250 To 750 'ox, oy points in rectangle. If the point is part of an ellipse, it will be white, otherwise it will be black
For ox = 250 To 750
aa = ((ox - cx) ^ 2) / m ^ 2
bb = ((oy - cy) ^ 2) / n ^ 2
If aa + bb < 1 Then col = _RGB32(255) Else col = _RGB32(0)
PSet (ox, oy), col
Next
Next
I often use point detection in a circle, this can easily be modified to detect a point in an ellipse. Maybe it will be useful for someone.
Made a "just for fun" (to see if i could do it) program that simulates the menu of Need for Speed High Stakes PC version.
Copy the files in the ZIP to the folder where you have QB64.
When you click "Race" the program will attempt to launch an MP4 with the same name as the track you have selected.
Put your version of the video for the track into the "tracks-MP4s" folder.
This is optional. If no video for the track exists nothing will happen when you click "Race".
Anyway, let me know if you find this...amusing?
I have made one for NFS Hot Pursuit 2.
Waiting to see if anyone finds this NFS HS sim "fun".
If PrintMode = 1Then Line (x1 + 1, y + 1)-Step(wide, tall), SkyBlue, BF Else Line (x1 + 1, y + 1)-Step(wide, tall), LightGray, BF End If If PrintMode = 2Then Line (x2 + 1, y + 1)-Step(wide, tall), SkyBlue, BF Else Line (x2 + 1, y + 1)-Step(wide, tall), LightGray, BF End If
If PrintMode = 3Then Line (x3 + 1, y + 1)-Step(wide, tall), SkyBlue, BF Else Line (x3 + 1, y + 1)-Step(wide, tall), LightGray, BF End If UCprint428, 475, Black, 0, "NO" UCprint428, 493, Black, 0, "BG" UCprint462, 475, Black, 0, "NO" UCprint462, 493, Black, 0, "FG" UCprint493, 482, Black, 0, "ALL"
Line (x2, y)-Step(wide + 4, tall + 4), Gold, BF Line (x2 + 2, y + 2)-Step(wide, tall), Background, BF UCprint x1 + w, y + h, Black, 0, FontColorName UCprint x2 + w2, y + h, Black, 0, BackgroundName UCprint x1 + w, y + h + 35, White, 0, FontColorName UCprint x2 + w2, y + h + 35, White, 0, BackgroundName End Sub
SubGetColors
file$ = ".\internal\support\color\color32.bi" If_FileExists(file$) = 0ThenExit Sub'bad path, bad file... some glitch... we can't work Open file$ ForBinaryAs #1 ReDim Kolor(1000) As Color_Type
Line (100, 100)-(700, 400), Gold, BF Line (102, 102)-(698, 398), Background, BF If CurrentImage <> 0Then_PutImage (102, 102)-(698, 398), CurrentImage
x = 100: y = 100
If OldfontName <> DefaultFont.name Or OldFontSize <> DefaultFontSize Then If DefaultFont.name <> "No Font List Loaded"Then
oldf = f
f = _LoadFont(DefaultFont.dir, DefaultFontSize) _Font f
OldfontName = DefaultFont.name
olffontsize = DefaultFontSize End If End If If oldf <> f Then If oldf > 31Then_FreeFont oldf End If
SubDropDownFontList (x, y, wide, fontlist() As Font_type) Shared Font() As Font_type StaticAsLong f, CurrentFont IfUBound(Font) = 0Then
DefaultFont.name = "No Font List Loaded"
DefaultFont.dir = ""
CurrentFont = 0
f = 16
oldf = 16 End If If DefaultFont.name = ""Then
CurrentFont = 1
DefaultFont.name = Font(1).name
DefaultFont.dir = Font(1).dir End If
Line (x, y)-Step(wide + 4, 36), Gold, BF Line (x + 2, y + 2)-Step(wide, 32), SkyBlue, BF
w = (wide - _UPrintWidth(out$)) \ 2 UCprint x + w, y + 6, MidnightBlue, 0, out$
oldf = f End Sub
SubCleanFontList (FontList() As Font_type) For i = 1ToUBound(FontList)
P = _InStrRev(FontList(i).name, "(") 'strip off the (True Type) type id If P Then FontList(i).name = Left$(FontList(i).name, P - 1) Next End Sub
'a quick and simple combsort to make certain our list is in alphabetical order
gap = count Do
gap = 10 * gap \ 13 If gap < 1Then gap = 1
i = 1
swapped = 0 Do If FontList(i).name > FontList(i + gap).name Then Swap FontList(i).name, FontList(i + gap).name Swap FontList(i).dir, FontList(i + gap).dir
swapped = -1 End If
i = i + 1 Loop Until i + gap > count Loop Until gap = 1And swapped = 0 End Sub
As Dimster brought up here -- https://qb64phoenix.com/forum/showthread.php?tid=2505 -- there's no really great tool out there right now for previewing what text might look like on the screen; especially when changing colors/backgrounds/fonts/images.
This is the start of my solution to such a preview tool.
At the moment, this gets a list of all the fonts on an user's computer (Windows only), and it produces a preview pane with a background and font color, letting you choose your font and see how it'd look with that configuration.
I have converted the entire collection of constants used by Windows. It has been formatted to fit QB64 format. I figure this is a useful resource to have on hand when an API call wants certain values, you can find them here. I say it is a 'resource' not a module, because I doubt seriously anyone wants to include over 6000 constants into a program you're writing when you just need a handful. To make it easier to read, the entries are single spaced, and organized by first letter, except where a constant depends on another one. I have left such 'dependencies' in as they document something about the relevant API call.
Since this will help me a lot in various Windows calls I figure it might be valuable for others. It is included as an attachment to this message.
Just one small thing to contribute to the community, as a tiny contribution to add to the effort expended by others.
Paul
- - -
Paul Robinson <paul@paul-robinson.us>
"The lessons of history - if they teach us anything - is that no one learns the lessons that history teaches us."
Hello ! I want to make programs for android. Unfortunately, I've been programming in Basic for 30 years, and it's hard for my brain to switch to object-oriented programming. I don't see and understand at all how they are built on each other, how things can be connected. A week ago, I tried the development system called B4A (https://www.b4x.com), which is in principle written in Basic, but in practice it could be anything due to the lack of simplicity.
I made a program in QB64 in a couple of hours, and then converted it to B4A. I suffered with it for almost 2 days before I rewrote it properly and it finally started.
I have attached APK file. This should be launched on Android and the program will be installed. Pretty much the same as the code here.
In the qb64 version, the mouse behaves like the touchscreen on the phone. The left mouse button simulates touching the touchscreen, and the move button simulates moving the mouse.
Dim Shared map_dat(9)
Dim Shared map(99, 99)
Dim Shared map_p(9999, 9), map_pc
Dim Shared map_s(9999, 4), map_sc
Dim Shared map_l(9999, 9), map_lc
Dim Shared cam(9)
Dim Shared iranyitas(9)
lepes = (iranyitas(2) - iranyitas(1)) * .06
For t1 = 0 To 80
For t2 = 0 To 1
ang = cam(3) + t1 * (t2 * 2 - 1) * (3.1415 / 180)
lepes = (iranyitas(2) - iranyitas(1)) * .06 / 80 * (80 - t1)
x = cam(0) + Sin(ang) * lepes
y = cam(1) + Cos(ang) * lepes
If map(x - .5, y - .5) = 0 Then cam(0) = x: cam(1) = y: GoTo 88
Next t2
Next t1
88:
rot
For t = 0 To map_lc - 1
If map_p(map_l(t, 0), 5) And map_p(map_l(t, 1), 5) Then
x1 = map_p(map_l(t, 0), 3)
y1 = map_p(map_l(t, 0), 4)
x2 = map_p(map_l(t, 1), 3)
y2 = map_p(map_l(t, 1), 4)
temp = 127 * (map_p(map_l(t, 0), 6) + map_p(map_l(t, 1), 6))
Line (x1, y1)-(x2, y2), _RGB32(temp, temp, temp)
End If
Next t
_Display
Cls
Loop
Sub rot '(x, y, z)
For t = 0 To map_pc - 1
x2 = map_p(t, 0) - cam(0)
y2 = map_p(t, 1) - cam(1)
z2 = map_p(t, 2) - cam(2)
rotate_2d x2, y2, cam(3)
map_p(t, 5) = 0
If Abs(y2) < cam(7) Then
If Abs(x2) < cam(7) Then
dis = (x2 * x2 + y2 * y2)
If dis < cam(6) Then
If y2 > 0 Then
temp = 800 / y2
x = x2 * temp
y = z2 * temp
map_p(t, 3) = x + cam(8)
map_p(t, 4) = -y + cam(9)
map_p(t, 5) = 1
map_p(t, 6) = 1 - cam(5) * Sqr(dis)
End If
End If
End If
End If
Next t
End Sub
Sub control
mousex = 0: mousey = 0: mousew = 0: While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mousew = mousew + _MouseWheel: Wend
iranyitas(2) = iranyitas(1)
If _MouseButton(1) Then
iranyitas(0) = iranyitas(0) + mousex
iranyitas(1) = iranyitas(1) + mousey
End If
End Sub
Sub rotate_2d (x, y, ang): x1 = x * Cos(ang) - y * Sin(ang): y1 = x * Sin(ang) + y * Cos(ang): x = x1: y = y1: End Sub
Function interpolate (a, b, x): interpolate = a + (b - a) * x: End Function
Sub add_sq (a, b, c, d, plan)
map_s(map_sc, 0) = a
map_s(map_sc, 1) = b
map_s(map_sc, 2) = c
map_s(map_sc, 3) = d
map_s(map_sc, 4) = plan
map_sc = map_sc + 1
add_line a, b
add_line a, c
add_line c, d
add_line b, d
End Sub
Sub add_line (a, b)
find = -1
If map_lc > 0 Then
For t = 0 To map_lc - 1
If (map_l(t, 0) = a And map_l(t, 1) = b) Or (map_l(t, 0) = b And map_l(t, 1) = a) Then find = t
Next
End If
If find = -1 Then
map_l(map_lc, 0) = a
map_l(map_lc, 1) = b
map_lc = map_lc + 1
End If
End Sub
Function add_point (x, y, z)
find = -1
If map_pc > 0 Then
For t = 0 To map_pc - 1
If map_p(t, 0) = x And map_p(t, 1) = y And map_p(t, 2) = z Then find = t
Next t
End If
If find = -1 Then
map_p(map_pc, 0) = x
map_p(map_pc, 1) = y
map_p(map_pc, 2) = z
add_point = map_pc
map_pc = map_pc + 1
Else
add_point = find
End If
End Function
Sub createtrack (qx, qy, qf)
map_dat(0) = qx
map_dat(1) = qy
map_dat(2) = qf
Dim d(1)
Dim temp1
For x = 0 To qx - 1: For y = 0 To qy - 1: map(x, y) = 1: Next: Next
Do
temp1 = temp1 + map(d(0), d(1))
map(d(0), d(1)) = 0
t = Int(4 * Rnd)
d(t And 1) = d(t And 1) + (t And 2) - 1
If d(0) = 1 Or d(0) = map_dat(0) - 1 Or d(1) = 1 Or d(1) = map_dat(1) - 1 Then d(0) = Int(map_dat(0) / 2): d(1) = Int(map_dat(1) / 2)
If temp1 > qx * qy * qf Then Exit Do
Loop
End Sub
Sub create_textsq
For x = 0 To map_dat(0) - 1
For y = 0 To map_dat(1) - 1
p0 = add_point(x, y, map(x, y))
p1 = add_point(x + 1, y, map(x, y))
p2 = add_point(x, y + 1, map(x, y))
p3 = add_point(x + 1, y + 1, map(x, y))
add_sq p0, p1, p2, p3, 2
If map(x, y) = 0 Then
If map(x - 1, y) = 1 Then
x1 = x
y1 = y
x2 = x
y2 = y + 1
create_textsq2 x1, y1, x2, y2, 0
End If
If map(x + 1, y) = 1 Then
x1 = x + 1
y1 = y
x2 = x + 1
y2 = y + 1
create_textsq2 x1, y1, x2, y2, 0
End If
If map(x, y - 1) = 1 Then
x1 = x
y1 = y
x2 = x + 1
y2 = y
create_textsq2 x1, y1, x2, y2, 0
End If
If map(x, y + 1) = 1 Then
x1 = x
y1 = y + 1
x2 = x + 1
y2 = y + 1
create_textsq2 x1, y1, x2, y2, 0
End If
End If
Next
Next
End Sub
Sub create_textsq2 (x1, y1, x2, y2, plan)
p0 = add_point(x1, y1, 0)
p1 = add_point(x1, y1, 1)
p2 = add_point(x2, y2, 1)
p3 = add_point(x2, y2, 0)
add_sq p0, p1, p3, p2, plan
End Sub
I'm trying to read a TXT with a spanish text, full of accented characters (like á or Á) and obviously our beloved ñ and Ñ
I have loaded a font in memory (with _LOADFONT) and I'm trying to PRINTSTRING my file, but it is impossible. My screen is full of strange characters, and I don't know what to do... I think that it is an "unicode" problem, but I don't understand this thing... sorry
Type Font_Name_Type NameAsString
FileName AsString End Type ReDimShared Fonts(10000) As Font_Name_Type ReDimShared MonoFonts(10000) As Font_Name_Type Screen_NewImage(1280, 720, 32) GetFontList GetMonoFontList
numbered = -1'number our quick list
l = 20'number of lines to print to the screen
w = 50'width to print to the screen
Do UntilEOF(1) Line Input #1, temp$
sep = InStr(temp$, ":")
l$ = _Trim$(Left$(temp$, sep - 1))
r$ = _Trim$(Mid$(temp$, sep + 1)) If l$ <> "PSPath"Then If l$ <> ""Then' skip the blank space lines
Fonts(count).Name = l$
Fonts(count).FileName = r$
count = count + 1 End If Else Exit Do' we can stop reading files at this point (according to my tests) End If Loop Close f Kill"temp_fontlist.txt"' clean up the file after we're done with parsing it.
count = count - 1' adjust for that last count + 1, which we didn't use. ReDim_Preserve Fonts(count) As Font_Name_Type
'a quick and simple combsort to make certain our list is in alphabetical order
gap = count Do
gap = 10 * gap \ 13 If gap < 1Then gap = 1
i = 0
swapped = 0 Do If Fonts(i).Name > Fonts(i + gap).NameThen Swap Fonts(i).Name, Fonts(i + gap).Name Swap Fonts(i).FileName, Fonts(i + gap).FileName
swapped = -1 End If
i = i + 1 Loop Until i + gap > count Loop Until gap = 1And swapped = 0 Else'very poor error handling here Print"Powershell failed to create font list." Beep Sleep Exit Sub End If End Sub
The above will generate, sort, and display a list of all the fonts which is installed on an user's Windows PC. This gives you both the font name and style (such as "Courier New Bold"), as well as the filename ("courbd.ttf", in this case).
(Code updated to the latest version in this thread, which should have fixes for terminal vs console, and also for too small of a console/terminal size.)
Here comes a CPU benchmark generating one picture with stats, screenshot-ready, hee-hee. Thus, every random machine can be evaluated.
Many times I need a tool reporting the transferring speed of uncached RAM and a metric for CPU's ability (across all cores) in supersimple integer calculations (inhere, factorizing numbers):
Code: (Select All)
for (i = 2; i <= n; i++) {
while (n % i == 0) {
n /= i;
}
}
Cannot resist the simplicity and throwing this two-level loop to all available threads. Since it doesn't stress caches and uncached RAM, it serves as the closest equivalent to getting the RAW and CUMULATIVE power of the CPU in "MHz" i.e. frequency department. Meaning, the resultant number represents the ability of CPU to ... loop.
The used number is 4*4096 numbers for factorization, my slowest laptop (4 threads) calculates them in ~4000 seconds whereas my fastest (8 threads) in ~2000 seconds, it might seem unnecessarily big but it is not since a formidable Threadripper has 128 threads, the benchmark has to cover it.
My laptop 'Djudjeto':
My laptop 'Dzvertcheto':
So, I wrote two console tools in C doing that, utilizing all the availble cores, they are invoked by QB64PE GUI and using the superb @OldMoses MagScope, the resultant lines are easily viewable - on any monitor (including 1366x768 modes).
All the sourcecodes are included into the attached package, even though it is fully portable, in reality it is effective/useful only in Linux environment, simply latest GCC and CLANG generated too far away from one another code. CLANG, being 2x faster, didn't dig what causes this huge gap...
Oh, since the BANDWIDTH reporter sums all the QWORDS within the memory block it is some ~2GB/s below the value reported by the AIDA's Memory Read, once I asked one of the authors of their benchmarks few things, he said that AIDA uses hand-written highly optimized Assembler. I chose different path, using C summing all the QWORDS with all the threads within AVX2 vectors, this makes it less synthetic and more reliable.
The benchmark uses 4GB and 6GB with Celeron and AVX2 capable CPUs, respectively. So, 8GB RAM are needed.
For a customer I have created a utility in QB64 (console-mode).
It's relatively small and simple (some REST calls via SHELL "wget ..." to update csv-files)
I develop everything on Windows 10 and use the latest QB64pe x64 3.12
Now it's finished and need to compile it for Mac-OS (customer uses macbooks everywhere)
Since I don't have a Mac, I use a VirtualBox with Mac Big Sur (11?) for some time now to compile my QB64 programs for a Mac.
This always worked, until now...
When tested by customer they see binary stuff scrolling by very fast in a terminal window; as if the executable is displayed instead of executed...
Since I know nothing about Mac, I don't know what goes wrong here.
Anyone?
