A quick little InForm project to test a couple buttons and some textbox, translate a secret message or decode one.
Code: (Select All)
'Cryptogram.bas for QB64 version 1106 just before 1.2 number change
' first test of Inform beta 7, B+ 2018-06-02
' now to figure out all the files that are needed to distribute this tiny little test
': This program uses
': InForm - GUI library for QB64 - Beta version 7
': Fellippe Heitor, 2016-2018 - fellippe@qb64.org - [url=https://qb64phoenix.com/forum/member.php?action=profile&uid=325]@fellippeheitor[/url]
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
': Controls' IDs: ------------------------------------------------------------------
Rem NOTICE: THIS FORM HAS BEEN RECENTLY EDITED
'>> The controls in the list below may have been added or renamed,
'>> and previously existing controls may have been deleted since
'>> this program's structure was first generated.
'>> Make sure to check your code in the events SUBs so that
'>> you can take your recent edits into consideration.
' and I lost all the following code!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Secret Santa 3.bas for QB64 B+ 2018-05-01
' based on versions of Secret Santa I did in JB 2016-12-03
' the letters and digits want to give each other presents at Christmas
' if A is Santa to B, then B can't also be Santa to A (or B)
'To keep Code more secret randomize with a secret seed known only to you and intended reciever
secret## = 3254760 '< user and reciever should Enter this number
Randomize secret##
Dim Shared letters$, Reform$, Code$
letters$ = "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz1234567890"
L = Len(letters$)
Dim LS$(L)
'laod array
For i = 1 To L
LS$(i) = Mid$(letters$, i, 1)
Next
'scramble array Knuth Shuffle method
For i = L To 2 Step -1
R = Int(i * Rnd) + 1
Swap LS$(i), LS$(R)
Next
'now reform the Letters
Reform$ = ""
For i = 1 To L
Reform$ = Reform$ + LS$(i)
Next
' Here is simple trick to non repetition > pair the letter with the next one up!!!
Code$ = ""
For i = 1 To L - 1
Code$ = Code$ + Mid$(Reform$, i + 1, 1)
Next
'catch last letter pair to first
Code$ = Code$ + Mid$(Reform$, 1, 1)
': ---------------------------------------------------------------------------------
Dim Shared Cryptogram As Long
Dim Shared lbMessage As Long
Dim Shared tbMessage As Long
Dim Shared btCode As Long
Dim Shared lbCoded As Long
Dim Shared tbCode As Long
Dim Shared btDecode As Long
Dim Shared lbCodeMessage As Long
Dim Shared lbDecodedMessage As Long
Function encrypt$ (codeThis$)
For i = 1 To Len(codeThis$)
c$ = Mid$(codeThis$, i, 1)
If InStr(letters$, c$) = 0 Then coded$ = coded$ + c$ Else coded$ = coded$ + encryptChar$(Mid$(codeThis$, i, 1))
Next
encrypt$ = coded$
End Function
Function decode$ (This$)
For i = 1 To Len(This$)
c$ = Mid$(This$, i, 1)
If InStr(letters$, c$) = 0 Then dc$ = dc$ + c$ Else dc$ = dc$ + decodeChar$(Mid$(This$, i, 1))
Next
decode$ = dc$
End Function
Function encryptChar$ (forLetter$)
p = InStr(Reform$, forLetter$)
encryptChar$ = Mid$(Code$, p, 1)
End Function
Function decodeChar$ (Letter$)
p = InStr(Code$, Letter$)
decodeChar$ = Mid$(Reform$, p, 1)
End Function
': Event procedures: ---------------------------------------------------------------
Sub __UI_BeforeInit
End Sub
Sub __UI_OnLoad
End Sub
Sub __UI_BeforeUpdateDisplay
'This event occurs at approximately 30 frames per second.
'You can change the update frequency by calling SetFrameRate DesiredRate%
End Sub
Sub __UI_BeforeUnload
'If you set __UI_UnloadSignal = False here you can
'cancel the user's request to close.
End Sub
Sub __UI_Click (id As Long)
Select Case id
Case Cryptogram
Case lbMessage
Case tbMessage
Case btCode
Caption(lbCodeMessage) = encrypt$(Text(tbMessage))
Case lbCoded
Case tbCode
Case btDecode
Caption(lbDecodedMessage) = decode$(Text(tbCode))
'SetFocus tbMessage works
End Select
End Sub
Sub __UI_MouseEnter (id As Long)
Select Case id
Case Cryptogram
Case lbMessage
Case tbMessage
Case btCode
Case lbCoded
Case tbCode
Case btDecode
End Select
End Sub
Sub __UI_MouseLeave (id As Long)
Select Case id
Case Cryptogram
Case lbMessage
Case tbMessage
Case btCode
Case lbCoded
Case tbCode
Case btDecode
End Select
End Sub
Sub __UI_FocusIn (id As Long)
Select Case id
Case tbMessage
Case btCode
Case tbCode
Case btDecode
End Select
End Sub
Sub __UI_FocusOut (id As Long)
'This event occurs right before a control loses focus.
'To prevent a control from losing focus, set __UI_KeepFocus = True below.
Select Case id
Case tbMessage
Case btCode
Case tbCode
Case btDecode
End Select
End Sub
Sub __UI_MouseDown (id As Long)
Select Case id
Case Cryptogram
Case lbMessage
Case tbMessage
Case btCode
Case lbCoded
Case tbCode
Case btDecode
End Select
End Sub
Sub __UI_MouseUp (id As Long)
Select Case id
Case Cryptogram
Case lbMessage
Case tbMessage
Case btCode
Case lbCoded
Case tbCode
Case btDecode
End Select
End Sub
Sub __UI_KeyPress (id As Long)
'When this event is fired, __UI_KeyHit will contain the code of the key hit.
'You can change it and even cancel it by making it = 0
Select Case id
Case tbMessage
Case btCode
Case tbCode
Case btDecode
End Select
End Sub
Sub __UI_TextChanged (id As Long)
Select Case id
Case tbMessage
Case tbCode
End Select
End Sub
Sub __UI_ValueChanged (id As Long)
Select Case id
End Select
End Sub
Sub __UI_FormResized
End Sub
'$Include:'InForm\InForm.ui'
.frm code too?
Code: (Select All)
': This form was generated by
': InForm - GUI library for QB64 - Beta version 7
': Fellippe Heitor, 2016-2018 - fellippe@qb64.org - [url=https://qb64phoenix.com/forum/member.php?action=profile&uid=325]@fellippeheitor[/url]
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
Posted by: bobalooie - 01-27-2026, 01:47 AM - Forum: In-Form
- No Replies
My second attempt with Inform
Before I retired, I was a professional electrical engineer. I have done a lot of electrical site work, which included street/path lighting, outlets for street tree systems (holiday lights), ball field lighting, etc. Good engineering practice requires that the voltage drops through the system must be evaluated because the National Electrical Code mandates that the total voltage drop in total through the system must not exceed 3% of the supply voltage. For example, on a 240V circuit, the voltage at the end of the circuit may not be less than 232.8V.
I have boring Excel spreadsheets to facilitate the calculation, but I saw an oppo to try something new.
The program calculates the voltage drop in the circuit between each pair of nodes as well as a total voltage drop from source to end. Those of you who know Ohm's Law will get it. Feel free to play with it.
Excel has long been a favorite tool of mine for working with simple lists & tabulated data.
For personal use, I don't usually need the fancy connecting to database servers with power query or even pivot tables. It's just very useful to have a grid that you can easily copy & paste to & from a basic table in Word (or a rich text editor), tab-delimited text in Notepad, or from HTML tables, and then play with using Excel's formulas and my own VBA macros.
Anyway, it's not broke (yet) but with all the annoying and constant changes Microsoft is determined to force on us (the latest annoyance being the macro recorder now records "Office scripts" by default instead of the standard VBA macros, which although you can disable it, is just another unwanted change and a sign that MS is moving to phase BASIC out of their products (vbscript is already on the chopping block)). Also the cost of Office means you can't share this stuff with someone if they don't have a subscription.
So I started thinking about alternatatives. You have Google Sheets, which is Web-based and depends on their whole ecosystem and doesn't use a BASIC dialect for writing macros. Not to mention they now are using our data to train their ai and for whatever purpose they want. Hard pass.
The obvious choice would be QB64PE!
Has anyone played around with implementing an Excel-like grid, that can hold a large number of rows/columns comparable to Excel, that you can select cells in, which can be cut, copied & pasted with the standard Ctrl-x, Ctrl-c, Ctrl-v, to & from say, a Word table, or from an HTML table, or to/from Notepad as tab-delimited text? The next step would be implementing some basic formulas, which would just be QB64PE functions.
Any thoughts? Is this something that could be done with InForm? (I have yet to dive into that yet.)
If this is ridiculously hard then so be it, but I thought I would ask...
Hi
following the invite of moderator of this section of the forum dedicated to Inform I post here a bunch of links to my applications made with Informpe or the older Inform (made with previous Inform until 7.0 it seems to remember so, and with Falcon.h library) and ported to Inform_PE.
The news that I found very interesting are:
1. different (indipendent) path of Inform application (the older needed to stay in the same folder of QB64pe) towards QB64pe folder
2. independency from Falcon.h library that arises from the files in the added folder extensions
here the links to the thread of my Informpe Applications already published on this forum in other sections (so we avoid to duplicate the pages and files on this forum)
the 21 game in which there is also the discussion on how to share Informpe applications (in sum: better to install Informpe than downloading and extracting in each project's folder the ResourcePack taken here InformPE resource pack or from here InformPE resource pack)
Encrypt/Decrypt: a demo of cryptography: a simple cryptographic machine with old methods by substitution one to one of the character of the message with different ways to calculate the forward and backward character.
From Listbox to graphic view: a simple program that draws points on a positive cartesian area with x and y cohordinates using .CSV file for sharing data input and output
The Speed Bible of coding in QB64pe: a program for tutorial in getting faster code written in QB64pe. The application is an example to open a webpage, to show a list of arguments, to show a file in a large area of text (Informpe hasn't any multilinetextbox or similar container/item to show massive text in a window. Here I use a picturebox on which I draw the text that is scrollable via keyboard).
You can read the code (the more snippets are written by me and someone can be more raw but all they go straight to the goal of showing the argument selected) and run it via QB64pe after compiling it.
The contents (tips and rules) cames out from a talking in a thread, some from the "Amazing Steve", others from the Developers Team and Expert coders. I tried to give all of them the credits.
My idea of a good Solitaire is one that has no distractions or goofy audio/visual "rewards". Just you and a simulated card deck. I like it to be like the old Windows 3.1 Solitaire.
After suffering long enough on a Solitaire that made me sit through ads every two or three hands, I decided to write my own damn version. I calls it Quiet Solitaire. It's a little buggy still, but I've clocked many hours on it without major issues.
Left mouse to flip a card, or choose a pile to move, second left mouse on pile to move it to.
Right mouse on cards to be moved to the foundation piles.
Hotkey D for new deal, esc to quit, and that's about all there is to this one, unless one counts the Easter egg.
TYPE V2 ' Position (x, y) Vector <x, y> pair
x AS INTEGER
y AS INTEGER
END TYPE
TYPE region
ul AS V2 ' upper left position
lr AS V2 ' lower right position
END TYPE
TYPE card
in AS INTEGER ' index of card
rk AS INTEGER ' rank of card (A,2,3,4,5,6,7,8,9,10,J,Q,K) sequential from 1 to 13
st AS INTEGER ' suit of card (2-5) black even, red odd
im AS LONG ' image handle of card
fc AS _BYTE ' facing of card (up=true, down=false)
END TYPE
DIM SHARED Main&
Main& = _NEWIMAGE(680, 540, 32)
SCREEN Main&
DO: LOOP UNTIL _SCREENEXISTS
_SCREENMOVE 5, 5
DIM SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
DIM AS INTEGER tog
tog = 0
DIM SHARED deck(52) AS card ' The Deck
DIM SHARED transfer AS INTEGER ' stack movement flag
DIM SHARED fromPile AS INTEGER ' stack moved from
REDIM SHARED pick%(13) ' moving array
DIM CardDeck&
CardDeck& = _LOADIMAGE(_EMBEDDED$("Carddeck"), 32, "memory")
IF CardDeck& = -1 THEN PRINT "Cards.png failed to load, bye!": END
DIM rank%, suit%
DIM AS INTEGER SW, SH, SPRow, SPCol, Peektop
rank% = 1: suit% = 1
SW = 72: SH = 96: SPRow = 13: SPCol = 4: Peektop = 18
CONST back = 10 ' display offset for face down cards in build stacks
CONST face = 24 ' display offset for face up cards in build stacks
CONST TRUE = -1
CONST FALSE = 0
' cards 72 x 96 3x4
deck(0).im = _NEWIMAGE(72, 96, 32) ' create card back image
_PUTIMAGE , CardDeck&, deck(0).im, (13 * SW, 0 * SH)-STEP(SW, SH) 'put card back sprite in image handle
'original sprite order: clubs spades hearts diamonds swap spades and hearts to align even/odd suit numbering to red/black
DIM x%, sheetx%, sheety%
suit% = 2
FOR x% = 1 TO 52
deck(x%).in = x%
deck(x%).rk = rank%
deck(x%).st = suit% '
deck(x%).im = _NEWIMAGE(72, 96, 32)
deck(x%).fc = 0
sheetx% = ((x% - 1) MOD SPRow) * SW
SELECT CASE x%
CASE 1 TO 13 ' Clubs suit=1
sheety% = 0 '
CASE 14 TO 26 ' Spades to Hearts suit=2
sheety% = 2 * SH
CASE 27 TO 39 ' Hearts to Spades suit=3
sheety% = SH
CASE 40 TO 52 ' Diamonds suit=4
sheety% = 3 * SH
END SELECT
_PUTIMAGE , CardDeck&, deck(x%).im, (sheetx%, sheety%)-STEP(SW, SH)
rank% = rank% + 1 ' Ace to King ascending
IF x% MOD 13 = 0 THEN
suit% = suit% + 1
rank% = 1
END IF
NEXT x%
DIM SHARED A(52) AS INTEGER
FOR x% = 1 TO 52: A(x%) = x%: NEXT x%
Initialize
Card_Refresh
DIM dn%, k$, in%, ms
dn% = 0
DO
DO
k$ = INKEY$
IF k$ = CHR$(27) THEN in% = -1: dn% = -1
IF k$ = CHR$(116) THEN tog = NOT tog: in% = -1 'Cheating Easter egg
IF k$ = CHR$(108) THEN 'load
Load_Hand
Card_Refresh
END IF
IF k$ = CHR$(115) THEN 'save
Save_Hand
END IF
IF k$ = CHR$(100) THEN
Initialize
in% = -1
END IF
ms = MBS%
mp.x = _MOUSEX: mp.y = _MOUSEY
IF ms AND 1 THEN
Clear_MB 1
Mouse_Left mp
in% = -1
END IF
IF ms AND 2 THEN
Clear_MB 2
Mouse_Right mp
in% = -1
END IF
_LIMIT 30
LOOP UNTIL in%
in% = 0
IF tog THEN
Card_List
ELSE
Card_Refresh
END IF
IF Victory_Check% THEN
_PRINTSTRING (_WIDTH / 2 - 32, _HEIGHT / 2), "Winner!"
END IF
_DISPLAY
LOOP UNTIL dn%
END
'---------------------------------------------------------------
SUB Analyze_Stack (down AS INTEGER, up AS INTEGER, index AS INTEGER)
DIM x%
down = 0
up = 0
x% = 0
DO UNTIL stack(index, x%) = 0
SELECT CASE deck(stack(index, x%)).fc
CASE TRUE: up = up + 1 ' count face up
CASE FALSE: down = down + 1 ' count face down
END SELECT
x% = x% + 1
LOOP
END SUB 'Analyze_Stack
'---------------------------------------------------------------
SUB Box_Region (b AS region, c AS LONG, t AS INTEGER)
DIM x%
FOR x% = 0 TO t - 1
LINE (b.ul.x + x%, b.ul.y + x%)-(b.lr.x - x%, b.lr.y - x%), c, B
NEXT x%
END SUB 'Box_Region
'---------------------------------------------------------------debugging and cheating Easter egg
SUB Card_List
DIM bld%, ace%, dn%, up%, y%, r%, num$, suit$
DIM AS INTEGER ypos
CLS
FOR ace% = 2 TO 5
ypos = 0: r% = 0
Box_Region tpstk(ace%), Red, 1
Analyze_Stack dn%, up%, ace%
IF up% > 0 THEN
FOR y% = 1 TO up%
num$ = Rank_Name$(deck(stack(ace%, r%)))
suit$ = Suit_Name$(deck(stack(ace%, r%)))
_PRINTSTRING (tpstk(ace%).ul.x, ypos), LEFT$(num$, 4) + LEFT$(suit$, 4)
ypos = ypos + 16 ' increment ypos by back constant
r% = r% + 1
NEXT y%
END IF
NEXT ace%
FOR bld% = 6 TO 12
r% = 0
ypos = tpstk(bld%).ul.y
Box_Region tpstk(bld%), &HFFFF0000, 1
Analyze_Stack dn%, up%, bld%
'place any face down cards
IF dn% > 0 THEN
FOR y% = 1 TO dn%
COLOR &HFFFF0000
num$ = Rank_Name$(deck(stack(bld%, r%)))
suit$ = Suit_Name$(deck(stack(bld%, r%)))
_PRINTSTRING (tpstk(bld%).ul.x, ypos), LEFT$(num$, 4) + LEFT$(suit$, 4)
ypos = ypos + 16 ' increment ypos by back constant
r% = r% + 1
NEXT y%
END IF
'place any face up cards
IF up% > 0 THEN
FOR y% = 1 TO up%
COLOR &HFFFFFFFF
num$ = Rank_Name$(deck(stack(bld%, r%)))
suit$ = Suit_Name$(deck(stack(bld%, r%)))
_PRINTSTRING (tpstk(bld%).ul.x, ypos), LEFT$(num$, 4) + LEFT$(suit$, 4)
ypos = ypos + 16 ' increment ypos by face constant
r% = r% + 1
NEXT y%
END IF
NEXT bld%
Box_Region tpstk(0), &HFFFF0000, 1
Analyze_Stack dn%, up%, 0
FOR y% = 0 TO dn% - 1
_PRINTSTRING (5, _HEIGHT - (20 + y% * 16)), Rank_Name$(deck(stack(0, y%))) + " of " + Suit_Name$(deck(stack(0, y%)))
NEXT y%
Analyze_Stack dn%, up%, 1
FOR y% = 0 TO up% - 1
_PRINTSTRING (200, _HEIGHT - (20 + y% * 16)), Rank_Name$(deck(stack(1, y%))) + " of " + Suit_Name$(deck(stack(1, y%)))
NEXT y%
END SUB 'Card_List
'---------------------------------------------------------------
SUB Card_Refresh
DIM AS INTEGER ypos
DIM x%, y%, r%, trash%, ace%, bld%, up%, dn%
DIM img&, mc&, q&, px&
DIM AS V2 mid
DIM m AS _MEM
CLS , Green
IF UpCheck% AND NOT Victory_Check% THEN 'set a flag to reveal the solve button if ready for solution but not yet done
Box_Region sbut, Red, 3
Mid_Region mid, sbut
_PRINTSTRING (mid.x - 20, mid.y - 8), "Solve"
END IF
IF stack(0, 0) <> 0 THEN '..................................Stock Stack
trash% = Image_Region(tpstk(0), deck(0).im, Main&, "c", "c")
ELSE
Box_Region tpstk(0), &HFFFF0000, 1
END IF
IF stack(1, 0) <> 0 THEN '..................................Waste Stack
x% = 0
DO UNTIL stack(1, x% + 1) = 0
x% = x% + 1
LOOP
IF transfer AND fromPile = 1 THEN
'negative
img& = _COPYIMAGE(deck(stack(1, x%)).im)
m = _MEMIMAGE(img&)
mc& = 0
DO
_MEMGET m, m.OFFSET + mc& * 4, px&
q& = Negative&(px&)
_MEMPUT m, m.OFFSET + mc& * 4, q&
mc& = mc& + 1
LOOP UNTIL mc& * 4 = m.SIZE - 4
_PUTIMAGE (tpstk(1).ul.x, tpstk(1).ul.y), img&
_MEMFREE m
IF img& < -1 THEN _FREEIMAGE img&
ELSE
trash% = Image_Region(tpstk(1), deck(stack(1, x%)).im, Main&, "c", "c")
END IF
ELSE
Box_Region tpstk(1), &HFFFF0000, 1
END IF
'STACK 2 - 5
FOR ace% = 2 TO 5 '.........................................Foundation Stacks
IF stack(ace%, 0) <> 0 THEN
'show the topmost
Analyze_Stack dn%, up%, ace%
IF up% + dn% > 0 THEN
trash% = Image_Region(tpstk(ace%), deck(stack(ace%, up% + dn% - 1)).im, Main&, "c", "c")
END IF
ELSE
DIM tc AS V2
Box_Region tpstk(ace%), &HFFFF0000, 1
Mid_Region tc, tpstk(ace%)
_PRINTSTRING (tc.x - _SHL(LEN(suitname$(ace%)), 2), tc.y - 8), suitname$(ace%)
END IF
NEXT ace%
FOR bld% = 6 TO 12 '........................................Tableau Stacks
r% = 0
ypos = tpstk(bld%).ul.y
Analyze_Stack dn%, up%, bld%
'place any face down cards
IF dn% > 0 THEN
FOR y% = 1 TO dn%
_PUTIMAGE (tpstk(bld%).ul.x, ypos), deck(0).im 'place card back
ypos = ypos + back ' increment ypos by back constant
r% = r% + 1
NEXT y%
END IF
'place any face up cards
IF up% > 0 THEN
FOR y% = 1 TO up%
_PUTIMAGE (tpstk(bld%).ul.x, ypos), deck(stack(bld%, r%)).im 'place card face
IF transfer AND bld% = fromPile THEN
img& = _COPYIMAGE(deck(stack(bld%, r%)).im)
m = _MEMIMAGE(img&)
mc& = 0
DO
_MEMGET m, m.OFFSET + mc& * 4, px&
q& = Negative&(px&)
_MEMPUT m, m.OFFSET + mc& * 4, q&
mc& = mc& + 1
LOOP UNTIL mc& * 4 = m.SIZE - 4
_PUTIMAGE (tpstk(bld%).ul.x, ypos), img&
_MEMFREE m
IF img& < -1 THEN _FREEIMAGE img&
END IF
ypos = ypos + face ' increment ypos by face constant
r% = r% + 1
NEXT y%
END IF
NEXT bld%
_PRINTMODE _KEEPBACKGROUND
_PRINTSTRING (5, _HEIGHT - 17), "d = deal l = load s = save esc = quit"
END SUB 'Card_Refresh
'---------------------------------------------------------------
'Description
'Clear the mousebutton queue - only releases when button released
SUB Clear_MB (var AS INTEGER)
DO UNTIL NOT _MOUSEBUTTON(var)
_LIMIT 30
WHILE _MOUSEINPUT: WEND
LOOP
END SUB 'Clear_MB
'---------------------------------------------------------------
SUB Deal
DIM x%, r%, dr%, st%
DO
FOR st% = 6 TO 12
IF st% - 6 - r% < 0 THEN
stack(st%, r%) = 0 ' put a zero where no card on the deal
ELSE
x% = x% + 1 ' index for next card
stack(st%, r%) = A(x%) ' place card x% on stack st% and rank r%
deck(A(x%)).fc = _IIF(st% - 6 - r% = 0, -1, 0) 'face up first card of the stack rank
END IF
NEXT st%
r% = r% + 1
LOOP UNTIL r% = 7
DO ' put the rest in the draw
x% = x% + 1
deck(A(x%)).fc = 0
stack(0, dr%) = A(x%)
dr% = dr% + 1
LOOP UNTIL x% = 52
DO
stack(0, dr%) = 0
dr% = dr% + 1
LOOP UNTIL dr% = 53
transfer = 0
END SUB 'Deal
'---------------------------------------------------------------
FUNCTION Go% (from AS INTEGER, tto AS INTEGER)
DIM r%, s%
r% = deck(from).rk = deck(tto).rk - 1
s% = deck(from).st MOD 2 <> deck(tto).st MOD 2
Go% = _IIF(r%, _IIF(s%, TRUE, FALSE), FALSE)
END FUNCTION 'Go%
'---------------------------------------------------------------
FUNCTION Image_Region (r AS region, i AS LONG, d AS LONG, xj AS STRING, yj AS STRING)
DIM AS INTEGER xs, ys, xp, yp, xl, yl ' ready for OPTION EXPLICIT programs
xp = r.ul.x: yp = r.ul.y: xl = r.lr.x: yl = r.lr.y ' isolate sent parameters from any changes
DIM AS SINGLE rt, xrt, yrt
xrt = (xl - xp) / _WIDTH(i) ' width of area divided by width of image
yrt = (yl - yp) / _HEIGHT(i) ' height of area divided by height of image
rt = _IIF(xrt < yrt, xrt, yrt) ' pick the smaller of the two ratios to fit area
xs = _WIDTH(i) * rt ' final image size ratio in x
ys = _HEIGHT(i) * rt ' final image size ratio in y
xp = -xp * (xj = "l") - (_SHR(xl - xp, 1) + xp - _SHR(xs, 1)) * (xj = "c") - (xl - xs) * (xj = "r")
xl = xp + xs
yp = -yp * (yj = "u") - (_SHR(yl - yp, 1) + yp - _SHR(ys, 1)) * (yj = "c") - (yl - ys) * (yj = "d")
yl = yp + ys
_PUTIMAGE (xp, yp)-(xl, yl), i, d
Image_Region = rt
END FUNCTION 'Image_Region
'---------------------------------------------------------------
SUB Initialize
'DIM st%, sl%
'FOR st% = 0 TO 12
' FOR sl% = 0 TO 52
' stack(st%, sl%) = 0
' NEXT sl%
'NEXT st%
DIM m AS _MEM
m = _MEM(stack())
_MEMFILL m, m.OFFSET, 13 * 53, 0 AS INTEGER
_MEMFREE m
Shuffle A()
Deal
END SUB 'Initialize
'---------------------------------------------------------------
FUNCTION InRange% (var##, ll##, ul##)
InRange% = _CLAMP(var##, ll##, ul##) = var##
END FUNCTION 'InRange4%
'---------------------------------------------------------------
FUNCTION InRegion% (p AS V2, r AS region)
InRegion% = -(InRange%(p.x, r.ul.x, r.lr.x) * InRange%(p.y, r.ul.y, r.lr.y)) 'in region? T/F
END FUNCTION 'InRegion%
'---------------------------------------------------------------
' Description:
' Polls state of mouse wheel and buttons and allows drag operations.
' Author: Steve McNeill
FUNCTION MBS% 'Mouse Button Status
DIM AS INTEGER tempMBS, BD
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 'MBS%
'---------------------------------------------------------------
SUB Mid_Region (re AS V2, send AS region)
' ³ ÀÄ region sent to find mid point of
' ÀÄ (x, y) point returned
're.x = _SHR(send.lr.x - send.ul.x, 1) + send.ul.x
're.y = _SHR(send.lr.y - send.ul.y, 1) + send.ul.y
re = send.lr: R2_Add re, send.ul, -1
R2_Mult re, .5
R2_Add re, send.ul, 1
END SUB 'Mid_Region
'---------------------------------------------------------------WORKING
SUB Mouse_Left (ms AS V2)
DIM x%, a%, t%, d%, u%, df%, uf%, i%, ran%, m%, f%, flg%
DIM img&
FOR x% = 0 TO 12
IF InRegion(ms, tpstk(x%)) THEN EXIT FOR
NEXT x%
SELECT CASE x%
CASE 0 ' STOCK STACK REGION
IF transfer THEN transfer = NOT transfer
IF stack(0, 0) = 0 THEN ' reset from waste stack back to stock stack when empty
Analyze_Stack d%, u%, 1
RANDOMIZE TIMER
FOR m% = 0 TO d% + u% - 1
ran% = INT(RND * (d% + u%))
SWAP stack(1, m%), stack(1, ran%)
NEXT m%
Push_Pop d% + u%, 1, 0, -1
ELSE ' draw card from stock stack and place on top of waste stack
Push_Pop 1, 0, 1, -1
END IF
CASE 1 ' WASTE STACK REGION
transfer = NOT transfer
fromPile = x%
CASE 2 TO 5 ' FOUNDATION STACK REGIONS
CASE 6 TO 12 ' TABLEAU STACK REGIONS
Analyze_Stack d%, u%, x% '
transfer = NOT transfer
IF u% <> 0 THEN ' if face up cards are present in the stack
IF transfer THEN ' Are we in a potential transfer move?
fromPile = x% ' Yes. Assign fromPile, but do nothing until the next column click
ELSE ' No. Complete the transfer from the previously chosen fromPile
IF x% = fromPile THEN
fromPile = 0
ELSE
Analyze_Stack df%, uf%, fromPile
IF fromPile = 1 THEN
IF Go%(stack(1, df% + uf% - 1), stack(x%, d% + u% - 1)) THEN
Animate deck(stack(1, df% + uf% - 1)).im, 1, x%
Push_Pop 1, 1, x%, 0
END IF
EXIT SUB ' a simple waste to tableau, one card transfer. Our job is done here.
END IF
GOSUB grab_face_ups
FOR t% = 0 TO UBOUND(pick%)
IF Go%(pick%(t%), stack(x%, d% + u% - 1 + i%)) THEN 'does pick card go on top tableau card?
i% = i% + 1
stack(x%, d% + u% - 1 + i%) = pick%(t%) 'Yes increment counter i% and transfer the element
END IF
NEXT t%
'Large pile animation
DIM stk&
stk& = _NEWIMAGE(72, 96 + (face * i%), 32)
_PUTIMAGE , 0, stk&, (tpstk(fromPile).ul.x, tpstk(fromPile).ul.y + df% * back)-STEP(72, 96 + (face * i%))
IF i% > 0 THEN ' subscript error trap. Don't pass a zero stack to Pop function
DO
a% = Pop(fromPile) ' Pump & Dump from stack of those cards accepted by move
i% = i% - 1 ' pop only as many as were moved
LOOP UNTIL i% = 0
END IF
Animate stk&, fromPile, x%
_FREEIMAGE stk&
END IF
END IF
ELSE ' no face up cards are present in the stack
IF d% = 0 THEN ' no face down cards are present in the stack
Analyze_Stack df%, uf%, fromPile
IF fromPile = 1 THEN
'IF NOT tranfer is to skip out of subscript error of clicking an empty tableau
IF NOT transfer THEN
IF deck(stack(fromPile, df% + uf% - 1)).rk = 13 THEN 'only a king should go on an empty stack SUBSCRIPT ERROR
Animate deck(stack(fromPile, df% + uf% - 1)).im, 1, x%
Push_Pop 1, 1, x%, 0
END IF
END IF
ELSE
IF df% + uf% <= 0 THEN EXIT SUB ' no card to move, leave before subscript error
GOSUB grab_face_ups
IF deck(pick%(0)).rk = 13 THEN ' if first card is a king. SUBSCRIPT OUT OF RANGE ERROR WHEN EMPTY
FOR t% = 0 TO UBOUND(pick%)
stack(x%, d% + u% + t%) = pick%(t%)
stack(fromPile, df% + t%) = 0 ' empty from stack elements
NEXT t%
fromPile = 0
END IF
END IF
ELSE
transfer = NOT transfer
IF d% > 0 THEN ' if there are face down cards,
deck(stack(x%, d% - 1)).fc = -1 ' flip the last card in the stack
END IF
END IF
END IF ' end: face up cards present in stack test
END SELECT
IF InRegion%(ms, sbut) THEN
IF UpCheck% THEN
DO
flg% = FALSE
FOR a% = 1 TO 12
SELECT CASE a%
CASE 2 TO 5
_CONTINUE
CASE ELSE
Analyze_Stack d%, u%, a%
IF d% + u% = 0 THEN _CONTINUE
flg% = TRUE
f% = deck(stack(a%, d% + u% - 1)).st
Analyze_Stack df%, uf%, f%
IF deck(stack(a%, d% + u% - 1)).rk - 1 = deck(stack(f%, df% + uf% - 1)).rk THEN
img& = deck(stack(a%, d% + u% - 1)).im
Animate img&, a%, f%
'Push Pop(a%), f%, 0
Push_Pop 1, a%, f%, 0
END IF
END SELECT
NEXT a%
LOOP UNTIL NOT flg%
END IF
END IF
EXIT SUB
grab_face_ups:
REDIM pick%(uf% - 1)
FOR a% = 0 TO uf% - 1
pick%(a%) = stack(fromPile, df% + a%) 'put all face up cards in frompile into pick array
NEXT a%
RETURN
END SUB 'Mouse_Left
'---------------------------------------------------------------
SUB Mouse_Right (ms AS V2)
DIM x%, d%, u%, rd%, ru%, pt%, t%, a%, tabl%, solve%
FOR x% = 0 TO 12
IF InRegion(ms, tpstk(x%)) THEN EXIT FOR
NEXT x%
SELECT CASE x%
CASE 1, 6 TO 12
IF stack(0, 0) = 0 AND stack(1, 0) = 0 THEN ' when stock and waste piles are empty
solve% = TRUE
FOR a% = 1 TO 52
IF deck(a%).fc = FALSE THEN solve% = FALSE 'if any card not face up, we aren't solved yet
NEXT a%
IF solve% THEN
FOR a% = 2 TO 5
Analyze_Stack d%, u%, a%
FOR tabl% = 6 TO 12
Analyze_Stack rd%, ru%, tabl%
IF rd% + ru% > 0 THEN
IF deck(stack(tabl%, rd% + ru% - 1)).st = a% THEN 'If suit matches
IF deck(stack(tabl%, rd% + ru% - 1)).rk = deck(stack(a%, d% + u%)).rk + 1 THEN
Animate deck(stack(tabl%, rd% + ru% - 1)).im, tabl%, a%
'Push Pop(tabl%), a%, 0
Push_Pop 1, tabl%, a%, 0
END IF
END IF
END IF
NEXT tabl%
NEXT a%
END IF
END IF
Analyze_Stack d%, u%, x% ' determine the suit of the last card in stack x%
IF d% + u% > 0 THEN ' trap for subscript error
t% = d% + u% - 1
IF deck(stack(x%, t%)).fc = FALSE THEN EXIT SUB 'do not transfer a face down card
pt% = deck(stack(x%, t%)).st ' create a pointer to the appropriate suit stack 2-5
Analyze_Stack rd%, ru%, pt% ' poll state of pointer stack
IF deck(stack(x%, t%)).rk = ru% + 1 THEN ' if that card is .rk+1 equal to last card in the suit stack
stack(pt%, ru%) = stack(x%, t%) ' transfer to that suit stack
Animate deck(stack(x%, t%)).im, x%, pt%
stack(x%, t%) = 0 ' erase from x% stack
END IF
deck(stack(pt%, ru%)).fc = TRUE
END IF
END SELECT
END SUB 'Mouse_Right
'---------------------------------------------------------------
FUNCTION Negative& (var AS LONG)
Negative& = _RGBA32(255 - _RED32(var), 255 - _GREEN32(var), 255 - _BLUE32(var), _ALPHA32(var))
END FUNCTION 'Negative&
'---------------------------------------------------------------
FUNCTION Pop (stk AS INTEGER)
DIM dn%, up%
Analyze_Stack dn%, up%, stk
Pop = stack(stk, dn% + up% - 1) ' return topmost array value, accounting for 0 element
stack(stk, dn% + up% - 1) = 0 ' clear topmost array element
END FUNCTION 'Pop
'---------------------------------------------------------------
SUB Push (var AS INTEGER, stk AS INTEGER, flip AS INTEGER)
DIM dn%, up%
Analyze_Stack dn%, up%, stk
stack(stk, dn% + up%) = var ' push value to next array element
IF flip THEN deck(var).fc = NOT deck(var).fc ' turn over card if flip = TRUE
END SUB 'Push
SUB Push_Pop (quan AS INTEGER, fpile AS INTEGER, tpile AS INTEGER, flip AS INTEGER)
DIM td%, tu%, fd%, fu%, x%
DIM pp%(quan - 1)
FOR x% = 0 TO quan - 1 ' Pop quan elements from from origin
Analyze_Stack fd%, fu%, fpile
pp%(x%) = stack(fpile, fd% + fu% - 1)
stack(fpile, fd% + fu% - 1) = 0
NEXT x%
FOR x% = quan - 1 TO 0 STEP -1 ' Push popped elements to destination
Analyze_Stack td%, tu%, tpile
stack(tpile, td% + tu%) = pp%(x%)
IF flip THEN deck(pp%(x%)).fc = NOT deck(pp%(x%)).fc
NEXT x%
END SUB 'Push_Pop
'---------------------------------------------------------------
SUB Shuffle (arr() AS INTEGER)
DIM i%, ran%
RANDOMIZE TIMER
FOR i% = 1 TO 52
ran% = INT(RND * 52) + 1
SWAP arr(i%), arr(ran%)
NEXT i%
END SUB 'Shuffle
'---------------------------------------------------------------
FUNCTION Rank_Name$ (var AS card)
SELECT CASE var.rk
CASE 1: Rank_Name$ = "Ace"
CASE 2: Rank_Name$ = "Two"
CASE 3: Rank_Name$ = "Three"
CASE 4: Rank_Name$ = "Four"
CASE 5: Rank_Name$ = "Five"
CASE 6: Rank_Name$ = "Six"
CASE 7: Rank_Name$ = "Seven"
CASE 8: Rank_Name$ = "Eight"
CASE 9: Rank_Name$ = "Nine"
CASE 10: Rank_Name$ = "Ten"
CASE 11: Rank_Name$ = "Jack"
CASE 12: Rank_Name$ = "Queen"
CASE 13: Rank_Name$ = "King"
END SELECT
END FUNCTION 'Rank_Name$
'---------------------------------------------------------------
FUNCTION Suit_Name$ (var AS card)
SELECT CASE var.st
CASE 2: Suit_Name$ = "Clubs"
CASE 3: Suit_Name$ = "Hearts"
CASE 4: Suit_Name$ = "Spades"
CASE 5: Suit_Name$ = "Diamonds"
END SELECT
END FUNCTION 'Suit_Name
'---------------------------------------------------------------
FUNCTION Victory_Check%
DIM x%
Victory_Check% = TRUE
FOR x% = 2 TO 5
IF stack(x%, 12) = 0 THEN
Victory_Check% = FALSE
ELSE
IF deck(stack(x%, 12)).rk MOD 13 <> 0 THEN Victory_Check% = FALSE
END IF
NEXT x%
END FUNCTION 'Victory_Check
'---------------------------------------------------------------
FUNCTION UpCheck%
DIM x%, s%
s% = TRUE
FOR x% = 1 TO 52
IF deck(x%).fc = FALSE THEN s% = FALSE: EXIT FOR
NEXT x%
UpCheck% = s%
END FUNCTION 'UpCheck%
'---------------------------------------------------------------
SUB Save_Hand
DIM f&
DIM x%, s%, c%
f& = FREEFILE
OPEN "hand.bin" FOR BINARY AS f&
FOR x% = 1 TO 52
PUT f&, , deck(x%)
NEXT x%
FOR s% = 0 TO 12
FOR c% = 0 TO 52
PUT f&, , stack(s%, c%)
NEXT c%
NEXT s%
CLOSE f&
END SUB 'Save_Hand
'---------------------------------------------------------------
SUB Load_Hand
DIM f&
DIM x%, s%, c%
f& = FREEFILE
IF _FILEEXISTS("hand.bin") THEN
OPEN "hand.bin" FOR BINARY AS f&
FOR x% = 1 TO 52
GET f&, , deck(x%)
NEXT x%
FOR s% = 0 TO 12
FOR c% = 0 TO 52
GET f&, , stack(s%, c%)
NEXT c%
NEXT s%
CLOSE f&
END IF
END SUB 'Load_Hand
'---------------------------------------------------------------
SUB Animate (i AS LONG, f AS INTEGER, t AS INTEGER)
'ÞßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÝ
'Þ Animate card image 'i' movement from stack 'f' to stack 't' Ý
'ÞÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÝ
DIM d%, u%, x%, sd%, ed%, dt%, ut%
DIM bk&, crd&
DIM AS V2 st, nd, mv, an, ans
crd& = _COPYIMAGE(i, 33)
Card_Refresh
bk& = _COPYIMAGE(0, 33)
IF f > 5 THEN ' if coming from a tableau pile
Analyze_Stack d%, u%, f
sd% = (d% * back) + (u% * face) ' determine the fan position of target card
END IF
IF t > 5 THEN ' if going to a tableau pile
Analyze_Stack dt%, ut%, t
ed% = (dt% * back) + (ut% * face)
END IF
st = tpstk(f).ul ' get start point of movement vector
st.y = st.y + sd% ' add tableau fan position if any
nd = tpstk(t).ul ' get end point of movement vector
nd.y = nd.y + ed%
mv = nd: R2_Add mv, st, -1 ' subtract start point from end point to get movement vector
DO
_PUTIMAGE , bk& ' overlay base layer
x% = x% + 1 ' increment movement factor
R2_Norm an, mv, x% ' set vector magnitude to movement factor
ans = st: R2_Add ans, an, 1 ' add movement vector to start point
_PUTIMAGE (ans.x, ans.y), crd& ' overlay the card image at new point
_DISPLAY
LOOP UNTIL x% >= R2_Mag!(mv) ' loop until card arrives at destination
IF crd& < -1 THEN _FREEIMAGE crd&
IF bk& < -1 THEN _FREEIMAGE bk&
END SUB 'Animate
'------------------------------------------------------------------------------
SUB R2_Add (re AS V2, se AS V2, m AS INTEGER)
'ÞßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÝ
'Þ Add a scalar multiple (m) of vector <se> to vector <re> Ý
'ÞÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÝ
re.x = re.x + se.x * m
re.y = re.y + se.y * m
END SUB 'R2_Add
'------------------------------------------------------------------------------
FUNCTION R2_Mag! (v AS V2)
'ÞßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÝ
'Þ Obtain the scalar magnitude of 2D vector (v) Ý
'ÞÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÝ
R2_Mag! = _HYPOT(v.x, v.y)
END FUNCTION 'R2_Mag!
'------------------------------------------------------------------------------
SUB R2_Norm (re AS V2, v AS V2, scalar AS SINGLE)
'ÞßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÝ
'Þ Grow/Shrink V2 vector <v> to (scalar) length. <re> & <v> can be the Ý
'Þ same vectors, overwriting the original. Vector direction is preserved. Ý
'Þ Returns: vector <re> as new length of <v> Ý
'ÞÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÝ
DIM m!
DIM t AS V2
t = v
m! = R2_Mag!(t)
IF m! = 0 THEN
re.x = 0: re.y = 0
ELSE
re.x = (t.x / m!) * scalar
re.y = (t.y / m!) * scalar
END IF
END SUB 'R2_Norm
'------------------------------------------------------------------------------
SUB R2_Mult (re AS V2, scalar AS SINGLE)
'ÞßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÝ
'Þ Multiply 2D vector <re> by scalar Ý
'ÞÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÝ
re.x = re.x * scalar
re.y = re.y * scalar
END SUB 'R2_Mult
Lately I was writing a bit of code to do some job for my work. Importing a clipboarded Excel column into an array, it came in as one large string.
Lazy as I am I thought to make ChatGPT do the dirty work but as usual, it made a mess of the program.
It seems that ChatGPT doesn't know too much about QB64PE (just as Copilot as mentioned in another post), so in the end I gave up with it and provided the link of the wiki. Which it immediately started scanning, so who knows, next time ....
As usual it was using non-existing commands. But this time, it was a very interesting command:
_REPLACE$(source$,old$,new$)
Where in a source$, every occurrance of old$ was replaced with new$.
For a single replace, you could code this with a few commands, With multiple occurences, the code gets somewhat more complex, so here lies the real strength. Then I thought how nice it would be to have a fast, internal command. There are many occasons where this is useful, like replacing the comma's for dots in a large number. Now, I have a multi-line function for that.
Now I don't know if this is the right section of the forum, but I did not see a better place for the suggestion. If there is, please move it there!
The program uses the following InForm objects:
Form
Frame
MenuBar
Button
Label
Unzip the file and extract the folder into your PEQB64 directory. In the IDE make sure that you have the Run Option “Save EXE in source folder” checked.
': ____ ____ ____ ____ ____ ____ ____ ____ ____ ____
': ||C |||A |||L |||C |||U |||L |||A |||T |||O |||R ||
': ||__|||__|||__|||__|||__|||__|||__|||__|||__|||__||
': |/__\|/__\|/__\|/__\|/__\|/__\|/__\|/__\|/__\|/__\|
':
': QB64 Calculator V1.1
': Terry Ritchie - 08/29/18
':
': Built as a clone of the Windows 7 standard calculator
': An exersize in getting to know the InForm library
':
': This program uses
': InForm-PE for QB64-PE - v1.5.8 based upon InForm by Fellippe Heitor
': Copyright (c) 2025 QB64 Phoenix Edition Team
': https://github.com/QB64-Phoenix-Edition/InForm-PE
'----------------------------------------------------------------------------------------------------------------------
OPTION _EXPLICIT
': Program constants: -------------------------------------------------------------------------------------------------
DIM SHARED Calculator AS LONG
DIM SHARED frmResults AS LONG
DIM SHARED mnuEdit AS LONG
DIM SHARED mnuHelp AS LONG
DIM SHARED butMC AS LONG
DIM SHARED butMR AS LONG
DIM SHARED butMS AS LONG
DIM SHARED butMplus AS LONG
DIM SHARED butMminus AS LONG
DIM SHARED butBS AS LONG
DIM SHARED butCE AS LONG
DIM SHARED butC AS LONG
DIM SHARED butSign AS LONG
DIM SHARED butSQR AS LONG
DIM SHARED but7 AS LONG
DIM SHARED but8 AS LONG
DIM SHARED but9 AS LONG
DIM SHARED butDivide AS LONG
DIM SHARED butPercent AS LONG
DIM SHARED but4 AS LONG
DIM SHARED but5 AS LONG
DIM SHARED but6 AS LONG
DIM SHARED butMultiply AS LONG
DIM SHARED butReciprocate AS LONG
DIM SHARED but1 AS LONG
DIM SHARED but2 AS LONG
DIM SHARED but3 AS LONG
DIM SHARED butSubtract AS LONG
DIM SHARED but0 AS LONG
DIM SHARED butPoint AS LONG
DIM SHARED butAdd AS LONG
DIM SHARED butEqual AS LONG
DIM SHARED mnuCopy AS LONG
DIM SHARED mnuPaste AS LONG
DIM SHARED mnuAbout AS LONG
DIM SHARED lblAnswer AS LONG
DIM SHARED lblMemory AS LONG
DIM SHARED lblHistory AS LONG
': Program variables: -------------------------------------------------------------------------------------------------
DIM SHARED operand$ ' current operand
DIM SHARED history$ ' calculation history
DIM SHARED operand1 AS DOUBLE ' first operand enetered
DIM SHARED operand2 AS DOUBLE ' second operand entered
DIM SHARED operator AS INTEGER ' current operator selected
DIM SHARED operator$(4)
DIM SHARED previousoperator AS INTEGER ' previous operator saved
DIM SHARED resetoperand AS INTEGER ' True when operand entry needs reset
DIM SHARED memory AS DOUBLE ' value stored in memory
DIM SHARED nohistory AS INTEGER
': Program procedures: ------------------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------------------------------------
SUB ALERT () ' ALERT()
'------------------------------------------------------------------------------------------------------------------
DIM i AS LONG
PLAY "MBQ0" ' play in the background and disable volume ramping
FOR i = 800 TO 2000 STEP 100
SOUND i, .2
NEXT
FOR i = 2000 TO 50 STEP -100
SOUND i, .2
NEXT
END SUB
'----------------------------------------------------------------------------------------------------------------------
FUNCTION CLEAN$ (n AS DOUBLE) ' CLEAN$()
'------------------------------------------------------------------------------------------------------------------
' Return number (n) as a string with no leading/trailing spaces
' Add leading zero if necessary
DIM c$ ' n converted to a clean string
c$ = LTRIM$(RTRIM$(STR$(n))) ' create clean string
IF ASC(c$, 1) = 46 THEN ' first character a decimal point?
c$ = "0" + c$ ' yes, add leading zero
ELSEIF ASC(c$, 1) = 45 AND ASC(c$, 2) = 46 THEN ' no, minus sign then decimal point?
c$ = "-0" + RIGHT$(c$, LEN(c$) - 1) ' yes, add leading zero
END IF
CLEAN$ = c$ ' return cleaned string
END FUNCTION
'----------------------------------------------------------------------------------------------------------------------
SUB UPDATEOPERAND (n$) ' UPDATEOPERAND()
'------------------------------------------------------------------------------------------------------------------
' Add user entries to operand
' Keep operand to a max length of 16 numbers (not including decimal point)
' Reset user operand input as needed
' Keep leading zero for decimal values between one and negative one
DIM olen AS INTEGER ' operand length
IF resetoperand THEN ' new operand input?
operand$ = "" ' yes, reset operand
resetoperand = False ' reset trigger
END IF
IF n$ = "." THEN ' adding decimal point?
IF INSTR(operand$, ".") = 0 THEN ' yes, already a decimal point?
IF operand$ = "" THEN ' no, has operand been reset?
n$ = "0." ' yes, add leading zero
END IF
ELSE ' yes, decimal point exists
n$ = "" ' ignore user request for decimal point
END IF
END IF
operand$ = operand$ + n$ ' update operand with user entry
olen = LEN(operand$) ' get length of operand
IF INSTR(operand$, ".") > 0 THEN olen = olen - 1 ' don't count decimal point if preset
IF olen > 16 THEN operand$ = LEFT$(operand$, LEN(operand$) - 1) ' keep operand within 16 number limit
END SUB
'----------------------------------------------------------------------------------------------------------------------
SUB CALCULATE () ' CALCULATE()
'------------------------------------------------------------------------------------------------------------------
' Calculate operand values based on operator previously used
' Store result back into current operand
SELECT CASE previousoperator ' which operator to use?
CASE ADDITION ' add the operands
operand$ = CLEAN$(operand1 + operand2) ' perform clculation
CASE SUBTRACTION ' subtract the operands
operand$ = CLEAN$(operand1 - operand2) ' perform calculation
CASE MULTIPLICATION ' multiply the operands
operand$ = CLEAN$(operand1 * operand2) ' perform calculation
CASE DIVISION ' divide the operands
IF operand2 = 0 THEN ' dividing by zero?
ALERT ' get user's attention
operand$ = "Can't divide by zero!" ' yes, not in this universe!
ELSE ' no, physics is safe for now
operand$ = CLEAN$(operand1 / operand2) ' perform calculation
END IF
END SELECT
END SUB
'----------------------------------------------------------------------------------------------------------------------
SUB COMMITOPERAND () ' COMMITOPERAND()
'------------------------------------------------------------------------------------------------------------------
' Get value of current operand
' Calculate operands if necessary
' Save current operand value
' Remember the operator that invoked this routine
operand2 = VAL(operand$) ' store value of current operand
IF previousoperator THEN ' previous operator selected?
CALCULATE ' yes, calculate
END IF
operand1 = VAL(operand$) ' move current total to previous value
previousoperator = operator ' move current operator to previous operator
resetoperand = True ' trigger an operand reset
END SUB
'----------------------------------------------------------------------------------------------------------------------
SUB SCANKEYBOARD () ' SCANKEYBOARD()
'------------------------------------------------------------------------------------------------------------------
' Scan the keyboard for user keystrokes
' Invoke the appropriate button for the desired key
DIM k$ ' key pressed by user
DIM ctrl AS INTEGER
k$ = INKEY$ ' look for a key press
IF k$ <> "" THEN ' was a key pressed?
SELECT CASE k$ ' yes, which one?
CASE "0" ' zero key pressed
__UI_Click (but0) ' manually click the zero button
CASE "1" ' etc..
__UI_Click (but1) ' etc..
CASE "2"
__UI_Click (but2)
CASE "3"
__UI_Click (but3)
CASE "4"
__UI_Click (but4)
CASE "5"
__UI_Click (but5)
CASE "6"
__UI_Click (but6)
CASE "7"
__UI_Click (but7)
CASE "8"
__UI_Click (but8)
CASE "9"
__UI_Click (but9)
CASE "."
__UI_Click (butPoint)
CASE "+"
__UI_Click (butAdd)
CASE "-"
__UI_Click (butSubtract)
CASE "*"
__UI_Click (butMultiply)
CASE "/"
__UI_Click (butDivide)
CASE "%"
__UI_Click (butPercent)
CASE "=", CHR$(13) ' treat ENTER and = the same
__UI_Click (butEqual)
CASE CHR$(8) ' backspace key pressed
__UI_Click (butBS)
CASE "c", "C" ' CTRL-C copy
ctrl = _KEYDOWN(100305) OR _KEYDOWN(100306)
IF ctrl THEN BEEP
' Will need to investigate how to capture CTRL-C and CTRL-V
' Neither the code above or below works
CASE "v", "V" ' CTRL-V paste
IF __UI_CtrlIsDown THEN ' is CTRL key presses?
BEEP
END IF
END SELECT
END IF
END SUB
'----------------------------------------------------------------------------------------------------------------------
SUB ADDHISTORY (h$) ' ADDHISTORY()
'------------------------------------------------------------------------------------------------------------------
IF nohistory THEN
nohistory = False
ELSE
history$ = history$ + h$
END IF
SUB __UI_BeforeUpdateDisplay
'This event occurs at approximately 30 frames per second.
'You can change the update frequency by calling SetFrameRate DesiredRate%
DIM answer$ ' current operand displayed
SCANKEYBOARD ' process keys pressed by user
Caption(lblHistory) = history$ + operator$(operator) ' update history display
answer$ = operand$ ' copy operand
IF answer$ = "" THEN answer$ = "0" ' set to zero if empty
Caption(lblAnswer) = answer$ ' display current operand
IF memory THEN ' does memory have value?
Caption(lblMemory) = "M" ' yes, apply screen indication
ELSE ' no
Caption(lblMemory) = "" ' remove screen indication
END IF
END SUB
SUB __UI_BeforeUnload
'If you set __UI_UnloadSignal = False here you can
'cancel the user's request to close.
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE Calculator
CASE butMC ' memory clear clicked
memory = 0 ' reset memory value
CASE butMR ' memory recall clicked
IF memory THEN ' memory available?
operand$ = CLEAN$(memory) ' Yes, make it the current operand
resetoperand = True ' trigger an operand reset
END IF
CASE butMS ' memory store clicked
memory = VAL(operand$) ' overwrite memory with current operand
resetoperand = True ' trigger an operand reset
CASE butMplus ' memory addition clicked
memory = memory + VAL(operand$) ' add current operand to memory
resetoperand = True ' trigger an operand reset
CASE butMminus ' memory subtraction clicked
memory = memory - VAL(operand$) ' subtract current operand from memory
resetoperand = True ' trigger an operand reset
CASE butBS ' backspace clicked
IF LEN(operand$) THEN ' characters in operand?
operand$ = LEFT$(operand$, LEN(operand$) - 1) ' yes, remove right-most character
END IF
CASE butReciprocate ' reciprocate clicked
IF VAL(operand$) THEN ' dividing by zero?
ADDHISTORY (operator$(previousoperator) + "Reciproc(" + operand$ + ")")
nohistory = True ' skip operand history next time
operator = EQUATE
operand$ = CLEAN$(1 / VAL(operand$)) ' no, calculate reciprocate
ELSE ' yes, physics will collapse!
ALERT ' get user's attention
operand$ = "Can't divide by zero!" ' report error to user
END IF
resetoperand = True ' trigger an operand reset
CASE butSQR ' square root clicked
IF VAL(operand$) >= 0 THEN ' positive value?
ADDHISTORY (operator$(previousoperator) + "SQRT(" + operand$ + ")")
nohistory = True ' skip operand history next time
operator = EQUATE
operand$ = CLEAN$(SQR(VAL(operand$))) ' yes, calculate square root
ELSE ' no, value is negative
ALERT ' get user's attention
operand$ = "Invalid input!" ' nice try buddy
END IF
resetoperand = True ' trigger an operand reset
SUB __UI_MouseEnter (id AS LONG)
SELECT CASE id
CASE Calculator
CASE frmResults
CASE mnuEdit
CASE mnuHelp
CASE butMC
CASE butMR
CASE butMS
CASE butMplus
CASE butMminus
CASE butBS
CASE butCE
CASE butC
CASE butSign
CASE butSQR
CASE but7
CASE but8
CASE but9
CASE butDivide
CASE butPercent
CASE but4
CASE but5
CASE but6
CASE butMultiply
CASE butReciprocate
CASE but1
CASE but2
CASE but3
CASE butSubtract
CASE but0
CASE butPoint
CASE butAdd
CASE butEqual
CASE mnuCopy
CASE mnuPaste
CASE mnuAbout
CASE lblAnswer
CASE lblMemory
CASE lblHistory
END SELECT
END SUB
SUB __UI_MouseLeave (id AS LONG)
SELECT CASE id
CASE Calculator
CASE frmResults
CASE mnuEdit
CASE mnuHelp
CASE butMC
CASE butMR
CASE butMS
CASE butMplus
CASE butMminus
CASE butBS
CASE butCE
CASE butC
CASE butSign
CASE butSQR
CASE but7
CASE but8
CASE but9
CASE butDivide
CASE butPercent
CASE but4
CASE but5
CASE but6
CASE butMultiply
CASE butReciprocate
CASE but1
CASE but2
CASE but3
CASE butSubtract
CASE but0
CASE butPoint
CASE butAdd
CASE butEqual
CASE mnuCopy
CASE mnuPaste
CASE mnuAbout
CASE lblAnswer
CASE lblMemory
CASE lblHistory
END SELECT
END SUB
SUB __UI_FocusIn (id AS LONG)
SELECT CASE id
CASE butMC
CASE butMR
CASE butMS
CASE butMplus
CASE butMminus
CASE butBS
CASE butCE
CASE butC
CASE butSign
CASE butSQR
CASE but7
CASE but8
CASE but9
CASE butDivide
CASE butPercent
CASE but4
CASE but5
CASE but6
CASE butMultiply
CASE butReciprocate
CASE but1
CASE but2
CASE but3
CASE butSubtract
CASE but0
CASE butPoint
CASE butAdd
CASE butEqual
END SELECT
END SUB
SUB __UI_FocusOut (id AS LONG)
'This event occurs right before a control loses focus.
'To prevent a control from losing focus, set __UI_KeepFocus = True below.
SELECT CASE id
CASE butMC
CASE butMR
CASE butMS
CASE butMplus
CASE butMminus
CASE butBS
CASE butCE
CASE butC
CASE butSign
CASE butSQR
CASE but7
CASE but8
CASE but9
CASE butDivide
CASE butPercent
CASE but4
CASE but5
CASE but6
CASE butMultiply
CASE butReciprocate
CASE but1
CASE but2
CASE but3
CASE butSubtract
CASE but0
CASE butPoint
CASE butAdd
CASE butEqual
END SELECT
END SUB
SUB __UI_MouseDown (id AS LONG)
SELECT CASE id
CASE Calculator
CASE frmResults
CASE mnuEdit
CASE mnuHelp
CASE butMC
CASE butMR
CASE butMS
CASE butMplus
CASE butMminus
CASE butBS
CASE butCE
CASE butC
CASE butSign
CASE butSQR
CASE but7
CASE but8
CASE but9
CASE butDivide
CASE butPercent
CASE but4
CASE but5
CASE but6
CASE butMultiply
CASE butReciprocate
CASE but1
CASE but2
CASE but3
CASE butSubtract
CASE but0
CASE butPoint
CASE butAdd
CASE butEqual
CASE mnuCopy
CASE mnuPaste
CASE mnuAbout
CASE lblAnswer
CASE lblMemory
CASE lblHistory
END SELECT
END SUB
SUB __UI_MouseUp (id AS LONG)
SELECT CASE id
CASE Calculator
CASE frmResults
CASE mnuEdit
CASE mnuHelp
CASE butMC
CASE butMR
CASE butMS
CASE butMplus
CASE butMminus
CASE butBS
CASE butCE
CASE butC
CASE butSign
CASE butSQR
CASE but7
CASE but8
CASE but9
CASE butDivide
CASE butPercent
CASE but4
CASE but5
CASE but6
CASE butMultiply
CASE butReciprocate
CASE but1
CASE but2
CASE but3
CASE butSubtract
CASE but0
CASE butPoint
CASE butAdd
CASE butEqual
CASE mnuCopy
CASE mnuPaste
CASE mnuAbout
CASE lblAnswer
CASE lblMemory
CASE lblHistory
END SELECT
END SUB
SUB __UI_KeyPress (id AS LONG)
'When this event is fired, __UI_KeyHit will contain the code of the key hit.
'You can change it and even cancel it by making it = 0
SELECT CASE id
CASE butMC
CASE butMR
CASE butMS
CASE butMplus
CASE butMminus
CASE butBS
CASE butCE
CASE butC
CASE butSign
CASE butSQR
CASE but7
CASE but8
CASE but9
CASE butDivide
CASE butPercent
CASE but4
CASE but5
CASE but6
CASE butMultiply
CASE butReciprocate
CASE but1
CASE but2
CASE but3
CASE butSubtract
CASE but0
CASE butPoint
CASE butAdd
CASE butEqual
END SELECT
END SUB
SUB __UI_TextChanged (id AS LONG)
SELECT CASE id
CASE lblAnswer
CASE lblMemory
CASE lblHistory
END SELECT
END SUB
SUB __UI_ValueChanged (id AS LONG)
SELECT CASE id
CASE lblAnswer
but as usual, it made a mess of the program.
