| Welcome, Guest |
You have to register before you can post on our site.
|
|
|
| Scribble Text demo |
|
Posted by: James D Jarvis - 05-15-2022, 05:59 PM - Forum: Programs
- Replies (6)
|
 |
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
Next SC
scribbleprint 1, 400, "Enter Your Name.", 1, 1.5, _RGB32(250, 250, 250)
Input A$
Cls
A$ = "Bye " + A$ + "!"
scribbleprint Int(Rnd * 400), Int(Rnd * 400), A$, (Rnd * 3) + 1, (Rnd * 3) + 1, _RGB32(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
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
|
|
|
| Text sub, any place, any size, any color |
|
Posted by: bplus - 05-15-2022, 02:35 PM - Forum: Utilities
- Replies (2)
|
 |
Here is a demo of Text sub
Code: (Select All) _Title "Demo Text Sub" ' b+ 2022-05-15
Const w = 1024, h = 600, wd2 = 512, hd2 = 300
Screen _NewImage(w, h, 32)
_ScreenMove 80, 0
txt$ = "Hello World"
For textHeight = 1 To hd2 / 2
Cls
r = 255 * textHeight / (hd2 / 2)
Text wd2 - .5 * (textHeight / 16) * 8 * Len(txt$), hd2 - textHeight / 2, textHeight, _RGB32(r, 0, 255 - r), txt$
_Display
_Limit 30
Next
Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)
Dim fg As _Unsigned Long, cur&, I&, multi, xlen
fg = _DefaultColor
cur& = _Dest
I& = _NewImage(8 * Len(txt$), 16, 32)
_Dest I&
Color K, _RGBA32(0, 0, 0, 0)
_PrintString (0, 0), txt$
multi = textHeight / 16
xlen = Len(txt$) * 8 * multi
_PutImage (x, y)-Step(xlen, textHeight), I&, cur&
Color fg
_FreeImage I&
End Sub
|
|
|
|
| CharSets |
|
Posted by: TarotRedhand - 05-15-2022, 11:02 AM - Forum: One Hit Wonders
- No Replies
|
 |
This is an implementation of mathematical sets that deals solely with characters. For an expanded explanation download the pdf readme below -
CHARSET README.pdf (Size: 259.26 KB / Downloads: 138)
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
Sub WaitKey
Do
Loop While InKey$ = ""
End Sub
'$INCLUDE: 'CHARSET.BM'
Thanks to @SMcNeill for helping me to port this.
Hope you find a use for this. Have fun.
TR
|
|
|
|
| Scribble Font Builder |
|
Posted by: James D Jarvis - 05-15-2022, 03:10 AM - Forum: Works in Progress
- Replies (2)
|
|
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://qb64phoenix.com/forum/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://qb64phoenix.com/forum/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
|
|
|
|
| Boxing accident |
|
Posted by: James D Jarvis - 05-14-2022, 03:01 PM - Forum: Programs
- Replies (7)
|
|
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
|
|
|
|
| A func.bas makes a func.exe - Can I Call(SHELL?) to func.exe? |
|
Posted by: dcromley - 05-13-2022, 07:26 PM - Forum: Help Me!
- Replies (2)
|
 |
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.
Code: (Select All) _Title "Test IncodeMsecs"
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 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.
Code: (Select All) _Title "Test2 msecs"
Option _Explicit
DefLng A-Z
Print Shell("msecs") ' SLOW!
Print Shell("msecs")
Print Shell("msecs")
Print Shell("msecs")
Print Shell("msecs")
Print Shell("msecs")
Print Shell("msecs")
Print Shell("msecs")
Print Shell("msecs")
Print Shell("msecs")
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?
I would appreciate your solutions.
|
|
|
|
| A Rabbit Hole |
|
Posted by: TarotRedhand - 05-13-2022, 05:53 PM - Forum: General Discussion
- Replies (7)
|
|
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.
Dark-Basic-Pro (GitHub)
MediaBASIC (SourceForge)
REALbasic (wayback machine)
SmallBASIC (Own web site hosted via GitHub)
XBasic (Own web site hosted via SourceForge)
yabasic (GitHub)
Anyone know of any others (not including BASIC V included with Risc OS)
TR
|
|
|
|
| Oh yeah I'm enjoying QB64 |
|
Posted by: James D Jarvis - 05-13-2022, 05:15 PM - Forum: General Discussion
- Replies (2)
|
|
I've been tinkering with QB64 like mad in recent weeks and I'm just happy it exists and has a community of users supporting it.
The ease at which it puts the modern machine on call for me is very appreciated.
I've programmed in c/c++ but never really had fun with it. Years back when I programmed much more I'd often prototype or bash out a routine in basic before making it work with C/C++ and assembler. Once upon a time I even had a major graphics board manufacturer trying to recruit me into an in-house demo squad writing graphical demos to show off their goods but I wimped out and went on to become a concept artist for an R&D firm where most of my programming skills were used to write filters and getting adobe products to import some obscure data format (contractors would try and trick my employers with proprietary formats to lock them in if we wanted to keep using the data but if I could confirm all the work they did was for hire I was into data in a couple days). I'm amazed at how rusty some of my skills have gotten but I'm also amazed at how powerful the machines have gotten and how easy to is to make use of that with QB64. A lot of the work of programming in QB4.5 and PowerBasic in the old days was getting around the system and hardware bottlenecks and some are still there but I can mostly just ignore them these days and that just increase the fun.
I sometimes worry the ease of access to very powerful features is teaching me to be lazy but that passes when I can knock off a little program without having to learn a framework or an API and how a particular implementation of the programming language does or doesn't deal with said features inside a RAD suite.
Looked at some old coding tricks and I realized...wow 80-90% of this was to get around the segment limits and the memory model. Actually being able to casually knock out a program that uses dozens if not hundreds of megs of ram is a pleasure. (I still get nervous about garbage collection.)
It's fun. Thanks folks.
|
|
|
|
| dottext ,scale and display text chars |
|
Posted by: James D Jarvis - 05-13-2022, 02:30 PM - Forum: Utilities
- Replies (3)
|
|
3 simple subs and a sample program for an alternate way to scale and display text. It's expandable if you want to use fancier fonts. (there's also a color reference builder but that's just so to make rgb32 colors a little easier to use.)
Code: (Select All) 'dottext
'draw scalable standard text using locate coordinates
Dim Shared ms&, chardot&
Dim Shared klr(0 To 255) As _Unsigned Long
ms& = _NewImage(800, 520, 32)
Screen ms&
_PrintMode _KeepBackground
'!!!! If you want to use another font put apporptiate code here
fw = _FontWidth 'manuually set this if changing code to use a hand drawn font image instead ofusing default
chardot& = _NewImage(fw * 255, 50, 32) 'create an image buffer to place and hold the font
'Screen chardot& uncomment to look at it if you would like to
_Dest chardot&
Cls
_ControlChr Off
buildrefcolors
Color klr(15)
For x = 0 To 255
Print Chr$(x); 'print that font into place
Next x
dottext 2, 1, "Dotext, 2 routines to draw scaleable text dot by dot", klr(3), 1, 1
Screen ms&
_Dest ms&
dottext 3, 3, "Sample Text, standard size.", klr(15), 1, 1
dottext 4, 4, "Sample Text, double height.", klr(8), 1, 2
dottext 6, 6, "Sample Text, double height and width.", klr(12), 2, 2
backdottext 8, 8, "Sample Text, double size and a background.", Chr$(219), klr(11), klr(8), 2, 1
dottext 10, 10, "Sample Text, x1.4 width x2.2 height.", klr(13), 1.4, 2.2
Locate 13, 1: Print "Plain text."
dottext 13, 13, "Sample Text,triple sized!", klr(14), 3, 3
dottext 16, 3, "Randomly sized height, width and color.", klr(Int(Rnd * 15) + 1), Rnd * 3 + .5, Rnd * 3 + .5
dottext 19, 1, "Enter your name.", klr(15), 2, 1
Locate 21, 1: Input n$
n$ = "ByE " + n$ + " !"
px = 1
For c = 1 To Len(n$)
'breaking down and printing the text message letter by letter
A$ = Mid$(n$, c, 1)
ww = Int(Rnd * 6) + 1
hh = Int(Rnd * 6) + 1
scalechar 22, px, Asc(A$), _RGB32(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255)), ww, hh
px = px + ww
Next c
Sub scalechar (c, r, char, cc As _Unsigned Long, tw, th)
'the raw sub to scan the font image and draw each dot in the font
Dim kc As _Unsigned Long
ww = _FontWidth 'this needs to be changed if yuo choose to load a font as a whole image instead
hh = _FontHeight 'this needs to be changed if yuo choose to load a font as a whole image instead
tr = (r - 1) * ww
tc = (c - 1) * hh
_Source chardot&
_Dest ms&
tx = char * 8
ty = 0
For px = 0 To (ww - 1)
For py = 0 To (hh - 1)
kc = Point(tx + px, ty + py)
If kc <> klr(0) Then
'PSet (xx + px, yy + py), cc
' Line (xx + px * mag - (mag - 1), yy + py * mag - (mag - 1))-(xx + px * mag, yy + py * mag), cc, BF
Line (tr + px * tw, tc + py * th)-(tr + (px + 1) * tw - 1, tc + (py + 1) * th - 1), cc, BF
End If
Next py
Next px
End Sub
Sub dottext (c, r, text$, cc As _Unsigned Long, tw, th)
'take text strign and pass it through scalechar to get print it
Dim kc As _Unsigned Long
tr = r
tc = c
For k = 1 To Len(text$)
ch = Asc(Mid$(text$, k, 1))
scalechar tc, tr, ch, cc, tw, th
tr = tr + tw
Next k
End Sub
Sub backdottext (c, r, text$, bkg$, cc As _Unsigned Long, bgc As _Unsigned Long, tw, th)
'as dotext but wiht a background character and background color defiend in same command
Dim kc As _Unsigned Long
tr = r
tc = c
bc = Asc(bkg$)
For k = 1 To Len(text$)
ch = Asc(Mid$(text$, k, 1))
scalechar tc, tr, bc, bgc, tw, th
scalechar tc, tr, ch, cc, tw, th
tr = tr + tw
Next k
End Sub
Sub buildrefcolors
'color reference table for using rgb32 colors quickly
For c = 0 To 255
klr(c) = _RGB32(c, c, c) 'all grey for now
Next c
_Source chardot&
klr(0) = Point(1, 1) '<- the pixel at this location in chardot defines black , this would matter if you loaded a an image
'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) = _RGB(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
|
|
|
|
|
