TLFont System

[temu92]

Oletko kyllästynyt siihen että CoolBasic-pelit tukee vain ja ainoastaan Windossin fonts kansiossa olevia fontteja? Nyt ei ole enää hätää. TLF System on saapunut markkinoille. Se on yksinkertainen rasterifontti systeemi joka mahdollistaa erilaisten fonttien käytön peleissäsi.
Vähän tuunaamalla vielä saat tehtyä omat fontit, mutta se jätetään kotitehtäväksi(?)

Koodia ei ole ihan kauheasti kommentoitu joten toivotaan että koodi itse selittäisi itsensä jos haluat saada sen toiminnasta jotain selkoa.

Tässä fontinkonvertoijan koodi. Tarvitsee alkuperäisen fontin fonts kansiossa

Funktiot
MakeTLFFont(uuden tiedoston nimi, kirjaimen ruudun leveys, kirjaimen ruudun korkeus, fontin nimi Fonts kansiossa, fontin koko [, paksu fontti, kursivoitu fontti, alleviivattu fontti])

Code: Select all

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

Ja itse fontti systeemi. Tämä ei enää tarvitse fonts kansion fontteja

Funktiot - käyttö
LoadTLFFont(.tlf fontin tiedostonimi[, R, G, B]) - Palauttaa uuden fontin ID numeron. Voit määrittää värin fontille latausvaiheessa
SetTLFFont(fontin ID numero) - Laittaa ladatun fontin käyttöön
TLFText(teksti, x, y[, kirjainten väli]) - Tulostaa tekstin annettuun paikkaan
TLFTextWidth(teksti[, kirjainten väli]) - Laskee annetun merkkijonon pituuden pikseleinä
TLFTextHeight(teksti) - Palauttaa annetun merkkijonon korkeuden pikseleinä

Code: Select all

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

Kommenttia plix0r?

[cheeshelmet.jr]

VAU Tää on ihan mahtava. KIITOS

[elmo123]

Voisin sanoa turhaksi, sillä jos laittaa pelin lataamaan vaikka LoadFont("Media\nasalization.TTF") niin minulla ainakin lataa sen pelin kansioista eikä Windowsin fonteista. Kun ei laita tuota "Media\"-osaa, niin CB lataa fontin oletuksellisesti Windows-kansiosta.

EDIT:

[quote=Marcoder]Eihän tuo fontti ole Windows-kansiossa)[/quote]
Juu, oli jäänyt sinne teenpäs ohjelman jolla tehdään omia fontteja

[Marcoder]

Voisin sanoa turhaksi, sillä jos laittaa pelin lataamaan vaikka LoadFont("Media\nasalization.TTF") niin minulla ainakin lataa sen pelin kansioista eikä Windowsin fonteista. Kun ei laita tuota "Media\"-osaa, niin CB lataa fontin oletuksellisesti Windows-kansiosta.

Oletkos varma ettei tuota fonttia ole asennettu windowsin fonttikansioon?
Esittämääsi tapaa on kokeiltu ja toimimattomaksi havaittu.
CB ei välitä tuosta polusta tuon taivaallista.
Esimerkiksi seuraava koodi toimii vaikka latauspolussa on "vähän" sanomista.

Code: Select all

f = LoadFont("media\huuhaa\jeejee\\\\impact.ttf", 30)
SetFont f
Repeat
    Text 10, 10, "Mikä fontti?"
    DrawScreen
Forever

[vilQuri]

Kiitti paljon !!! tätä tarviin uuteen peli projektiin

[Purple]

TOI ON MIELETÖN!!!