Font8, Font14 and Font16 for FreeBASIC version >=0.24

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
D.J.Peters
Posts: 7852
Joined: May 28, 2005 3:28

Font8, Font14 and Font16 for FreeBASIC version >=0.24

Postby D.J.Peters » Jan 06, 2013 1:37

How FreeBASIC export the internal font8, font14 and font16 are changed.
Here are my old "play with font" for FreeBASIC >=0.24

Joshy

Code: Select all

type Font
  w as long
  h as long
  d as any ptr
end type

enum
  FB_FONT_8 = 0,
  FB_FONT_14
  FB_FONT_16
end enum

extern Fonts(2)  alias "__fb_font"  as Font

sub PrintXY3(byref f       as Font, _
             byval xpos    as integer, _
             byval ypos    as integer, _
             byref text    as string, _
             byval fgcol   as integer=&HFFFFFF, _
             byval bgcol   as integer=-1, _
             byval Size    as integer=1, _
             byval Filled  as integer=1, _
             byval Round   as integer=0 )

  dim as integer i,y,yend,l,code,x,bits,sx
  dim row as ubyte ptr
  l=len(text)-1:if l<0 then exit sub
  yend=f.h-1:if Size<1 then exit sub
  screeninfo sx
  screenlock
  for i = 0 to l
    code=text[i]:code*=f.h:row=f.d+code
    if Size>1 then
      if Filled=0 then
        for y = 0 to yend
          bits=*row
          for x=0 to 7
            if (bits and 1) then
              if Round=0 then
                line (xpos+x*size,ypos+y*size)-step(size,size),fgcol,b
              else
                circle (xpos+x*size+size*0.5,ypos+y*size+size*0.5),size*0.5,fgcol
              end if
            elseif bgcol<>-1 then
              if Round=0 then
                line (xpos+x*size,ypos+y*size)-step(size,size),bgcol,b
              else
                circle (xpos+x*size+size*0.5,ypos+y*size+size*0.5),size*0.5,bgcol
              end if
            end if
            bits=bits shr 1
          next
          row+=1
        next
        xpos+=f.w*Size::if (xpos-f.w*Size)>sx then screenunlock:exit sub
      else ' filled
        for y = 0 to yend
          bits=*row
          for x=0 to 7
            if (bits and 1) then
              if Round=0 then
                line (xpos+x*size,ypos+y*size)-step(size,size),fgcol,bf
              else
                circle (xpos+x*size+size*0.5,ypos+y*size+size*0.5),size*0.5,fgcol,,,,f
              end if
            elseif bgcol<>-1 then
              if Round=0 then
                line (xpos+x*size,ypos+y*size)-step(size,size),bgcol,bf
              else
                circle (xpos+x*size+size*0.5,ypos+y*size+size*0.5),size*0.5,bgcol,,,,f
              end if
            end if
            bits=bits shr 1
          next
          row+=1
        next
        xpos+=f.w*Size:if (xpos-f.w*Size)>sx then screenunlock:exit sub
      end if
    else 'no Size
      for y = 0 to yend
        bits=*row
        for x=0 to 7
          if (bits and 1) then
            pset (xpos+x,ypos+y),fgcol
          elseif bgcol<>-1 then
            pset (xpos+x,ypos+y),bgcol
          endif
          bits=bits shr 1
        next
        row+=1
      next
      xpos+=f.w:if (xpos-f.w)>sx then screenunlock:exit sub
    end if
  next
  screenunlock
end sub


dim as integer Size,y,x,filled,round,fgcol,bgcol,c
dim as double  w
'screen 19
screenres 640,480 ',32
y=0:cls
for Size=1 to 8
  x=0        :printxy3 Fonts(FB_FONT_14) ,x,y,"8x14 ",1 ,,Size
  x+=Size*8*4:printxy3 Fonts(FB_FONT_14) ,x,y,"8x14 ",2 ,,Size,0
  x+=Size*8*4:printxy3 Fonts(FB_FONT_14) ,x,y,"8x14 ",3 ,,Size,1,1
  x+=Size*8*4:printxy3 Fonts(FB_FONT_14) ,x,y,"8x14 ",4 ,,Size,0,1
  y+=Size*14
next
sleep 3000,1

y=0:cls
for Size=1 to 8
  x=0        :printxy3 Fonts(FB_FONT_14) ,x,y,"8x14 ",4 ,5,Size
  x+=Size*8*4:printxy3 Fonts(FB_FONT_14) ,x,y,"8x14 ",3 ,6,Size,0
  x+=Size*8*4:printxy3 Fonts(FB_FONT_14) ,x,y,"8x14 ",2 ,7,Size,1,1
  x+=Size*8*4:printxy3 Fonts(FB_FONT_14) ,x,y,"8x14 ",1 ,8,Size,0,1
  y+=Size*14
next
sleep 3000,1

do
  fgcol    = 1+rnd*254
  bgcol    = rnd*2 :if bgcol>1 then bgcol=1 +rnd *254 else bgcol=-1
  while fgcol=bgcol:fgcol= 1+rnd*254:wend
  for filled=1 to 0 step -1
    for round=0 to 1
      for w=-3.14 to 3.14 step 6.28/80
        size=cos(w)*32+33
        cls
        printxy3 Fonts(FB_FONT_8) ,0,0,"Play with font.",fgcol,bgcol,Size,filled,round
        printxy3 Fonts(FB_FONT_16),400,400,"Size=" & str(Size),7,,4,0
        sleep 50:if len(inkey) then exit do
      next
    next
  next
loop
Last edited by D.J.Peters on Apr 09, 2018 12:56, edited 1 time in total.
Roland Chastain
Posts: 851
Joined: Nov 24, 2011 19:49
Location: Dakar, Senegal
Contact:

Re: Font8, Font14 and Font16 for FreeBASIC version >=0.24

Postby Roland Chastain » Jan 06, 2013 11:07

Great ! I will use it. :)
FXG861
Posts: 86
Joined: Feb 01, 2009 17:10
Location: Canada
Contact:

Re: Font8, Font14 and Font16 for FreeBASIC version >=0.24

Postby FXG861 » Jan 07, 2013 16:44

Good Job !!!

Will be very usefull for future project

Thank you D.J. Peters
dodicat
Posts: 6022
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Font8, Font14 and Font16 for FreeBASIC version >=0.24

Postby dodicat » Jan 08, 2013 2:20

Screen 8 with font height set to 16 is about the best quality I've found.
Just leaving an extra pixel (9 instead of 8) between the characters seperates the blodgy ones.

Code: Select all


Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,textangle As Single=0,charangle As Single=0,im As Any Pointer=0)
    Type point2d
        As Single x,y
        As Uinteger col
    End Type
    Dim As Integer flag,codenum=256
    if instr(text,"|") then flag=1
    Static As Integer runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(128,codenum)
    If runflag=0 Then   '                  'scan codenum of codepage once
        Dim As Uinteger background=0
        screen 8
        width 640\8,200\16  'new setting to 8 by 16 pixels
        Dim count As Integer
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As Integer=1 To 8  'scan for characters
                For y As Integer=1 To 16
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
                    End If
                Next y
            Next x
            count=0
        Next ch
        runflag=1
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 128,codenum),np
    Dim As Single cr= 0.01745329 'degs to radians
    #macro rotate(p1,p2,a,d)
    np.col=p2.col
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #endmacro
   
    Dim As point2d cpt(1 To 128),c=Type<point2d>(xpos,ypos),c2
    Dim As Integer dx=xpos,dy=ypos
    For z6 As Integer=1 To Len(text)
        var asci=text[z6-1]
        If asci=124 Then
            if charangle<>0 then xpos=xpos+12*sin(charangle*cr)
            dx=xpos:dy=dy+16:Goto skip 'pipe | for new line
        End If
        For _x1 As Integer=1 To 128
            temp(_x1,asci).x=infoarray(_x1,asci).x+dx
            temp(_x1,asci).y=infoarray(_x1,asci).y+dy
            temp(_x1,asci).col=colour
            rotate(c,temp(_x1,asci),textangle,size)
            cpt(_x1)=np
            var copyy=np.y
            If charangle<>0 Then
              if flag then var p=1 else  p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr)))
                rotate(c2,cpt(_x1),charangle,1)
               if flag then np.y=copyy
                cpt(_x1)=np
            End If
            If infoarray(_x1,asci).x<>0 Then 'paint only relevant points
                If Abs(size)>1 Then
                    line(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+9+4*(sin(charangle*cr))*flag
        skip:
    Next z6
End Sub
Sub init Constructor 'automatic loader
    drawstring(0,0,"",0,0)
    Screen 0
End Sub

' ==================================== EXAMPLE ==================
screen 20

dim as string s
for x as integer=0 to 256
    if x mod 30=0 then s=s+"|" ''' note: | means a new line
  s=s+chr(x)
next x


drawstring(0,0,s,3,3.75)
drawstring 50,700,"press a key",7,2
sleep
color ,15
cls
dim as double a,k=.5
do
    a=a+k
    screenlock
    cls
drawstring 400,400,string(30,"_"),6,2,a
drawstring 400,400,s+"|"+string(30,"-"),6,2,a
drawstring 0,0,"Press <esc> to end",2,2
screenunlock
sleep 1,1
loop until (inkey)=chr(27)
sleep


 

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest