Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Topics - bplus

Pages: 1 [2] 3 4 ... 21

QB64 Discussion / February Number Challenge

« on: February 11, 2022, 02:14:18 pm »

I found this at Liberty Basic Forum (Feb 8) and so far nobody there has figured it out.

I just did but let's see if someone else can here at this forum:

tsh73

Quote

It is high-school test problem my kid got yesterday
I jumped in - but after getting something working... I Googled and it happened that I solved quite anoter task (Doh).

So here is it (Google-translated text, original is in Russian)
Let's call a nontrivial divisor of a natural number its divisor, which is not equal to one and the number itself. For example, the number 6 has two nontrivial divisors: 2 and 3. Find all natural numbers belonging to the segment [123456789; 223456789] and having exactly three nontrivial divisors. For each found number, write down its largest nontrivial divisor in the answer. Arrange the answers in ascending order.

Could you solve it without Google?

I couldn't solve it with Google only learned that non trivial divisor is not the same as a proper divisor.

I tried brute force but that was going to take hours, no there is a little thing you have to discover then easy as pie.

It's fine if your list the three divisors and the number between 123456789 and 223456789 more than one but not many.

Programs / p5js

« on: February 02, 2022, 03:04:32 pm »

Here is really nice set of tools Ashish and Fellippe setup some time ago. p5js is referred to allot and so I thought it would be good to post an updated set that works for QB64 v2+

@Qwerkey I recommend this QB64 Classic for the library.

Programs / Split Versus Tokenize

« on: February 01, 2022, 11:33:24 am »

https://qb64forum.alephc.xyz/index.php?topic=4618.msg140260#msg140260

Quote

I think my way of splitting a string into an array is slightly better:

I say Split has at least two advantages!
1. Less LOC
2. Preserves blank lines from a .bas file.

And I am pretty sure for small files there is no significant time differences, not even sure if Tokenize is faster and how big a file you need to see it. I leave that to believers of Tokenize. ;-))

Code: QB64: [Select]

_Title "Split versus Tokenize" ' b+ 2022-02-01
 
' Is Tokenize really worth the extra LOC compared to Split?
' No! if you want to preserve blank lines.
 
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
'            save this file as "Split versus Tokenize.bas"
 
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
Open "Split versus Tokenize.bas" For Binary As #1
buf$ = Space$(LOF(1))
 
Get #1, , buf$
 
Close #1
 
deli$ = Chr$(13) + Chr$(10)
 
ReDim LoadMe$(1 To 1)
 
startSplit = Timer(.001)
Split buf$, deli$, LoadMe$()
splitTime = Timer(.001) - startSplit
 
For i = LBound(LoadMe$) To 10
    Print i, LoadMe$(i)
Next
'For i = UBound(LoadMe$) - 5 To UBound(LoadMe$)
'    Print i, LoadMe$(i)
'Next
Print "Time for Split was:"; splitTime
 
' reset for tokenize
ReDim LoadMe$(1 To 1)
startTokenize = Timer(.001)
tokenize buf$, deli$, LoadMe$()
TokenizeTime = Timer(.001) - startTokenize
For i = LBound(LoadMe$) To 10
    Print i, LoadMe$(i)
Next
'For i = UBound(LoadMe$) - 5 To UBound(LoadMe$)
'    Print i, LoadMe$(i)
'Next
Print "Time for Tokenize was:"; TokenizeTime  ' << edit: had wrong variable in here
 
 
 
' note: I buggered this twice now, FOR base 1 array REDIM MyArray (1 to 1) AS ... the (1 to 1) is not same as (1) which was the Blunder!!!
'notes: REDIM the array(0) to be loaded before calling Split '<<<< IMPORTANT dynamic array and empty, can use any lbound though
'This SUB will take a given N delimited string, and delimiter$ and create an array of N+1 strings using the LBOUND of the given dynamic array to load.
'notes: the loadMeArray() needs to be dynamic string array and will not change the LBOUND of the array it is given.  rev 2019-08-27
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
    Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
    curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
    dpos = InStr(curpos, SplitMeString, delim)
    Do Until dpos = 0
        loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
        arrpos = arrpos + 1
        If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
        curpos = dpos + LD
        dpos = InStr(curpos, SplitMeString, delim)
    Loop
    loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
    ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End Sub
 
Sub tokenize (toTokenize As String, delimiters As String, StorageArray() As String)
    Declare CustomType Library
        Function strtok%& (ByVal str As _Offset, delimiters As String)
    End Declare
    Dim As _Offset tokenized
    Dim As String tokCopy: tokCopy = toTokenize + Chr$(0)
    Dim As String delCopy: delCopy = delimiters + Chr$(0)
    Dim As _Unsigned Long lowerbound: lowerbound = LBound(StorageArray)
    Dim As _Unsigned Long i: i = lowerbound
    tokenized = strtok(_Offset(tokCopy), delCopy)
    While tokenized <> 0
        ReDim _Preserve StorageArray(lowerbound To UBound(StorageArray) + 1)
        StorageArray(i) = pointerToString(tokenized)
        tokenized = strtok(0, delCopy)
        i = i + 1
    Wend
    ReDim _Preserve StorageArray(UBound(StorageArray) - 1)
End Sub
 
Function pointerToString$ (pointer As _Offset)
    Declare CustomType Library
        Function strlen%& (ByVal ptr As _Unsigned _Offset)
    End Declare
    Dim As _Offset length: length = strlen(pointer)
    If length Then
        Dim As _MEM pString: pString = _Mem(pointer, length)
        Dim As String ret: ret = Space$(length)
        _MemGet pString, pString.OFFSET, ret
        _MemFree pString
    End If
    pointerToString = ret
End Function
 
 
 

Edit: had wrong Time variable in showing Tokenize Time. Ha! I was wondering how they were coming exactly the same each time tested.

Programs / Quick Directory Files Listing for Windows Only

« on: January 31, 2022, 02:22:45 pm »

I thought I posted this already here at forum, maybe just Discord. I remember Spriggsy's help with Console use:

Code: QB64: [Select]

_Title "Quick Dir Listing Windows only" ' b+ 2022-01-19
 
Dim Shared tmpDir As String '  establish a permanent spot for temp files
If Environ$("TEMP") <> "" Then 'Thanks to Steve McNeill use user temp files directory
    tmpDir = Environ$("TEMP")
ElseIf Environ$("TMP") <> "" Then
    tmpDir = Environ$("TMP")
Else 'Thanks to Steve McNeill this should be very unlikely
    If _DirExists("C:\temp") Then Else MkDir "C:\temp"
    tmpDir = "C:\temp"
End If
 
' thanks Spriggsy   
$Console:Only
'$ScreenHide
'_Console On
'_Dest _Console
 
 
' assuming in th edirectory of interest otherwise chdir
ChDir ".." ' the above directory
 
ReDim fileList$(0) ' setup Dynamic Array to load into
loadFiles fileList$() ' get the files
 
' see what we caught
For i = 0 To UBound(fileList$) ' 0 item is always nothing so ubound of FileList$ = number of real files
    Print i, fileList$(i)
 
    ' from here you can weed out the files you dont want
 
Next
 
' nice simple little file catcher for Windows
Sub loadFiles (fa() As String)
    Dim tmpFile As String, Index%
    tmpFile = tmpDir + "\FILE$INF0.INF" 'aha!, not a fully pathed file to user directory but here is good!
 
    ' this sorts first by file extention then by filename
    Shell _Hide "DIR *.* /a:-d /b /o:-gen > " + tmpFile
    '*.* any name and extension
    '/b is bare list
    '/a:-d nodirectories
    '/o:-gen no directories, sort by extension then name
 
    Open tmpFile$ For Input As #1
    Do While Not EOF(1)
        Index% = Index% + 1
        ReDim _Preserve fa(Index%) As String
        Line Input #1, fa(Index%)
    Loop
    Close #1
    Kill tmpFile$
End Sub
 
 

No you don't have to use this code in Console, I just did because it scrolls back so you can read longer lists.
You just need the first block that sets up TempDir variable and the Sub LoadFiles. You can mod that for particular use, say just looking for .bas files change *.* to *.bas :)

EDIT: sorry I posted old copy before Spriggsy help

Programs / A Replacement Method for Data Statements

« on: January 31, 2022, 01:30:22 pm »

Welcome @MrGW454

I saw you difficulty on Discord, here is alternate to DATA statements

Code: QB64: [Select]

_Title "Replacement Method for Data statements" 'b+ 2022-01-31
 
'our Data as string(s)
dat$ = "bplus,SMcNeill,FellippeHeitor,vince,"
dat$ = dat$ + "Qwerkey,Ashish,Luke,RCcola87,MrGW454"
 
'Load into this array
ReDim members$(1 To 1) ' use REDIM for dynamic array that we can change size of
Split dat$, ",", members$() ' Load data into members$()
 
'Show it worked
For i = 1 To UBound(members$)
    Print members$(i)
Next
 
' note: I buggered this twice now, FOR base 1 array REDIM MyArray (1 to 1) AS ... the (1 to 1) is not same as (1) which was the Blunder!!!
'notes: REDIM the array(0) to be loaded before calling Split '<<<< IMPORTANT dynamic array and empty, can use any lbound though
'This SUB will take a given N delimited string, and delimiter$ and create an array of N+1 strings using the LBOUND of the given dynamic array to load.
'notes: the loadMeArray() needs to be dynamic string array and will not change the LBOUND of the array it is given.  rev 2019-08-27
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
    Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
    curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
    dpos = InStr(curpos, SplitMeString, delim)
    Do Until dpos = 0
        loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
        arrpos = arrpos + 1
        If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
        curpos = dpos + LD
        dpos = InStr(curpos, SplitMeString, delim)
    Loop
    loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
    ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End Sub
 
 

QB64 Discussion / How about dictating your QB64 Program?

« on: January 26, 2022, 02:33:51 pm »

I ran into this while looking for a sample of Text to Speech Sounds for Johnno.
https://www.google.com/search?client=opera&q=speech+to+text+windows+10+youtube&sourceid=opera&ie=UTF-8&oe=UTF-8#kpvalbx=_e6DxYYGYAcLB0PEP18ab4A013

Be cool if we could do this for coding! Then we might not need SpellChecker, but probably be likely we would be turning it off.

Programs / Passing Time

« on: January 23, 2022, 05:10:52 pm »

More fun with RotoZoom3

Code: QB64: [Select]

Option _Explicit
_Title "Does anyone really know what time it is?" ' b+ 2022-01-23
Type obj
    As Single X, Y, ScaleX, ScaleY, RotXY, DScaleX, DScaleY, DRotXY, ScaleLimit
End Type
 
Const SW = 1025, SH = 721, NClocks = 40
Screen _NewImage(SW, SH, 32)
_ScreenMove 150, 10
Randomize Timer
Dim Shared c&
Dim midP, i
c& = _NewImage(313, 313, 32)
_Dest c&
midP = Int((313 - 1) / 2)
clock midP, midP, 149
'Line (0, 0)-(311, 311), , B ' check centering
_Dest 0
_ClearColor &HFF000000, c&
Dim Shared Clocks(1 To NClocks) As obj
For i = 1 To NClocks
    newClock i, 1
Next
Do
    Cls
    _Title "Does anyone really know what time it is? Sure " + Time$
    _Dest c&
    Line (0, 0)-(311, 311), &HFF000000, BF ' blank out fro redraw
    midP = Int((313 - 1) / 2)
    clock midP, midP, 149
    _Dest 0
    _ClearColor &HFF000000, c&
    For i = 1 To NClocks
        RotoZoom3 Clocks(i).X, Clocks(i).Y, c&, Clocks(i).ScaleX, Clocks(i).ScaleY, Clocks(i).RotXY
        Clocks(i).Y = Clocks(i).Y + 1
        If Clocks(i).Y > _Height + 150 Then
            newClock i, 0
        Else
            'updates
            Clocks(i).ScaleX = Clocks(i).ScaleX + Clocks(i).DScaleX
            If Clocks(i).ScaleX < -Clocks(i).ScaleLimit Then Clocks(i).DScaleX = -Clocks(i).DScaleX: Clocks(i).ScaleX = -Clocks(i).ScaleLimit
            If Clocks(i).ScaleX > Clocks(i).ScaleLimit Then Clocks(i).DScaleX = -Clocks(i).DScaleX: Clocks(i).ScaleX = Clocks(i).ScaleLimit
            Clocks(i).ScaleY = Clocks(i).ScaleY + Clocks(i).DScaleY
            If Clocks(i).ScaleY < -Clocks(i).ScaleLimit Then Clocks(i).DScaleY = -Clocks(i).DScaleY: Clocks(i).ScaleY = -Clocks(i).ScaleLimit
            If Clocks(i).ScaleY > Clocks(i).ScaleLimit Then Clocks(i).DScaleY = -Clocks(i).DScaleY: Clocks(i).ScaleY = Clocks(i).ScaleLimit
            Clocks(i).RotXY = Clocks(i).RotXY + Clocks(i).DRotXY
        End If
    Next
    _Display
    _Limit 60
Loop Until _KeyDown(27)
 
Sub newClock (i, initTF)
    Clocks(i).X = Rnd * SW
    If initTF Then Clocks(i).Y = rrnd(-150, SH) Else Clocks(i).Y = -150
    Clocks(i).ScaleLimit = 1
    Clocks(i).ScaleX = rrnd(-Clocks(i).ScaleLimit, Clocks(i).ScaleLimit)
    Clocks(i).ScaleY = rrnd(-Clocks(i).ScaleLimit, Clocks(i).ScaleLimit)
    Clocks(i).DScaleX = rrnd(-.005 * Clocks(i).ScaleLimit, .005 * Clocks(i).ScaleLimit)
    Clocks(i).DScaleY = rrnd(-.005 * Clocks(i).ScaleLimit, .005 * Clocks(i).ScaleLimit)
    Clocks(i).RotXY = _Pi(2) * Rnd
    Clocks(i).DRotXY = rrnd(-.005 * _Pi, .005 * _Pi)
End Sub
 
Sub clock (x, y, r)
    Dim a, r1, hrs
    For a = 0 To 359 Step 6
        If a Mod 30 = 0 Then r1 = 1 / 30 * r Else r1 = 1 / 75 * r
        Circle (x + r * Cos(_D2R(a)), y + r * Sin(_D2R(a))), r1
        Paint (x + r * Cos(_D2R(a)), y + r * Sin(_D2R(a))), _RGB32(100, 100, 100), _RGB32(255, 255, 255)
    Next
    If Val(Left$(Time$, 2)) + (Val(Mid$(Time$, 4, 2)) / 60) >= 12 Then hrs = Val(Left$(Time$, 2)) + (Val(Mid$(Time$, 4, 2)) / 60) - 12 Else hrs = Val(Left$(Time$, 2)) + (Val(Mid$(Time$, 4, 2)) / 60)
    ftri0 x + 1 / 15 * r * Cos(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2) + _Pi(1 / 2)), y + 1 / 15 * r * Sin(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2) + _Pi(1 / 2)), x + 1 / 15 * r * Cos(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2) - _Pi(1 / 2)), y + 1 / 15 * r * Sin(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2) - _Pi(1 / 2)), x + r * Cos(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2)), y + r * Sin(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2)), _RGB32(255, 0, 0)
    ftri0 x + 1 / 10 * r * Cos(hrs * _Pi(1 / 6) - _Pi(1 / 2) + _Pi(1 / 2)), y + 1 / 10 * r * Sin(hrs * _Pi(1 / 6) - _Pi(1 / 2) + _Pi(1 / 2)), x + 1 / 10 * r * Cos(hrs * _Pi(1 / 6) - _Pi(1 / 2) - _Pi(1 / 2)), y + 1 / 10 * r * Sin(hrs * _Pi(1 / 6) - _Pi(1 / 2) - _Pi(1 / 2)), x + 2 / 3 * r * Cos(hrs * _Pi(1 / 6) - _Pi(1 / 2)), y + 2 / 3 * r * Sin(hrs * _Pi(1 / 6) - _Pi(1 / 2)), _RGB32(0, 0, 255)
    Line (x, y)-(x + r * Cos(Val(Right$(Time$, 2)) * _Pi(1 / 30) - _Pi(1 / 2)), y + r * Sin(Val(Right$(Time$, 2)) * _Pi(1 / 30) - _Pi(1 / 2))), _RGB32(255, 255, 0)
    Circle (x, y), 1 / 10 * r, _RGB32(255, 255, 255)
    Paint (x + 1 / 75 * r, y + 1 / 75 * r), _RGB32(100, 100, 100), _RGB32(255, 255, 255)
    Circle (x, y), 1 / 30 * r, _RGB32(0, 0, 0)
End Sub
 
Sub ftri0 (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim D As Long, a&
    D = _Dest
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest D
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub
 
Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single) ' 0 at end means no scaling of x or y
    Dim px(3) As Single: Dim py(3) As Single
    Dim W&, H&, sinr!, cosr!, i&, x2&, 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(-radianRotation): cosr! = Cos(-radianRotation)
    For i& = 0 To 3
        x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y
        px(i&) = x2&: py(i&) = y2&
    Next
    _MapTriangle _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle _Seamless(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
 
Function rrnd (n1, n2) 'return real number (_single, double, _float depending on default / define setup)
    rrnd = (n2 - n1) * Rnd + n1
End Function
 
 

Programs / Playing with fire (again)

« on: January 17, 2022, 10:31:44 pm »

Quote

bplus is into letters now instead of graphics, sad times

OK @_vince maybe this will cheer your up. ;-))

Code: QB64: [Select]

_Title "Jolly Roger on Fire" 'b+ 2022-01-17
 
Const xmax = 500, ymax = 400
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 160
 
Dim p&(300) 'pallette
For i = 1 To 100
    fr = 240 * i / 100 + 15
    p&(i) = _RGB(fr, 0, 0)
    p&(i + 100) = _RGB(255, fr, 0)
    p&(i + 200) = _RGB(255, 255, fr)
Next
w~& = _RGB32(255)
jr& = _LoadImage("Jolly Roger.png") '
_PutImage , jr&, 0
xxmax = 500: yymax = 200 'pixels too slow
xstep = xmax / xxmax: ystep = ymax / yymax
Dim f(xxmax, yymax), ff(xxmax, yymax) 'fire array and seed
For y = 0 To yymax - 1
    For x = 0 To xxmax - 1
        If Point(x * xstep, y * ystep) = w~& Then f(x, y) = 300: ff(x, y) = 300
    Next
Next
 
While 1 'main fire
    Cls
    For y = 1 To yymax - 1
        For x = 1 To xxmax - 1 'shift fire seed a bit
            r = Rnd
            If r > .9 Then f(x, y) = ff(x, y)
        Next
    Next
    For y = 0 To yymax - 2 'fire based literally on 4 pixels below it like cellular automata
        For x = 1 To xxmax - 1
            f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)
            Line (x * xstep, y * ystep)-Step(xstep, ystep), p&(f(x, y)), BF
        Next
    Next
    _Display
    _Limit 30
Wend
 
Function max (a, b)
    If a > b Then max = a Else max = b
End Function
 
 

And this might look familiar:

Code: QB64: [Select]

Option _Explicit
_Title "Jolly Roger on Fire: try spacebar" 'b+ 2022-01-17
DefLng A-Z
Const sw = 700, sh = 500, fw = 600, fh = 400
Screen _NewImage(sw, sh, 32)
_ScreenMove 230, 60
Dim i, fr, w~&, jr, img, xxmax, yymax, xstep, ystep, x, y, a, x0, y0, r!
Dim p(300) 'pallette
For i = 1 To 100
    fr = 240 * i / 100 + 15
    p(i) = _RGB(fr, 0, 0)
    p(i + 100) = _RGB(255, fr, 0)
    p(i + 200) = _RGB(255, 255, fr)
Next
w~& = _RGB32(255)
jr = _LoadImage("Jolly Roger.png")
 
img = _NewImage(fw, fh, 32)
_PutImage , jr&, img
xxmax = fh: yymax = 200
xstep = fw / xxmax: ystep = fh / yymax
Dim f(xxmax, yymax), ff(xxmax, yymax) 'fire array and seed
_Source img
For y = 0 To yymax - 1
    For x = 0 To xxmax - 1
        If Point(x * xstep, y * ystep) = w~& Then f(x, y) = 300: ff(x, y) = 300
    Next
Next
 
' from _vince flag wave
a = fh / 20
x0 = (sw - fw) / 2 'center flag on screen top left corner
y0 = (sh - fh) / 2
 
Dim r, g, b, toggle
Dim As Double t, z, xx, yy, dx, dy, dz
Dim As _Unsigned Long tl, tr, bl, br
Color , &HFF9999BB
Do
    If InKey$ = " " Then toggle = 1 - toggle
    ' update the img
    _Dest img
    If toggle Then Line (0, 0)-(fw, fh), &HFF000000, BF Else _PutImage , jr&, img ' blank out image or not either way is interesting
    For y = 1 To yymax - 1
        For x = 1 To xxmax - 1 'refuel fire seed
            r! = Rnd
            If r! > .7 Then f(x, y) = ff(x, y)
        Next
    Next
    For y = 0 To yymax - 2 'fire based literally on 4 pixels below it like cellular automata
        For x = 1 To xxmax - 1
            f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)
            Line (x * xstep, y * ystep)-Step(xstep, ystep), p&(f(x, y)), BF
        Next
    Next
    _Dest 0
    'source is still img
    t = t + 0.2
    Cls
    For y = 0 To fh + a * 0.707 Step 1
        For x = 0 To fw + a * 0.707 Step 1
            z = (0.1 + 0.4 * (x / fw)) * a * Sin(x / 35 - y / 70 - t) + 0.5 * a
            dz = 50 * a * Cos(x / 35 - y / 70 - t) / 35
 
            xx = x + z * 0.707 - a * 0.707
            yy = y - z * 0.707
 
            If (Int(xx) >= 0 And Int(xx) < fw - 1 And Int(yy) >= 0 And Int(yy) < fh - 1) Then
                tl = Point(Int(xx), Int(yy))
                tr = Point(Int(xx) + 1, Int(yy))
                bl = Point(Int(xx), Int(yy) + 1)
                br = Point(Int(xx) + 1, Int(yy) + 1)
 
                dx = xx - Int(xx)
                dy = yy - Int(yy)
 
                r = _Round((1 - dy) * ((1 - dx) * _Red(tl) + dx * _Red(tr)) + dy * ((1 - dx) * _Red(bl) + dx * _Red(br)))
                g = _Round((1 - dy) * ((1 - dx) * _Green(tl) + dx * _Green(tr)) + dy * ((1 - dx) * _Green(bl) + dx * _Green(br)))
                b = _Round((1 - dy) * ((1 - dx) * _Blue(tl) + dx * _Blue(tr)) + dy * ((1 - dx) * _Blue(bl) + dx * _Blue(br)))
 
                r = r + dz
                g = g + dz
                b = b + dz
 
                If r < 0 Then r = 0
                If r > 255 Then r = 255
                If g < 0 Then g = 0
                If g > 255 Then g = 255
                If b < 0 Then b = 0
                If b > 255 Then b = 255
                PSet (x0 + x, y0 - a * 0.707 + y), _RGB(r, g, b)
            End If
        Next
    Next
    Line (0, 0)-(x0 + 15, y0 - 4), &HFF000000
    Line (0, 1)-(x0 + 15, y0 - 3), &HFF000000
    Line (20, sh)-(x0 + 10, y0 - 9 + fh), &HFF000000
    Line (20, sh + 1)-(x0 + 10, y0 - 9 + fh + 1), &HFF000000
    _Display
    _Limit 50
Loop Until _KeyHit = 27
 
Function max (a, b)
    If a > b Then max = a Else max = b
End Function
 
 

Zip with bas sources and image

Programs / Boggle play against AI - WIP

« on: January 13, 2022, 11:46:33 am »

https://en.wikipedia.org/wiki/Boggle

The AI is going to be handicapped starting with only 1 point words (3 or 4 letters words from Scrabble Dictionary that don't use Q (that is 2 points)) and maybe a shorter time limit too.

Just got started last night from trying to figure out Dimster's "Babble" Game, I thought he might mean Boggle?

Any way got a board working:

Code: QB64: [Select]

Option _Explicit
_Title "Boggle 1" ' b+ start 2022-01-12
' Scabble Word List and Dictionary
' ref dictionary: https://boardgames.stackexchange.com/questions/38366/latest-collins-scrabble-words-list-in-text-file
' Die configurations
' https://boardgames.stackexchange.com/questions/29264/boggle-what-is-the-dice-configuration-for-boggle-in-various-languages
' Thank you!
 
Randomize Timer
Dim Shared Board$(3, 3)
Dim Shared As Long f48, f30, dx(7), dy(7)
Screen _NewImage(800, 600, 32)
_ScreenMove 200, 100
_PrintMode _KeepBackground
Do
    Cls
    NewBoard
    ' display timer and allow input of words from user for 3 minutes
    ' meanwhile AI will calc all the 1 point words it can from board
 
    Sleep
Loop
 
Sub NewBoard
    Static BeenHere, Di$(), Numbers()
    Dim As Long i, r, c, row, col
    If BeenHere = 0 Then 'load and initialize
        f48 = _LoadFont("Arial.ttf", 48, "MONOSPACE")
        f30 = _LoadFont("Arial.ttf", 30, "MONOSPACE")
        If f48 <= 0 Then Print "Sub NewBoard: Font did not load, goodbye.": End
        dx(0) = -1: dy(0) = -1 ' this is for AI to find words
        dx(1) = 0: dy(1) = -1
        dx(2) = 1: dy(2) = -1
        dx(3) = -1: dy(3) = 0
        dx(4) = 1: dy(4) = 0
        dx(5) = -1: dy(5) = 1
        dx(6) = 0: dy(6) = 1
        dx(7) = 1: dy(7) = 1
        Dim Di$(0 To 15) ' this for 16 di, 6 letters per
        Di$(1) = "RIFOBX"
        Di$(2) = "IFEHEY"
        Di$(3) = "DENOWS"
        Di$(4) = "UTOKND"
        Di$(5) = "HMSRAO"
        Di$(6) = "LUPETS"
        Di$(7) = "ACITOA"
        Di$(8) = "YLGKUE"
        Di$(9) = "QBMJOA"
        Di$(10) = "EHISPN"
        Di$(11) = "VETIGN"
        Di$(12) = "BALIYT"
        Di$(13) = "EZAVND"
        Di$(14) = "RALESC"
        Di$(15) = "UWILRG"
        Di$(0) = "PACEMD"
        Dim Numbers(0 To 15) ' for shuffling die order
        For i = 0 To 15
            Numbers(i) = i
        Next
        BeenHere = -1
    End If
    For i = 15 To 1 Step -1 'shuffle die
        Swap Numbers(i), Numbers(Int(Rnd * (i + 1)))
    Next
    'For i = 1 To 16: Print Numbers(i);: Next: Print   ' check the shuffle
    For i = 0 To 15 'choosing random face of die = 1 Letter
        Index2ColRow i, c, r
        Board$(c, r) = Mid$(Di$(Numbers(i)), Int(Rnd * 6) + 1, 1)
    Next
    _Font f48
    For row = 0 To 3 '  display the board
        For col = 0 To 3
            Line ((col + 1) * 60 - 5, (row + 1) * 60 - 5)-Step(54, 54), &HFF2020FF, BF 'face color or die
            If Board$(col, row) = "Q" Then 'If face has a Q it is supposed to be "Qu"
                _Font f30
                Color &HFF661111 'shade
                _PrintString ((col + 1) * 60 - 4, (row + 1) * 60 + 11), "Q"
                _PrintString ((col + 1) * 60 + 24, (row + 1) * 60 + 11), "U"
                Color &HFFBBBBBB 'letter
                _PrintString ((col + 1) * 60 - 7, (row + 1) * 60 + 9), "Q"
                _PrintString ((col + 1) * 60 + 22, (row + 1) * 60 + 9), "U"
                _Font f48
            Else
                Color &HFF661111 'shade
                _PrintString ((col + 1) * 60 + 2, (row + 1) * 60 + 2), Board$(col, row)
                Color &HFFBBBBBB 'letter
                _PrintString ((col + 1) * 60, (row + 1) * 60), Board$(col, row)
            End If
        Next
    Next
    _Font 16
End Sub
 
Function ColRow2Index& (row As Long, col As Long) ' convert a board letter to index (not needed yet?)
    ColRow2Index& = row * 4 + col
End Function
Sub Index2ColRow (indexIn As Long, rowOut As Long, colOut As Long) 'convert die index to board col, row
    colOut = indexIn Mod 4: rowOut = indexIn \ 4
End Sub
 

Programs / Read & Print the Type from your bas source

« on: January 09, 2022, 04:45:11 pm »

Proof of concept, proved!

Code: QB64: [Select]

_Title "Read Type test" 'b+ 2022-01-09
 
Type ButtonData
    Caption As String
    Department As String
    Group As String
    Price As Integer
    TaxRate As Integer
    Printer As Integer
    Colour_Red As Integer
    Colour_Green As Integer
    Colour_Blue As Integer
End Type
 
Print myType$("Read Type test.bas")
 
 
Function myType$ (file$) ' for proof of concept assuming one type to get
    If _FileExists(file$) Then
        Open file$ For Input As #1
        While Not EOF(1)
            Line Input #1, fl$
            If Left$(fl$, 4) = "Type" Then
                While Left$(fl$, 8) <> "End Type"
                    Line Input #1, fl$
                    If b$ = "" Then
                        b$ = _Trim$(Mid$(fl$, 1, InStr(fl$, " A"))) ' hmmm does trim$ do tabs?
                    Else
                        b$ = b$ + Chr$(10) + _Trim$(Mid$(fl$, 1, InStr(fl$, " A")))
                    End If
                Wend
                myType$ = b$
                Close #1
                Exit Function
            End If
        Wend
    End If
End Function
 

Remember to save this to disk before trying.

edit: add close #1
edit: exit function when you got what you came for

Programs / TriQuad Puzzle inspired by Rick3137

« on: January 09, 2022, 04:14:29 pm »

Welcome @Rick3137

Remember this (over 4 years ago)?

Code: QB64: [Select]

Option _Explicit
_Title "TriQuad Puzzle" 'B+ start 2019-07-17 trans to QB64 from:
' TriQuad.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-03-26
' inspired by rick3137's recent post at Naalaa of cute puzzle
' 2019-07 Complete remake for N X N puzzles, not just 3 X 3's.
' post at QB64 forum 2019-10-14
 
Randomize Timer
 
Const xmax = 1000, margin = 50 'screen size, margin that should allow a line above and below the puzzle display
Const topLeftB1X = margin, topLeftB2X = xmax / 2 + .5 * margin, topY = margin
 
'these have to be decided from user input from Intro screen
Dim Shared ymax, N, Nm1, NxNm1, sq, sq2, sq4
ymax = 500 'for starters in intro screen have resizing in pixels including ymax
 
ReDim Shared B1(2, 2), B2(2, 2) ' B1() box container for scrambled pieces of C(), B2 box container to build solution
ReDim Shared C(8, 3) '9 squares 4 colored triangles, C() contains the solution as created by code, may not be the only one!
 
Dim mx, my, mb, bx, by, holdF, ky As String, again As String
 
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 40
intro
restart:
assignColors
holdF = N * N
While 1
    Cls
    showB (1)
    showB (2)
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    If mb Then
        Do While mb
            While _MouseInput: Wend
            mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
        Loop
        If topY <= my And my <= topY + N * sq Then
            by = Int((my - topY) / sq)
            If topLeftB1X <= mx And mx <= topLeftB1X + N * sq Then 'mx in b1
                bx = Int((mx - topLeftB1X) / sq)
                If holdF < N * N Then 'trying to put the piece on hold here?
                    If B1(bx, by) = N * N Then
                        B1(bx, by) = holdF: holdF = N * N
                    End If
                ElseIf holdF = N * N Then
                    If B1(bx, by) < N * N Then
                        holdF = B1(bx, by): B1(bx, by) = N * N
                    End If
                End If
            ElseIf topLeftB2X <= mx And mx <= topLeftB2X + N * sq Then 'mx in b2
                bx = Int((mx - topLeftB2X) / sq)
                If holdF < N * N Then
                    If B2(bx, by) = N * N Then
                        B2(bx, by) = holdF: holdF = N * N
                    End If
                ElseIf holdF = N * N Then
                    If B2(bx, by) < N * N Then
                        holdF = B2(bx, by): B2(bx, by) = N * N
                    End If
                End If 'my out of range
            End If
        End If
    End If
    If solved Then
        Color hue(9)
        Locate 2, 1: centerPrint "Congratulations puzzle solved!"
        _Display
        _Delay 3
        Exit While
    End If
    ky = InKey$
    If Len(ky) Then
        If ky = "q" Then
            showSolution
            Color hue(9)
            Locate 2, 1: centerPrint "Here is solution (for 10 secs), Goodbye!"
            _Display
            _Delay 10
            System
        End If
    End If
    _Display
    _Limit 100
Wend
Color hue(9): Locate 2, 1: centerPrint Space$(50): Locate 2, 1
centerPrint "Press enter to play again, any + enter ends... "
_Display
again = InKey$
While Len(again) = 0: again = InKey$: _Limit 200: Wend
If Asc(again) = 13 Then GoTo restart Else System
 
Function solved
    'since it is possible that a different tile combination could be a valid solution we have to check points
    Dim x, y
    'first check that there is a puzzle piece in every slot of b2
    For y = 0 To Nm1
        For x = 0 To Nm1
            If B2(x, y) = N * N Then Exit Function
        Next
    Next
    'check left and right triangle matches in b2
    For y = 0 To Nm1
        For x = 0 To Nm1 - 1
            If Point(topLeftB2X + x * sq + sq2 + sq4, topY + y * sq + sq2) <> Point(topLeftB2X + (x + 1) * sq + sq4, topY + y * sq + sq2) Then Exit Function
        Next
    Next
    'check to and bottom triangle matches in b2
    For y = 0 To Nm1 - 1
        For x = 0 To Nm1
            'the color of tri4 in piece below = color tri1 of piece above
            If Point(topLeftB2X + x * sq + sq2, topY + y * sq + sq2 + sq4) <> Point(topLeftB2X + x * sq + sq2, topY + (y + 1) * sq + sq4) Then Exit Function
        Next
    Next
    'if made it this far then solved
    solved = -1
End Function
 
Sub showSolution
    Dim x, y, index
    For y = 0 To Nm1
        For x = 0 To Nm1
            drawSquare index, x * sq + topLeftB2X, y * sq + topY
            index = index + 1
        Next
    Next
End Sub
 
Sub showB (board)
    Dim x, y, index
    For y = 0 To Nm1
        For x = 0 To Nm1
            If board = 1 Then
                index = B1(x, y)
                drawSquare index, x * sq + topLeftB1X, y * sq + topY
            Else
                index = B2(x, y)
                drawSquare index, x * sq + topLeftB2X, y * sq + topY
            End If
        Next
    Next
End Sub
 
Sub drawSquare (index, x, y)
    Line (x, y)-Step(sq, sq), &HFF000000, BF
    Line (x, y)-Step(sq, sq), &HFFFFFFFF, B
    If index < N * N Then
        Line (x, y)-Step(sq, sq), &HFFFFFFFF
        Line (x + sq, y)-Step(-sq, sq), &HFFFFFFFF
        Paint (x + sq2 + sq4, y + sq2), hue(C(index, 0)), &HFFFFFFFF
        Paint (x + sq2, y + sq2 + sq4), hue(C(index, 1)), &HFFFFFFFF
        Paint (x + sq4, y + sq2), hue(C(index, 2)), &HFFFFFFFF
        Paint (x + sq2, y + sq4), hue(C(index, 3)), &HFFFFFFFF
    End If
End Sub
 
Sub assignColors ()
    'the pieces are indexed 0 to N X N -1  (NxNm1)
    ' y(index) = int(index/N) : x(index) = index mod N
    ' index(x, y) = (y - 1) * N + x
 
    Dim i, j, x, y
    'first assign a random color rc to every triangle
    For i = 0 To NxNm1 'piece index
        For j = 0 To 3 'tri color index for piece
            C(i, j) = rand(1, 9)
        Next
    Next
    'next match c0 to c3 of square to right
    For y = 0 To Nm1
        For x = 0 To Nm1 - 1
            'the color of tri3 of next square piece to right = color of tri0 to left of it
            C(y * N + x + 1, 2) = C(y * N + x, 0)
        Next
    Next
    For y = 0 To Nm1 - 1
        For x = 0 To Nm1
            'the color of tri4 in piece below = color tri1 of piece above
            C((y + 1) * N + x, 3) = C(y * N + x, 1)
        Next
    Next
 
    ' C() now contains one solution for puzzle, may not be the only one
 
    ' scramble pieces to box1
    Dim t(0 To NxNm1), index 'temp array
    For i = 0 To NxNm1: t(i) = i: Next
    For i = NxNm1 To 1 Step -1: Swap t(i), t(rand(0, i)): Next
    For y = 0 To Nm1
        For x = 0 To Nm1
            B1(x, y) = t(index)
            index = index + 1
            B2(x, y) = N * N
            'PRINT B1(x, y), B2(x, y)
        Next
    Next
End Sub
 
Function hue~& (n)
    Select Case n
        Case 0: hue~& = &HFF000000
        Case 1: hue~& = &HFFA80062
        Case 2: hue~& = &HFF000050
        Case 3: hue~& = &HFFE3333C
        Case 4: hue~& = &HFFFF0000
        Case 5: hue~& = &HFF008000
        Case 6: hue~& = &HFF0000FF
        Case 7: hue~& = &HFFFF64FF
        Case 8: hue~& = &HFFFFFF00
        Case 9: hue~& = &HFF00EEEE
        Case 10: hue~& = &HFF663311
    End Select
End Function
 
Function rand% (n1, n2)
    Dim hi, lo
    If n1 > n2 Then hi = n1: lo = n2 Else hi = n2: lo = n1
    rand% = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function
 
Sub intro 'use intro to select number of pieces
    Dim test As Integer
    Cls: Color hue(8): Locate 3, 1
    centerPrint "TriQuad Instructions:": Print: Color hue(9)
    centerPrint "This puzzle has two boxes that contain up to N x N square pieces of 4 colored triangles."
    centerPrint "The object is to match up the triangle edges from left Box to fill the Box on the right.": Print
    centerPrint "You may move any square piece to an empty space on either board by:"
    centerPrint "1st clicking the piece to disappear it,"
    centerPrint "then clicking any empty space for it to reappear.": Print
    centerPrint "You may press q to quit and see the solution displayed.": Print
    centerPrint "Hint: the colors without matching"
    centerPrint "complement, are edge pieces.": Print
    centerPrint "Good luck!": Color hue(5)
    Locate CsrLin + 2, 1: centerPrint "Press number key for square pieces per side (3 to 9, 1 to quit)..."
    While test < 3 Or test > 9
        test = Val(InKey$)
        If test = 1 Then System
    Wend
    N = test ' pieces per side of 2 boards
    Nm1 = N - 1 ' FOR loops
    NxNm1 = N * N - 1 ' FOR loop of piece index
    'sizing
    sq = (xmax / 2 - 1.5 * margin) / N 'square piece side size
    sq2 = sq / 2: sq4 = sq / 4
    ymax = sq * N + 2 * margin
    ReDim B1(Nm1, Nm1), B2(Nm1, Nm1), C(NxNm1, 3)
    Screen _NewImage(xmax, ymax, 32)
    '_SCREENMOVE 300, 40    'need again?
    'PRINT ymax
End Sub
 
Sub centerPrint (s$)
    Locate CsrLin, (xmax / 8 - Len(s$)) / 2: Print s$
End Sub
 

Quote

Sub intro 'use intro to select number of pieces
Dim test As Integer
Cls: Color hue(8): Locate 3, 1
centerPrint "TriQuad Instructions:": Print: Color hue(9)
centerPrint "This puzzle has two boxes that contain up to N x N square pieces of 4 colored triangles."
centerPrint "The object is to match up the triangle edges from left Box to fill the Box on the right.": Print
centerPrint "You may move any square piece to an empty space on either board by:"
centerPrint "1st clicking the piece to disappear it,"
centerPrint "then clicking any empty space for it to reappear.": Print
centerPrint "You may press q to quit and see the solution displayed.": Print
centerPrint "Hint: the colors without matching"
centerPrint "complement, are edge pieces.": Print
centerPrint "Good luck!": Color hue(5)

Programs / Wordle - a new word game

« on: January 07, 2022, 11:48:47 pm »

Pretty easy to figure out, read title bar for instructions:

Code: QB64: [Select]

_Title "Wordle: 6 guesses to get 5 letter word, enter guess or nothing to quit, yellow is right letter wrong place, green is right letter right place."
Randomize Timer ' b+ 20220107
f& = _LoadFont("arial.ttf", 24, "MONOSPACE")
Screen _NewImage(1024, 600, 32)
_ScreenMove 100, 100
Color _RGB32(200, 200, 200), _RGB32(0, 0, 0)
Do ' again new round
    Cls
    Open "5 Letter Words.txt" For Input As #1 'grab a word, this is fast enough
    nWord = Int(Rnd * 2104) + 1
    For i = 1 To nWord
        Input #1, w$
    Next
    Close #1
    'Locate 20, 60: Print w$ ' for debug or cheat
    printRow = 0
    For i = 1 To 6 ' allowed 6 guesses
        hits = 0 ' how many letters are dead right?
        tryAgain: ' opps too many or few letters in guess
        printRow = printRow + 1 ' track left print line for inputs mostly
        Locate printRow, 1: Print " "; _Trim$(Str$(i)); "# ";
        Input "Enter a 5 letter word for your guess "; guess$
        If guess$ = "" Then System
        If Len(guess$) <> 5 Then Sound 50, 4: printRow = printRow + 1: Print "Try again": GoTo tryAgain
        _Font f&
        For letter = 1 To 5
            Locate i, letter + 30
            If Mid$(w$, letter, 1) = Mid$(guess$, letter, 1) Then
                hits = hits + 1
                Color _RGB32(0, 0, 0), _RGB32(0, 128, 0)
            ElseIf InStr(w$, Mid$(guess$, letter, 1)) Then
                Color _RGB32(0, 0, 0), _RGB32(255, 255, 0)
            Else
                Color _RGB32(200, 200, 200), _RGB32(0, 0, 0)
            End If
            Print Mid$(guess$, letter, 1)
        Next
        _Font 16
        Color _RGB32(200, 200, 200), _RGB32(0, 0, 0)
        If hits = 5 Then Locate printRow + 1: Print "You got it!": _Delay 3: GoTo skip
    Next
    Sound 50, 4
    printRow = printRow + 2
    Locate printRow, 1: Print "The word was "; w$
    _Delay 3
    skip:
Loop
 

The zip contains source, exe for Windows, 2 word files and the code to convert one to "5 Letter Words.txt" file.

Programs / Custom Edit Image, Save and Load with Turkey Hunt WIP Game

« on: December 30, 2021, 02:45:44 pm »

OK here's the story I started translating this guys tutorial for beginner Blitzmax here:
https://www.syntaxbomb.com/tutorials/learning-basic-for-total-beginners-blitzmax-ng/msg347053898/#msg347053898

Blitzmax code:

Code: [Select]

SuperStrict
Graphics 800,600
Global Land:TImage    = LoadImage("land.png")
Global Chicken:TImage = LoadImage("chicken.png")
Global Shot:TSound=LoadSound("fire.ogg")
Global cX:Int, cY:Int=300
Global mX:Int, mY:Int
Global Points:Int
Repeat
        Cls
        DrawImage Land    , 0 , 0
        'DrawImage Chicken , cX , cY
        '   comment out the original command, and use DrawRect instead:
        SetColor 111,0,0
        DrawRect cX, cY, 60,40
        cX = cX +2
        If GunFire() =True Then
                cX=-100
                Points=Points+1
        EndIf
        SetColor 255,255,255
        DrawRect mX-25, mY-1,50,3
        DrawRect mX-1, mY-25,3,50
        'HideMouse
        DrawText "Points: " + points, 700,550
        Flip
Until AppTerminate()
ShowMouse
 
 
Function GunFire:Int()
        mX=MouseX()
        mY=MouseY()    
        If MouseHit(1)
                PlaySound Shot
                If (mX>cX) And (mx<cX+60)
                        If (mY>cY) And (mY<cY+40)
                                ' collision
                                Return True
                        EndIf
                EndIf
        EndIf
        Return False
End Function

But the code didn't come with a chicken image so I thought I'd reuse the Turkey Cartoon from Turkey Run from Thanksgiving ie Turkey Day

OK but now the Turkey's background isn't working with the background for the Hunt. (I just used white to hide the turkey background mostly white in image in Turkey Day.)

So like Colonel Panic here: https://qb64forum.alephc.xyz/index.php?topic=4539.0
I got interested in custom editing and saving and loading a modified image.

So I reworked SMcNeill's quick demo for any image not just the screen got it working without _defalte$ _inflate with this code:

Code: QB64: [Select]

Option _Explicit
_Title "Edit image test" 'b+ 2021-12-29 sure would like to take an image and the subject wo background colors
' from  C:\Users\marka\Desktop\QB64 work\000 work QB64\000 Test\More Saving Images
' file "Fast Image Save and Load.bas" by SMcNeill 2021-12-07
 
 
''Scn& = _NewImage(800, 600, 32)  'should not need these 2 lines if loadimage with 32
''Screen Scn&
Dim image&: image& = _LoadImage("turkey run.jpg", 32) ' <<<<<<<<<<<<<<<<< Edit Image file name
''Print image& ' OK -12   guess I forgot to save file before trying so in QB64 folder instead of project folder
''Sleep
 
Dim Scn&: Scn& = _NewImage(_Width(image&), _Height(image&), 32)
Screen Scn&
_Source image& ' for using Point from image
 
''_ClearColor Point(10, 10), image&  ' testing a know background point to make transparent
''_PutImage , image&, 0 '
''Print "Paint test, press any... ": Sleep
''_PutImage , image&, 0 '
''Paint (10, 10), &HFFFFFFFF, &HFF000000 ' nope "turkey run.jpg" has no pure black border enclosing the image
''End
 
Dim mx, my, outRed, outGrn, outBlu, outAlp, x, y
Do
    Cls ' must clear screen to see what was cleared from image if anything
    _PutImage , image&, 0 '
    While _MouseInput: Wend ' poll mouse to show me where I am at
    mx = _MouseX: my = _MouseY
    Line (mx - 3, my - 3)-(mx + 3, my + 3), , B ' eraser block  black & white frame around eraser
    Line (mx - 4, my - 4)-(mx + 4, my + 4), &HFF000000, B ' eraser block
    cAnalysis Point(mx, my), outRed, outGrn, outBlu, outAlp
    Locate 1, 1: Print Space$((_Width - 1) / 8)
    Locate 1, 1: Print outRed; outGrn; outBlu; outAlp
    If _MouseButton(1) Then
        For y = my - 2 To my + 2
            For x = mx - 2 To mx + 2
                _ClearColor Point(x, y), image&
            Next
        Next
    End If
    _Display
    _Limit 100
Loop Until _KeyDown(27)
_AutoDisplay
_Source 0
Cls 'get rid of mouse stuff before save image
_PutImage , image&, 0
 
'Dim M As _MEM: M = _MemImage(Scn&)
'Screengrab$ = Space$(M.SIZE)
'_MemGet M, M.OFFSET, Screengrab$
 
'The above will:
'Dim a mem block.  Point it to your screen's image.
'Set a string that size.
'Get the whole screen at once into that string.
 
 
'Then to save to disk all at once:
'Open "Test SaveLoad Image.bin" For Binary As #1
'Put #1, , Screengrab$
'Close
'Open the file, put the data in one chunk, close the file.
 
' hopefully the above has been encoded properly into a Sub
SaveCustomImage Scn&, "Test Save Turkey Run"
 
Cls
Print "Press any to test load image again... "
Sleep
 
'Loading is the same, in reverse:
'Open "Test SaveLoad Image.bin" For Binary As #1
'Get #1, , Screengrab$
'Close
'And putting the data back to screen is also done all in one command:
'_MemPut M, M.OFFSET, Screengrab$
 
'And hopefully the LoadCustomImage& Function gets the data back from file
Dim image2&: image2& = LoadCustomImage&("Test Save Turkey Run")
_PutImage , image2&, 0 ' put back on screen
 
Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
    outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub
 
'this will create 2 files for Custom Image:
'1) FileName$ + "CI_DIM" for image dimensions
'2) FileName$ + "CI" for the Custom Image data
Sub SaveCustomImage (imgHdl&, fileSaveBaseName$) ' for any image setup by _newimage
    Dim As Long w, h: w = _Width(imgHdl&): h = _Height(imgHdl&)
    Dim M As _MEM: M = _MemImage(imgHdl&) 'Dim a mem block.  Point it to your screen's image.
    Dim screenGrab$: screenGrab$ = Space$(M.SIZE) 'Set a string that size.
    'screenGrab$ = _Deflate$(screenGrab$)
    _MemGet M, M.OFFSET, screenGrab$ 'Get the whole screen at once into that string.
    Open fileSaveBaseName$ + ".CI_DIM" For Output As #1
    Print #1, w
    Print #1, h
    Close #1
    Open fileSaveBaseName$ + ".CI" For Binary As #1
    Put #1, , screenGrab$
    Close
End Sub
 
' Function returns Image Handle& (like _LoadFile)
Function LoadCustomImage& (fileLoadBaseName$) ' reverse the Save
    Dim As Long w, h
    Open fileLoadBaseName$ + ".CI_DIM" For Input As #1 ' get dimensions of custom image
    Input #1, w
    Input #1, h
    Close #1
    Dim imgHdl&: imgHdl& = _NewImage(w, h, 32) 'setup space and handle for it
    Dim M As _MEM: M = _MemImage(imgHdl&) ' put data into handle space reserved
    Dim screenGrab$: screenGrab$ = Space$(M.SIZE)
    Open fileLoadBaseName$ + ".CI" For Binary As #1 ' get data
    'screenGrab$ = Space$(LOF(1))
    Get #1, , screenGrab$
    Close #1
    'screenGrab$ = _Inflate$(screenGrab$)  ' doesn't work
    _MemPut M, M.OFFSET, screenGrab$
    LoadCustomImage& = imgHdl& ' finally assign the function
End Function
 

Press escape when done erasing pixels and the image is saved and the loaded and displayed to test code in subs just as it was tested in Steve's original.

Then I ran the modified image in Turkey Hunt:

Code: QB64: [Select]

_Title "Turkey Shoot" 'b+ 2021-12-29   translate from BlitzMax to QB64 and modify, source:
'  https://www.syntaxbomb.com/tutorials/learning-basic-for-total-beginners-blitzmax-ng/msg347053898/#msg347053898
'  from MidiMaster tutorial on BlitzMax started Dec 22, 2021
 
' single comments are BlitzMax code
'' double comments are added notes by bplus
 
'SuperStrict
Option _Explicit ' must Dimension variables with types before using
 
'' current default type is single suffix ! not needed which is low precision float
 
'Graphics 800,600
'' land.png the background is 1347 X 600 so let's use a screen in same proportion  shrink by 1.1225 so no distorion of background
Screen _NewImage(1200, 534, 32) ' << the 32 allows RGBA color, this sets up customized graphics screen
_ScreenMove 60, 100 '' centers screen in window
 
'Global Land:TImage    = LoadImage("land.png")   '' dims 1347 x 600
Dim Land&: Land& = _LoadImage("land.png")
 
'Global Chicken:TImage = LoadImage("chicken.png")
'' for Global use Shared keyword with Dim (or ReDim or Static for Subs to preserve values)
''Dim Shared Turkey&: Turkey& = _LoadImage("turkey run.jpg")
'' remove background color OK this isn't the cleanest removal , BlizMax just drew a rectangle
''_Source Turkey&
''_ClearColor Point(10, 10), Turkey&
''_ClearColor Point(64, 22), Turkey&
''_ClearColor Point(86, 133), Turkey&
''_PutImage (0, 0), Turkey&, 0
 
''Do ' find points to make transparent
''    While _MouseInput: Wend
''    Locate 1, 1: Print Space$(40)
''    Locate 1, 1: Print _MouseX, _MouseY, Point(_MouseX, _MouseY) \ 256, (Point(_MouseX, _MouseY) \ 256) \ 256, ((Point(_MouseX, _MouseY) \ 256) \ 256) \ 256
''    _Display
''    _Limit 100
''Loop
''End
''_ClearColor Point(10, 10), Turkey&
''_Source 0
 
' the above block was replaced with a Custom Image Load
Dim Shared Turkey&: Turkey& = LoadCustomImage&("Test Save Turkey Run")
_ClearColor &HFF000000, Turkey&
_PutImage (100, 100), Turkey&, 0 ' I want to see how our image looks from custom load
Print "Here is our target, press any to continue..."
Sleep
 
 
Dim Shared TurkeyWidth&: TurkeyWidth& = 100 '     proportional to image
Dim Shared TurkeyHeight&: TurkeyHeight& = 83
 
'Global Shot:TSound=LoadSound("fire.ogg")
Dim Shared Shot&: Shot& = _SndOpen("fire.ogg")
 
'Global cX:Int, cY:Int=300
'Global mX:Int, mY:Int
'Global Points:Int
' in QB64 you can Dim with suffix or say Type in DIM ststement
'Since we are using a Turkey instead of a Chicken:
Dim Shared As Long TurkeyX, TurkeyY, MX, MY, Points
TurkeyY = 350 ' for now the other values are at 0
 
_MouseHide '
 
'start turkey on right side of screen, this image can only run left
TurkeyX = _Width
 
 
'Repeat
' default drawing color is already white
Do
 
    'Cls '' not needed in QB64
 
    'DrawImage Land    , 0 , 0
    _PutImage , Land&, 0 ' stretch/shrink image to fit screen  This already CLS screen
 
    'DrawImage Chicken , cX , cY
    '   comment out the original command, and use DrawRect instead:
    '    SetColor 111,0,0
    '    DrawRect cX, cY, 60,40
 
    _PutImage (TurkeyX, TurkeyY)-Step(TurkeyWidth&, TurkeyHeight&), Turkey&, 0 ' shrink image into Box
 
 
    '    cX = cX +2
    TurkeyX = TurkeyX - Rnd * 20
 
    'if turkey lives to run outside of screen replace it on left side
    If TurkeyX + _Width(Turkey&) < 0 Then TurkeyX = _Width + 50
 
 
    'If GunFire() =True Then
    If GunFire& Then
 
        ' QB64 Bonus display turkey upside down!!!
        _PutImage , Land&, 0 ' stretch/shrink image to fit screen
        _PutImage (TurkeyX, TurkeyY)-Step(TurkeyWidth&, TurkeyHeight&), Turkey&, 0, (0, _Height(Turkey&))-Step(_Width(Turkey&), -_Height(Turkey&))
        _Display
        _Delay 1 ' ha, upside down
 
 
        '        cX=-100
        TurkeyX = _Width ' reset turkey to left side of screen
 
        Points = Points + 1 'same for both for next loop
 
    End If ' same
 
    'SetColor 255,255,255
    'DrawRect mX-25, mY-1,50,3
    'DrawRect mX-1, mY-25,3,50
 
    ' This is for mouse scope  (the gunFire call updates mouse info in loop)
    Line (MX - 20, MY)-Step(40, 0), &HFF000000
    Line (MX, MY - 20)-Step(0, 40), &HFF000000
    Circle (MX, MY), 8
    Circle (MX, MY), 14
    ''HideMouse
    'did this before starting loop
 
    'DrawText "Points: " + points, 700,550
    _PrintString (10, 10), " Points:" + Str$(Points) + " "
 
    'Flip
    _Display ' prevent blinking form CLS
    _Limit 60 ' 30 frames per second at most!
 
    'Until AppTerminate()
Loop Until _KeyDown(27) 'quit with escape, top right x click will also close window no matter what
'ShowMouse
'_MouseShow not really needed
 
 
'Function GunFire:Int()
'        mX=MouseX()
'        mY=MouseY()
'        If MouseHit(1)
'                PlaySound Shot
'                If (mX>cX) And (mx<cX+60)
'                        If (mY>cY) And (mY<cY+40)
'                                ' collision
'                                Return True
'                        EndIf
'                EndIf
'        EndIf
'        Return False
'End Function
 
Function GunFire& () ' Long integer Type
    While _MouseInput: Wend ' poll mouse updates the mouse information in keyWords starting with _Mouse...
    MX = _MouseX: MY = _MouseY
    If _MouseButton(1) Then ' Left mouse button is down, might want to wait until released but we delay in main loop if hit
        _SndPlay Shot&
        If (MX > TurkeyX) And (MX < TurkeyX + TurkeyWidth&) Then
            If (MY > TurkeyY) And (MY < TurkeyY + TurkeyHeight&) Then
                ' collision
                ' return True value with Function name
                GunFire& = -1 ' anything not 0 is true
            End If
        End If
    End If
    'else function returns 0
End Function
 
' Function returns Image Handle& (like _LoadFile)
Function LoadCustomImage& (fileLoadBaseName$) ' reverse the Save
    Dim As Long w, h
    Open fileLoadBaseName$ + ".CI_DIM" For Input As #1 ' get dimensions of custom image
    Input #1, w
    Input #1, h
    Close #1
    Dim imgHdl&: imgHdl& = _NewImage(w, h, 32) 'setup space and handle for it
    Dim M As _MEM: M = _MemImage(imgHdl&) ' put data into handle space reserved
    Dim screenGrab$: screenGrab$ = Space$(M.SIZE)
    Open fileLoadBaseName$ + ".CI" For Binary As #1 ' get data
    Get #1, , screenGrab$
    Close #1
    _MemPut M, M.OFFSET, screenGrab$
    LoadCustomImage& = imgHdl& ' finally assign the function
End Function
 
 

Which is nice start but begging for refinements ;-))

So my question (mostly to @SMcNeill) is can the sub and function be modified to use _deflate and _inflate from the Editing app? I left in comments to the code I tried but the playback is ending up blank without any errors flagged, so I uncommented the working save and load that I could use in Turkey Hunt.

Oh here is a zip with code, images and exes for Windows 10-64. The sound and images are for forum use only for discussion.

Programs / There they go!

« on: December 24, 2021, 07:54:55 pm »

Code: QB64: [Select]

_Title " There they go!"
Screen _NewImage(1280, 640, 32)
_ScreenMove 70, 70
Dim sleigh$(1 To 5)
For i = 1 To 5
    Read sleigh$(i)
Next
x = 1: y = _Height - 7 * 16
Do
    Cls
    For i = 1 To 5
        _PrintString (x, y + i * 16), sleigh$(i)
    Next
    x = x + 1
    y = y - .5
    _Display
    _Limit 100
Loop Until x = _Width Or y = -16 * 6
 
sleigh: ' thanks tsh73 at JB   len 34
Data "__     _  __                      "
Data "| \__ `\O/  `--  {}    \}    {/   "
Data "\    \_(~)/______/=____/=____/=*  "
Data " \=======/    //\\  >\/> || \>    "
Data "----`---`---  `` `` ```` `` ``    "
 
 

Programs / UDT Array to Data File by Random Access Test

« on: December 24, 2021, 02:17:34 am »

Again inspired by conversation on Discord, this is something I did in 90's with old QB but never got around to testing with QB64 until now:

Code: QB64: [Select]

_Title "UDT to Random Access File Test" ' b+ 2021-12-24
Type Image
    As String * 255 Text, FileName
    As Long SzX, SzY, PosX, PosY
End Type
 
Const SW = 1000, SH = 700
ReDim As Image TheItem(1 To 100), TheRecord
 
'testing the FakeText$ function because RA is very strict on fixed strings!
TheItem(1).Text = FakeText$(255)
TheItem(1).FileName = FakeText$(255)
Print TheItem(1).Text
Print Len(TheItem(1).Text)
Print TheItem(1).FileName
Print Len(TheItem(1).FileName)
Print "zzz"
Sleep
 
'make fake data to file
For i = 1 To 100
    TheItem(i).Text = FakeText$(255)
    TheItem(i).SzX = 100 + Rnd * 20
    TheItem(i).SzY = 70 + Rnd * 14
    TheItem(i).PosX = Rnd * (SW - TheItem(i).SzX)
    TheItem(i).PosY = Rnd * (SH - TheItem(i).SzY)
    TheItem(i).FileName = FakeText$(255)
Next
 
Open "Data Dump.RA" For Random As #1 Len = Len(TheRecord)
For i = 1 To 100
    'odious and tedious is this
    TheRecord.Text = TheItem(i).Text
    TheRecord.SzX = TheItem(i).SzX
    TheRecord.SzY = TheItem(i).SzY
    TheRecord.PosX = TheItem(i).PosX
    TheRecord.PosY = TheItem(i).PosY
    TheRecord.FileName = TheItem(i).FileName
    Put #1, , TheRecord
Next
Close #1
Print "Data File Ready"
 
' OK we got data filed! Now can we get it back
Open "Data Dump.RA" For Random As #1 Len = Len(TheRecord)
For i = 1 To 100
    Cls
    Get #1, i, TheRecord
    Print "Record Number:"; i
    Print "Text: "; TheRecord.Text
    Print "SzX:"; TheRecord.SzX
    Print "SzY:"; TheRecord.SzY
    Print "PosX:"; TheRecord.PosX
    Print "PosY:"; TheRecord.PosY
    Print "FileName:"; TheRecord.FileName
    Print " zzz..."
    Sleep
Next
Close #1
 
Function FakeText$ (lengthh)
    BlankString$ = Space$(lengthh)
    fini = Int(Rnd * 255) + 1
    For i = 1 To fini
        Mid$(BlankString$, i, 1) = Chr$(Rnd * (96 - 32) + 32)
    Next
    FakeText$ = BlankString$
End Function
 

Pages: 1 [2] 3 4 ... 21

News:

Show Posts

Topics - bplus

QB64 Discussion / February Number Challenge

Programs / p5js

Programs / Split Versus Tokenize

Programs / Quick Directory Files Listing for Windows Only

Programs / A Replacement Method for Data Statements

QB64 Discussion / How about dictating your QB64 Program?

Programs / Passing Time

Programs / Playing with fire (again)

Programs / Boggle play against AI - WIP

Programs / Read & Print the Type from your bas source

Programs / TriQuad Puzzle inspired by Rick3137

Programs / Wordle - a new word game

Programs / Custom Edit Image, Save and Load with Turkey Hunt WIP Game

Programs / There they go!

Programs / UDT Array to Data File by Random Access Test