I wanted old style vector fonts in a program and realized I had to work them up myself. Here's a demo program that goes along with the scribble font editor I posted earlier.
Code: (Select All)
'scribbledemo 1
' a demo program to go along with the scribble font editor and subs I am working on
Dim Shared S1&
Dim Shared Klr(0 To 255) As _Unsigned Long
Dim Shared pencolor As _Unsigned Long
Dim Shared charcode$(0 To 255), current_ch
Dim Shared fonstspec$
Dim Shared fontW, fontH
fontW = 10
fontH = 16
S1& = _NewImage(640, 480, 32) ' the main screen
Screen S1&
_PrintMode _KeepBackground , S1&
'loadfont "zarp01.sft" <- the extrnal file i used and a stub for some other use
loadhardfont 'so the demo works without an external file
Randomize Timer
scale = 2
For scale = 0.1 To 20 Step 0.2
Cls
_Limit 60
For X = 64 To 90
scribblechar (X - 64) * (10 * scale), 100, Chr$(X), scale, scale, _RGB(250, 250, 250)
Next X
_Display
Next scale
oldscale = scale
For n = 1 To 27
For scale = oldscale To 0.1 Step -0.2
Cls
_Limit 200
X = 63 + n
'randomizing the color of the letters to give old-school vector flicker effect
scribblechar 100, 100, Chr$(X), scale, scale, _RGB(Int(Rnd * 200) + 50, Int(Rnd * 200) + 50, Int(Rnd * 200) + 50)
_Display
Next scale
Next n
Cls
AA$ = "Some sample text AbCdEfGhIjKlMnOpQrStUvWxYz"
scribbleprint 10, 20, AA$, 1, 1.5, _RGB32(250, 250, 250)
SW = 1: SH = 1
AA$ = "It doesn't do true print scrolling but it does support scale based wrapping back to the horizontal positon of the print coordinate"
scribbleprint 100, 100, AA$, SW, 2, _RGB32(250, 250, 250)
_Delay 1
For SC = 1 To 3 Step 0.1
Cls
_Limit 3
AA$ = "Some sample text AbCdEfGhIjKlMnOpQrStUvWxYz"
scribbleprint 10, 20, AA$, 1, 1.5, _RGB32(250, 250, 250)
SW = 1: SH = 1
AA$ = "It doesn't do true print scrolling but it does support scale based wrapping back to the horizontal position of the print coordinate"
scribbleprint 100, 60, AA$, SW * SC, SH * SC, _RGB32(250, 250, 250)
_Display
Next SC
For SC = 3 To 0.5 Step -0.1
Cls
_Limit 5
AA$ = "Some sample text AbCdEfGhIjKlMnOpQrStUvWxYz"
scribbleprint 10, 20, AA$, 1, 1.5, _RGB32(250, 250, 250)
SW = 1: SH = 1
AA$ = "It doesn't do true print scrolling but it does support scale based wrapping back to the horizontal position of the print coordinate"
scribbleprint 100, 60, AA$, SW * SC, SH * SC, _RGB32(250, 250, 250)
_Display
reps = Int(Rnd * 900) + 12
For X = 1 To reps
_Limit 100
ch = Int(Rnd * 128) + 1
scalew = (Rnd * 6) + .5: scaleh = (Rnd * 6) + .5
Klr(0) = _RGB32(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
xx = Int(Rnd * 600): yy = Int(Rnd * 400)
scribbleprint xx, yy, Chr$(ch), scalew, scaleh, Klr(0)
_Display
Next X
hardfont: 'incomplete ascii scribble font for demo so no extra files needed
Data "","032161838A7C1C0A03U2333U2434U6353U546453U6354U3324233433U5354U6463U172A6A77593917","032161838B6D2D0B03U1423342514U7463546574U17193B5B7977U5977U593917"
Data "4332130507394B59878573524346","1742774B17","483C2C2D6D6C5C48U4672402246U477587794715071947","2D6D6C4B2C2DU4B5A7987755442341507193A4B"
Data "36446476684836","346476786A3A282634U00808D0D00","543425273858676554","00808D0D00U3454656758382725343638U5458U3557U5537U3555U3757"
Data "2C6C8A886626080A2CU2662U426264","21617365251321U454DU2969","2181832321U333A1C1939","2181842421U8489696C8A89U343C1D1A3A","3745574937U4542U494CU5777U3717U3614U5674U7A58U381A"
Data "1C12771C","16727B16","255285U525BU285B88","3A3121243AU6A6171746AU6C6D7D6CU3C3D2D3C","8C8131043787U414C"
Data "827121121324U15336385896B2B1915U7A8B8C7D2D1C","25757828257826762875"
Data "385A78U335173U515AU3B7B","5A52U345274","385A78U5A52","1666U446648"
Data "7616U341638","242777","322436U526456","42168642","0321436183854B0503"
Data "","5D6C5B4C5DU5972513259","204042332220U606273828060","212CU616CU0484U0A8A","3D30U606DU8583613113153767898B6C2C1B"
Data "1B75U5A7A7C5C5AU3634141636","8D6DU7D242240608284080B2D4D6A","61818264726261","71131B7D","11737B1D"
Data "1676U2369U6329","1777U444A","5E6D6B8B8D5E","2676","5B7B7D5D5B"
Data "721C","20020B2D6D8B826020U622B","3251U505DU3D7D","0504406084870A0D8D"
Data "04022060828567898B6D2D0B09U6727","8808505DU4D6D","8000062565878B6D2D0B","605031050B2D6D8B87662608"
Data "010080474D","2D0B082666888B6D2DU6684826020020426","80894EU81703003062888","52546252U5A58685A"
Data "54536354U575A3C","71177D","2575U2979","22882D","141230608286484AU4C4D5D4C","6C3C1913306083896A4A38344363665735","0D408DU7A1A"
Data "0D0040736606U8A66U6D8AU0D6D","40064D89U8440","0D0020873D0D","80000D8DU7707"
Data "0D0080U0656","8440075D8A8858","0D00U808DU8606","2070U404DU2D7DU","1080U606B4D1B19"
Data "000DU8D0680","000D8D","0D0048808D","0D008D80","2060828C7D1D0C0220","0D0050835606"
Data "030A3D5D8A83503003U8E48","0D0050835606U8D46","8360300337898B6D2D0A","0080404D"
Data "000B2D6D8B80","004D80","002D456D80","008DU0D80","004580U454D","00800D8D"
Data "70101D7D","118D","11717C1C","634023","1D8D","212243","1D1969U35656DU7D1DU3526"
Data "1D12U2D5D7B59191C2D","4D1A4679U4D7B","6D62U6C4D1D1969","7D1D1936567919"
Data "3D355275U1868","56785B1956U7E76U2E7E","1D12U587DU1858","2D4DU393DU36354536"
Data "676C4E2C2AU64746564","1D12U187DU1866","3D1DU2D22","1D174A777D"
Data "1D177D77","3D1B193757797B5D3D","1E171847794B1A","666C7E8EU6836093B68"
Data "1D16U18365678","1B2D6D7B592917255577","353D4DU1767","161B3D6D7C76"
Data "164D76","163D496D76","167DU761D","167AU767C4E2C","16761D7D"
Data "71413235462748393C4D7D","4145U484D","21516265567758696C5D2D","13316381"
Data "232666634123","734113164876U666B3B","171B3D6D7C77U75748475U15142415"
Data "7B4D1B1745777818U33624233","090D5D6B6909U061555666C7DU124162"
Data "061555666D1D0B0969U13122213U43425243"
Data "","","","","","","","","","","","",""
Data "","","","","","","","","","","","","","","",""
Data "","","","","","","","","","","","","",""
Data "","","","","","","","","","","","","","","","","","",""
Data "","","","","","","","","","","","","","","",""
Data "","","","","","","","","","","","","","","","","",""
Data "","","","","","","","","","","","","","","","","","",""
Data "","","","","","","",""
Sub loadhardfont
Restore hardfont
For cc = 0 To 255
Read charcode$(cc)
Next cc
Close #1
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "FONT LOADED"
_Delay 0.5
End Sub
Sub loadfont (filename$)
filein$ = filename$
Open filein$ For Input As #1
For headerread = 1 To 6
Input #1, dummy$
Next headerread
Input #1, fontspec$ 'not used yet but keeeping in place for revision
For cc = 0 To 255
Input #1, charcode$(cc)
Next cc
Close #1
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "FONT LOADED"
_Delay 0.5
End Sub
Sub scribbleprint (x, y, t$, sw, sh, pk As _Unsigned Long)
pl = Len(t$)
screenwid = _Width(32) 'chnage this to your screen mode if you don't use 32-bit
px = x
py = y
For c = 1 To pl
ct$ = Mid$(t$, c, 1)
scribblechar px, py, ct$, sw, sh, pk
px = px + (fontW * sw)
If px + fontW >= screenwid Then
px = x
' py = y + (fontH * sh)
py = py + (fontH * sh)
End If
Next c
End Sub
Sub scribblechar (x, y, t$, sw, sh, tk As _Unsigned Long)
xx = x
yy = y
lx$ = ""
ly$ = ""
points = 0
tt = Asc(t$)
If Len(charcode$(tt)) > 0 Then
For c = 1 To Len(charcode$(tt))
If Mid$(charcode$(tt), c, 1) <> "U" Then
nx$ = Mid$(charcode$(tt), c, 1)
ny$ = Mid$(charcode$(tt), c + 1, 1)
c = c + 1
If points = 0 Then
lx$ = nx$
ly$ = ny$
points = points + 1
Else
points = points + 1
If points = 2 Then
lx = Val("&H" + lx$): ly = Val("&H" + ly$)
nx = Val("&H" + nx$): ny = Val("&H" + ny$)
Line (xx + lx * sw, yy + ly * sh)-(xx + nx * sw, yy + ny * sh), tk
points = points - 1
lx$ = nx$
ly$ = ny$
End If
End If
Else
lx$ = ""
ly$ = ""
points = 0
End If
Next c
End If
End Sub
The actual library consists of a BI file and a BM file. There is also a test program that accompanies these. First off the BI
CHARSET.BI
Code: (Select All)
REM ******************************************************
REM * Filespec : charset.bas charset.bi *
REM * Date : June 23 1997 *
REM * Time : 12:01 *
REM * Revision : 1.0B *
REM * Update : *
REM ******************************************************
REM * Released to the Public Domain *
REM ******************************************************
CONST SetSize = 32 ' Number of bytes to store set contents
CONST Last = SetSize - 1
CONST TRUE = -1
CONST FALSE = 0
TYPE CharSet
MySet AS STRING * SetSize
MySize AS INTEGER
END TYPE
Then the actual library code -
CHARSET.BM
Code: (Select All)
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB SetError ( ErrMessage AS STRING )
PRINT "ERROR : ";ErrMessage
PRINT "ABORTING NOW!"
STOP
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB LoadSet ( A AS CharSet, LoadChars AS STRING )
IF LoadChars <> "" THEN
LoadSize% = LEN(LoadChars)
Here% = 1
LocationNext% = INSTR(Here%, LoadChars, "...")
DO WHILE LocationNext% > 0
Start% = ASC(MID$(LoadChars, LocationNext% - 1, 1))
Fini% = ASC(MID$(LoadChars, LocationNext% + 3, 1))
Here% = LocationNext% + 4
IF Start% > Fini% THEN
Start% = (Start% XOR Fini%)
Fini% = (Start% XOR Fini%)
Start% = (Start% XOR Fini%)
END IF
FOR X% = Start% TO Fini%
Y% = 1 + (X% \ 8)
Z% = X% MOD 8
MID$(A.MySet, Y%, 1) = CHR$(ASC(MID$(A.Myset, Y%, 1)) OR PowerOf2%(Z%))
NEXT X%
IF Here% >= LoadSize% THEN
EXIT DO
END IF
LocationNext% = INSTR(Here%, LoadChars, "...")
LOOP
IF Here% < LoadSize% THEN
FOR X% = Here% TO LoadSize%
AChar$ = MID$(LoadChars, X%, 1)
Y% = 1 + (ASC(AChar$) \ 8)
Z% = ASC(AChar$) MOD 8
MID$(A.MySet, Y%, 1) = CHR$(ASC(MID$(A.MySet, Y%, 1)) OR PowerOf2%(Z%))
NEXT X%
END IF
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB Recount ( A AS CharSet )
A.MySize = 0
FOR X% = 1 TO SetSize
TestChar$ = MID$(A.MySet, X%, 1)
FOR Y% = 0 TO 7
IF (ASC(TestChar$) AND PowerOf2%(Y%)) <> 0 THEN
A.MySize = A.MySize + 1
END IF
NEXT Y%
NEXT X%
END SUB
REM ******************************************************
REM * Private FUNCTION - Do not call directly *
REM ******************************************************
FUNCTION PowerOf2% ( Power AS INTEGER )
SELECT CASE Power
CASE 0
PowerOf2% = 1
CASE 1
PowerOf2% = 2
CASE 2
PowerOf2% = 4
CASE 3
PowerOf2% = 8
CASE 4
PowerOf2% = 16
CASE 5
PowerOf2% = 32
CASE 6
PowerOf2% = 64
CASE 7
PowerOf2% = 128
CASE ELSE
PowerOf2% = 0
END SELECT
END FUNCTION
REM *****************************************************************
REM * Must be called before a charset is used unless that charset *
REM * is used to hold the results of a set operation. Valid set *
REM * operations that can be called in lieu of this routine are - *
REM * CopySet, MakeSetEmpty, SetComplement, SetUnion, SetDifference,*
REM * SetIntersection and SymmetricSetDifference, where without *
REM * exception the uninitialised set would be used for the *
REM * rightmost parameter. *
REM * *
REM * The string InitialChars is used to specify the initial *
REM * contents of the CharSet being initialised. The format of *
REM * the string is as follows. *
REM * *
REM * If an empty set is desired it is possible to pass an empty *
REM * string "" to this routine, although the routine MakeSetEmpty *
REM * would probably be quicker. *
REM * *
REM * A range of characters can be specified by the use of a *
REM * trigraph (...) in the form a...z which would tell this *
REM * routine to include all the characters from lower case 'a' to *
REM * lower case 'z' inclusive. More than one range of characters *
REM * may be specified for a set, but all ranges MUST be the first *
REM * of the characters specified. *
REM * *
REM * A list of the actual characters required to be contained *
REM * within the set such as "axwf9\" may be part of (or the whole *
REM * of) the string, but MUST appear after any range(s) of *
REM * characters. *
REM * *
REM * See the example program for more help. *
REM *****************************************************************
SUB InitialiseSet ( A AS CharSet, InitialChars AS STRING )
MakeSetEmpty A
LoadSet A, InitialChars
Recount A
END SUB
REM *****************************************************************
REM * Copies the contents of one set to another. *
REM *****************************************************************
SUB CopySet ( This AS CharSet, ToThis AS CharSet )
ToThis.MySet = This.MySet
ToThis.MySize = This.Mysize
END SUB
REM *****************************************************************
REM * Adds the characters of the string IncludeChars to set A. The *
REM * same rules for the contents of the string used by the routine *
REM * InitialiseSet apply. *
REM *****************************************************************
SUB IncludeInSet ( A AS CharSet, IncludeChars AS STRING )
LoadSet A, IncludeChars
Recount A
END SUB
REM *****************************************************************
REM * If any of the characters in ExcludedChars are also part of *
REM * set A, such characters will be removed from set A. *
REM *****************************************************************
SUB ExcludeFromSet ( A AS CharSet, ExcludedChars AS STRING )
DIM TempSet AS CharSet
IF ExcludedChars = "" THEN
SetError("ExcludeFromSet - No chars to exclude!")
END IF
InitialiseSet TempSet, ExcludedChars
FOR X% = 1 TO SetSize
MID$(A.MySet, X%, 1) = CHR$(ASC(MID$(A.MySet, X%, 1)) AND NOT(ASC(MID$(TempSet.MySet, X%, 1))))
NEXT X%
Recount A
END SUB
REM *****************************************************************
REM * Returns the number of elements of set A. *
REM *****************************************************************
FUNCTION Cardinality% ( A AS CharSet )
Cardinality% = A.MySize
END FUNCTION
REM *****************************************************************
REM * Tests for set A being empty. *
REM *****************************************************************
FUNCTION SetIsEmpty ( A AS CharSet )
SetIsEmpty = (A.MySize = 0)
END FUNCTION
REM *****************************************************************
REM * Empties set A. *
REM *****************************************************************
SUB MakeSetEmpty ( A AS CharSet )
FOR X% = 1 TO SetSize
MID$(A.MySet, X%, 1) = CHR$(0)
NEXT X%
A.MySize = 0
END SUB
REM *****************************************************************
REM * In order to use this routine, the string TestChar MUST only *
REM * have a single character. If the string is empty or it has *
REM * more than 1 character, an error message will be displayed and *
REM * the program will be STOPped. *
REM * *
REM * This routine tests whether the character TestChar is a member *
REM * of set A (TestChar IN A). *
REM *****************************************************************
FUNCTION IsMember ( A AS CharSet, TestChar AS STRING )
IF TestChar = "" THEN
SetError("IsMember - No char to test!")
END IF
IF LEN(TestChar) > 1 THEN
SetError("IsMember - Too many chars to test!")
END IF
Y% = 1 + (ASC(TestChar) \ 8)
Z% = ASC(TestChar) MOD 8
IsMember = ((ASC(MID$(A.MySet, Y%, 1)) AND PowerOf2(Z%)) <> 0)
END FUNCTION
REM *****************************************************************
REM * Converts the set A to the string OutChars for PRINTING etc. *
REM *****************************************************************
SUB GetSetContents ( A AS CharSet, OutChars AS String )
OutChars = ""
FOR X% = 1 TO SetSize
Temp$ = MID$(A.MySet, X%, 1)
FOR Y% = 0 TO 7
IF (ASC(Temp$) AND PowerOf2%(Y%)) <> 0 THEN
OutChars = OutChars + CHR$(((X% - 1) * 8) + Y%)
END IF
NEXT Y%
NEXT X%
END SUB
REM *****************************************************************
REM * Tests for A = B. *
REM *****************************************************************
FUNCTION SetEquality ( A AS CharSet, B AS CharSet )
SetEquality = (A.MySet = B.MySet)
END FUNCTION
REM *****************************************************************
REM * Tests for A <> B. *
REM *****************************************************************
FUNCTION SetInequality ( A AS CharSet, B AS CharSet )
SetInequality = (A.MySet <> B.MySet)
END FUNCTION
REM *****************************************************************
REM * Tests to see if all of the characters contained in the set *
REM * This are also present in the set OfThis, i.e that the set *
REM * This is a subset of the set OfThis. Note if the 2 sets are *
REM * equal or the set This is empty then the set This IS a subset *
REM * of the set OfThis. *
REM *****************************************************************
FUNCTION IsSubsetOf ( This AS CharSet, OfThis AS CharSet )
IF SetEquality(This, OfThis) THEN
IsSubsetOf = TRUE
EXIT FUNCTION
END IF
IF SetIsEmpty(This) THEN
IsSubsetOf = TRUE
EXIT FUNCTION
END IF
IF This.MySize > OfThis.MySize THEN
IsSubsetOf = FALSE
EXIT FUNCTION
END IF
FOR X% = 1 TO SetSize
TestChar1$ = MID$(This.MySet, X%, 1)
TestChar2$ = MID$(OfThis.MySet, X%, 1)
FOR Y% = 0 TO 7
Z% = PowerOf2%(Y%)
P% = (ASC(TestChar1$) AND Z%)
Q% = (ASC(TestChar2$) AND Z%)
IF ((P% <> 0) AND (Q% = 0)) THEN
IsSubsetOf = FALSE
EXIT FUNCTION
END IF
NEXT Y%
NEXT X%
IsSubsetOf = TRUE
END FUNCTION
REM *****************************************************************
REM * Identical to the routine IsSubsetOf with the exception that *
REM * the 2 sets may not be equal (This <> OfThis). *
REM *****************************************************************
FUNCTION IsStrictSubsetOf ( This AS CharSet, OfThis AS CharSet )
IF SetEquality(This, OfThis) THEN
IsStrictSubsetOf = FALSE
EXIT FUNCTION
END IF
IsStrictSubsetOf = IsSubsetOf(This, OfThis)
END FUNCTION
REM *****************************************************************
REM * The operation set complement places all the characters that *
REM * are NOT part of the set A into the set ComplementOfA. *
REM *****************************************************************
SUB SetComplement ( A AS CharSet, ComplementOfA AS CharSet )
FOR X% = 1 TO SetSize
MID$(ComplementOfA.MySet, X%, 1) = CHR$((ASC(MID$(A.MySet, X%, 1))) XOR 255)
NEXT X%
Recount ComplementOfA
END SUB
REM *****************************************************************
REM * The operation set union combines all the characters that are *
REM * in set A and all the characters that are in set B and returns *
REM * the result of this in set C. *
REM *****************************************************************
SUB SetUnion ( A AS CharSet, B AS CharSet, C AS CharSet )
FOR X% = 1 TO SetSize
MID$(C.MySet, X%, 1) = CHR$(ASC(MID$(A.MySet, X%, 1)) OR ASC(MID$(B.MySet, X%, 1)))
NEXT X%
Recount C
END SUB
REM *****************************************************************
REM * The operation set difference places only those characters of *
REM * set A which are NOT part of set B into set C. *
REM *****************************************************************
SUB SetDifference ( A AS CharSet, B AS CharSet, C AS CharSet )
FOR X% = 1 TO SetSize
MID$(C.MySet, X%, 1) = CHR$(ASC(MID$(A.MySet, X%, 1)) AND NOT(ASC(MID$(B.MySet, X%, 1))))
NEXT X%
Recount C
END SUB
REM *****************************************************************
REM * After this operation set C will contain only those characters *
REM * which occur in both set A and set C. *
REM *****************************************************************
SUB SetIntersection ( A AS CharSet, B AS CharSet, C AS CharSet )
FOR X% = 1 TO SetSize
MID$(C.MySet, X%, 1) = CHR$(ASC(MID$(A.MySet, X%, 1)) AND ASC(MID$(B.MySet, X%, 1)))
NEXT X%
Recount C
END SUB
REM *****************************************************************
REM * This operation is the set equivalent of the logical operation *
REM * exclusive or, in that after this operation set C will contain *
REM * only those characters that occur in either set A or set B but *
REM * not in both. *
REM *****************************************************************
SUB SymmetricSetDifference ( A AS CharSet, B AS CharSet, C AS CharSet )
FOR X% = 1 TO SetSize
MID$(C.MySet, X%, 1) = CHR$(ASC(MID$(A.MySet, X%, 1)) XOR ASC(MID$(B.MySet, X%, 1)))
NEXT X%
Recount C
END SUB
Finally the test program -
TESTSETS.BAS
Code: (Select All)
'$INCLUDE: 'CHARSET.BI'
Dim ASet As CharSet, BSet As CharSet, CSet As CharSet, DSet As CharSet
Dim ESet As CharSet, FSet As CharSet, GSet As CharSet, HSet As CharSet
Dim ISet As CharSet, JSet As CharSet, KSet As CharSet, SetL As CharSet
Dim MSet As CharSet, NSet As CharSet, OSet As CharSet, SetP As CharSet
Dim QSet As CharSet, SetR As CharSet, SSet As CharSet, TSet As CharSet
AStr$ = Chr$(129) + "..." + Chr$(147)
BStr$ = Chr$(0) + "..." + Chr$(31)
CStr$ = Chr$(148) + "..." + Chr$(255)
DStr$ = Chr$(33) + "..." + Chr$(127)
EStr$ = Chr$(0) + "...MO..." + Chr$(255)
Screen _NewImage(235, 50, 0)
Cls
InitialiseSet ASet, "A...Za...z"
InitialiseSet BSet, ",.<>;':@#~{}[]"
InitialiseSet CSet, "0...9!œ$%^&*()_-+=\|"
InitialiseSet DSet, AStr$
InitialiseSet ESet, "a...z0...9!œ$%^&*()_-+=\|;:'@#~[]{}"
InitialiseSet FSet, "acegikmoqsuwy"
InitialiseSet GSet, "A...Z"
InitialiseSet HSet, "a...z"
CopySet ASet, ISet
InitialiseSet JSet, ""
SetComplement JSet, KSet
MakeSetEmpty SetL
InitialiseSet MSet, DStr$
InitialiseSet NSet, EStr$
SetComplement NSet, OSet
CopySet NSet, SetP
ExcludeFromSet NSet, BStr$
GetSetContents ASet, FStr$
Print "Set A contains - "; FStr$
GetSetContents BSet, FStr$
Print "Set B contains - "; FStr$
GetSetContents CSet, FStr$
Print "Set C contains - "; FStr$
GetSetContents DSet, FStr$
Print "Set D contains - "; FStr$
GetSetContents ESet, FStr$
Print "Set E contains - "; FStr$
GetSetContents FSet, FStr$
Print "Set F contains - "; FStr$
GetSetContents GSet, FStr$
Print "Set G contains - "; FStr$
GetSetContents HSet, FStr$
Print "Set H contains - "; FStr$
GetSetContents ISet, FStr$
Print "Set I contains - "; FStr$
GetSetContents JSet, FStr$
If Len(FStr$) = 0 Then FStr$ = "Nothing!"
Print "Set J contains - "; FStr$
ExcludeFromSet KSet, BStr$
GetSetContents KSet, FStr$
IncludeInSet KSet, BStr$
Print "Set K contains - "; FStr$
GetSetContents SetL, FStr$
If Len(FStr$) = 0 Then FStr$ = "Nothing!"
Print "Set L contains - "; FStr$
GetSetContents MSet, FStr$
Print "Set M contains - "; FStr$
GetSetContents NSet, FStr$
Print "Set N contains - "; FStr$
GetSetContents OSet, FStr$
Print "Set O contains - "; FStr$
ExcludeFromSet SetP, BStr$
GetSetContents SetP, FStr$
IncludeInSet SetP, BStr$
Print "Set P contains - "; FStr$
Print
Print "Cardinality of A = "; Cardinality%(ASet)
Print "Cardinality of B = "; Cardinality%(BSet)
Print "Cardinality of C = "; Cardinality%(CSet)
Print "Cardinality of D = "; Cardinality%(DSet)
Print "Cardinality of E = "; Cardinality%(ESet)
Print "Cardinality of F = "; Cardinality%(FSet)
Print "Cardinality of G = "; Cardinality%(GSet)
Print "Cardinality of H = "; Cardinality%(HSet)
Print "Cardinality of I = "; Cardinality%(ISet)
Print "Cardinality of J = "; Cardinality%(JSet)
Print "Cardinality of K = "; Cardinality%(KSet)
Print "Cardinality of L = "; Cardinality%(SetL)
Print "Cardinality of M = "; Cardinality%(MSet)
Print "Cardinality of N = "; Cardinality%(NSet)
Print "Cardinality of O = "; Cardinality%(OSet)
Print "Cardinality of P = "; Cardinality%(SetP)
Print
If SetIsEmpty(SetL) Then
Print "Set L is EMPTY!"
Else
Print "Error in SetIsEmpty!"
Stop
End If
If IsMember(HSet, "a") Then
Print "The letter 'a' is a member of set H."
Else
Print "Error in IsMember!"
Stop
End If
If SetEquality(ASet, ISet) Then
Print "Set A = Set I"
Else
Print "Error in SetEquality!"
Stop
End If
If SetInequality(ASet, BSet) Then
Print "Set A <> Set B"
Else
Print "Error in SetInequality!"
Stop
End If
If IsSubsetOf(ISet, ASet) Then
Print "Set I is a subset of Set A"
Else
Print "Error in IsSubsetOf!"
Stop
End If
If Not (IsStrictSubsetOf(ISet, ASet)) And IsStrictSubsetOf(FSet, ASet) Then
Print "Set I is NOT a strict subset of A while Set F is."
Else
Print "Error in IsStrictSubsetOf!"
Stop
End If
Print
Print "Press Any Key to continue"
WaitKey
Cls
Print
Print "Testing the operation of set union on -> G + B = Q."
Print
GetSetContents GSet, FStr$
Print "Set G contains - "; FStr$
GetSetContents BSet, FStr$
Print "Set B contains - "; FStr$
SetUnion GSet, BSet, QSet
GetSetContents QSet, FStr$
Print "After set union set Q contains - "; FStr$
Print
Print "Testing the operation of set Difference on -> H - F = R."
Print
GetSetContents HSet, FStr$
Print "Set H contains - "; FStr$
GetSetContents FSet, FStr$
Print "Set F contains - "; FStr$
SetDifference HSet, FSet, SetR
GetSetContents SetR, FStr$
Print "After set difference set R contains - "; FStr$
Print
Print "Testing the operation of set Intersection on -> H * E = S."
Print
GetSetContents HSet, FStr$
Print "Set H contains - "; FStr$
GetSetContents ESet, FStr$
Print "Set E contains - "; FStr$
SetIntersection HSet, ESet, SSet
GetSetContents SSet, FStr$
Print "After set intersection set S contains - "; FStr$
Print
Print "Testing the operation of symmetric set difference on -> C / E = T."
Print
GetSetContents CSet, FStr$
Print "Set C contains - "; FStr$
GetSetContents ESet, FStr$
Print "Set E contains - "; FStr$
SymmetricSetDifference CSet, ESet, TSet
GetSetContents TSet, FStr$
Print "After set symmetric set difference set T contains - "; FStr$
Print
Print "All tests complete."
Print
End
I wanted to use a vector drawn font in another program, maybe using the draw command. I started to hardcode the font and I realized that was actually the hard way to do it. So I built this font editor. I realized I could ditch the draw commands for now too (I may or may not return to using them, it's working without that.)
I'm not done with this yet and there is surely a demo program to follow to give folks ideas for their own programs to make use of this font style (or write a better one).
It's functional at this point.
Code: (Select All)
'scribble font builder
'a simple editor to build simple vector fonts for use in QB64 programs
'by James D. Jarvis
_Title "Scribble Font Builder v0.01"
Dim Shared S1&, bt&
Dim Shared buttoncount
buttoncount = 0
Dim Shared Klr(0 To 255) As _Unsigned Long
Dim Shared kl As _Unsigned Long
Dim Shared bk As _Unsigned Long
Dim Shared pencolor As _Unsigned Long
Dim Shared penstate, gridstate
Dim Shared cbgrid$(160, 2)
Dim Shared charcode$(0 To 255), current_ch
Dim Shared button(500) As _Unsigned Long 'the color tags for the buttons
Dim Shared fonstspec$ 'not used yet
S1& = _NewImage(640, 480, 32) ' the main screen
Screen S1&
_PrintMode _KeepBackground , S1&
bt& = _NewImage(640, 480, 32) ' the button tracker
penstate = 0
gridstate = 1
buildrefcolors
pencolor = Klr(15)
drawgrid
draw_buttonbar
_Dest S1&
current_ch = Asc("A")
For c = 0 To 255
charcode$(c) = ""
Next c
_ControlChr Off
displaychar
displaypenstate
showcharcode
lastadd$ = ""
'***********************************************
'main loop
'***********************************************
Do
' Screen bt&
_Limit 1000
Line (10, 50)-(15, 55), Klr&(kl), BF
ask$ = InKey$
If ask$ <> "" Then
Select Case ask$
Case Chr$(27), "Q", "q"
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print " QUIT PROGRAM ? "
Locate 26, 25
Print "press Y or N"
Choice$ = pickkey$("YyNn")
If LCase$(Choice$) = "n" Then
'all is well
showcharcode
Else
GoTo exitmain
End If
Case "<", ","
current_ch = current_ch - 1
If current_ch < 0 Then current_ch = 255
displaychar
showcharcode
hidegrid
drawcode
Line (140, 70)-(150, 86), Klr(0), BF
Case ">", "."
current_ch = current_ch + 1
If current_ch > 255 Then current_ch = 0
displaychar
showcharcode
hidegrid
drawcode
Line (140, 70)-(150, 86), Klr(0), BF
Case "D", "d"
penstate = 1
displaypenstate
Case "U", "u"
penstate = 0
charcode$(current_ch) = charcode$(current_ch) + "U"
showcharcode
displaypenstate
End Select
ask$ = ""
End If
Mouser mx, my, mb
If mb Then
Do While mb 'wait for button release
Mouser mx, my, mb
_Source bt&
bk = Point(mx, my)
_Dest S1&
Loop
'******** button handling code ************
' check position clicked in button tracking image
' get the color in that location
'i color matches that assigned to button execute button commands
'***************************************
For kc = 1 To buttoncount
If bk = button(kc) Then
bk = kc
End If
Next kc
If bk > 0 And bk < buttoncount + 1 Then
Select Case bk
Case 1 TO 160
If penstate = 1 Then
add$ = cbgrid$(bk, 1) + cbgrid$(bk, 2)
If add$ <> lastadd$ Then
charcode$(current_ch) = charcode$(current_ch) + add$
lastadd$ = add$
showcharcode
drawcode
End If
Else
Beep
End If
Case 161 'newfont
savefont
For c = 0 To 255
charcode$(c) = ""
Next c
current_ch = 65
displaychar
hidegrid
drawcode
Case 162 'save font
savefont
Case 163 'loadfotn
loadfont
Case 164 'enter asc code
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "Enter ASC CODE FOR NEW CHARACTER"
Locate 26, 25
Print "(0 to 255)"
Input ncc
If ncc > -1 And ncc < 256 Then
current_ch = ncc
displaychar
hidegrid
drawcode
Line (140, 70)-(150, 86), Klr(0), BF
End If
showcharcode
Case 165 'select previous character
current_ch = current_ch - 1
If current_ch < 0 Then current_ch = 255
displaychar
showcharcode
hidegrid
drawcode
Line (140, 70)-(150, 86), Klr(0), BF
Case 166 'select next character
current_ch = current_ch + 1
If current_ch > 255 Then current_ch = 0
displaychar
showcharcode
hidegrid
drawcode
Line (140, 70)-(150, 86), Klr(0), BF
Case 167 'change penstate
If penstate = 0 Then
penstate = 1
displaypenstate
Else
penstate = 0
displaypenstate
charcode$(current_ch) = charcode$(current_ch) + "U"
showcharcode
End If
Case 168 'grid on or grid off
If gridstate = 0 Then
gridstate = 1
Else
gridstate = 0
End If
hidegrid
Case 169 'erase current character
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "ERASE CURENT CHARACTER ?"
Locate 26, 25
Print "press Y or N"
Choice$ = pickkey$("YyNn")
If LCase$(Choice$) = "n" Then
showcharcode
Else
Line (140, 70)-(150, 86), Klr(0), BF
charcode$(current_ch) = ""
showcharcode
hidegrid
End If
End Select
End If
End If
Loop Until InKey$ = Chr$(27)
exitmain:
Screen bt&
Sub buildrefcolors
For c = 0 To 255
Klr(c) = _RGB32(c, c, c) 'all grey for now
Next c
'very slightly cooled EGA palette
Klr(1) = _RGB32(0, 0, 170) 'ega_blue
Klr(2) = _RGB32(0, 170, 0) 'ega_green
Klr(3) = _RGB32(0, 170, 170) 'ega_cyan
Klr(4) = _RGB32(170, 0, 0) 'ega_red
Klr(5) = _RGB32(170, 0, 170) 'ega_magenta
Klr(6) = _RGB32(170, 85, 0) 'ega_brown
Klr(7) = _RGB32(170, 170, 170) 'ega_litgray
Klr(8) = _RGB32(85, 85, 85) 'ega_gray
Klr(9) = _RGB32(85, 85, 250) 'ega_ltblue
Klr(10) = _RGB32(85, 250, 85) 'ega_ltgreen
Klr(11) = _RGB32(85, 250, 250) 'ega_ltcyan
Klr(12) = _RGB32(250, 85, 85) 'ega_ltred
Klr(13) = _RGB32(250, 85, 250) 'ega_ltmagenta
Klr(14) = _RGB32(250, 250, 85) 'ega_yellow
Klr(15) = _RGB32(250, 250, 250) 'ega_white
End Sub
Sub Mouser (x, y, b)
mi = _MouseInput
b = _MouseButton(1)
x = _MouseX
y = _MouseY
End Sub
Sub drawgrid
'draws grid on main scrren and button click spots on button tracker image
xx = 200: YY = 50
_Dest S1&
For x = 0 To 9
Line (xx + x * 20, YY)-(xx + x * 20, YY + 300), Klr(2)
Next x
For y = 0 To 15
Line (xx, YY + y * 20)-(xx + 180, YY + y * 20), Klr(2)
Next y
br = 0
bg = 1
bb = 1
_Dest bt&
For x = 0 To 9
For y = 0 To 15
br = br + 1
button(br) = _RGB32(br, bg, bb)
Circle (xx + x * 20, YY + y * 20), 6, _RGB32(br, bg, bb)
Paint (xx + x * 20, YY + y * 20), _RGB32(br, bg, bb), _RGB32(br, bg, bb)
cbgrid$(br, 1) = Hex$(x)
cbgrid$(br, 2) = Hex$(y)
Next y
Next x
buttoncount = buttoncount + 160
End Sub
Sub fillbox (x1, y1, x2, y2, thickness, style, fill As _Unsigned Long)
xa = x1: xb = x2: ya = y1: yb = y2
For l = 1 To thickness
Line (xa, ya)-(xb, yb), pencolor, B , style
xa = xa + 1: xb = xb - 1
ya = ya + 1: yb = yb - 1
Next l
If fill > 0 Then
Line (xa, ya)-(xb, yb), fill, BF
End If
End Sub
Sub draw_buttonbar
br = 200: bg = 0: bb = 2
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 5, 5, 30, 100, 2, "NEW font", Klr(8)
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 5, 40, 30, 100, 2, "SAVE font", Klr(8)
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 5, 75, 30, 100, 2, "LOAD font", Klr(8)
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 5, 110, 30, 100, 2, "CHARACTER", Klr(8)
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 5, 145, 30, 30, 2, "<", Klr(2)
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 75, 145, 30, 30, 2, ">", Klr(2)
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 5, 180, 30, 100, 2, "PEN U/D", Klr(2)
_Dest bt&
Line (200, 10)-(380, 40), button(buttoncount), BF 'penstate banner will aslo act as same button
_Dest S1&
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 5, 215, 30, 100, 2, "Grid ON/OFF", Klr(2)
buttoncount = buttoncount + 1
bg = bg + 1
button(buttoncount) = _RGB32(br, bg, bb)
drawbutton 5, 240, 30, 100, 2, "Erase", Klr(4)
End Sub
Sub displaypenstate
xx = 200: YY = 30
If penstate = 1 Then
fillbox 200, 10, 380, 40, 2, &HFFFFFFFF, Klr(2)
text$ = "PEN DOWN"
px = 290 - _PrintWidth(text$) / 2
_PrintString (px, 16), text$
Else
Line (200, 10)-(380, 40), Klr(20), BF
fillbox 200, 10, 380, 40, 2, &HF0F0FF0F, Klr(4)
text$ = "!! PEN UP !!"
px = 290 - _PrintWidth(text$) / 2
_PrintString (px, 16), text$
End If
End Sub
Sub displaychar
_PrintMode _FillBackground
_PrintString (52, 150), Chr$(current_ch)
_PrintMode _KeepBackground
End Sub
Sub drawbutton (bx, by, hh, ww, thick, text$, fill As _Unsigned Long)
fsize = _FontHeight
_Dest S1&
cx = ww / 2
cy = hh / 2 - fsize / 2
pw = _PrintWidth(text$)
pw = Int(pw / 2)
Color pencolor
fillbox bx, by, bx + ww - 1, by + hh - 1, thick, &HFFFFFFFF, fill
_PrintString (bx + cx - pw, by + cy), text$
_Dest bt&
Line (bx, by)-(bx + ww - 1, by + hh - 1), button(buttoncount), BF
End Sub
Sub showcharcode
Line (1, 370)-(639, 479), Klr(0), BF
tx$ = "Character: " + Chr$(current_ch)
_PrintString (1, 370), tx$
_PrintString (1, 390), charcode$(current_ch)
End Sub
Sub drawcode
xx = 200
yy = 50
lx$ = ""
ly$ = ""
points = 0
If Len(charcode$(current_ch)) > 0 Then
For c = 1 To Len(charcode$(current_ch))
If Mid$(charcode$(current_ch), c, 1) <> "U" Then
nx$ = Mid$(charcode$(current_ch), c, 1)
ny$ = Mid$(charcode$(current_ch), c + 1, 1)
c = c + 1
If points = 0 Then
lx$ = nx$
ly$ = ny$
points = points + 1
Else
points = points + 1
If points = 2 Then
lx = Val(lx$): ly = Val("&H" + ly$)
nx = Val(nx$): ny = Val("&H" + ny$)
Line (xx + lx * 20, yy + ly * 20)-(xx + nx * 20, yy + ny * 20), Klr(15)
points = points - 1
lx$ = nx$
ly$ = ny$
End If
End If
Else
lx$ = ""
ly$ = ""
points = 0
End If
Next c
End If
scribblechar 140, 70, Chr$(current_ch), 1, Klr(15)
End Sub
Sub hidegrid
xx = 200: yy = 50
Line (200, 50)-(380, 350), Klr(0), BF
If gridstate = 0 Then
'Line (200, 50)-(380, 350), Klr(0), BF
Else
For x = 0 To 9
Line (xx + x * 20, yy)-(xx + x * 20, yy + 300), Klr(2)
Next x
For y = 0 To 15
Line (xx, yy + y * 20)-(xx + 180, yy + y * 20), Klr(2)
Next y
End If
drawcode
End Sub
Sub scribblechar (x, y, t$, s, tk As _Unsigned Long)
xx = x
yy = y
lx$ = ""
ly$ = ""
points = 0
tt = Asc(t$)
If Len(charcode$(tt)) > 0 Then
For c = 1 To Len(charcode$(tt))
If Mid$(charcode$(tt), c, 1) <> "U" Then
nx$ = Mid$(charcode$(tt), c, 1)
ny$ = Mid$(charcode$(tt), c + 1, 1)
c = c + 1
If points = 0 Then
lx$ = nx$
ly$ = ny$
points = points + 1
Else
points = points + 1
If points = 2 Then
lx = Val(lx$): ly = Val("&H" + ly$)
nx = Val(nx$): ny = Val("&H" + ny$)
Line (xx + lx * s, yy + ly * s)-(xx + nx * s, yy + ny * s), tk
points = points - 1
lx$ = nx$
ly$ = ny$
End If
End If
Else
lx$ = ""
ly$ = ""
points = 0
End If
Next c
End If
End Sub
Function pickkey$ (list$)
pickflag = 0
Do
_Limit 60
x = _KeyHit
x = -x
If x > 0 And x < 256 Then
A$ = Chr$(x)
If InStr(list$, A$) Then pickflag = 1
pickkey$ = A$
End If
Loop Until pickflag = 1
End Function
Sub savefont
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "Save Current Font ?"
Locate 26, 25
Print "press Y or N"
Choice$ = pickkey$("YyNn")
If LCase$(Choice$) = "n" Then
showcharcode
Else
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "Please Enter a File Name"
Locate 26, 25
Input filename$
fileout$ = filename$
Open fileout$ For Output As #1
Write #1, " ****************************************************************************************"
oline$ = " " + filename$
Write #1, oline$
Write #1, " ****************************************************************************************"
Write #1, " This A SCribble Font wrtitten for use in QB64 programs"
Write #1, " please see https://staging.qb64phoenix.com/index.php for more on scribble fonts and QB64PE"
Write #1, " ****************************************************************************************"
Write #1, "10x16"
For c = 0 To 255
Write #1, charcode$(c)
Next c
Close #1
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "File Saved"
_Delay 0.5
End If
showcharcode
End Sub
Sub loadfont
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "Save Current Font before Loading NEW FONT ?"
Locate 26, 25
Print "press Y or N"
Choice$ = pickkey$("YyNn")
If LCase$(Choice$) = "Y" Then
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "Please Enter a File Name"
Locate 26, 25
Input filename$
fileout$ = filename$
Open fileout$ For Output As #1
Write #1, " ****************************************************************************************"
oline$ = " " + filename$
Write #1, oline$
Write #1, " ****************************************************************************************"
Write #1, " This A SCribble Font wrtitten for use in QB64 programs"
Write #1, " please see https://staging.qb64phoenix.com/index.php for more on scribble fonts and QB64PE"
Write #1, " ****************************************************************************************"
Write #1, "10x16"
For c = 0 To 255
Write #1, charcode$(c)
Next c
Close #1
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "File Saved"
_Delay 1
Choice$ = "n"
End If
If LCase$(Choice$) = "n" Then
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "Please Enter a File Name of FONT to LOAD"
Locate 26, 25
Input filename$
fileout$ = filename$
filein$ = filename$
Open filein$ For Input As #1
For headerread = 1 To 6
Input #1, dummy$
Next headerread
Input #1, fontspec$ 'not used yet but keeeping in place for revision
For cc = 0 To 255
Input #1, charcode$(cc)
Next cc
Close #1
Line (1, 370)-(639, 479), Klr(0), BF
Locate 25, 25
Print "FONT LOADED"
Choice$ = "z"
_Delay 1
End If
showcharcode
End Sub
Hi, I finally found some time and went through the disks. Here is a DLL for playing MIDI files and below it is LibXMP from RhoSigma, which allows you to play MOD, XM, S3M and other audio formats. At the end is also support for IMF music files.
All of these programs must be compiled in a 32-bit IDE because the used dynamic libraries are 32-bit.
MIDI playing:
Code: (Select All)
'program works only in 32bit IDE because DLL library is 32bit. Tested in QB64 v. 1.2 (revision 20180202/85)
DECLARE DYNAMIC LIBRARY "playmidi32"
FUNCTION PlayMIDI& (filename AS STRING)
END DECLARE
DO WHILE _KEYHIT <> 27
PRINT "Press spacebar for stop music or Esc for end"
status = PlayMIDI("Super Mario 64 - Medley.mid")
DO WHILE i$ <> CHR$(32) OR i$ = CHR$(27)
i$ = INKEY$
IF i$ = CHR$(27) THEN SYSTEM
LOOP
stat2 = PlayMIDI("")
PRINT "STOPED. Press other key (no spacebar or Esc) for playing from begin again."
SLEEP
i$ = ""
LOOP
For midi playing is need library Playmidi32.dll
MOD/XM/S3M and other playing:
Code: (Select All)
'Author: RhoSigma
'***********************************
'*** Use the QB64 32-bit version ***
'*** the DLL is for 32 bits only ***
'***********************************
'--- declare the required (only) DLL routines, there are much more ---
DECLARE DYNAMIC LIBRARY "./libxmp"
FUNCTION xmp_create_context%& ()
SUB xmp_free_context (BYVAL xmp_context%&)
FUNCTION xmp_load_module& (BYVAL xmp_context%&, path$)
SUB xmp_release_module (BYVAL xmp_context%&)
FUNCTION xmp_start_player& (BYVAL xmp_context%&, BYVAL rate&, BYVAL format&)
FUNCTION xmp_play_buffer& (BYVAL xmp_context%&, BYVAL buffer%&, BYVAL size&, BYVAL loops&)
SUB xmp_end_player (BYVAL xmp_context%&)
END DECLARE
'--- init player ---
ctx%& = xmp_create_context%&
xErr& = xmp_load_module&(ctx%&, "s.xm" + CHR$(0)) 'load music MOD/XM/S3M file (amiga MOD file format)
xErr& = xmp_start_player&(ctx%&, _SNDRATE, 0)
'--- get storage for sound data ---
DIM buf AS _MEM
bsz& = _SNDRATE * 5 * 2 * 2 'space for 5 seconds 16-bit stereo sound
buf = _MEMNEW(bsz&)
'--- init scroll text ---
txt$ = "The 'External Module Player (XMP)' library (http://xmp.sourceforge.net/) " +_
"integrated into the QB64 parts system could greatly improve the sound " +_
"abilities of QB64 by easily adding dozens of well known and even some " +_
"obscure music tracker formats from various platforms ontop of the already " +_
"existing sound functions. Hence it could bring back a couple of those " +_
"formats, which got lost with the transition from SDL to OpenGL. --- --- "
'--- main loop ---
PRINT "Press any key to stop replay, or wait until end ..."
st! = TIMER
DO
_LIMIT 7
IF _SNDRAWLEN < .5 THEN GOSUB RefillSoundBuffer
'do your stuff here (non-blocking, ie. no INPUT etc.)
LOCATE 10, 10
PRINT LEFT$(txt$, 60)
txt$ = MID$(txt$, 2) + LEFT$(txt$, 1)
'-----
LOCATE 14, 24
PRINT USING "Buffered sound: ##.##### seconds"; _SNDRAWLEN
'-----
ct! = TIMER
min$ = RIGHT$("00" + LTRIM$(STR$(INT((ct! - st!) / 60))), 2)
sec$ = RIGHT$("00" + LTRIM$(STR$(INT((ct! - st!) - (VAL(min$) * 60)))), 2)
LOCATE 16, 24
PRINT USING " Elapsed time: &:& (mm:ss)"; min$; sec$
LOOP UNTIL xErr& 'WHILE NOT xErr& AND _KEYHIT = 0
_SNDRAWDONE
'--- free storage ---
_MEMFREE buf
'--- free player ---
xmp_end_player ctx%&
xmp_release_module ctx%&
xmp_free_context ctx%&
'--- get next portion of sound and send to _SNDRAW ---
RefillSoundBuffer:
'To avoid sound garbage at the end, we first clear the
'buffer, just in case the final portion doesn't fill the
'entire buffer anymore.
_MEMFILL buf, buf.OFFSET, bsz&, 0 AS _BYTE
'-----
xErr& = xmp_play_buffer&(ctx%&, buf.OFFSET, bsz&, 1)
'PRINT bsz&, xErr&
'must be compiled in 32bit IDE
DECLARE DYNAMIC LIBRARY "./imfLib"
SUB InitIMFPlayer
SUB StartIMFMusic (BYVAL pointer AS _OFFSET, BYVAL size AS _OFFSET)
SUB ShutdownIMFPlayer ()
SUB SetIMFEndedEvent (hwnd, UWM_MUSICENDED)
'// where hwnd is the window to get your user defined
'// message UWM_MUSICENDED (i.e. #define UWM_MUSICENDED (WM_APP + 1)).
'// There you should restart the song by just calling
'// StartIMFMusic with the same pointer again, or load
'// another song and start this.
END DECLARE
file$ = "test.imf"
T = 0
ff = FREEFILE
OPEN file$ FOR BINARY AS ff
size = LOF(ff) - T
REDIM NewSound AS _MEM
NewSound = _MEMNEW(size)
s$ = SPACE$(size)
REM SEEK ff, T
GET #ff, , s$
_MEMPUT NewSound, NewSound.OFFSET, s$
s$ = ""
CLOSE #ff
InitIMFPlayer
StartIMFMusic NewSound.OFFSET, NewSound.SIZE
SetIMFEndedEvent _WINDOWHANDLE, 5
DO
LOCATE 1
PRINT "Press any key to end. For listening set your audio to stereo and disable some dolby software!"
LOOP UNTIL _KEYHIT = 32
ShutdownIMFPlayer
_MEMFREE NewSound
END
For this is need IMFLib.dll, placed in IMF Play.zip
All need libraries, source codes and music files in attachment.
Zip files contians just BAS files, music files and DLL. None EXE files.
So writing a sub to draw rectangles with line thickness and the first one I knocked out revealed a curious and happy surprise:
Code: (Select All)
'Boxing accident
Screen _NewImage(800, 500, 32)
Dim Shared pencolor As _Unsigned Long
pencolor = _RGB32(250, 250, 250)
box 2, 2, 140, 80, 3, &HFFFFFFFF
box 152, 2, 250, 100, 3, &HFF
box 300, 2, 400, 200, 9, &HF0F0F0F
box 30, 200, 90, 400, 20, &HF00F00F
Locate 20, 20: Print "A happy accident using line styles"
Locate 21, 20: Print "and a simple algorithm"
Sub box (x1, y1, x2, y2, thickness, style)
xa = x1: xb = x2: ya = y1: yb = y2
For l = 1 To thickness
Line (xa, ya)-(xb, yb), pencolor, B , style
xa = xa + 1: xb = xb - 1
ya = ya + 1: yb = yb - 1
Next l
End Sub
'
' The foloowing lines serve no purpose other that to illustrate that the program
' will never reach those lines of code.
For z = 1 To 10
Next z
System
In this code, I am hiding the QB64pe screen until I take some actions based upon the size of the desktop on which the program is being run. As a result, I try to obtain the width and height of the desktop. However, the line "x = _DesktopWidth: y = _DesktopHeight" will simply hang forever.
If you execute the code above, it will look within the IDE as if the program runs and ends because you get access to the IDE again after running the program. However, if you look at task manager you will find that the program is still running:
As further proof of this, try to run the same program in Debug mode by pressing the F7 key. Note that it will hang on the line "x = _DesktopWidth: y = _DesktopHeight" and you will never be able to step past that line.
I find it odd that the QB64pe screen would have to be displayed just to allow me to get the width and height of my actual display.
Is this expected behavior for some reason? If so, any workaround or possibility of a fix for this?
Quote:I was recently asked for guidelines about the process for contributing to QB64's source code/core functionality.
I am supportive of ANY change to QB64 which: 1) Will not break existing functionality in any way 2) Is multi-platform compatible 3) Does not grossly/negatively interfere with the QB64 programming experience 4) Does not contain any known bugs 5) Is/Will be clearly documented so others can use it (either on the forum or in the WIKI) 6) Does not allow mixed language/CPU specific command integration (such as inline C++ code, assembly, etc) 7) Is not malicious in any way
Does your idea meet all of the above criteria? If so your next steps are... 1) Code it! (make sure you note any files you change and where for your own reference) 2) Submit it. i) If you are a QB64 repository contributor, grab the latest version of the repository, make your changes and push them (I and the community will test the next dirty build [which is automatically created from the repository] and as long as it works, job done!) or... ii) Become a repository contributor by asking me on the Q&A forum
Everybody has a different opinion about what QB64 can/should be. But unless we make it what the individuals in our community want it to be then we all lose. So even if we personally don't want/need things like... - Path finding - Sorting - A suite of string commands - University-degree level math operations - A circle fill command - ODBC functionality - OOP - Name spaces - Option explicit - Web server interoperability - Nullable/Reference types ...someone does.
My new philosophy is to let QB64 be what the community want it to be. Even if we end up with 1000s of commands that barely get used by the majority, it is better than QB64 not being used at all. And if someone implements something incredibly stupid/unnecessary (such as a _HELLOWORLD command) the beauty of a repository is that it can always be rolled back later. Because of this philosophy, you won't see me standing in the way of any changes.
Sub: A func.bas makes a func.exe - Can I SHELL to func.exe? Yes I can, but it is SLOW. My func.bas program is msecs.bas, which gets milliseconds since midnight.
Program 1 shows that the API call is FAST. BUT I don't want to have all the baggage (Type..End Type, Declare..EndDeclare, Function..EndFunction), I'd rather compile it and call (SHELL?) it.
Type typeTime
yr As Integer
mo As Integer
ddWk As Integer
dd As Integer
hh As Integer
mm As Integer
ss As Integer
ms As Integer
End Type
Declare Dynamic Library "Kernel32"
Sub GetSystemTime (lpSystemTime As typeTime)
End Declare
Dim i, nloops, ms0 ' start
For i = 1 To 20
ms0 = IncodeMsecs
Do Until IncodeMsecs <> ms0: Loop ' start a new ms
nloops = 0 ' start counting
ms0 = IncodeMsecs ' during this 1 ms
Do Until IncodeMsecs <> ms0: nloops = nloops + 1: Loop
Print nloops; " loops in 1 millisecond"
Next i
Function IncodeMsecs () ' This is FAST, but how to compile it and use it as an exe file?
Dim sysTime As typeTime, hh, mm, ss, ms
GetSystemTime sysTime
hh = sysTime.hh
mm = sysTime.mm
ss = sysTime.ss
ms = sysTime.ms
IncodeMsecs = ms + 1000 * (ss + 60 * (mm + 60 * hh))
End Function
Program 2 is THE msecs.bas (with the baggage) which makes msecs.exe which returns milliseconds:
Code: (Select All)
_Title "msecs"
Option _Explicit
DefLng A-Z
Type typeTime
yr As Integer
mo As Integer
ddWk As Integer
dd As Integer
hh As Integer
mm As Integer
ss As Integer
ms As Integer
End Type
Declare Dynamic Library "Kernel32"
Sub GetSystemTime (lpSystemTime As typeTime)
End Declare
Dim Shared sysTime As typeTime
GetSystemTime sysTime
Dim hh, mm, ss, ms
hh = sysTime.hh
mm = sysTime.mm
ss = sysTime.ss
ms = sysTime.ms
System ms + 1000 * (ss + 60 * (mm + 60 * hh))
Program 3 (without the baggage) shows that IT WORKS, but is SLOW. You spend 1000 ms to get the current ms.
1) I don't want to hear about something like that _Millisecs() already exists -- I want to pursue doing this. [ I found out about Timer(.001) ! ]
2) Apparently msecs.exe is not staying in memory - is being re-loaded each call.
3) Apparently msecs.exe is opening/closing an unused/unwanted console window.
4) This makes it SLOW. Can I fix these issues?
To the Admins - If you don't think this thread is appropriate for this site please remove it.
Inspired by this thread on here, but not wanting to derail it, I went searching for old dialects of BASIC that are still available for download and not on the list provided by @CharlieJV. What I came across surprised me. Some are still there but are now open source (you may have to compile them yourself) and one is available via the wayback machine. For anyone interested here is the list of the ones I found with links to the relevant pages. Note I am not trying to direct people away from QB64, this is purely for curiosity's sake.
![[Image: Image1.jpg]](https://i.ibb.co/qjsLdT6/Image1.jpg)
