Quote:' 2026-02-21&22 I WAS all set to add card images to this but dang! to show a hand properly
' I have to have room to display the whole deck a 4 rows by 13 columns proposition. That PLUS
' I am just too plain lazy to Mod this code to card images when it works so well without!
' So I decided to fix the colors up 2 shades of red for red suits and 2 shades of black for
' black suits plus a dark print would work better on lite blue background that I like.
Code: (Select All)
Option _Explicit
_Title "Regular Gin Rummy" 'b+ rebuild start 2020-10-18
' from the revised cards of Grin Rummy add the 10-18 Optimze code to the Grim Rummy update,
' cleanup and debug the mess as well as establish scoring rules for this Variation.
' 2020-10-19 fix running fan waiting for screen click, readjust message lines,
' readjust colors for redder red for hearts and greener green for clubs.
' 2026-02-21&22 I WAS all set to add card images to this but dang! to show a hand properly
' I have to have room to display the whole deck a 4 rows by 13 columns proposition. That PLUS
' I am just too plain lazy to Mod this code to card images when it works so well without!
' So I decided to fix the colors up 2 shades of red for red suits and 2 shades of black for
' black suits plus a dark print would work better on lite blue background that I like.
DefInt A-Z
Randomize Timer
Const xmax = 800, ymax = 400 'screen to be expanded when start card images
'y Constants for locating and displaying
Const DeckY = 150 ' cards remain and discard top changing
Const ScoreY = 190 ' least changing item in middle
Const MessageY = 238 ' bottom
Const CardOffsetX = 20
Const CCardsOffsetY = 16
Const PCardsOffsetY = 288 ' now in pixels
' for current and future card images
Const CardW = 32 'pixels 3 chars wide
Const CardH = 16 'pixels 1 char high
'some colors
Const Black = &HFF000000, White = &HFFFFFFBB, BColor = &HFF6677DD
Const Ref = &HFF000033 ' dark blue on lite blue background ' color changes 2/22/2026
Dim Shared Clr(3) As _Unsigned Long
Clr(0) = &HFFAA0033 'red touch of blue hearts chr$(3) ' color changes 2/22/2026
Clr(1) = &HFFFF2200 'red gold diamonds chr$(4)
Clr(2) = &HFF003300 'dark green almost black clubs chr$(5)
Clr(3) = &HFF000022 'dark blue almost black spades chr$(6)
' card format = "##s" = 3 chars = space or 1 for 10 + # or Letter for digit/Face + card symbol
Dim Shared Deck$(0 To 51), DeckPointer As Integer ' contains shuffled cards, deckpointer points to last card out
Dim Shared Discard$, Turn$ 'discard$ is card always face up that both players see
Dim Shared P$(12, 3), C$(12, 3) ' p = human or c = computer
Dim Shared PMeldCards$, PNM, PMeldPts, PDeadCards$, PND, PDeadPts 'see updateStatus
Dim Shared CMeldCards$, CNM, CMeldPts, CDeadCards$, CND, CDeadPts
Dim Shared PScore, CScore, Laydown, ShowComputerHand
Dim Shared Pick1$(2), Pick2$(3) 'human player's button choices at each play
Pick1$(0) = "Quit": Pick1$(1) = "Draw Discard": Pick1$(2) = "Draw from Deck"
Pick2$(0) = "Quit": Pick2$(1) = "Gin - all cards melded": Pick2$(2) = "Knock": Pick2$(3) = "Pass to computer"
'local variables for main loop of game round and laydown section
Dim clicked 'human's button choice
Dim card$ ' used often for passing back and forth with routines
Dim message$ ' used for reporting results of laydown
Dim wf$ 'winflag
Dim oldMouse
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 150
SetupGame 'create deck, human is first up
restart:
ResetRound
wf$ = ""
Do
If Turn$ = "p" Then 'player's turn
clicked = GetButtonNumberChoice%(Pick1$())
If clicked = 0 Then
System
ElseIf clicked = 1 Then ' Human draws discard
AddCard P$(), Discard$ ' put the discard into the humans hand
Discard$ = "" ' show the discard missing because in human hand
ElseIf clicked = 2 Then ' Human draws from deck if there are enough cards
If 52 - DeckPointer < 2 Then Laydown = 5: GoTo skip Else AddCard P$(), DealCard$
End If
UpdateStatus ' display all this
card$ = GetDiscardClick$ ' get human's discard
RemoveCard P$(), card$ ' take this card out of human hand
Discard$ = card$ ' put into discard catagory
UpdateStatus ' show the changes
clicked = GetButtonNumberChoice%(Pick2$())
Select Case clicked
Case 0: System ' quit
Case 1: If PDeadPts <> 0 Then Beep: Turn$ = "c" Else Laydown = 1
Case 2: If PDeadPts > 10 Then Beep: Turn$ = "c" Else Laydown = 2
Case 3: Turn$ = "c" ' pass
End Select
ElseIf Turn$ = "c" Then 'computer's turn
card$ = Discard$
CardDiscard card$ '
If card$ = Discard$ Then 'computer passed on the discard by passing it back
' so draw from deck if not out of cards?
If 52 - DeckPointer < 2 Then Laydown = 5: GoTo skip Else card$ = DealCard$
CardDiscard card$
Discard$ = card$
UpdateStatus
YCP MessageY, "Computer drew from Deck and discarded."
Else 'computer kept discard
Discard$ = card$
UpdateStatus
YCP MessageY, "Computer kept Discard and discarded another."
End If
_Delay 2
If CDeadPts = 0 Then
Laydown = 3
ElseIf CDeadPts <= 10 Then
Laydown = 4
Else
Turn$ = "p"
End If
End If
skip:
Loop Until Laydown
' scoring round
ShowComputerHand = 1 'to show computer hand
Select Case Laydown
Case 1 ' human gin
message$ = "Human: 15 + " + TS$(PMeldPts) + " + " + TS$(CDeadPts) + " has been added to your score."
PScore = PScore + 15 + PMeldPts + CDeadPts
wf$ = "p"
Turn$ = "c"
Case 2, 4 'knock
If PDeadPts > CDeadPts Then
message$ = "Computer: " + TS$(CMeldPts) + " + " + TS$(PDeadPts) + " has been added to your score."
CScore = CScore + CMeldPts + PDeadPts
wf$ = "c"
Turn$ = "p"
ElseIf CDeadPts > PDeadPts Then
message$ = "Human: " + TS$(PMeldPts) + " + " + TS$(CDeadPts) + " has been added to your score."
PScore = PScore + PMeldPts + CDeadPts
wf$ = "p"
Turn$ = "p"
Else
message$ = "Tie, No winner this round."
If Turn$ = "c" Then Turn$ = "p" Else Turn$ = "c"
End If
Case 3 ' computer gin
message$ = "Computer: 15 + " + TS$(CMeldPts) + " + " + TS$(PDeadPts) + " has been added to your score."
CScore = CScore + 15 + CMeldPts + PDeadPts
wf$ = "c"
Turn$ = "p"
Case 5
message$ = "The deck has < 2 cards, this round is Null!" ' turn is same as was
End Select
UpdateStatus
If wf$ = "p" Then
DrwBtn xmax - 210, ymax - 100, "WIN "
ElseIf wf$ = "c" Then
DrwBtn xmax - 210, 50, "WIN "
End If
If CScore >= 500 Or PScore >= 500 Then message$ = message$ + " Winner!" ' cant clear score yet
YCP MessageY, message$ + " click..."
oldMouse = -1
Do ' winner button showing somethimes wait for click to clear buttons, reset score if game won.
While _MouseInput: Wend
If _MouseButton(1) And oldMouse = 0 Then
Line (xmax - 210, 0)-(xmax, ymax), BColor, BF 'blank out button area
If InStr(message$, "Winner!") Then PScore = 0: CScore = 0 'reset main scores
Exit Do
End If
oldMouse = _MouseButton(1)
_Limit 200
Loop
GoTo restart
Sub SetupGame 'Intro to this version, create deck of cards, set turn to human
Dim suit, value, i, bn
Dim m$(2): m$(0) = "Quit": m$(1) = "Gin Rummy Intro": m$(2) = "Let's play Gin Rummy"
Color Ref, BColor 'once and for all on bColor
Cls
YCP 160, "'Gin Rummy Intro' Button will load the text file"
YCP 180, "'Gin Rummy Intro.txt' into your favorite editor"
YCP 200, "for you to refer to now or during play of Gin Rummy."
YCP 220, "You are free to add your own notes to the file."
bn = GetButtonNumberChoice(m$())
If bn = 0 Then System
If bn = 1 Then Shell _DontWait "Gin Rummy Intro.txt" 'oh nice! don't have to load and show!
If Deck$(0) = "" Then 'create deck
For suit = 1 To 4
For value = 1 To 13
Deck$(i) = Mid$(" A 2 3 4 5 6 7 8 910 J Q K", 2 * (value - 1) + 1, 2) + Mid$(Chr$(3) + Chr$(4) + Chr$(5) + Chr$(6), suit, 1) 'Suit_Value
i = i + 1
Next
Next
End If
Turn$ = "p" 'player always starts game
End Sub
Sub ResetRound
Dim i, r 'locals, wow not many for all the code here
Erase P$, C$ 'clear hands 13 cols and 4 rows arrays copy of ordered deck
Laydown = 0: ShowComputerHand = 0 '< 1 for debug or cheating
'shuffle deck
For i = 51 To 1 Step -1
r = Int(Rnd * (i + 1))
Swap Deck$(i), Deck$(r)
Next
DeckPointer = 0 'deal some cards out
For i = 1 To 10
AddCard P$(), DealCard$
AddCard C$(), DealCard$
Next
Discard$ = Deck$(DeckPointer): DeckPointer = DeckPointer + 1 'set first discard$
UpdateStatus
End Sub
Sub UpdateStatus
Optimize C$(), CMeldCards$, CNM, CMeldPts, CDeadCards$, CND, CDeadPts
Optimize P$(), PMeldCards$, PNM, PMeldPts, PDeadCards$, PND, PDeadPts
Color Ref, BColor
Cls
Show "p" ' show updates pDeadPts cardDiscard updates cDeadPts
If ShowComputerHand Then Show "c"
'fixed I think
Color Clr(InStr(Chr$(3) + Chr$(4) + Chr$(5) + Chr$(6), Right$(Discard$, 1)) - 1), White
' this is only used in UpdateStatus
Sub Show (player$) 'players hand is displayed 5 lines above bottom of screen in 4 lines
Dim r, c
For r = 0 To 3
Color Clr(r)
For c = 0 To 12
If player$ = "p" Then
If P$(c, r) = "" Then
_PrintString (c * 40 + CardOffsetX, r * 16 + PCardsOffsetY), " "
Else
Color , White
_PrintString (c * 40 + CardOffsetX, r * 16 + PCardsOffsetY), P$(c, r)
Color , BColor
End If
Else
If C$(c, r) = "" Then
_PrintString (c * 40 + CardOffsetX, r * 16 + CCardsOffsetY), " "
Else
Color , White
_PrintString (c * 40 + CardOffsetX, r * 16 + CCardsOffsetY), C$(c, r)
Color , BColor
End If
End If
Next
Next
Color &HFFFFFF00 'dark brown sort a like cMeldTotal?
If player$ = "p" Then
YCP 80 + PCardsOffsetY, " Player: Meld = " + TS$(PMeldPts) + " Deadwood = " + TS$(PDeadPts)
Else
YCP 80 + CCardsOffsetY, "Computer: Meld = " + TS$(CMeldPts) + " Deadwood = " + TS$(CDeadPts)
End If
Color White
End Sub
'player reviews card rec'd and discards through mouse click
Function GetDiscardClick$ 'this has to be reworked
Dim oldMouse, mCol, mRow, mb
YCP MessageY, "Click Discard"
oldMouse = -1
Do
While _MouseInput: Wend 'convert mouse positions to array row and col
mCol = Int((_MouseX - CardOffsetX) / (CardW + 8) + .25)
mRow = Int((_MouseY - PCardsOffsetY) / (CardH))
mb = _MouseButton(1)
'LOCATE 13, 2: PRINT mCol, mRow
If mb And oldMouse = 0 Then
If mRow >= 0 And mRow <= 3 Then
If mCol >= 0 And mCol <= 12 Then
If P$(mCol, mRow) <> "" Then GetDiscardClick$ = P$(mCol, mRow): Exit Function
End If
End If
End If
oldMouse = mb
_Limit 200
Loop
End Function
'computer gets card and discards through this AI ================== Computer's AI
Sub CardDiscard (card$) 'for AI 2020-10-11 rewrite this for new Optimize
Dim cCards$, low, d$, saveI, i, tm$, tn, tp, dn, deadPts, oPts
cCards$ = ListCards$(C$())
Optimize C$(), tm$, tn, tp, d$, dn, deadPts
low = deadPts: saveI = 0: oPts = deadPts
AddCard C$(), card$
For i = 1 To 10 ' with card in hand swap all cards out for best points
RemoveCard C$(), Mid$(cCards$, i * 3 - 2, 3)
Optimize C$(), tm$, tn, tp, d$, dn, deadPts
If deadPts < low Then saveI = i: low = deadPts
AddCard C$(), Mid$(cCards$, i * 3 - 2, 3)
Next
RemoveCard C$(), card$ ' back to original 10 cards
If card$ = Discard$ Then
If oPts - low > 4 Then
AddCard C$(), card$
RemoveCard C$(), Mid$(cCards$, saveI * 3 - 2, 3)
card$ = Mid$(cCards$, saveI * 3 - 2, 3)
End If
Else 'card <> discard$ take the best
If saveI <> 0 Then
AddCard C$(), card$
RemoveCard C$(), Mid$(cCards$, saveI * 3 - 2, 3)
card$ = Mid$(cCards$, saveI * 3 - 2, 3)
End If
End If
End Sub
Function DealCard$
DealCard$ = Deck$(DeckPointer): DeckPointer = DeckPointer + 1
End Function
Function Points% (card$)
Dim place
place = InStr(" A 2 3 4 5 6 7 8 910 J Q K", Mid$(card$, 1, 2))
If (place + 1) / 2 < 10 Then Points% = (place + 1) / 2 Else Points% = 10
End Function
Sub AddCard (a$(), card$)
'PRINT card$
Dim r, c
r = InStr(Chr$(3) + Chr$(4) + Chr$(5) + Chr$(6), Right$(card$, 1)) - 1: c = (InStr(" A 2 3 4 5 6 7 8 910 J Q K", Mid$(card$, 1, 2)) - 1) / 2
'PRINT c, r, card$
a$(c, r) = card$
End Sub
Sub RemoveCard (a$(), card$)
Dim r, c
r = InStr(Chr$(3) + Chr$(4) + Chr$(5) + Chr$(6), Right$(card$, 1)) - 1: c = (InStr(" A 2 3 4 5 6 7 8 910 J Q K", Mid$(card$, 1, 2)) - 1) / 2
a$(c, r) = ""
End Sub
'modified for this app
Sub YCP (y, s$) 'for xmax pixel wide graphics screen Center Print at pixel y row
_PrintString ((_Width - 220 - Len(s$) * 8) / 2, y), s$
End Sub
'this sub uses drwBtn
Function GetButtonNumberChoice% (choice$()) 'developed for this app but likely can use as is elsewhere
Dim ub, b, oldmouse, mx, my, mb
ub = UBound(choice$)
For b = 0 To ub
DrwBtn xmax - 210, b * 60 + 90, choice$(b)
Next
oldmouse = -1
Do
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb And oldmouse = 0 Then
If mx > xmax - 210 And mx <= xmax - 10 Then
For b = 0 To ub
If my >= b * 60 + 90 And my <= b * 60 + 140 Then
Line (xmax - 210, 0)-(xmax, ymax), BColor, BF
GetButtonNumberChoice% = b: Exit Function
End If
Next
Beep
Else
Beep
End If
End If
oldmouse = _MouseButton(1)
_Limit 200
Loop
End Function
Sub DrwBtn (x, y, s$) '200 x 50
Dim th, tw, gray~&
th = 16: tw = 8 * Len(s$): gray~& = _RGB32(190, 190, 190)
Line (x, y)-Step(204, 54), _RGB32(0, 0, 0), BF
Line (x - 2, y - 2)-Step(201, 51), _RGB32(255, 255, 255), BF
Line (x, y)-Step(200, 50), gray~&, BF
Color _RGB32(0, 0, 0), gray~&
_PrintString (x + 100 - 4 * Len(s$), y + 17), s$
Color White, BColor
End Sub
Sub SAppend (arr() As String, addItem$)
ReDim _Preserve arr(LBound(arr) To UBound(arr) + 1) As String
arr(UBound(arr)) = addItem$
End Sub
Function TS$ (number)
TS$ = _Trim$(Str$(number))
End Function
' ========================================== add Optimizer Code and fix it for new cards design
' 5 SUBs 2 FUNCTIONs
' needs FUNCTION cards$(hand$()), FUNCTION cardRemovedSet$ (set$, card$) for deadwood calcs
' needs SUB ListStraights (hand$(), StrCards$, nStrCards AS INTEGER, strPoints AS INTEGER)
' needs SUB ListGroups (hand$(), grpCards$, nGrpCards AS INTEGER, grpPoints AS INTEGER)
' needs SUB ListIntersects (strt$, grp$, listI$()) , FUNCTION TS$
' needs SUB addCard (hand$(), card$), SUB removeCard (hand$(), card$)
Sub Optimize (hand$(), meld$, nMeld, meldPts, deadwood$, nDeadwood, deadwoodPts)
Dim sCards$, gCards$, copyS$, copyG$, comb$, combine$, temp$, d$
Dim nSt As Integer, nGr As Integer, stPts As Integer, grPts As Integer, i As Integer, j As Integer
Dim nI As Integer, nCombos As Integer, highSet$, nHiCards, hiPts
Dim c As Integer, r As Integer
ReDim dbl$(0) ' cards that intersect so appear twice once in straight sets and then in group
Dim justS$(12, 3), justG$(12, 3)
Dim copyS$(12, 3), copyG$(12, 3)
ListStraights hand$(), sCards$, nSt, stPts
For i = 1 To nSt 'put only straight cards in justS$
AddCard justS$(), Mid$(sCards$, i * 3 - 2, 3)
Next
ListGroups hand$(), gCards$, nGr, grPts
For i = 1 To nGr 'put only straight cards in justS$
AddCard justG$(), Mid$(gCards$, i * 3 - 2, 3)
Next
ListIntersects sCards$, gCards$, dbl$()
If UBound(dbl$) > 0 Then 'then we have intersects
nI = UBound(dbl$): nCombos = 2 ^ nI
For i = 1 To nI ' build a template for deciding what to do with each intersect
temp$ = temp$ + TS$(i)
Next
' look for the best sum of cards and points of all combinations of removing intersect cards from straight set or group
For i = 1 To nCombos
comb$ = "" ' for building a combination
For j = 0 To nI - 1 'generate comb$ here now instead of in array
If (i - 1) And 2 ^ j Then
If comb$ = "" Then comb$ = Mid$(temp$, j + 1, 1) Else comb$ = comb$ + ", " + Mid$(temp$, j + 1, 1)
End If
Next
'make copys of the straight set and the group set because we will be removing cards as comb$ dictates
For r = 0 To 3
For c = 0 To 12
copyS$(c, r) = justS$(c, r)
copyG$(c, r) = justG$(c, r)
Next
Next
If comb$ = "" Then ' copys$ stays same
For j = 1 To Len(temp$) ' remove all intersects from copyG$()
RemoveCard copyG$(), dbl$(j)
Next
Else
For j = 1 To Len(temp$) 'remove card from straight set according to dictates of comb$
d$ = TS$(j) 'if combo generated here
If InStr(comb$, d$) Then ' all combs are 1 digit less than intersect number
RemoveCard copyS$(), dbl$(j)
Else 'it's remove the card from one or the other
RemoveCard copyG$(), dbl$(j)
End If
Next
End If
'run the counts from the sets again
ListStraights copyS$(), sCards$, nSt, stPts
ListGroups copyG$(), gCards$, nGr, grPts
combine$ = sCards$ + gCards$
If i = 1 Then
highSet$ = combine$: nHiCards = nSt + nGr: hiPts = stPts + grPts
Else
If nSt + nGr > nHiCards Then
highSet$ = combine$: nHiCards = nSt + nGr: hiPts = stPts + grPts
ElseIf stPts + grPts > hiPts Then
highSet$ = combine$: nHiCards = nSt + nGr: hiPts = stPts + grPts
End If
End If
Next
Else ' no intersects between straights and groups
highSet$ = sCards$ + gCards$: nHiCards = nSt + nGr: hiPts = stPts + grPts
End If
'OK we should have the optimum set!
meld$ = highSet$: nMeld = nHiCards: meldPts = hiPts
'calc Deadwood set
deadwood$ = ListCards$(hand$()) ' all the cards
For i = 1 To nHiCards ' minus meld
deadwood$ = CardRemovedSet$(deadwood$, Mid$(highSet$, i * 3 - 2, 3))
Next
nDeadwood = Len(deadwood$) / 3 'number of deadwood cards
deadwoodPts = 0
For i = 1 To nDeadwood
deadwoodPts = deadwoodPts + Points%(Mid$(deadwood$, i * 3 - 2, 3))
Next
End Sub
' needs points%(card$)
Sub ListStraights (hand$(), StrCards$, nStrCards As Integer, strPoints As Integer)
' hand is 2D array
Dim r As Integer, c As Integer, quit As Integer, cStart As Integer, cEnd As Integer, ci As Integer
StrCards$ = "": nStrCards = 0: strPoints = 0
For r = 0 To 3 'suits
c = 0: quit = 0
Do While quit = 0 And c < 13
While hand$(c, r) = "" 'search blanks until hit a card
c = c + 1
If c > 11 Then quit = 1: Exit While
Wend
If c < 11 Then 'have enough for 3 card straight
cStart = c
While hand$(c, r) <> "" ' while cards are next to each other
c = c + 1
If c = 13 Then quit = 1: Exit While
Wend
If c = 13 Then cEnd = 12 Else cEnd = c - 1
If cEnd - cStart + 1 > 2 Then 'enough for straight
For ci = cStart To cEnd ' STEP -1 ' load highest cards first into straight set < reversed this back 10-18
StrCards$ = StrCards$ + hand$(ci, r)
nStrCards = nStrCards + 1
strPoints = strPoints + Points%(hand$(ci, r))
Next
End If
If c > 11 Then quit = 1
Else
Exit Do
End If
Loop
Next
End Sub
' needs points%(card$)
Sub ListGroups (hand$(), grpCards$, nGrpCards As Integer, grpPoints As Integer)
Dim c As Integer, count As Integer, ci As Integer
grpCards$ = "": nGrpCards = 0: grpPoints = 0
For c = 0 To 12 ' now for the groups
count = 0
For ci = 0 To 3
If hand$(c, ci) <> "" Then count = count + 1
Next
If count > 2 Then
For ci = 0 To 3
If hand$(c, ci) <> "" Then
grpCards$ = grpCards$ + hand$(c, ci)
nGrpCards = nGrpCards + 1
grpPoints = grpPoints + Points%(hand$(c, ci))
End If
Next
End If
Next
End Sub
'needs sAppend(arr$(), insert$)
Sub ListIntersects (strt$, grp$, listI$())
Dim NS As Integer, NG As Integer, i As Integer, j As Integer
NS = Len(strt$) / 3: NG = Len(grp$) / 3
ReDim listI$(0)
If (NS > 0) And (NG > 0) Then
For i = 1 To NS
For j = 1 To NG
If Mid$(strt$, i * 3 - 2, 3) = Mid$(grp$, j * 3 - 2, 3) Then
SAppend listI$(), Mid$(strt$, i * 3 - 2, 3)
End If
Next
Next
End If
End Sub
Function ListCards$ (hand$())
Dim c As Integer, r As Integer, rtn$
For c = 0 To 12 ' now for the groups
For r = 0 To 3
If hand$(c, r) <> "" Then rtn$ = rtn$ + hand$(c, r)
Next
Next
ListCards$ = rtn$
End Function
Function CardRemovedSet$ (set$, card$)
Dim i, nCards, newSet$
nCards = Len(set$) / 3
For i = 1 To nCards
If card$ <> Mid$(set$, i * 3 - 2, 3) Then newSet$ = newSet$ + Mid$(set$, i * 3 - 2, 3)
Next
CardRemovedSet$ = newSet$
End Function
PLUS without Card images we don't have to attach or embed image file!
You will find the AI for the Computer player quite good!
Here are some snaps to get the gist of the game, what melding looks like:
Dang I am getting like Walter with all the pics but needed for How to Play without reading all the rules though that would help.
Double dang there IS a Help / Intro text file to attach with this. I will attach a zip for bas source and Help file.
I have an array with positive values and want to sort the array from negative to positive in ascending order but the negative values in descending order
suppose I have [-1.65068012389, -0.524647623275, 1.65068012389, 0.524647623275]
I want [ -0.524647623275, -1.65068012389 , 0.524647623275, 1.65068012389]
This is a fairly simple programme that allows the user to compose tunes, using the volume, tempo, note-length and tone features provided in QB64PE.
Code: (Select All)
Common Shared LineNumum, LN$, CPR, MX, MY, Tune$, Tunes$(), Octave, Length, Tempo, Volume, NT, NT$
Common Shared TN$, OldTune$, LastOp$, Remove$
SW = 1040: sh = 720
Screen _NewImage(SW, sh, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f&
CPR = SW / _PrintWidth("X") ' chars per row for this screen setting
_ScreenMove (_DesktopWidth - SW) / 2, 100
Color _RGB(255, 255, 255), _RGB(64, 64, 0): Cls
'Kill "TuneDir": Kill "Tunes"
If Not _FileExists("TuneDir") Or Not _FileExists("Tunes") Then
Open "TuneDir" For Output As #1: Open "Tunes" For Output As #2 ' create new files if missing
Close
End If
'Kill "TUNEDIR": Kill "TUNES" ' delete all tunes for testing functions
whitekeys:
For a = 292 To 682 Step 65
Line (a, 505)-(a + 60, 635), _RGB(255, 255, 255), BF
Next
blackkeys:
Line (332, 505)-(372, 560), _RGB(32, 32, 0), BF
Line (397, 505)-(437, 560), _RGB(32, 32, 0), BF
Line (527, 505)-(567, 560), _RGB(32, 32, 0), BF
Line (592, 505)-(631, 560), _RGB(32, 32, 0), BF
Line (657, 505)-(696, 560), _RGB(32, 32, 0), BF
KeyLabels:
Centre "C# Eb F# Ab Bb ", 25
Centre "C D E F G A B", 33
Tune$ = ""
Do
DisplayTune
Do
i = _MouseInput
Loop Until _MouseButton(1)
MX = _MouseX: MY = _MouseY
DealWithMouse
Do
i = _MouseInput
Loop Until Not _MouseButton(1)
Loop
Sub DealWithMouse
Select Case MY
Case 50 To 85 ' <--------------------- octave, length, tempo, volume
White: Locate 8, 1
Select Case MX ' get the mouse horiz position
Case 164 To 204 ' Octave -
If Octave > 0 Then ' don't do anything if at octave 0
If LastOp$ = "O" Then
Tune$ = Left$(Tune$, Len(Tune$) - 2)
End If
Octave = Octave - 1
Locate 4, 19: White: Print LTrim$(Str$(Octave)) + " "
Tune$ = Tune$ + "O" + LTrim$(Str$(Octave))
LastOp$ = "O"
End If
Case 267 To 307 ' Octave +
If Octave < 6 Then ' don't do anything if at octave 6
If LastOp$ = "O" Then
Tune$ = Left$(Tune$, Len(Tune$) - 2)
End If
Octave = Octave + 1
Locate 4, 19: White: Print LTrim$(Str$(Octave)) + " "
Tune$ = Tune$ + "O" + LTrim$(Str$(Octave))
LastOp$ = "O"
End If
Case 352 To 392 ' Length -
If Length > 1 Then
If LastOp$ = "L" Then Tune$ = Left$(Tune$, Len(Tune$) - Len((Str$(Length))))
Length = Length / 2
Locate 4, 33: Print Space$(3): Locate 4, 33: White: Print LTrim$(Str$(Length)) + " "
Tune$ = Tune$ + "L" + LTrim$(Str$(Length))
LastOp$ = "L"
End If
Case 455 To 495 ' Length +
If Length < 64 Then
If LastOp$ = "L" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Length)))
Length = Length * 2
Locate 4, 33: Print Space$(3): Locate 4, 33:: White: Print LTrim$(Str$(Length)) + " "
Tune$ = Tune$ + "L" + LTrim$(Str$(Length))
LastOp$ = "L"
End If
Case 555 To 595 ' Tempo -
If Tempo > 40 Then ' only if not at maximum
If LastOp$ = "T" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Tempo)))
Tempo = Tempo - 10
Locate 4, 48: White: Print LTrim$(Str$(Tempo)) + " "
Tune$ = Tune$ + "T" + LTrim$(Str$(Tempo))
LastOp$ = "T"
End If
Case 658 To 698 ' tempo +
If Tempo < 246 Then ' only if not at maximum
If LastOp$ = "T" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Tempo)))
Tempo = Tempo + 10
Locate 4, 48: White: Print LTrim$(Str$(Tempo)) + " "
Tune$ = Tune$ + "T" + LTrim$(Str$(Tempo))
LastOp$ = "T"
End If
Case 750 To 790 ' Volume-
If Volume > 4 Then
If LastOp$ = "V" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Volume)))
Volume = Volume - 5
Locate 4, 63: White: Print Space$(4): Locate 4, 63: Print LTrim$(Str$(Volume))
Tune$ = Tune$ + "V" + LTrim$(Str$(Volume))
LastOp$ = "V"
End If
Case 853 To 893 ' Volume+
If Volume < 96 Then
If LastOp$ = "V" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Volume)))
Volume = Volume + 5
Locate 4, 63: White: Print Space$(4): Locate 4, 63: Print LTrim$(Str$(Volume))
Tune$ = Tune$ + "V" + LTrim$(Str$(Volume))
LastOp$ = "V"
End If
End Select
Case 110 To 145 ' <--------------------- New, Back, Play, Save
Play "o3l4t125v50" ' ' reset defaults
LastOp$ = ""
Select Case MX
Case 170 To 253 ' new tune
Tune$ = "" ' delete tune string
Octave = 3: Length = 4: Tempo = 125: Volume = 50 ' reset defaults
For a = 9 To 20: Locate a, 1: Print Space$(80);: Next ' erase old tune display
Locate 4, 19: White: Print LTrim$(Str$(Octave))
Locate 4, 33: White: Print " ": Locate 4, 33: Print LTrim$(Str$(Length))
Locate 4, 48: White: Print " ": Locate 4, 48: Print LTrim$(Str$(Tempo))
Locate 4, 63: White: Print " ": Locate 4, 63: Print LTrim$(Str$(Volume))
Case 490 To 573 ' play tune
Play "v0o3l4t120cv50" ' ensure default settings are applied first
Play Tune$
Case 660 To 743 ' load tune
NT = 0
Open "TuneDir" For Input As #1
If LOF(1) < 2 Then Play bad$: Centre "No tunes saved yet, sorry", 10: Sleep 1: WIPE "10": Close: Exit Sub
Play "v0o3l4t120cv50"
WipeTuneDisplay
Locate 10, 1
While Not EOF(1)
NT = NT + 1
Input #1, Tune$
Print Tab(35); NT; Tab(40); Tune$
Wend
Close
Centre "Number of the tune to load ", 22 ' invite number selection
Locate 22, 53: Input TN$
If Val(TN$) > NT Or Val(TN$) = 0 Then Exit Sub
TN = Val(TN$)
Open "tunes" For Input As #1
For a = 1 To TN: Input #1, Tune$: Next: Close
Locate 18, 60
_KeyClear
WipeTuneDisplay ' tune may be shorter, so erase previous tune display
WIPE "1822": Centre "The requested tune is loaded", 18: Sleep 1
l = Len(Tune$)
Case 805 To 888 ' save tune
If Tune$ = "" Then Exit Sub
Cls: Close
NT = 0
Yellow: Centre "Existing Tunes:", 12: White
Open "TuneDir" For Input As #1 ' get Tunes list
While Not EOF(1)
Input #1, OldTune$
NT = NT + 1
Print Tab(35); NT; Tab(40); OldTune$
Wend
Close
_KeyClear
If NT > 9 Then
Yellow: Centre "No more room; tune to be replaced (1 to 10) ", 24
White: Locate 24, 60: Input Remove$
If Val(Remove$) > 10 Or Val(Remove$) < 1 Then Run
DeleteTune
End If
WIPE "24"
Yellow: Centre "What will you call your new tune ", 24
White: Locate 24, 53: Input TuneName$
If TuneName$ = "" Then
Centre "No file changes made", 12: Sleep 1
Run
End If
WIPE "1224"
NT = NT + 1
Open "TuneDir" For Append As #1
Open "tunes" For Append As #2
Write #1, TuneName$
Write #2, Tune$
Close ' place name and tune number in tune directory
txt$ = "Added " + TuneName$ + " to file"
Centre txt$, 12: Sleep 1: Cls
NT = 0
Yellow: Centre "Existing Tunes", 12: White
Open "TuneDir" For Input As #1 ' get Tunes list
While Not EOF(1)
Input #1, OldTune$
NT = NT + 1
Print Tab(35); NT; Tab(40); OldTune$
Wend
Close: Sleep 2: Tune$ = ""
Run
Case 310 To 393 ' erase last char of tune
Tune$ = Left$(Tune$, Len(Tune$) - 1)
DisplayTune
End Select
KeyBoard:
Case 504 To 561 ' black keys
LastOp$ = ""
Select Case MX
Case 333 To 373
Tune$ = Tune$ + "C+"
Case 397 To 437
Tune$ = Tune$ + "E-"
Case 527 To 566
Tune$ = Tune$ + "F+"
Case 592 To 631
Tune$ = Tune$ + "A-"
Case 657 To 696
Tune$ = Tune$ + "B-"
End Select
Case 504 To 634 ' white keys
LastOp$ = ""
Select Case MX
Case 291 To 354
Tune$ = Tune$ + "C"
Case 356 To 419
Tune$ = Tune$ + "D"
Case 421 To 484
Tune$ = Tune$ + "E"
Case 486 To 549
Tune$ = Tune$ + "F"
Case 551 To 614
Tune$ = Tune$ + "G"
Case 616 To 679
Tune$ = Tune$ + "A"
Case 681 To 744
Tune$ = Tune$ + "B"
End Select
End Select
End Sub
Sub DisplayTune:
WipeTuneDisplay ' tune may be shorter, so erase previous tune display
Locate 14, 10
l = Len(Tune$)
For a = 1 To l
If a Mod (60) = 0 Then Print Tab(10); ' display tune in rows of 60 chars
Print Mid$(Tune$, a, 1);
Next
End Sub
Sub DeleteTune
Open "TuneDir" For Input As #1 ' get old files
Open "Tunes" For Input As #2
Open "TempTuneDir" For Output As #3 ' create new files
Open "TempTunes" For Output As #4
For a = 1 To Val(Remove$) - 1
Input #1, TuneName$: Write #3, TuneName$ ' copy records before selected into new file
Input #2, Tune$: Write #4, Tune$
Next
Input #1, TuneName$: Input #2, Tune$ ' read selected record and discard it
For a = Val(Remove$) + 1 To NT
Input #1, TuneName$: Write #3, TuneName$ ' copy remaining old records into new file
Input #2, Tune$: Write #4, Tune$
Next
Close
Kill "TuneDir": Kill "Tunes" ' delete old files
Name "TempTuneDir" As "TuneDir" ' rename new files as old files
Name "TempTunes" As "Tunes"
Sleep 2
End Sub
Sub Centre (txt$, linenum)
ctr = Int(CPR / 2 - Len(txt$) / 2) + 1 ' CPR is chars per row for this screen setting
Locate linenum, ctr ' place text at horiz centre of screen
Print txt$
End Sub
Sub WIPE (ln$) ' clear selected screen rows
If Len(ln$) = 1 Then ln$ = "0" + ln$
For a = 1 To Len(ln$) - 1 Step 2
wl = Val(Mid$(ln$, a, 2))
Locate wl, 1: Print Space$(CPR);
Next
End Sub
Sub WipeTuneDisplay
Locate 10, 1: Print Space$(880)
End Sub
Sub White
Color _RGB(255, 255, 255)
End Sub
Sub Yellow
Color _RGB(255, 255, 0)
End Sub
Sub Red
Color _RGB(255, 0, 0)
End Sub
Sub Instructions:
Yellow: Centre "Piano", 8: White: Print
Print " A simple mouse-driven programme to allow tunes to be composed, saved, and"
Print " re-played. They can be edited and saved later under the same name or a": Print
Print " new one. The tunes can use up to 7 octaves, with standard 13 semitones per"
Print " octave (13 TET) notation. It accommodates volume from 0% (silent) to 100% "
Print " of the system sound, and tempo from 32 bpm to 255 bpm, with note-lengths of"
Print " from 1 to 64, expressed as full-note fractions, e.g. 4 is 1 crotchet."
Yellow: Centre "Press Left-Mouse to begin", 19
Do
m = _MouseInput
b = _MouseButton(1)
Loop While b <> -1: Cls ' wait for left-mouse click
Sleep 1
End Sub
Running this program is Windows and Linux/macOS gives differing results. It appears that the functions CSRLIN and POS(0) only work correctly in Windows, when using $CONSOLE:ONLY.
Code: (Select All)
'CSRLIN and POS(0) bug
$CONSOLE:ONLY
LOCATE 10, 10
x = CSRLIN: y = POS(0)
PRINT "Cursor position :"; x; ", "; y
In Windows it reports the location as 10,10. In Linux/macOS it reports 1,1
I have found a workaround, so no big deal. I figured I'd bring it to your attention.
I'm working on another library, nobody asked for, and I was checking compatibility across platforms. So, I dug out an old Mac, updated it, as much as I could including xcode. It is running macOS Catalina v10.15.8.
Somewhere between QB64pe v4.2 and v4.3 the installation breaks. To be clear v4.2 is fine, but v4.3 is not.
To me it's no big deal, but I figured I'd bring it to your attention.
Building 'QB64-PE'
rm -fr ./internal/c/qbx.o ./internal/c/libqb/src/threading.o ./internal/c/libqb/src/buffer.o ./internal/c/libqb/src/bitops.o ./internal/c/libqb/src/command.o ./internal/c/libqb/src/environ.o ./internal/c/libqb/src/file-fields.o ./internal/c/libqb/src/filepath.o ./internal/c/libqb/src/filesystem.o ./internal/c/libqb/src/datetime.o ./internal/c/libqb/src/error_handle.o ./internal/c/libqb/src/gfs.o ./internal/c/libqb/src/qblist.o ./internal/c/libqb/src/hexoctbin.o ./internal/c/libqb/src/mem.o ./internal/c/libqb/src/shell.o ./internal/c/libqb/src/qbs.o ./internal/c/libqb/src/qbs_str.o ./internal/c/libqb/src/qbs__tostr.o ./internal/c/libqb/src/qbs_cmem.o ./internal/c/libqb/src/qbs_mk_cv.o ./internal/c/libqb/src/qbs_val.o ./internal/c/libqb/src/string_functions.o ./internal/c/libqb/src/graphics.o ./internal/c/libqb/src/logging/logging.o ./internal/c/libqb/src/logging/qb64pe_symbol.o ./internal/c/libqb/src/logging/stacktrace.o ./internal/c/libqb/src/logging/handlers/fp_handler.o ./internal/c/libqb/src/logging/unix/symbol.o ./internal/c/libqb/src/http-stub.o ./internal/c/libqb/src/threading-posix.o ./internal/c/libqb/src/glut-main-thread.o ./internal/c/libqb/src/glut-message.o ./internal/c/libqb/src/glut-msg-queue.o ./internal/c/libqb/src/mac-key-monitor.o ./internal/c/libqb/src/mac-mouse-support.o ./internal/c/libqb/src/logging/mingw/file.o ./internal/c/libqb/src/logging/mingw/pe.o ./internal/c/libqb/src/logging/mingw/pe_symtab.o ./internal/c/libqb/src/logging/mingw/symbol.o ./internal/c/libqb/src/http.o ./internal/c/libqb/src/console-only-main-thread.o ./internal/c/parts/audio/extras/foo_midi/InstrumentBankManager.o ./internal/c/parts/audio/extras/foo_midi/MIDIPlayer.o ./internal/c/parts/audio/extras/foo_midi/OpalPlayer.o ./internal/c/parts/audio/extras/foo_midi/PSPlayer.o ./internal/c/parts/audio/extras/foo_midi/TSFPlayer.o ./internal/c/parts/audio/extras/hivelytracker/hvl_replay.o ./internal/c/parts/audio/extras/libmidi/MIDIContainer.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessor.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorGMF.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorHMI.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorHMP.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorLDS.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorMDS.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorMUS.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorRCP.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorRIFF.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorSMF.o ./internal/c/parts/audio/extras/libmidi/MIDIProcessorXMI.o ./internal/c/parts/audio/extras/libmidi/Recomposer/CM6File.o ./internal/c/parts/audio/extras/libmidi/Recomposer/GDSFile.o ./internal/c/parts/audio/extras/libmidi/Recomposer/MIDIStream.o ./internal/c/parts/audio/extras/libmidi/Recomposer/RCP.o ./internal/c/parts/audio/extras/libmidi/Recomposer/RCPConverter.o ./internal/c/parts/audio/extras/libmidi/Recomposer/RunningNotes.o ./internal/c/parts/audio/extras/libmidi/Recomposer/Support.o ./internal/c/parts/audio/extras/libxmp-lite/common.o ./internal/c/parts/audio/extras/libxmp-lite/control.o ./internal/c/parts/audio/extras/libxmp-lite/dataio.o ./internal/c/parts/audio/extras/libxmp-lite/effects.o ./internal/c/parts/audio/extras/libxmp-lite/filetype.o ./internal/c/parts/audio/extras/libxmp-lite/filter.o ./internal/c/parts/audio/extras/libxmp-lite/flow.o ./internal/c/parts/audio/extras/libxmp-lite/format.o ./internal/c/parts/audio/extras/libxmp-lite/hio.o ./internal/c/parts/audio/extras/libxmp-lite/it_load.o ./internal/c/parts/audio/extras/libxmp-lite/itsex.o ./internal/c/parts/audio/extras/libxmp-lite/lfo.o ./internal/c/parts/audio/extras/libxmp-lite/load.o ./internal/c/parts/audio/extras/libxmp-lite/load_helpers.o ./internal/c/parts/audio/extras/libxmp-lite/md5.o ./internal/c/parts/audio/extras/libxmp-lite/memio.o ./internal/c/parts/audio/extras/libxmp-lite/misc.o ./internal/c/parts/audio/extras/libxmp-lite/mix_all.o ./internal/c/parts/audio/extras/libxmp-lite/mixer.o ./internal/c/parts/audio/extras/libxmp-lite/mod_load.o ./internal/c/parts/audio/extras/libxmp-lite/period.o ./internal/c/parts/audio/extras/libxmp-lite/player.o ./internal/c/parts/audio/extras/libxmp-lite/read_event.o ./internal/c/parts/audio/extras/libxmp-lite/rng.o ./internal/c/parts/audio/extras/libxmp-lite/s3m_load.o ./internal/c/parts/audio/extras/libxmp-lite/sample.o ./internal/c/parts/audio/extras/libxmp-lite/scan.o ./internal/c/parts/audio/extras/libxmp-lite/smix.o ./internal/c/parts/audio/extras/libxmp-lite/virtual.o ./internal/c/parts/audio/extras/libxmp-lite/win32.o ./internal/c/parts/audio/extras/libxmp-lite/xm_load.o ./internal/c/parts/audio/extras/primesynth/primesynth.o ./internal/c/parts/audio/extras/qoa/qoa.o ./internal/c/parts/audio/extras/radv2/opal.o ./internal/c/parts/audio/extras/stb/stb_vorbis.o ./internal/c/parts/audio/extras/tinysoundfont/tsf.o ./internal/c/parts/audio/extras/ymfmidi/patches.o ./internal/c/parts/audio/extras/ymfmidi/player.o ./internal/c/parts/audio/extras/hively_ma_vtable.o ./internal/c/parts/audio/extras/midi_ma_vtable.o ./internal/c/parts/audio/extras/mod_ma_vtable.o ./internal/c/parts/audio/extras/qoa_ma_vtable.o ./internal/c/parts/audio/extras/radv2_ma_vtable.o ./internal/c/parts/audio/stub_audio.o ./internal/c/parts/audio/audio.o ./internal/c/parts/audio/miniaudio/miniaudio.o ./internal/c/parts/audio/audio.a ./internal/c/parts/core/freeglut.a ./internal/c/parts/core/freeglut/freeglut_callbacks.o ./internal/c/parts/core/freeglut/freeglut_cursor.o ./internal/c/parts/core/freeglut/freeglut_display.o ./internal/c/parts/core/freeglut/freeglut_ext.o ./internal/c/parts/core/freeglut/freeglut_font.o ./internal/c/parts/core/freeglut/freeglut_font_data.o ./internal/c/parts/core/freeglut/freeglut_gamemode.o ./internal/c/parts/core/freeglut/freeglut_geometry.o ./internal/c/parts/core/freeglut/freeglut_glutfont_definitions.o ./internal/c/parts/core/freeglut/freeglut_init.o ./internal/c/parts/core/freeglut/freeglut_input_devices.o ./internal/c/parts/core/freeglut/freeglut_joystick.o ./internal/c/parts/core/freeglut/freeglut_main.o ./internal/c/parts/core/freeglut/freeglut_menu.o ./internal/c/parts/core/freeglut/freeglut_misc.o ./internal/c/parts/core/freeglut/freeglut_overlay.o ./internal/c/parts/core/freeglut/freeglut_spaceball.o ./internal/c/parts/core/freeglut/freeglut_state.o ./internal/c/parts/core/freeglut/freeglut_stroke_mono_roman.o ./internal/c/parts/core/freeglut/freeglut_stroke_roman.o ./internal/c/parts/core/freeglut/freeglut_structure.o ./internal/c/parts/core/freeglut/freeglut_teapot.o ./internal/c/parts/core/freeglut/freeglut_videoresize.o ./internal/c/parts/core/freeglut/freeglut_window.o ./internal/c/parts/core/freeglut/freeglut_xinput.o ./internal/c/parts/core/glew/glew.o ./internal/c/parts/input/game_controller/game_controller.a ./internal/c/parts/input/game_controller/libstem_gamepad/Gamepad_macosx.o ./internal/c/parts/input/game_controller/libstem_gamepad/Gamepad_private.o ./internal/c/parts/input/game_controller/game_controller.o ./internal/c/parts/video/font/freetype/freetype.a ./internal/c/parts/video/font/font.a ./internal/c/parts/video/font/freetype/adler32.o ./internal/c/parts/video/font/freetype/afadjust.o ./internal/c/parts/video/font/freetype/afblue.o ./internal/c/parts/video/font/freetype/afcjk.o ./internal/c/parts/video/font/freetype/afdummy.o ./internal/c/parts/video/font/freetype/afglobal.o ./internal/c/parts/video/font/freetype/afgsub.o ./internal/c/parts/video/font/freetype/afhints.o ./internal/c/parts/video/font/freetype/afindic.o ./internal/c/parts/video/font/freetype/aflatin.o ./internal/c/parts/video/font/freetype/afloader.o ./internal/c/parts/video/font/freetype/afmodule.o ./internal/c/parts/video/font/freetype/afmparse.o ./internal/c/parts/video/font/freetype/afranges.o ./internal/c/parts/video/font/freetype/afshaper.o ./internal/c/parts/video/font/freetype/bdfdrivr.o ./internal/c/parts/video/font/freetype/bdflib.o ./internal/c/parts/video/font/freetype/cffcmap.o ./internal/c/parts/video/font/freetype/cffdecode.o ./internal/c/parts/video/font/freetype/cffdrivr.o ./internal/c/parts/video/font/freetype/cffgload.o ./internal/c/parts/video/font/freetype/cffload.o ./internal/c/parts/video/font/freetype/cffobjs.o ./internal/c/parts/video/font/freetype/cffparse.o ./internal/c/parts/video/font/freetype/cidgload.o ./internal/c/parts/video/font/freetype/cidload.o ./internal/c/parts/video/font/freetype/cidobjs.o ./internal/c/parts/video/font/freetype/cidparse.o ./internal/c/parts/video/font/freetype/cidriver.o ./internal/c/parts/video/font/freetype/crc32.o ./internal/c/parts/video/font/freetype/dlg.o ./internal/c/parts/video/font/freetype/dlgwrap.o ./internal/c/parts/video/font/freetype/ft-hb-ft.o ./internal/c/parts/video/font/freetype/ft-hb.o ./internal/c/parts/video/font/freetype/ftadvanc.o ./internal/c/parts/video/font/freetype/ftbbox.o ./internal/c/parts/video/font/freetype/ftbdf.o ./internal/c/parts/video/font/freetype/ftbitmap.o ./internal/c/parts/video/font/freetype/ftbsdf.o ./internal/c/parts/video/font/freetype/ftbzip2.o ./internal/c/parts/video/font/freetype/ftcalc.o ./internal/c/parts/video/font/freetype/ftcbasic.o ./internal/c/parts/video/font/freetype/ftccache.o ./internal/c/parts/video/font/freetype/ftccmap.o ./internal/c/parts/video/font/freetype/ftcglyph.o ./internal/c/parts/video/font/freetype/ftcid.o ./internal/c/parts/video/font/freetype/ftcimage.o ./internal/c/parts/video/font/freetype/ftcmanag.o ./internal/c/parts/video/font/freetype/ftcmru.o ./internal/c/parts/video/font/freetype/ftcolor.o ./internal/c/parts/video/font/freetype/ftcsbits.o ./internal/c/parts/video/font/freetype/ftdbgmem.o ./internal/c/parts/video/font/freetype/ftdebug.o ./internal/c/parts/video/font/freetype/fterrors.o ./internal/c/parts/video/font/freetype/ftfntfmt.o ./internal/c/parts/video/font/freetype/ftfstype.o ./internal/c/parts/video/font/freetype/ftgasp.o ./internal/c/parts/video/font/freetype/ftgloadr.o ./internal/c/parts/video/font/freetype/ftglyph.o ./internal/c/parts/video/font/freetype/ftgrays.o ./internal/c/parts/video/font/freetype/ftgxval.o ./internal/c/parts/video/font/freetype/ftgzip.o ./internal/c/parts/video/font/freetype/fthash.o ./internal/c/parts/video/font/freetype/ftinit.o ./internal/c/parts/video/font/freetype/ftlcdfil.o ./internal/c/parts/video/font/freetype/ftlzw.o ./internal/c/parts/video/font/freetype/ftmac.o ./internal/c/parts/video/font/freetype/ftmm.o ./internal/c/parts/video/font/freetype/ftobjs.o ./internal/c/parts/video/font/freetype/ftotval.o ./internal/c/parts/video/font/freetype/ftoutln.o ./internal/c/parts/video/font/freetype/ftpatent.o ./internal/c/parts/video/font/freetype/ftpfr.o ./internal/c/parts/video/font/freetype/ftpsprop.o ./internal/c/parts/video/font/freetype/ftraster.o ./internal/c/parts/video/font/freetype/ftrend1.o ./internal/c/parts/video/font/freetype/ftrfork.o ./internal/c/parts/video/font/freetype/ftsdf.o ./internal/c/parts/video/font/freetype/ftsdfcommon.o ./internal/c/parts/video/font/freetype/ftsdfrend.o ./internal/c/parts/video/font/freetype/ftsmooth.o ./internal/c/parts/video/font/freetype/ftsnames.o ./internal/c/parts/video/font/freetype/ftstream.o ./internal/c/parts/video/font/freetype/ftstroke.o ./internal/c/parts/video/font/freetype/ftsvg.o ./internal/c/parts/video/font/freetype/ftsynth.o ./internal/c/parts/video/font/freetype/ftsystem.o ./internal/c/parts/video/font/freetype/fttrigon.o ./internal/c/parts/video/font/freetype/fttype1.o ./internal/c/parts/video/font/freetype/ftutil.o ./internal/c/parts/video/font/freetype/ftwinfnt.o ./internal/c/parts/video/font/freetype/ftzopen.o ./internal/c/parts/video/font/freetype/gxvbsln.o ./internal/c/parts/video/font/freetype/gxvcommn.o ./internal/c/parts/video/font/freetype/gxvfeat.o ./internal/c/parts/video/font/freetype/gxvjust.o ./internal/c/parts/video/font/freetype/gxvkern.o ./internal/c/parts/video/font/freetype/gxvlcar.o ./internal/c/parts/video/font/freetype/gxvmod.o ./internal/c/parts/video/font/freetype/gxvmort.o ./internal/c/parts/video/font/freetype/gxvmort0.o ./internal/c/parts/video/font/freetype/gxvmort1.o ./internal/c/parts/video/font/freetype/gxvmort2.o ./internal/c/parts/video/font/freetype/gxvmort4.o ./internal/c/parts/video/font/freetype/gxvmort5.o ./internal/c/parts/video/font/freetype/gxvmorx.o ./internal/c/parts/video/font/freetype/gxvmorx0.o ./internal/c/parts/video/font/freetype/gxvmorx1.o ./internal/c/parts/video/font/freetype/gxvmorx2.o ./internal/c/parts/video/font/freetype/gxvmorx4.o ./internal/c/parts/video/font/freetype/gxvmorx5.o ./internal/c/parts/video/font/freetype/gxvopbd.o ./internal/c/parts/video/font/freetype/gxvprop.o ./internal/c/parts/video/font/freetype/gxvtrak.o ./internal/c/parts/video/font/freetype/inffast.o ./internal/c/parts/video/font/freetype/inflate.o ./internal/c/parts/video/font/freetype/inftrees.o ./internal/c/parts/video/font/freetype/md5.o ./internal/c/parts/video/font/freetype/otvbase.o ./internal/c/parts/video/font/freetype/otvcommn.o ./internal/c/parts/video/font/freetype/otvgdef.o ./internal/c/parts/video/font/freetype/otvgpos.o ./internal/c/parts/video/font/freetype/otvgsub.o ./internal/c/parts/video/font/freetype/otvjstf.o ./internal/c/parts/video/font/freetype/otvmath.o ./internal/c/parts/video/font/freetype/otvmod.o ./internal/c/parts/video/font/freetype/pcfdrivr.o ./internal/c/parts/video/font/freetype/pcfread.o ./internal/c/parts/video/font/freetype/pcfutil.o ./internal/c/parts/video/font/freetype/pfrcmap.o ./internal/c/parts/video/font/freetype/pfrdrivr.o ./internal/c/parts/video/font/freetype/pfrgload.o ./internal/c/parts/video/font/freetype/pfrload.o ./internal/c/parts/video/font/freetype/pfrobjs.o ./internal/c/parts/video/font/freetype/pfrsbit.o ./internal/c/parts/video/font/freetype/pngshim.o ./internal/c/parts/video/font/freetype/psarrst.o ./internal/c/parts/video/font/freetype/psauxmod.o ./internal/c/parts/video/font/freetype/psblues.o ./internal/c/parts/video/font/freetype/psconv.o ./internal/c/parts/video/font/freetype/pserror.o ./internal/c/parts/video/font/freetype/psfont.o ./internal/c/parts/video/font/freetype/psft.o ./internal/c/parts/video/font/freetype/pshalgo.o ./internal/c/parts/video/font/freetype/pshglob.o ./internal/c/parts/video/font/freetype/pshints.o ./internal/c/parts/video/font/freetype/pshmod.o ./internal/c/parts/video/font/freetype/pshrec.o ./internal/c/parts/video/font/freetype/psintrp.o ./internal/c/parts/video/font/freetype/psmodule.o ./internal/c/parts/video/font/freetype/psobjs.o ./internal/c/parts/video/font/freetype/psread.o ./internal/c/parts/video/font/freetype/psstack.o ./internal/c/parts/video/font/freetype/sfdriver.o ./internal/c/parts/video/font/freetype/sfobjs.o ./internal/c/parts/video/font/freetype/sfwoff.o ./internal/c/parts/video/font/freetype/sfwoff2.o ./internal/c/parts/video/font/freetype/t1afm.o ./internal/c/parts/video/font/freetype/t1cmap.o ./internal/c/parts/video/font/freetype/t1decode.o ./internal/c/parts/video/font/freetype/t1driver.o ./internal/c/parts/video/font/freetype/t1gload.o ./internal/c/parts/video/font/freetype/t1load.o ./internal/c/parts/video/font/freetype/t1objs.o ./internal/c/parts/video/font/freetype/t1parse.o ./internal/c/parts/video/font/freetype/t42drivr.o ./internal/c/parts/video/font/freetype/t42objs.o ./internal/c/parts/video/font/freetype/t42parse.o ./internal/c/parts/video/font/freetype/ttbdf.o ./internal/c/parts/video/font/freetype/ttcmap.o ./internal/c/parts/video/font/freetype/ttcolr.o ./internal/c/parts/video/font/freetype/ttcpal.o ./internal/c/parts/video/font/freetype/ttdriver.o ./internal/c/parts/video/font/freetype/ttgload.o ./internal/c/parts/video/font/freetype/ttgpos.o ./internal/c/parts/video/font/freetype/ttgxvar.o ./internal/c/parts/video/font/freetype/ttinterp.o ./internal/c/parts/video/font/freetype/ttkern.o ./internal/c/parts/video/font/freetype/ttload.o ./internal/c/parts/video/font/freetype/ttmtx.o ./internal/c/parts/video/font/freetype/ttobjs.o ./internal/c/parts/video/font/freetype/ttpload.o ./internal/c/parts/video/font/freetype/ttpost.o ./internal/c/parts/video/font/freetype/ttsbit.o ./internal/c/parts/video/font/freetype/ttsvg.o ./internal/c/parts/video/font/freetype/winfnt.o ./internal/c/parts/video/font/freetype/woff2tags.o ./internal/c/parts/video/font/freetype/zutil.o ./internal/c/parts/video/font/font.o ./internal/c/parts/video/font/hashing.o ./internal/c/parts/video/font/stub_font.o ./internal/c/parts/video/image/image.o ./internal/c/parts/video/image/jo_gif/jo_gif.o ./internal/c/parts/video/image/nanosvg/nanosvg.o ./internal/c/parts/video/image/pixelscalers/hqx.o ./internal/c/parts/video/image/pixelscalers/mmpx.o ./internal/c/parts/video/image/pixelscalers/sxbr.o ./internal/c/parts/video/image/qoi/qoi.o ./internal/c/parts/video/image/sg_curico/sg_curico.o ./internal/c/parts/video/image/sg_pcx/sg_pcx.o ./internal/c/parts/video/image/stb/stb_image.o ./internal/c/parts/video/image/image.a ./internal/c/parts/gui/tinyfiledialogs.o ./internal/c/parts/gui/gui.o ./internal/c/parts/data/data_processing.a ./internal/c/parts/data/miniz.o ./internal/c/parts/data/modp_b64.o ./internal/c/parts/data/compression.o ./internal/c/parts/data/encoding.o ./internal/c/parts/os/clipboard/clipboard.a ./internal/c/parts/os/clipboard/clip/clip.o ./internal/c/parts/os/clipboard/clip/image.o ./internal/c/parts/os/clipboard/clip/clip_osx.o ./internal/c/parts/os/clipboard/clipboard.o
c++ -std=gnu++20 -fno-strict-aliasing -Wno-conversion-null -I./internal/c/libqb/include -I./internal/c/parts/core/freeglut/include -I./internal/c/parts/core/glew/include -DDEPENDENCY_SOCKETS -DDEPENDENCY_NO_PRINTER -DDEPENDENCY_ICON -DDEPENDENCY_NO_SCREENIMAGE internal/c/libqb.cpp -c -o internal/c/libqb_make_00010100.o
c++ -std=gnu++20 -fno-strict-aliasing -Wno-conversion-null -I./internal/c/libqb/include -I./internal/c/parts/core/freeglut/include -I./internal/c/parts/core/glew/include -DDEPENDENCY_SOCKETS -DDEPENDENCY_NO_PRINTER -DDEPENDENCY_ICON -DDEPENDENCY_NO_SCREENIMAGE internal/c/qbx.cpp -c -o internal/c/qbx.o
c++ -O2 -std=gnu++20 -fno-strict-aliasing -Wno-conversion-null -I./internal/c/libqb/include -I./internal/c/parts/core/freeglut/include -I./internal/c/parts/core/glew/include -DDEPENDENCY_SOCKETS -DDEPENDENCY_NO_PRINTER -DDEPENDENCY_ICON -DDEPENDENCY_NO_SCREENIMAGE -Wall -Wextra internal/c/libqb/src/threading.cpp -c -o internal/c/libqb/src/threading.o
error: errorinvalid: value 'gnu++20'invalid invalue error '-std=gnu++20': 'gnu++20'
in invalid'-std=gnu++20' value
note'gnu++20': inusenote : '-std=gnu++20''c++98' use
or 'c++98''c++03' orfornote 'c++03': 'ISO C++ 1998 with amendments' forusestandard 'ISO C++ 1998 with amendments''c++98'
standardor
'c++03' notefor: note'ISO C++ 1998 with amendments'use: standard'gnu++98'use
or'gnu++98' 'gnu++03'or notefor'gnu++03': 'ISO C++ 1998 with amendments and GNU extensions'for use standard 'ISO C++ 1998 with amendments and GNU extensions''gnu++98'
standardor
'gnu++03'note : fornote: use'ISO C++ 1998 with amendments and GNU extensions' use'c++11'standard 'c++11'for
for'ISO C++ 2011 with amendments' note'ISO C++ 2011 with amendments'standard: standard
use
'c++11' notefor: note : 'ISO C++ 2011 with amendments'use standarduse'gnu++11'
'gnu++11'for for'ISO C++ 2011 with amendments and GNU extensions' note 'ISO C++ 2011 with amendments and GNU extensions': standard usestandard
'gnu++11'
fornote : note'ISO C++ 2011 with amendments and GNU extensions': usestandard use'c++14'
'c++14'for notefor'ISO C++ 2014 with amendments': 'ISO C++ 2014 with amendments'standarduse standard
'c++14'
for note'ISO C++ 2014 with amendments': note standard: use
use'gnu++14' 'gnu++14'for notefor : 'ISO C++ 2014 with amendments and GNU extensions''ISO C++ 2014 with amendments and GNU extensions' use standard standard'gnu++14'
for note'ISO C++ 2014 with amendments and GNU extensions'note: : standarduseuse
'c++17''c++17' fornotefor : 'ISO C++ 2017 with amendments''ISO C++ 2017 with amendments' usestandardstandard 'c++17'
for 'ISO C++ 2017 with amendments'notenote : : standarduseuse
'gnu++17''gnu++17' noteforfor: 'ISO C++ 2017 with amendments and GNU extensions'use'ISO C++ 2017 with amendments and GNU extensions' standard'gnu++17'standard
for
'ISO C++ 2017 with amendments and GNU extensions'note note: standard: use
use'c++2a' note'c++2a'for: for'Working draft for ISO C++ 2020'use 'Working draft for ISO C++ 2020''c++2a'standard standard
for
'Working draft for ISO C++ 2020'note : standardnoteuse:
'gnu++2a'use fornote'gnu++2a': 'Working draft for ISO C++ 2020 with GNU extensions'foruse standard'Working draft for ISO C++ 2020 with GNU extensions''gnu++2a'
standardfor
'Working draft for ISO C++ 2020 with GNU extensions' standard
make: *** [internal/c/libqb/src/threading.o] Error 1
make: *** Waiting for unfinished jobs....
make: *** [internal/c/qbx.o] Error 1
make: *** [internal/c/libqb_make_00010100.o] Error 1
Most of the WP stuff I made decades ago required a lot of emphasis on saving memory, so a gigantic doc, as a single string, was not in the cards back then. At one point I made a single string version, but rather than dig through the last 8 years of crap quality work, I decided to have some fun and start a new build.
So this is the fundamentals without text highlighting. It has _Resize to squish or expand the page width. If you REM out the included test string, you can run it with whatever you have stored to your clipboard.
Right now, it is in bruit force mode, meaning it does a rewrap for every key press. I'll modify it to only wrap when needed, place it into subs, and switch over to UDTs at some point.
Use the Insert key to switch from insert to overwrite mode. All other WP keys to control the cursor, page keys, home end, Ctrl+Home, Ctrl+End, etc. are included. Enter key for paragraph.
Code: (Select All)
$Resize:On Width60, 35: _Font16
t.mt = 3: t.ml = 4: t.mr = t.ml + 19: t.mb = t.mt + 4
t.pw = t.mr - t.ml + 1: total = Len(new$): DisplayHeight = t.mb - t.mt + 1 IfLen(_Clipboard$) Then new$ = _Clipboard$ ReDim track(0), eol(0) GoSub skin
CurStyle = 7 Do ReDim map(DisplayHeight) AsString: For i = 1To DisplayHeight: map(i) = String$(t.ml - 1 + t.pw, Chr$(0)): Next IfNot scroll ThenReDim track(0), eol(0): index = 0: TextLines = 0: a = 1: DisplayOnScreen = 0: total = Len(new$) Else index = t.scr
CurShow = 0: Locate , , CurShow Do
index = index + 1 IfNot scroll Then If TextLines >= t.scr And DisplayOnScreen = 0Then DisplayOnScreen = -1 IfInStr(Mid$(new$, a, t.pw + 1), Chr$(13)) Then
q = 2: c = a: para$ = Chr$(20)
x1$ = Mid$(new$, a, InStr(Mid$(new$, a, t.pw + 1), Chr$(13)) - 1) Else IfRight$(Mid$(new$, a, t.pw + 1), 1) = " "And t.pw > 1Then q = 1Else q = 0
x1$ = Mid$(new$, a, t.pw): c = a End If If q Or a + t.pw > total Then If a + Len(x1$) + q > total Then q = -1: Else a = a + Len(x1$) + q Else If_InStrRev(x1$, " ") Then x1$ = Mid$(x1$, 1, _InStrRev(x1$, " "))
a = a + Len(x1$) End If
TextLines = TextLines + 1 ReDim_Preserve track(TextLines + 1), eol(TextLines + 1)
track(TextLines) = c: eol(TextLines) = Len(x1$) Else IfUBound(track) < t.scr + 1 + cnt ThenReDim_Preserve track(t.scr + 1 + cnt + 1), eol(t.scr + 1 + cnt + 1)
x1$ = Mid$(new$, track(t.scr + 1 + cnt), eol(t.scr + 1 + cnt)) IfMid$(new$, track(t.scr + 1 + cnt) + eol(t.scr + 1 + cnt), 1) = Chr$(13) Then para$ = Chr$(20)
DisplayOnScreen = -1 End If
s$ = String$(t.pw, 0): Mid$(s$, 1) = x1$ If CurReplaceArray Then IfLen(para$) Then k = 1Else k = 0 If track(index) - 1 + eol(index) + k >= CurReplaceArray Or q = -1And DisplayOnScreen < 0Then' q = -1 handles deleting from the end of the text. If cnt = 0And DisplayOnScreen = 0Then DisplayOnScreen = -1: t.scr = index - DisplayHeight If DisplayOnScreen < 0Then
yy = t.mt - 1 + cnt + 1: xx = t.ml + CurReplaceArray - track(index): CurReplaceArray = 0 If ParaRemoved And xx = t.ml AndMid$(new$, track(row - 1), 1) = Chr$(13) Then autokey$ = Chr$(0) + "H|" + Chr$(0) + "O" End If End If End If If DisplayOnScreen < 0Then
cnt = cnt + 1 Mid$(map(cnt), 1) = x1$ + para$ ' Map may be 1 column longer if it ends in a paragraph. Locate t.mt - 1 + cnt, t.ml, CurShow, 7, CurStyle: Print s$; If cnt = DisplayHeight Or scroll And cnt = TextLines Then
DisplayOnScreen = 1: If scroll Then q = -1 End If End If
para$ = "" Loop Until q = -1 If DisplayOnScreen <> 1ThenFor i = 0To t.mb - t.mt - cnt: Locate t.mt + cnt + i, t.ml, CurShow, 7, CurStyle: PrintSpace$(t.pw);: Next: DisplayOnScreen = 1
track(TextLines + 1) = Len(new$) + 1: eol(TextLines + 1) = 0
j = 0: q = 0: x1$ = "": cnt = 0: scroll = 0: hh = 0: para$ = "": ParaRemoved = 0
CurShow = 1: j = 0: GoSub Place_Cursor Do If_ResizeThen If initiate Then If_ResizeWidth \ _FontWidth > _WidthAnd_Width < 150Then t.mr = t.mr + 1: t.pw = t.mr - t.ml + 1: Width_Width + 1, _Height: _Font16: GoSub skin: Exit Do If_ResizeWidth \ _FontWidth < _WidthThen If t.mr - t.ml > 0Then
t.mr = t.mr - 1: t.pw = t.mr - t.ml + 1: Width_Width - 1, _Height: _Font16: GoSub skin: Exit Do End If End If End If
initiate = 1 End If _Limit60 GoSub keyboard IfLen(b$) ThenExit Do Loop
yy = CsrLin: xx = Pos(0) Loop
keyboard: While_MouseInput: m.mw = m.mw + _MouseWheel: Wend
m.x = _MouseX
m.y = _MouseY
m.lb = _MouseButton(1)
m.rb = _MouseButton(2) If m.mw Then If m.mw > 0Then b$ = Chr$(0) + "P"Else b$ = Chr$(0) + "H"
m.mw = 0 Else IfLen(autokey$) Then IfInStr(autokey$, "|") Then b$ = Mid$(autokey$, 1, InStr(autokey$, "|") - 1): autokey$ = Mid$(autokey$, InStr(autokey$, "|") + 1) Else b$ = autokey$: autokey$ = "" Else
b$ = InKey$ End If End If IfLen(b$) Then
j = 0: row = yy + t.scr - (t.mt - 1): xxEOL = t.ml - 1 + eol(row) Select Case b$ CaseChr$(27): System CaseChr$(13) ' Paragraph.
t = track(yy - (t.mt - 1) + t.scr): t = t + xx - (t.ml - 1) - 1
new$ = Mid$(new$, 1, t - 1) + Chr$(13) + Chr$(10) + Mid$(new$, t)
TextLines = TextLines + 1: ReDim_Preserve track(TextLines + 1), eol(TextLines + 1)
autokey$ = Chr$(0) + "P" + "|" + Chr$(0) + "G" CaseChr$(32) ToChr$(126)
t = track(row) + xx - (t.ml - 1) - 1 If t > total Or ovw = 0Or ovw AndMid$(new$, t, 1) = Chr$(13) Then
new$ = Mid$(new$, 1, t - 1) + b$ + Mid$(new$, t) Else' Overwrite within text. Mid$(new$, t, 1) = b$ End If If xx > t.mr And yy = t.mb Then t.scr = t.scr + 1' Forces scroll down to next line. If yy = t.mt And t.scr > 0And DisplayHeight > 2Then t.scr = t.scr - 1 If yy = t.mb And t.scr + DisplayHeight < TextLines And DisplayHeight > 1Then t.scr = t.scr + 1 GoSub Cursor_Relocate: autokey$ = Chr$(0) + "M" CaseChr$(8) If row > 1Or row = 1And xx > t.ml Then autokey$ = Chr$(0) + "K|" + Chr$(0) + "S" CaseChr$(0) + "S"' Delete. GoSub Cursor_Relocate IfMid$(new$, CurReplaceArray, 1) = Chr$(13) Then k = 1Else k = 0
new$ = Mid$(new$, 1, CurReplaceArray - 1) + Mid$(new$, CurReplaceArray + k + 1) If yy = t.mt And t.scr > 0And DisplayHeight > 2Then t.scr = t.scr - 1 If yy = t.mb And t.scr + DisplayHeight < TextLines And DisplayHeight > 1Then t.scr = t.scr + 1 If k Then ParaRemoved = -1: k = 0 CaseChr$(0) + "I"' PgUp.
t.scr = t.scr - (DisplayHeight - 1): If t.scr < 0Then t.scr = 0 If xx - (t.ml - 1) > eol(row) Then autokey$ = Chr$(0) + "O" CaseChr$(0) + "Q"' PgDn.
t.scr = t.scr + (DisplayHeight - 1): If t.scr + DisplayHeight > TextLines Then t.scr = TextLines - DisplayHeight If xx - (t.ml - 1) > eol(row) Then autokey$ = Chr$(0) + "O" CaseChr$(0) + "s"' Ctrl + Arrow Lt.
k = track(row) - 1 + xx - (t.ml - 1) - 1: i = 0 IfMid$(new$, k, 1) = Chr$(10) Then
autokey$ = Chr$(0) + "K" Else Do Until k = 0
t$ = Mid$(new$, k, 1): If i = 0And t$ > Chr$(32) Then i = 1 If i Then If t$ = " "Then k = k + 1: Exit Do If t$ = Chr$(13) Then k = k + 2: Exit Do End If
k = k - 1 Loop If k Then
CurReplaceArray = k Do If CurReplaceArray >= track(t.scr + 1) ThenExit DoElse t.scr = t.scr - 1 Loop Else
autokey$ = Chr$(0) + "w" End If End If
k = 0: h = 0: i = 0: t$ = "" CaseChr$(0) + "t"' Ctrl + Arrow Rt.
k = track(row) - 1 + xx - (t.ml - 1): h = 0 If k < total Then Do
t$ = Mid$(new$, k, 1): If t$ = " "Or t$ = Chr$(13) Then h = Asc(t$) If t$ <> " "And h ThenExit DoElse k = k + 1 Loop Until k = total If h = 13And k = track(row) - 1 + xx - (t.ml - 1) Then
autokey$ = Chr$(0) + "M"' Move off a paragraph. Do not use k + 2 here as it will jump a paragraph with terminal paragraph/paragraph/paragraph format. Else If k = total Then
autokey$ = Chr$(0) + "u" Else
CurReplaceArray = k If DisplayHeight >= TextLines Then k = TextLines Else k = t.scr + DisplayHeight Do If t.scr < TextLines - DisplayHeight And CurReplaceArray >= track(k) + eol(k) Then t.scr = t.scr + 1: k = k + 1ElseExit Do Loop End If End If
k = 0: h = 0: t$ = "" Else
autokey$ = Chr$(0) + "O" End If CaseChr$(0) + "w"' Ctrl + Home.
yy = t.mt: xx = t.ml: j = 0: GoSub Place_Cursor: t.scr = 0 CaseChr$(0) + "u"' Ctrl + End. If t.scr + DisplayHeight < TextLines Then
t.scr = TextLines - DisplayHeight: autokey$ = Chr$(0) + "u" Else
yy = TextLines - t.scr + (t.mt - 1): xx = t.mr + 1: j = -1: GoSub Place_Cursor
autokey$ = Chr$(0) + "P"' Check for terminal paragraph and ignore if not present. End If CaseChr$(0) + "G"
xx = t.ml: GoSub Place_Cursor CaseChr$(0) + "O"
j = -1: xx = t.mr + 1: GoSub Place_Cursor CaseChr$(0) + "K" If xx > t.ml Then
xx = xx - 1: j = 0: GoSub Place_Cursor Else If row > 1Then
tmp$ = Mid$(new$, track(row - 1) + eol(row - 1), 1) If tmp$ = Chr$(13) Or tmp$ = Chr$(32) And eol(row - 1) = t.pw Then tmp$ = ""Else tmp$ = "|" + Chr$(0) + "K" If autokey$ = ""Then
autokey$ = Chr$(0) + "H|" + Chr$(0) + "O" + tmp$ Else
autokey$ = Chr$(0) + "H|" + Chr$(0) + "O" + tmp$ + "|" + autokey$ ' Adds Backspace if present. End If
tmp$ = "" End If End If CaseChr$(0) + "M" If xx < xxEOL Or xx = xxEOL And row = TextLines Or xx = xxEOL AndMid$(new$, track(row) + t.pw, 1) = " "Or xx = xxEOL AndMid$(new$, track(row) + eol(row), 1) = Chr$(13) Then If row <= TextLines Then xx = xx + 1: j = 0: GoSub Place_Cursor Else If row < TextLines Or row = TextLines And xx > t.mr AndMid$(new$, track(row) + t.pw, 1) = " "OrMid$(new$, track(row) + eol(row), 1) = Chr$(13) Then' > occurs when a marginal space is present.
autokey$ = Chr$(0) + "P" + "|" + Chr$(0) + "G" End If End If CaseChr$(0) + "H" If yy = t.mt Then If t.scr > 0Then t.scr = t.scr - 1Else b$ = "" Else
yy = yy - 1: j = -1: GoSub Place_Cursor End If CaseChr$(0) + "P" Select Case row Case Is = TextLines ' Last line only cursors down if text line is full. If eol(row) = t.pw AndMid$(new$, track(row) + t.pw, 1) = " "OrMid$(new$, track(row) + eol(row), 1) = Chr$(13) Then If yy = t.mb Then t.scr = t.scr + 1Else yy = yy + 1: xx = t.ml
TextLines = TextLines + 1: ReDim_Preserve track(TextLines + 1), eol(TextLines + 1)
track(TextLines) = Len(new$) + 1: eol(TextLines) = 0
j = -1: GoSub Place_Cursor ' Cursor will be placed in home line position. Else
b$ = ""' Can't cursor down. End If Case Is < TextLines If yy = t.mb Then t.scr = t.scr + 1Else yy = yy + 1: j = -1: GoSub Place_Cursor End Select CaseChr$(0) + "R"
ovw = Not ovw If ovw Then CurStyle = 1Else CurStyle = 7 Case Else: b$ = "" End Select IfLen(b$) = 2ThenIfInStr("KMHPIQGOtsuw", Right$(b$, 1)) Then scroll = -1 Else If m.y And oldmy <> m.y Or m.x And m.x <> oldmx Or m.lb = -1Or m.rb = -1Then If m.y >= t.mt And m.x <= t.mr + 1And m.y <= t.mb And m.x >= t.ml Then inside = _TRUE Else inside = _FALSE If inside = _TRUE Then If m.lb = -1Then
y1 = m.y - (t.mt - 1): x1 = m.x - (t.ml - 1) Rem t = track(y1 + t.scr): t = t + x1 - 1 IfAsc(Mid$(map(y1), x1, 1)) Then
yy = m.y: xx = m.x: j = 0: GoSub Place_Cursor Else IfAsc(Left$(map(y1), 1)) > 0Then' Click inside page but beyond text.
yy = m.y: xx = t.mr + 1: j = -1: GoSub Place_Cursor Else If t.scr + y1 = TextLines Then' Last line after a new paragraph was started.
yy = m.y: xx = t.mr + 1: j = -1: GoSub Place_Cursor End If End If End If End If End If End If End If
oldmy = m.y: oldmx = m.x Return
Place_Cursor:
row = yy + t.scr - (t.mt - 1): xxEOL = t.ml - 1 + eol(row) If j And xx > xxEOL Then xx = xxEOL + 1 Locate yy, xx, CurShow, 7, CurStyle
j = 0 Return
It's an odd request, but I'm a big fan of function pointers/dispatch tables. I always want one more level of indirection
Using a big Select Case instead of an array of a UDT type with a pointer will get the job done and is no hardship, but it never hurts to ask. so this is more of a want than a need and it's certainly not a typical Basic sounding thing.
As an aside I've been "futzing" around with QB64PE for the past couple of weeks and the experience on the Mac has been great. I've tried a few times in the past but kept drifting away. Solid work you all have been doing.
A friend sent this to me. I wasn't sure where to post it, but it's very eye-opening and well worth the read. It's an article on AI and how it's getting better at an exponential rate, written by a programmer. The implications are pretty disturbing. Buckle up.
#1 is old school 3-D like in the 1950s. Holy cow it works! You'll need the red/blue 3d glasses* - looks lame without them.
#2 is 1980s style isometric graphics, no glasses needed.
*Search Amazon or your favorite store for "3D Paper Glasses for Movies and TV - Blue and Red Anaglyph Cardboard Glasses for Films" - 5 pairs for $3.99!
"
