TLFont System

Oletko tehnyt jotain, mistä muut voisivat hyötyä. Postita vinkit tänne.
Post Reply
User avatar
temu92
Web Developer
Web Developer
Posts: 1226
Joined: Mon Aug 27, 2007 9:56 pm
Location: Gamindustri
Contact:

TLFont System

Post by temu92 » Sun Oct 14, 2007 8:15 pm

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
The Ohje wrote: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
The Ohje wrote: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?
Last edited by temu92 on Sat May 01, 2010 1:32 pm, edited 2 times in total.

cheeshelmet.jr
Member
Posts: 75
Joined: Tue Aug 28, 2007 6:59 am

Re: TL Fontti Systeemi

Post by cheeshelmet.jr » Mon Oct 15, 2007 7:21 am

VAU :o Tää on ihan mahtava. KIITOS

User avatar
elmo123
Active Member
Posts: 153
Joined: Sun Sep 09, 2007 4:19 pm

Re: TL Fontti Systeemi

Post by elmo123 » Mon Oct 15, 2007 2:28 pm

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 :D teenpäs ohjelman jolla tehdään omia fontteja :lol:

Last edited by elmo123 on Sun Oct 21, 2007 2:09 pm, edited 1 time in total.
Kiinnostuin pelien tekemisestä ennen 1. luokkaa.
Sitten 3. luokalla tuli CB. Ja siitä se alkoi.

Blender! TF2! CB! Game Maker! Nokia-mollaus! Kitaransoitto! Breakdance! MadTracker! Minecraft!

User avatar
Marcoder
Active Member
Posts: 120
Joined: Tue Aug 28, 2007 8:21 am

Re: TL Fontti Systeemi

Post by Marcoder » Mon Oct 15, 2007 2:43 pm

elmo123 wrote: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

User avatar
vilQuri
Active Member
Posts: 239
Joined: Wed Aug 29, 2007 6:25 pm
Location: Turku

Re: TL Fontti Systeemi

Post by vilQuri » Wed Oct 17, 2007 3:04 pm

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

User avatar
Purple
Newcomer
Posts: 7
Joined: Thu Oct 25, 2007 1:01 pm
Location: Vaasa
Contact:

Re: TL Fontti Systeemi

Post by Purple » Thu Oct 25, 2007 9:30 pm

TOI ON MIELETÖN!!! 8-)
Työn alla :
- Yewi » Rpg peli. Valmis 2% ( Tuleekohan koskaan valmiiksi? :/ )
¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨
Purple

Post Reply