' Make mono bitmap custom font on FreeBASIC
' Support character code : chr(&H20) - chr(&H7f)
'
' Usage: make_mono_font.exe INPUT_FONT.bmp OUTPUT_FONT.bmp
'
' by mieki256
' License : CC0 / Public Domain
' Last updated: <2024/02/12 20:25:39 +0900>

Const START_CHR = &H20
Const END_CHR   = &H7f

Const SCRW = 800
Const SCRH = 600
Dim As Integer sdepth = 32

If Command(1) = "" And Command(2) = "" Then
    Print "Usage: " & Command(0) & " INPUT.bmp OUTPUT.bmp" : End
End If

Dim As String infilename  = Command(1)
Dim As String outfilename = Command(2)

Dim As Integer f
Dim As Long w, h

' open bitmap file
f = FreeFile()
Open infilename For Binary Access Read As #f
If Err > 0 Then Print "Error: Can not open file" : End

' get bitmap width and height
Get #f, 19, w    ' get width
Get #f,   , h    ' get height
Close #f

ScreenRes SCRW, SCRH, sdepth

' load base font image
Dim As Any Ptr base_font = ImageCreate(w, h, RGB(0, 0, 0))
bload infilename, base_font

Print "Load : " & infilename

' create new font image
Dim As Any Ptr out_font = ImageCreate(w, h + 1, RGB(255, 0, 255))
Put out_font, (0, 1), base_font, PSet

' get custom font header address
Dim As ubyte Ptr headerp
ImageInfo out_font, , , , , headerp

' set header
headerp[0] = 0
headerp[1] = START_CHR  ' first character code
headerp[2] = END_CHR    ' end character code

' get 1 character Width
Dim As Integer cw = Int(w / (END_CHR - START_CHR + 1))
For i As Integer = 0 To (END_CHR - START_CHR)
    headerp[3 + i] = cw
Next i

bsave outfilename, out_font

color RGB(255, 255, 255), RGB(0, 0, 0)
Print "Save : " & outfilename
Print "Push Any Key"
sleep

ImageDestroy out_font
ImageDestroy base_font