Post by ubi44 on Jan 24, 2024 20:34:43 GMT
This program allows you to add colors, bold, lights, and cuts to any monochrome font without gradients.
The SizeFont variable is decisive when it comes to the accuracy of the scan of the letters ... I left it on 32!
The resolution can be adjusted by changing the HIGH variable (line 16) that defines the height of the screen. 480 minimum! 1080 max!
To load a font you need a .ttf or .otf Font!
The SizeFont variable is decisive when it comes to the accuracy of the scan of the letters ... I left it on 32!
The resolution can be adjusted by changing the HIGH variable (line 16) that defines the height of the screen. 480 minimum! 1080 max!
To load a font you need a .ttf or .otf Font!
Type lettr
t As Integer ' if t=0 first | if t=1 its point of the letter| if t=2 its last point of the letter | if t=3 it's a hole in the letter
x As _Float ' x vector to next point
y As _Float ' y vector to next point
End Type
Type vec2
x As _Float
y As _Float
End Type
Dim WidthOfSpaceX ' Width of a space ...(without letter). calculated in Scanlet sub.
WidthOfSpaceY = 100 ' Height'''''''''''''''''''''''''''''''
SpaceBetweenLetter = 25 ' space between letter! (without space) coul'd be negative.
Dim Shared Lett(256, 500) As lettr ' Stores letters Lett(letter, point of letter)
Dim Shared LettStart(256) As vec2 ' Stores the start position to draw letters x,y
Dim Shared SizeOfLetter(256) ' the width of each letter
HIGH = 600 ' the _height value of a 4/3 screen _newimage ! minimum -480 !
Screen _NewImage(HIGH * 4 / 3, HIGH, 32)
Dim Shared SizeFont
fontHandle& = _Font ' save current Font
' the font must be printable in QB64 (if the letters are too big ! Then there are the cut edges)
' only monochrome black & white with no gradient !
SizeFont = 32 ' sizefont is used for the scan (Scanlet sub) ..of letters. For Font as verdana, high value (32) give best result. 14 is minimum & well done with default font.
' SizeFont depends on font's finesse (the more finesse the more big value!
'_Font _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\" + "impact.ttf", SizeFont) ' you can try different font from windows .or elsewhere.! if you load a font ,use SizeFont as the size% of Font.
'_Font _LoadFont("./******.ttf", SizeFont)
Scanlet
_Font fontHandle& ' restore original Font even if no _Font had been loaded before the letters were scanned: Scanlet
Dim DEFx ' is to adjust size ..to fit screen
DEFx = 1
Cls ' why not!
psx = .04: psy = .04 ' increments for rotation 3D
CUTy = 15 ' autocut
VD = -5 ' increment of 'autocut' CUTy
grouch = Timer + .5
R$ = ".TYPE TEXT." '''' the key input!
M$ = Chr$(2) + " hello world " + Chr$(2)
Dim save$(20) ' the text line in wallpaper...
Dim zoom(20)
save$(0) = "Some of the most important landmarks in the United States include feats of architecture "
save$(1) = "and modern engineering. San Francisco, California, is a beautiful city on its own, but "
save$(2) = "it is also home to The Golden Gate Bridge, a 1.7 mile suspension bridge connecting the "
save$(3) = "San Francisco Peninsula to the Marin Headlands. The bridge holds the title of one of the "
save$(4) = "Wonders of the Modern World according to the American Society of Civil Engineers. "
save$(5) = "One of the most popular ways to appreciate the bridge is to take an excursion to the "
save$(6) = "Golden Gate National Recreation Area just outside of San Francisco. The park contains "
save$(7) = "hiking trails, great spots for picnicking, and offers some of the best vantage points "
save$(8) = "for panoramic photographs of the bridge leading into the city. "
save$(9) = "David recently had some friends visit him in San Francisco, and he made sure to include "
save$(10) = "a visit to the recreation area as part of their tour. They enjoyed walking through the "
save$(11) = "trails, observing some of the native wildlife, and even having a casual picnic in the park."
save$(12) = "David friends were thankful that he guided them through this impressive area of California."
save$(13) = "They made sure to take a group photograph with the Golden Gate Bridge in the background. "
save$(14) = "David friends had the picture framed, and they later presented it to David in order "
save$(15) = "to thank him for his hospitality during their stay. "
save$(16) = "The Grand Canyon, one of the Seven Wonders of the Natural World, is located in the state "
save$(17) = "of Arizona. It is also a UNESCO World Heritage Site. Formed by over 70 million years of "
save$(18) = "erosion from the Colorado River, the Grand Canyon offers a spectacular view. The canyon "
save$(19) = "spans 277 miles in length, up to 18 miles in width, and it measures over a mile in depth..."
save$(20) = " ''''https://lingua.com/english/reading/golden-gate-bridge/ "
current = 20
For i = 0 To 20
zoom(i) = .1 ' size of each 20 save$()
Next i
Randomize (Timer)
bolding = Int(Rnd * 4) ' see Select Case bolding __the 'colooring & bold' .')
If bolding > 3 Then bolding = 3
'ftimer! = Timer + 1 'fps timer
form = 1 + Int(Rnd * 4) ' form determine the cut (F3 key) / CUT is the cut of a letter ( increment 5 ) ...25 MAX , ... 5 MIN
Select Case form
Case 1
CUT = 5
Case 2
CUT = 10
Case 3
CUT = 15
Case 4
CUT = 20
Case 5
CUT = 25
End Select
ct = .01: ct1 = ct: ct2 = ct / 2: ct8 = ct / 8: ctx8 = .01 * .8 'increment for the fake cos(timer*x)
Light = Int(Rnd * 3) 'some light if needed!
Select Case Light
Case 1
L$ = "from-Left"
Case 2
L$ = "from-Top"
Case 3
L$ = "from-Right"
Case 4
L$ = "from-Botom"
Case 0
L$ = "Off"
End Select
Do
If grouch < Timer Then ' change auto for "ABCDEFGHIJKLMNOPQRSTUVWXYZ" text
If grout Then '
CUTy = CUTy + VD
If CUTy >= 30 Or CUTy <= 0 Then VD = -VD: CUTy = CUTy + VD * 2
grouch = Timer + .5 '
grout = 0 '
End If
End If
taille = (CosTimerx8) ' size of text "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
CosTimerx8 = CosTimerx8 + ctx8
grout = 0
If CosTimerx8 > 1 Or CosTimerx8 < 0 Then grout = 1: ctx8 = -ctx8: CosTimerx8 = CosTimerx8 + ctx8 * 2
graa = 5 ' "bold" of r$ text colouring
If ctx8 < 0 Then grout = 0
Cls , _RGB(6, 8, 17) ' cls with color gradient! '''''''''''''''CPU-hungry. Use a CLS instead if it lacks fluidity
For y = 0 To _Height Step 3
Line (0, y)-(_Width, y), _RGBA(35 + CosTimer * 15 - (y / _Height) * 40, 20 + (CosTimer8) * 15 - (y / _Height) * 20, 47 - CosTimer2 * 23 - (y / _Height) * 53, 125 + HIGH / 6)
Next y
CosTimer = CosTimer + ct1: CosTimer8 = CosTimer + ct8: CosTimer2 = CosTimer + ct2
If CosTimer > 1 Or CosTimer < -1 Then ct1 = -ct1: CosTimer = CosTimer + ct1 * 2
If CosTimer2 > 1 Or CosTimer2 < -1 Then ct2 = -ct2: CosTimer = CosTimer + ct2 * 2
If CosTimer8 > 1 Or CosTimer8 < -1 Then ct8 = -ct8: CosTimer = CosTimer + ct8 * 2
'the xx variable is used To place text$. to place centered i start from the center of screen minus half of the size of text, calculated with CALCsize() function. ,-_,/\_o'.)---^\__
ypos = 0
Hxx = 100
Hxxo = -100
For i = 0 To 20
ypos = ypos + WidthOfSpaceY * zoom(i) * 2
xx = _Width / 2 - (zoom(i) * DEFx) * (CALCsize(save$(i)) / 2)
Print2D save$(i), zoom(i) * DEFx, 5, 1, xx, _Height / 7 + ypos, CUT, 55, 75 + bout * .4, 24 - bout / 4, 35, Light, 1 ' 2d text
If xx < Hxx Then Hxx = xx
If xx > Hxxo Then Hxxo = xx
Next i
If Hxx < 10 Then DEFx = DEFx - .005
If Hxxo > 50 Then DEFx = DEFx + .005
If DEFx < 0 Then DEFx = 0
If DEFx > 2 Then DEFx = 2
text$ = "F1 Bold': " + Str$(bolding) + " | F2 Light: " + L$ + " | F3 cut: " + Str$(CUT)
xx = _Width / 2 - (.192 * DEFx) * (CALCsize(text$) / 2) '
Print2D text$, .19 * DEFx, 15, 1, xx, 1, 5, 178, 80, 14, 150, 0, 0
text$ = "type some text or hit enter to reset, esc to quit"
xx = _Width / 2 - (.18) * DEFx * (CALCsize(text$) / 2)
Print2D text$, (.18) * DEFx, 15, 1, xx, _Height - WidthOfSpaceY * 2.5 * (.18), 5, 178, 120, 24, 150, 0, 0
text$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
xx = _Width / 2 - ((taille * (.3 + (1 - taille) * .5))) * DEFx * (CALCsize(text$) / 2)
Print2D text$, (taille * (.3 + (1 - taille) * .5)) * DEFx, 15, 1, xx, 100 * taille * (.5 + (1 - taille) * .5), CUTy, 178, 120, 24, 255 * taille * .35, Light, 2
Print2D text$, (taille * (.3 + (1 - taille) * .5)) * DEFx, 2, -1, xx, 100 * taille * (.5 + (1 - taille) * .5), CUTy, 150, 150, 0, 255 * taille * .45, Light, 2
text$ = " . Hit F1 and see . | . Hit F2 To on/off Light . | . Hit F3 to change the cut . | . Hit F4 to fullscreen or windowed . | . Use arrow keys to adjust space between letters . |"
xx = repose
If xx < -((.2) * (CALCsize(text$) * DEFx)) Then repose = _Width + 8
Print2D text$, (.2) * DEFx, 10, -1, xx - 1, _Height - WidthOfSpaceY * 4 * (.2) - 1, 5, 178, 120, 24, 150, 4, Abs(Cos(Timer * 3)) * 2
Print2D text$, (.2) * DEFx, 0, -1, xx, _Height - WidthOfSpaceY * 4 * (.2), 5, 1, 1, 1, 255, 0, 0
repose = repose - 2
xx = _Width / 2 - (5 + go) * DEFx * (CALCsize(R$) / 2) '
bout = Len(R$) '83
If 5 + go <= zoom(2) And cont > 20 And xx < _Width / 80 Then 'If R$ reaches the edge of the screen and its size limit, it is saved in Save$(20)
current = current + 1
If current > 20 Then
For i = 0 To 19 ' Pull it all up a line
save$(i) = save$(i + 1)
zoom(i) = zoom(i + 1)
Next i
current = 20
End If
save$(current) = R$ ' save
zoom(current) = zoom(1)
R$ = ""
cont = 0
End If
YYtest = (_Height * .5) + (5 + go) * DEFx * WidthOfSpaceY
yy = yy - 10
If yy < (_Height * .5) - (5 + go) * DEFx * WidthOfSpaceY Then yy = (_Height * .5) - (5 + go) * DEFx * WidthOfSpaceY
If YYtest > _Height * .8 Then yy = yy - 15
If yy < 0 Then yy = 0
If bout > 55 Then bout = 55 ' the 'bolding of text bolding, is more of a bold coming out or drooling or a bold coming in to fill characters
'''''''''''''''''''''''''''''' bolding = 0,1,2,3 changes colors by drooling or filling!
If bolding = 0 Then
Print2D R$, (5 + go) * DEFx, 1.25 * (1 + (graa - bout * .005)), -1, xx, yy, CUT, 255, 120 + bout * 1.14, 24 - bout / 4, 155, Light, (5 + go) * 3
Print2D R$, (5 + go) * DEFx, ((graa - bout * .01)), -1, xx, yy, CUT, 127 - bout, bout * 2.4, 4 + bout * .4, 255, Light, (5 + go) * 3
End If
If bolding = 1 Then
Print2D R$, (5 + go) * DEFx, 2.5 * (1 + (graa - bout * .005)), 1, xx, yy, CUT, 50, 50 + bout * 1.14, 174 - bout * .4, 155, Light, (5 + go) * 3
Print2D R$, (5 + go) * DEFx, (1 + (graa - bout * .01)), -1, xx, yy, CUT, 127 + bout, bout * 2.4, 255 - bout * .4, 255, Light, (5 + go) * 3
End If
If bolding = 2 Then
Print2D R$, (5 + go) * DEFx, (1 + (graa - bout * .005)), -1, xx, yy, CUT, 155, 120 + bout * 1.14, 124 - bout / 4, 155, Light, (5 + go) * 3
Print2D R$, (5 + go) * DEFx, 1.85 * (1 + (graa - bout * .01)), 1, xx, yy, CUT, 55 - bout, bout * 2.4, 4 + bout * .4, 255, Light, (5 + go) * 3
End If
If bolding = 3 Then
Print2D R$, (5 + go) * DEFx, 2.75 * (1 + (graa - bout * .005)), 1, xx, yy, CUT, 55, 75 + bout * 1.4, 24 - bout / 4, 155, Light, (5 + go) * 3
Print2D R$, (5 + go) * DEFx, (1 + (graa - bout * .01)), -1, xx, yy, CUT, 75, 87 + bout * 1.4, 44 - bout / 4, 255, Light, (5 + go) * 3
End If
If R$ <> "" Then ' then adjust the size with var 'go' to set the good size of r$ in Print2D to fit the screen ! (used as (5 + go)
If xx < 0 Then go = go - .07: If go < -5 Then go = -5
If xx > _Width / (6) Then go = go + .01: If go > -1 Then go = -1
End If
'keyboard
x = _KeyHit ' input key presed or not!
If x Then
If x < 0 Then '
' Released negative value means key released
x = -x
If add = 1 Then add = 2 ' if key pressed and key released then key confirm!
Else
add = 1 ' key pressed
' Pressed positive value means key pressed
End If
If x < 256 Then 'ASCII code values
If add = 2 Then If x <> 7 And (x < 9 Or x > 13) And x <= 255 Then R$ = R$ + Chr$(x): add = 0: cont = cont + 1 ' if key confirm add keypress to r$ and set add to 0
End If
If go <> 0 Then If x = 13 And add = 2 Then M$ = R$: R$ = "": go = -4.2: add = 0 ' if hit enter reset and save to M$ for Print3D
If x = 15104 And add = 2 Then 'F1 key
Select Case bolding
Case 0
bolding = 1
Case 1
bolding = 2
Case 2
bolding = 3
Case 3
bolding = 0
End Select
If R$ = "" Then R$ = ".TYPE TEXT."
add = 0
End If
If x = 15360 And add = 2 Then 'F2 key
Select Case Light
Case 0
Light = 1
L$ = "from-Left"
Case 1
Light = 2
L$ = "from-Top"
Case 2
Light = 3
L$ = "from-Right"
Case 3
Light = 4
L$ = "from-Botom"
Case 4
Light = 0
L$ = "Off"
End Select
add = 0
End If
If x = 15616 And add = 2 Then 'F3 key
Select Case form
Case 0
form = 1: CUT = 5
Case 1
form = 2: CUT = 10
Case 2
form = 3: CUT = 15
Case 3
form = 4: CUT = 20
Case 4
form = 0: CUT = 25
End Select
add = 0
End If
If x = 15872 And add = 2 Then 'F4 key
foff = _FullScreen
If foff = 0 Then _FullScreen _SquarePixels , _Smooth Else _FullScreen Off
add = 0
End If
' arrows keys
If x = 19200 Then SpaceBetweenLetter = SpaceBetweenLetter - .5
If x = 19712 Then SpaceBetweenLetter = SpaceBetweenLetter + .5
If x = 20480 Then WidthOfSpaceY = WidthOfSpaceY - .5
If x = 18432 Then WidthOfSpaceY = WidthOfSpaceY + .5
End If
'''
' set angle rotation for Print3D
If turn = 0 Then angyz = angyz + psy
If turn = 1 Then angxz = angxz + psx
If turn = 0 Then If angyz > 6.28 Or angyz < 0 Then psy = -psy: angyz = angyz + psy: turn = 1
If turn = 1 Then If angxz > 6.28 Or angxz < 0 Then psx = -psx: angxz = angxz + psx: turn = 0
''''''''''''''''
movex = (_Width / 2 - (CALCsize(M$) / 2) * .05 * DEFx) * Cos(Timer * .5) 'the .25 must be .5 but it's 3d and z is about 1500 so .25
For i = 1 To 10
Print3D M$, .1 * DEFx, (.1) * -(CALCsize(M$) / 2), WidthOfSpaceY * -(.1), (-2.5 + i) * .25, movex, _Height * .315, 300, angxz, angyz, Cos(Timer / 2) * .1, CUT, 144, 144, 144, 175 ' + i * 17 ' 3d text
Next i
_Display
_Limit 60
'' calculation of FPS
'gfps = gfps + 1
'If ftimer! < Timer Then
' fps = gfps
' ftimer! = Timer + 1
' gfps = 0
'End If
Loop Until _KeyDown(27)
End
Sub Scanlet 'Scans all 255 characters
Shared WidthOfSpaceX
Dim x As Integer, y As Integer
lettre = 1
debut:
oldSTARTx = 0
oldSTARTy = 0
Cls
Locate (20 - (SizeFont / 4)) / 2, 1
For ik = 1 To lettre
If ik = 7 Or (ik >= 9 And ik <= 13) Or ik > 255 Then _Continue
Print Chr$(ik) + " ";
Next ik
h$ = Str$(Int((lettre / 255) * 100)) + "%"
_PrintString (_Width / 1.44, _Height / 1.14), h$
Line (_Width / 3.26, _Height / 1.12)-(_Width / 1.44, _Height / 1.06), _RGB(230, 0, 0), BF
Line (_Width / 3.26 + (_Width / 160), _Height / 1.11)-(_Width / 3.26 + (_Width / 160) + (_Width / 2.66 - ((1 - lettre / 255) * _Width / (2.66))), _Height / 1.07), , BF
_Display 'no show!
Cls
PTT = 0 'Number of points to make a letter
_PrintString (401, 201), (Chr$(lettre))
For x = 400 To 400 + SizeFont
For y = 200 To 200 + SizeFont
If _Red32(Point(x, y)) = 255 Then Line (5 + (-400 + x) * 10, 5 + (y - 200) * 10)-((-400 + x) * 10 + 15, (y - 200) * 10 + 15), _RGB(255, 255, 255), BF
Next y
Next x
'calculation of width of letter!
minx = SizeFont * 10
maxx = 0
For y = 0 To SizeFont * 10
For x = 0 To SizeFont * 10
If _Red32(Point(x, y)) = 255 Then
If x < minx Then minx = x: Exit For
End If
Next x
Next y
For y = 0 To SizeFont * 10
For x = SizeFont * 10 - 1 To 1 Step -1
If _Red32(Point(x, y)) = 255 Then
If x > maxx Then maxx = x: Exit For
End If
Next x
Next y
SizeOfLetter(lettre) = (maxx - minx)
If maxx - minx < 0 Then SizeOfLetter(lettre) = 0 Else totsize = totsize + SizeOfLetter(lettre): tts = tts + 1
Cls
_PrintString (401, 201), (Chr$(lettre))
' Redraw the letter in reverse video and in large size, to show the holes in the letters!
For x = 400 To 400 + SizeFont
For y = 200 To 200 + SizeFont
If _Red32(Point(x, y)) = 255 Then
Line (5 + (-400 + x) * 10, 5 + (y - 200) * 10)-((-400 + x) * 10 + 15, (y - 200) * 10 + 15), _RGB(0, 0, 0), BF
Else
Line (5 + (-400 + x) * 10, 5 + (y - 200) * 10)-((-400 + x) * 10 + 15, (y - 200) * 10 + 15), _RGB(255, 255, 255), BF
End If
Next y, x
' Erase the letter and leave only the holes
For yy = 1 To SizeFont * 10
Paint (5, yy), _RGB(0, 0, 0)
Next yy
'Scans holes
For hy = 0 To SizeFont * 10
For hx = 0 To SizeFont * 10
If Point(hx, hy) = _RGB(255, 255, 255) Then
x = hx: y = hy
dab = 3
GoSub SCANLEttRE
PTT = PTT + 1
Paint (hx + 1, hy + 1), _RGB(0, 0, 0) ' erase hole
End If
Next hx
Next hy
'redraw the letter
For x = 400 To 400 + SizeFont
For y = 200 To 200 + SizeFont
If _Red32(Point(x, y)) = 255 Then Line (5 + (-400 + x) * 10, 5 + (y - 200) * 10)-((-400 + x) * 10 + 15, (y - 200) * 10 + 15), _RGB(255, 255, 255), BF
Next y
Next x
'scan letter
For hy = 0 To SizeFont * 10
For hx = 0 To SizeFont * 10
If Point(hx, hy) = _RGB(255, 255, 255) Then
x = hx: y = hy
dab = 1
GoSub SCANLEttRE
PTT = PTT + 1
Paint (hx + 1, hy + 1), _RGB(0, 0, 0) 'erase letter
End If
Next hx
Next hy
Lett(lettre, PTT).t = 2 'end of letter
lettre = lettre + 1 'next
If lettre > 255 Then
WidthOfSpaceX = totsize / tts 'average width of space!
Exit Sub
End If
GoTo debut 'next
SCANLEttRE: 'follows the contour of the letter or hole and creates a dot with each change of direction! in Print3D and Print2D the cut consist in jump one or more dot
STARTX = x
STARTY = y
dirx = 1: diry = 0
olddirx = 1: olddiry = 0
If PTT > 0 Then
Lett(lettre, PTT).x = ((STARTX - oldSTARTx))
Lett(lettre, PTT).y = ((STARTY - oldSTARTy))
Lett(lettre, PTT).t = 0
Else
LettStart(lettre).x = (x)
LettStart(lettre).y = (y)
End If
totx = x: toty = y
Do
dbb:
lon = lon + 1
If dirx = 1 Then
If _Red32(Point(x + dirx, y)) = 0 Then
If _Red32(Point(x, y + 1)) = 255 Then
dirx = 0: diry = 1
GoTo 7
End If
If _Red32(Point(x, y - 1)) = 255 Then dirx = 0: diry = -1: GoTo 7
End If
If _Red32(Point(x + dirx, y)) = 255 And _Red32(Point(x + dirx, y - 1)) = 0 And _Red32(Point(x + dirx, y + 1)) = 255 Then
dirx = 1: diry = 0: GoTo 7
End If
If _Red32(Point(x + dirx, y)) = 255 And _Red32(Point(x + dirx, y - 1)) = 255 Then dirx = 0: diry = -1: GoTo 7
End If
If dirx = -1 Then
If _Red32(Point(x + dirx, y)) = 0 Then
If _Red32(Point(x, y - 1)) = 255 Then dirx = 0: diry = -1: GoTo 7
If _Red32(Point(x, y + 1)) = 255 Then dirx = 0: diry = 1: GoTo 7
End If
If _Red32(Point(x + dirx, y)) = 255 And _Red32(Point(x + dirx, y + 1)) = 0 Then dirx = -1: diry = 0: GoTo 7
If _Red32(Point(x + dirx, y)) = 255 And _Red32(Point(x + dirx, y - 1)) = 255 Then dirx = 0: diry = 1: GoTo 7
End If
If diry = 1 Then
If _Red32(Point(x, y + diry)) = 0 Then
If _Red32(Point(x - 1, y)) = 255 Then dirx = -1: diry = 0: GoTo 7
If _Red32(Point(x + 1, y)) = 255 Then dirx = 1: diry = 0: GoTo 7
End If
If _Red32(Point(x, y + diry)) = 255 And _Red32(Point(x + 1, y + diry)) = 0 Then diry = 1: dirx = 0: GoTo 7
If _Red32(Point(x, y + diry)) = 255 And _Red32(Point(x + 1, y + diry)) = 255 Then dirx = 1: diry = 0: GoTo 7
End If
If diry = -1 Then
If _Red32(Point(x, y + diry)) = 0 Then
If _Red32(Point(x - 1, y)) = 255 Then dirx = -1: diry = 0: GoTo 7
If _Red32(Point(x + 1, y)) = 255 Then dirx = 1: diry = 0: GoTo 7
End If
If _Red32(Point(x, y + diry)) = 255 And _Red32(Point(x - 1, y + diry)) = 0 Then diry = -1: dirx = 0: GoTo 7
If _Red32(Point(x, y + diry)) = 255 And _Red32(Point(x - 1, y + diry)) = 255 Then dirx = -1: diry = 0: GoTo 7
End If
GoTo dbb
7 If olddirx <> dirx Then
vecx = vecx + olddirx * lon
vecy = vecy + olddiry * lon
PTT = PTT + 1
Lett(lettre, PTT).x = (vecx)
Lett(lettre, PTT).y = (vecy)
Lett(lettre, PTT).t = dab
totx = totx + vecx
toty = toty + vecy
vecx = 0: vecy = 0
lon = 0
End If
x = x + dirx: y = y + diry
If x = STARTX And y = STARTY Then
Exit Do 'The round is over!
End If
olddirx = dirx: olddiry = diry
Loop
PTT = PTT + 1
Lett(lettre, PTT).x = (STARTX - totx)
Lett(lettre, PTT).y = (STARTY - toty)
Lett(lettre, PTT).t = dab
lon = 0
oldSTARTx = STARTX
oldSTARTy = STARTY
Return
End Sub
Function CALCsize (phrase$) 'return the lenght of a sentence
Shared WidthOfSpaceX
Shared SpaceBetweenLetter
largeur = 0
For Lete = 1 To Len(phrase$)
I = Asc(phrase$, Lete)
If I <> 32 Then
largeur = largeur + SizeOfLetter(I) + SpaceBetweenLetter
Else
largeur = largeur + WidthOfSpaceX
End If
Next
CALCsize = largeur
End Function
Sub Print2D (phrase$, T As _Float, GRa, ORDre, Vx, Vy, Dcoupe, r, g, b, a, Light As Integer, LightForce)
'phrase$ The sentence to print
'T for size ..taille in french!)
'Gra to make bold
'ORDre to bold in or out -1 is out, other is in
'vx vy starting position of phrase$ in screen coord
'Dcoupe to define a cutout of the letter 5- to 25 step 5
'r g b a _RGBA()
'Light add Light, off or from left,top,right,bottom 0,1,2,3,4
'Lightforce the intensity of light 25 is a max!
Dim LARGEUR 'the place occupied by letters that have already been written
Shared WidthOfSpaceX 'Width of a letter
Shared SpaceBetweenLetter '..
If T * .6 > 2 Then Toff = 2 Else Toff = T * .6
DDcoupe = Dcoupe
If T < .1 Then GRa = 1: Toff = 1
If T < 0 Then T = 0
If DDcoupe < 5 Then DDcoupe = 5
If DDcoupe > 25 Then DDcoupe = 25
sDcoupe = DDcoupe
LARGEUR = 0
For Lete = 1 To Len(phrase$)
I = Asc(phrase$, Lete)
If Lete > 1 Then
J = Asc(phrase$, Lete - 1)
If J <> 32 Then
LARGEUR = LARGEUR + SizeOfLetter(J) + SpaceBetweenLetter
Else
LARGEUR = LARGEUR + WidthOfSpaceX
End If
End If
stx = (LettStart(I).x) * T + Vx + LARGEUR * T
sty = (LettStart(I).y) * T + Vy
If I = 7 Or (I >= 9 And I <= 13) Or I > 255 Then Exit Sub
If I = 32 Then GoTo 3117 'space...
Select Case I 'if some limit cause letters unreadable the cut is limited ..work only with default system font. comment the select case to see the difference!!
Case 74, 187, 90
If DDcoupe > 25 Then DDcoupe = 25
Case 120, 88, 107, 54, 116
If DDcoupe > 15 Then DDcoupe = 15
Case 83, 71, 87, 119, 132, 122, 106, 50, 77
If DDcoupe > 20 Then DDcoupe = 20
Case 118, 86
If DDcoupe > 10 Then DDcoupe = 10
Case 78, 109, 110
If DDcoupe > 25 Then DDcoupe = 25
Case 115
If DDcoupe > 10 Then DDcoupe = 10
Case 75
If DDcoupe > 15 Then DDcoupe = 25
Case Else
DDcoupe = sDcoupe
End Select
If ((I > 47 And I < 58)) Or ((I > 64 And I < 123)) Then
'is not special characters.
Else
'if it's special charctere
If DDcoupe > 20 Then DDcoupe = 20 'needed for default font !
End If
Do
uP: tpx = Lett(I, pt).x: tpy = Lett(I, pt).y
If Lett(I, pt).t >= 1 Or pt = 0 Then
L1 = Sqr(tpx * tpx + tpy * tpy)
coupe:
If L1 < DDcoupe Then
upx = Lett(I, pt + 1).x: upy = Lett(I, pt + 1).y 'Saved vectors
tpx = tpx + upx: tpy = tpy + upy
If Lett(I, pt).t <> 2 Then pt = pt + 1
If Lett(I, pt).t = 1 Or Lett(I, pt).t = 3 Then
upx = Lett(I, pt).x: upy = Lett(I, pt).y
L1 = Sqr(upx * upx + upy * upy)
GoTo coupe
End If
End If
End If
tpp = tpp + 1
If Lett(I, pt).t >= 1 Then
bfx = stx + tpx * T
bfy = sty + tpy * T
dist = Sqr(tpx * tpx + tpy * tpy)
dix = (-tpy / dist) * (T)
diy = (tpx / dist) * (T)
For gras = 1 To GRa Step 3 - Toff
If ORDre = -1 Then
ax = stx - dix * gras: ay = sty - diy * gras
bx = bfx - dix * gras: by = bfy - diy * gras
Else
ax = stx + dix * gras: ay = sty + diy * gras
bx = bfx + dix * gras: by = bfy + diy * gras
End If
If Lett(I, pt).t <> 3 Or ORDre = -1 Then
If ax > 0 And ay > 0 And bx > 0 And by > 0 And ax < _Width And bx < _Width And ay < _Height And by < _Height Then
lux = (LightForce * pt * .1) / gras
Line (ax, ay)-(bx, by), _RGBA(r, g, b, a)
End If
End If
Next gras
If stx > 0 And sty > 0 And bfx > 0 And bfy > 0 And stx < _Width And bfx < _Width And sty < _Height And bfy < _Height Then
lux = a * LightForce
If Lett(I, pt).t <> 3 Then ' if not hole
If r >= g And r > b Then
If Light = 0 Then Line (stx, sty)-(bfx, bfy), _RGBA(r, g, b, a)
If Light = 3 Then Line (stx, sty)-(bfx, bfy), _RGBA(r - dix * lux, g - lux * dix, (b), lux)
If Light = 4 Then Line (stx, sty)-(bfx, bfy), _RGBA(r - diy * lux, g - lux * diy, (b), lux)
If Light = 1 Then Line (stx, sty)-(bfx, bfy), _RGBA(r + dix * lux, g + lux * dix, (b), lux)
If Light = 2 Then Line (stx, sty)-(bfx, bfy), _RGBA(r + diy * lux, g + lux * diy, (b), lux)
Else
If Light = 0 Then Line (stx, sty)-(bfx, bfy), _RGBA(r, g, b, a)
If Light = 1 Then Line (stx, sty)-(bfx, bfy), _RGBA(r - dix * lux, g + lux * dix * g, (b - diy * lux * b), lux)
If Light = 2 Then Line (stx, sty)-(bfx, bfy), _RGBA(r - diy * lux, g + lux * diy * g, (b + dix * lux * b), lux)
If Light = 3 Then Line (stx, sty)-(bfx, bfy), _RGBA(r + dix * lux, g - lux * dix * g, (b + diy * lux * b), lux)
If Light = 4 Then Line (stx, sty)-(bfx, bfy), _RGBA(r + diy * lux, g - lux * diy * g, (b - dix * lux * b), lux)
End If
Else
If r >= g And r > b Then
If Light = 0 Then Line (stx, sty)-(bfx, bfy), _RGBA(r, g, b, a)
If Light = 1 Then Line (stx, sty)-(bfx, bfy), _RGBA(r - dix * lux, g - lux * dix, (b), lux)
If Light = 3 Then Line (stx, sty)-(bfx, bfy), _RGBA(r - diy * lux, g - lux * diy, (b), lux)
If Light = 2 Then Line (stx, sty)-(bfx, bfy), _RGBA(r + dix * lux, g + lux * dix, (b), lux)
If Light = 4 Then Line (stx, sty)-(bfx, bfy), _RGBA(r + diy * lux, g + lux * diy, (b), lux)
Else
If Light = 0 Then Line (stx, sty)-(bfx, bfy), _RGBA(r, g, b, a)
If Light = 3 Then Line (stx, sty)-(bfx, bfy), _RGBA(r - dix * lux, g + lux * dix * g, (b - diy * lux * b), lux)
If Light = 4 Then Line (stx, sty)-(bfx, bfy), _RGBA(r - diy * lux, g + lux * diy * g, (b + dix * lux * b), lux)
If Light = 1 Then Line (stx, sty)-(bfx, bfy), _RGBA(r + dix * lux, g - lux * dix * g, (b + diy * lux * b), lux)
If Light = 2 Then Line (stx, sty)-(bfx, bfy), _RGBA(r + diy * lux, g - lux * diy * g, (b - dix * lux * b), lux)
End If
End If
End If
End If
stx = stx + tpx * T
sty = sty + tpy * T
If Lett(I, pt).t <> 2 Then pt = pt + 1: GoTo uP
Loop Until Lett(I, pt).t = 2
3117 pt = 0: tpp = 0
Next Lete
End Sub
Sub Print3D (phrase$, T, Vx, Vy, Vz, px, py, pz, angx, angy, angz, Dcoupe, r, g, b, a)
'phrase$ the sentence to print
'T for size
'vx vy vz starting position of the phrase$ in a 3D coordinate system where 0,0,0 is the center of the screen and the center of rotation Negative and positive values can be entered
' px py ..and pz because in rotation the position is the center 0,0,0 , this is used to replace on screen more easy after rotation. px pz are 2d coord _ pz is 3d coord to push far from the 0 after rotation
'angx,angy,angz Rotation around the axis
'Dcoupe to define a cutout of the letter 5 to 25 step 5
'r g b a _RGBA()
Shared WidthOfSpaceX
Shared SpaceBetweenLetter
If DDcoupe < 5 Then DDcoupe = 5
If DDcoupe > 25 Then DDcoupe = 25
DDcoupe = Dcoupe
cosX = Cos(angx): sinX = Sin(angx)
cosY = Cos(angy): sinY = Sin(angy)
cosZ = Cos(angz): sinZ = Sin(angz)
sDcoupe = Dcoupe
mm = Len(phrase$) / 2
For Lete = 1 To Len(phrase$)
I = Asc(phrase$, Lete)
If Lete > 1 Then
J = Asc(phrase$, Lete - 1)
If J <> 32 Then
LARGEUR = LARGEUR + SizeOfLetter(J) + SpaceBetweenLetter
Else
LARGEUR = LARGEUR + WidthOfSpaceX
End If
End If
stx = (LettStart(I).x) * T + Vx + LARGEUR * T
sty = (LettStart(I).y) * T + Vy
stz = 0
If I = 7 Or (I >= 9 And I <= 13) Or I > 255 Then Exit Sub
If I = 32 Then GoTo 3065 'space...
Select Case I
Case 74, 75, 187, 90, 122
If DDcoupe > 25 Then DDcoupe = 25
Case 120, 88, 107, 54
If DDcoupe > 15 Then DDcoupe = 15
Case 83, 71, 87, 119, 132, 122, 106, 50
If DDcoupe > 20 Then DDcoupe = 20
Case 118, 86
If DDcoupe > 10 Then DDcoupe = 10
Case 77, 78, 109, 110
If DDcoupe > 25 Then DDcoupe = 25
Case 115
If DDcoupe > 10 Then DDcoupe = 10
Case Else
DDcoupe = sDcoupe
End Select
If ((I > 47 And I < 58)) Or ((I > 64 And I < 123)) Then
Else
If DDcoupe > 20 Then DDcoupe = 20
End If
Do
uP: tpx = Lett(I, pt).x: tpy = Lett(I, pt).y
If Lett(I, pt).t >= 1 Or pt = 0 Then
L1 = Sqr(tpx * tpx + tpy * tpy)
coupe:
If L1 < DDcoupe Then
upx = Lett(I, pt + 1).x: upy = Lett(I, pt + 1).y
tpx = tpx + upx: tpy = tpy + upy
If Lett(I, pt).t <> 2 Then pt = pt + 1
If Lett(I, pt).t = 1 Or Lett(I, pt).t = 3 Then
upx = Lett(I, pt).x: upy = Lett(I, pt).y
L1 = Sqr(upx * upx + upy * upy)
GoTo coupe
End If
End If
End If
tpp = tpp + 1
If Lett(I, pt).t >= 1 Then
atx = stx: aty = sty: atz = stz + Vz
btx = stx + tpx * T: bty = sty + tpy * T: btz = stz + Vz
'rotations 'xz angx yz angy xy angz
tatx = atx * cosX - atz * sinX 'xz
atz = atx * sinX + atz * cosX
atx = tatx
taty = aty * cosY - atz * sinY 'yz
atz = aty * sinY + atz * cosY + pz
aty = taty
tbtx = btx * cosX - btz * sinX 'xz
btz = btx * sinX + btz * cosX
btx = tbtx
tbty = bty * cosY - btz * sinY 'yz
btz = bty * sinY + btz * cosY + pz
bty = tbty
taty = aty * cosZ - atx * sinZ 'xy
atx = aty * sinZ + atx * cosZ
aty = taty
tbty = bty * cosZ - btx * sinZ 'xy
btx = bty * sinZ + btx * cosZ
bty = tbty
afx = _Width / 2 + 40 * (atx) / (atz) * 15 + px
afy = _Height / 2 + 40 * (aty) / (atz) * 20 + py
bfx = _Width / 2 + 40 * (btx) / (btz) * 15 + px
bfy = _Height / 2 + 40 * (bty) / (btz) * 20 + py
If buit = 0 Then affx = afx: affy = afy: buit = 1
If afx > -5 And afy > -5 And bfx > -5 And bfy > -5 And afx < _Width + 5 And afy < _Height + 5 And bfx < _Width + 5 And bfy < _Height + 5 Then
If atz > -20 And btz > -20 Then Line (afx, afy)-(bfx, bfy), _RGBA(r, g, b, (a))
End If
End If
stx = stx + tpx * T
sty = sty + tpy * T
If Lett(I, pt).t <> 2 Then pt = pt + 1: GoTo uP
Loop Until Lett(I, pt).t = 2
3065 pt = 0: tpp = 0
Next Lete
End Sub