Well hello again, I'm here with another bit of code, I was pondering the idea of a way to add serial codes and code checks to my programs, and this is what i came up with to generate a serial number>
Code: (Select All)
Function genCode$
Dim As Single one, two, three: one = 8: two = 7: three = 4
Dim code As String
'1
Do
For i = 1 To 5
x$ = x$ + _Trim$(Str$(Int(Rnd * 10)))
Next
If Val(x$) Mod one = 0 Then
Exit Do
Else
x$ = ""
End If
Loop
code = x$
x$ = ""
'2
Do
For i = 1 To 7
x$ = x$ + _Trim$(Str$(Int(Rnd * 10)))
Next
If Val(x$) Mod two = 0 Then
Exit Do
Else
x$ = ""
End If
Loop
code = code + "-" + x$
x$ = ""
'3
Do
For i = 1 To 5
x$ = x$ + _Trim$(Str$(Int(Rnd * 10)))
Next
If Val(x$) Mod three = 0 Then
Exit Do
Else
x$ = ""
End If
Loop
and this is what checks to see if the code is valid, and then returns a 1 for valid and a 0 for invalid>
Code: (Select All)
Function checkcode (d As String)
Dim As Single one, two, three: one = 8: two = 7: three = 4
Dim As String a, b, c
If InStr(d, "-") = 0 Then
a = Mid$(d, 1, 5)
b = Mid$(d, 6, 7)
c = Mid$(d, 13, 5)
Print a, b, c
End If
a = Left$(d, InStr(d, "-") - 1)
b = Mid$(d, InStr(d, "-") + 1, 7)
c = Right$(d, 5)
If Val(a) Mod one = 0 And Val(b) Mod two = 0 And Val(c) Mod three = 0 Then
If d = "" Then checkcode = 0: Exit Function
checkcode = 1
Else
checkcode = 0
End If
End Function
I have heard in the air a spealing that said "Bubble sort!"
It let me remember a old fashioned book of programming in Pascal. An just then this the "bubble gum".
So while I go to Psychoanalyst to set up better my mind here a Demonstration of different ways to build up a Bubble Sort routine...
in sum their are seven different routines... the first is the classical version, then it follows the last_index decreasing, the last_index swaped, the split & compact with different dimensions for splitting and one of the two index optimized manners...
run and choose you preferred BUBBLE SORT algorithm...
here I show the result got running the following code
and here the code:
Code: (Select All)
Const max = 32767
Randomize Timer
Type DATATYPE
a As Integer
b As Integer
c As Integer
End Type
ReDim SortedList(1 To max) As DATATYPE, t(1 To max) As DATATYPE
'The sort will only be done on the value of 'a' (SortedList().a) and the values can range from 1 to 32767.
init SortedList() ' this is the original array created at random
initT SortedList(), t() ' this copies the first array into the second array
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble t()
Print t(1).a, t(max - 1).a, t(max).a
Color 1
Print " Bubble 1 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t() ' so we use the identical array to be ordered
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble2 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 2
Print " Bubble 2 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t()
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble3 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 3
Print " Bubble 3 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t()
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble4 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 4
Print " Bubble 4 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t()
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble5 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 5
Print " Bubble 5 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t()
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble6 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 6
Print " Bubble 6 order"
Print (Timer(.001) - t#)
Color 7
End
Sub bubble (a() As DATATYPE)
' bubblesort
' we compare 2 sequential elements of a set of elements until no swap has been performed
' while the first element is higher/lower (increasing/decreasing order) than the second element we swap the 2 elements
NoSwap = 0
While NoSwap = 0
NoSwap = -1
For count = 1 To max - 1
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0
Next count
Wend
End Sub
Sub bubble2 (a() As DATATYPE)
' bubblesort
' we compare 2 sequential elements of a set of elements until no swap has been performed
' but we ignore the last elements because they has been already ordered
' while the first element is higher/lower (increasing/decreasing order) than the second element we swap the 2 elements
NoSwap = 0
Fmax = max
While NoSwap = 0
NoSwap = -1
Fmax = Fmax - 1
For count = 1 To Fmax
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0
Next count
Wend
End Sub
Sub bubble3 (a() As DATATYPE)
' bubblesort
' we compare 2 sequential elements of a set of elements until no swap has been performed
' but we ignore the last elements because they has been already ordered by swap
' while the first element is higher/lower (increasing/decreasing order) than the second element we swap the 2 elements
NoSwap = 0
Last = max - 1
While NoSwap = 0
NoSwap = -1
For count = 1 To Last
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0: Last = count
Next count
Wend
End Sub
Sub bubble4 (a() As DATATYPE)
' this is multibubble
' we split the array if too big into many subarray ordered by bubble sort
' using as max bubble dimension to order 3200 item for array
stepB = UBound(a) / 3200
For index = 1 To (UBound(a) - stepB) Step stepB
' bubble2 type
NoSwap = 0
First = index
Last = index + stepB - 1
While NoSwap = 0
NoSwap = -1
Last = Last - 1
For count = First To Last
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0
Next count
Wend
Next
bubble2 a() ' the last ordering operation
End Sub
Sub bubble5 (a() As DATATYPE)
' this is multibubble
' we split the array if too big into many subarray ordered by bubble sort
' using as max bubble dimension to order 100 item for array
stepB = UBound(a) / 100
For index = 1 To (UBound(a) - stepB) Step stepB
' bubble3 type
NoSwap = 0
First = index
Last = index + stepB - 1
While NoSwap = 0
NoSwap = -1
For count = First To Last
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0: Last = count
Next count
Wend
Next
bubble3 a() ' the last ordering operation
End Sub
Sub bubble6 (a() As DATATYPE)
' this is multibubble
' we split the array if too big into many subarray ordered by bubble sort
' using as max bubble dimension to order 1000 item for array
stepB = UBound(a) / 1000
For index = 1 To (UBound(a) - stepB) Step stepB
' bubble3 type
NoSwap = 0
First = index
Last = index + stepB - 1
While NoSwap = 0
NoSwap = -1
For count = First To Last
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0: Last = count
Next count
Wend
Next
bubble3 a() ' the last ordering operation
End Sub
Sub initT (b() As DATATYPE, a() As DATATYPE)
For count = 1 To max
a(count).a = b(count).a
Next count
End Sub
Sub init (a() As DATATYPE)
For count = 1 To max
a(count).a = (Rnd * max - 1) + 1
Next count
End Sub
Sub ShowArray (A() As DATATYPE)
For count = 1 To max
Print A(count).a
Next count
End Sub
Here's a couple routines to create randomly varying brickfill patterns. There are briefer and mathematically slicker ways to do simple brick patterns but if you want to add a little variation in color and style the code can get a little longer. If you can make use of it feel free.
Code: (Select All)
'linebricks
'playing with brick patterns drawn with the line command
'fills whole screen and 2 other area with a colored brick pattern that can randomly vary from brick to brick
'press any key for brickish wonder or esc to quit
Screen _NewImage(800, 500, 32)
_Title "Linebricks a brickfill demo"
Randomize Timer
Do
'this randomly sey bw (brick width) bh (brick height) and mw (mortar width) for the purposes of demonstration
bw = 4 + 4 * Int(Rnd * 8)
bh = (bw * 3) / 5
mw = bh / (4 + Rnd * 8)
If mw < .5 Then mw = .5
brickfill 0, 0, _Width, _Height, bw, bh, mw, _RGB32(240, 40, 40), _RGB32(100, 100, 100), 49, 12
brickfill 0, 0, 200, 150, bw, bh, mw, _RGB32(40, 40, 40), _RGB32(100, 100, 100), 50, 6
brickfill 200, 160, 400, 350, bw * 2, bh * 2, mw, _RGB32(40, 240, 40), _RGB32(100, 100, 100), 20, 10
Loop Until waitanykey$ = Chr$(27)
Function waitanykey$
_KeyClear
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
waitanykey$ = kk$
End Function
Sub brick (x, y, w, h, mwid, brickcolor As _Unsigned Long, mortarcolor As _Unsigned Long, cv)
'draw a brick
'each brick has color variation randomly picked in side the raneg defiend by cv
'each brick may be randonly standard, have a lightened highlight or a deep shadow and a higlight
Dim tcolor As _Unsigned Long
tred = _Red32(brickcolor) + Int(Rnd * cv) - Int(Rnd * cv)
tgreen = _Green32(brickcolor) + Int(Rnd * cv) - Int(Rnd * cv)
tblue = _Blue32(brickcolor) + Int(Rnd * cv) - Int(Rnd * cv)
If tred < 0 Then tred = 0
If tgreen < 0 Then tgreen = 0
If tblue < 0 Then tblue = 0
If tred > 255 Then tred = 255
If tgreen > 255 Then tgreen = 255
If tblue > 255 Then tblue = 255
tcolor = _RGB32(tred, tgreen, tblue)
Line (x, y)-(x - 1 + w, y - 1 + h), mortarcolor, BF
Select Case Int(1 + Rnd * 14)
Case 1, 2, 3, 4, 5, 6 'plain brick
Line (x + mwid, y + mwid)-(x - 1 + w - mwid, y - 1 + h - mwid), tcolor, BF
Case 7, 8 'sahdow and highlight brick
tred = tred - Int(cv / 2 + Rnd * cv)
tgreen = tgreen - Int(cv / 2 + Rnd * cv)
tblue = tblue - Int(cv / 2 + Rnd * cv)
If tred < 0 Then tred = 0
If tgreen < 0 Then tgreen = 0
If tblue < 255 Then tblue = 0
tcolor = _RGB32(tred, tgreen, tblue)
Line (x + mwid, y + mwid)-(x - 1 + w - mwid, y - 1 + h - mwid), tcolor, BF
tred = tred + Int(2 + Rnd * cv)
tgreen = tgreen + Int(2 + Rnd * cv)
tblue = tblue + Int(2 + Rnd * cv)
If tred > 255 Then tred = 255
If tgreen > 255 Then tgreen = 255
If tblue > 255 Then tblue = 255
tcolor = _RGB32(tred, tgreen, tblue)
sv = (10 + Rnd * 20) / 10
Line (x + (mwid * sv), y + mwid)-(x - 1 + w - mwid, y - 1 + h - (mwid * sv)), tcolor, BF
Case Else 'highlight brick
Line (x + mwid, y + mwid)-(x - 1 + w - mwid, y - 1 + h - mwid), tcolor, BF
tred = tred + Int(Rnd * (cv * .65))
tgreen = tgreen + Int(Rnd * (cv * .65))
tblue = tblue + Int(Rnd * (cv * .65))
If tred > 255 Then tred = 255
If tgreen > 255 Then tgreen = 255
If tblue > 255 Then tblue = 255
tcolor = _RGB32(tred, tgreen, tblue)
sv = (10 + Rnd * 20) / 10
Line (x + (mwid * sv), y + mwid)-(x - 1 + w - mwid, y - 1 + h - (mwid * sv)), tcolor, BF
End Select
End Sub
Sub brickfill (sx, sy, ex, ey, bw, bh, mwid, brickcolor As _Unsigned Long, mortarcolor As _Unsigned Long, cv, crackrange)
'crackrange is the raw maximum rnd range used to add cracks to the wall
Dim zag(1 To 10, 1 To 2)
b = 0
For y = sy To ey Step bh
b = b + 1
For x = sx To ex Step bw
If b Then
brick x - (bw \ 2), y, bw, bh, mwid, brickcolor, mortarcolor, cv
Else
brick x, y, bw, bh, mwid, brickcolor, mortarcolor, cv
End If
Next x
If b = 1 Then b = -1
Next y
cracks = Int(Rnd * crackrange)
For c = 1 To cracks
cx = Int(sx + Rnd * (ex - sx)): cy = Int(sy + Rnd * (ey - sy))
zag(1, 1) = cx: zag(1, 2) = cy
xshift = Int(-3 + Rnd * 6)
yshift = Int(-3 + Rnd * 6)
If xshift = 0 Then xshift = -1
If yshift = 0 Then yshift = -1
For z = 2 To 10
zag(z, 1) = zag(z - 1, 1) + xshift * Int(Rnd * ((ex - sx) / 20))
zag(z, 2) = zag(z - 1, 2) + yshift * Int(Rnd * ((ey - sy) / 20))
Next z
For z = 1 To 9
If zag(z, 1) > 0 And zag(z, 2) > 0 Then
If zag(z + 1, 1) <= ex And zag(z + 1, 2) <= ey Then Line (zag(z, 1), zag(z, 2))-(zag(z + 1, 1), zag(z + 1, 2)), _RGB32(90, 90, 90)
End If
Next z
Next c
End Sub
So is it me, my screen, an optical resolution, or how _putimage works that leads to me not actually getting square pixels with this little bit of code? The red dots created at 15,15 and 16,16 in the sample image just aren't the same size when I run this code:
Ok, so this is probably quite simple, but it's frustrating the heck out of me! This is A.jpg
(Please try to keep response simple).
Code: (Select All)
Screen _NewImage(1000, 800, 256)
Print "Why is line 8 returning Illegal function call?"
Sleep 2
h = 200: v = 200 ' horiz and vert position for pic
ReDim pic(4) As Long
im(1) = _LoadImage("RecPics/" + Chr$(65) + ".jpg")
Print: Print "im(1) is"; im(1); " (if less than -1, this handle should be ok)"
_PutImage (h, v), im(1)
Sleep
_FreeImage (im(1))
This is a program I created when very bored to take a list of 19-digit integers from a text file and figure out if they're prime or not. I was trying to get a palindrome out of one of them but failed so far LOL.
The program is listed below but is worthless without the data files which are part of the attachment.
Code: (Select All)
'by mnrvovrfc, first revision Dec-2020
$CHECKING:OFF
_DEFINE A-Z AS LONG
DIM PRIMEBIT(1 TO 4999995) AS _BIT
DIM PVAL(1 TO 1000) AS _UNSIGNED _INTEGER64
DIM X AS _UNSIGNED _INTEGER64, PLIMIT AS _UNSIGNED LONG, Y AS _UNSIGNED LONG, Z AS _UNSIGNED LONG
DIM fl AS _BIT, ofl AS _BIT, q AS _BYTE
IF NOT _FILEEXISTS(ifile$) THEN
PRINT "Cannot run without this file: prime20dig.txt"
END
END IF
IF _FILEEXISTS(dataf$) THEN
fi = FREEFILE
OPEN dataf$ FOR INPUT AS fi
LINE INPUT #fi, a$
CLOSE fi
sop = VAL(LTRIM$(a$))
IF sop < 1 THEN sop = 1
ELSE
sop = 1
END IF
PRINT "Please wait, loading ..."
READ Y
READ Y
DO WHILE Y
Y = (Y - 1) \ 2
PRIMEBIT(Y) = -1
READ Y
LOOP
PRINT "Checking input file..."
GOSUB setmytitle
fl = -1
l = 1
u = 1
v = UBOUND(PVAL)
fi = FREEFILE
OPEN ifile$ FOR INPUT AS fi
SEEK #fi, sop
DO UNTIL EOF(fi)
LINE INPUT #fi, a$
IF a$ <> "" THEN
PVAL(u) = VAL(a$)
u = u + 1
IF fl THEN fl = 0
IF u > v THEN sop = SEEK(fi): EXIT DO
END IF
l = l + 1
LOOP
IF EOF(fi) THEN sop = 1
CLOSE fi
IF fl THEN
PRINT "Nothing to do!"
END
END IF
COLOR 15, 5: CLS
GOSUB setmytitle
_DISPLAY
ofl = 0
FOR u = 1 TO v
X = PVAL(u)
IF X = 0 THEN EXIT FOR
IF u MOD 10 = 0 THEN q = _EXIT
IF q THEN EXIT FOR
omb = _MOUSEINPUT
IF omb THEN
IF _MOUSEBUTTON(1) THEN ofl = -1
IF _MOUSEBUTTON(2) THEN ofl = -1
END IF
IF ofl THEN
ofl = 0
_DISPLAY
END IF
fl = -1
Z = 1
FOR Y = 1 TO 4999995
Z = Z + 2
IF PRIMEBIT(Y) THEN
IF X MOD Z = 0 THEN fl = 0: EXIT FOR
END IF
NEXT
IF fl THEN
PLIMIT = FIX(SQR(X * 1.0#))
FOR Y = 9999993 TO PLIMIT STEP 2
IF X MOD Y = 0 THEN fl = 0: EXIT FOR
NEXT
END IF
IF fl THEN
PRINT X
GOSUB setmytitle
_DISPLAY
ELSE
PVAL(u) = 0
END IF
NEXT
IF q = 0 THEN
fo = FREEFILE
IF _FILEEXISTS(outf$) THEN
OPEN outf$ FOR APPEND AS fo
ELSE
OPEN outf$ FOR OUTPUT AS fo
END IF
FOR u = 1 TO v
IF PVAL(u) > 0 THEN
PRINT #fo, STR$(PVAL(u))
END IF
NEXT
CLOSE fo
fo = FREEFILE
OPEN dataf$ FOR OUTPUT AS fo
PRINT #fo, sop
CLOSE fo
COLOR 14
PRINT "Completed!"
_DISPLAY
_DELAY 3
END IF
SYSTEM
setmytitle:
_TITLE "Prime 20 Digits"
RETURN
FUNCTION makeuserprof$ (s$)
IF s$ = "" THEN
makeuserprof$ = ""
EXIT FUNCTION
END IF
mypath$ = s$
''added NA27
IF LEFT$(mypath$, 2) = ".\" OR LEFT$(mypath$, 2) = "./" THEN
afile$ = "qb64curdir.txt"
b$ = "%USERPROFILE%"
IF _FILEEXISTS(afile$) THEN
c$ = ""
fi = FREEFILE
OPEN afile$ FOR INPUT AS fi
IF NOT EOF(fi) THEN
LINE INPUT #fi, c$
c$ = RTRIM$(LTRIM$(c$))
END IF
CLOSE fi
IF c$ <> "" THEN
IF RIGHT$(c$, 1) = "\" OR RIGHT$(c$, 1) = "/" THEN
b$ = LEFT$(c$, LEN(c$) - 1)
ELSE
b$ = c$
END IF
mypath$ = b$ + MID$(mypath$, 2)
END IF
END IF
END IF
u = INSTR(mypath$, "/")
v = INSTR(mypath$, "\")
IF u = 0 AND v = 0 THEN
makeuserprof$ = ""
EXIT FUNCTION
END IF
IF u > 0 THEN
ReplaceString2 mypath$, "/", "\", 0
END IF
u = INSTR(mypath$, "%")
IF u > 0 THEN
v = INSTR(u + 1, mypath$, "%\")
ELSE
u = 0
END IF
IF u = 1 AND v > u THEN
''continue function code
ELSE
makeuserprof$ = mypath$
EXIT FUNCTION
END IF
a$ = UCASE$(mypath$)
uprof$ = ENVIRON$("USERPROFILE")
FOR i = 1 TO 6
SELECT CASE i
CASE 1
b$ = "%USERPROFILE%"
c$ = uprof$
CASE 2
b$ = "%USERPROF%"
''c$ same as case 1
CASE 3
b$ = "%MUSIC%"
c$ = uprof$ + "\Music"
CASE 4
b$ = "%DOCS%"
c$ = uprof$ + "\Documents"
CASE 5
b$ = "%DOCU%"
c$ = uprof$ + "\Documents"
CASE 6
b$ = "%PIC%"
c$ = uprof$ + "\Pictures"
END SELECT
IF INSTR(a$, b$) THEN
ReplaceString2 mypath$, b$, c$, 1
EXIT FOR
END IF
NEXT
makeuserprof$ = mypath$
END FUNCTION
FUNCTION returntfn$ (femplate$)
STATIC sernum AS LONG, sernumset AS _BIT
sret$ = ""
a$ = LTRIM$(RTRIM$(femplate$))
IF a$ <> "" THEN
u = INSTR(a$, "|")
IF u > 0 THEN
IF LEFT$(a$, 1) = "%" OR INSTR(a$, "/") > 0 THEN
a$ = makeuserprof$(a$)
END IF
IF sernumset = 0 THEN
sernumset = NOT sernumset
sernum = 1
END IF
IF RIGHT$(a$, 1) <> "\" THEN
DO
n$ = LTRIM$(STR$(sernum))
IF LEN(n$) < 4 THEN n$ = LEFT$("0000", 4 - LEN(n$))
sret$ = a$
ReplaceString2 sret$, "|", n$, 1
sernum = sernum + 1
LOOP UNTIL NOT _FILEEXISTS(sret$)
END IF
END IF
END IF
returntfn$ = sret$
END FUNCTION
SUB ReplaceString2 (tx AS STRING, sfind AS STRING, repl AS STRING, numtimes AS _UNSIGNED LONG)
DIM s AS STRING, t AS STRING
DIM ls AS _UNSIGNED LONG, lx AS _UNSIGNED LONG, count AS _UNSIGNED LONG, j AS _UNSIGNED LONG
IF (tx = "") OR (sfind = "") OR (sfind = repl) OR (LEN(sfind) > LEN(tx)) THEN EXIT SUB
s = UCASE$(sfind): t = UCASE$(tx)
ls = LEN(s)
count = 0
goahead = 1
DO
u = INSTR(t, s)
IF u > 0 THEN
tx$ = LEFT$(tx, u - 1) + repl + MID$(tx, u + ls)
t = UCASE$(tx)
IF numtimes > 0 THEN count = count + 1: IF count >= numtimes THEN goahead = 0
ELSE
goahead = 0
END IF
LOOP WHILE goahead
END SUB
'$INCLUDE: 'tprime.bi'
As the program is presented, it looks for a file named "prime19dig.txt" in the user's Documents directory. This file is over 80MB in size! Do not try to open it in Notepad or any other text editor that cannot handle files larger than 1MB. I created it and a few others with a Lua script, being more interested in patterns of the digits. It's because trying to go sequentially would be very slow and come up with numbers boring to look at or could peel the paint from the walls. Such as 10000000002835706257.
This program only takes numbers from a list and figures out if they're prime or not. If prime they are listed on the screen and they are also sent to an output file called "prime19dig-out.txt". The program should end in 5 to 10 minutes on a dual-core CPU laptop created within the last five years. Then the user could choose to run it again to pick up where it left off. This could be done for a while until it runs out of "candidates" and it starts from the beginning -- then you say give me another 80MB file. This information is saved in a file called "prime19dig-pref.txt", should not be tampered by anybody who hasn't read and understood the source code!
I have indeed created another version of this program that focused only on numbers higher than 18 followed by 18 zeros. But the program posted here is only one example of what could be done with 64-bit integers. Imagine when 128-bit becomes the norm later on...
Note: there was another number 10043560040404043561 that figured in one of my fantasy stories, about a rock band that created a song singing it out. It was supposed to be for LOL's. Imagine like Katy Perry or Springsteen singing, "zero zero four, zero four, zero four, zero four, three five six!" Sorry not a good judge with female solo artists after Madonna and others ruined my sense for pop-rock forever. But that integer is not prime, must add six to it.
(Maybe I should use an external file-sharing service because I made one attempt to upload but it didn't display in the available list of attachments, although it reflected the large jump in size of total attachments. I will have to delete one of the two attempts later, if it could be found.)
When using graphics, especially in games, it's often necessary to clear an image from a surface before placing another image in its place because of alpha transparency issues. The method I usually use to do this was way to slow for the current project I'm working on. So I started playing with and timing alternative methods.
Thought I would pass this tidbit of information along.
Using a 512x736 32bit image and each method repeated 10000 times I get the following.
My usual method: 0.644 seconds
Odest = _DEST
_DEST Image
CLS
_DEST Odest
Using LINE BF method: 0.620 seconds (curious that LINE is faster than CLS)
Well, as you can see, the 3rd method is superior. I created a simple subroutine to handle this for me now:
SUB RENEW_IMAGE (Image AS LONG)
DIM Iwidth AS INTEGER ' width of image
DIM Iheight AS INTEGER ' height of image
Iwidth = _WIDTH(Image) ' get width of image
Iheight = _HEIGHT(Image) ' get height of image
_FREEIMAGE Image ' remove the image from RAM
Image = _NEWIMAGE(Iwidth, Iheight, 32) ' recreate a blank surface
Be careful what you do, I always recommend COPYING the program to another folder and putting the files there. I've tried it all and it's a working procedure. The described procedure assumes that you have already created a PMF2 file that contains all the files you need to include in the EXE file.
STEP 1:
Code: (Select All)
'STEP 1: Your EXE file is named Step1 (for example, but EXE file name must be the same as second parameter for ExtractExe!)
' Copy to this EXE ExtractEse, and all need sources for PMF2 extractor as in this example
' DO NOT RUN IT, MAKE EXE FILE ONLY and then goto step 2 in example 2 for completing this operation.
Type Header ' Header 1
ID As String * 4 ' file format signature PMF2
Files_Total As Long ' how much files container contains
End Type
Type File_List ' Header 2
FileNameLEN As _Unsigned _Byte 'Lenght for file name (example: Untitled.bas = file name lenght = 12)
Compress As _Unsigned _Byte ' Compression. 0 = not used, 1 = used (_INFLATE$)
Offset As Long ' Area in file (offset) where start this file data
BlockSize As Long ' Byte size (how much bytes is used for this file in PMF2 container, size after compression if used)
End Type
Dim Shared PMF2H As Header
ReDim Shared PMF2FL(0) As File_List 'each added file has its own index in this field
Const Show = -1
Const Unpack_All = 0
ExtractExe "archive.pmf2", "Step1.exe" 'get PMF2 from EXE
_Delay 1 'is need!
UnPack_PMF2 "archive.pmf2", Unpack_All ' get files from PMF2
'your program is here
End
Sub ExtractExe (OutputFile As String, ThisExeFile As String)
Dim As Long ExeSize
TEF = FreeFile
Open ThisExeFile For Binary As #TEF
Get #TEF, LOF(TEF) - 3, ExeSize
' Print "Original EXE size: "; ExeSize
If ExeSize < 0 Then Print "Invalid record.": End
OutputFileBinary$ = Space$(LOF(TEF) - ExeSize - 4)
Get #TEF, ExeSize + 1, OutputFileBinary$
Close #TEF
' Print "V RAM je "; Len(OutputFileBinary$); "bytes"
Open OutputFile For Binary As #TEF
Put #TEF, , OutputFileBinary$
OutputFileBinary$ = ""
Close #TEF
End Sub
Sub UnPack_PMF2 (ArchiveName As String, METHOD As _Byte)
'method: -1 = show files in PMF2 file
' 0 = UnPack all files from PMF2 file
' > 0 = Unpack file writed in this position in PMF2 file (-1) - use record number printed in Show mode
If _FileExists(ArchiveName) Then
FF = FreeFile
Open ArchiveName For Binary As FF
Get FF, , PMF2H ' read head 1
If PMF2H.ID = "PMF2" Then
If PMF2H.Files_Total > -1 Then
ReDim As File_List PMF2FL(PMF2H.Files_Total)
Get FF, , PMF2FL() ' read head 2
ReDim As String Names(PMF2H.Files_Total)
For ReadFileNames = 0 To PMF2H.Files_Total ' read files names in file
N$ = Space$(PMF2FL(ReadFileNames).FileNameLEN)
Get FF, , N$
Names(ReadFileNames) = N$
N$ = ""
Next
Select Case METHOD ' This is information block (Show)
Case -1
Print "Pos. File name Compressed Size in PMF2 file [bytes]"
Print "-----------------------------------------------------------------"
For ReadContent = 0 To PMF2H.Files_Total
F_Name$ = Names(ReadContent)
If Len(F_Name$) > 15 Then F_Name$ = Mid$(F_Name$, 1, 12) + "..."
If PMF2FL(ReadContent).Compress Then F_Compress$ = "Yes" Else F_Compress$ = "No"
F_Size& = PMF2FL(ReadContent).BlockSize
ddd = Len(LTrim$(Str$(ReadContent)))
Print LTrim$(Str$(ReadContent + 1)) + "."; Spc(4 - ddd); F_Name$; Spc(18 - Len(F_Name$) + ddd); F_Compress$; Spc(12); F_Size&
If ReadContent Mod 18 = 0 And ReadContent > 0 Then
Print "Press any key for next..."
Sleep
Cls
Print "Pos. File name Compressed Size in PMF2 file [bytes]"
Print "-----------------------------------------------------------------"
End If
Next
Case 0 ' extract it
For UnPack = 0 To PMF2H.Files_Total
If _FileExists(Names(UnPack)) Then 'add automaticaly parentheses and number, if file exists
u = 0
Do Until _FileExists(Names(UnPack)) = 0
Dot = InStr(1, Names(UnPack), ".") - 1
Test$ = Mid$(Names(UnPack), 1, Dot) + "(" + _Trim$(Str$(u) + ")") + Right$(Names(UnPack), PMF2FL(UnPack).FileNameLEN - Dot)
If _FileExists(Test$) = 0 Then Names(UnPack) = Test$
Test$ = ""
u = u + 1
Loop
End If
EF = FreeFile
Open Names(UnPack) For Binary As EF
N$ = Space$(PMF2FL(UnPack).BlockSize)
Get FF, , N$
If PMF2FL(UnPack).Compress Then Rec$ = _Inflate$(N$) Else Rec$ = N$
Put EF, , Rec$
N$ = ""
Rec$ = ""
Close EF
Next UnPack
Case Is > 0 ' unpack just one concrete file
Fi = METHOD - 1
If Fi > UBound(Names) Then Print "Invalid record add as parameter for Unpack_PMF2 SUB!": Sleep 3: End
If _FileExists(Names(Fi)) Then 'add automaticaly parentheses and number, if file exists
u = 0
Do Until _FileExists(Names(Fi)) = 0
Dot = InStr(1, Names(Fi), ".") - 1
Test$ = Mid$(Names(Fi), 1, Dot) + "(" + _Trim$(Str$(u) + ")") + Right$(Names(Fi), PMF2FL(Fi).FileNameLEN - Dot)
If _FileExists(Test$) = 0 Then Names(Fi) = Test$
Test$ = ""
u = u + 1
Loop
End If
EF = FreeFile
Open Names(Fi) For Binary As EF
N$ = Space$(PMF2FL(Fi).BlockSize)
Seek FF, PMF2FL(Fi).Offset
Get FF, , N$
If PMF2FL(Fi).Compress Then Rec$ = _Inflate$(N$) Else Rec$ = N$
Put EF, , Rec$
N$ = ""
Rec$ = ""
Close EF
End Select
Else
Print "Invalid record: Number of files in PMF2 file: "; PMF2H.Files_Total: Sleep 3: End
End If
Else
Print "Invalid PMF2 file format. ": Sleep 3: End
End If
Else
Print "PMF2 file: "; ArchiveName$; " not exists. Can not continue.": Sleep 3: End
End If
End Sub
Place to your program PMF2 headers and source code as in this example. COMPILE IT, DO NOT RUN IT! We need EXE file named Step1.exe, this program is named as Step1.bas it is very important for correct function!
Then, when EXE file is done, we can add files to EXE - Step 2:
Code: (Select All)
'STEP 2: USE PMF2 archiver for compress more files to PMF2 and then insert it to EXE file.
AddToExe "pmf2test2023.pmf2", "step1.exe"
End
Sub AddToExe (File As String, ExeFile As String)
Dim As Long FileSize
If _FileExists(ExeFile) Then
If _FileExists(File) Then
Af = FreeFile
Open File For Binary As #Af
FileBin$ = Space$(LOF(Af))
Get #Af, , FileBin$
Close #Af
Af = FreeFile
Open ExeFile For Binary As #Af
FileSize = LOF(Af)
Seek #Af, LOF(Af) + 1
Put #Af, , FileBin$
Put #Af, , FileSize
Close #Af
FileBin$ = ""
Else Print "Sorry, file "; File; "not exists"
End If
Else Print "Sorry, file "; ExeFile; "not exists."
End If
End Sub
Program insert archive file pmf2test2023.pmf2 to file test1.exe
If you do all correct, after running program Step1.exe all files from PMF2 are extracted to harddrive.
If there is interest, I am willing to modify the output of PMF2 so that the files are not saved to the hard disk, but to the computer's memory.
But then of course you have to have your own solution for working with these yours files.
![[Image: image.png]](https://i.ibb.co/NNJf6gz/image.png)
![[Image: A.jpg]](https://i.ibb.co/JvkNNYb/A.jpg)
