A bigger font

[D.J.Peters]

@Jawade from section tips and tricks

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 long=&HFFFFFF, _
             byval bgcol   as long=-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,c
dim as long fgcol,bgcol
dim as double  w
'screen 19
screenres 640,480,,2
screenset 1,0
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
flip:sleep 2000,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
flip:sleep 2000,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
        flip : sleep 50 : if len(inkey) then exit do
      next
    next
  next
loop

[dodicat]

I tried to dress up the codepage (dos) fonts a while ago.
I have changed things to suit the 64 bit compiler.

But you can't make a silk purse out of a sow's ear, or so they say.

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 Integer _x,_y
    Imageinfo tim,_x,_y
    Dim  As Ulong Pointer im=Imagecreate(_x,_y)
    Dim As integer 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 init Constructor 'automatic loader
    drawstring(0,0,"",0,0)
    Screen 0
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 integer w,h
    Dim As integer pitch,pitch2
    Dim  As Any Pointer row,row2
    Dim As Ulong Pointer pixel,pixel2
    Dim As Ulong col
    dim as integer 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  ========================================
'======================================================================


'keep track of framerate
Function framecounter() As long
    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

'===========  USAGE ========================
screen 20,32  'must be 32 bit graohics
color ,rgb(0,0,100)

'set up five different fonts
dim as any pointer fontsize1
dim as any pointer fontsize2
dim as any pointer fontsize3
dim as any pointer fontsize4
dim as any pointer fontsize5

'tweak can be used to alter the fonts a bit
dim as long tweak=0
'set size and colour
CreateFont fontsize1,1,rgb(200,0,0),tweak
CreateFont fontsize2,2,rgb(200,200,0),tweak
CreateFont fontsize3,3,rgb(200,200,200),tweak
CreateFont fontsize4,4,rgb(0,200,200) ' -"-
CreateFont fontsize5,5,rgb(200,100,0) ' -"-

do
    screenlock
    cls
    draw string(10,20),"Normal Draw String"
    draw string(10,50),"Font Size one",,fontsize1
    draw string(10,100),"Font Size two",,fontsize2
    draw string(10,200),"Font Size three",,fontsize3
    draw string(10,300),"Font Size four",,fontsize4
    draw string(10,400),"Font Size five",,fontsize5
    draw string(10,500),"System timer: " &timer,,fontsize3
    draw string(500,100),"Frames per second = " & framecounter,,fontsize2
    draw string(0,600),"ABCDEFGHIJKLMNOPQRSTUVWXYZ->size 3",,fontsize3
    draw string(0,650),"abcdefghijklmnopqrstuvwxyz->size 3",,fontsize3
    screenunlock
    sleep 1,1
    loop until len(inkey)

sleep
  

[BasicCoder2]

Joshy,
Replaced my example with your version.
I also used multiput to speed things up

Code: Select all

#include "multiput.bi"

screenres 1280,480,32

sub printText(x as integer, y as integer, txt as string, fg as ulong, bg as ulong,mag as integer)
  if screenptr()=0 then return ' no screen
  var n = len(txt) : if n<1 then return ' no chars
  n shl=3 ' nPixels = nChars * fontwidth
  var img = imagecreate(n,8,bg)
  if img = 0 then return
  draw string img,(0,0),txt,fg
   ' MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],angle,[Trans]
    multiput 0,x, y,img,mag,mag,0.0,1
  imagedestroy img
end sub

cls
'printText (integer, integer, string, ulong, ulong, integer)
'printText (x,y,string,foreground color, background color, magnification of 8x8 character)
for i as integer = 1 to 8
    cls
    printText ( 640,240,chr(3) & " hello world " & chr(3),rgb(255,0,0),rgb(0,255,0),i)
    locate 2,2
    print "mag  = ";i
    print " TAP SPACE BAR"
    sleep
next i

cls
print "DONE"
sleep

[sancho3]

@D.J.Peters: Very cool. Here is the link to the Tip/Trick you posted.

@Dodicat:
The lack of kerning on fixed width fonts really shows at larger heights. In size 5, the f and the ive look nearly a full space apart and the v and the e look nearly adjacent.
It fine for playing around but if you want something dressy you are forced into custom fonts with draw string. And 1 for each color you intend to use.

I am relatively new to FB considering its age, but I find it hard to believe the active developers and users of the early days were satisfied with this.
At this time however, the point is moot.

[D.J.Peters]

Why not using FBTrueType ?
viewtopic.php?f=14&t=25083

Joshy

[dodicat]

Here are some windows fonts.
The drawfont sub is partially by mysoft.
Win 10 has them, lesser Wins might not have all of them.

Code: Select all

#include "windows.bi"
#include "fbgfx.bi"
'freeconsole
Dim As String p( 1 To ...)={ _
"Times New Roman", _
"cambria", _
"caladea", _
"calibri", _
"Comic Sans MS", _
"candara", _
"Courier New", _
"carlito", _
"Arial", _
"Vivaldi", _
"consolas", _
"constantia", _
"corbel",_
"courier", _
"dejavu sans", _
"dejavu serif", _
"fixedsys",_
"franklin gothic", _
"gabriola", _
"gentium basic", _
"georgia", _
"impact", _
"liberation mono", _
"liberation sans", _
"liberation serif", _
"linux biolinum G", _
"linux libertine G", _
"lucida console", _
"lucida sans unicode", _
"microsoft sans serif", _
"modern", _
"ms sans serif", _
"ms serif", _
"open sans", _
"opensymbol", _
"palatino linotype", _
"pt serif", _
"roman", _
"segoe MDL2 assets", _
"segoe print", _
"segoe script", _
"sitka heading", _
"sitka small", _
"small fonts", _
"source code pro", _
"source sans pro", _
"symbol",_
"system", _
"tahoma", _
"terminal", _
"trebuchet MS", _
"verdana", _
"gadugi", _
"wingdings"}
'convert to lcase
for n as long=lbound(p) to ubound(p)
    p(n)=lcase(p(n))
    next n
'sort to alphabetical order
For n As Long=Lbound(p) To Ubound(p)-1
    For m As Long=n+1 To Ubound(p)
        If p(m)<p(n) Then Swap p(n),p(m)
    Next
Next
'write font types to console
for n as long=lbound(p) to ubound(p)
    print n, p(n)
    next n

Dim As Ulong clr(Lbound(p) To Ubound(p))
Randomize 1
'colour each font
For n As long=Lbound(p) To Ubound(p)
    clr(n)=Rgb(50+Rnd*200,50+Rnd*200,50+Rnd*200)
Next n
'Fonts -- concise from Mysoft's code
Const FS_BOLD = 2
Const FS_ITALIC = 4 

Sub DrawFont(Byref BUFFER As Any Ptr=0,Byval POSX As Long, Byval POSY As Long, _
    Byref FTEXT As String, Byref FNAME As String,Byval FSIZE As Long, _
    Byval FCOLOR As Ulong=Rgb(255,255,255),Byval FSTYLE As Long=0,Byval CHARSET As Long=DEFAULT_CHARSET )
    
    Static FINIT As Long
    Static As hdc THEDC
    Static As hbitmap THEBMP
    Static As Any Ptr THEPTR
    Static As fb.image Ptr FBBLK
    Static As Long TXTSZ,RESU,RESUU
    Static As hfont THEFONT
    Static As Long FW,FI,TXYY
    Static DSKWND As hwnd, DSKDC As hdc
    Static MYBMPINFO As BITMAPINFO
    Static As TEXTMETRIC MYTXINFO
    Static As SIZE TXTSIZE
    Static As RECT RCT
    Static As Ubyte Ptr ubp
    ubp=Cptr(Ubyte Ptr,@FCOLOR)
    Swap ubp[0],ubp[2]
    Dim As Ubyte alphaval =ubp[3]
    ubp[3]=0
    #define FontSize(PointSize) -MulDiv(PointSize, GetDeviceCaps(THEDC, LOGPIXELSY), 72) 
    
    If FINIT = 0 Then   
        FINIT = 1   
        With MYBMPINFO.bmiheader
            .biSize = Sizeof(BITMAPINFOHEADER)
            .biWidth = 2048
            .biHeight = -513
            .biPlanes = 1
            .biBitCount = 32
            .biCompression = BI_RGB
        End With   
        DSKWND = GetDesktopWindow()
        DSKDC = GetDC(DSKWND)
        THEDC = CreateCompatibleDC(DSKDC)
        THEBMP = CreateDIBSection(THEDC,@MYBMPINFO,DIB_RGB_COLORS,@THEPTR,null,null)  
        ReleaseDC(DSKWND,DSKDC)   
    End If
    If (FSTYLE And FS_BOLD) Then FW = FW_BOLD Else FW = FW_NORMAL   
    If (FSTYLE And FS_ITALIC) Then FI = True Else FI = False   
    THEFONT = CreateFont(FontSize(FSIZE),0,0,0,FW,FI,0,0,CHARSET,0,0,0,0,Cast(Any Ptr,Strptr(FNAME)))   
    SelectObject(THEDC,THEBMP)
    SelectObject(THEDC,THEFONT)
    GetTextMetrics(THEDC,@MYTXINFO)
    GetTextExtentPoint32(THEDC,Strptr(FTEXT),Len(FTEXT),@TXTSIZE) 
    TXTSZ = TXTSIZE.CX
    TXYY = TXTSIZE.CY
    If (FSTYLE And FS_ITALIC) Then
        If MYTXINFO.tmOverhang Then
            TXTSZ += MYTXINFO.tmOverhang
        Else
            TXTSZ += 1+(FSIZE/2)
        End If
        TXYY += 1+(FSIZE/8)
    End If
    RCT.LEFT = 0
    RCT.TOP = 1
    RCT.RIGHT = TXTSZ
    RCT.BOTTOM = TXYY+1
    TXTSZ -= 1
    TXYY -= 1
    SetBkColor(THEDC,Rgba(255,0,255,0))
    SetTextColor(THEDC,FCOLOR)
    SystemParametersInfo(SPI_GETFONTSMOOTHING,null,@RESU,null)
    If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,False,@RESUU,null)
    ExtTextOut(THEDC,0,1,ETO_CLIPPED Or ETO_OPAQUE,@RCT,Strptr(FTEXT),Len(FTEXT),null)
    If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,True,@RESUU,null)
    FBBLK = THEPTR+(2048*4)-Sizeof(fb.image)
    FBBLK->Type = 7
    FBBLK->bpp = 4
    FBBLK->Width = 2048
    FBBLK->height = 512
    FBBLK->pitch = 2048*4
    Put BUFFER,(POSX,POSY),FBBLK,(0,0)-(TXTSZ-1,TXYY),Alpha,alphaval
    DeleteObject(THEFONT)
End Sub

#define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)

Type box
    As Double x,y,w,h
    As Ulong col
    as string * 1 symbol
    Declare Function inbox(As long,As long) As long
    Declare Sub Draw()
End Type


Function box.inbox(x As long,y As long) As long
    If x>this.x And x<this.x+this.w Then
        If y>this.y And y<this.y+this.h Then
            Return -1
        End If
    End If
End Function

Sub box.draw()
    Line(this.x,this.y)-(this.x+this.w,this.y+this.h),this.col,bf
    if asc(this.symbol)<>0 then
        ..draw string (x+w/2-4,y+h/2-4),this.symbol,0
        end if
End Sub

Dim As box b(1 To 5)
b(1)=Type<box>(780+50,20,20,560,Rgb(240,240,240))'scrollbars-vertical
b(2)=Type<box>(780+50,0,20,20,Rgb(218,218,218),chr(30))
b(3)=Type<box>(780+50,580,20,20,Rgb(218,218,218),chr(31))
b(4)=Type<box>(780+50,20,20,20,Rgb(166,166,166))
b(5)=Type<box>(0,0,800,600,0)'whole screen

Dim As box h(1 To 4)
h(1)=Type<box>(20,580,780,20,Rgb(240,240,240))'scrollbars-horizontal
h(2)=Type<box>(0,580,20,20,Rgb(218,218,218),chr(17))
h(3)=Type<box>(800,580,20,20,Rgb(218,218,218),chr(16))
h(4)=Type<box>(20,580,20,20,Rgb(166,166,166))


Dim As box toggle(1 To 6)
toggle(1)=Type<box>(650,0,40,20,Rgb(0,200,0))'option boxes
toggle(2)=Type<box>(690,0,40,20,Rgb(0,0,200))
toggle(3)=Type<box>(730,0,40,20,Rgb(200,0,200))
toggle(4)=Type<box>(610,0,40,20,Rgb(200,200,200))
toggle(5)=Type<box>(570,0,40,20,Rgb(0,200,200))
toggle(6)=Type<box>(530,0,40,20,Rgb(200,200,0))
#macro show(style,sz)
Screenlock
Cls
#macro showboxes()
'box titles (written below boxes)
Draw String(650,30),"norm"
Draw String(690,30),"bold"
Draw String(730,30),"italic"
Draw String(615,30)," B+I"
Draw String(560,30)," Ucase "
Draw String(520,30),"Lcase"

'draw the click boxes
For n As long=1 To 6
    toggle(n).draw()
Next n
#endmacro
'write the fonts out
For z As long=1 To Ubound(p)
    ypos=48*z-1*w
    If ypos>-50 And ypos<600 Then
        If sz=1 Then
            DrawFont(,dx,ypos+10,Ucase(p(z)+txt),p(z),30,clr(z),style)
        Else
            DrawFont(,dx,ypos+10,Lcase(p(z)+txt),p(z),30,clr(z),style)
        End If
    End If
Next z
showboxes()
'draw the scrollbars
For n As long=1 To Ubound(b)-1
    b(n).draw()
    h(n).draw
Next n
Screenunlock
#endmacro

Dim As long Number=Ubound(p)+1,flag,msg,cse
Screenres 850,600,32

Dim As String txt="  ",cs=" Lowercase",Wmsg="Normal"
For n As long=28 To 96 '96 gets most characters
    txt+=Chr(n)
Next n
Dim As long x,y,mb,ypos,wheel,lastwheel,dx=20,limit=-25*60 'horizontal txt length
Dim As Double w,lastw
Dim As long fps,sleeptime
Windowtitle string(50," ")+wmsg +cs
Do
    Getmouse x,y,wheel,mb
    If b(5).inbox(x,y) Then 
        w=w+10*(lastwheel-wheel)
        lastwheel=wheel
    End If
    If w<0 Then w=lastw
    If w>38*Number Then w=38*Number
    b(4).y=map(0,38*number,w,21,550)
    lastw=w
    For n As long=1 To Ubound(b)-1
        If b(n).inbox(x,y)And mb=1 Then
            
            Select Case  n
            Case 3:w=w+10:b(4).y=map(0,38*Number,w,20+1,560-1)
            Case 2:w=w-10:b(4).y=map(0,38*Number,w,20+1,560-1)
            Case 1 
                If y<560 Then 
                    b(4).y=y
                    w=map(20+1,560-1,b(4).y,0,38*Number)
                End If
            End Select
        End If
    Next n
    
    For n As long=1 To 3
        If h(n).inbox(x,y)And mb=1 Then
            Select Case  n
            Case 3:dx=dx-10:h(4).x=map(21,limit,dx,21,779):If dx<Limit Then dx=Limit
            Case 2:dx=dx+10:h(4).x=map(21,limit,dx,21,779):If dx>21 Then dx=21
            Case 1 
                If y>20 Then 
                    h(4).x=x
                    dx=map(21,779,x,21,limit)
                    
                End If
            End Select
        End If
    Next n
    If mb=1 Then Windowtitle string(50," ")+wmsg+cs
    For n As long=1 To 6
        If toggle(n).inbox(x,y) And flag=0 Then
            If mb Then
                flag=1
                Select Case n
                Case 1:msg=0:wmsg="Normal"
                Case 2:msg=2:wmsg="Bold"
                Case 3:msg=4:wmsg="Italic"
                Case 4:msg=2 Or 4:wmsg="Bold Italic"
                Case 5:cse=1:cs=" Uppercase"
                Case 6:cse=0:cs=" Lowercase"
                End Select
            End If
        End If
    Next n
    show(msg,cse)
    flag=mb
    Sleep 1,1
Loop Until Len(Inkey)


  

[dodicat]

Sancho3
The custom draw string fonts I posted earlier are only expansions of the dos fonts.
Any spacings e.t.c. are determined by the system code page, and not by me.
Use the mouse here to magnify the pixels in draw string and draw string custom.

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 Integer _x,_y
    Imageinfo tim,_x,_y
    Dim  As Ulong Pointer im=Imagecreate(_x,_y)
    Dim As integer 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,0),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 init Constructor 'automatic loader
    drawstring(0,0,"",0,0)
    Screen 0
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 integer w,h
    Dim As integer pitch,pitch2
    Dim  As Any Pointer row,row2
    Dim As Ulong Pointer pixel,pixel2
    Dim As Ulong col
    dim as integer 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  ========================================
'======================================================================


'keep track of framerate
Function framecounter() As long
    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

Sub Magnify()
    #define resetwheel(w,fl) fl=w
    #define wheel(w,f) w-f
    Dim As Integer mx,my,mw,button:Getmouse mx,my,mw,button
    Static As Integer flag,pmw
    mw=(mw/2)
   If button=4 Then  resetwheel(mw,flag)
    Dim As Uinteger array(1 To 6561),count
    pmw=wheel(mw,flag)
    if pmw<=1 then exit sub
    For z As Integer=1 To 2
        For x As Integer=mx-40 To mx+40
            For y As Integer=my-40 To my+40
                count+=1
                If z=1 Then array(count)=Point(x,y)
                If z=2 Then
                    var NewX=pmw*(x-mx)+mx:var NewY=pmw*(y-my)+my
                    line(newx-pmw/2,newy-pmw/2)-(newx+pmw/2,newy+pmw/2),array(count),bf
                End If
            Next y
        Next x
        count=0
    Next z
    Line(mx-pmw*40,my-pmw*40)-(mx+pmw*40,my+pmw*40),5,B
End Sub

'===========  USAGE ========================
screen 20,32  'must be 32 bit graohics
color ,rgb(0,0,100)

'set up five different fonts
dim as any pointer fontsize1,fontsize2


'tweak can be used to alter the fonts a bit
dim as long tweak=0
'set size and colour
CreateFont fontsize1,1,rgb(255,255,255),tweak
CreateFont fontsize2,2,rgb(255,255,255),tweak
dim as string s="abcdefghijklmnopqrstuvwxyz0123456789"
s+=ucase(s)
do
    screenlock
    cls
    draw string(10,200),s+" draw string raw"  ,rgb(255,255,255)
    draw string(10,220),s+" draw string custom",,fontsize1
    draw string(10,320),"FPS  "&framecounter,,fontsize2
    magnify()
    screenunlock
    sleep 1,1
    loop until len(inkey)

sleep
   

[bluatigro]

this may be useful :

warning :
the char's are 8 high in fulscreen
in screen 20 16 pixel's

Code: Select all

'' bluatigro 12 sept 2018
'' automatic big text

dim shared as integer letterpart( 255 , 8 ) 
dim as integer char , ix , iy

#include "fbgfx.bi"
#if __FB_LANG__ = "fb"
  Using FB '' Scan code constants are stored in the FB namespace in lang FB
#endif

DIM shared AS INTEGER winx, winy, bitdepth , nu
SCREENINFO winx , winy , bitdepth
SCREENRES winx , winy , 32 , 2 , FB.GFX_FULLSCREEN

for char = 0 to 255
  cls
  print chr( char )
  for ix = 0 to 8
    for iy = 0 to 8
      if point( ix , iy ) <> -16777216 then
        letterpart( char , iy ) += 2 ^ ix
      end if
    next iy
  next ix
next char

sub digit( a as double , b as double _
  , q as double , d as double  , kl as ulong )
  dim as double x , y
  for x = 0 to 8
    for y = 0 to 8
      if letterpart( q , y ) and 2 ^ x then 
        circle( a + ( x - 4 ) * d , b + ( y - 4 ) * d ) _
        , d / 2 , kl ,,,, f
      end if
    next y
  next x
end sub

sub text( a as double , b as double , txt as zstring _
  , d as double , kl as ulong )
  dim as double l = len( txt ) , x
  for x = 1 to l
    digit a + ( x - l / 2 - 1 ) * d * 8 , b _
    , asc( mid( txt , x , 1 ) ) , d , kl
  next x
end sub

sub digit2( a as double , b as double _
  , q as double , dx as double  , dy as double , kl as ulong )
  dim as double x , y
  for x = 0 to 8
    for y = 0 to 8
      if letterpart( q , y ) and 2 ^ x then 
        circle( a + ( x - 4 ) * dx , b + ( y - 4 ) * dy ) _
        , dx / 2 , kl ,,,dy/dx, f
      end if
    next y
  next x
end sub

sub text2( a as double , b as double , txt as zstring _
  , dx as double , dy as double , kl as ulong )
  dim as double l = len( txt ) , x
  for x = 1 to l
    digit2 a + ( x - l / 2 - 1 ) * x * 8 , b _
    , asc( mid( txt , x , 1 ) ) , dx , dy , kl
  next x
end sub

[Jawade]

He is beautiful, but one thing: he is not fast,