Point Font Mesh...

Everything related to 3D programming
User avatar
DK_PETER
Addict
Addict
Posts: 898
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Point Font Mesh...

Post by DK_PETER »

Code: Select all

;Point font
;By DK_PETER
DeclareModule _Font
  Declare.i Init()
  Declare.i Resolution(width.i = -1, height.i = -1)
  Declare.i Run()
EndDeclareModule

Module _Font
  Structure _Obj
    id.i
    ms.i
  EndStructure
  Global ob._Obj
  
  Structure _Gad
    txt.i
    create.i
    save.i
    font.i
  EndStructure
  Global g._Gad
  
  Structure _bVar
    ev.i
    w.i
    h.i
    win.i
    scr.i
    cam.i
    quit.i
    fon.i
    tmfon.i
  EndStructure
  Global b._bVar
  
  Structure _Nav
    x.f
    y.f
    z.f
  EndStructure
  Global n._Nav
  
  Declare.i CreateButton()
  Declare.i FontButton()
  Declare.i SaveButton()
  Declare.i Create(Im.i)
  Declare.i DoFont()
  
  Procedure.i Init()
    Protected Ready.i = #True
    If InitEngine3D(#PB_Engine3D_DebugLog) = 0
      MessageRequester("Engine error!", "Unable to initialize the engine")
      ProcedureReturn #False
    EndIf
    If InitSprite() = 0
      MessageRequester("Sprite error!", "Unable to initialize the Sprite")
      ProcedureReturn #False
    EndIf    
    If InitKeyboard() = 0
      MessageRequester("Keyboard error", "Unable To initialize keyboard")
      ProcedureReturn #False
    EndIf
    ProcedureReturn #True
  EndProcedure
  
  Procedure.i Resolution(width.i = -1, height.i = -1)
    Protected num.i, x.i
    num = ExamineDesktops()
    If width = -1
      For x = 0 To num - 1
        b\w + DesktopWidth(x)
      Next
    Else
      b\w = width
    EndIf
    If height = -1
      b\h = DesktopHeight(0)
    Else
      b\h = width
    EndIf
    b\win = OpenWindow(#PB_Any, 0, 0, b\w, b\h, "Point Font Mesh creator V0.01 - by DK_PETER (Arrow keys to rotate and +/- keys to zoom)", #PB_Window_ScreenCentered)
    b\scr = OpenWindowedScreen(WindowID(b\win), 0, 0, b\w, b\h-100)
    g\txt = StringGadget(#PB_Any, 5, b\h-90, 300, 30, "")
    g\font = ButtonGadget(#PB_Any, 308, b\h-90, 100, 30, "Font")
    g\create = ButtonGadget(#PB_Any, 410, b\h-90, 100, 30, "Create")
    g\save   = ButtonGadget(#PB_Any, 512, b\h-90, 100, 30, "Save")
    GadgetToolTip(g\txt, "Type text to convert")
    BindGadgetEvent(g\create, @CreateButton())
    BindGadgetEvent(g\font, @FontButton())
    BindGadgetEvent(g\save, @SaveButton())
    b\fon = LoadFont(#PB_Any, "Arial", 72, #PB_Font_Bold)
    b\tmfon = LoadFont(#PB_Any, "Arial", 12,#PB_Font_Bold)
    SetGadgetFont(g\txt, FontID(b\tmfon))
    SetGadgetText(g\txt, "TEXT TEST!")
    ;Window part_done...
    b\cam = CreateCamera(#PB_Any, 0, 0, 100, 100)
   EndProcedure
  
  Procedure.i Run()
    Repeat  
      Repeat
        b\ev = WindowEvent()
        If b\ev = #PB_Event_CloseWindow : b\quit = #True : EndIf
      Until b\ev = 0
      ExamineKeyboard()
      
        If KeyboardPushed(#PB_Key_Up)
          n\x = -0.5
        ElseIf KeyboardPushed(#PB_Key_Down)
          n\x = 0.5
        Else
          n\x = 0
        EndIf
        If KeyboardPushed(#PB_Key_Left)
          n\y = 0.5
        ElseIf KeyboardPushed(#PB_Key_Right)
          n\y = -0.5
        Else
          n\y = 0
        EndIf
        If KeyboardPushed(#PB_Key_Add)
          n\z = 0.1
        ElseIf KeyboardPushed(#PB_Key_Subtract)
          n\z = -0.1
        Else
          n\z = 0
        EndIf
        If IsEntity(ob\id)
          MoveEntity(ob\id, 0, 0, n\z)
          RotateEntity(ob\id, n\x, n\y, 0, #PB_Relative)
        EndIf

      RenderWorld()
      
      FlipBuffers()
      
      ExamineKeyboard()
      
    Until KeyboardPushed(#PB_Key_Escape) Or b\quit = #True
    
  EndProcedure
  
  Procedure.i CreateButton()
    Protected ret.i
    im = DoFont()
    ret = Create(im)
  EndProcedure
  
  Procedure.i FontButton()
    Protected res.i
    res = FontRequester("Arial", 12, 0)
    If res
      If IsFont(b\fon) : FreeFont(b\fon) : EndIf
      If IsFont(b\tmfon) : FreeFont(b\tmfon) : EndIf
      b\fon = LoadFont(#PB_Any,SelectedFontName(), SelectedFontSize(), SelectedFontStyle())
      b\tmfon = LoadFont(#PB_Any,SelectedFontName(), 10, SelectedFontStyle())
      SetGadgetFont(g\txt, FontID(b\tmfon))
    EndIf
  EndProcedure
  
  Procedure.i SaveButton()
    Protected ret.i, nam.s
    nam = SaveFileRequester("Save mesh", "font", "Mesh (*.mesh)|*.mesh",0)
    If nam <> ""
      SaveMesh(ob\ms, nam + ".mesh")
    EndIf
  EndProcedure
  
  Procedure.i DoFont()
    Protected tm.i, im.i
    tm = CreateImage(#PB_Any, 10, 10)
    StartDrawing(ImageOutput(tm))
    DrawingFont(FontID(b\fon))
    w = TextWidth(GetGadgetText(g\txt))
    h = TextHeight(GetGadgetText(g\txt))
    StopDrawing()
    FreeImage(tm)
    im = CreateImage(#PB_Any, w+3, h+3, 32, 0)
    StartDrawing(ImageOutput(im))
    DrawingFont(FontID(b\fon))
    DrawingMode(#PB_2DDrawing_Transparent)
    DrawText(1, 1, GetGadgetText(g\txt), $FF00FF)
    StopDrawing()
    ProcedureReturn im  
  EndProcedure
  
  Procedure.i Create(Im.i)
    Protected w.i, h.i, x.i, y.i, dw.f, dh.f
    w = ImageWidth(Im) : h = ImageHeight(Im)
    ;Free old...
    If IsEntity(ob\id) : FreeEntity(ob\id) : EndIf
    If IsMesh(ob\ms) : FreeMesh(ob\ms) : EndIf
    
    Protected Dim c.i(w, h)
    StartDrawing(ImageOutput(Im))
    For y = 0 To h-1
      For x = 0 To w-1
        If Point(x,y) = $FF00FF
          c(x,y) = 1
        Else
          c(x,y) = 0
        EndIf
      Next x
    Next y
    StopDrawing()
    dw = ((w/2)*-1)/30
    dh = ((h/2)*-1)/30
    ob\ms = CreateMesh(#PB_Any, #PB_Mesh_PointList)
    For y = 1 To h
      For x = 1 To w
        If c(x, y) = 1
          MeshVertexPosition(dw+x/30, dh+y/30, 0.05)
          MeshVertexPosition(dw+x/30, dh+y/30,-0.05) ;comment this out for one layer only
        EndIf
      Next x
    Next y
    FinishMesh(ob\ms)
    ;UpdateMeshBoundingBox(ob\ms)
    CreateEntity(ob\id, MeshID(ob\ms), #PB_Material_None, 0, 0, -20)
    RotateEntity(ob\id, 180, 0, 0)
    FreeImage(Im)
    ProcedureReturn #True
  EndProcedure
EndModule

If _Font::Init() = #True
  _Font::Resolution()
  _Font::Run()
EndIf

Last edited by DK_PETER on Sun Apr 16, 2017 6:28 pm, edited 1 time in total.
Current configurations:
Ubuntu 20.04/64 bit - Window 10 64 bit
Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
applePi
Addict
Addict
Posts: 1404
Joined: Sun Jun 25, 2006 7:28 pm

Re: Point Font Mesh...

Post by applePi »

Thank you DK_PETER for this utility , this is a great idea to convert fonts to a cloud of points, and then to save it to a mesh file. i have used a chinese words from google trans and saved it to a mesh, loading it again in another program is a great experience.
User avatar
DK_PETER
Addict
Addict
Posts: 898
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Point Font Mesh...

Post by DK_PETER »

A little oopsie had crept into the example above (screen width) - fixed.

Here's an extended version:

Code: Select all

;Point font Extended
;By DK_PETER
DeclareModule _Font
  Declare.i Init()
  Declare.i Resolution(width.i = -1, height.i = -1)
  Declare.i Run()
EndDeclareModule

Module _Font
  #DIV = 50.0
  Structure _Obj
    id.i
    ma.i
    ms.i
    tx.i
  EndStructure
  Global ob._Obj
  
  Structure _Gad
    txt.i
    create.i
    save.i
    font.i
    spac.i
    laye.i
    olin.i
    mat.i
  EndStructure
  Global g._Gad
  
  Structure _bVar
    ev.i
    w.i
    h.i
    win.i
    scr.i
    cam.i
    quit.i
    fon.i
    tmfon.i
  EndStructure
  Global b._bVar
  
  Structure _Nav
    x.f
    y.f
    z.f
  EndStructure
  Global n._Nav
  
  Declare.i CreateButton()
  Declare.i FontButton()
  Declare.i SaveButton()
  Declare.i Create(Im.i)
  Declare.i OutLine()
  Declare.i DoFont()
  Declare.i Layers()
  Declare.i SpaceBetween()
  Declare.i CreateTextures()
  
  Global ol.i = #False, Spacing.f = 0.05, layer.i = 1
  
  Macro RanCol
    RGB(Random(255,10), Random(255,50), Random(255,10))
  EndMacro
  
  Procedure.i Init()
    Protected Ready.i = #True
    If InitEngine3D(#PB_Engine3D_DebugLog) = 0
      MessageRequester("Engine error!", "Unable to initialize the engine")
      ProcedureReturn #False
    EndIf
    If InitSprite() = 0
      MessageRequester("Sprite error!", "Unable to initialize the Sprite")
      ProcedureReturn #False
    EndIf    
    If InitKeyboard() = 0
      MessageRequester("Keyboard error", "Unable To initialize keyboard")
      ProcedureReturn #False
    EndIf
    ProcedureReturn #True
  EndProcedure
  
  Procedure.i Resolution(width.i = -1, height.i = -1)
    Protected num.i, x.i, ypos.i
    num = ExamineDesktops()
    If width = -1
      For x = 0 To num - 1
        b\w + DesktopWidth(x)
      Next
    Else
      b\w = width
    EndIf
    If height = -1
      b\h = DesktopHeight(0)
    Else
      b\h = height
    EndIf
    ypos = b\h / 20
    b\win    = OpenWindow(#PB_Any, 0, 0, b\w, b\h, "Point Font Mesh creator V0.01 - by DK_PETER (Arrow keys to rotate and +/- keys to zoom)", #PB_Window_ScreenCentered)
    b\scr    = OpenWindowedScreen(WindowID(b\win), 0, 0, b\w, b\h-ypos)
    g\txt    = StringGadget(#PB_Any, 5, b\h - ypos, 300, 30, "")
    g\font   = ButtonGadget(#PB_Any, 308, b\h - ypos, 100, 30, "Font")
    g\create = ButtonGadget(#PB_Any, 410, b\h - ypos, 100, 30, "Create")
    g\save   = ButtonGadget(#PB_Any, 512, b\h - ypos, 100, 30, "Save")
    g\laye   = StringGadget(#PB_Any, 614, b\h - ypos, 20, 30, Str(layer), #PB_String_Numeric|#ES_CENTER)  
    g\spac   = StringGadget(#PB_Any, 638, b\h - ypos, 40, 30, StrF(Spacing, 2), #PB_String_Numeric|#ES_CENTER)
    g\olin   = CheckBoxGadget(#PB_Any, 684, b\h - ypos, 80, 30, "Outlined")
    g\mat    = ButtonGadget(#PB_Any, 770, b\h - ypos, 100, 30, "Add Material")
    GadgetToolTip(g\laye, "Type number of layers (1 to 6)")
    GadgetToolTip(g\spac, "Type space number between layers(0.001 to 2.00)")
    GadgetToolTip(g\txt, "Type text to convert")
    GadgetToolTip(g\mat, "Adds a random material to entity")
    BindGadgetEvent(g\create, @CreateButton())
    BindGadgetEvent(g\font, @FontButton())
    BindGadgetEvent(g\save, @SaveButton())
    BindGadgetEvent(g\laye, @Layers())
    BindGadgetEvent(g\spac, @SpaceBetween())
    BindGadgetEvent(g\olin, @OutLine())
    BindGadgetEvent(g\mat, @CreateTextures())
    b\fon = LoadFont(#PB_Any, "Arial", 72, #PB_Font_Bold)
    b\tmfon = LoadFont(#PB_Any, "Arial", 12,#PB_Font_Bold)
    SetGadgetFont(g\txt, FontID(b\tmfon))
    SetGadgetText(g\txt, "TEXT TEST!")
    ;Window part_done...
    b\cam = CreateCamera(#PB_Any, 0, 0, 100, 100)
  EndProcedure
  
  Procedure.i Run()
    Repeat  
      Repeat
        b\ev = WindowEvent()
        If b\ev = #PB_Event_CloseWindow : b\quit = #True : EndIf
      Until b\ev = 0
      ExamineKeyboard()
      
      If KeyboardPushed(#PB_Key_Up)
        n\x = -1
      ElseIf KeyboardPushed(#PB_Key_Down)
        n\x = 1
      Else
        n\x = 0
      EndIf
      If KeyboardPushed(#PB_Key_Left)
        n\y = 1
      ElseIf KeyboardPushed(#PB_Key_Right)
        n\y = -1
      Else
        n\y = 0
      EndIf
      If KeyboardPushed(#PB_Key_Add)
        n\z = 0.5
      ElseIf KeyboardPushed(#PB_Key_Subtract)
        n\z = -0.5
      Else
        n\z = 0
      EndIf
      If IsEntity(ob\id)
        MoveEntity(ob\id, 0, 0, n\z)
        RotateEntity(ob\id, n\x, n\y, 0, #PB_Relative)
      EndIf
      
      RenderWorld()
      
      FlipBuffers()
      
      ExamineKeyboard()
      
    Until KeyboardPushed(#PB_Key_Escape) Or b\quit = #True
    
  EndProcedure
  
  Procedure.i CreateButton()
    Protected ret.i
    im = DoFont()
    ret = Create(im)
  EndProcedure
  
  Procedure.i FontButton()
    Protected res.i
    res = FontRequester("Arial", 12, 0)
    If res
      If IsFont(b\fon) : FreeFont(b\fon) : EndIf
      If IsFont(b\tmfon) : FreeFont(b\tmfon) : EndIf
      b\fon = LoadFont(#PB_Any,SelectedFontName(), SelectedFontSize(), SelectedFontStyle())
      b\tmfon = LoadFont(#PB_Any,SelectedFontName(), 10, SelectedFontStyle())
      SetGadgetFont(g\txt, FontID(b\tmfon))
    EndIf
  EndProcedure
  
  Procedure.i SpaceBetween()
    Protected sp.f = ValF(GetGadgetText(g\spac))
    If sp < 0.0 : sp = 0.0 : SetGadgetText(g\spac, "0.0") : EndIf
    If sp > 2.0 : sp = 2.0 : SetGadgetText(g\spac, "2.0")  : EndIf
    Spacing = sp
  EndProcedure
  
  Procedure.i SaveButton()
    Protected ret.i, nam.s
    nam = SaveFileRequester("Save mesh", "font", "Mesh (*.mesh)|*.mesh",0)
    If nam <> ""
      SaveMesh(ob\ms, nam + ".mesh")
    EndIf
  EndProcedure
  
  Procedure.i DoFont()
    Protected tm.i, im.i, tx.s = GetGadgetText(g\txt)
    tm = CreateImage(#PB_Any, 10, 10)
    StartDrawing(ImageOutput(tm))
    DrawingFont(FontID(b\fon))
    w = TextWidth(tx)
    h = TextHeight(tx)
    StopDrawing()
    FreeImage(tm)
    im = CreateImage(#PB_Any, w, h, 32, 0)
    StartDrawing(ImageOutput(im))
    DrawingFont(FontID(b\fon))
    DrawingMode(#PB_2DDrawing_Transparent)
    If ol  = #True
      DrawText(0, 0, tx, $FF00FF)
      DrawText(6, 0, tx, $FF00FF)
      DrawText(0, 4, tx, $FF00FF)
      DrawText(6, 4, tx, $FF00FF)
      DrawText(3, 2, tx, $0)
    Else
      DrawText(0, 0, tx, $FF00FF)
    EndIf
    StopDrawing()
    ProcedureReturn im  
  EndProcedure
  
  Procedure.i OutLine()
    If GetGadgetState(g\olin) = #PB_Checkbox_Checked
      ol = #True
    Else
      ol = #False
    EndIf
  EndProcedure
  
  Procedure.i Layers()
    Protected Index.i
    If GetGadgetText(g\laye) = "" : SetGadgetText(g\laye, "1") : EndIf
    Index = Val(GetGadgetText(g\laye))
    If Index = 0 : Index = 1 : EndIf
    If index > 6 : index = 6 : EndIf
    layer = Index
  EndProcedure
  
  Procedure.i CreateTextures()
    Protected x.i
    If IsEntity(ob\id) > 0
      If IsMaterial(ob\ma) > 0 : FreeMaterial(ob\ma) : EndIf
      If IsTexture(ob\ma) > 0 : FreeTexture(ob\tx) : EndIf
      ob\tx = CreateTexture(#PB_Any, 128, 128)
      StartDrawing(TextureOutput(ob\tx))
      If Random(100, 0) < 50
        If Random(100,50) < 50
          For x = 0 To 128 Step 2
            Box(x, 0, 2, 128, RanCol)
          Next x
        Else
          For x = 0 To 128 Step 2
            Box(0, x, 128, 2, RanCol)
          Next x
        EndIf
      Else
        DrawingMode(#PB_2DDrawing_Gradient)
        FrontColor(RanCol) : BackColor(RanCol)
        BoxedGradient(0, 0, 128, 128)
        Box(0, 0, 128, 128)
      EndIf
      StopDrawing()
      ob\ma = CreateMaterial(#PB_Any, TextureID(ob\tx))
      MaterialBlendingMode(ob\ma, #PB_Material_Add)
      SetEntityMaterial(ob\id, MaterialID(ob\ma))
    EndIf
  EndProcedure
  
  Procedure.i Create(Im.i)
    Protected w.i, h.i, x.i, y.i, dw.f, dh.f, cx.i, begin.f, pos.f
    w = ImageWidth(Im) : h = ImageHeight(Im)
    If IsEntity(ob\id) : FreeEntity(ob\id) : EndIf
    If IsMesh(ob\ms) : FreeMesh(ob\ms) : EndIf
    If IsMaterial(ob\ma) : FreeMaterial(ob\ma) : EndIf
    If IsTexture(ob\tx) : FreeTexture(ob\tx) : EndIf
    Protected Dim c.i(w, h)
    StartDrawing(ImageOutput(Im))
    For y = 1 To h-1
      For x = 1 To w-1
        If Point(x,y) = $FF00FF 
          c(x,y) = 1
        Else
          c(x,y) = 0
        EndIf
      Next x
    Next y
    StopDrawing()
    dw = ((w/2)*-1)/#DIV
    dh = ((h/2)*-1)/#DIV
    begin = ((Spacing * Layer) / 2) * -1
    ob\ms = CreateMesh(#PB_Any, #PB_Mesh_PointList)
    For cx = 1 To layer
      pos = begin + (Spacing*cx)
      For y = 1 To h
        For x = 1 To w
          If c(x, y) = 1
            MeshVertexPosition(dw+x/#DIV, dh+y/#DIV, pos)
          EndIf
        Next x
      Next y
    Next cx
    BuildMeshTangents(ob\ms)
    FinishMesh(ob\ms)
    UpdateMeshBoundingBox(ob\ms)
    CreateEntity(ob\id, MeshID(ob\ms), #PB_Material_None, 0, 0, -20)
    RotateEntity(ob\id, 180, 0, 0)
    FreeImage(Im)
    ProcedureReturn #True
  EndProcedure
EndModule

If _Font::Init() = #True
  _Font::Resolution()
  _Font::Run()
EndIf
Current configurations:
Ubuntu 20.04/64 bit - Window 10 64 bit
Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
Post Reply