It is currently Mon Aug 21, 2017 8:31 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 3 posts ] 
Author Message
 Post subject: Point Font Mesh...
PostPosted: Sat Apr 15, 2017 12:32 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Sat Feb 19, 2011 10:06 am
Posts: 669
Location: Denmark
Code:
;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


_________________
“Tell me and I forget. Teach me and I remember. Involve me and I learn.”
— Benjamin Franklin
Current configurations: Windows 7/10, Intel 6800K, Gtx 970, 32 gb ram.


Last edited by DK_PETER on Sun Apr 16, 2017 6:28 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Point Font Mesh...
PostPosted: Sun Apr 16, 2017 7:46 am 
Offline
Addict
Addict

Joined: Sun Jun 25, 2006 7:28 pm
Posts: 1252
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.


Top
 Profile  
Reply with quote  
 Post subject: Re: Point Font Mesh...
PostPosted: Sun Apr 16, 2017 6:35 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Sat Feb 19, 2011 10:06 am
Posts: 669
Location: Denmark
A little oopsie had crept into the example above (screen width) - fixed.

Here's an extended version:

Code:
;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

_________________
“Tell me and I forget. Teach me and I remember. Involve me and I learn.”
— Benjamin Franklin
Current configurations: Windows 7/10, Intel 6800K, Gtx 970, 32 gb ram.


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 3 posts ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 2 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye