Custom FB Fonts

General discussion for topics related to the FreeBASIC project or its community.
Post Reply
dagmarsawayn
Posts: 1
Joined: Dec 23, 2021 15:06

Custom FB Fonts

Post by dagmarsawayn »

Has anyone created any custom fonts using the native Draw String font system? If so, would you be willing to share one for study and learning purposes?
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Custom FB Fonts

Post by dodicat »

I did this a few years ago

Code: Select all



'=============   FONTS SET UP ==========================

Function Filter(Byref tim As Ulong Pointer,_
    rad As Single,_
    destroy as long=1,_
    fade as long=0) As Ulong Pointer
   #define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
if fade<0 then fade=0:if fade>100 then fade=100
    Type p2
        As long x,y
        As Ulong col
    End Type
    #macro ppoint(_x,_y,colour)
    pixel=row+pitch*(_y)+4*(_x)
    (colour)=*pixel
    #endmacro
    #macro ppset(_x,_y,colour)
    pixel=row+pitch*(_y)+4*(_x)
    *pixel=(colour)
    #endmacro
    #macro average()
    ar=0:ag=0:ab=0:inc=0
    xmin=x:If xmin>rad Then xmin=rad
    xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
    ymin=y:If ymin>rad Then ymin=rad
    ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
    For y1 As long=-ymin To ymax
        For x1 As long=-xmin To xmax
            inc=inc+1
            ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
            ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
            ab=ab+(NewPoints(x+x1,y+y1).col And 255)
        Next x1
    Next y1
    if fade=0 then
    averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
    else
    averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
    end if
    #endmacro
    dim as single fd=map(0,100,fade,1,0)
    Dim As long _x,_y
    Imageinfo tim,_x,_y
    Dim  As Ulong Pointer im=Imagecreate(_x,_y)
    Dim As long pitch
    Dim  As Any Pointer row
    Dim As Ulong Pointer pixel
    Dim As Ulong col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As long=0 To (_y)-1
        For x As long=0 To (_x)-1
            ppoint(x,y,col)
            NewPoints(x,y)=type<p2>(x,y,col)
        Next x
    Next y
    Dim As Ulong averagecolour
    Dim As long ar,ag,ab
    Dim As long xmin,xmax,ymin,ymax,inc
    Imageinfo im,,,,pitch,row
    For y As long=0 To _y-1
        For x As long=0 To _x-1 
            average()
           ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
        Next x
    Next y
   if destroy then ImageDestroy tim: tim = 0
    Function= im
End Function
'basic dos fonts
Sub drawstring(xpos As long,ypos As long,text As String,colour As Ulong,size As Single,im As Any Pointer=0)
    Type D2
        As Double x,y
        As Ulong col
    End Type
    Static As d2 cpt(),XY()
    Static As long runflag
    If runflag=0 Then   
        Redim  XY(128,127)
        Redim cpt(1 To 64*2)
        screen 8
        width 640\8,200\16
        dim as ulong pointer img
        Dim count As long
        For ch As long=1 To 127
            img=imagecreate(640,200)
            Draw String img,(1,1),Chr(ch)
            For x As long=1 To 8 
                For y As long=1 To 16
                    If Point(x,y,img)<>0 Then
                        count=count+1
                        XY(count,ch)=Type<D2>(x,y)
                    End If
                Next y
            Next x
            count=0
            imagedestroy img
        Next ch
        runflag=1
    End If
    If size=0 Then Exit Sub
    Dim As D2 np,t
    #macro Scale(p1,p2,d)
    np.col=p2.col
    np.x=d*(p2.x-p1.x)+p1.x
    np.y=d*(p2.y-p1.y)+p1.y
    #endmacro
   
    Dim As D2 c=Type<D2>(xpos,ypos)
    Dim As long dx=xpos,dy=ypos
    For z6 As long=1 To Len(text)
        Var asci=text[z6-1]
        For _x1 As long=1 To 64*2
            t=Type<D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)         
            Scale(c,t,size)
            cpt(_x1)=np
           
            If XY(_x1,asci).x<>0 Then
                If Abs(size)>1 Then
                    Line im,(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
                Else
                    Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
                End If
            End If
        Next _x1
        dx=dx+8
    Next z6
End Sub

Sub initfont Constructor 'automatic loader
    drawstring(0,0,"",0,0)
    SCREEN 0, , , &h80000000
End Sub

function Colour(im as any pointer,newcol as ulong,tweak as long,fontsize as long) as any pointer
    #macro ppset2(_x,_y,colour)
    pixel2=row2+pitch2*(_y)+(_x)*dpp2
    *pixel2=(colour)
    #endmacro
    #macro ppoint(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*dpp
    (colour)=*pixel
    #endmacro
    dim as long grade
    select case as const fontsize
    case 1:grade=200
    case 2:grade=225
    case 3:grade=200
    case 4:grade=190
    case 5:grade=165
    case else: grade=160
    end select
    dim as long w,h
    Dim As long pitch,pitch2
    Dim  As Any Pointer row,row2
    Dim As Ulong Pointer pixel,pixel2
    Dim As Ulong col
    dim as long dpp,dpp2
    Imageinfo im,w,h,dpp,pitch,row
    dim as any pointer temp
    temp=imagecreate(w,h)
    Imageinfo temp,,,dpp2,pitch2,row2
    for y as long=0 to h-1
        for x as long=0 to w-1
            ppoint(x,y,col)
         Var v=.299*((col Shr 16)And 255)+.587*((col Shr 8)And 255)+.114*(col And 255)
         if v>(grade+tweak) then
       ppset2(x,y,newcol)
       else
       ppset2(x,y,rgb(255,0,255))
      end if
        next x
    next y
    return temp
end function

sub CreateFont(byref myfont as any pointer,fontsize as long,col as ulong,tweak as long=0)
Const FIRSTCHAR =32,LASTCHAR=127
Const NUMCHARS=(LASTCHAR-FIRSTCHAR)+1
Dim As ubyte Ptr p
dim as any pointer temp
Dim As long i
temp = ImageCreate(NUMCHARS*8*FontSize,16*FontSize,rgb(255,0,255))
myfont=ImageCreate(NUMCHARS*8*FontSize,16*FontSize,rgb(255,0,255))

For i = FIRSTCHAR To LASTCHAR
    drawstring ((i - FIRSTCHAR) * 8*FontSize, 1,chr(i),rgb(255,255,255),FontSize,temp)
Next i
if fontsize<=0 then fontsize=1
if fontsize>1 then
for n as long=0 to fontsize-2
    temp=filter(temp,1,1,0)
next n
end if

temp=Colour(temp,col,tweak,fontsize)
put myfont,(0,0),temp,trans
ImageInfo( myfont,,,,, p )
p[0]=0
p[1]=FIRSTCHAR
p[2]=LASTCHAR
For i = FIRSTCHAR To LASTCHAR
    p[3+i-FIRSTCHAR]=8*FontSize
next i
imagedestroy(temp)
end sub
'=================== END FONT SETUP  ========================================
'======================================================================


Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function





screen 20,32  'must be 32 bit graohics
color ,rgb(255,100,0)
cls
dim as any pointer font,frame,fin
CreateFont font,4,rgb(0,100,0),0
CreateFont frame,3,rgb(0,100,255),0
CreateFont fin,1,rgb(255,255,255),0
do
screenlock
cls
draw string(200,200),"Timer = " &timer,,font
draw string(30,300),"Framerate = "&framecounter,,frame
draw string(30,500),"Press <esc> to end . . .",,fin

screenunlock
sleep 1
loop until inkey=chr(27)

sleep
 
For Linux I think line 135 should maybe be screen 0 only
RockTheSchock
Posts: 252
Joined: Mar 12, 2006 16:25

Re: Custom FB Fonts

Post by RockTheSchock »

Post Reply