Not to be confused with CircleFill, this is CircleFiller -- this fills an area with circles!
Code: (Select All)
Screen _NewImage(640, 480, 32)
Const Red = &HFFFF0000
Line (200, 200)-(400, 400), Red, B
CircleFiller 300, 300, 10, Red
Sleep
Cls , 0
Circle (320, 240), 100, Red
CircleFiller 320, 240, 10, Red
Sub CircleFiller (x, y, r, k As _Unsigned Long)
If CircleFillValid(x, y, r, k) Then
CircleFill x, y, r, k
CircleFiller x - r - r - 1, y, r, k
CircleFiller x + r + r + 1, y, r, k
CircleFiller x, y - r - r - 1, r, k
CircleFiller x, y + r + r + 1, r, k
End If
End Sub
Sub CircleFill (cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long)
Dim a As Long, b As Long
Dim x As Long, y As Long
Dim xx As Long, yy As Long
Dim sx As Long, sy As Long
Dim e As Long
Dim rx As Integer, ry As Integer
rx = r: ry = r
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
Do While sx >= sy
Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
If y <> 0 Then Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
If (e + e + xx) > 0 Then
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
End If
Loop
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
Do While sx <= sy
Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
Do
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
Loop Until (e + e + yy) > 0
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
Loop
End Sub
Function CircleFillValid (cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long)
Dim a As Long, b As Long
Dim x As Long, y As Long
Dim xx As Long, yy As Long
Dim sx As Long, sy As Long
Dim e As Long
Dim rx As Integer, ry As Integer
rx = r: ry = r
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
Do While sx >= sy
For i = cx - x To cx + x
If Point(i, cy - y) = c Then Exit Function
Next
'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
If y <> 0 Then
'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
For i = cx - x To cx + x
If Point(i, cy + y) = c Then Exit Function
Next
End If
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
If (e + e + xx) > 0 Then
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
End If
Loop
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
Do While sx <= sy
'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
For i = cx - x To cx + x
If Point(i, cy - y) = c Then Exit Function
If Point(i, cy + y) = c Then Exit Function
Next
Do
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
Loop Until (e + e + yy) > 0
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
Loop
CircleFillValid = -1
End Function
This can also be easily modified to become an EllipseFiller (as I'm actually using the EllipseFill routines for this and modified them so rx/ry are both passed by r instead...), if case anyone wants a nice EllipseFiller utility.
And what's the purpose of this, you ask?
I was thinking of plugging it into my little hourglass program so it'd drop balls instead of sand, but then I figured, "Nah... I'm too lazy. This is good enough. Somebody else can go back and insert the routines into the program if they want to now. I'm going to dinner and a movie with the wife..."
Everybody else makes clocks... I made an hourglass!
Code: (Select All)
Screen _NewImage(1024, 720, 32)
_ScreenMove _Middle
_Define A-Z As LONG
Dim Shared SandCounter
Dim FillColor As _Unsigned Long
ReDim Shared Sand(100000) As Coord
ReDim Shared RemoveSand(100000) As Coord
Dim Pause As _Float
Const Seconds = 10
f = _LoadFont("OLDENGL.ttf", 32)
_Font f
DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
FillWithSand CenterX, CenterY, FillColor
PCopy 0, 1
_DontBlend
Do
PCopy 1, 0
For i = 1 To SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: Next
If Pause = 0 Then Pause = SandCounter / Seconds
CountDown = Seconds
o$ = Str$(CountDown): _PrintString (512 - _PrintWidth(o$) \ 2, 570), o$ + " "
min = 1: max = 0
t# = Timer(0.001)
Do
If max < SandCounter Then
max = max + 1
PSet (RemoveSand(max).x, RemoveSand(max).y), 0
End If
For i = min To max
If Point(Sand(i).x, Sand(i).y + 1) = 0 Then 'fall down
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).y = Sand(i).y + 1
ElseIf Point(Sand(i).x - 1, Sand(i).y + 1) = 0 Then 'fall down and left
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
ElseIf Point(Sand(i).x + 1, Sand(i).y + 1) = 0 Then 'fall down and right
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
Else 'sit and don't move any more
min = min + 1
End If
PSet (Sand(i).x, Sand(i).y), FillColor
Next
If Timer - t# >= 1 Then t# = Timer(0.001): CountDown = CountDown - 1: o$ = Str$(CountDown): _PrintString (512 - _PrintWidth(o$) \ 2, 570), o$ + " "
_Limit Pause 'to set the timing properly (IF possible. Slow computers may not run this unoptimized code at speed for an hourglass with a low flip time.)
_Display
If _KeyHit Then System
Loop Until max = SandCounter
Loop
Sub FillWithSand (x, y, kolor As _Unsigned Long)
If Point(x - 1, y) = 0 Then
PSet (x - 1, y), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
FillWithSand x - 1, y, kolor
End If
If Point(x, y - 1) = 0 Then
PSet (x, y - 1), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
FillWithSand x, y - 1, kolor
End If
If Point(x + 1, y) = 0 Then
PSet (x + 1, y), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
FillWithSand x + 1, y, kolor
End If
End Sub
Sub DrawHourGlass (x, y, high, wide, gap, thick, kolor As _Unsigned Long) 'x/y center
Line (x - gap, y)-Step(-wide, -high), kolor
Line -Step(2 * (wide + gap), -thick), kolor, BF
Line (x + gap, y)-Step(wide, -high), kolor
Line (x + gap, y)-Step(wide, high), kolor
Line (x - gap, y)-Step(-wide, high), kolor
Line -Step(2 * (wide + gap), thick), kolor, BF
For thickness = 1 To thick
For Yborder = 0 To y + high + thick
For Xborder = 0 To x
If Point(Xborder + 1, Yborder) Then PSet (Xborder, Yborder), kolor 'thicken left
Next
For Xborder = x + wide + 2 * gap + thickness To x + 1 Step -1
If Point(Xborder - 1, Yborder) Then PSet (Xborder, Yborder), kolor 'thicken right
Next
Next
Next
End Sub
DECLARE DYNAMIC LIBRARY "kernel32"
FUNCTION GlobalFree~%& (BYVAL hMem~%&)
FUNCTION GetLastError~& ()
END DECLARE
DECLARE DYNAMIC LIBRARY "gdi32"
FUNCTION DeleteDC& (BYVAL hdc~%&)
FUNCTION SetTextAlign~& (BYVAL hdc~%&, BYVAL fMode~&)
FUNCTION GetTextAlign~& (BYVAL hdc~%&)
FUNCTION TextOutA& (BYVAL hdc~%&, BYVAL nXStart&, BYVAL nYStart&, BYVAL lpString~%&, BYVAL cchString&)
FUNCTION StartDocA& (BYVAL hdc~%&, BYVAL lpdi~%&)
FUNCTION AbortDoc& (BYVAL hdc~%&)
FUNCTION StartPage& (BYVAL hDC~%&)
FUNCTION EndPage& (BYVAL hdc~%&)
FUNCTION EndDoc& (BYVAL hdc~%&)
FUNCTION ResetDCA~%& (BYVAL hdc~%&, BYVAL lpInitData~%&)
END DECLARE
DECLARE DYNAMIC LIBRARY "user32"
FUNCTION FindWindowA%& (BYVAL lpClassName%&, BYVAL lpWindowName%&)
END DECLARE
DECLARE DYNAMIC LIBRARY "comdlg32"
FUNCTION PrintDlgExA~& (BYVAL lppd~%&) ' returns an HRESULT
END DECLARE
DECLARE CUSTOMTYPE LIBRARY
' http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=10886.msg91583#msg91583
SUB SUB_READDEVMODE (BYVAL p~%&)
SUB SUB_READDEVNAMES (BYVAL p~%&)
END DECLARE
TYPE DOCINFOA
cbSize AS LONG
lpszDocName AS _UNSIGNED _OFFSET ' LPCSTR
lpszOutput AS _UNSIGNED _OFFSET ' LPCSTR
lpszDatatype AS _UNSIGNED _OFFSET ' LPCSTR
fwType AS _UNSIGNED LONG
END TYPE
TYPE POINTL
x AS LONG
y AS LONG
END TYPE
CONST len_DEVMODEA = 156
TYPE DEVMODEA
dmDeviceName AS STRING * CCHDEVICENAME
dmSpecVersion AS _UNSIGNED INTEGER
dmDriverVersion AS _UNSIGNED INTEGER
dmSize AS _UNSIGNED INTEGER
dmDriverExtra AS _UNSIGNED INTEGER
dmFields AS _UNSIGNED LONG
' union {
' struct { comment either the following 8 lines
dmOrientation AS INTEGER
dmPaperSize AS INTEGER
dmPaperLength AS INTEGER
dmPaperWidth AS INTEGER
dmScale AS INTEGER
dmCopies AS INTEGER
dmDefaultSource AS INTEGER
dmPrintQuality AS INTEGER
' };
' struct { or the following 3 lines
' dmPosition AS POINTL
' dmDisplayOrientation AS _UNSIGNED LONG
' dmDisplayFixedOutput AS _UNSIGNED LONG
' };
' };
dmColor AS INTEGER
dmDuplex AS INTEGER
dmYResolution AS INTEGER
dmTTOption AS INTEGER
dmCollate AS INTEGER
dmFormName AS STRING * CCHFORMNAME
dmLogPixels AS _UNSIGNED INTEGER
dmBitsPerPel AS _UNSIGNED LONG
dmPelsWidth AS _UNSIGNED LONG
dmPelsHeight AS _UNSIGNED LONG
' union { comment exactly 1 of the following 2 lines
' dmDisplayFlags AS _UNSIGNED LONG
dmNup AS _UNSIGNED LONG
' };
dmDisplayFrequency AS _UNSIGNED LONG
dmICMMethod AS _UNSIGNED LONG
dmICMIntent AS _UNSIGNED LONG
dmMediaType AS _UNSIGNED LONG
dmDitherType AS _UNSIGNED LONG
dmReserved1 AS _UNSIGNED LONG
dmReserved2 AS _UNSIGNED LONG
dmPanningWidth AS _UNSIGNED LONG
dmPanningHeight AS _UNSIGNED LONG
END TYPE
TYPE DEVNAMES
wDriverOffset AS _UNSIGNED INTEGER
wDeviceOffset AS _UNSIGNED INTEGER
wOutputOffset AS _UNSIGNED INTEGER
wDefault AS _UNSIGNED INTEGER
END TYPE
TYPE PRINTPAGERANGE
nFromPage AS _UNSIGNED LONG
nToPage AS _UNSIGNED LONG
END TYPE
$IF 32BIT THEN
TYPE PRINTDLGEX
lStructSize AS _UNSIGNED LONG
hwndOwner AS _UNSIGNED _OFFSET ' HWND
hDevMode AS _UNSIGNED _OFFSET ' HGLOBAL
hDevNames AS _UNSIGNED _OFFSET ' HGLOBAL
hDC AS _UNSIGNED _OFFSET ' HDC
Flags AS _UNSIGNED LONG
Flags2 AS _UNSIGNED LONG
ExclusionFlags AS _UNSIGNED LONG
nPageRanges AS _UNSIGNED LONG
nMaxPageRanges AS _UNSIGNED LONG
lpPageRanges AS _UNSIGNED _OFFSET ' LPPRINTPAGERANGE
nMinPage AS _UNSIGNED LONG
nMaxPage AS _UNSIGNED LONG
nCopies AS _UNSIGNED LONG
hInstance AS _UNSIGNED _OFFSET ' HINSTANCE
lpPrintTemplateName AS _UNSIGNED _OFFSET ' LPCSTR
lpCallback AS _UNSIGNED _OFFSET ' LPUNKNOWN
nPropertyPages AS _UNSIGNED LONG
lphPropertyPages AS _UNSIGNED _OFFSET ' HPROPSHEETPAGE *
nStartPage AS _UNSIGNED LONG
dwResultAction AS _UNSIGNED LONG
END TYPE
$ELSE
TYPE PRINTDLGEX
lStructSize AS _UNSIGNED _INTEGER64
hwndOwner AS _UNSIGNED _OFFSET ' HWND
hDevMode AS _UNSIGNED _OFFSET ' HGLOBAL
hDevNames AS _UNSIGNED _OFFSET ' HGLOBAL
hDC AS _UNSIGNED _OFFSET ' HDC
Flags AS _UNSIGNED LONG
Flags2 AS _UNSIGNED LONG
ExclusionFlags AS _UNSIGNED LONG
nPageRanges AS _UNSIGNED LONG
nMaxPageRanges AS _UNSIGNED _INTEGER64
lpPageRanges AS _UNSIGNED _OFFSET ' LPPRINTPAGERANGE
nMinPage AS _UNSIGNED LONG
nMaxPage AS _UNSIGNED LONG
nCopies AS _UNSIGNED _INTEGER64 'LONG
hInstance AS _UNSIGNED _OFFSET ' HINSTANCE
lpPrintTemplateName AS _UNSIGNED _OFFSET ' LPCSTR
lpCallback AS _UNSIGNED _OFFSET ' LPUNKNOWN
nPropertyPages AS _UNSIGNED _INTEGER64 'LONG
lphPropertyPages AS _UNSIGNED _OFFSET ' HPROPSHEETPAGE *
nStartPage AS _UNSIGNED LONG
dwResultAction AS _UNSIGNED LONG
END TYPE
$END IF
DIM pageranges(0 TO 7) AS PRINTPAGERANGE
DIM pde AS PRINTDLGEX
DIM hWnd AS _UNSIGNED _OFFSET
DIM hr AS _UNSIGNED LONG
DIM t AS STRING
DIM t1 AS STRING * 16
DIM doc AS DOCINFOA
hr = PrintDlgExA(_OFFSET(pde))
IF S_OK <> hr THEN PRINT "ZZError. HRESULT: 0x" + LCASE$(HEX$(hr))
PRINT pde.dwResultAction
IF pde.hDevMode THEN SUB_READDEVMODE _OFFSET(pde.hDevMode)
IF pde.hDevNames THEN SUB_READDEVNAMES _OFFSET(pde.hDevNames)
IF PD_RESULT_PRINT = pde.dwResultAction THEN
IF pde.hDC THEN
t1 = "qb64 prn test" + CHR$(0) ' fixed len str so it won't move
doc.cbSize = LEN(doc)
doc.lpszDocName = _OFFSET(t1)
doc.lpszOutput = 0
doc.lpszDatatype = 0
doc.fwType = 0
IF 0 >= StartDocA(pde.hDC, _OFFSET(doc)) THEN PRINT "doc error"
IF 0 >= StartPage(pde.hDC) THEN PRINT "doc error"
IF GDI_ERROR = SetTextAlign(pde.hDC, GetTextAlign(pde.hDC) OR TA_UPDATECP) THEN PRINT "GDI error"
t = "Hello, world!"
IF 0 = TextOutA(pde.hDC, 0, 0, _OFFSET(t), LEN(t)) THEN PRINT "error"
IF 0 >= EndPage(pde.hDC) THEN PRINT "doc error"
IF 0 >= EndDoc(pde.hDC) THEN PRINT "doc error"
END IF
END IF
IF pde.hDevMode THEN
IF 0 <> GlobalFree(pde.hDevMode) THEN PRINT "Error: 0x" + LCASE$(HEX$(GetLastError))
END IF
IF pde.hDevNames THEN
IF 0 <> GlobalFree(pde.hDevNames) THEN PRINT "Error: 0x" + LCASE$(HEX$(GetLastError))
END IF
IF pde.hDC THEN
IF 0 = DeleteDC(pde.hDC) THEN PRINT "Error: 0x" + LCASE$(HEX$(GetLastError))
END IF
END
SUB readDevMode (t AS DEVMODEA)
PRINT t.dmDeviceName
' etc...
END SUB
SUB readDevNames (t AS DEVNAMES)
DIM m AS _MEM
t$ = SPACE$(255)
m = _MEM(_OFFSET(t) + t.wDriverOffset, 255)
_MEMGET m, m.OFFSET, t$
PRINT t$
m = _MEM(_OFFSET(t) + t.wDeviceOffset, 255)
_MEMGET m, m.OFFSET, t$
PRINT t$
m = _MEM(_OFFSET(t) + t.wOutputOffset, 255)
_MEMGET m, m.OFFSET, t$
PRINT t$
'PRINT peekstr(_OFFSET(t) + t.wDriverOffset)
'PRINT peekstr(_OFFSET(t) + t.wDeviceOffset)
'PRINT peekstr(_OFFSET(t) + t.wOutputOffset)
END SUB
DIM SHARED WorkScreen AS LONG, DisplayScreen AS LONG
$RESIZE:ON
WorkScreen = _NEWIMAGE(3600, 2400, 32) ' a nice large screen so we can scroll like crazy
DisplayScreen = _NEWIMAGE(640, 480, 32) 'a nice small display screen
SCREEN DisplayScreen
_DEST WorkScreen
PRINT "Let's print all sorts of stuff on our workscreen, and make certain that it's more than long enough so that it'll scroll quite a ways across from the normal screen."
PRINT
PRINT
LINE (400, 400)-(3000, 1200), &HFFFFFF00, BF
FOR i = 1 TO 145
COLOR _RGB32(RND * 256, RND * 256, RND * 256), 0 'various colors for each line
PRINT "LINE #"; i; ". This is just a bunch of junk for testing purposes only. As you can see, if you want to read all the text from this line, you're going to have to scroll to see it all."
NEXT
StartX = 0: StartY = 0: W = _WIDTH(DisplayScreen): H = _HEIGHT(DisplayScreen)
_DEST DisplayScreen
DO
IF _RESIZE THEN
temp = _NEWIMAGE(_RESIZEWIDTH, _RESIZEHEIGHT, 32)
SCREEN temp
_FREEIMAGE DisplayScreen
DisplayScreen = temp
W = _WIDTH(DisplayScreen): H = _HEIGHT(DisplayScreen)
_DELAY .25
junk = _RESIZE 'clear the resize flag after manually setting the screen to the size we specified.
END IF
_LIMIT 30
CLS
ScrollBar StartX, 2
ScrollBar StartY, 1
k = _KEYHIT
SELECT CASE k
CASE ASC("A"), ASC("a"), 19200: StartX = StartX - 10: IF StartX < 0 THEN StartX = 0
CASE ASC("S"), ASC("s"), 20480: StartY = StartY + 10: IF StartY > _HEIGHT(WorkScreen) - H THEN StartY = _HEIGHT(WorkScreen) - H
CASE ASC("D"), ASC("d"), 19712: StartX = StartX + 10: IF StartX > _WIDTH(WorkScreen) - W THEN StartX = _WIDTH(WorkScreen) - W
CASE ASC("W"), ASC("w"), 18432: StartY = StartY - 10: IF StartY < 0 THEN StartY = 0
END SELECT
WHILE _MOUSEINPUT: WEND
IF _MOUSEBUTTON(1) THEN
IF _MOUSEX > W - 21 AND _MOUSEY < H - 20 THEN 'We're on a up/down scroll bar
StartY = _MOUSEY / _HEIGHT(DisplayScreen) * _HEIGHT(WorkScreen)
IF StartY > _HEIGHT(WorkScreen) - H THEN StartY = _HEIGHT(WorkScreen) - H
END IF
IF _MOUSEY > H - 21 AND _MOUSEX < W - 20 THEN 'we're on the left/right scroll bar
StartX = _MOUSEX / _WIDTH(DisplayScreen) * _WIDTH(WorkScreen)
IF StartX > _WIDTH(WorkScreen) - W THEN StartX = _WIDTH(WorkScreen) - W
END IF
END IF
SUB ScrollBar (Start, Direction)
D = _DEST: _DEST DisplayScreen 'our scrollbars show on the display
Min = 0
MaxH = _HEIGHT(DisplayScreen)
MaxW = _WIDTH(DisplayScreen)
H = _HEIGHT(WorkScreen)
W = _WIDTH(WorkScreen)
IF Direction = 1 THEN 'up/down bar
Box MaxW - 20, 0, 20, MaxH - 20, &HFF777777, &HFFFFFFFF
Box MaxW - 19, Start / H * MaxH, 18, MaxH / H * MaxH - 20, &HFFFF0000, 0 'Red with transparent
ELSE 'left/right bar
Box Min, MaxH - 20, MaxW - 20, 20, &HFF777777, &HFFFFFFFF 'Gray with white border
Box Start / W * MaxW, MaxH - 19, MaxW / W * MaxW - 20, 18, &HFFFF0000, 0 'Red with transparent
END IF
_DEST D
END SUB
SUB Box (x, y, wide, high, kolor AS _UNSIGNED LONG, border AS _UNSIGNED LONG)
LINE (x, y)-STEP(wide, high), kolor, BF
LINE (x, y)-STEP(wide, high), border, B
END SUB
Use arrows (or WASD) to scroll the screen, or press the mousebutton down over the scroll bar and see it in action. Then grab the corner of the screen and resize it, and watch how the scroll bars automatically resize to fit the new dimensions and continue to work as you'd expect them to.
Resizeable program -- Check! Scroll bars for it -- Check!
As the title says, "Scroll bars and resizable programs". We do both things in this little demo. (And now we also do arrow keys and mouse support!)
'Random length string database creation.
'This demo will utilize two different files to manage our database.
'the first one will be the data, and the second will be our index to the data
TYPE RecordType
Name AS STRING
Age AS _BYTE
Sex AS STRING
Phone AS STRING
END TYPE
TYPE IndexType
StartPosition AS LONG
LengthName AS LONG 'track how long the name is
LengthSex AS LONG 'track how long the sex is
LengthPhone AS LONG 'track how long the phone is
END TYPE
DEFLNG A-Z
DIM SHARED Record AS RecordType, Index AS IndexType
DIM SHARED RecordNumber, RecordCount
OPEN "Demo.dba" FOR BINARY AS #1 'the demo database
OPEN "Demo.ndx" FOR BINARY AS #2 'the demo index
RecordCount = LOF(2) \ LEN(Index)
DO
choice = ShowOptions
SELECT CASE choice
CASE 1: AddRecord
CASE 2:
CASE 3:
CASE 4: RecordNumber = RecordNumber - 1: IF RecordNumber < 1 THEN RecordNumber = RecordCount
CASE 5: RecordNumber = RecordNumber + 1: IF RecordNumber > RecordCount THEN RecordNumber = 1
CASE 6: SYSTEM
END SELECT
LOOP
SUB ShowMainInfo
CLS
IF RecordNumber > 0 THEN 'Get the current record and display it
GET #2, (RecordNumber - 1) * LEN(Index) + 1, Index
Record.Name = SPACE$(Index.LengthName)
Record.Sex = SPACE$(Index.LengthSex)
Record.Phone = SPACE$(Index.LengthPhone)
GET #1, Index.StartPosition, Record.Name
GET #1, , Record.Age
GET #1, , Record.Sex
GET #1, , Record.Phone
ELSE
Record.Name = ""
Record.Age = 0
Record.Sex = ""
Record.Phone = ""
END IF
SUB AddRecord
RecordNumber = 0 'Display a blank record
ShowMainInfo
RecordCount = RecordCount + 1 'increase our total count of records
RecordNumber = RecordCount 'And set our current record to the new record count value
PRINT "ENTER Name : "
PRINT "ENTER Age : "
PRINT "ENTER Sex : "
PRINT "ENTER Phone: "
LOCATE 10, 14: INPUT ; ""; Record.Name
LOCATE 11, 14: INPUT ; ""; Record.Age
LOCATE 12, 14: INPUT ; ""; Record.Sex
LOCATE 13, 14: INPUT ; ""; Record.Phone
filesize = LEN(Record.Name) + LEN(Record.Age) + LEN(Record.Sex) + LEN(Record.Phone)
Index.StartPosition = LOF(1) + 1
Index.LengthName = LEN(Record.Name)
Index.LengthSex = LEN(Record.Sex)
Index.LengthPhone = LEN(Record.Phone)
PUT #2, (RecordCount - 1) * LEN(Index) + 1, Index
t$ = Record.Name: PUT #1, LOF(1) + 1, t$ 'We must use a temp string, as we can't put a variable length string type to a file
PUT #1, , Record.Age
t$ = Record.Sex: PUT #1, , t$
t$ = Record.Phone: PUT #1, , t$
END SUB
FUNCTION ShowOptions
ShowMainInfo
PRINT "1) Add Record"
PRINT "2) Delete Record Record (Not Implemented Yet)"
PRINT "3) Edit Record Record (Not Implemented Yet)"
PRINT "4) Previous Record"
PRINT "5) Next Record"
PRINT "6) Quit"
PRINT
PRINT
DO
i$ = INPUT$(1)
SELECT CASE i$
CASE "1" TO "6": ShowOptions = VAL(i$): EXIT FUNCTION
END SELECT
LOOP
END FUNCTION
Folks have recently been talking about how to make databases with BINARY vs RANDOM access, and somebody brought up how they'd manage variable length strings with a database, using line terminations and parsing... (I think it might have been bplus who mentioned that method.)
Here's how I generally work with handling variable length strings with a database.
For each variable length database, I usually use two databases -- one for the data, and one for an index to the data, which is what I'm doing with the above. (Though sometimes, I'll pack both files into one database, with the index being a set positional header, and the data coming after that header -- but I thought I'd show the simplest form of the process first.)
Now, before I let the demo get too complicated that it might turn folks off from looking at it, I'm just going to post the bare bones of the process first. The code above basically doesn't do anything except allow us to ADD RECORDS, and browse those records sequentially -- but it does show how we'd GET/PUT our information, and track where all that information is while on a disk for us.
RecordNumber is the current record that we're looking at RecordCount is the total number of records which our database contains.
"Demo.dba" is the demo database "Demo.ndx" is the demo index
In AddRecord, you can see where we get the information from the user and how we put the proper information onto the drive for us, so we can access it later, and in ShowMainInfo, you can see the process by which we get that information back for us.
Honestly, I don't think there's anything very complicated about what we're doing here, so I really don't know what I need to comment on, or what questions someone might have about the process. If anyone has any specific questions, feel free to ask, and I'll happily answer them, but the process is really very simple:
One file is the user's data, the other file tracks each record's position and lengths inside that file, so we only retrieve and work with what we want, when we want it.
A simple database is included below, but you can freely ignore it if you want. Just run the code above and add your own records and browse them all you want.
(I'd posted this elsewhere, but thought I'd share it here so folks who might not be reading the other topic could locate this and maybe someday reference it, or make use of it, for their own stuff.)
Here's a little something which I tossed together in about 20 minutes this afternoon, which you might be able to use:
Code: (Select All)
Screen _NewImage(1280, 720, 32)
Dim As String prompt(3), results(3)
prompt(0) = "Name": prompt(1) = "Age": prompt(2) = "Sex": prompt(3) = "Phone Number"
For i = 1 To 100 'Draw some stuff on the screen for a background
Line (Rnd * 1280, Rnd * 720)-(Rnd * 1280, Rnd * 720), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF
Next
Print "SLEEPING SO YOU CAN SEE OUR BACKGROUND"
Sleep
MultiInput 100, 100, prompt(), results(), 20
Print: Print "As you can see, when finished, our pop up restored our background..."
Print "And your answers were the following:"
For i = 0 To UBound(results): Print results(i): Next
Sub MultiInput (xPos, yPos, prompt() As String, results() As String, maxLength As Integer)
backupImage = _CopyImage(0) 'copy our screen
B = _Blend: _DontBlend: A = _AutoDisplay: u = UBound(prompt)
For i = 0 To u 'get box size
p = _PrintWidth(prompt(i)): If p > maxWidth Then maxWidth = p
Next
boxWidth = maxWidth + maxLength * _FontWidth + 10: boxheight = (u + 1) * (_FontHeight + 3)
Do
If Timer > t# + .5 Then blink = Not blink: t# = Timer
k = _KeyHit 'get input
Select Case k
Case 18432: selection = selection - 1: If selection < 0 Then selection = u 'up
Case 20480, 13: selection = selection + 1: If selection > u Then selection = 0 'down
Case 27: Exit Do 'esc is the exit/finish code
Case 8: results(selection) = Left$(results(selection), Len(results(selection)) - 1) 'backspace
Case 32 TO 255: results(selection) = results(selection) + Chr$(k) 'all else
End Select
_PutImage , backupImage 'restore background
Line (xPos, yPos)-Step(boxWidth, boxheight), 0, BF: Line (x + xPos + maxWidth + 1, y + yPos)-Step(0, boxheight), -1 'draw box
For i = 0 To u
Line (x + xPos, y + i * (_FontHeight + 3) + yPos)-Step(boxWidth, _FontHeight + 3), -1, B
_PrintString (x + xPos + 2, y + i * (_FontHeight + 3) + yPos + 2), prompt(i)
If i = selection And blink Then out$ = results(i) + Chr$(219) Else out$ = results(i)
_PrintString (x + xPos + maxWidth + 3, y + i * (_FontHeight + 3) + yPos + 2), out$
Next
_Limit 30: _Display
Loop
_PutImage , backupImage
If B Then _Blend
If A Then _AutoDisplay
_FreeImage backupImage
End Sub
45 lines total, and only 33 lines for our SUB, which does all the real work for us.
And what's this do, you ask?
It creates a simple, stand-alone, multi-line, POP-UP input box which we can use the arrow keys to move up and down between.
Usage is rather simple: 1) Dim 2 arrays to hold your prompts and the results. 2) Set your prompts. 3) Call the function, get the results.
$COLOR:32
_DEFINE A-Z AS LONG
SCREEN _NEWIMAGE(1020, 780, 32)
ScreenMove_Middle
PRINT "Your desktop dimensions: "; _DESKTOPWIDTH, _DESKTOPHEIGHT
PRINT "Your program dimensions: "; _WIDTH, _HEIGHT
PRINT "Your program borders : "; glutGet(506)
PRINT "Your program titlebar : "; glutGet(507)
PRINT
PRINT "To properly center your program, it should be at:"
PRINT (_DESKTOPWIDTH - _WIDTH) / 2,
PRINT (_DESKTOPHEIGHT - _HEIGHT) / 2
PRINT
PRINT "Using Screenmove_Middle, it is currently at:"
PRINT glutGet(100), glutGet(101)
PRINT
SLEEP
PRINT "Using _SCREENMOVE _MIDDLE, the screen is placed at:"
_SCREENMOVE _MIDDLE
PRINT glutGet(100), glutGet(101)
PRINT
PRINT "Which, as you can see, doesn't account for our borders or titlebar width and height."
SLEEP
CLS
PRINT "Maybe a better example would be to move the screen to 0,0."
_SCREENMOVE 0, 0
PRINT "Notice how the titlebar and borders are still here?"
PRINT "Our program is actually at: "; glutGet(100), glutGet(101)
SLEEP
ScreenMove 0, 0
PRINT "And notice how our program window now starts at 0,0, like we told it to?"
PRINT "And, as you can see, we're now actually at :"; glutGet(100), glutGet(101)
SLEEP
CLS
PRINT "And, best of all, since all these values are calculated manually, you don't need to worry about using a _DELAY with them, at the beginning of your code, as we're manually setting our X/Y position and not trying to do it automatically."
SUB ScreenMove_Middle
$IF BORDERDEC = UNDEFINED THEN
$LET BORDERDEC = TRUE
DECLARE LIBRARY
FUNCTION glutGet& (BYVAL what&)
END DECLARE
$END IF
BorderWidth = glutGet(506)
TitleBarHeight = glutGet(507)
_SCREENMOVE (_DESKTOPWIDTH - _WIDTH - BorderWidth) / 2 + 1, (_DESKTOPHEIGHT - _HEIGHT - BorderWidth) / 2 - TitleBarHeight + 1
END SUB
SUB ScreenMove (x, y)
$IF BORDERDEC = UNDEFINED THEN
$LET BORDERDEC = TRUE
DECLARE LIBRARY
FUNCTION glutGet& (BYVAL what&)
END DECLARE
$END IF
BorderWidth = glutGet(506)
TitleBarHeight = glutGet(507)
_SCREENMOVE x - BorderWidth, y - BorderWidth - TitleBarHeight
END SUB
Note: I found these subtle positioning differences to be vital for me, in another little batch program which tries to interact with my screen in various ways. Clicks were often not registering as my screen simply wasn't where I expected it to be. A box from (0,0)-(100,100), wasn't really at those coordinates, as it was instead at (borderwidth, borderwidth + titlebarheight)-STEP(100,100)...
Which was more than enough to throw all my work off and cause all sorts of unintentional glitches.
Just something rather neat that I thought I'd share, even if I haven't honestly sorted out an use for it (yet)...
Code: (Select All)
DECLARE CUSTOMTYPE LIBRARY 'Use Customtype for self-referencing a sub written inside your program
SUB SUB_EXAMPLE (BYVAL passed AS _OFFSET) 'this points to SUB EXAMPLE below, but uses an OFFSET to point to its parameter.
'NOTE: The sub/function name *MUST* be the same as QB64 translates it as, for us.
'General rule of thumb is to make the subname ALL CAPS, preceeded by SUB_ or FUNCTION_ as dictated.
SUB SUB_EXAMPLE2 (BYVAL passed AS _OFFSET)
END DECLARE
TYPE DataType 'A datatype to use as an example
x AS STRING * 12
y AS LONG
z AS LONG
END TYPE
TYPE DataType2 'a second datatype
byte1 AS _UNSIGNED _BYTE
byte2 AS _UNSIGNED _BYTE
byte3 AS _UNSIGNED _BYTE
byte4 AS _UNSIGNED _BYTE
byte5 AS _UNSIGNED _BYTE
byte6 AS _UNSIGNED _BYTE
byte7 AS _UNSIGNED _BYTE
byte8 AS _UNSIGNED _BYTE
byte9 AS _UNSIGNED _BYTE
byte10 AS _UNSIGNED _BYTE
byte11 AS _UNSIGNED _BYTE
byte12 AS _UNSIGNED _BYTE
byte13 AS _UNSIGNED _BYTE
byte14 AS _UNSIGNED _BYTE
byte15 AS _UNSIGNED _BYTE
byte16 AS _UNSIGNED _BYTE
byte17 AS _UNSIGNED _BYTE
byte18 AS _UNSIGNED _BYTE
byte19 AS _UNSIGNED _BYTE
byte20 AS _UNSIGNED _BYTE
END TYPE
DIM m AS _MEM 'A memblock to store some information
m = _MEMNEW(20) 'The proper size to fill the data type that we're interested in passing back to our program.
_MEMPUT m, m.OFFSET, "Hello World" '12 bytes
_MEMPUT m, m.OFFSET + 12, -2 AS LONG '4 more
_MEMPUT m, m.OFFSET + 16, 3 AS LONG '4 more to make all 20
SUB_EXAMPLE m.OFFSET 'Call the sub with the offset to these 20 bytes of memory
SLEEP
SUB_EXAMPLE2 m.OFFSET 'Notice, we passed the same block of memory, but are handling it differently here,
' according to the paramters set in the second sub
_MEMFREE m
END
SUB Example (t AS DataType) 'And here, we want to set up the actual sub to work with our example datatype.
PRINT t.x 'print the values of that memblock
PRINT t.y
PRINT t.z
END SUB
SUB Example2 (x AS DataType2)
COLOR 12
PRINT x.byte1
PRINT x.byte2
PRINT x.byte3
PRINT x.byte4
PRINT x.byte5
PRINT x.byte6
PRINT x.byte7
PRINT x.byte8
PRINT x.byte9
PRINT x.byte10
PRINT x.byte11
PRINT x.byte12
PRINT x.byte13
PRINT x.byte14
PRINT x.byte15
PRINT x.byte16
PRINT x.byte17
PRINT x.byte18
PRINT x.byte19
PRINT x.byte20
END SUB
Do
Cls
held$ = ""
result = MBS
left = left - (result And 8) \ 8
right = right - (result And 16) \ 16
middle = middle - (result And 32) \ 32
If result And 64 Then held$ = "Left held"
If result And 128 Then held$ = "Right held"
If result And 256 Then held$ = "Middle held"
If result And 512 Then scroll = scroll + 1
If result And 1024 Then scroll = scroll - 1
Print "MouseX: "; _MouseX
Print "MouseY: "; _MouseY
Print "Left down : "; result And 1
Print "Right down : "; result And 2
Print "Middle down : "; result And 4
Print "Left pressed : "; left
Print "Right pressed : "; right
Print "Middle pressed: "; middle
Print "Mouse Wheel Scrolled: "; scroll
Print
Print "Last held event started at X/Y :"; Mouse_StartX, Mouse_StartY
Print "Last held event ended at X/Y :"; Mouse_EndX, Mouse_EndY
Print held$
_Limit 60
Loop
Function MBS% 'Mouse Button Status
Static StartTimer As _Float
Static ButtonDown As Integer
Static ClickCount As Integer
Const ClickLimit## = 0.2 'Less than 1/4th of a second to down, up a key to count as a CLICK.
' Down longer counts as a HOLD event.
Shared Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
While _MouseInput 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
Select Case Sgn(_MouseWheel)
Case 1: tempMBS = tempMBS Or 512
Case -1: tempMBS = tempMBS Or 1024
End Select
Wend
If _MouseButton(1) Then tempMBS = tempMBS Or 1
If _MouseButton(2) Then tempMBS = tempMBS Or 2
If _MouseButton(3) Then tempMBS = tempMBS Or 4
If StartTimer = 0 Then
If _MouseButton(1) Then 'If a button is pressed, start the timer to see what it does (click or hold)
ButtonDown = 1: StartTimer = Timer(0.01)
Mouse_StartX = _MouseX: Mouse_StartY = _MouseY
ElseIf _MouseButton(2) Then
ButtonDown = 2: StartTimer = Timer(0.01)
Mouse_StartX = _MouseX: Mouse_StartY = _MouseY
ElseIf _MouseButton(3) Then
ButtonDown = 3: StartTimer = Timer(0.01)
Mouse_StartX = _MouseX: Mouse_StartY = _MouseY
End If
Else
BD = ButtonDown Mod 3
If BD = 0 Then BD = 3
If Timer(0.01) - StartTimer <= ClickLimit Then 'Button was down, then up, within time limit. It's a click
If _MouseButton(BD) = 0 Then tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0
Else
If _MouseButton(BD) = 0 Then 'hold event has now ended
tempMBS = 0: ButtonDown = 0: StartTimer = 0
Mouse_EndX = _MouseX: Mouse_EndY = _MouseY
Else 'We've now started the hold event
tempMBS = tempMBS Or 32 * 2 ^ ButtonDown
End If
End If
End If
MBS = tempMBS
End Function
I had one of these somewhere before, but I'll be danged if I can find it, so I rolled another one...
A simple routine to check the mouse buttons and to give us information on up/down, click, and hold statuses, as well as hold start/stop positions. Results are all stored in a single binary integer, and basically break down to:
1 -- left down 2 -- right down 4 -- middle down 8 -- left clicked 16 -- right clicked 32 -- middle clicked 64 -- left held 128 -- right held 256 -- middle held 512 -- scroll down 1024 -- scroll up
Starting X/Y and Ending X/Y positions are available in the shared Mouse_ variables.
Note, HOLD and CLICK events are independent of each other. We don't register a free click with each hold event. Windows tends to count first down events as clicks, so all hold events start with a click event and then transition into a hold event. I didn't need that for my purposes, so this will either give you a hold event OR a click event; not both.
Tutorial: How to turn a QB64 interpreter into a compiler.
(WINDOWS ONLY!)
Several of our members have made excellent interpreters in QB64 that run BAS code. I ported one of mine to QB64, and wanted to take it further and make it an compiler that turn BAS code in standalone EXE's. Here's a tutorial on how I did it. With this method you can make your own EXE producing compiler in QB64.
It's easier to explain the method by just going through the steps of making one, so in this tutorial we will turn a small interpreter into a EXE producing compiler. Please note - this is not a 'true' compiler, but more like a 'bytecode' one. The EXE's produced are merely a special interpreter with source coded binded to it - Like RapidQ and other basic compilers out there do. The EXE's will read itself and run the attached code. I've attached all the needed source files to this post at the bottom for easier saving. So...Download all the attached BAS files before we begin.
STEP #1) Compile the MarkExeSize.bas tool to an EXE first. The interpreter and compiler EXE's we make here will need to be marked by that tool. You can read what MarkExeSize does in its source code.
(MarkExeBas.bas)
Code: (Select All)
'===============
'MarkExeSize.bas
'===============
'Marks QB64 compiled EXE's with its EXE data size.
'Coded by Dav, JAN/2021
'WINDOWS ONLY!
'This helps facilitate using appended data on the EXE.
'It saves the compiled EXE size to the EXE file, so
'the program can read that info and jump to its data.
'It does this by borrowing some space near the top of
'the EXE file. It shortens 'This program cannot be run
'in DOS mode.' to 'This program can't run in DOS mode.' and
'uses those 4 gained spaces to save EXE file size instead.
'=======================================================
'Example...after you mark your EXE file, it can do this:
'=======
'OPEN COMMAND$(0) FOR BINARY AS 1 'Open itself up...
'test$ = INPUT$(200, 1) 'grab a little info
'place = INSTR(1, test$, "This program can't") 'look for words
'IF place = 0 THEN PRINT "No data found.": CLOSE: END
'grab exesize info...
'SEEK 1, place + 35: ExeSize& = CVL(INPUT$(4, 1))
'Go there....
'SEEK 1, ExeSize& + 1 'where appended data begins
'=======================================================
'NOTE: Always mark the EXE before appending data to it.
' If you use EXE compressors, like UPX, mark the EXE
' AFTER using UPX, not before, otherwise the info won't
' be read correctly by your program.
IF COMMAND$ = "" THEN
INPUT "EXE to Mark -->", exe$
PRINT
ELSE
exe$ = COMMAND$
END IF
IF exe$ = "" THEN END
IF NOT _FILEEXISTS(exe$) THEN
PRINT "File not found.": END
END IF
OPEN exe$ FOR BINARY AS 1
'find location of place to mark
test$ = INPUT$(200, 1)
place = INSTR(1, test$, "This program can")
IF place = 0 THEN
PRINT "This file is not markable."
CLOSE: END
END IF
'jump to location
SEEK 1, place
look$ = INPUT$(19, 1) 'grab a little info
SELECT CASE look$
CASE IS = "This program cannot"
'mark/overwrite exe file info file with new info
PRINT "Marking file "; exe$
PRINT
PRINT "EXE files size:"; LOF(1)
PRINT "Data start loc:"; LOF(1) + 1
new$ = "This program can't run in DOS mode." + MKL$(LOF(1))
PUT 1, place, new$
PRINT: PRINT "Done."
CASE IS = "This program can't "
PRINT "EXE already appears to be marked."
PRINT
SEEK 1, place + 35: datastart& = CVL(INPUT$(4, 1))
PRINT "EXE files size:"; LOF(1)
PRINT "Data start loc:"; datastart& + 1
PRINT "Size of data :"; LOF(1) - datastart&
CASE ELSE
PRINT "EXE is not markable."
END SELECT
CLOSE
STEP #2) Compile the sample interpreter.bas to EXE. This is just an example interpreter. The main thing is that this interpreter is made to open itself up when run, and load source code attached to itself, instead of loading an external BAS file. Think of it as the runtime file. But don't attach any BAS code to it yet, just compile it for now. (When using your own interpreter you will need to adapt it to load code this way too).
(interpreter.bas)
Code: (Select All)
'Mini Interpreter runtime.
'A compiled EXE of this runs BAS code attached to it.
DIM Code$(100) 'space for 100 lines
'==========================================================
OPEN COMMAND$(0) FOR BINARY AS 1
place = INSTR(1, INPUT$(200, 1), "This program can't")
IF place = 0 THEN
CLOSE: END
ELSE
SEEK 1, place + 35: ExeSize& = CVL(INPUT$(4, 1))
END IF
'==========================================================
'Make sure something is attached to exe...
IF ExeSize& + 1 > LOF(1) THEN END
SEEK 1, ExeSize& + 1
Lines = 1
WHILE NOT EOF(1)
LINE INPUT #1, c$
Code$(Lines) = c$
Lines = Lines + 1
WEND
CLOSE 1
FOR t = 1 TO Lines
ExecuteLine Code$(t)
NEXT
SUB ExecuteLine (cmd$)
cmd$ = LTRIM$(RTRIM$(cmd$))
IF LEFT$(cmd$, 1) = "'" THEN EXIT SUB
IF UCASE$(LEFT$(cmd$, 3)) = "REM" THEN EXIT SUB
IF UCASE$(LEFT$(cmd$, 5)) = "SLEEP" THEN SLEEP
IF UCASE$(cmd$) = "BEEP" THEN BEEP
IF UCASE$(LEFT$(cmd$, 6)) = "COLOR " THEN
COLOR VAL(RIGHT$(cmd$, LEN(cmd$) - 6))
END IF
IF UCASE$(cmd$) = "PRINT" THEN PRINT
IF UCASE$(LEFT$(cmd$, 7)) = "PRINT " + CHR$(34) THEN
PRINT MID$(cmd$, 8, LEN(cmd$) - 8)
END IF
IF UCASE$(LEFT$(cmd$, 3)) = "CLS" THEN CLS
IF UCASE$(LEFT$(cmd$, 3)) = "END" THEN END
END SUB
STEP #3) Compile the compiler.bas to EXE. This little programs whole job is to combine the interpreter+source code together. But - It will have the interpreter runtime attached to it eventually, like the interpreter has code attached to it. We will attach that later. For now just compile it...
(compiler.bas)
Code: (Select All)
'Mini Compiler example
PRINT
PRINT "A Mini .BAS Compiler"
PRINT "Compile .BAS to .EXE"
PRINT
INPUT "BAS to open ->", in$: IF in$ = "" THEN END
INPUT "EXE to make ->", out$: IF out$ = "" THEN END
'First see if this EXE is marked...
OPEN COMMAND$(0) FOR BINARY AS 1
place = INSTR(1, INPUT$(200, 1), "This program can't")
IF place = 0 THEN CLOSE: END
'Grab EXE size info
SEEK 1, place + 35: ExeSize& = CVL(INPUT$(4, 1))
'Make sure data attached...
IF ExeSize& + 1 > LOF(1) THEN END
'Jump to data
SEEK 1, ExeSize& + 1
'Extract data, make EXE file...
OPEN out$ FOR OUTPUT AS 2
outdata$ = INPUT$(LOF(1) - ExeSize&, 1)
PRINT #2, outdata$;: outdata$ = ""
'Add/attach BAS code to EXE
OPEN in$ FOR BINARY AS 3
outdata$ = INPUT$(LOF(3), 3)
PRINT #2, outdata$;
CLOSE
PRINT "Made "; out$
END
OPTIONAL STEP: At this point you could run UPX on those EXE's to reduce their size down to about 500k. You will have to download UPX from off the internet. I use it a lot. Works well on QB64 generated EXE's. Make sure if you do this step, that you do it right here - BEFORE using MarkExeSize on them.
STEP #4) Now use the MarkExeSize.exe tool on both the interpreter.exe and compiler.exe programs. It saves their EXE size in the EXE's. IMPORTANT: This is a needed step. Without it, the EXE's won't know how to open a file attached to them.
STEP #5) Now it's time to make the mini.exe compiler program. Drop to a command prompt, into the folder where the new EXE's are, and combine both the compiler.exe+interpreter.exe files like this, making a new file called mini.exe:
copy /b compiler.exe+interpreter.exe mini.exe
If all went well, You just made a new EXE file called mini.exe. It's the whole compiler that contains the interpreter runtime too. Run mini.exe, and you can now compile the demo.bas below. It will generate a demo.exe out of it. The interpreter.exe & compiler.exe are no longer needed - mini.exe is the only thing needed to make the EXE files from BAS code.
(demo.bas)
Code: (Select All)
REM Sample program
COLOR 3
PRINT "Hit any key to clear..."
SLEEP
BEEP
CLS
COLOR 15
PRINT "Cleared!"
END
Final comments:The example here is just a simple interpreter, just to show you how to do yours. Be aware that unless you encode/decode your source code on the interpreter, people will be able to open up your EXE and see the source code, so I would put in an encoding/decoding method in your interpreter.
Try building this sample first, and you will see how easy it is to turn your interpreter into a byte-code compiler using QB64. Start your own programming language!
