Pure BitmapFont

Advanced game related topics
Papala
User
User
Posts: 38
Joined: Wed Sep 12, 2012 5:09 pm

Pure BitmapFont

Post by Papala »

Hey, here is a bitmapfont module, not realy over yet but already usable and his BitmapFont generator.
Their's 2 way of display some text :
Direct display of a raw text (not effect allowed)
Or with the box system. Create a box then add it some text, somme effect like shaking wave, blink or color blink can be add with tag in you string like "bla bla bla ${shake} BLAAAAA {\} bla bla".
I don't know if that's realy optimised... But well I think i did my best.
Here a preview :
Image

And the code :
The generator named : "Awesome bitmapFont Generator" (Hell yeah !)

Code: Select all

EnableExplicit

UsePNGImageEncoder()
UseLZMAPacker()

Enumeration
  #Str_Char
  #Btn_Font
  #Btn_Generate
  #Btn_Refresh
  #Btn_Load
  #Txt_Font
  #Cnv_Sample
  ;------------------Setting window----------
  #Cmb_Font
  #Chk_Bold
  #Chk_Italic
  #Chk_StrikeOut
  #Chk_Shadow
  #Btn_Color
  #Btn_ShadowColor
  #Btn_BackgroundColor
  #Str_Alpha
  #Str_OffsetX
  #Str_OffsetY
  #Str_Size
  #Str_MargeUp
  #Str_MargeDown
  #Str_MargeLeft
  #Str_MargeRight
  #Lst_Size
  #Cnv_Preview
EndEnumeration
Enumeration
  #Window_Main
  #Window_Font
EndEnumeration

Structure Font
  Name.s
  Size.c
  Shadow.a
  ShadowX.a
  ShadowY.a
  Color.i
  ShadowColor.i
  BackGroundColor.i
  FntAlpha.a
  ShadowAlpha.a
  String.s
  Height.c
  Width.c
  Flag.i
  MargeUp.C
  MargeDown.c
  MargeLeft.c
  MargeRight.c
  MaxValue.c
EndStructure

Structure Char
  X.i
  Y.i
  Width.i
  Height.i
EndStructure

Structure CFP_FONTDATA
   Type.b
   Symbol.b
   Name.s
EndStructure

Structure CFP_USERDATA
   himlFontType.i
   FontSize.b
   hwndParent.i
 EndStructure
 
Declare OpenMainWindow()
Declare OpenFontWindow()
Declare RefreshSample()
Declare GenerateFont()
Declare Loadfnt()
Declare Close()
Declare ChangeSize()
Declare ChangeColor()
Declare Style()
Declare Shadow()
Declare ShadowAlpha()
Declare Offset()
Declare Marging()
Declare RefreshPreview()
Declare Load()
;----------------CFP fonctions declaration---------------------------
Declare CFP_CreateGagdet(Gadget,X,Y,Width,Height,ItemHeight=20,FontSize=11)
Declare.s CFP_GetGadgetText(Gadget,Item)
Declare CFP_FreeGadget(Gadget)
Declare CFP_EnumFonts(Gadget)
Declare CFP_EnumProc(*lpelfe.ENUMLOGFONTEX,*lpntme.NEWTEXTMETRICEX,FontType,lParam)
Declare CFP_WndProc(hWnd,uMsg,wParam,lParam)
Declare CFP_Change()

Global Font.font, FntList.LOGFONT
Global NewList ftd.CFP_FONTDATA()

With Font
  \Name = "Arial"
  \String = "!"+Chr(34)+"# $%&'()*+,-./0123456789:;<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюяЄІЇЎҐєіїўґÄäÀàÂâÁáÃãÅåÆæÈèÊêÉéÇçĞğÎîÍíİıÑñÖöÒòÔôÓóÕõŒœØøŞşÜüÙùÛûÚúŸÿ¿¡ßŐőŰű"
  \Size = 72
  \Shadow = 0
  \ShadowX = 5
  \ShadowY = 5
  \ShadowAlpha = 128
  \Color = RGBA(255,255,255,255)
  \ShadowColor = RGBA(0,0,0,128)
  \BackGroundColor = RGB(204,204,204)
  \FntAlpha = 255
EndWith

OpenMainWindow()
Repeat : WaitWindowEvent() : ForEver
Procedure OpenMainWindow()
  If OpenWindow(#Window_Main,0,0,1200,768,"Awesome bitmapFont Generator",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
    StringGadget(#Str_Char,10,10,1100,50,Font\String)
    ButtonGadget(#Btn_Refresh,1130,10,60,20,"Refresh")
    ButtonGadget(#Btn_Font,10,80,40,20,"Font")
    ButtonGadget(#Btn_Load,650,80,60,20,"Load")
    TextGadget(#Txt_Font,60,80,500,20,Font\Name+","+Font\Size,#PB_Text_Border)
    CanvasGadget(#Cnv_Sample,10,110,1180,628)
    ButtonGadget(#Btn_Generate,580,80,60,20,"Save")
    BindEvent(#PB_Event_CloseWindow,@Close())
    BindGadgetEvent(#Btn_Font,@OpenFontWindow())
    BindGadgetEvent(#Btn_Refresh,@RefreshSample())
    BindGadgetEvent(#Btn_Generate,@GenerateFont())
    BindGadgetEvent(#Btn_Load,@Load())
    RefreshSample()
  EndIf
EndProcedure

Procedure OpenFontWindow()
  Protected FontLoop
  If OpenWindow(#Window_Font,0,0,800,400,"Configure font",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
    TextGadget(#PB_Any,10,10,100,20,"Font :")
    TextGadget(#PB_Any,340,10,100,20,"Style :")
    TextGadget(#PB_Any,460,10,100,20,"Size :")
    CFP_CreateGagdet(#Cmb_Font,10,40,300,24)
    CheckBoxGadget(#Chk_Bold,340,40,80,20,"Bold")
    CheckBoxGadget(#Chk_Italic,340,70,80,20,"Italic")
    CheckBoxGadget(#Chk_StrikeOut,340,100,80,20,"StrikeOut")
    StringGadget(#Str_Size,460,40,150,20,Str(Font\Size),#PB_String_Numeric)
    ListViewGadget(#Lst_Size,460,60,150,60)
    TextGadget(#PB_Any,10,150,100,20,"Text color")
    CheckBoxGadget(#Chk_Shadow,10,170,100,20,"Shadow color")
    TextGadget(#PB_Any,200,150,100,20,"Background color")
    TextGadget(#PB_Any,630,40,40,20,"Padding")
    StringGadget(#Str_MargeUp,700,40,30,20,Str(Font\MargeUp),#PB_String_Numeric)
    StringGadget(#Str_MargeLeft,665,65,30,20,Str(Font\MargeLeft),#PB_String_Numeric)
    StringGadget(#Str_MargeDown,700,90,30,20,Str(Font\MargeDown),#PB_String_Numeric)
    StringGadget(#Str_MargeRight,735,65,30,20,Str(Font\MargeRight),#PB_String_Numeric)
    TextGadget(#PB_Any,700,65,30,20,"A",#PB_Text_Border|#PB_Text_Center)
    CreateImage(0,30,20)
    CreateImage(1,30,20)
    CreateImage(2,30,20)
    StartDrawing(ImageOutput(0))
    Box(0,0,30,20,Font\Color)
    StopDrawing()
    StartDrawing(ImageOutput(1))
    Box(0,0,30,20,Font\ShadowColor)
    StopDrawing()
    StartDrawing(ImageOutput(2))
    Box(0,0,30,20,Font\BackGroundColor)
    StopDrawing()
    ButtonImageGadget(#Btn_Color,150,150,30,20,ImageID(0))
    ButtonImageGadget(#Btn_ShadowColor,150,170,30,20,ImageID(1))
    ButtonImageGadget(#Btn_BackgroundColor,300,150,30,20,ImageID(2))
    TextGadget(#PB_Any,220,170,40,20,"Alpha :")
    StringGadget(#Str_Alpha,300,170,40,20,Str(Font\ShadowAlpha),#PB_String_Numeric)
    TextGadget(#PB_Any,370,170,40,20,"OffestX :")
    StringGadget(#Str_OffsetX,450,170,40,20,Str(Font\ShadowX),#PB_String_Numeric)
    TextGadget(#PB_Any,520,170,40,20,"OffsetY :")
    StringGadget(#Str_OffsetY,600,170,40,20,Str(Font\ShadowY),#PB_String_Numeric)
    CanvasGadget(#Cnv_Preview,10,200,780,180)
    For FontLoop = 0 To 14
      AddGadgetItem(#Lst_Size,-1,Str(32+FontLoop*8))
    Next FontLoop
    If Font\Shadow
      SetGadgetState(#Chk_Shadow,#PB_Checkbox_Checked)
    EndIf
    BindGadgetEvent(#Chk_Bold,@Style())
    BindGadgetEvent(#Chk_Italic,@Style())
    BindGadgetEvent(#Chk_StrikeOut,@Style())
    BindGadgetEvent(#Chk_Shadow,@Shadow())
    BindGadgetEvent(#Lst_Size,@ChangeSize(),#PB_EventType_LeftClick)
    BindGadgetEvent(#Str_Size,@ChangeSize(),#PB_EventType_Change)
    BindGadgetEvent(#Btn_Color,@ChangeColor())
    BindGadgetEvent(#Btn_ShadowColor,@ChangeColor())
    BindGadgetEvent(#Btn_BackgroundColor,@ChangeColor())
    BindGadgetEvent(#Str_Alpha,@ShadowAlpha(),#PB_EventType_Change)
    BindGadgetEvent(#Str_OffsetX,@Offset(),#PB_EventType_Change)
    BindGadgetEvent(#Str_OffsetY,@Offset(),#PB_EventType_Change)
    BindGadgetEvent(#Str_MargeDown,@Marging(),#PB_EventType_Change)
    BindGadgetEvent(#Str_MargeLeft,@Marging(),#PB_EventType_Change)
    BindGadgetEvent(#Str_MargeRight,@Marging(),#PB_EventType_Change)
    BindGadgetEvent(#Str_MargeUp,@Marging(),#PB_EventType_Change)
    RefreshPreview()
  EndIf
EndProcedure

Procedure Load()
  Protected File$, *Buffer
  File$ = OpenFileRequester("Load file",GetCurrentDirectory(),"Font file(*.afg) | *.afg",0)
  If File$
    OpenPack(0,File$,#PB_PackerPlugin_Lzma )
    ExaminePack(0)
    NextPackEntry(0)
    *Buffer = AllocateMemory(PackEntrySize(0))
    UncompressPackMemory(0,*Buffer,MemorySize(*Buffer),PackEntryName(0))
    ClosePack(0)
    CatchJSON(0,*Buffer,MemorySize(*Buffer))
    ExtractJSONStructure(JSONValue(0),@Font,Font)
    FreeMemory(*Buffer)
    RefreshSample()
  EndIf
EndProcedure

Procedure GenerateFont()
  Font\String = GetGadgetText(#Str_Char)
  Protected X = Font\Width * 14, Y = Font\Height * Round((Len(Font\String)/14),#PB_Round_Up)
  Protected Img, LoopX, LoopY,OffsetX,OffsetY, JsonData, *Buffer,JsonSize,Temp$
  Protected NewMap Charset.char()
  X + 14 * (Font\MargeLeft+Font\MargeRight)
  Y + Round((Len(Font\String)/14),#PB_Round_Up) * (Font\MargeUp+Font\MargeDown)
  img = CreateImage(#PB_Any,X,Y,32,#PB_Image_Transparent)
  If img
    StartDrawing(ImageOutput(img))
    DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
    DrawingFont(FontID(0))
    For Loopy = 0 To Y/Font\Height-1
      For LoopX = 0 To 14
        If Font\Shadow
          DrawText(LoopX * Font\Width + Font\ShadowX + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight , LoopY * Font\Height + Font\ShadowY + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown, Mid(Font\String,(LoopX+1)+LoopY * 14,1),Font\ShadowColor)
          OffsetX = Font\ShadowX
          OffsetY = Font\ShadowY
        Else
          OffsetX = 0 : OffsetY = 0
        EndIf
        DrawText(LoopX * Font\Width + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight, LoopY * Font\Height + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown, Mid(Font\String,(LoopX+1)+LoopY * 14,1),Font\Color)
        If Not Mid(Font\String,(LoopX+1)+LoopY * 14,1) = ""
          Temp$ = Mid(Font\String,(LoopX+1)+LoopY * 14,1)
          If PeekC(@Temp$) > Font\MaxValue
            Font\MaxValue = PeekC(@Temp$)
          EndIf
          Charset(Mid(Font\String,(LoopX+1)+LoopY * 14,1))\X = LoopX * Font\Width + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight
          Charset()\Y = LoopY * Font\Height + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown
          Charset()\Height = TextHeight(Mid(Font\String,(LoopX+1)+LoopY * 14,1))+OffsetX + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight
          Charset()\Width = TextWidth(Mid(Font\String,(LoopX+1)+LoopY * 14,1))+OffsetY + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown
        EndIf
      Next LoopX
    Next LoopY
    StopDrawing()
    CreateJSON(0)
    InsertJSONStructure(JSONValue(0),@Font,Font)
    JsonData = AddJSONMember(JSONValue(0),"Chardata")
    InsertJSONMap(JsonData,Charset())
    *Buffer = AllocateMemory(ExportJSONSize(0))
    ExportJSON(0,*Buffer,MemorySize(*Buffer))
    CreatePack(0,Font\Name+".afg",#PB_PackerPlugin_Lzma)
    AddPackMemory(0,*Buffer,MemorySize(*Buffer),Font\Name+".json")
    FreeMemory(*Buffer)
    *Buffer = EncodeImage(img,#PB_ImagePlugin_PNG)
    AddPackMemory(0,*Buffer,MemorySize(*Buffer),Font\Name+".png")
    FreeMemory(*Buffer)
    ClosePack(0)    
    FreeImage(img)
    FreeJSON(0)
    MessageRequester("Awesome bitmapFont Generator","Font succefully generated")
    ProcedureReturn #True
  EndIf
  MessageRequester("Awesome bitmapFont Generator","An error has ocurred...")
EndProcedure

Procedure RefreshSample()
  Protected LoopX,LoopY, x, y, str$ = GetGadgetText(#Str_Char)
  Loadfnt()
  StartDrawing(CanvasOutput(#Cnv_Sample))
  Box(0,0,1180,628,Font\BackGroundColor)
  DrawingFont(FontID(0))
  DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
  Font\Height = TextHeight("A")
  Font\Width = TextWidth("A")+30
  x = 1180/Font\Width +1
  y = 628 / Font\Height
  For LoopY = 0 To y
    For LoopX = 0 To x
      If Font\Shadow
        DrawText(LoopX * Font\Width + Font\ShadowX,LoopY * Font\Height + Font\ShadowY,Mid(str$,LoopX + LoopY * x+1,1),Font\ShadowColor)
      EndIf
      DrawText(LoopX * Font\Width,LoopY * Font\Height,Mid(str$,LoopX + LoopY * x+1,1),Font\Color)
    Next LoopX
  Next LoopY
  StopDrawing()
EndProcedure

Procedure ChangeSize()
  If EventGadget() = #Lst_Size
    SetGadgetText(#Str_Size,GetGadgetText(#Lst_Size))
  EndIf
  font\Size = Val(GetGadgetText(#Str_Size))
  Loadfnt()
  RefreshPreview()
EndProcedure

Procedure Loadfnt()
  LoadFont(0,Font\Name,font\Size,Font\Flag)
EndProcedure

Procedure Marging()
  Select EventGadget()
    Case #Str_MargeDown
      Font\MargeDown = Val(GetGadgetText(#Str_MargeDown))
    Case #Str_MargeLeft
      Font\MargeLeft = Val(GetGadgetText(#Str_MargeLeft))
    Case #Str_MargeRight
      Font\MargeRight = Val(GetGadgetText(#Str_MargeRight))
    Case #Str_MargeUp
      Font\MargeUp = Val(GetGadgetText(#Str_MargeUp))
  EndSelect
EndProcedure

Procedure ChangeColor()
  Protected Color
  If EventGadget() = #Btn_Color
    Color = ColorRequester(font\Color)
    If Not Color = -1
      Font\Color = RGBA(Red(Color),Green(Color),Blue(Color),255)
    StartDrawing(ImageOutput(0))
    Box(0,0,30,20,Color)
    StopDrawing()
    EndIf
  ElseIf EventGadget() = #Btn_ShadowColor
    Color = ColorRequester(font\ShadowColor)
    If Not Color = -1
      Font\ShadowColor = RGBA(Red(Color),Green(Color),Blue(Color),Val(GetGadgetText(#Str_Alpha)))
    StartDrawing(ImageOutput(1))
    Box(0,0,30,20,Color)
    StopDrawing()
    EndIf
  Else
    Color = ColorRequester(Font\BackGroundColor)
    If Not Color = -1
      Font\BackGroundColor = Color
    StartDrawing(ImageOutput(2))
    Box(0,0,30,20,Color)
    StopDrawing()
    EndIf
  EndIf
  If Not Color = -1
    RefreshPreview()
  EndIf
EndProcedure

Procedure Style()
  font\Flag = 0
  If GetGadgetState(#Chk_Bold) = #PB_Checkbox_Checked
    Font\Flag | #PB_Font_Bold
  EndIf
  If GetGadgetState(#Chk_Italic) = #PB_Checkbox_Checked
    Font\Flag | #PB_Font_Italic
  EndIf
  If GetGadgetState(#Chk_StrikeOut) = #PB_Checkbox_Checked
    Font\Flag | #PB_Font_StrikeOut
  EndIf
  Loadfnt()
  RefreshPreview()
EndProcedure

Procedure Offset()
  Font\ShadowX = Val(GetGadgetText(EventGadget()))
  RefreshPreview()
EndProcedure

Procedure ShadowAlpha()
  Font\ShadowAlpha = Val(GetGadgetText(#Str_Alpha))
  Font\ShadowColor = RGBA(Red(Font\ShadowColor),Green(Font\ShadowColor),Blue(Font\ShadowColor),Font\ShadowAlpha)
  RefreshPreview()
EndProcedure

Procedure Shadow()
  If GetGadgetState(#Chk_Shadow) = #PB_Checkbox_Checked
    Font\Shadow = 1
  Else
    Font\Shadow = 0
  EndIf
  RefreshPreview()
EndProcedure

Procedure RefreshPreview()
  StartDrawing(CanvasOutput(#Cnv_Preview))
  Box(0,0,780,180,Font\BackGroundColor)
  DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
  DrawingFont(FontID(0))
  If Font\Shadow
    DrawText(10+Font\ShadowX,10+Font\ShadowY,"The quick brown fox jumped over the lazy dog.",Font\ShadowColor)
  EndIf
  DrawText(10,10,"The quick brown fox jumped over the lazy dog.",Font\Color)
  StopDrawing()
EndProcedure

Procedure Close()
  If GetActiveWindow() = #Window_Main
    End
  Else
    CFP_FreeGadget(101)
    CloseWindow(#Window_Font)
    FreeImage(0)
    FreeImage(1)
    FreeImage(2)
    SetGadgetText(#Txt_Font,Font\Name+","+Font\Size)
    RefreshSample()
  EndIf
EndProcedure

;===============================================================
;Display font with style & icon ================================
; Title: Font Preview ComboBox =================================
; Author: Fluid Byte ===========================================
; Platform: Windows ============================================
; Created: Jan 27, 2009 ========================================
; Updated: May 29, 2017 ========================================
; E-Mail: fluidbyte@web.de =====================================
;http://forums.purebasic.com/english/viewtopic.php?f=12&t=36198=
;===============================================================

Procedure CFP_Change()
  Font\Name = CFP_GetGadgetText(#Cmb_Font,GetGadgetState(#Cmb_Font))
  Loadfnt()
  RefreshPreview()
EndProcedure

Procedure CFP_CreateGagdet(Gadget,X,Y,Width,Height,ItemHeight=20,FontSize=11)
   Protected himlFontType, hwndParent, *cfpu.CFP_USERDATA
   
   himlFontType = ImageList_Create_(16,12,#ILC_MASK,0,0)
   ImageList_AddMasked_(himlFontType,CatchImage(0,?FontType),#Yellow)   
      
   hwndParent = GadgetID(ContainerGadget(#PB_Any,X,Y,Width,Height))
   ComboBoxGadget(Gadget,0,0,Width,Height,#CBS_OWNERDRAWFIXED)
   SendMessage_(GadgetID(Gadget),#CB_SETITEMHEIGHT,0,ItemHeight)   
   CloseGadgetList()
   
   *cfpu = AllocateMemory(SizeOf(CFP_USERDATA))
   *cfpu\himlFontType = himlFontType
   *cfpu\FontSize = FontSize
   *cfpu\hwndParent = hwndParent
   SetWindowLongPtr_(GadgetID(Gadget),#GWLP_USERDATA,*cfpu)
   
   SetWindowLongPtr_(hwndParent,#GWL_WNDPROC,@CFP_WndProc())
   
   CFP_EnumFonts(Gadget)
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure.s CFP_GetGadgetText(Gadget,Item)
   If IsGadget(Gadget)
      Protected *cfpf.CFP_FONTDATA
      *cfpf = GetGadgetItemData(Gadget,Item)      
      ProcedureReturn *cfpf\Name
   EndIf
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_FreeGadget(Gadget)
   If IsGadget(Gadget)
      Protected *cfpu.CFP_USERDATA, Result
      
      *cfpu = GetWindowLongPtr_(GadgetID(Gadget),#GWLP_USERDATA)

      If *cfpu
         Result = ImageList_Destroy_(*cfpu\himlFontType)
         
         If Result : Result = FreeMemory(*cfpu) : EndIf
      EndIf
   EndIf
   
   ProcedureReturn Result
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_WndProc(hWnd,uMsg,wParam,lParam)
  Select uMsg
    Case #WM_COMMAND
      Select (wParam >> 16) & $ffff
        Case  #CBN_SELCHANGE
          CFP_Change()
      EndSelect
    Case #WM_DRAWITEM
      Protected *lpdis.DRAWITEMSTRUCT = lParam   
      
      ; --- Draw item focus rectangle or normal state      
      If *lpdis\itemState & #ODS_SELECTED
         Protected hbrFocus = CreateSolidBrush_(GetSysColor_(#COLOR_HIGHLIGHT))
         FillRect_(*lpdis\hDC,*lpdis\rcItem,hbrFocus)
         DeleteObject_(hbrFocus)
         DrawFocusRect_(*lpdis\hDC,*lpdis\rcItem)            
         SetTextColor_(*lpdis\hDC,GetSysColor_(#COLOR_HIGHLIGHTTEXT))
      Else
         Protected hbrFace = CreateSolidBrush_(GetSysColor_(#COLOR_WINDOW))
         FillRect_(*lpdis\hDC,*lpdis\rcItem,hbrFace)
         DeleteObject_(hbrFace)
         SetTextColor_(*lpdis\hDC,GetSysColor_(#COLOR_WINDOWTEXT))
      EndIf   
  
      Protected *ftd.CFP_FONTDATA = GetGadgetItemData(wParam,*lpdis\itemID)         
      Protected *cfpu.CFP_USERDATA = GetWindowLongPtr_(*lpdis\hwndItem,#GWLP_USERDATA)
  
      ; --- Draw Font Icons
      If *ftd\Type > -1
         ImageList_Draw_(*cfpu\himlFontType,*ftd\Type,*lpdis\hDC,2,*lpdis\rcItem\top + 3,#ILD_TRANSPARENT)
      EndIf
      
      ; --- Create Preview Font
      Protected lplf.LOGFONT, hfntPreview
      
      lplf\lfHeight = -MulDiv_(*cfpu\FontSize,GetDeviceCaps_(*lpdis\hDC,#LOGPIXELSY),72)         
      
      If *ftd\Symbol : lplf\lfCharSet = #SYMBOL_CHARSET : EndIf         
      
      PokeS(@lplf\lfFaceName,*ftd\name)         
      
      hfntPreview = CreateFontIndirect_(lplf)
  
      ; --- Draw Preview Text
      SetBkMode_(*lpdis\hDC,#TRANSPARENT)   
      
      If *ftd\Symbol ; If it's a smybol font like Webdings
         Protected fsz.SIZE
         
         ; Write the fonts name
         *lpdis\rcItem\left + 20
         SelectObject_(*lpdis\hDC,GetStockObject_(#DEFAULT_GUI_FONT))
         GetTextExtentPoint32_(*lpdis\hDC,*ftd\Name,Len(*ftd\Name),fsz)
         DrawText_(*lpdis\hDC,*ftd\Name,-1,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)   
         
         ; Display demo charachters next to the name
         *lpdis\rcItem\left + fsz\cx + 3
         SelectObject_(*lpdis\hDC,hfntPreview)
         DrawText_(*lpdis\hDC,"ABC123",6,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
      Else
         *lpdis\rcItem\left + 20
         SelectObject_(*lpdis\hDC,hfntPreview)         
         DrawText_(*lpdis\hDC,*ftd\Name,-1,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
      EndIf   
      
      DeleteObject_(hfntPreview)
      
      ProcedureReturn #True
  EndSelect
  ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_EnumFonts(Gadget)
  Protected lplf.LOGFONT, hdc, Index, start
  
  lplf\lfCharset = #DEFAULT_CHARSET
  
  hdc = GetDC_(0)
  EnumFontFamiliesEx_(hdc,lplf,@CFP_EnumProc(),hdc,0)
  ReleaseDC_(0,hdc)
  
  SortStructuredList(ftd(),#PB_Sort_Ascending,OffsetOf(CFP_FONTDATA\Name),#PB_String)
  
  ForEach ftd()
    AddGadgetItem(Gadget,-1,ftd()\Name)
    If ftd()\Name = Font\Name
      start = Index
    EndIf
    SetGadgetItemData(Gadget,Index,ftd())
    Index + 1            
  Next
  SetGadgetState(Gadget,start)
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_EnumProc(*lpelfe.ENUMLOGFONTEX,*lpntme.NEWTEXTMETRICEX,FontType,lParam)
   Protected CHRSET = *lpelfe\elfLogFont\lfCharSet & 255
   
   ; WESTERN FONTS / SYSTEM FONTS / SYMBOL FONTS
    If Not Left(PeekS(@*lpelfe\elfLogFont\lfFaceName),1) = "@"
      If CHRSET = #ANSI_CHARSET Or CHRSET = #OEM_CHARSET Or CHRSET = #SYMBOL_CHARSET
        AddElement(ftd())
        
        Select FontType
           Case #TRUETYPE_FONTTYPE : ftd()\Type = 0
           Case #DEVICE_FONTTYPE : ftd()\Type = 1
           Case #RASTER_FONTTYPE : ftd()\Type = 2
           Default : ftd()\Type = -1
        EndSelect
        
        If CHRSET = #SYMBOL_CHARSET : ftd()\Symbol = 1 : EndIf
        
        ; Using 'lfFaceName' of the LOGFONT structure gives unique fontnames and avoids dublicates.
        ; When using 'elfFullName' of the ENUMLOGFONTEX structure you still can get dublicates even
        ; though you limit the character set like above. Also you don't need to cycle through the
        ; whole LinkedList everytime to find out if a fontname already exists.
        ;
        ; The created fontlist SHOULD be identical to the one in MS Wordpad + bitmap fonts (Courier, etc.)
          ftd()\Name = PeekS(@*lpelfe\elfLogFont\lfFaceName)
      EndIf
    EndIf

   ProcedureReturn #True
EndProcedure

DataSection
   FontType:
   Data.l $01964D42,$00000000,$00760000,$00280000,$00300000,$000C0000,$00010000,$00000004,$01200000,$00000000
   Data.l $00000000,$00000000,$00000000,$00000000,$00000000,$80000080,$80000000,$00800080,$00800000,$80800080
   Data.l $80800000,$C0C00080,$000000C0,$FF0000FF,$FF000000,$00FF00FF,$00FF0000,$FFFF00FF,$FFFF0000,$BBBB00FF
   Data.l $5555BBBB,$BBBBBB55,$BB7B77B8,$B9BBBBBB,$97B97B99,$BBBBBBBB,$55BBBBBB,$BBBBBBBB,$8B868870,$99BBBBBB
   Data.l $79999799,$BBBBBBBB,$55BBBBBB,$B8BBBBBB,$68B8BB00,$99BBBBBB,$B799797B,$BBBBBB9B,$55666666,$B8BBBBBB
   Data.l $76BBBB00,$99BBBB8B,$7B99B77B,$BBBBBBBB,$55BB66BB,$B8BBBBBB,$86BBBB00,$99BBBB6B,$9B79BB7B,$BBBBBBBB
   Data.l $55BB65BB,$B8BB5BBB,$B6BB8B00,$79BBBB68,$97B9BB9B,$BBBBBBBB,$55BB65BB,$BBBB5BBB,$B6BB7B00,$B9BBBB68
   Data.l $99B7BB97,$BBBBBBBB,$555B65BB,$BBBB5BB5,$B7BB0B70,$B7BBBB66,$99BBBB99,$B6BBBB7B,$555565BB,$BBBB5B55
   Data.l $B7BB08B0,$BBBBBB68,$79BB9B79,$B6BBBB9B,$6BBB66BB,$BBBBBBBB,$B7BB00B8,$BBBBBB68,$79BB99B7,$B6BBBB97
   Data.l $6BB6666B,$BBBBBBBB,$867880BB,$BBBBBB6B,$9799B9BB,$B6BBBB79,$6B666666,$BBBBBBBB,$6887BBBB,$BBBBBBBB
   Data.l $BBBBBBBB
   Data.b $BB,$BB
EndDataSection
And here is the module :

Code: Select all

DeclareModule PureBF
  Declare LoadBitmapFont(File$) ;Return the generated number on success, 0 otherwise.
  Declare CatchBitmapFont(*MemoryAddress,Size)  ;Return the generated number on success, 0 otherwise. (Need to write file in temp directory... Not sure this is the best way, probably not a secure to use fonction)
  Declare DisplayText(*Font,X,Y,Text$,Zoom.f,Opacity,Color=#PB_Default) ;Fast display a raw text, no tag can or effect can be use. #CR$ or #CRLF$ character can be use for carriage return. 
  Declare GetTextWidth(*Font,Text$,Zoom.f) ;Return the width of a text displayed with DisplayText() function.
  Declare GetTextHeight(*Font,Text$,Zoom.f) ;Return the height of a text displayed with DisplayText() function.
  Declare CreateTextBox(X,Y,Width,Height,Flag=0)   ;Create a new empty text box. Return the generated number. Flag use PB's text constante (#PB_Text_Center | #PB_Text_Right)
  Declare FreeTextBox(*TextBox)             ;Delete a text box and all the text contained.
  Declare DisplayTextBox(*TextBox)          ;Display the text box and process the effect is needed.
  Declare AddTextBoxString(*TextBox,*Font,String$,Zoom.f,Opacity,Color=#PB_Default) ;Add a string to the TextBox, String will be add after the previous one.
  Declare AddTextBoxStringN(*TextBox,*Font,String$,Zoom.f,Opacity,Color=#PB_Default) ;Add a string to the TextBox followed by a carriage return charactere.
  Declare SetShakeAttribut(Speed.f,Target.f) ;Set the shake effect speed and target. (Target is the delta in pixel letters will move, Speed in pixel).
  Declare SetWaveAttribut(Speed.f,Target.f) ;Set the Wave effect speed and target. (Target is the delta in pixel letters will move, Speed in pixel).
  Declare SetBlinkSpeed(Speed) ;Blink effect will switch status every #Speed frames.
  Declare SetBlinkColor(Color)
  Declare SetRainbowAttribut(Speed.f,RStep.f) ;Set the Rainbow effect speed and color gap between each letters.
  Declare.f GetShakeSpeed()
  Declare.f GetWaveSpeed()
  Declare.f GetShakeTarget()
  Declare.f GetWaveTarget()
  Declare GetBlinkSpeed()
  Declare GetBlinkColor()
  Declare.f GetRainbowSpeed()
  Declare.f GetRainbowStep()
  Declare.f GetTextBoxX(*TextBox)
  Declare.f GetTextBoxY(*TextBox)
  Declare MoveTextBox(*TextBox,X,Y,Mode = #PB_Absolute)
EndDeclareModule
Module PureBF
  #PBF_Compatibility = 0 ; 0 Mean faster render time but Unicode only and require low memory acces. /!\ Requesting to display a charactere unavaliable in the font can result in a crash /!\ 
                         ; 1 Mean slower render time but compatible with every text mode and SpiderBasic
                         ; Compatibility set to 1 can have faster render time with short text especialy on hardware with slow memory acces
  
  ;--------- Declaration-------------------------------------------------
  EnableExplicit
  UsePNGImageDecoder()
  UseLZMAPacker()
  ;{ Structures
  Structure Font
    Name.s
    Size.c
    Shadow.a
    ShadowX.a
    ShadowY.a
    Color.i
    ShadowColor.i
    BackGroundColor.i
    FntAlpha.a
    ShadowAlpha.a
    String.s
    Height.c
    Width.c
    Flag.i
    MargeUp.C
    MargeDown.c
    MargeLeft.c
    MargeRight.c
    MaxValue.c
  EndStructure
  
  Structure Char
    X.i
    Y.i
    Width.i
    Height.i
  EndStructure
  
  Structure BitmapFont
    Sprite.i
    FontInto.Font
    CompilerIf #PBF_Compatibility = 0
      Array CharInfo.Char(1)
    CompilerElse
      Map MapInfo.Char()
    CompilerEndIf
  EndStructure
    
  Structure Shake
    Enable.a
    Speed.f
    Target.c
    Delta.f
  EndStructure
  
  Structure Wave
    Enable.a
    Speed.f
    Target.c
    Delta.f
  EndStructure
  
  Structure Blink
    Enable.a
    Speed.i
    Count.i
    Color.i
    State.a
  EndStructure
  
  Structure Rainbow
    Enable.a
    Speed.f
    RainbowStep.f
    Delta.f
  EndStructure
  
  Structure TextList
    Line.c
    Text.s
    X.i
    Y.i
    Color.i
    Opacity.a
    Zoom.f
    ClipHeight.i
    *Font.BitmapFont
    Shake.Shake
    Wave.Wave     
    Blink.Blink
    Rainbow.Rainbow
  EndStructure
  
  Structure TextBox
    X.f
    Y.f
    CursorX.i
    CursorY.i
    CurentLine.c
    Width.i
    Height.i
    Flag.a
    List Text.TextList()
  EndStructure
      
  ;} End structures
  
  ; Variables
  Global  ShakeSpeed.f=2, WaveSpeed.f=0.15, ShakeTarget.f=2, WaveTarget.f=5, BlinkSpeed = 30, BlinkColor, RainbowSpeed.f = 0.04, RainbowStep.f = 0.1
  Global NewList TextBoxList.TextBox()
  ;{Procedures
  Declare AddTextToBox(*TextBox,*Font,Text$,Shake,Wave,Blink,ColorBlink,Rainbow,Zoom.f,Opacity,Color)
  Declare AligneText(*TextBox)
  Declare AddLineToBox(*TextBox)
  Declare SetShake(*TextBox)
  Declare SetWave(*TextBox)
  Declare SetBlink(*TextBox)
  Declare SetColorBlink(*TextBox)
  Declare SetRainbow(*TextBox)
  Declare MakeShake(*TextBox)
  Declare MakeWave(*TextBox,Delta)
  Declare MakeBlink(*textBox)
  Declare MakeRainbow(*TextBox,Delta)
  
  ; }

  ;---------End Declaration-----------------------------------------------
  
  ;---------Public Procedures---------------------------------------------
  
  Procedure LoadBitmapFont(File$) ;LoadBitmapFont function for PureBasic only 
    Protected *PackBuffer, *Return.BitmapFont,Loop, LoopMax, Temp$
    CompilerIf #PBF_Compatibility = 0
      Protected NewMap MapInfo.Char()
    CompilerEndIf
    If OpenPack(0,File$,#PB_PackerPlugin_Lzma)
      ExaminePack(0)
      NextPackEntry(0)
      *PackBuffer = AllocateMemory(PackEntrySize(0))
      UncompressPackMemory(0,*PackBuffer,MemorySize(*PackBuffer),PackEntryName(0))
      *Return = AllocateMemory(SizeOf(BitmapFont))
      InitializeStructure(*Return,BitmapFont)
      CatchJSON(0,*PackBuffer,MemorySize(*PackBuffer))
      ExtractJSONStructure(JSONValue(0),*Return\FontInto,Font)
      ExamineJSONMembers(JSONValue(0))
      While NextJSONMember(JSONValue(0))
        If JSONMemberKey(JSONValue(0)) = "Chardata"
          CompilerIf #PBF_Compatibility = 0
            ExtractJSONMap(JSONMemberValue(JSONValue(0)),MapInfo())
          CompilerElse
            ExtractJSONMap(JSONMemberValue(JSONValue(0)),*Return\MapInfo())
          CompilerEndIf
        EndIf
      Wend
      FreeMemory(*PackBuffer)
      NextPackEntry(0)
      *PackBuffer = AllocateMemory(PackEntrySize(0))
      UncompressPackMemory(0,*PackBuffer,MemorySize(*PackBuffer))
      *Return\Sprite = CatchSprite(#PB_Any,*PackBuffer,#PB_Sprite_AlphaBlending)
      FreeMemory(*PackBuffer)
      ClosePack(0)
      *Return\FontInto\Width / 2
      CompilerIf #PBF_Compatibility = 0
        ReDim *Return\CharInfo(*Return\FontInto\MaxValue)
        LoopMax = Len(*Return\FontInto\String)
        For Loop = 1 To LoopMax
          Temp$ = Mid(*Return\FontInto\String,Loop,1)
          If FindMapElement(MapInfo(),Temp$)
            CopyStructure(@MapInfo(),@*Return\CharInfo(PeekC(@Temp$)),Char)
          EndIf
        Next Loop
        FreeMap(MapInfo())
      CompilerEndIf
      ProcedureReturn *Return
    EndIf
    ProcedureReturn #False
  EndProcedure
  
  Procedure CatchBitmapFont(*Memory,Size)
    Protected *Return.Font
    If CreateFile(0,GetTemporaryDirectory()+"PureBFTemp")
      WriteData(0,*Memory,Size)
      CloseFile(0)
      *Return = LoadBitmapFont(GetTemporaryDirectory()+"PureBFTemp")
      If *Return
        DeleteFile(GetTemporaryDirectory()+"PureBFTemp")
        ProcedureReturn *Return
      EndIf
    EndIf
    ProcedureReturn #False
  EndProcedure
  
  Procedure DisplayText(*Font.BitmapFont,X,Y,Text$,Zoom.f,Opacity,Color=#PB_Default)
    Protected loop,loopmax = Len(text$),DeltaX 
    CompilerIf #PBF_Compatibility = 0 
      Protected Index
      loopmax - 1
      For loop = 0 To loopmax
        Index = PeekC(@Text$+(loop)*2)
        If Index = #LF
          DeltaX = 0 : Y + *Font\FontInto\Height * Zoom
        Else
          ClipSprite(*Font\Sprite,*Font\CharInfo(Index)\X,*Font\CharInfo(Index)\Y,*Font\CharInfo(Index)\Width,*Font\CharInfo(Index)\Height)
          ZoomSprite(*Font\Sprite,*Font\CharInfo(Index)\Width*Zoom,*Font\CharInfo(Index)\Height * Zoom)
          DisplayTransparentSprite(*Font\Sprite,X+DeltaX,Y,Opacity,Color)
          DeltaX+*Font\CharInfo(Index)\Width * Zoom
        EndIf
    CompilerElse
      Protected Char$  
      For loop = 1 To loopmax
        Char$ = Mid(Text$,loop,1)
        If Char$ = #LF$
          DeltaX = 0 : Y + *Font\FontInto\Height * Zoom
        Else
          If FindMapElement(*Font\MapInfo(),Char$)
            ClipSprite(*Font\Sprite,*Font\MapInfo()\X,*Font\MapInfo()\Y,*Font\MapInfo()\Width,*Font\MapInfo()\Height)
            ZoomSprite(*Font\Sprite,*Font\MapInfo()\Width*Zoom,*Font\MapInfo()\Height * Zoom)
            DisplayTransparentSprite(*Font\Sprite,X+DeltaX,Y,Opacity,Color)
            DeltaX+*Font\MapInfo()\Width * Zoom
          EndIf
        EndIf
    CompilerEndIf
    Next loop
  EndProcedure
  
  Procedure CreateTextBox(X,Y,Width,Height,Flag=0)
    AddElement(TextBoxList())
    Define *TextBox.Textbox = @TextBoxList() ;AllocateStructure(TextBox)
    *TextBox\X = X
    *TextBox\Y = Y
    *TextBox\Width = Width
    *TextBox\Height = Height
    *TextBox\CurentLine = 1
    *TextBox\Flag = Flag
    ProcedureReturn *TextBox
  EndProcedure  
  
  Procedure FreeTextBox(*TextBox)
    ;FreeStructure(*TextBox)
    ChangeCurrentElement(TextBoxList(),*TextBox)
    DeleteElement(TextBoxList())
  EndProcedure
  
  Procedure DisplayTextBox(*TextBox.TextBox)
    Protected loop, loopmax, DeltaX, DeltaY, Color, Blink
    ForEach *TextBox\Text()
      If *TextBox\Text()\Blink\Enable
        Blink = MakeBlink(*TextBox)
        If Blink = -2
          Continue
        Else
          Color = Blink
        EndIf
      Else
        Color = *TextBox\Text()\Color
      EndIf
      loopmax = Len(*TextBox\Text()\Text) : DeltaX = 0 : DeltaY = 0
      If *TextBox\Text()\Shake\Enable
        DeltaX + MakeShake(*TextBox) : DeltaY = DeltaX/2
      EndIf
      CompilerIf #PBF_Compatibility = 0
        Protected Index
        loopmax - 1
        For loop = 0 To loopmax
          If *TextBox\Text()\Wave\Enable
            DeltaY = MakeWave(*TextBox,loop)
          EndIf
          If *TextBox\Text()\Rainbow\Enable
            Color = MakeRainbow(*TextBox,loop)
          EndIf
          Index = PeekC(@*TextBox\Text()\Text + loop * 2)
          ClipSprite(*TextBox\Text()\Font\Sprite,*TextBox\Text()\Font\CharInfo(Index)\X,*TextBox\Text()\Font\CharInfo(Index)\Y,*TextBox\Text()\Font\CharInfo(Index)\Width,*TextBox\Text()\ClipHeight)
          ZoomSprite(*TextBox\Text()\Font\Sprite,*TextBox\Text()\Font\CharInfo(Index)\Width * *TextBox\Text()\Zoom, *TextBox\Text()\ClipHeight * *TextBox\Text()\Zoom)
          DisplayTransparentSprite(*TextBox\Text()\Font\Sprite,*TextBox\X + *TextBox\Text()\X+DeltaX, *TextBox\Y + *TextBox\Text()\Y+DeltaY, *TextBox\Text()\Opacity, Color)
          DeltaX+*TextBox\Text()\Font\CharInfo(Index)\Width * *TextBox\Text()\Zoom
          
    CompilerElse
        Protected Char$
        For loop = 1 To loopmax
          If *TextBox\Text()\Wave\Enable
            DeltaY = MakeWave(*TextBox,loop)
          EndIf
          If *TextBox\Text()\Rainbow\Enable
            Color = MakeRainbow(*TextBox,loop)
          EndIf
          Char$ = Mid(*TextBox\Text()\Text,loop,1)
          If FindMapElement(*TextBox\Text()\Font\MapInfo(),Char$)
            ClipSprite(*TextBox\Text()\Font\Sprite,*TextBox\Text()\Font\MapInfo()\X,*TextBox\Text()\Font\MapInfo()\Y,*TextBox\Text()\Font\MapInfo()\Width,*TextBox\Text()\ClipHeight)
            ZoomSprite(*TextBox\Text()\Font\Sprite,*TextBox\Text()\Font\MapInfo()\Width * *TextBox\Text()\Zoom, *TextBox\Text()\ClipHeight * *TextBox\Text()\Zoom)
            DisplayTransparentSprite(*TextBox\Text()\Font\Sprite,*TextBox\X + *TextBox\Text()\X+DeltaX, *TextBox\Y + *TextBox\Text()\Y+DeltaY, *TextBox\Text()\Opacity, Color)
            DeltaX + *TextBox\Text()\Font\MapInfo()\Width * *TextBox\Text()\Zoom
          EndIf
      
    CompilerEndIf
          Next
        Next
  EndProcedure
  
  Procedure AddTextBoxString(*TextBox.TextBox,*Font.BitmapFont,String$,Zoom.f,Opacity,Color=#PB_Default)
    Protected Index = 1, Text$, TempText$, SpaceCount, Shake, Wave, Blink,Rainbow, ColorBlink
    SpaceCount = CountString(String$," ") + 2
    Repeat
      TempText$ = StringField(String$,Index," ")
      If TempText$ = "{\}" 
        If Not Text$ = ""
          AddTextToBox(*TextBox,*Font,Text$+" ",Shake,Wave,Blink,ColorBlink,Rainbow,Zoom,Opacity,Color)
          Text$ = ""
        EndIf
        If Shake : *TextBox\CursorX + ShakeTarget : EndIf
         Shake = 0 : Wave = 0 : Blink = 0 : ColorBlink = 0 : Rainbow = 0
      ElseIf Mid(TempText$,1,2) = "${"
        If Not Text$ = ""
          AddTextToBox(*TextBox,*Font,Text$+" ",Shake,Wave,Blink,ColorBlink,Rainbow,Zoom,Opacity,Color)
          Text$ = ""
        EndIf
        TempText$ = LCase(Mid(TempText$,3,Len(TempText$)-3))
        Select TempText$
          Case "shake"
            Shake = 1
          Case "wave"
            Wave = 1
          Case "blink"
            Blink = 1
          Case "colorblink"
            ColorBlink = 1
          Case "rainbow"
            Rainbow = 1
        EndSelect
      Else
        If GetTextWidth(*Font,Text$ + RTrim(TempText$),Zoom) + *TextBox\CursorX < *TextBox\Width
          If Text$ = ""
            Text$ + TempText$
          Else
            Text$ + " "+TempText$
          EndIf
        Else
          AddTextToBox(*TextBox,*Font,Text$,Shake,Wave,Blink,ColorBlink,Rainbow,Zoom,Opacity,Color)
          AddLineToBox(*TextBox)
          Text$ = TempText$
        EndIf
      EndIf
      Index + 1
    Until Index = SpaceCount
    If Not Text$ = ""
      AddTextToBox(*TextBox,*Font,Text$,Shake,Wave,Blink,ColorBlink,Rainbow,Zoom,Opacity,Color)
    EndIf
  EndProcedure
  
  Procedure AddTextBoxStringN(*TextBox,*Font,String$,Zoom.f,Opacity,Color=#PB_Default)
    AddTextBoxString(*TextBox,*Font,String$,Zoom,Opacity,Color)
    AddLineToBox(*TextBox)
  EndProcedure
  
  Procedure MoveTextBox(*TextBox.TextBox,X,Y,Mode = #PB_Absolute)
    Select Mode
      Case #PB_Absolute
        *TextBox\X = X
        *TextBox\Y = Y
      Case #PB_Relative
        *TextBox\X + X
        *TextBox\Y + Y
    EndSelect
  EndProcedure
  
  ;---------------Setter and Getter procedures---------------------------
  
  Procedure SetShakeAttribut(Speed.f,Target.f)
    ShakeSpeed = Speed
    ShakeTarget = Target
  EndProcedure
  
  Procedure SetWaveAttribut(Speed.f,Target.f)
    WaveSpeed = Speed
    WaveTarget = Target
  EndProcedure
  
  Procedure SetBlinkSpeed(Speed)
    BlinkSpeed = Speed
  EndProcedure
  
  Procedure SetBlinkColor(Color)
    BlinkColor = Color
  EndProcedure
  
  Procedure SetRainbowAttribut(Speed.f,RStep.f)
    RainbowSpeed = Speed
    RainbowStep = RStep
  EndProcedure
  
  Procedure.f GetShakeSpeed()
    ProcedureReturn ShakeSpeed
  EndProcedure
  
  Procedure.f GetShakeTarget()
    ProcedureReturn ShakeTarget
  EndProcedure
  
  Procedure.f GetWaveSpeed()
    ProcedureReturn WaveSpeed
  EndProcedure
  
  Procedure.f GetWaveTarget()
    ProcedureReturn WaveTarget
  EndProcedure
  
  Procedure GetBlinkSpeed()
    ProcedureReturn BlinkSpeed
  EndProcedure
  
  Procedure GetBlinkColor()
    ProcedureReturn BlinkColor
  EndProcedure
  
  Procedure.f GetRainbowSpeed()
    ProcedureReturn RainbowSpeed
  EndProcedure
  
  Procedure.f GetRainbowStep()
    ProcedureReturn RainbowStep
  EndProcedure
  
  Procedure.f GetTextBoxX(*TextBox.TextBox)
    ProcedureReturn *TextBox\X
  EndProcedure
  
  Procedure.f GetTextBoxY(*TextBox.TextBox)
    ProcedureReturn *TextBox\Y
  EndProcedure
  
  Procedure GetTextWidth(*Font.BitmapFont,Text$,Zoom.f)
    Protected Loop, LoopMax=Len(Text$),Width, Index,MemWidth
    CompilerIf #PBF_Compatibility = 0
      LoopMax - 1
      For loop = 0 To LoopMax
        Index = PeekC(@Text$+(loop)*2)
        If Index = #LF
          If Width > MemWidth : MemWidth = Width : EndIf
          Width = 0
        Else
          Width + *Font\CharInfo(Index)\Width * Zoom
        EndIf
    CompilerElse
      Protected Char$    
      For Loop = 1 To LoopMax
        Char$ = Mid(Text$,Loop,1)
        If Char$ = #LF$
          If Width > MemWidth : MemWidth = Width : EndIf
          Width = 0
        Else
          If FindMapElement(*Font\MapInfo(),Char$)
            Width+*Font\MapInfo()\Width * Zoom
          EndIf
        EndIf
    CompilerEndIf
    Next Loop
    If MemWidth > Width : Width = MemWidth : EndIf
    ProcedureReturn Width
  EndProcedure
  
  Procedure GetTextHeight(*Font.BitmapFont,Text$,Zoom.f) 
    Protected Height
    Height = *Font\FontInto\Height * (CountString(Text$,#LF$)+1) * Zoom
    ProcedureReturn Height    
  EndProcedure  
  ;-----------------------------------------------------------------------
  
  
  ;--------Private Procedures---------------------------------------------
  
  Procedure AddTextToBox(*TextBox.TextBox,*Font.BitmapFont,Text$,Shake,Wave,Blink,ColorBlink,Rainbow,Zoom.f,Opacity,Color)
    If Not Text$ = ""
      If *TextBox\CursorY < *TextBox\Height
        AddElement(*TextBox\Text())
        *TextBox\Text()\Font = *Font
        *TextBox\Text()\Text = Text$
        If Shake : SetShake(*TextBox) : EndIf
        If Wave : PushListPosition(*TextBox\Text()): SetWave(*TextBox) : PopListPosition(*TextBox\Text()) : EndIf
        If Blink : SetBlink(*TextBox) : EndIf
        If ColorBlink : SetColorBlink(*TextBox) : EndIf
        If Rainbow : SetRainbow(*TextBox) : EndIf
        *TextBox\Text()\Color = Color
        *TextBox\Text()\Opacity = Opacity
        *TextBox\Text()\Zoom = Zoom
        *TextBox\Text()\X = *TextBox\CursorX
        *TextBox\Text()\Y = *TextBox\CursorY
        If *TextBox\CursorY + *Font\FontInto\Height * Zoom > *TextBox\Height
          *TextBox\Text()\ClipHeight = *Font\FontInto\Height - (*Font\FontInto\Height - (*TextBox\Height - *TextBox\CursorY) / Zoom)
        Else
          *TextBox\Text()\ClipHeight = *Font\FontInto\Height 
        EndIf
        *TextBox\Text()\Line = *TextBox\CurentLine
        *TextBox\CursorX + GetTextWidth(*Font,Text$,Zoom)
        If *TextBox\Flag
          AligneText(*TextBox)
        EndIf
      EndIf
    EndIf
  EndProcedure
  
  Procedure AligneText(*TextBox.TextBox)
    Protected DeltaX
    If *TextBox\Flag = #PB_Text_Center
      DeltaX = (*TextBox\Width - *TextBox\CursorX) / 2
    Else
      DeltaX = *TextBox\Width - *TextBox\CursorX
    EndIf
    ForEach *TextBox\Text()
      If *TextBox\Text()\Line = *TextBox\CurentLine
        *TextBox\Text()\X =  DeltaX
        DeltaX + GetTextWidth(*TextBox\Text()\Font,*TextBox\Text()\Text,*TextBox\Text()\Zoom)
      EndIf
    Next
  EndProcedure
  
  Procedure AddLineToBox(*TextBox.TextBox)
    Protected DeltaLine
    *TextBox\CursorY + *TextBox\Text()\Font\FontInto\Height * *TextBox\Text()\Zoom
    *TextBox\CursorX = 0
    *TextBox\CurentLine + 1
    ForEach *TextBox\Text()
      If *TextBox\Text()\Wave\Target > DeltaLine
        DeltaLine = *TextBox\Text()\Wave\Target
      EndIf
    Next
    *TextBox\CursorY + DeltaLine
  EndProcedure
  
  Procedure SetShake(*TextBox.TextBox)
    *TextBox\Text()\Shake\Enable = 1
    *TextBox\Text()\Shake\Speed = ShakeSpeed
    *TextBox\Text()\Shake\Target = ShakeTarget
    *TextBox\CursorX + ShakeTarget
  EndProcedure
  
  Procedure SetWave(*TextBox.TextBox)
    Protected DeltaLine
    *TextBox\Text()\Wave\Enable = 1
    *TextBox\Text()\Wave\Speed = WaveSpeed
    *TextBox\Text()\Wave\Target = WaveTarget
    ForEach *TextBox\Text()
      If *TextBox\Text()\Line = *TextBox\CurentLine
        If *TextBox\Text()\Wave\Enable
          If *TextBox\Text()\Wave\Target >= WaveTarget
            ProcedureReturn
          Else
            If *TextBox\Text()\Wave\Target > DeltaLine
              DeltaLine = *TextBox\Text()\Wave\Target
            EndIf
          EndIf
        EndIf
      EndIf
    Next
    DeltaLine = WaveTarget - DeltaLine
    ForEach *TextBox\Text()
      If *TextBox\Text()\Line = *TextBox\CurentLine
        *TextBox\Text()\Y + DeltaLine
      EndIf
    Next
    *TextBox\CursorY + DeltaLine
  EndProcedure
    
  Procedure SetBlink(*TextBox.TextBox)
    *TextBox\Text()\Blink\Enable = 1
    *TextBox\Text()\Blink\Speed = BlinkSpeed
  EndProcedure
  
  Procedure SetColorBlink(*TextBox.TextBox)
    *TextBox\Text()\Blink\Enable = 2
    *TextBox\Text()\Blink\Speed = BlinkSpeed
    *TextBox\Text()\Blink\Color = BlinkColor
  EndProcedure
  
  Procedure SetRainbow(*TextBox.TextBox)
    *TextBox\Text()\Rainbow\Enable = 1
    *TextBox\Text()\Rainbow\Speed = RainbowSpeed
    *TextBox\Text()\Rainbow\RainbowStep = RainbowStep
  EndProcedure
  
  Procedure MakeShake(*TextBox.TextBox)
    *TextBox\Text()\Shake\Delta + *TextBox\Text()\Shake\Speed
    If *TextBox\Text()\Shake\Delta >= *TextBox\Text()\Shake\Target
      *TextBox\Text()\Shake\Speed = - *TextBox\Text()\Shake\Speed
    ElseIf *TextBox\Text()\Shake\Delta <= - *TextBox\Text()\Shake\Target
      *TextBox\Text()\Shake\Speed =  Abs(*TextBox\Text()\Shake\Speed)
    EndIf
    ProcedureReturn *TextBox\Text()\Shake\Delta
  EndProcedure
  
  Procedure MakeWave(*TextBox.TextBox,Delta)
    If Delta = 1
      *TextBox\Text()\Wave\Delta + *TextBox\Text()\Wave\Speed
      If *TextBox\Text()\Wave\Delta >= *TextBox\Text()\Wave\Target
        *TextBox\Text()\Wave\Delta = 0
      EndIf
    EndIf
    ProcedureReturn *TextBox\Text()\Wave\Target * Sin(2 * #PI / *TextBox\Text()\Wave\Target * (Delta+ *TextBox\Text()\Wave\Delta))
  EndProcedure
  
  Procedure MakeRainbow(*TextBox.TextBox,Delta)
    Protected Result.f,H.f,R,G,B
    If Delta = 1
      *TextBox\Text()\Rainbow\Delta + *TextBox\Text()\Rainbow\Speed
      If *TextBox\Text()\Rainbow\Delta > #PI * 2
        *TextBox\Text()\Rainbow\Delta = 0
      EndIf
    EndIf
    Result =Cos((Delta * *TextBox\Text()\Rainbow\RainbowStep + *TextBox\Text()\Rainbow\Delta))
    Result = Degree(#PI * (Result+1))
    H = Result / 60
    Select Result
      Case 0 To 59
        R = 255 : G = Mod(H,2) * 255 : B = 0
      Case 60 To 119
        R = (1-(Mod(H,2)-1)) * 255 : G = 255 : B = 0
      Case 120 To 179
        R = 0 : G = 255 : B = Mod(H,2) * 255
      Case 180 To 239
        R = 0 : G = (1-(Mod(H,2)-1)) * 255 : B = 255
      Case 240 To 299
        R = Mod(H,2) * 255 : G = 0 : B = 255
      Case 300 To 360
        R = 255 : G = 0 : B = (1-(Mod(H,2)-1)) * 255
    EndSelect
    ProcedureReturn RGB(R,G,B)
  EndProcedure
  
  Procedure MakeBlink(*TextBox.TextBox)
    *TextBox\Text()\Blink\Count + 1
    If *TextBox\Text()\Blink\Count = *TextBox\Text()\Blink\Speed
      *TextBox\Text()\Blink\State = (*TextBox\Text()\Blink\State + 1) % 2
      *TextBox\Text()\Blink\Count = 0
    EndIf
    If *TextBox\Text()\Blink\State
      ProcedureReturn *TextBox\Text()\Color
    Else
      If *TextBox\Text()\Blink\Enable = 1 ; Perform if tag is Blik
        ProcedureReturn -2
      Else ; Perform if tag is BlinkColor
        ProcedureReturn *TextBox\Text()\Blink\Color
      EndIf
    EndIf
  EndProcedure
  
EndModule


;-------------------------------------------------------------------------------------------
;----------------------------------Exemple of use-------------------------------------------
;-------------------------------------------------------------------------------------------
CompilerIf #PB_Compiler_IsMainFile
  InitSprite()
  OpenWindow(0,0,0,800,300,"",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
  OpenWindowedScreen(WindowID(0),0,0,800,300);,0,0,0,#PB_Screen_NoSynchronization)
  SetFrameRate(60)
  Define a.f = 1 , b.f = 1
  fnt=PureBF::LoadBitmapFont("Arial.afg")
  time = ElapsedMilliseconds()
  box = PureBF::CreateTextBox(400,100,300,150,#PB_Text_Center)
  box2 = PureBF::CreateTextBox(30,150,300,150,#PB_Text_Right)
  PureBF::SetBlinkColor($FF2200)
  PureBF::AddTextBoxString(box,fnt,"Ceci est un essais de ${shake} phrase {\} longue pour ${blink} voir {\} ",0.25,255)
  PureBF::SetBlinkSpeed(60)
  PureBF::AddTextBoxString(box,fnt,"si le ${Wave} retour ${colorblink} à la ligne {\} est pris en compte.",0.25,255,#Red)
  PureBF::AddTextBoxString(box2,fnt,"Une deuxième ${rainbow} ${wave} textbox avec d'autres effets {\} est-ce que ça fonctionne aussi ?",0.25,140) 
  Repeat
    ClearScreen($000000)
    PureBF::DisplayText(fnt,10,10,"Testouille "+#LF$+"???",0.25,255)
    PureBF::DisplayText(fnt,10,PureBF::GetTextHeight(fnt,"Testouille "+#LF$+"???",0.25)+10,"Là aussi !!",0.33,100,RGB(128,130,12))
    PureBF::DisplayText(fnt,PureBF::GetTextWidth(fnt,"Testouille "+#LF$+"???",0.25)+10+PureBF::GetTextWidth(fnt," ",0.25),10,"Ca marche !!",0.25,128,128)
    PureBF::DisplayText(fnt,10,100,"Яабвгдеёжзийкл",0.25,255)
    FPS + 1
    PureBF::DisplayText(fnt,650,10,"FPS : "+FPSCount,0.25,255)
;     PureBF::MoveTextBox(box,a,b,#PB_Relative)
;     If PureBF::GetTextBoxX(box)  >= 400
;       a = - Random(30,10)/10
;     ElseIf PureBF::GetTextBoxX(box) <= 200
;       a = Random(30,10)/10
;     EndIf
;     If PureBF::GetTextBoxY(box) >= 150
;       b = - Random(20,10)/10
;     ElseIf PureBF::GetTextBoxY(box) <= 50
;       b = Random(20,10)/10
;     EndIf
    PureBF::DisplayTextBox(box)
    PureBF::DisplayTextBox(box2)
    If ElapsedMilliseconds() - time >= 1000
      FPSCount = FPS : FPS = 0 : time = ElapsedMilliseconds()
    EndIf
    FlipBuffers()
  Until WindowEvent() = #PB_Event_CloseWindow
CompilerEndIf


Enjoy !
Last edited by Papala on Wed Dec 12, 2018 4:12 pm, edited 4 times in total.
User avatar
RSBasic
Moderator
Moderator
Posts: 1218
Joined: Thu Dec 31, 2009 11:05 pm
Location: Gernsbach (Germany)
Contact:

Re: Pure BitmapFont

Post by RSBasic »

Image
Image
Image
Papala
User
User
Posts: 38
Joined: Wed Sep 12, 2012 5:09 pm

Re: Pure BitmapFont

Post by Papala »

Little Update : I'd replace the tag named "Snake" by "Wave" I don't even know why did I chose this name...
Add the "Flag" parameter to the CreateTextBox() procedure wich can be #PB_Text_Center or #PB_Text_Right (or juste ignore) to center or aligne on the right the text of the TextBox.

Edit : add the tag rainbow, SetRainbowAttribut(Speed,RStep) can be use to define the rainbow effect. Speed is how fast will the effect move RStep is the collor difference between 2 letter (base one the color wheel). (Speed default is 0.04, RStep 0.1)
Papala
User
User
Posts: 38
Joined: Wed Sep 12, 2012 5:09 pm

Re: Pure BitmapFont

Post by Papala »

Update : Some little bug fix and no more pointer use, if you set #PBF_Compatibility = 1 and modify the LoadBitmapFont() procedure it should work with Spider Basic. I do not have SB for now, if someone is intrested to try it, pleas tell me if that work ^^"
Post Reply