PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Drawing bitmap font on CanvasGadget

https://www.purebasic.fr/english/viewtopic.php?t=52160

Page 1 of 1

Drawing bitmap font on CanvasGadget

Posted: Wed Nov 21, 2012 10:30 am
by flaith
Hello everyone,

just want you to try the following program, I'm testing bitmap font with canvas
Right click to select and change the current font
Thanks for your return :)

DrawFontCanvas

Edit: You can change the size of the font

Here is all the fonts I'm using :
Apple II Font
Image
Apple II Font Out
Image
Minitel Font
Image
Terminal Font
Image
Ghost'n Goblins Font :
Image

And here is the code :

Code: Select all

;- Datasection
DataSection
  _DS_IMG_Font_APPLE:     IncludeBinary "Img_Spr\IMG_FONT_APPLE.png"
  _DS_IMG_Font_APPLE_Out: IncludeBinary "Img_Spr\IMG_FONT_APPLE_OUT.png"
  _DS_IMG_Font_MINITEL:   IncludeBinary "Img_Spr\IMG_FONT_MINITEL.png"
  _DS_IMG_Font_TERMINAL:  IncludeBinary "Img_Spr\IMG_FONT_TERMINAL.png"
  _DS_IMG_Font_GOBLINS:   IncludeBinary "Img_Spr\IMG_FONT_G&G.png"
EndDataSection

Enumeration 
  #MAIN_WIN
  #CANVAS
EndEnumeration

#SCREEN_Width        = 640
#SCREEN_Height       = 480
#NB_CHAR_BY_LINE     = 28                        ; 28 Char by Line inside Font Image

Structure CS_PIXEL
  Pixel.l                                         ; Fixed to 4 bits
EndStructure

Structure CS_FONT
  FontName.s
  CharWidth.i
  CharHeight.i
  Address.i
EndStructure

Global.i ActualSizeH = 0, ActualSizeW = 0, SpaceForDisable = 1, LastFontUsed = -1, LastNumFont = 0, ResizeMode = #PB_Image_Raw
Global.i TransparentColor, ImgFont
Global.i MaxCharByLine, MaxLine

Global.i ColorFontWhite, ColorFontBlack, ColorFontGrey, ColorFontRed, ColorFontGreen, ColorFontBlue, ColorFontNewRed, ColorFontYellow
Global.i PosX, PosY

Global.CS_FONT FontList

Procedure.i ConvertToAlpha(__ImageID.i, __TransparentColor.i)
  ; The '__TransparentColor' become Alpha
  Protected.i _BufferImg, _PitchImg, _PixelFormatImg
  Protected.i _X, _Y, _OnePixel
  Protected.i *Line.CS_PIXEL

  StartDrawing(ImageOutput(__ImageID))
    _BufferImg      = DrawingBuffer()
    _PitchImg       = DrawingBufferPitch()
;     _PixelFormatImg = DrawingBufferPixelFormat() - #PB_PixelFormat_ReversedY

    For _Y = 0 To ImageHeight(__ImageID) - 1
      *Line = _BufferImg + _PitchImg * _Y
      For _X = 0 To ImageWidth(__ImageID) - 1 
        _OnePixel = *Line\Pixel
        If _OnePixel = $FF000000 | __TransparentColor    ; Color to change ?
          *Line\Pixel = $00FFFFFF                        ; Convert to AlphaChannel
        EndIf
        *Line + 4                                        ; Next Pixel
      Next
    Next
  StopDrawing()
EndProcedure

Procedure SetImgColor(__Color.i)
  TransparentColor = __Color
EndProcedure

Procedure.i MakeFontColor(__Color.i)
  Protected.i _NewImgFont

  _NewImgFont = CreateImage(#PB_Any, ImageWidth(ImgFont), ImageHeight(ImgFont), 32)
  If _NewImgFont
    StartDrawing(ImageOutput(_NewImgFont))
      ; Draw a box for the char color
      Box(0,0,ImageWidth(ImgFont),ImageHeight(ImgFont), __Color)
      ; Drawing the font in Alpha mdoe
      DrawAlphaImage(ImageID(ImgFont), 0, 0, 255)
    StopDrawing()
    ;Convert the transparent color to an Alpha
    ConvertToAlpha(_NewImgFont, TransparentColor)
    ProcedureReturn _NewImgFont
  Else
    ProcedureReturn #False
  EndIf
EndProcedure

Procedure GenerateColorFont()
  If IsImage(ColorFontWhite)  : FreeImage(ColorFontWhite)  : EndIf
  If IsImage(ColorFontBlack)  : FreeImage(ColorFontBlack)  : EndIf
  If IsImage(ColorFontGrey)   : FreeImage(ColorFontGrey)   : EndIf
  If IsImage(ColorFontRed)    : FreeImage(ColorFontRed)    : EndIf
  If IsImage(ColorFontGreen)  : FreeImage(ColorFontGreen)  : EndIf
  If IsImage(ColorFontBlue)   : FreeImage(ColorFontBlue)   : EndIf
  If IsImage(ColorFontNewRed) : FreeImage(ColorFontNewRed) : EndIf
  If IsImage(ColorFontYellow) : FreeImage(ColorFontYellow) : EndIf
  ;                                   $BBGGRR
  ColorFontWhite      = MakeFontColor($FFFFFF)
  ColorFontBlack      = MakeFontColor($000000)
  ColorFontGrey       = MakeFontColor($99A8AC)
  ColorFontRed        = MakeFontColor($0000FF)
  ColorFontGreen      = MakeFontColor($00FF00)
  ColorFontBlue       = MakeFontColor($FF0000)
  ColorFontNewRed     = MakeFontColor($6600FF)
  ColorFontYellow     = MakeFontColor($00CCEE)  
EndProcedure

Procedure SetValueFont(__Name.s, __Width.i, __Height.i, __Address.i)
  FontList\FontName   = __Name
  FontList\CharWidth  = __Width
  FontList\CharHeight = __Height
  FontList\Address    = __Address
  ActualSizeW         = FontList\CharWidth
  ActualSizeH         = FontList\CharHeight

  If IsImage(ImgFont) : FreeImage(ImgFont) : EndIf
  ImgFont             = CatchImage(#PB_Any, FontList\Address)

  If ImgFont
    ConvertToAlpha(ImgFont, #White)
    SetImgColor($FF00FF)
    GenerateColorFont()
  Else
    MessageRequester("Error","Cannot create new image font for "+FontList\FontName)
    End
  EndIf
EndProcedure

Procedure SetFont(__Num.i)
  Select __Num
    Case 0
      SetValueFont("Apple", 6, 8, ?_DS_IMG_Font_APPLE)
    Case 1
      SetValueFont("Apple OUT", 7, 10, ?_DS_IMG_Font_APPLE_Out)
    Case 2
      SetValueFont("Minitel", 14, 17, ?_DS_IMG_Font_MINITEL)
    Case 3
      SetValueFont("Terminal", 12, 16, ?_DS_IMG_Font_TERMINAL)
    Case 4
      SetValueFont("Ghost & Goblins", 16, 16, ?_DS_IMG_Font_GOBLINS)
  EndSelect
  LastNumFont = __Num
EndProcedure

Procedure Init()
  UsePNGImageDecoder()
  SetFont(0)
EndProcedure

Procedure SetResizeMode(__Flag.i = #PB_Image_Raw)
  ResizeMode = __Flag
EndProcedure

Procedure ResizeFont(__Width.i = -1, __Height.i = -1)
  Protected.f _RatioH, _RatioW
  
  SetFont(LastNumFont)

  If __Width <> -1
    _RatioW   = __Width / FontList\CharWidth
  Else
    _RatioW   = 1                              ; cf below, multiply with the Height
  EndIf

  If __Height <> -1
    _RatioH   = __Height / FontList\CharHeight
  Else
    _RatioH   = _RatioW
  EndIf
  
  SpaceForDisable = _RatioW
  ActualSizeH     = FontList\CharHeight * _RatioH
  ActualSizeW     = FontList\CharWidth  * _RatioW
  SetWindowTitle(#MAIN_WIN, "FONT "+FontList\FontName+" / Size ("+Str(ActualSizeW)+"x"+Str(ActualSizeH)+")")
  ResizeImage(ImgFont, ImageWidth(ImgFont) * _RatioW, ImageHeight(ImgFont) * _RatioH, ResizeMode)

  MaxCharByLine = WindowWidth(#MAIN_WIN)/ActualSizeW
  MaxLine       = WindowHeight(#MAIN_WIN)/ActualSizeH

  GenerateColorFont()
EndProcedure

Procedure GS_TextGadget(__X.i,__Y.i,__Text.s, __FontID.i = -1)
  Protected.i _Len = Len(__Text)
  Protected.s _Char
  Protected.i _Ascii, _FontLine, _ClipX, _ClipY
  Protected.i _Index, _tmpImage
  
  If __FontID = 0
    MessageRequester("Error", "No ID for font "+FontList\FontName)
    End
  EndIf

  If __FontID = -1
    If LastFontUsed <> -1
      __FontID = LastFontUsed
    Else
      ;Error
      End
    EndIf
  EndIf

  For _Index = 1 To _Len
    _Char     = Mid(__Text, _Index, 1)
    _Ascii    = Asc(_Char) - 32
    _ClipX    = (_Ascii % #NB_CHAR_BY_LINE) * ActualSizeW
    _ClipY    = (_Ascii / #NB_CHAR_BY_LINE) * ActualSizeH
    _tmpImage = GrabImage(__FontID, #PB_Any, _ClipX, _ClipY, ActualSizeW, ActualSizeH)
    If _tmpImage : DrawAlphaImage(ImageID(_tmpImage), __X, __Y, 255) : FreeImage(_tmpImage) : EndIf
    __X + ActualSizeW
  Next
  LastFontUsed = __FontID
EndProcedure

Procedure Cls(__Canvas.i, __color.i)
  StartDrawing(CanvasOutput(__Canvas))
    Box(0,0,#SCREEN_Width,#SCREEN_Height, __color)
  StopDrawing()
EndProcedure

Procedure DrawMyFont(__Canvas.i)
  Protected.i _PosX = 0, _PosY = 0
  StartDrawing(CanvasOutput(__Canvas))
    GS_TextGadget(_PosX,_PosY, "Hello there !", ColorFontWhite)
    GS_TextGadget(_PosX+SpaceForDisable,_PosX+ActualSizeH+SpaceForDisable, "Open or Cancel", ColorFontWhite)
    GS_TextGadget(_PosX,_PosY+ActualSizeH, "Open or Cancel", ColorFontGrey)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*2, "Now i'm in red :)", ColorFontRed)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*3, "----**** Like the Green one ? ****----", ColorFontGreen)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*4, "Or the blue one is better, make your choice :D", ColorFontBlue)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*5, "----5----1----5----2----5----3----5----4----5----5----5----6----5----7----5----8----5----9--", ColorFontBlack)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*6, "         0         0         0         0         0         0         0         0         0")
    GS_TextGadget(_PosX,_PosY+ActualSizeH*8, "Once upon a time, a woman with big brown eyes knocked at my door...")
    GS_TextGadget(_PosX,_PosY+ActualSizeH*9, "She started to scream but stopped when she saw me",ColorFontWhite)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*10, "i was making my exercices and i was sweaty...")
    GS_TextGadget(_PosX,_PosY+ActualSizeH*15,"               TOP SCORE",ColorFontNewRed)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*15,"PLAYER #                        PLAYER $",ColorFontYellow)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*16,"10000        100,000,000               0",ColorFontWhite)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*20,"Maximum characters by line = "+Str(MaxCharByLine),ColorFontYellow)
    GS_TextGadget(_PosX,_PosY+ActualSizeH*21,"Maximum lines              = "+Str(MaxLine))
  StopDrawing()
EndProcedure

Procedure UpdateWindow()
  MaxCharByLine       = WindowWidth(#MAIN_WIN)/ActualSizeW
  MaxLine             = WindowHeight(#MAIN_WIN)/ActualSizeH
  SetWindowTitle(#MAIN_WIN, "FONT "+FontList\FontName+" / Size ("+Str(ActualSizeW)+"x"+Str(ActualSizeH)+")")
  Cls(#CANVAS, RGB(150, 100, 50))
  SetActiveGadget(#CANVAS)
EndProcedure

Procedure CheckEventCanvas(__CanvasGadget.i)
  DrawMyFont(__CanvasGadget)
  Select EventType()
    Case #PB_EventType_Input
      Debug Chr(GetGadgetAttribute(__CanvasGadget, #PB_Canvas_Input))
    Case #PB_EventType_RightClick
      DisplayPopupMenu(0, WindowID(#MAIN_WIN))
    Case #PB_EventType_KeyUp
      _key = GetGadgetAttribute(__CanvasGadget, #PB_Canvas_Key)
      If _key = #PB_Shortcut_Escape
        _Quit = 1
      EndIf
  EndSelect
EndProcedure

Procedure DisplayWindow()
  Protected.i _ValEvent

  If OpenWindow(#MAIN_WIN, 0, 0, #SCREEN_Width, #SCREEN_Height, "FONT "+FontList\FontName+" / Size ("+Str(ActualSizeW)+"x"+Str(ActualSizeH)+")", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_ScreenCentered)
    If CreatePopupMenu(0)
      OpenSubMenu("Change Font")
        MenuItem(1, "Apple")
        MenuItem(2, "Apple OUT")
        MenuItem(3, "Minitel")
        MenuItem(4, "Terminal")
        MenuItem(5, "Ghost & Goblins")
      CloseSubMenu()
      OpenSubMenu("Size")
        MenuItem(6, ">> Original size")
        MenuItem(7, "Size 6")
        MenuItem(8, "Size 7")
        MenuItem(9, "Size 8")
        MenuItem(10, "Size 9")
        MenuItem(11, "Size 10")
        MenuItem(12, "Size 11")
        MenuItem(13, "Size 12")
        MenuItem(14, "Size 13")
        MenuItem(15, "Size 14")
      CloseSubMenu()
      MenuBar()
      MenuItem(99, "Quit")
    EndIf
  
    CanvasGadget(#CANVAS, 0, 0, #SCREEN_Width, #SCREEN_Height, #PB_Canvas_Keyboard)

    MaxCharByLine       = WindowWidth(#MAIN_WIN)/ActualSizeW
    MaxLine             = WindowHeight(#MAIN_WIN)/ActualSizeH
  
    Cls(#CANVAS, RGB(150, 100, 50))
  
    SetActiveGadget(#CANVAS)
  
    Repeat
      Repeat
        _EventWindow = WaitWindowEvent()
        Select _EventWindow
          Case #PB_Event_CloseWindow
            _Quit = 1
          Case #PB_Event_Gadget
            If EventGadget() = #CANVAS
              CheckEventCanvas(#CANVAS)
            EndIf
          Case #PB_Event_Menu
            _ValEvent = EventMenu()
            Select _ValEvent
              Case 1
                SetFont(0) : UpdateWindow()
              Case 2
                SetFont(1) : UpdateWindow()
              Case 3
                SetFont(2) : UpdateWindow()
              Case 4
                SetFont(3) : UpdateWindow()
              Case 5
                SetFont(4) : UpdateWindow()
              Case 6
                ResizeFont(FontList\CharWidth, FontList\CharHeight) : Cls(#CANVAS, RGB(150, 100, 50))
              Case 7 To 15
                ResizeFont(_ValEvent-1) : Cls(#CANVAS, RGB(150, 100, 50))
              Case 99 : _Quit = 1
            EndSelect
        EndSelect
      Until _Quit
    Until _Quit
  EndIf
EndProcedure

;- ---- MAIN ----
Init()
DisplayWindow()

Re: Drawing bitmap font on CanvasGadget

Posted: Wed Nov 21, 2012 4:15 pm
by IdeasVacuum
Windows XP 32bit

Generally, all fonts and sizes look pretty good. On my screen (1280 x 1024 x 32), the Minitel font is the very best, Ghost & Goblins a bit too jagged though.

Re: Drawing bitmap font on CanvasGadget

Posted: Wed Nov 21, 2012 6:10 pm
by Demivec
Each font has problems with certain sizes where it the characters will be drawn incorrectly. The c's will have underlines for instance.

For example artifacts occur with:
Apple font at sizes 8, 11, 14.
Apple Outline: sizes 6, 11, 13.
Minitel: all sizes. (artifacts with periods at end of line and over x in exercices)
Terminal: sizes 8, 11, 13.
Ghost & Goblins: size 7. (l's in lower lines have outline overwrite font color).


@Edit: corrected a typo and listed some more fonts and sizes where problems occur.

Re: Drawing bitmap font on CanvasGadget

Posted: Wed Nov 21, 2012 6:14 pm
by eesau
Only the original font sizes look good, other sizes look either very jaggy or have artifacts.

Re: Drawing bitmap font on CanvasGadget

Posted: Wed Nov 21, 2012 6:17 pm
by netmaestro
Most of them look good here, but the Apple font seems to have some artifacts:
Image

Re: Drawing bitmap font on CanvasGadget

Posted: Wed Nov 21, 2012 7:21 pm
by flaith
Thanks a lot for your returns, I really appreciate :D
Indeed there is some artifacts, actually I'm using a raw resizeimage
I will post my "dirty" code soon :wink:

Re: Drawing bitmap font on CanvasGadget

Posted: Thu Nov 22, 2012 4:01 pm
by flaith
"Dirty" code put in the first post :wink:

Re: Drawing bitmap font on CanvasGadget

Posted: Thu Nov 22, 2012 6:20 pm
by Kwai chang caine
Hello FLAITH :D

Me, i found that nice 8)
That remember to me, the long night before the minitel, dead now :(
When i was looking for a woman with my numerous button on my face :mrgreen:

I knowing nothing in graphical...and even not know what is "artithing" :oops: :oops:

But i know make screenshot :wink:
I'm under VISTA PRO, 1440 x 900, if that can help you :D
http://erdsjb.free.fr/PureStorage/Provisoire/Flaith.zip

Re: Drawing bitmap font on CanvasGadget

Posted: Thu Nov 22, 2012 6:27 pm
by flaith
Thanks for the screenshots KCC :D
Actually it's just a test to make an editor for an assembler 6502/65C816 with the Apple Font in 40 or 80 columns
I want it to look like the assembler Merlin 8/16 for Apple II/IIGS :wink:
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited