For now I'll call attention to one simple case - a 4:3 ratio.
Say 100 columns to 75 rows, that's 4:3 right?
100x75 = 7500 items.
Here is what the 2 programs output for 7500 items:
Is my program's output not correct?
Code for both programs is below.
Anyway, thanks again for your patience and time with this...
I will follow up later!
Madscijr:
Steve:
Say 100 columns to 75 rows, that's 4:3 right?
100x75 = 7500 items.
Here is what the 2 programs output for 7500 items:
| Program | Items | H-Ratio | V-Ratio | Columns | Rows | Total Cells | Empty Cells | Layout |
|---|---|---|---|---|---|---|---|---|
| steve | 7500 | 4 | 3 | 104 | 78 | 8112 | 612 | Older PC monitor + analog TV (640x480; 1024x768; etc.) |
| madsci | 7500 | 4 | 3 | 100 | 75 | 7500 | 0 | Older PC monitor + analog TV (640x480, 1024x768, etc.) |
Is my program's output not correct?
Code for both programs is below.
Anyway, thanks again for your patience and time with this...
I will follow up later!
Madscijr:
Code: (Select All)
Option _Explicit
Type LayoutType
HRatio As Single
VRatio As Single
Name As String
ColumnCount As Integer
RowCount As Integer
TargetCount As Long
CellCount As Long
EmptyCells As Long
Error As String
End Type ' LayoutType
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim iLoop1 As Integer
Dim iLoop2 As Integer
Dim iCount As Integer
Dim iItemCount As Long
Dim iEvenCount As Long
Dim iSquareCount As Long
Dim iLayoutCount As Integer
Dim sNextName As String
Dim RatioSum As Single
Dim sngColumnCount As Single
Dim sngRowCount As Single
Dim sngRowCol As Single
Dim sRatio As String
Dim sColsRows As String
Dim sCount As String
Dim sLine As String
Dim iMaxEmpty As Long
Dim iMinEmpty As Long
Dim iNextMinEmpty As Long
Dim iIndex As Integer
Dim iSortIndex As Integer
Dim bFinished As Integer
Dim in$
' LAYOUTS
ReDim arrLayout(1 To 32) As LayoutType
ReDim arrSorted(1 To 32) As LayoutType
' SHOW USER DEBUG FILE/PATH SO THEY CAN COPY TO CLIPBOARD:
in$ = _INPUTBOX$(m_ProgramName$, "Current debug filename is:", m_ProgramPath$ + m_ProgramName$ + ".txt")
' INIT SCREEN
Screen _NewImage(1280, 900, 32)
_ScreenMove 0, 0
Cls , cBlack
' =============================================================================
' INITIALIZE LAYOUT OPTIONS
For iLoop1 = LBound(arrLayout) To UBound(arrLayout)
arrLayout(iLoop1).Name = ""
arrLayout(iLoop1).HRatio = 0
arrLayout(iLoop1).VRatio = 0
arrLayout(iLoop1).Error = ""
Next iLoop1
iLayoutCount = 0
Restore RatioData
Do
iLayoutCount = iLayoutCount + 1
Read arrLayout(iLayoutCount).HRatio
Read arrLayout(iLayoutCount).VRatio
Read sNextName: arrLayout(iLayoutCount).Name = Replace$(sNextName, ";", ",")
If arrLayout(iLayoutCount).HRatio = 0 Then Exit Do
Loop
RatioData:
Data 1,1,Square (profile pictures; social media)
Data 2,3,Classic 35mm (4x6; 6x9; etc.)
Data 5,7,5 x 7 photo
Data 17,22,Standard letter size (8.5x11)
Data 4,3,Older PC monitor + analog TV (640x480; 1024x768; etc.)
Data 4,5,Art prints + medium format (8x10; 16x20)
Data 11,14,legal paper (11x14)
Data 16,9,Standard HD display (1920x1080; 1280x720; etc.)
Data 0,0,Custom (user enters ratio)
' =============================================================================
' PROMPT USER TO ENTER A NUMBER THEN CALCULATE ROWS/COLUMNS BASED ON LAYOUT RATIOS
Do
Do
Color cLtGray, cBlack
Print "-------------------------------------------------------------------------------"
Print "Grid Layouts"
Print "-------------------------------------------------------------------------------"
Input "Number of items? (0 to exit)"; in$
Print
_KeyClear: '_DELAY 1
If IsNumber%(in$) = _TRUE Then
iItemCount = Val(in$)
Exit Do
End If
Loop
If iItemCount < 1 Then Exit Do
' -----------------------------------------------------------------------------
' Get even # of items
If IsEven%(iItemCount) = _TRUE Then
iEvenCount = iItemCount
Else
iEvenCount = iItemCount + 1
End If
' -----------------------------------------------------------------------------
' Get total # of items we would need for an equal number of rows and columns
' DOES COUNT ALLOW FOR A PERFECT SQUARE?
sngRowCol = Sqr(iItemCount)
If sngRowCol = Int(sngRowCol) Then
' COUNT IS ALREADY RIGHT FOR SQUARE LAYOUT
iSquareCount = iItemCount
Else
' ADD ITEMS TO ALLOW FOR SQUARE LAYOUT
iSquareCount = iItemCount
Do
iSquareCount = iSquareCount + 1
sngRowCol = Sqr(iSquareCount)
If sngRowCol = Int(sngRowCol) Then Exit Do
Loop
End If
' -----------------------------------------------------------------------------
' DETERMINE RATIOS WITH CALCULATED NUMBER OF ROWS/COLUMNS FOR EACH
iMaxEmpty = 0
'For iLoop1 = 1 To iLayoutCount
For iLoop1 = LBound(arrLayout) To UBound(arrLayout)
' Ignore uninitialized
If arrLayout(iLoop1).HRatio > 0 And arrLayout(iLoop1).VRatio > 0 Then
arrLayout(iLoop1).Error = ""
arrLayout(iLoop1).ColumnCount = 0
arrLayout(iLoop1).RowCount = 0
arrLayout(iLoop1).TargetCount = iItemCount
arrLayout(iLoop1).CellCount = 0
arrLayout(iLoop1).EmptyCells = 0
If arrLayout(iLoop1).HRatio <= 0 Then
arrLayout(iLoop1).Error = arrLayout(iLoop1).Error + _
"Illegal value: " + _
"arrLayout(" + _TRIM$(Str$(iLoop1)) + ").HRatio = " + _
_TRIM$(Str$(arrLayout(iLoop1).HRatio)) + ". "
End If
If arrLayout(iLoop1).VRatio <= 0 Then
arrLayout(iLoop1).Error = arrLayout(iLoop1).Error + _
"Illegal value: " + _
"arrLayout(" + _TRIM$(Str$(iLoop1)) + ").VRatio = " + _
_TRIM$(Str$(arrLayout(iLoop1).VRatio)) + ". "
End If
If Len(arrLayout(iLoop1).Error) = 0 Then
' IS RATIO A PERFECT SQUARE?
If arrLayout(iLoop1).HRatio = arrLayout(iLoop1).VRatio Then
' # OF COLUMS EQUALS # ROWS
arrLayout(iLoop1).ColumnCount = Sqr(iSquareCount)
arrLayout(iLoop1).RowCount = arrLayout(iLoop1).ColumnCount
Else
' NOT A PERFECT SQUARE
sngColumnCount = Sqr(iEvenCount * (arrLayout(iLoop1).HRatio / arrLayout(iLoop1).VRatio))
sngRowCount = Sqr(iEvenCount * (arrLayout(iLoop1).VRatio / arrLayout(iLoop1).HRatio))
' DO THESE DIVIDE EVENLY?
If sngColumnCount = Int(sngColumnCount) Then
arrLayout(iLoop1).ColumnCount = Int(sngColumnCount)
Else
arrLayout(iLoop1).ColumnCount = Fix(sngColumnCount)
End If
If sngRowCount = Int(sngRowCount) Then
arrLayout(iLoop1).RowCount = Int(sngRowCount)
Else
arrLayout(iLoop1).RowCount = Fix(sngRowCount)
End If
' ENOUGH COLUMNS & ROWS?
If arrLayout(iLoop1).HRatio > arrLayout(iLoop1).VRatio Then
Do
If arrLayout(iLoop1).ColumnCount * arrLayout(iLoop1).RowCount >= iItemCount Then Exit Do
arrLayout(iLoop1).ColumnCount = arrLayout(iLoop1).ColumnCount + 1
Loop
Else
Do
If arrLayout(iLoop1).ColumnCount * arrLayout(iLoop1).RowCount >= iItemCount Then Exit Do
arrLayout(iLoop1).RowCount = arrLayout(iLoop1).RowCount + 1
Loop
End If
End If
End If
' Calculate total # of cells + empty cells
If Len(arrLayout(iLoop1).Error) = 0 Then
arrLayout(iLoop1).CellCount = arrLayout(iLoop1).ColumnCount * arrLayout(iLoop1).RowCount
arrLayout(iLoop1).EmptyCells = arrLayout(iLoop1).CellCount - arrLayout(iLoop1).TargetCount
' STORE MAXIMUM # OF EMPTY CELLS
If arrLayout(iLoop1).EmptyCells > iMaxEmpty Then
iMaxEmpty = arrLayout(iLoop1).EmptyCells
End If
End If
End If
Next iLoop1
' -----------------------------------------------------------------------------
' SORT RATIOS IN ORDER OF EMPTY CELLS
'arrLayout(iLoop1).EmptyCells = arrLayout(iLoop1).CellCount - arrLayout(iLoop1).TargetCount
' INITIALIZE SORTED LAYOUTS
For iLoop1 = LBound(arrSorted) To UBound(arrSorted)
arrSorted(iLoop1).Name = ""
arrSorted(iLoop1).HRatio = 0
arrSorted(iLoop1).VRatio = 0
arrSorted(iLoop1).Error = ""
Next iLoop1
' SORT RATIOS
bFinished = _FALSE
iSortIndex = LBound(arrSorted) - 1
iMinEmpty = iMaxEmpty + 1 ' reset min value to find
Do
' Reset compare
iNextMinEmpty = iMaxEmpty + 1 ' reset temp min value to find
iIndex = LBound(arrLayout) - 1 ' Set iIndex outside of array bounds, next smallest not found (yet)
' Find smallest empty
For iLoop1 = LBound(arrLayout) To UBound(arrLayout)
' Ignore unused
If arrLayout(iLoop1).HRatio > 0 And arrLayout(iLoop1).VRatio > 0 Then
' Ignore errors
If Len(arrLayout(iLoop1).Error) = 0 Then
' Is this the smallest yet?
If arrLayout(iLoop1).EmptyCells < iMinEmpty Then
iMinEmpty = arrLayout(iLoop1).EmptyCells ' update minimum
End If
' Is this the smallest of the ones left so far?
If arrLayout(iLoop1).EmptyCells < iNextMinEmpty Then
iNextMinEmpty = arrLayout(iLoop1).EmptyCells ' update minimum
iIndex = iLoop1 ' remember this layout
End If
End If
End If
Next iLoop1
' Add smallest to sorted
' As long as iIndex is within array bounds, we found next smallest
If iIndex >= LBound(arrLayout) Then
iSortIndex = iSortIndex + 1
If iSortIndex <= UBound(arrSorted) Then
arrSorted(iSortIndex).HRatio = arrLayout(iIndex).HRatio
arrSorted(iSortIndex).VRatio = arrLayout(iIndex).VRatio
arrSorted(iSortIndex).Name = arrLayout(iIndex).Name
arrSorted(iSortIndex).ColumnCount = arrLayout(iIndex).ColumnCount
arrSorted(iSortIndex).RowCount = arrLayout(iIndex).RowCount
arrSorted(iSortIndex).TargetCount = arrLayout(iIndex).TargetCount
arrSorted(iSortIndex).CellCount = arrLayout(iIndex).CellCount
arrSorted(iSortIndex).EmptyCells = arrLayout(iIndex).EmptyCells
arrSorted(iSortIndex).Error = ""
arrLayout(iIndex).Error = "Sorted" ' remove this from sort pool
Else
' Exceeded sorted array size, quit sorting
Exit Do
End If
Else
' Finished sorting
Exit Do
End If
Loop
' -----------------------------------------------------------------------------
' HEADER FOR DISPLAYING SORTED RESULTS TO SCREEN
Color cLtGray, cBlack
Print "LAYOUTS FROM MOST OPTIMAL TO LEAST:"
Print
Color cWhite~&, cBlack
Print " # H-Ratio V-Ratio Columns Rows Cells Empty Layout"
Print "---- -------- -------- -------- -------- -------- -------- ------"
' 1 12345678 12345678 12345678 12345678 12345678 12345678 123456
' -----------------------------------------------------------------------------
' HEADER FOR OUTPUTTING RESULTS TO A TAB-DELIMITED FILE
PrintDebugFile _
"Items" + chr$(9) + _
"H-Ratio" + chr$(9) + _
"V-Ratio" + chr$(9) + _
"Columns" + chr$(9) + _
"Rows" + chr$(9) + _
"Total Cells" + chr$(9) + _
"Empty Cells" + chr$(9) + _
"Layout"
' -----------------------------------------------------------------------------
' OUTPUT RESULTS TO SCREEN AND FILE
iCount = 0
For iLoop1 = LBound(arrSorted) To UBound(arrSorted)
' Ignore unused
If arrSorted(iLoop1).HRatio > 0 And arrSorted(iLoop1).VRatio > 0 Then
iCount = iCount + 1
' -----------------------------------------------------------------------------
' OUTPUT TO SCREEN
' ASSEMBLE SPACE-DELIMITED LINE
sLine = _
Right$(String$(4, " ") + _Trim$(Str$(iItemCount)), 4) + _
" " + _
left$( _Trim$(Str$(arrSorted(iLoop1).HRatio)) + string$(8, " "), 8) + _
" " + _
left$( _Trim$(Str$(arrSorted(iLoop1).VRatio)) + string$(8, " "), 8) + _
" " + _
right$( string$(8, " ") + _Trim$(Str$(arrSorted(iLoop1).ColumnCount)) , 8) + _
" " + _
right$( string$(8, " ") + _Trim$(Str$(arrSorted(iLoop1).RowCount)) , 8) + _
" " + _
right$( string$(8, " ") + _Trim$(Str$(arrSorted(iLoop1).CellCount)) , 8) + _
" " + _
right$( string$(8, " ") + _Trim$(Str$(arrSorted(iLoop1).EmptyCells)) , 8) + _
" " + _
arrSorted(iLoop1).Name
' SHOW OPTIMAL LAYOUTS IN YELLOW, SQUARE LAYOUTS IN LIME, ALL OTHERS IN CYAN
If arrSorted(iLoop1).ColumnCount = arrSorted(iLoop1).RowCount Then
Color cLime~&, cBlack
ElseIf arrSorted(iLoop1).EmptyCells = iMinEmpty Then
Color cYellow~&, cBlack
Else
Color cCyan~&, cBlack
End If
' PRINT NEXT LINE
Print Left$(sLine, 160)
' -----------------------------------------------------------------------------
' OUTPUT TO FILE
' ASSEMBLE TAB-DELIMITED LINE
sLine = _
_Trim$(Str$(iItemCount)) + _
chr$(9) + _
_Trim$(Str$(arrSorted(iLoop1).HRatio)) + _
chr$(9) + _
_Trim$(Str$(arrSorted(iLoop1).VRatio)) + _
chr$(9) + _
_Trim$(Str$(arrSorted(iLoop1).ColumnCount)) + _
chr$(9) + _
_Trim$(Str$(arrSorted(iLoop1).RowCount)) + _
chr$(9) + _
_Trim$(Str$(arrSorted(iLoop1).CellCount)) + _
chr$(9) + _
_Trim$(Str$(arrSorted(iLoop1).EmptyCells)) + _
chr$(9) + _
arrSorted(iLoop1).Name
' WRITE NEXT LINE TO FILE
PrintDebugFile sLine
End If
Next iLoop1
' CLEAR KEYBOARD BUFFER AND START OVER
_KeyClear: '_DELAY 1
Print
Loop
Cls: Print: Print "Finished"
End
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsOdd%
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = _TRUE
Else
IsEven% = _FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = _FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = _TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = _FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = _FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to a debug file in the EXE folder.
' Debug file is named the same thing as the program EXE name with ".txt" at the end.
' For example the program "C:\QB64\MyProgram.BAS" running as
' "C:\QB64\MyProgram.EXE" would have an output file "C:\QB64\MyProgram.EXE.txt".
' If the file doesn't exist, it is created, otherwise it is appended to.
' If in debug mode, show the user the debug path that they can copy/paste
' using _INPUTBOX$:
' result$ = _INPUTBOX$(m_ProgramName$, "Current debug filename is:", m_ProgramPath$ + m_ProgramName$ + ".txt")
Sub PrintDebugFile (sText As String)
Dim sFileName As String
Dim sError As String
Dim sOut As String
Dim sTimestamp as string
sFileName = m_ProgramPath$ + m_ProgramName$ + ".txt"
sError = ""
sTimestamp = CurrentDateTime$
If _FileExists(sFileName) = _FALSE Then
sOut = ""
'sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
'sOut = sOut + "PROGRAM : " + m_ProgramName$ + Chr$(13) + Chr$(10)
'sOut = sOut + "RUN DATE: " + sTimestamp + Chr$(13) + Chr$(10)
'sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sError = PrintFile$(sFileName, sOut, _FALSE)
End If
If Len(sError) = 0 Then
sError = PrintFile$(sFileName, sText, _TRUE)
End If
If Len(sError) <> 0 Then
Print sTimestamp + " PrintDebugFile FAILED"
Print String$( len(sTimestamp) + 1, " ") + "sFileName = " + chr$(34) + sFileName + chr$(34)
Print String$( len(sTimestamp) + 1, " ") + "ERROR = " + sError
End If
End Sub ' PrintDebugFile
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=_TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
' Example:
' m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = m_ProgramPath$ + m_ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, _FALSE)
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = _TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEXT MODE COLOR CODE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cBlackT%
cBlackT% = 0
End Function
Function cBlueT%
cBlueT% = 1
End Function
Function cGreenT%
cGreenT% = 2
End Function
Function cLtBlueT%
cLtBlueT% = 3
End Function
Function cRedT%
cRedT% = 4
End Function
Function cPurpleT%
cPurpleT% = 5
End Function
Function cOrangeT%
cOrangeT% = 6
End Function
Function cWhiteT%
cWhiteT% = 7
End Function
Function cGrayT%
cGrayT% = 8
End Function
Function cPeriwinkleT%
cPeriwinkleT% = 9
End Function
Function cLtGreenT%
cLtGreenT% = 10
End Function
Function cCyanT%
cCyanT% = 11
End Function
Function cLtRedT%
cLtRedT% = 12
End Function
Function cPinkT%
cPinkT% = 13
End Function
Function cYellowT%
cYellowT% = 14
End Function
Function cLtGrayT%
cLtGrayT% = 15
End Function
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEXT MODE COLOR CODE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RGB COLOR FUNCTIONS #RGB
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLtGray~& ()
cLtGray~& = cLightGray~&
End Function ' cLtGray~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RGB COLOR FUNCTIONS @RGB
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Steve:
Code: (Select All)
' Grid Formatting Demo
' https://qb64phoenix.com/forum/showthread.php?tid=3482&pid=0#pid0
' From: SMcNeill
' Date: 2/21/2025 1:00 PM
' Based off the topic here: https://qb64phoenix.com/forum/showthread.php?tid=3475
' -----------------------------------------------------------------------------
' I tried to break this down as simple as possible, so that one can use this
' to generate a series of grids in a set ratio and choose which layout would
' work best for their number of items. I *think* this basically follows the
' same spirit of what [url=https://qb64phoenix.com/forum/member.php?action=profile&uid=10]@madscijr[/url] was trying to do with his code.
'
' One difference here though -- I removed the inverse values as they're always
' going to be the same result, just turned sideways!
'
' a 4 x 6 grid holds 24 items.
' a 6 x 4 grid holds the same 24 items.
'
' Seems like a waste to list them both. If one really wants that, then just
' swap your X and Y numbers. It won't change how many items the grid would hold.
' 4 x 6 is the same as 6 x 4. Wink
'
' Try it out. See if this does what you were trying to do, and see if it's a
' little bit simpler and easier to understand. Big Grin
Type Ratio_Type
x As _Integer64
y As _Integer64
description As String
size As _Integer64
scale As _Integer64
total As _Integer64
empty As _Integer64
End Type
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared Ratio(8) As Ratio_Type
Dim shared items As Long
' SHOW USER DEBUG FILE/PATH SO THEY CAN COPY TO CLIPBOARD:
Dim in$ : in$ = _INPUTBOX$(m_ProgramName$, "Current debug filename is:", m_ProgramPath$ + m_ProgramName$ + ".txt")
Screen _NewImage(1280, 720, 32)
InitRatios
Cls
Do
Input "Enter the number of items =>"; items
If items <= 0 Then System
CalculateGrids items
SortGrids
DisplayGrids
Loop
Sub DisplayGrids
dim sLine as string
Print
Color &HFF00FF00&&
' HEADER FOR DISPLAYING SORTED RESULTS TO SCREEN
Print " # H-Ratio V-Ratio Columns Rows Cells Empty Layout"
Print "---- -------- -------- -------- -------- -------- -------- ------"
' HEADER FOR OUTPUTTING RESULTS TO A TAB-DELIMITED FILE
PrintDebugFile _
"Items" + chr$(9) + _
"H-Ratio" + chr$(9) + _
"V-Ratio" + chr$(9) + _
"Columns" + chr$(9) + _
"Rows" + chr$(9) + _
"Total Cells" + chr$(9) + _
"Empty Cells" + chr$(9) + _
"Layout"
Color &HFFFFFFFF&&
For i = 1 To UBound(Ratio)
' -----------------------------------------------------------------------------
' OUTPUT TO SCREEN
' ASSEMBLE SPACE-DELIMITED LINE
sLine = _
Right$(String$(4, " ") + _Trim$(Str$(items)), 4) + _
" " + _
left$( _Trim$(Str$(ratio(i).x)) + string$(8, " "), 8) + _
" " + _
left$( _Trim$(Str$(ratio(i).y)) + string$(8, " "), 8) + _
" " + _
right$( string$(8, " ") + _Trim$(Str$(ratio(i).x * ratio(i).scale)) , 8) + _
" " + _
right$( string$(8, " ") + _Trim$(Str$(ratio(i).y * ratio(i).scale)) , 8) + _
" " + _
right$( string$(8, " ") + _Trim$(Str$(ratio(i).x * ratio(i).scale * ratio(i).y * ratio(i).scale)) , 8) + _
" " + _
right$( string$(8, " ") + _Trim$(Str$(ratio(i).empty)) , 8) + _
" " + _
ratio(i).description
'ratio(i).scale
' PRINT NEXT LINE
print left$(sLine, 160)
' -----------------------------------------------------------------------------
' OUTPUT TO FILE
' ASSEMBLE TAB-DELIMITED LINE
sLine = _
_Trim$(Str$(items)) + _
chr$(9) + _
_Trim$(Str$(ratio(i).x)) + _
chr$(9) + _
_Trim$(Str$(ratio(i).y)) + _
chr$(9) + _
_Trim$(Str$(ratio(i).x * ratio(i).scale)) + _
chr$(9) + _
_Trim$(Str$(ratio(i).y * ratio(i).scale)) + _
chr$(9) + _
_Trim$(Str$(ratio(i).x * ratio(i).scale * ratio(i).y * ratio(i).scale)) + _
chr$(9) + _
_Trim$(Str$(ratio(i).empty)) + _
chr$(9) + _
ratio(i).description
' WRITE NEXT LINE TO FILE
PrintDebugFile sLine
Next i
End Sub ' DisplayGrids
Sub SortGrids
For i = 1 To UBound(Ratio)
For j = i + 1 To UBound(Ratio)
If Ratio(i).empty > Ratio(j).empty Then Swap Ratio(i), Ratio(j)
Next j, i
End Sub ' SortGrids
Sub CalculateGrids (items)
For i = 1 To UBound(Ratio)
n = 1
Do Until Ratio(i).size * n ^ 2 > items
n = n + 1
Loop
Ratio(i).scale = n ' this is the scaler
Ratio(i).total = Ratio(i).size * n ^ 2 ' this is the total number of cells
Ratio(i).empty = Ratio(i).total - items
Next i
End Sub ' CalculateGrids
Sub InitRatios
RatioData:
Data 1,1,Square (profile pictures; social media)
Data 2,3,Classic 35mm (4x6; 6x9; etc.)
Data 5,7,5 x 7 photo
Data 17,22,Standard letter size (8.5x11)
Data 4,3,Older PC monitor + analog TV (640x480; 1024x768; etc.)
Data 4,5,Art prints + medium format (8x10; 16x20)
Data 11,14,legal paper (11x14)
Data 16,9,Standard HD display (1920x1080; 1280x720; etc.)
For i = 1 To UBound(Ratio)
Read Ratio(i).x, Ratio(i).y, Ratio(i).description
Ratio(i).size = Ratio(i).x * Ratio(i).y
Next i
End Sub ' InitRatios
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to a debug file in the EXE folder.
' Debug file is named the same thing as the program EXE name with ".txt" at the end.
' For example the program "C:\QB64\MyProgram.BAS" running as
' "C:\QB64\MyProgram.EXE" would have an output file "C:\QB64\MyProgram.EXE.txt".
' If the file doesn't exist, it is created, otherwise it is appended to.
' If in debug mode, show the user the debug path that they can copy/paste
' using _INPUTBOX$:
' result$ = _INPUTBOX$(m_ProgramName$, "Current debug filename is:", m_ProgramPath$ + m_ProgramName$ + ".txt")
Sub PrintDebugFile (sText As String)
Dim sFileName As String
Dim sError As String
Dim sOut As String
Dim sTimestamp as string
sFileName = m_ProgramPath$ + m_ProgramName$ + ".txt"
sError = ""
sTimestamp = CurrentDateTime$
If _FileExists(sFileName) = _FALSE Then
sOut = ""
'sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
'sOut = sOut + "PROGRAM : " + m_ProgramName$ + Chr$(13) + Chr$(10)
'sOut = sOut + "RUN DATE: " + sTimestamp + Chr$(13) + Chr$(10)
'sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sError = PrintFile$(sFileName, sOut, _FALSE)
End If
If Len(sError) = 0 Then
sError = PrintFile$(sFileName, sText, _TRUE)
End If
If Len(sError) <> 0 Then
Print sTimestamp + " PrintDebugFile FAILED"
Print String$( len(sTimestamp) + 1, " ") + "sFileName = " + chr$(34) + sFileName + chr$(34)
Print String$( len(sTimestamp) + 1, " ") + "ERROR = " + sError
End If
End Sub ' PrintDebugFile
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=_TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
' Example:
' m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = m_ProgramPath$ + m_ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, _FALSE)
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = _TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$