Keskustelu: Koodit: CoolBasic: TL Font System

Global screenw, screenh
screenw=600
screenh=100

SCREEN screenw, screenh

Dim TLFFont(256)
Global SaveTemp
SaveTemp=False

//---

// Luodaan fontti
font=MakeTLFFont("times.tlf", 25, 30, "Times New Roman", 20)

// Funktiot

Function MakeTLFFont(newfpath$, fw, fh, fontname$, fontsize, bold=0, italic=0, underline=0)
	CenterText screenw/2, screenh/2, "Odota hetki... Fonttia "+fontname$+" muutetaan .tlf muotoon", 2
	DrawScreen

	SetFont LoadFont(fontname$, fontsize, bold, italic, underline)

	img	= MakeImage(fw*16,fh*16)

	DrawToImage img
	For i=1 To 256
		l$=Chr(i)
		w=TextWidth(l$)
		h=TextHeight(l$)
		If w<fw And h<fh Then
			CenterText x*fw+fw/2,-(y*fh+fh/2), l$, 2
		EndIf

		x+1
		If i Mod 16 = 0 Then y+1:x=0
	Next i

	DrawToScreen

	If SaveTemp Then SaveImage img, "temp.bmp"

	//---

	f	= OpenToWrite(newfpath$)
	If f=0 Then MakeError "Unable To Create "+newfpath$

	WriteInt f, fw
	WriteInt f, fh

	x=0
	y=0
	For i=1 To 256
		l$=Chr(i)
		lw=TextWidth(l$)

		temp		= MakeImage(fw,fh)
		TLFFont(i)	= MakeImage(lw, fh)

		// Kirjain temppiin reunojen kanssa
		DrawToImage temp
			DrawImageBox img, 0, 0, x*fw, y*fh, fw, fh
		DrawToScreen

		// Reunat pois plz
		DrawToImage TLFFont(i)
			DrawImageBox temp, 0, 0, fw/2-lw/2, 0, lw, fh
		DrawToScreen

		DeleteImage temp

		x+1
		If i Mod 16 = 0 Then y+1:x=0
	Next i

	For i=1 To 256
		l$=Chr(i)
		lw=TextWidth(l$)

		WriteShort f, i
		WriteInt f, lw

		For y=0 To fh
			For x=0 To ImageWidth(TLFFont(i))
				PickImageColor TLFFont(i), x, y
				r	= getRGB(RED)
				g	= getRGB(GREEN)
				b	= getRGB(BLUE)

				// Tarkistetaan onko pikseli erivärinen kun musta ja jos ON
				// niin kirjota se ylös ja jos ei niin älä
				If r<>0 And g<>0 And b<>0 Then
					WriteByte f, 1 'Joo
				Else
					WriteByte f, 0 'Ei
				EndIf
			Next x
		Next y
	Next i
	CloseFile f
EndFunction

Global CurFontID, UsingFont
UsingFont=-1
Const FONTCOUNT = 5 // Saa muuttaa tarpeen mukaan

Const LETTERIMG = 0 // Älä muuta
Const LETTERWIDTH = 1 // Sama homma

Dim TLFFont(256, 1, FONTCOUNT)

// Ylläolevat vakiot ja globaalit on pakolliset
//---

font=LoadTLFFont("times.tlf", Rand(100,255), Rand(100,255), Rand(100,255))
SetTLFFont(font)

Color 255,255,255

Repeat
	Text 0,0,"FPS: "+FPS()

	s$	= "Hei täähän toimii hienosti!"
	s2$	= Date()+" "+Time()

	TLFText(s2$, MouseX()-TLFTextWidth(s$)/2, MouseY()-TLFTextHeight(s$)/2)
	TLFText(s$, 200-TLFTextWidth(s$)/2, 70)

	DrawScreen
Forever

Function SetTLFFont(fontid) ' Vaihtaa fontin aktiiviseksi. Tämä funktio syö LoadTLFFontin palauttamia ID numeroita
	If fontid<0 Or fontid>CurrentFontID Then Return 0
	UsingFont=fontid
EndFunction

Function LoadTLFFont(filepath$, r=255, g=255, b=255) ' Lataa fontin ja palauttaa sen ID numeron
	f	= OpenToRead(filepath$)

	fw	= ReadInt(f)
	fh	= ReadInt(f)

	Color r, g, b

	For i=1 To 256
		lid	= ReadShort(f)
		lw	= ReadInt(f)

		TLFFont(i, LETTERWIDTH, CurFontID)	= lw
		TLFFont(i, LETTERIMG, CurFontID)	= MakeImage(lw, fh)

		DrawToImage TLFFont(i, LETTERIMG, CurFontID)
		For y=0 To fh
			For x=0 To lw
				pix=ReadByte(f)

				If pix=1 Then
					Dot x, y
				EndIf
			Next x
		Next y
		DrawToScreen
	Next i

	CloseFile f

	fontid=CurFontID
	CurFontID+1
	Return fontid
EndFunction

Function TLFTextWidth(txt$, spacing=0) ' Tekstin leveys senhetkisellä fontilla
	fontid=UsingFont
	If fontid=-1 Then Return 0

	l = Len(txt$)
	For i=1 To l
		letter$ = Mid(txt$, i, 1)
		lw = TLFFont(Asc(letter$), LETTERWIDTH, fontid)+spacing
		width+lw
	Next i

	Return width
EndFunction

Function TLFTextHeight(txt$) ' Tekstin korkeus senhetkisellä fontilla
	fontid=UsingFont
	If fontid=-1 Then Return 0

	lh = TLFFont(1, LETTERIMG, fontid)

	Return ImageHeight(lh)
EndFunction

Function TLFText(txt$, x, y, spacing=0)
	fontid=UsingFont
	If fontid=-1 Then Return 0

	l = Len(txt$)
	For i=1 To l
		letter$ = Mid(txt$, i, 1)
		lw = TLFFont(Asc(letter$), LETTERWIDTH, fontid)+spacing
		DrawImage TLFFont(Asc(letter$), LETTERIMG, fontid), x, y
		x+lw
	Next i
EndFunction