FreeBASIC FBTrueType(描画画面に日本語を表示)

#include once "FBTrueType.bi"

' test of TTPrint with wstring

dim as integer maxw=800,maxh=600
screenres maxw,maxh,32
const fontfile = "ＭＳ 明朝.ttf"
chdir exepath()

' load the font
var font = FontLoad(fontfile)
if font<0 then
  print "error: loading: " & fontfile & " " & ErrorText(font)
  beep : sleep : end 1
end if

dim as wstring * 20 russian = "Привет, мир!"
dim as wstring * 20 greek   = "Καλημέρα κόσμε!"
dim as wstring * 20 Japanese   = "こんにちは世界！"
dim as integer y=10
for i as integer = 0 to 11
  if i Mod 3=0 then
    TTPrint font,32,y,russian,rgb(i*23,255,255-i*23),16+i*4
  elseif i Mod 3=1 then
    TTPrint font,32,y,greek,rgb(i*23,255,255-i*23),16+i*4
  else
    TTPrint font,32,y,Japanese,rgb(i*23,255,255-i*23),16+i*4
  end if 
  y+=16+i*4
next
sleep

' 文字列を TrueType フォントで表示
sub TTPrint overload(byval font as long, _
                     byval x as long,byval y as long, _
                     byref txt as string, _
                     byval col as ulong=rgb(255,255,255), _
                     byval size as long=24)
  dim as FontProps  fProps
  dim as GlyphProps gProps
  dim as long maxw,maxh,bytes,cx=x,cy=y
  if screenptr()=0 then return
  screeninfo maxw,maxh,,bytes
  if bytes<>4 then return
  if size<4 then return
  var nChars=len(txt) : if nChars<1 then return
  if FontPorperties(font, size, fprops) then return
  nChars-=1
  for i as long = 0 to nChars
    var char = txt[i]
    if char<33 then
      if char=32 then cx+=size\4
    else
      var index1 = GlyphIndex(font, char)
      if index1<>GLYPH_NOT_FOUND then
        dim as long index2 = iif(i<nChars,GlyphIndex(font,txt[i+1]),0)
        if index2=GLYPH_NOT_FOUND then index2=0
        if GlyphProperties(font, fProps, gProps, index1,index2) = 0 then
          if cx+gProps.w>=maxw then cy += fProps.advanceHeight : cx=x
          var AlphaChannel = GlyphImageCreate(font, fProps, gProps,index1)
          if AlphaChannel then
            var glyph = ImageCreate(gProps.w,gProps.h,col)
            put glyph,(0,0),AlphaChannel,ALPHA
            put (cx,cy + gProps.y),glyph,ALPHA
            ImageDestroy glyph
            ImageDestroy AlphaChannel
          endif
          cx += gProps.advanceWidth + gProps.kernAdvance
        endif
      endif
    endif
  next
end sub

' wstring を TrueType フォントで表示
sub TTPrint (byval font as long, _
             byval x as long, byval y as long, _
             byref txt as wstring, _
             byval col as ulong=rgb(255,255,255), _
             byval size as long=24)
  dim as FontProps  fProps
  dim as GlyphProps gProps
  dim as long maxw,maxh,bytes,cx=x,cy=y
  if screenptr()=0 then return
  screeninfo maxw,maxh,,bytes
  if bytes<>4 then return
  if size<4 then return
  var nChars=len(txt) : if nChars<1 then return
  if FontPorperties(font, size, fprops) then return
  nChars-=1
  for i as long = 0 to nChars
    var char = txt[i]
    if char<33 then
      if char=32 then cx+=size\4
    else
      var index1 = GlyphIndex(font, char)
      if index1<>GLYPH_NOT_FOUND then
        dim as long index2 = iif(i<nChars,GlyphIndex(font,txt[i+1]),0)
        if index2=GLYPH_NOT_FOUND then index2=0
        if GlyphProperties(font, fProps, gProps, index1,index2) = 0 then
          if cx+gProps.w>=maxw then cy += fProps.advanceHeight : cx=x
          var AlphaChannel = GlyphImageCreate(font, fProps, gProps,index1)
          if AlphaChannel then
            var glyph = ImageCreate(gProps.w,gProps.h,col)
            put glyph,(0,0),AlphaChannel,ALPHA
            put (cx,cy + gProps.y),glyph,ALPHA
            ImageDestroy glyph
            ImageDestroy AlphaChannel
          end if
          cx += gProps.advanceWidth + gProps.kernAdvance
        endif
      endif
    endif
  next
end sub

'FBTrueType static Win/Lin 32/64-bit
'by owen » Jun 15, 2019 8:09 
'https://www.freebasic.net/forum/viewtopic.php?f=14&t=25083&start=60#p261726
'"c:\windows\fonts\*.ttf")一覧を表示して、カーソル選択したフォントで Hello World を表示

#include once "FBTrueType.bi"
screenres 1000,400,32

Dim As String fontfile,fontfiles()
Dim As Integer font_c
Dim As Long font
fontfile=Dir("c:\windows\fonts\*.ttf")
Do
   If fontfile="" Then
      Exit Do
   Else
      font = FontLoad("c:\windows\fonts\" & fontfile)
      If font>0 Then
         font_c+=1
         ReDim Preserve fontfiles(font_c)
         fontfiles(font_c)=fontfile
         FontDestroy()
      EndIf
      fontfile=Dir()
   EndIf
Loop
For i As Integer = 1 To font_c
   fontfile = Mid(fontfiles(i),1,Len(fontfiles(i))-4)
   font = FontLoad("c:\windows\fonts\" & fontfiles(i))
   TTPrint font,10,20*i-20, fontfile,rgb(255,255,255),20
   FontDestroy()
Next


Dim As Integer mr,mx,my,myp,mw,mwp,mb,mc
Dim As Integer wy
Dim As Integer selected_font,selected_font_p
Do
   Select Case InKey
      Case Chr(27),Chr(255)+"k"
         Exit Do
   End Select
   mr=GetMouse(mx,my,mw,mb,mc)
   If mr=0 And mw<>mwp Then
      If mw>mwp Then
         wy+=20
      Else
         wy-=20
      EndIf
      If wy>0 Then wy=0
      If wy<font_c*20*-1+400 Then wy=font_c*20*-1+400
      mwp=mw
   EndIf
   mw=0
   selected_font=(my+10)/20+Abs(wy)/20
   If selected_font<>selected_font_p Then
      selected_font_p=selected_font
      ScreenLock
      Cls
      For i As Integer = 1 To font_c
         Select Case 20*i-20+wy
            Case -20 To 400
               fontfile = Mid(fontfiles(i),1,Len(fontfiles(i))-4)
               font = FontLoad("c:\windows\fonts\" & fontfiles(i))
               If i=selected_font Then
                  TTPrint font,10,20*i-20+wy, fontfile,rgb(255,0,255),20
               Else
                  TTPrint font,10,20*i-20+wy, fontfile,rgb(255,255,255),20
               EndIf
               
               FontDestroy()
         End Select
      Next
      font = FontLoad("c:\windows\fonts\" & fontfiles(selected_font))
      TTPrint font,500,20, "Hello World",rgb(255,255,255),80
      FontDestroy()
      ScreenUnLock
   End If
   Sleep 1
Loop

' ttf examples with sdl and fb native
' by thrive4 » Nov 17, 2022 12:26
' https://www.freebasic.net/forum/viewtopic.php?p=295676#p295676
'Last edited by thrive4 on Dec 02, 2022 16:09, edited 5 times in total.
'Japanese by Makoto Watanabe 2022/12/10
'Shift-JIS でも UNICODE でもコンパイル・実行可
'
' fb truetype lib can be found at
' https://www.freebasic.net/forum/viewtopic.php?t=25083
#Include Once "fbgfx.bi"
#Include Once "FBTrueType.bi"
#Include Once "vbcompat.bi"
#If __FB_LANG__ = "fb"
Using fb '' constants and structures are stored in the FB namespace in lang fb
#EndIf

Dim e As Event
Dim running         As boolean = TRUE
Dim screenwidth     As Integer = 1280*4/5
Dim screenheight    As Integer = 720*4/5
Dim fullscreen      As boolean = FALSE
Dim desktopw        As Integer
Dim desktoph        As Integer
Dim desktopr        As Integer
' get desktop info
' デスクトップの情報を取得
ScreenInfo desktopw, desktoph,,,desktopr
Print "desktopw= "; desktopw; " desktoph= "; desktoph;" desktopr= ";desktopr

' font 
Dim Shared ttffontsize As Integer
Dim ttffontcolor    As ULong = RGB(255, 255, 255)
Dim logocolor       As ULong = RGB(55, 55, 55)
Dim textmarkercolor As ULong = RGB(75, 0, 0) ' used for custom text marker as underline etc
'Dim ttffont         As String  = ExePath + "\gisha.ttf"
Const ttffont = "ＭＳ 明朝.ttf"
Dim fontsizeclock   As Integer
Dim fontsizedate    As Integer
Dim fontsizelogo    As Integer

' supplement message with fb system metrics or...
' wmic cpu list /format:list
' lscpu for unix
Dim os As WString * 20 = "unknown"
#Ifdef __FB_WIN32__
    os = "windows" 
#EndIf
#Ifdef __FB_UNIX__
    os = "unix" 
#EndIf
Dim ttfmessagea As WString * 20 = ":cpu cores "
Dim ttfmessageb As WString * 20 = ":ram "
Dim ttfmessagec As WString * 20 = ":プラットホーム " & os
Dim ttfmessaged As WString * 20 = ":fb バージョン " & __FB_VERSION__
Dim ttfmessagee As WString * 20 = ":取り消し "

' used for dimensions and location of text
' テキストの寸法と位置に使う
Dim As Integer iW, iH
Dim As Integer posx, sposx
Dim As Integer posy, sposy

' setup clock and date display
' 時計と日付表示の設定
Dim Shared clockposx As Integer
Dim Shared clockposy As Integer
Dim datetime As Double
Dim dateformat As WString * 20 = "yyyy/mm/dd"
Dim timeformat As WString * 20 = "hh:mm:ss"

' used for text input
' テキスト入力に使う
Dim inptext As WString * 20 = ""
Dim bkminptext As WString * 20 = ""

' load the font
' フォントを読み込む
Var font = FontLoad(ttffont)
If font < 0 Then
  Print "error: loading: " & ttffont & " " & ErrorText(font)
End If

' ghetto text orientation fx
' slightly tweaked from https://www.freebasic.net/forum/viewtopic.php?t=12068&hilit=invert+value+put
' code by counting_pine
Sub put_hflip(ByVal x As Integer, ByVal y As Integer, ByVal img As Any Ptr)
    Dim As Integer w, h
    If ImageInfo( img, w, h ) <> 0 Then Exit Sub
    For x2 As Integer = 0 To w-1
        Put (x + x2, y), img, (w - 1 - x2, 0) - Step(0, h - 1), Alpha
    Next x2
End Sub

Sub put_vflip(ByVal x As Integer, ByVal y As Integer, ByVal img As Any Ptr)
    Dim As Integer w, h
    If ImageInfo( img, w, h ) <> 0 Then Exit Sub        
    For y2 As Integer = 0 To h - 1
        Put (x, y + y2), img, (0, h - 1 - y2) - Step(w - 1, 0), Alpha
    Next y2
End Sub

' work around for getting size of text with font
' フォントでテキストのサイズを取得するための回避策
Dim Shared txtwidth As Long

Sub ttprintex OverLoad(ByVal font As Long, _
                     ByVal x As Long, ByVal y As Long, _
                     ByRef txt As WString, _
                     ByVal col As ULong = RGB(255,255,255), _
                     ByRef fliptype As String, _
                     ByVal size As Long = 24)
  Dim As FontProps  fProps
  Dim As GlyphProps gProps
  Dim As Long maxw, maxh, bytes, cx = x, cy = y, bmky = cy
  If ScreenPtr() = 0 Then Return
  ScreenInfo maxw, maxh,, bytes
  If bytes <> 4 Then Return
  If size < 4 Then Return
  txt = Trim(txt)  
  Var nChars = Len(txt) : If nChars < 1 Then Return
  If FontPorperties(font, size, fprops) Then Return
  nChars -= 1
  txtwidth = 0
  For i As Long = 0 To nChars
    Var char = txt[i]
    If char < 33 Then
      If char = 32 Then cx += size * 0.25f
    Else
      Var index1 = GlyphIndex(font, char)
      If index1 <> GLYPH_NOT_FOUND Then
        Dim As Long index2 = IIf(i < nChars,GlyphIndex(font, txt[i + 1]), 0)
        If index2 = GLYPH_NOT_FOUND Then index2 = 0
        If GlyphProperties(font, fProps, gProps, index1, index2) = 0 Then
          If cx + gProps.w >= maxw Then cy += fProps.advanceHeight : cx = x
          Var AlphaChannel = GlyphImageCreate(font, fProps, gProps, index1)
          If AlphaChannel Then
            Var glyph = ImageCreate(gProps.w , gProps.h, col)
            Put glyph, (0,0), AlphaChannel, Alpha
            ' added flip and rotate text orientation
            ' テキストの向きの反転と回転を追加
            Select Case fliptype
                Case "fb_flip_horizontal"
                    put_hflip(cx, cy + gProps.y,glyph)
                Case "fb_flip_vertical"
                    put_vflip(cx, cy + gProps.y,glyph)
                Case "fb_flip_rotate"
                    'put_hflip(x, bmky,glyph)
                    Put(x, bmky + gProps.y), glyph, Alpha
                Case Else
                    Put(cx, cy + gProps.y), glyph, Alpha
            End Select
            bmky += fProps.advanceHeight * 0.8f
            ImageDestroy glyph
            ImageDestroy AlphaChannel
          EndIf
          cx += gProps.advanceWidth + gProps.kernAdvance
        EndIf
      EndIf
    EndIf
  txtwidth = cx
  Next
End Sub

' create curved boxes
' 曲がった箱を作る
' lifted from joytest.zip by coderjeff
' see https://www.freebasic.net/forum/viewtopic.php?p=54746&hilit=joytest#p54746
'fb_fillrect x loc,y loc, height, width, arc size, fill color
Sub fb_fillrect _
  ( _
    ByVal x As Integer, _
    ByVal y As Integer, _
    ByVal w As Integer, _
    ByVal h As Integer, _
    ByVal r As Integer, _
    ByVal c As Integer _
  )

  Circle (x + r    , y + r        ), r, c, , , , f
  Circle (x + r    , y + h - r - 1), r, c, , , , f
  Circle (x + w - r - 1, y + r    ), r, c, , , , f
  Circle (x + w - r - 1, y + h - r - 1), r, c, , , , f

  Line (x, y + r) - (x + w - 1, y + h - r), c, bf
  Line (x + r, y) - (x + w - r, y + h - 1), c, bf

End Sub
 
initscreen:
If fullscreen Then
    ScreenRes screenwidth, screenheight, 32, 1, GFX_NO_FRAME
Else
    ScreenRes screenwidth, screenheight, 32, 1, GFX_WINDOWED
End If
' (screenwidth * 0.25f) * 14 = 14pt approximation of fontsize proportional to screensize
ttffontsize     = Fix(screenheight / (screenwidth * 0.25f) * 14)
fontsizeclock   = Fix(screenheight / (screenwidth * 0.25f) * 16)
fontsizedate    = Fix(screenheight / (screenwidth * 0.25f) * 13)
fontsizelogo    = Fix(screenheight / (screenwidth * 0.25f) * 104)

' main loop
Do
    Dim datetime As Double = Now()
    Dim offsetcursor As Integer = Len(inptext)
    If (ScreenEvent(@e)) Then
        Select Case e.type
            Case EVENT_WINDOW_CLOSE
                Exit Do
            Case EVENT_KEY_PRESS
            Case EVENT_KEY_RELEASE
                Select Case e.scancode
                   Case SC_ESCAPE  'Esc キーで終了
                        Exit Do
                   Case SC_F11    'F11 で画面切替え
                        Select Case fullscreen
                            Case TRUE
                                screenwidth  = 1280*4/5
                                screenheight = 720*4/5
                                fullscreen = FALSE
                                GoTo initscreen
                            Case FALSE
                                screenwidth  = desktopw /5*2.7
                                screenheight = desktoph /5*2.7
                                fullscreen = TRUE
                                GoTo initscreen
                        End Select
                    Case SC_BACKSPACE
                        inptext = Left(inptext, offsetcursor - 1) + Mid(inptext, offsetcursor + 1)
                    Case SC_ENTER
                        bkminptext = inptext        
                    Case Else
                        inptext = inptext + Chr(e.ascii)
                End Select
            Case EVENT_WINDOW_CLOSE
                Exit Do
        End Select
    End If

  ScreenLock()
    Cls()
    ' clock
    clockposx = screenwidth  - 150
    clockposy = 30
    ttprintex font, clockposx, clockposy, Format(datetime, timeformat), ttffontcolor, "", fontsizeclock

    ' date
    ttprintex font, clockposx, clockposy + fontsizeclock, Format(datetime, dateformat), ttffontcolor, "", fontsizedate

    ' metrics
    ttprintex font, 10, 200, ttfmessagea, ttffontcolor, "", ttffontsize
    ttprintex font, 10, 200 + ttffontsize, ttfmessageb, ttffontcolor, "", ttffontsize
    ttprintex font, 10, 200 + ttffontsize * 2, ttfmessagec, ttffontcolor, "", ttffontsize
    ttprintex font, 10, 200 + ttffontsize * 3, ttfmessaged, ttffontcolor, "", ttffontsize

    ' fake underline with text marker
    ' テキストマーカー付きの偽の下線
    fb_fillrect   10, 200 + ttffontsize * 4, txtwidth, 1, 0, ttffontcolor
    ttprintex font, 10, 200 + ttffontsize * 4, ttfmessagee, ttffontcolor, "", ttffontsize

    ' fake striketrhough with text marker
    ' テキストマーカー付きの偽の取り消し線
    fb_fillrect   10, 200 + ttffontsize * 4.5, txtwidth, 1, 0, ttffontcolor

    ' text marker
    fb_fillrect   10, 200 + ttffontsize * 5, txtwidth, 3, 0, textmarkercolor

    ' logo
    ttprintex font, screenwidth * 0.5 - fontsizelogo * 0.5, screenheight * 0.5 - fontsizelogo * 0.5, "FB", logocolor, "", fontsizelogo

    ' rotated text
    ttprintex font, screenwidth * 0.5 - ttffontsize * 4.75, screenheight * 0.5 - ttffontsize * 2.7, "縦書き　ROTATED", ttffontcolor, "fb_flip_rotate", ttffontsize

    ' text input
    ttprintex font, screenwidth * 0.5 - ttffontsize * Len(inptext) * 0.25, (screenheight * 0.5 - ttffontsize * 0.5) + 200, inptext & "|", ttffontcolor, "", ttffontsize
    If bkminptext <> "" Then
        ttprintex font, screenwidth * 0.5 - ttffontsize * Len(bkminptext) * 0.25, (screenheight * 0.5 - ttffontsize * 0.5) + 250, bkminptext, ttffontcolor, "", ttffontsize
    End If

    ' scrolling text
    ttprintex font, sposx, screenheight * 0.95 - ttffontsize * 0.95, "scrolling text 流れる文字列 scrolling text 流れる文字列 scrolling text",  ttffontcolor, "", ttffontsize
    If sposx > 0 Then
        sposx = sposx - 1
    Else
        sposx = (screenwidth * 0.5 - ttffontsize * 0.5)
    End If

  ScreenUnlock()

  ' reduce cpus usage  
  Sleep(15, 1)
Loop

End