mieki256's diary

• FB_ScreenSaverKit.bas ... スクリーンセーバ作成時に必要になる処理をまとめたファイル
• Mambazo Doodle.bas ... スクリーンセーバの描画処理部分。これを改造して自分なりのスクリーンセーバを作る。
• Mambazo Doodle.exe ... スクリーンセーバの実行形式。拡張子を .scr にすればスクリーンセーバになる。
• Mambazo Doodle.rc ... リソースファイル。スクリーンセーバの設定ダイアログのレイアウトが記述してある
• Mambazo Doodle.xml ... 謎。リソースファイルから内包するように指定されていた

fbc "Mambazo Doodle.bas" "Mambazo Doodle.rc" -s gui

• 「-s gui」は、「GUIアプリとして生成せよ」という指定。これをつけないと、生成したアプリを実行するたびにDOS窓が開いてしまう。

copy "Mambazo Doodle.exe" "Mambazo Doodle.scr"

• FB_ScreenSaverKit.bas を include して、
• StartScreenSaver() を呼んで、
• SaverInfo.IsClosing が TRUE にならない限り、ひたすら描画に専念する。

• コマンドラインオプションを判別して、設定モード(/c)、プレビュー表示モード(/p xxxx)、フルスクリーン表示モード(/s) で処理を分けてる。ただ、この実装はちょっとバグがある。それについては後述。
• 設定モードの時は、リソースファイル Mambazo Doodle.rc に記述されてるダイアログを表示して、ダイアログが閉じられたら終了する。それ以外は何もしない。
• プレビュー表示モード、フルスクリーン表示モードの時は、ウインドウを新規作成する。
• そのウインドウで、キー入力やマウス操作があったか等を調べて、何か操作されてたらウインドウ破棄メッセージを送る。
• タイマーを設定して、一定時間毎に、bitmapバッファの内容をウインドウにコピーしている。このbitmapバッファに、前述の描画処理担当部分(Mambazo Doodle.bas)が、せっせと描画しているらしい。
• ウインドウの破棄メッセージが来たら、SaverInfo.IsClosing を TRUE にしている。

• メインメモリ上のbitmapバッファに対して、描画処理担当が描画。ウインドウ担当は、そのバッファ内容を、一定の時間間隔で自分のウインドウ内にコピーしている。
• スクリーンセーバの終了するタイミングは、ウインドウ担当が、SaverInfo.IsClosing を通じて知らせてくれる。描画処理担当は、SaverInfo.IsClosing が TRUE になったら終了処理をする。

• /c を与えられた場合、設定ダイアログを表示。
• /p xxxx を与えられた場合、xxxx(ウインドウハンドルを10進数で示した数値) を親とした子ウインドウを新規作成して、その新規作成したウインドウにスクリーンセーバの内容を描画する。
• /s を与えられた場合、フルスクリーン表示でスクリーンセーバを描画する。
• 何も与えられてない場合、設定ダイアログを表示。

Sub StartScreenSaver()
    Select Case LCase(Command(1))
    Case "/c"
        ' Config
        StartConfigDialog()
        End
    Case "/p"
        ' Preview
        Dim As String tmpHWnd = Command(2)
        SaverInfo.IsPreview = TRUE
        If tmpHWND <> "" Then
            SaverInfo.hWndParent = Cast(HWND__ Ptr, CLng(Val(tmpHWnd)))
        End If
        SetupScreenMode()
        ThreadCreate(@WindowThread)
    Case "/s"
        ' Full screen
        SetupScreenMode()
        ThreadCreate(@WindowThread)
    Case Else
        ' No options. Config
        StartConfigDialog()
        End
    End Select
End Sub

• LCase() は、文字列を小文字化してくれる関数。
• Command() は、コマンドラインオプションが入っている。何も指定されてなかったら "" が返ってくる。
• "/p xxxx" が与えられた時、command(1) には "/p" が、command(2) には "xxxx" が入る。

fbc ssfbscrsample.bas ssfbscrsample.rc -s gui
copy ssfbscrsample.exe ssfbscrsample.scr

fbc -x ssfbscrsample.scr ssfbscrsample.bas ssfbscrsample.rc -s gui

• スクリーンセーバが32bit版アプリで、Windows が 64bit版の場合、C:\Windows\SysWOW64\ にコピー。
• スクリーンセーバが32bit版アプリで、Windows が 32bit版の場合、C:\Windows\System32\ にコピー。
• スクリーンセーバが64bit版アプリで、Windows が 64bit版の場合、C:\Windows\System32\ にコピー。

#include "fb_screensaverkit.bas"

' use mmsystem
#include "windows.bi"
#include "win/mmsystem.bi"

timeBeginPeriod(1)

Randomize Timer

Const MAX_FPS = 60.0
Const PI = 3.141592653

Dim As Double start_time, prev_time, now_time, next_time, delta, one_frame
Dim As Integer frame_count
Dim As String fps_text = "FPS"

Dim As Integer sw, sh

'Start the Screen Saver
StartScreenSaver

#If 1
' get screen size. width and height
ScreenInfo sw, sh
#Else
'You can also find the width & height of the screen by using SaverInfo.ScrWidth & SaverInfo.ScrHeight
sw = SaverInfo.ScrWidth
sh = SaverInfo.ScrHeight
#Endif

' init work
Dim As Double x, y, dx, dy, r
x = sw / 2.0
y = sh / 2.0
dx = (CDbl(sw) / MAX_FPS) * 0.6
dy = (CDbl(sh) / MAX_FPS) * 0.4
r = sh / 16.0

start_time = Timer
prev_time = start_time
frame_count = 0

' main loop
Do Until SaverInfo.IsClosing = True

    ' get delta
    now_time = Timer
    delta = now_time - prev_time
    prev_time = now_time
    next_time = now_time + (1.0 / MAX_FPS)
    If delta < 0 Then delta = 1.0 / MAX_FPS

    ' count FPS
    If now_time >= start_time Then
        If (now_time - start_time) >= 1.0 Then
            fps_text = Str(frame_count) & " FPS"
            start_time += 1.0
            frame_count = 0
        End If
    Else
        start_time = now_time
    End If
    frame_count += 1

    ' move ball position
    x += (dx * MAX_FPS * delta)
    y += (dy * MAX_FPS * delta)

    If (x <= (r / 2) And dx < 0) Or (x >= (sw - (r / 2)) And dx > 0) Then dx *= -1.0
    If (y <= (r / 2) And dy < 0) Or (y >= (sh - (r / 2)) And dy > 0) Then dy *= -1.0

    If SaverInfo.IsClosing <> True Then
        ' draw start
        ' ScreenLock

        ' clear screen
        ' Line (0, 0)-(sw, sh), Rgb(0, 0, 0), BF
        color RGB(0, 0, 0), RGB(0, 0, 0)
        cls

        ' draw ball
        circle (x, y), r, RGB(255, 0, 0), , , , F

        ' darw FPS
        Draw String ((sw - Len(fps_text) * 8) / 2, 10), fps_text, RGB(255, 255, 255)

        ' draw end
        ' ScreenUnlock
    End If

    ' sleep
    If Timer < next_time Then
        Dim As Double wait_time = (next_time - Timer) * 1000.0
        If wait_time > 0 Then
            sleep wait_time
        End If
    End If
Loop

timeEndPeriod(1)

/* Screensaver title */
STRINGTABLE
BEGIN
    1 "FreeBASIC Screensaver"
END

/* icon */
100 ICON "fbscricon.ico"

/* dialog */
FB_SCRNSAVER_ABOUT DIALOGEX 6, 18, 160, 62
STYLE DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU | DS_NOFAILCREATE
 FONT 12,"Arial"
CAPTION "FB Screensaver Sample"
BEGIN
    DEFPUSHBUTTON "OK" IDOK, 55, 40, 50, 14
    CTEXT "FB Screensaver Sample" -1, 0, 5, 160, 8
    CTEXT "Version 1.0" -1, 0, 15, 160, 8
END

1 24 "ssFBscrSample.xml"

• 描画担当がバッファに描画してる最中に、ウインドウ担当がバッファ内容をコピーしようとしたら、どうなるか。
• ウインドウ担当がバッファ内容をコピーしてる最中に、描画担当がバッファを書き換えようとしたら、どうなるか。

• スクリーンセーバが32bit版アプリで、Windows が 64bit版の場合、C:\Windows\SysWOW64\ にコピー。
• スクリーンセーバが32bit版アプリで、Windows が 32bit版の場合、C:\Windows\System32\ にコピー。
• スクリーンセーバが64bit版アプリで、Windows が 64bit版の場合、C:\Windows\System32\ にコピー。

• ScreenSaverProc() の中に、時間計測処理と、初期化処理、描画処理、終了処理を呼び出す部分を追加した。
• StartScreenSaver(time_msec) に、タイマーをセットする際のミリ秒値を指定できるようにした。ここで与えたミリ秒の間隔で画面が更新される。
• FPSもカウントしてる。SaverInfo.fps の中に、計測したFPSが入っている。

#include "fb_screensaverkit.bas"

' use mmsystem
#include "windows.bi"
#include "win/mmsystem.bi"

' global work
Type wk
    scrw As Integer
    scrh As Integer
    x As Double
    y As Double
    dx As Double
    dy As Double
    r As Double
    max_fps As Double
End Type

Dim Shared wk As wk

'--------------------
' Initialize work

Sub InitProc()

    ' get screen size. width and height
    ' ScreenInfo scrw, scrh
    wk.scrw = SaverInfo.ScrWidth
    wk.scrh = SaverInfo.ScrHeight
    wk.max_fps = SaverInfo.max_fps

    wk.x = wk.scrw / 2.0
    wk.y = wk.scrh / 2.0
    wk.dx = (CDbl(wk.scrw) / wk.max_fps) * 0.6
    wk.dy = (CDbl(wk.scrh) / wk.max_fps) * 0.4
    wk.r = wk.scrh / 16.0

    ' timeBeginPeriod(1)
End Sub

'--------------------
' Rendering

Sub Render(ByVal delta As Double)
    If delta >= 1.0 Then delta = 1.0 / wk.max_fps
    
    ' move ball position
    wk.x += (wk.dx * wk.max_fps * delta)
    wk.y += (wk.dy * wk.max_fps * delta)
    If (wk.x <= wk.r And wk.dx < 0) Or (wk.x >= (wk.scrw - wk.r) And wk.dx > 0) Then wk.dx *= -1.0
    If (wk.y <= wk.r And wk.dy < 0) Or (wk.y >= (wk.scrh - wk.r) And wk.dy > 0) Then wk.dy *= -1.0

    ' draw start

    ' clear screen
    ' Line (0, 0)-(scrw, scrh), Rgb(0, 0, 0), BF
    color RGB(0, 0, 0), RGB(0, 0, 0)
    cls

    ' draw ball
    circle (wk.x, wk.y), wk.r, RGB(255, 0, 0), , , , F

    ' Get and draw FPS
    Dim As String fpstext = Str(SaverInfo.fps) & "FPS"
    Draw String ((wk.scrw - Len(fpstext) * 8) / 2, 10), fpstext, RGB(255, 255, 255)
    fpstext = ""  ' destroying a string

    ' draw end
End Sub

'--------------------
' End process

Sub ExitProc()
    ' timeEndPeriod(1)
End Sub

' --------------------
' main routine

Randomize Timer

'Start the Screen Saver. Set timer XX sec
StartScreenSaver(14)

' Wait until the screensaver ends
Do Until SaverInfo.IsClosing = True
    sleep 10
Loop

• InitProc() : 初期化処理。スクリーンセーバ用ウインドウが作成されたタイミングで呼ばれる。
• Render(delta) : 描画処理。毎フレーム呼ばれる。delta に、前回フレームからの経過時間(単位は秒。小数点以下有り)が入っているので、座標更新処理に使える。
• ExitProc() : 終了処理。スクリーンセーバ用ウインドウが破棄されるタイミングで呼ばれる。

/* Screensaver title */
STRINGTABLE
BEGIN
    1 "FreeBASIC Screensaver 3"
END

/* icon */
100 ICON "fbscricon.ico"

/* dialog */
FB_SCRNSAVER_ABOUT DIALOGEX 6, 18, 160, 62
STYLE DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU | DS_NOFAILCREATE
 FONT 12,"Arial"
CAPTION "FB Screensaver Sample 3"
BEGIN
    DEFPUSHBUTTON "OK" IDOK, 55, 40, 50, 14
    CTEXT "FB Screensaver Sample 3" -1, 0, 5, 160, 8
    CTEXT "Version 1.0" -1, 0, 15, 160, 8
END

1 24 "ssfbscrsample3.xml"

' リソースにアクセスするために windows.bi を使う
#include "windows.bi"

' 画像読み込み用ライブラリ FBImage を使う
#include once "FBImage.bi"

' カレントディレクトリを exeファイルのある場所にする
chdir exepath()

' リソースにアクセスするための名前
Const res_name = "pngimage"

Dim As HRSRC hResInfo
Dim As HGLOBAL hResData
Dim As ubyte Ptr resPtr
Dim As DWORD resSize

' リソースを探す
hResInfo = FindResource(NULL, strptr(res_name), RT_RCDATA)
If hResInfo = Null Then
    Print "Error : Not found resource" : end
End If

' リソースを読み込み
hResData = LoadResource(0, hResInfo)
If hResData = Null Then
    Print "Error : Not load resource"
    FreeResource(hResData) : end
End If

' リソースのポインタを取得
resPtr = CPtr(ubyte Ptr, LockResource(hResData))
If resPtr = Null Then
    Print "Error : Not get resource pointer"
    FreeResource(hResData) : end
End If

' リソースのサイズを取得
resSize = SizeofResource(NULL, hResInfo)
If resSize = 0 Then
    Print "Error : Can not get resource size"
    FreeResource(hResData) : end
End If

' デスクトップ解像度を指定
Dim As Integer scrw = 512
Dim As Integer scrh = 288

' ウインドウサイズと色深度(bpp)を指定
screenres scrw, scrh, 32

' メモリ上にある画像データを読み込む。ポインタとバイト数を渡す
var img = LoadRGBAMemory(resPtr, resSize)

' リソースを解放
FreeResource(hResData)

' 画像を描画。RGB=(255, 0, 255) のピクセルは透明色として扱う
Put (16, 16), img, TRANS

' キー入力があるまで待ち続ける
sleep

' 画像を使い終わったので破棄
ImageDestroy img

pngimage    RCDATA      "image_png.png"

fbc loadpnginmemory.bas resource.rc

• FindResource() ... リソースを検索する。
• LoadResource() ... リソースを読み込む。
• LockResource() ... リソースのアドレスを取得する。
• SizeofResource() ... リソースのサイズを取得する。
• FreeResource() ... 読み込んだリソースを解放する。

• 上記のページで紹介されているソースをコピーして、bin2bas.bas というファイル名でソースを保存する。
• fbc bin2bas.bas と打てば bin2bas.exe が生成できる。
• 使い方は、bin2bas.exe INPUT_FILE。bin2bas.exe hoge.png と打てば、hoge.bi と hoge.bas が生成される。

bin2bas.exe test.bin

extern test_data(0 to 48-1) as ubyte

#include once "test.bi"

dim shared test_data(0 to 48-1) as ubyte = { _
&h0,&h1,&h2,&h3,&h4,&h5,&h6,&h7,&h8,&h9,&hA,&hB,&hC,&hD,&hE,&hF,&h10,&h11,&h12,&h13,&h14,&h15,&h16,&h17,&h18,&h19,&h1A,&h1B,&h1C,&h1D,&h1E, _
&h1F,&h20,&h21,&h22,&h23,&h24,&h25,&h26,&h27,&h28,&h29,&h2A,&h2B,&h2C,&h2D,&h2E,&h2F }

python bin2bas.py -i test.bin

' input file = test.bin

Dim As Integer test_bin_data_length = 48
Dim shared test_bin_data(0 To (test_bin_data_length - 1)) As ubyte

For i As Integer = 0 To (test_bin_data_length - 1)
    read test_bin_data(i)
Next i

DATA _
&H00,&H01,&H02,&H03,&H04,&H05,&H06,&H07,&H08,&H09,&H0a,&H0b,&H0c,&H0d,&H0e,&H0f, _
&H10,&H11,&H12,&H13,&H14,&H15,&H16,&H17,&H18,&H19,&H1a,&H1b,&H1c,&H1d,&H1e,&H1f, _
&H20,&H21,&H22,&H23,&H24,&H25,&H26,&H27,&H28,&H29,&H2a,&H2b,&H2c,&H2d,&H2e,&H2f

import struct
import argparse


def main():
    desc = "Cpnvert binary file to basic source"
    parser = argparse.ArgumentParser(description=desc)
    parser.add_argument("-i", "--input", help="Input binary file", required=True)
    args = parser.parse_args()

    data = []
    with open(args.input, "rb") as f:
        while True:
            b = f.read(1)
            if b:
                data.append(struct.unpack("B", b)[0])
            else:
                break

    dataname = args.input.replace(".", "_")
    dataname += "_data"
    lengthname = dataname + "_length"

    print("' input file = %s" % (args.input))
    print("")
    print("Dim As Integer %s = %d" % (lengthname, len(data)))
    print("Dim shared %s(0 To (%s - 1)) As ubyte" % (dataname, lengthname))
    print("")
    print("For i As Integer = 0 To (%s - 1)" % (lengthname))
    print("    read %s(i)" % (dataname))
    print("Next i")
    print("")
    print("DATA _")

    s = ""
    cnt = 0
    for i in range(len(data)):
        s += "&H%02x," % data[i]
        cnt += 1
        if cnt % 16 == 0:
            if cnt == len(data):
                print(s[:-1])
            else:
                print("%s _" % s)
            s = ""
    if s != "":
        print(s[:-1])


if __name__ == "__main__":
    main()

> python bin2bas.py --help
usage: bin2bas.py [-h] -i INPUT

Convert binary file to basic source

options:
  -h, --help            show this help message and exit
  -i INPUT, --input INPUT
                        Input binary file

python bin2bas.py -i image_png.png > image_png.bas

' input file = image_png.png

Dim As Integer image_png_png_data_length = 50344
Dim shared image_png_png_data(0 To (image_png_png_data_length - 1)) As ubyte

For i As Integer = 0 To (image_png_png_data_length - 1)
    read image_png_png_data(i)
Next i

DATA _
&H89,&H50,&H4e,&H47,&H0d,&H0a,&H1a,&H0a,&H00,&H00,&H00,&H0d,&H49,&H48,&H44,&H52, _
&H00,&H00,&H01,&H00,&H00,&H00,&H01,&H00,&H08,&H06,&H00,&H00,&H00,&H5c,&H72,&Ha8, _

' ...

&Hba,&H45,&Hf0,&H3f,&Hac,&H83,&H26,&H35,&H43,&H1b,&H66,&Hed,&H00,&H00,&H00,&H00, _
&H49,&H45,&H4e,&H44,&Hae,&H42,&H60,&H82

' 画像読み込み用ライブラリ FBImage を使う
#include once "FBImage.bi"

' ubytes配列の画像データバイナリ
#include "image_png.bas"

' カレントディレクトリを exeファイルのある場所にする
chdir exepath()

' デスクトップ解像度を指定
Dim As Integer scrw = 512
Dim As Integer scrh = 288

' ウインドウサイズと色深度(bpp)を指定
screenres scrw, scrh, 32

' メモリ上にある画像データを FBImage で読み込む。ポインタとバイト数を渡す
Dim As Long size = image_png_png_data_length
var img = LoadRGBAMemory(@(image_png_png_data(0)), size)

' 画像を描画。RGB=(255, 0, 255) のピクセルは透明色として扱う
Put (16, 16), img, TRANS

' キー入力があるまで待ち続ける
sleep

' 画像を使い終わったので破棄
ImageDestroy img

fbc loadpngbin2bas.bas

' 画像読み込み用ライブラリ FBImage を使う
#include once "FBImage.bi"

#define IMAGEDATA_SIZE 50344
' #define IMAGEDATA_SIZE 297

' 画像バイナリをアセンブラの記述で内包する
Asm

.data
.global imgdata
imgdata:
.incbin "image_png.png"

End Asm

' カレントディレクトリを exeファイルのある場所にする
chdir exepath()

' デスクトップ解像度を指定
Dim As Integer scrw = 512
Dim As Integer scrh = 288

' ウインドウサイズと色深度(bpp)を指定
screenres scrw, scrh, 32

' 画像バイナリのアドレスを取得している？
Dim As Any Ptr image

Asm

push OFFSET imgdata
pop  [image]

End Asm

' メモリ上にある画像データを FBImage で読み込む。ポインタとバイト数を渡す
var img = LoadRGBAMemory(image, IMAGEDATA_SIZE)

' 画像を描画。RGB=(255, 0, 255) のピクセルは透明色として扱う
Put (16, 16), img, TRANS

' キー入力があるまで待ち続ける
sleep

' 画像を使い終わったので破棄
ImageDestroy img

ld -r -b binary -o image_png.o image_png.png

or

objcopy -I binary -O elf32-i386 -B i386 image_png.png image_png.o

fbc loadpngld.bas image_png.o

' 画像読み込み用ライブラリ FBImage を使う
#include once "FBImage.bi"

' カレントディレクトリを exeファイルのある場所にする
chdir exepath()

' リンクしたバイナリオブジェクトの先頭アドレスと終了アドレス
#If defined( __FB_WIN32__ ) And Not defined( __FB_64BIT__ )
' Windows 32bit
extern image_png_png_start alias "binary_image_png_png_start" as byte
extern image_png_png_end alias "binary_image_png_png_end" as byte
#Else
' Windows 64bit and other
extern image_png_png_start alias "_binary_image_png_png_start" as byte
extern image_png_png_end alias "_binary_image_png_png_end" as byte
#endif

' デスクトップ解像度を指定
Dim As Integer scrw = 512
Dim As Integer scrh = 288

' ウインドウサイズと色深度(bpp)を指定
screenres scrw, scrh, 32

' バイナリデータの先頭アドレスとサイズを取得
dim as byte ptr imgdata = @image_png_png_start
dim as Integer imgdata_length = @image_png_png_end - @image_png_png_start

' メモリ上にある画像データを FBImage で読み込む。ポインタとバイト数を渡す
var img = LoadRGBAMemory(imgdata, imgdata_length)

' 画像を描画。RGB=(255, 0, 255) のピクセルは透明色として扱う
Put (16, 16), img, TRANS

' キー入力があるまで待ち続ける
sleep

' 画像を使い終わったので破棄
ImageDestroy img

> objdump -t image_png.o

image_png.o:     file format pe-i386

 SYMBOL TABLE:
[  0](sec  1)(fl 0x00)(ty   0)(scl   2) (nx 0) 0x00000000 _binary_image_png_png_start
[  1](sec -1)(fl 0x00)(ty   0)(scl   2) (nx 0) 0x0000c4a8 _binary_image_png_png_size
[  2](sec  1)(fl 0x00)(ty   0)(scl   2) (nx 0) 0x0000c4a8 _binary_image_png_png_end

• 開始アドレスを示すシンボルは _binary_hoge_png_start に。
• 終了アドレスを示すシンボルは _binary_hoge_png_end に。

32bit:
binary_image_png_png_start
binary_image_png_png_end

64bit:
_binary_image_png_png_start
_binary_image_png_png_end

• __FB_WIN32__ は、Windows上でコンパイルする際に定義されるシンボル。
• __FB_64BIT__ は、64bitアプリとしてコンパイルする際に定義されるシンボル。

' put flip test 2
' 1 line 毎にループ処理して反転描画する。

#ifdef __FB_WIN32__
' Windowsの場合、mmsystemを利用
#include "windows.bi"
#include "win/mmsystem.bi"
#endif

' fbgfxモードを使う
#Include "fbgfx.bi"
Using fb

' Draw h v flip image
'
' x, y : Position, img : Bitmap image pointer
' sx, sy : Source position, sw, sh : Source width, height
' flag : 0 (normal), 1 (H Flip), 2 (V Flip), 3 (HV Flip)
Sub PutEx( _
      ByVal x As Integer, ByVal y As Integer, _
      ByVal img As Any Ptr, _
      ByVal sx As Integer, ByVal sy As Integer, _
      ByVal sw As Integer, ByVal sh As Integer, _
      ByVal flag As Integer )

    sw -= 1
    sh -= 1
    
    Select Case flag
    Case 0
        ' draw normal
        Put (x, y), img, (sx, sy) - Step(sw, sh), TRANS
    Case 1
        ' draw H flip image
        Dim As Integer xx = sx + sw
        For i As Integer = 0 To sw
            Put (x, y), img, (xx, sy) - step(0, sh), TRANS
            x += 1
            xx -= 1
        Next i
    Case 2
        ' draw V flip image
        Dim As Integer yy = sy + sh
        For i As Integer = 0 To sh
            Put (x, y), img, (sx, yy) - step(sw, 0), TRANS
            y += 1
            yy -= 1
        Next i
    Case 3
        ' draw HV flip
        Dim As Integer yy = sy + sh
        For yi As Integer = 0 To sh
            Dim As Integer xx = sx + sw
            For xi As Integer = 0 To sw
                Put (x + xi, y + yi), img, (xx, yy) - step(0, 0), TRANS
                xx -= 1
            Next xi
            yy -= 1
        Next yi
    End Select
End Sub

' 時間計測用の変数
Dim As Double start_time, prev_time, now_time, delta, next_time
Dim As Integer frame_count
Dim As String fps_text = "FPS"

Dim As Integer scrw, scrh  ' ウインドウサイズ
Dim As Integer imgw, imgh  ' 画像サイズ

chdir exepath()  ' カレントディレクトリを exeファイルのある場所にする

' ウインドウサイズと色深度を指定
scrw = 512
scrh = 288
Screenres scrw, scrh, 32

' 画像読み込み。FreeBASIC標準のbmp読み込みを使う場合
Dim img As any ptr = ImageCreate(128, 64)
Bload "obj.bmp", img
imageinfo img, imgw, imgh  ' 画像の幅と高さを取得

#ifdef __FB_WIN32__
timeBeginPeriod(1)         ' タイマー精度を1msecに向上
#endif

Dim As Double MAX_FPS = 60.0  ' FPS
start_time = Timer            ' 開始時間を取得
prev_time = start_time
frame_count = 0

Dim As Boolean running = True
Dim As Double anime_t = 0.0
Dim As Double x, y
x = scrw / 2
y = scrh / 2

' メインループ
While (running)

    ' 前回フレームから何秒経過したか取得。単位は秒(小数点以下有り)
    now_time = Timer
    delta = now_time - prev_time
    prev_time = now_time
    next_time = now_time + (1.0 / MAX_FPS)
    If delta < 0 Then delta = (1.0 / MAX_FPS)

    If now_time >= start_time Then
        If (now_time - start_time) >= 1.0 Then
            ' 1秒経過したのでFPSを取得
            fps_text = "FPS: " & frame_count
            start_time += 1.0
            frame_count = 0
        End If
    Else
        start_time = now_time
    End If
    frame_count += 1

    ' ESCキー、qキー、ウインドウの閉じるボタンを検出
    Dim As String k = inkey$
    If k = Chr$(27) Or k = "q" Or k = Chr$(255) + "k" Then
        running = False  ' メインループ終了
    End If

    anime_t += delta  ' アニメ表示用カウンタを更新

    ScreenLock  ' 描画開始
    color RGB(255, 255, 255), RGB(52, 164, 255)
    cls         ' 画面クリア

    ' 画像を描画
    Dim As Integer n, sx, sy, sw, sh, px, py
    n = Int(anime_t / 0.5) Mod 4  ' value = 0 - 6
    sw = (imgw / 2)  ' 幅
    sh = imgh        ' 高さ
    sx = 0           ' 描画元 x
    sy = 0           ' 描画元 y
    px = x - (sw / 2)
    py = y - (sh / 2)

    Select Case n
    Case 0 : PutEx px, py, img, sx, sy, sw, sh, 0
    Case 1 : PutEx px, py, img, sx, sy, sw, sh, 1
    Case 2 : PutEx px, py, img, sx, sy, sw, sh, 3
    Case 3 : PutEx px, py, img, sx, sy, sw, sh, 2
    End Select

    ' 文字列を描画
    Draw String (10, 10), fps_text
    Draw String (scrw / 2 - (8 * 6), scrh * 0.8), "HELLO WORLD"

    ScreenUnlock ' 描画終了

    If Timer < next_time Then
        ' 本来の1フレーム時間がまだ経過してないので sleep させる
        Dim As Double wait_ms = (next_time - Timer) * 1000.0
        If wait_ms > 0.0 Then sleep wait_ms
    End If
Wend

While Inkey <> "": Wend  ' キーバッファを空にする
ImageDestroy img  ' 画像を使い終わったので破棄

#ifdef __FB_WIN32__
timeEndPeriod(1)  ' タイマー精度を本来のスペックに戻す
#endif

' Put Flipped! v1.0
' (C) 2008 Innova and Kristopher Windsor
'
' Fast Put() Alternative with Horizontal / Vertical Flipping - freebasic.net
' https://www.freebasic.net/forum/viewtopic.php?t=11374

#include once "fbgfx.bi"
#include once "putflipped.bi"

Screenres 800, 600, 32

' Create sample image
Function CreateSampleImage() As fb.image Ptr
    Dim As fb.image Ptr graphic = ImageCreate(320, 240, &HFFFFFFFF)
    For i As Integer = 1 To 10000
        Dim As Integer x = Rnd * 320
        Dim As Integer y = Rnd * 240
        Dim As Integer r = Rnd * 32
        Dim As ulong col = Rgb(Rnd * 256, Rnd * 256, Rnd * 256)
        If Rnd < 0.5 Then col = RGB(255, 0, 255)
        Circle graphic, (x, y), r, col, , , , F
    Next i
    Line graphic, (0, 0) - (319, 239), &HFF88FF88, B '1px border for clipping tests
    Return graphic
End Function

' main
Dim As fb.image Ptr graphic = CreateSampleImage()
Dim As Integer mx, my, mb

' main loop
Do
    Getmouse mx, my,, mb

    Screenlock
    color RGB(40, 80, 160), RGB(40, 80, 160)
    Cls
    putflipped(graphic, mx - 160, my - 120, (mb And 1) > 0, (mb And 2) > 0)
    Screenunlock

    Sleep 10
Loop Until Inkey = Chr(27)

ImageDestroy(graphic)

• マウスを動かすと、その位置に画像が表示される。
• 左ボタンで水平反転描画。
• 右ボタンで垂直反転描画。
• ESCキーで終了。

' imgput() sample

#include "imgput.bi"

screenres 512, 288, 32

Dim As Any Ptr p = ImageCreate(101, 101)
Bload "sprite.bmp", p

imgput( p, , 10 + 120 * 0, 10, 0   )
imgput( p, , 10 + 120 * 1, 10, 90  )
imgput( p, , 10 + 120 * 2, 10, 180 )
imgput( p, , 10 + 120 * 3, 10, 270 )

imgput( p, , 10 + 120 * 0, 130, TRANSFORM_HFLIP  )
imgput( p, , 10 + 120 * 1, 130, TRANSFORM_VFLIP  )
imgput( p, , 10 + 120 * 2, 130, TRANSFORM_D1FLIP )
imgput( p, , 10 + 120 * 3, 130, TRANSFORM_D2FLIP )

imagedestroy p
sleep

#include "MultiPut.bi"
'
' main
'
screenres 1024, 480, 32
dim as integer w, h
screeninfo w, h

' ...

' main

Dim As Any Ptr img = CreateSampleImage()

dim as single rotation(5)
dim as boolean transparent
dim as integer frames

while inkey()=""
    screenlock
    line (0, 0) - step(w - 1, h - 1), 0, BF
    draw string (32, 0), "Original"
    put (0,8), img, PSET

    dim as single x
    for i as integer = 1 to 6
        dim as single scale = i * .5
        x += scale * 100
        MultiPut ,x, 240, img, scale, scale, rotation(i - 1), transparent
        rotation(6 - i) += i * .25
    next
    screenunlock
    
    frames += 1
    if frames mod 60 = 0 then transparent = not transparent
    sleep 10
Wend

ImageDestroy(img)

;; ----------------------------------------
;; VBScript (basic-mode)
(pushnew '("\\.vbs$" . basic-mode) *auto-mode-alist*)

;; ----------------------------------------
;; basicモードの設定
;; C-. でキーワード補完
;; タブをスペースに

(require "basic-mode")

(add-hook 'ed::*basic-mode-hook*
          #'(lambda ()
              (set-tab-columns 4 (selected-buffer))
              (setq ed::*basic-indent-level* 4)
              (make-local-variable 'indent-tabs-mode)
              (setq indent-tabs-mode nil)
              ))

(define-key *basic-mode-map* #\C-. 'ed::basic-completion)

(pushnew '("\\.bi$" . basic-mode) *auto-mode-alist*)

' imgput() sample. RGB = (255, 0, 255) is transparent

#include "imgputt.bi"

#define BPP  32
'#define BPP  16
'#define BPP  8

screenres 512, 288, BPP
Dim As Any Ptr p = ImageCreate(101, 101)
Select Case BPP
Case 8 : Bload "sprite_8bit.bmp", p : color 16, 16 : cls
Case 16 : Bload "sprite_16bit.bmp", p
Case 32 : Bload "sprite_24bit.bmp", p
End Select

Dim As Integer mode = 0  ' 0 Trans, 1 Pset

' Draw
imgputt( p, , 10 + 120 * 0, 10, 0,   mode)
imgputt( p, , 10 + 120 * 1, 10, 90,  mode)
imgputt( p, , 10 + 120 * 2, 10, 180, mode)
imgputt( p, , 10 + 120 * 3, 10, 270, mode)

imgputt( p, , 10 + 120 * 0, 130, TRANSFORM_HFLIP,  mode )
imgputt( p, , 10 + 120 * 1, 130, TRANSFORM_VFLIP,  mode )
imgputt( p, , 10 + 120 * 2, 130, TRANSFORM_D1FLIP, mode )
imgputt( p, , 10 + 120 * 3, 130, TRANSFORM_D2FLIP, mode )

imagedestroy p
sleep

#include "imgputt.bi"
#include "putex.bi"

#define BPP  32
'#define BPP  16
'#define BPP  8

screenres 512, 288, BPP
Dim As Any Ptr p = ImageCreate(101, 101)
Select Case BPP
Case 32 : Bload "sprite_24bit.bmp", p
Case 16 : Bload "sprite_16bit.bmp", p
Case 8 : Bload "sprite_8bit.bmp", p : color 16, 16 : cls
End Select

Dim As Double starttime, t0, t1, t2
Dim As Integer max_count = 3000

Sub sub1(ByVal max_count As Integer, ByVal p As Any Ptr)
    For i As Integer = 0 To max_count
        Put (10, 10), p, Trans
        ' Put (10, 10), p, Pset
    Next i
End Sub

Sub sub2(ByVal max_count As Integer, ByVal p As Any Ptr)
    For i As Integer = 0 To max_count
        'imgputt( p, , 130, 10, TRANSFORM_HFLIP, 0 )
        'imgputt( p, , 130, 10, TRANSFORM_VFLIP, 0 )
        imgputt( p, , 130, 10, TRANSFORM_HFLIP Or TRANSFORM_VFLIP, 0 )
    Next i
End Sub

Sub sub3(ByVal max_count As Integer, ByVal p As Any Ptr)
    For i As Integer = 0 To max_count
        'PutEx(10, 130, p, 0, 0, 101, 101, 1)
        'PutEx(10, 130, p, 0, 0, 101, 101, 2)
        PutEx(10, 130, p, 0, 0, 101, 101, 3)
    Next i
End Sub

starttime = Timer
ScreenLock
sub1(max_count, p)
ScreenUnlock
t0 = Timer - starttime

sleep 1000

starttime = Timer
ScreenLock
sub2(max_count, p)
ScreenUnlock
t1 = Timer - starttime

sleep 1000

starttime = Timer
ScreenLock
sub3(max_count, p)
ScreenUnlock
t2 = Timer - starttime

sleep 1000

Print "Put     : " & t0 & " sec (100%)"
Print "imgputt : " & t1 & " sec (" & int((t1 / t0) * 100) & "%)"
Print "PutEx   : " & t2 & " sec (" & int((t2 / t0) * 100) & "%)"

imagedestroy p
sleep

• imgputt() は、メモリからメモリに値をコピーするものとして処理をしている。
• PutEx() は、横1ライン、もしくは縦1ライン毎に、Put() を使って逆方向に描画していく。水平垂直反転の時だけ、1ドット単位で Put() を呼んで描画する。

• 水平反転のみ、かつ、透明色有効の場合、Put() と比べて、imgputt() は5倍遅い。PutEx() は6倍遅い。
• 垂直反転のみ、かつ、透明色有効の場合、Put() と比べて、imgputt() は5倍遅い。PutEx() は2倍遅い。
• 水平垂直反転、かつ、透明色有効の場合、Put() と比べて、imgputt() は5倍遅い。PutEX() は135倍遅い。

fbc imgputt_test.bas
fbc imgputt_test2.bas

imgputt_test.exe 32
imgputt_test2.exe 32

imgputt_test.exe 8
imgputt_test2.exe 8

imgputt_test.exe 16
imgputt_test2.exe 16

fbc imgputt_test2.bas -gen gcc -O 3

• -gen gcc ... gcc を使って exe を生成
• -O 3 ... 最適化レベル 3 を指定。

#include once "imgputt.bi"

screenres 512, 288, 32
Dim As Any Ptr p = ImageCreate(288, 288)
Bload "obj_24bit.bmp", p

Put (10, 10), p, (0, 96) - Step(96, 96), Trans

imgputt(p, , 10, 10 + 100, TRANSFORM_VFLIP, IMGPUT_TRANS, 0, 96, 96, 96)

imagedestroy p
sleep

' load bitmap image file

#ifndef __LOADBITMAPIMAGE__
#define __LOADBITMAPIMAGE__

Function LoadBitmapImage(ByRef fname As Const string) As Any Ptr
    Dim As Integer f
    Dim As Long w, h

    ' open bitmap file
    f = FreeFile()
    Open fname For Binary Access Read As #f
    If Err > 0 Then Print "Error: Can not open file" : Return 0
    Get #f, 19, w    ' get width
    Get #f,   , h    ' get height
    Close #f

    ' Print "Bitmap : " & fname & "  (w,h)=(" & w & "," & h & ")"

    ' create image
    Dim As Any Ptr img = ImageCreate(w, h, RGB(0, 0, 0))
    If img = 0 Then Print "Error: Can not ImageCreate()" : Return 0

    ' load bitmap to image
    bload fname, img
    Return img
End Function

#endif

' get bitmap image size

#include "loadbitmapimage.bi"

ScreenRes 512, 288, 32

Dim As String fname = "obj_8bit.bmp"
'Dim As String fname = "obj_16bit.bmp"
'Dim As String fname = "obj_24bit.bmp"

' load bitmap image
Dim img As Any Ptr = LoadBitmapImage(fname)

' get image width, height, bpp
Dim As Integer w, h, bpp
ImageInfo(img, w, h, bpp)

Put (0, 0), img

Print "Load: " & fname & " (" & w & ", " & h & ")"
Print "Push Any Key"

ImageDestroy(img)
sleep

    Get #f, 19, w    ' get width
    Get #f,   , h    ' get height

screencontrol(SET_GL_2D_MODE, OGL_2D_MANUAL_SYNC)
screencontrol(SET_GL_SCALE, 4)

screenres scrw, scrh, 32, , GFX_OPENGL

#define NO_BLUR 1  'change to 1
'Const SCRW = 320 : Const SCRH = 180
Const SCRW = 320 : Const SCRH = 240

#include "fbgfx.bi"
Using fb

' set screen depth
Dim As Integer sdepth = 32
Select Case Command(1)
Case "8"  : sdepth = 8
Case "16" : sdepth = 16
Case "32" : sdepth = 32
End Select

' get desktop size
Dim As Integer dispw, disph
ScreenInfo dispw, disph

' get scale (Integer)
Dim As Integer dscale = Int(disph / SCRH)
If dscale > (dispw / SCRW) Then dscale = Int(dispw / SCRW)

' ge true screen size
Dim As Integer tscrw, tscrh
tscrw = dispw / dscale
tscrh = disph / dscale

If (tscrw * dscale) <> dispw Then tscrw += (dispw - (tscrw * dscale))
If (tscrh * dscale) <> disph Then tscrh += (disph - (tscrh * dscale))

screencontrol(SET_GL_2D_MODE, OGL_2D_MANUAL_SYNC)
screencontrol(SET_GL_SCALE, dscale)

ScreenRes tscrw, tscrh, sdepth, , GFX_OPENGL Or GFX_NO_FRAME

#if (NO_BLUR = 1)
#include "GL/gl.bi"
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST)
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST)
#endif

Dim As Double angle = 0.0
Dim As Boolean running = True

Const PI = 3.1415926535897932

' Main Loop

Do
    If Inkey <> "" Then running = False

    ' set true screen view size
    view (0, 0) - (tscrw - 1, tscrh - 1), RGB(0, 0, 0)

    ' set draw area size
    Dim As Integer ox, oy
    ox = (tscrw - SCRW) * 0.5
    oy = (tscrh - SCRH) * 0.5
    view (ox, oy) - (SCRW - 1 + ox, SCRH - 1 + oy), RGB(30, 60, 120)

    ' clear screen
    Color RGB(255, 255, 255), RGB(30, 60, 120)
    cls
    
    Circle (SCRW \ 2, SCRH \ 2), (SCRH \ 2 - 1), RGB(0, 255, 0)

    Dim As Integer x, y, r
    r = SCRH / 4
    x = (SCRW / 2 - r - 1) * Cos(angle * PI / 180.0) + (SCRW / 2)
    y = (SCRH / 2 - r - 1) * Sin(angle * PI / 180.0) + (SCRH / 2)
    Circle (x, y), r, RGB(0, 255, 255)

    Draw String (0, 0), Str(SCRW) & "x" & SCRH & " (" & tscrw & "x" & tscrh & ")x" & dscale, RGB(255, 255, 255)

    angle += 1.0

    sleep 10
    flip()  ' change double buffer
Loop While running

#include "fbgfx.bi"
Using fb

' ...

screencontrol(SET_GL_2D_MODE, OGL_2D_MANUAL_SYNC)
screencontrol(SET_GL_SCALE, dscale)

ScreenRes tscrw, tscrh, sdepth, , GFX_OPENGL Or GFX_NO_FRAME

#include "GL/gl.bi"
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST)
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST)

Do
    ' ...

    sleep 10
    flip()  ' change double buffer
Loop While running

• ScreenControl() で、SET_GL_2D_MODE や SET_GL_SCALE を設定。
• SET_GL_SCALE で拡大率を整数で指定。
• ScreenRes の最後で、GFX_OPENGL を指定。
• OpenGL利用時は flip() でダブルバッファを切り替えるけど、必ずループの中で呼ばないとハングアップする。

'Const SCRW = 320 : Const SCRH = 180
Const SCRW = 320 : Const SCRH = 240

#include "fbgfx.bi"
Using fb

' set screen depth
Dim As Integer sdepth = 32
Select Case Command(1)
Case "8"  : sdepth = 8
Case "16" : sdepth = 16
Case "32" : sdepth = 32
End Select

' get desktop size
Dim As Integer dispw, disph
ScreenInfo dispw, disph

' get scale (Integer)
Dim As Double dscale = dispw / SCRW
If dscale > (disph / SCRH) Then dscale = disph / SCRH

ScreenRes dispw, disph, sdepth, , GFX_NO_FRAME
Dim As Any Ptr gbuf = ImageCreate(SCRW, SCRH)

Color RGB(255, 255, 255), RGB(0, 0, 0)
cls

Const PI = 3.1415926535897932
Dim As Double angle = 0.0
Dim As Boolean running = True

' Main Loop

While running
    If Inkey <> "" Then running = False

    ' draw to image buffer
    line gbuf, (0, 0) - (SCRW - 1, SCRH - 1), RGB(30, 60, 120), BF ' clear image buffer
    
    Circle gbuf, (SCRW \ 2, SCRH \ 2), (SCRH \ 2 - 1), RGB(0, 255, 0)

    Dim As Integer x, y, r
    r = SCRH / 4
    x = (SCRW / 2 - r - 1) * Cos(angle * PI / 180.0) + (SCRW / 2)
    y = (SCRH / 2 - r - 1) * Sin(angle * PI / 180.0) + (SCRH / 2)
    Circle gbuf, (x, y), r, RGB(0, 255, 255)

    Draw String gbuf, (0, 0), Str(SCRW) & "x" & SCRH, RGB(255, 255, 255)

    ' draw to screen
    ScreenLock
    Put (0, 0), gbuf, Pset
    ScreenUnlock
    
    angle += 1.0

    sleep 10
Wend

'Const SCRW = 320 : Const SCRH = 180
Const SCRW = 320 : Const SCRH = 240
'Const SCRW = 640 : Const SCRH = 480

#ifdef __FB_WIN32__
' Windows : use  mmsystem
#include "windows.bi"
#include "win/mmsystem.bi"
#endif

#include "fbgfx.bi"
Using fb

#include "imagescale2screen.bi"

#ifdef __FB_WIN32__
' Timer accuracy 1ms
timeBeginPeriod(1)
#endif

' set screen depth
Dim As Integer sdepth = 32
Select Case Command(1)
Case "8"  : sdepth = 8
Case "16" : sdepth = 16
Case "32" : sdepth = 32
End Select

' get desktop size
Dim As Integer dispw, disph
ScreenInfo dispw, disph

' get scale (Integer)
Dim As Double dscale = dispw / SCRW
If dscale > (disph / SCRH) Then dscale = disph / SCRH

' get dest image size
Dim As Integer tgtscrw, tgtscrh
tgtscrw = Int(SCRW * dscale)
tgtscrh = Int(SCRH * dscale)
If tgtscrw > dispw Then tgtscrw = dispw
If tgtscrh > disph Then tgtscrh = disph

' set screen size. like fullscreen
ScreenRes dispw, disph, sdepth, 2, GFX_NO_FRAME
Dim As Any Ptr gbuf = ImageCreate(SCRW, SCRH)

Dim As Double angle = 0.0
Dim As Boolean running = True

Const PI = 3.1415926535897932

#define MAX_FPS   60.0
Dim As Double start_time, prev_time, now_time, delta, next_time
Dim As Integer frame_count, fps_count

' save start time
start_time = Timer
prev_time = start_time
frame_count = 0
fps_count = 0

Dim As Integer workpage = 1
ScreenSet workpage, (workpage + 1) And &H01

' Main Loop

While running
    ' get delta time
    now_time = Timer
    delta = now_time - prev_time
    If delta < 0 Then delta = (1.0 / MAX_FPS)
    prev_time = now_time
    next_time = now_time + (1.0 / MAX_FPS)

    ' fps count
    If now_time >= start_time Then
        If (now_time - start_time) >= 1.0 Then
            ' get FPS
            fps_count = frame_count
            start_time += 1.0
            frame_count = 0
        End If
    Else
        start_time = now_time
    End If
    frame_count += 1

    If Inkey <> "" Then running = False

    angle += (1.0 * MAX_FPS) * delta

    ' draw to image buffer
    
    ' clear screen
    line gbuf, (0, 0) - (SCRW - 1, SCRH - 1), RGB(30, 60, 120), BF
    ' cls

    Circle gbuf, (SCRW \ 2, SCRH \ 2), (SCRH \ 2 - 1), RGB(0, 255, 0)

    Dim As Integer x, y, r
    r = SCRH / 4
    x = (SCRW / 2 - r - 1) * Cos(angle * PI / 180.0) + (SCRW / 2)
    y = (SCRH / 2 - r - 1) * Sin(angle * PI / 180.0) + (SCRH / 2)
    Circle gbuf, (x, y), r, RGB(0, 255, 255)

    Draw String gbuf, (0, 0), Str(SCRW) & "x" & SCRH & " (" & tgtscrw & "x" & tgtscrh & ") FPS:" & fps_count, RGB(255, 255, 255)
    
    ' draw to screen
    ScreenLock
    
    Color RGB(255, 255, 255), RGB(0, 0, 0)
    cls

    Dim As Integer ox, oy
    ox = (dispw - tgtscrw) / 2
    oy = (disph - tgtscrh) / 2
    ImageScale2screen(gbuf, ox, oy, tgtscrw, tgtscrh)
    
    ScreenUnlock

    workpage = (workpage + 1) And &H01
    ScreenSet workpage, (workpage + 1) And &H01
    
    If Timer < next_time Then
        ' sleep
        Dim As long wait_ms = (next_time - Timer) * 1000
        If wait_ms > 0 Then sleep wait_ms
    End If
Wend

#ifdef __FB_WIN32__
' reset timer accuracy
timeEndPeriod(1)
#endif

1 byte目 : Version情報。これは現在 0 しか用意されてないらしい。
2 byte目 : 開始文字コード。例えば ASCIIコードの「空白」から始まるなら、0x20になる。
3 byte目 : 終了文字コード。例えば ASCIIコードの「DEL」で終わるなら、0x7f になる。
4 byte目 : 開始文字 + 0 の横幅ドット数
5 byte目 : 開始文字 + 1 の横幅ドット数
6 byte目 : 開始文字 + 2 の横幅ドット数
...
...
N byte目 : 終了文字の横幅ドット数

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

Usage: make_mono_font.exe INPUT_FONT.bmp OUTPUT_FONT.bmp

Const SCRW = 512
Const SCRH = 288
Dim As Integer sdepth = 32

If Command(1) = "" Then
    Print "Usage : " & Command(0) & " INPUT_FONT.bmp" : end
End If

ScreenRes SCRW, SCRH, sdepth

Dim As String infilename  = Command(1)

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

Dim As Any Ptr img = ImageCreate(w, h)
bload infilename, img

Color RGB(255, 255, 255), RGB(0, 0, 0)
cls

h = 34
Draw String (0, h * 0), "Hello World !", , img
Draw String (0, h * 1), infilename, , img
Draw String (0, h * 2), "0123456789",    , img
Draw String (0, h * 3), "@ABCDEFGHIJKLMNO", , img
Draw String (0, h * 4), "PQRSTUVWXYZ[\]^_", , img
Draw String (0, h * 5), "`abcdefghijklmno", , img
Draw String (0, h * 6), "pqrstuvwxyz{|}~ ", , img

sleep
ImageDestroy img

Usage: test_fbfont.exe INPUT_FONT.bmp

 !"#$%&'()*+,-./
0123456789:;<=>?
@ABCDEFGHIJKLMNO
PQRSTUVWXYZ[\]^_
`abcdefghijklmno
pqrstuvwxyz{|}~ 

#include "bitmapasciifont.bi"
ScreenRes 320, 240, 32

Dim fnt As BitmapAsciiFont
fnt.load_image("font_profont_12x22.bmp")

fnt.draw_string(10, 10, "Hello World !")

sleep
fnt.destroy()

#include "bitmapasciifont.bi"

If Command(1) = "" Then
    Print "Usage: " & Command(0) & " INPUT_FONT.bmp" : end
End If

Dim As String fontfile = Command(1)

Const SCRW = 640
Const SCRH = 480
Dim As Integer sdepth = 32

ScreenRes SCRW, SCRH, sdepth

Dim fnt As BitmapAsciiFont
fnt.load_image(fontfile)

Dim As Integer h = fnt.cheight + 1
fnt.draw_string(0, h * 0, "Load: " & fontfile)
fnt.draw_string(0, h * 1, "Hello World ! 0123456789")
fnt.draw_string(0, h * 2, "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_")
fnt.draw_string(0, h * 3, "`abcdefghijklmnopqrstuvwxyz{|}~ ")
fnt.draw_string(0, h * 4, "Push any key to exit.")

sleep
fnt.destroy()

#include "crt.bi"

Sub Split(byref text As String, byref delim As String, result() as String)
    var p = strtok(strptr(text), strptr(delim))
    While (p)
        ReDim preserve result(UBound(result) + 1)
        result(UBound(result)) = *p
        p = strtok(NULL, strptr(delim))
    Wend
End Sub

' main

Dim As String text = "this   is   a     test"
Dim words() As String

split(text, " ", words())

Print text
For i As Integer = 0 To UBound(words)
    Print "[" & words(i) & "]"
Next i

Print "    ...success."

> strtok_test.exe
this   is   a     test
[this]
[is]
[a]
[test]
    ...success.

char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15

> strtok_test3.exe
char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15
[char]
[id=32]
[x=250]
[y=22]
[width=5]
[height=5]
[xoffset=-2]
[yoffset=21]
[xadvance=7]
[page=0]
[chnl=15]
    ...success.

info face="DejaVu Sans" size=24 bold=1 italic=0 charset="ANSI" unicode=0 stretchH=100 smooth=1 aa=4 padding=0,0,0,0 spacing=1,1 outline=2

> strtok_test3.exe
info face="DejaVu Sans" size=24 bold=1 italic=0 charset="ANSI" unicode=0 stretchH=100 smooth=1 aa=4 padding=0,0,0,0 spacing=1,1 outline=2
[info]
[face="DejaVu]
[Sans"]
[size=24]
[bold=1]
[italic=0]
[charset="ANSI"]
[unicode=0]
[stretchH=100]
[smooth=1]
[aa=4]
[padding=0,0,0,0]
[spacing=1,1]
[outline=2]
    ...success.

' License: CC0 / Public Domain

#ifndef __SPLITDQ__
#define __SPLITDQ__

Sub Splitdq(byref text As String, byref delim As String, result() as String)
    If text = "" Then Return
        
    Dim As ubyte ptr cp = strptr(text)
    Dim As ubyte ptr dp = strptr(delim)
    Dim As Integer slen = Len(text)
    Dim As Integer pi = 0
    Dim As Integer i = 0
    Dim As Boolean dqfg = False
    Dim As String s = ""
    
    Do
        If dqfg Then
            ' check double quotation pair
            If (*cp = 34) Then dqfg = False
        ElseIf (*cp = 34) Then
            ' found double quotation
            dqfg = True
        ElseIf (*cp = *dp) Then
            ' found delimiter
            s = Mid(text, pi + 1, (i - pi))
            pi = i + 1
        End If

        cp += 1
        i += 1

        If i >= slen Then
            s = Mid(text, pi + 1, (i - pi))
            pi = i + 1
        End If
        
        If s <> "" Then
            ReDim preserve result(UBound(result) + 1)
            result(UBound(result)) = s
            s = ""
        End If
    Loop While (i < slen)
End Sub

#endif

#include "splitdq.bi"

Dim As String text
'text = "char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15"
text = "info face=""DejaVu Sans"" size=24 bold=1 italic=0 charset=""ANSI"" unicode=0 stretchH=100 smooth=1 aa=4 padding=0,0,0,0 spacing=1,1 outline=2"

Dim words() As String
splitdq(text, " ", words())

Print text
For i As Integer = 0 To UBound(words)
    Print "[" & words(i) & "]"
Next i
Print "    ...success."

> test_splitdq.exe
info face="DejaVu Sans" size=24 bold=1 italic=0 charset="ANSI" unicode=0 stretchH=100 smooth=1 aa=4 padding=0,0,0,0 spacing=1,1 outline=2
[info]
[face="DejaVu Sans"]
[size=24]
[bold=1]
[italic=0]
[charset="ANSI"]
[unicode=0]
[stretchH=100]
[smooth=1]
[aa=4]
[padding=0,0,0,0]
[spacing=1,1]
[outline=2]
    ...success.

#ifndef __SPLITSTRINGA__
#define __SPLITSTRINGA__

Sub splitStringA(ByVal text As String, ByVal delim As String, result() as String, ByVal chk_dbqt As Boolean = False)
    If text = "" Then Return
    Dim As String src = text & delim
    Dim As String word = ""
    Dim As Boolean founded_dbqt = False

    For i As Integer = 0 To Len(src) - 1
        If founded_dbqt Then
            word &= Chr(src[i])
            If src[i] = 34 Then founded_dbqt = False  ' found double quote
        Else
            If src[i] <> delim[0] Then
                ' not delimiter
                word &= Chr(src[i])
                If chk_dbqt And src[i] = 34 Then founded_dbqt = True  ' found double quote
            Else
                ' found delimiter
                If word <> "" Then
                    ' word is not empty. save word to array
                    ReDim preserve result(UBound(result) + 1)
                    result(UBound(result)) = word
                    word = ""
                End If
            End If
        End If
    Next i
    If word <> "" Then
        ' word is not empty. save word to array
        ReDim preserve result(UBound(result) + 1)
        result(UBound(result)) = word
    End If
End Sub

#endif

#include "splitstringa.bi"

Dim As String text
text = "char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15"
'text = "info face=""DejaVu Sans"" size=24 bold=1 italic=0 charset=""ANSI"" unicode=0 stretchH=100 smooth=1 aa=4 padding=0,0,0,0 spacing=1,1 outline=2"

Dim words() As String
splitStringA(text, " ", words())
'splitStringA(text, " ", words(), True)  ' check double quote

Print "[" & text & "]"
For i As Integer = 0 To UBound(words)
    Print i & ": [" & words(i) & "]"
Next i
Print "end."

> test_splitstringa.exe
[char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15]
0: [char]
1: [id=32]
2: [x=250]
3: [y=22]
4: [width=5]
5: [height=5]
6: [xoffset=-2]
7: [yoffset=21]
8: [xadvance=7]
9: [page=0]
10: [chnl=15]
end.

#ifndef __SPLITSTRINGB__
#define __SPLITSTRINGB__

Sub splitStringB(ByVal src As String, ByVal delim As String, result(Any) As String)
    Do
        Dim As Integer i = InStr(1, src, Chr(delim[0])) ' search delimiter
        ReDim Preserve result(UBound(result) + 1)
        If i = 0 Then
            ' not found delimiter. exit loop
            result(UBound(result)) = src
            Exit Do
        End If
        result(UBound(result)) = Left(src, i - 1)  ' save word to array
        src = Mid(src, i + 1)  ' delete word
    Loop
End Sub

#endif

#include "splitstringb.bi"

Dim As String text
text = "char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15"
'text = "info face=""DejaVu Sans"" size=24 bold=1 italic=0 charset=""ANSI"" unicode=0 stretchH=100 smooth=1 aa=4 padding=0,0,0,0 spacing=1,1 outline=2"

Dim words() As String
splitStringB(text, " ", words())

Print "[" & text & "]"
For i As Integer = 0 To UBound(words)
    Print i & ": [" & words(i) & "]"
Next i
Print "end."

> test_splitstringb.exe
[char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15]
0: [char]
1: [id=32]
2: []
3: []
4: [x=250]
5: []
6: []
...
34: [page=0]
35: []
36: [chnl=15]
end.

info face="DejaVu Sans" size=24 bold=1 italic=0 charset="ANSI" unicode=0 stretchH=100 smooth=1 aa=4 padding=0,0,0,0 spacing=1,1 outline=2
common lineHeight=24 base=20 scaleW=256 scaleH=256 pages=1 packed=0 alphaChnl=1 redChnl=0 greenChnl=0 blueChnl=0
page id=0 file="bmfont_dejavu_0.png"
chars count=95
char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15
char id=33   x=71    y=89    width=8     height=20    xoffset=0     yoffset=2     xadvance=9     page=0  chnl=15
...
char id=125  x=51    y=0     width=14    height=24    xoffset=0     yoffset=1     xadvance=14    page=0  chnl=15
char id=126  x=208   y=105   width=17    height=9     xoffset=0     yoffset=8     xadvance=17    page=0  chnl=15
kernings count=86
kerning first=45  second=84  amount=-3  
kerning first=45  second=86  amount=-1  
...
kerning first=89  second=46  amount=-3  
kerning first=118 second=44  amount=-1  

#include "bmfont.bi"

Dim As bmfont bmfnt
bmfnt.loadInfo("bmfont_dejavu.fnt")

ScreenRes 320, 240, 32
bmfnt.loadImage()

bmfnt.drawstring(10, 10, "Hello World !")

sleep
bmfnt.destroy()

• #include "bmfont.bi" で bmfont というクラス相当(構造体 + 関数)が使えるようになる。
• bmfont.loadInfo() で .fntファイルを読み込んで解析して記録。
• bmfont.loadImage() で .fntファイルに書かれた画像ファイル(拡張子を .bmp に変更)をロード。
• bmfont.drawstring() でスクリーンに文字を描画。
• bmfont.destroy() でBMFont画像を破棄。

Usage: test_bmfont.exe [INPUT.fnt] [--dump]

fbc simple_sample.bas
fbc test_bmfont.bas

#ifndef __SPLITSTRINGB2__
#define __SPLITSTRINGB2__

Sub splitStringB2(ByVal src As String, ByVal delim As String, result(Any) As String)
    Do
        Dim As Integer i = InStr(1, src, Chr(delim[0])) ' search delimiter
        If i = 0 Then
            ' not found delimiter. exit loop
            ReDim Preserve result(UBound(result) + 1)
            result(UBound(result)) = src
            Exit Do
        End If

        Dim As String word = Left(src, i - 1)
        If word <> "" Then
            ReDim Preserve result(UBound(result) + 1)
            result(UBound(result)) = word ' save word to array
        End If
        src = Mid(src, i + 1)  ' delete word
    Loop
End Sub

#endif

#include "splitstringb2.bi"

Dim As String text
text = "char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15"
'text = "info face=""DejaVu Sans"" size=24 bold=1 italic=0 charset=""ANSI"" unicode=0 stretchH=100 smooth=1 aa=4 padding=0,0,0,0 spacing=1,1 outline=2"

Dim words() As String
splitStringB2(text, " ", words())

Print "[" & text & "]"
For i As Integer = 0 To UBound(words)
    Print i & ": [" & words(i) & "]"
Next i
Print "end."

> test_splitstringb2.exe
[char id=32   x=250   y=22    width=5     height=5     xoffset=-2    yoffset=21    xadvance=7     page=0  chnl=15]
0: [char]
1: [id=32]
2: [x=250]
3: [y=22]
4: [width=5]
5: [height=5]
6: [xoffset=-2]
7: [yoffset=21]
8: [xadvance=7]
9: [page=0]
10: [chnl=15]
end.

• 可変長文字列は使えない。固定長文字列(事前に確保した領域サイズから変更できない)になる。
• サブルーチンや関数に配列変数を渡せない。

• 事前に確保する領域は、処理をするにあたって十分足りるであろう大きな領域にしておく。今回の場合、配列で、256文字 x 256個あれば大丈夫かな…と…。
• サブルーチンに入れずに マクロ機能 (#macro - #endmacro) で代替してみる。

Dim As WString * 1024 text, delim
text = "新しい     朝が来た   希望の    朝だ"
delim = " "
Dim result(256) As WString * 256  ' max 256 length x 256

' ----------------------------------------
#macro splitW( s, d, a )
Dim As WString * 1024 src = s
Dim As Integer n = 0
Do
    Dim As Integer i = InStr(1, src, WChr(d[0])) ' search delimiter
    If i = 0 Then
        ' not found delimiter. exit Loop
        If src <> "" Then
            a(n) = src
            n += 1
        End If
        Exit Do
    End If

    Dim As WString * 256 word
    word = Left(src, i - 1)
    If word <> "" Then
        a(n) = word ' save word to Array
        n += 1
    End If
    src = Mid(src, i + 1)  ' delete word
Loop
#endmacro
' ----------------------------------------

splitW(text, delim, result)

Print "[" & text & "]"
For i As Integer = 0 To UBound(result)
    If result(i) = "" Then Exit For
    Print i & ": [" & result(i) & "]"
Next i
Print "end."

> test_splitw.exe
[新しい     朝が来た   希望の    朝だ]
0: [新しい]
1: [朝が来た]
2: [希望の]
3: [朝だ]
end.

ntp.nict.jp
ntp1.plala.or.jp
ntp2.plala.or.jp

• 10分毎に時間合わせ。
• 失敗時は1分毎に4回再挑戦。
• Max Free Run は 24年(years)に。
• 2秒(seconds)ずれてたら調整する。(Adjust System Time)

1. タスクスケジューラ起動。
2. Microsoft → Windows → Time Synchronization
3. SynchronizeTime を選択 → プロパティ。
4. トリガー → 新規。

• タスクの開始 : イベント時
• ログ : システム
• ソース : Power-Troubleshooter
• イベントID : 1
• 遅延時間 : 30秒

• トリガー → 新規。
• スクの開始 : スタートアップ時
• 遅延時間 : 1分

• 電源残量は、音量ボタンの「＋」をダブルクリック。4回点滅=100%、3回点滅=75%、2回点滅=50%、1回点滅=25%。
  
• 充電は、USB-C - USB-Aケーブルを使う。USB-C側を本体に差す。

• 電源ONは、電源ボタンを1秒押し続ける。
• 電源OFFは、電源ボタンを3秒押し続ける。
• 強制ペアリングモードにするには、音量ボタン「＋」「−」を両方共6秒間押し続ける。

$ pacman -S mingw-w64-i686-premake mingw-w64-i686-premake4 mingw-w64-x86_64-premake mingw-w64-x86_64-premake4

$ which premake
which: no premake in 

$ which premake5
/mingw64/bin/premake5

$ which premake4
/mingw64/bin/premake4

$ premake5 --version
premake5 (Premake Build Script Generator) 5.0.0-dev

$ premake4 --version
premake4 (Premake Build Script Generator) 4.3

$ pacman -Ss premake

$ pacman -S mingw-w64-i686-premake mingw-w64-i686-premake4 mingw-w64-x86_64-premake mingw-w64-x86_64-premake4

git clone https://github.com/SpartanJ/SOIL2.git
cd SOIL2

premake5 gmake2

cd make/windows

release_x86
release_x86_64
debug_x86
debug_x86_64

make config=release_x86_64

soil2.dll
soil2.lib

soil2-perf-test-release.exe
soil2-test-release.exe

$ pacman -Ss SDL2

$ pacman -S mingw-w64-i686-SDL2 mingw-w64-x86_64-SDL2

cd ../../bin/
./soil2-test-release.exe
./soil2-perf-test-release.exe

• soil2-test-release.exe ... ウインドウが表示されて画像が描画された。
• soil2-perf-test-release.exe ... 画像群を読み込んで、かかった時間が表示された。

$ objdump -p soil2-test-release.exe | grep dll
        DLL Name: soil2.dll
        DLL Name: libgcc_s_dw2-1.dll
        DLL Name: KERNEL32.dll
        DLL Name: msvcrt.dll
        DLL Name: SDL2.dll
        DLL Name: SHELL32.dll
        DLL Name: libstdc++-6.dll

libgcc_s_dw2-1.dll
libstdc++-6.dll
SDL2.dll
soil2.dll

libsoil32.so
libsoil64.so
OpenGL_RGB.png
OpenGL_RGBA.png
soil.bi
soil32.dll
soil64.dll
test01.bas
test02.bas

• *.so は Linux で使うファイル。
• *.dll は Windows で使うファイル。動的リンクライブラリ。
• soil.bi は、FreeBASICのソースからインポートするヘッダファイル。
• *.bas は、FreeBASIC のソースファイル。今回のサンプルファイル。

fbc test01.bas
fbc test02.bas

#include once "GL/gl.bi"
#include once "GL/glu.bi"
#include once "soil.bi"

' test of RGB texture

ChDir ExePath()

ScreenRes 640,480,32,,2

var texture = SOIL_load_OGL_texture("OpenGL_RGB.png", SOIL_LOAD_AUTO, SOIL_CREATE_NEW_ID, SOIL_FLAG_POWER_OF_TWO)

dim as integer w,h
screeninfo w,h
glViewport 0,0,w,h
glMatrixMode GL_PROJECTION
glLoadIdentity
gluPerspective 45.0, w/h, 0.1, 100.0
glMatrixMode GL_MODELVIEW
glLoadIdentity

glClearColor 1,0,0,1
glShadeModel GL_SMOOTH

glDisable GL_DEPTH_TEST
glDepthFunc GL_LEQUAL
glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST

glEnable GL_TEXTURE_2D
glBindTexture GL_TEXTURE_2D, texture

do
    glClear GL_COLOR_BUFFER_BIT
    
    glBegin GL_QUADS
    glTexCoord2f 0,0:glVertex3f -.5, .25,-5
    glTexCoord2f 1,0:glVertex3f  .5, .25,-5
    glTexCoord2f 1,1:glVertex3f  .5,-.25,-5
    glTexCoord2f 0,1:glVertex3f -.5,-.25,-5
    glEnd
    
    flip
loop while inkey=""

#ifdef __FB_WIN32__
' use mmsystem. Windows only
#include "windows.bi"
#include "win/mmsystem.bi"
#endif

#include once "fbgfx.bi"
Using FB
#include once "GL/gl.bi"
#include once "GL/glu.bi"
#include once "soil.bi"

Const IMG_FILE = "ufo.png"

Const OBJ_MAX = 10000
Const SPRITE_SIZE = 128
Const MAX_FPS = 60.0
Const PI = 3.1415926535897932

Dim Shared As Integer obj_num = OBJ_MAX  ' Shared ... global variable

ChDir ExePath()

' get desktop size
Dim shared As Integer scr_w, scr_h, sdepth
ScreenInfo scr_w, scr_h, sdepth

' set window screen size
If Command(1) = "/s" Or Command(2) = "/s" Then
    ' like fullscreen
    ScreenRes scr_w, scr_h, sdepth, ,GFX_OPENGL Or GFX_NO_FRAME
Else
    ' window style
    scr_w *= 0.8
    scr_h *= 0.8
    ScreenRes scr_w, scr_h, sdepth, ,GFX_OPENGL
End If

' obj work type
Type obj
    x As double
    y As double
    dx As double
    dy As Double
    w As Integer
    h As Integer

    Declare Sub init(ByVal x As Double, ByVal y As Double, ByVal dx As Double, ByVal dy As Double, ByVal w As Integer, ByVal h As Integer)
    Declare Sub update(ByVal delta As Double)

End Type

' obj init
Sub obj.init(ByVal x As Double, ByVal y As Double, ByVal dx As Double, ByVal dy As Double, ByVal w As Integer, ByVal h As Integer)
    this.x = x
    this.y = y
    this.dx = dx
    this.dy = dy
    this.w = w
    this.h = h
End Sub

' obj update
Sub obj.update(ByVal delta As double)
    this.x += (this.dx * MAX_FPS) * delta
    this.y += (this.dy * MAX_FPS) * delta
    Dim As Integer wh = this.w / 2
    Dim As Integer hh = this.h / 2
    If this.dx < 0.0 And this.x - wh <= 0     Then this.dx *= -1.0
    If this.dx > 0.0 And this.x + wh >= scr_w Then this.dx *= -1.0
    If this.dy < 0.0 And this.y - hh <= 0     Then this.dy *= -1.0
    If this.dy > 0.0 And this.y + hh >= scr_h Then this.dy *= -1.0
End Sub

#ifdef __FB_WIN32__
' Changed timer precision to 1 msec
timeBeginPeriod(1)
#endif

' init objs work
Dim objs(0 To OBJ_MAX) As obj

For i As Integer = 0 To UBound(objs)
    Dim As Double a, spd, dx, dy
    a = (Rnd * 360.0) * PI / 180.0
    spd = (scr_h / (MAX_FPS * 2)) * (Rnd + 0.25)
    dx = spd * Cos(a)
    dy = spd * Sin(a)
    objs(i).init(scr_w / 2, scr_h / 2, dx, dy, SPRITE_SIZE, SPRITE_SIZE)
Next i

obj_num = UBound(objs) / 2

For i As Integer = 1 To 2
    If Command(i) <> "" And Command(i) <> "/s" Then
        obj_num = Valint(Command(i))
        If obj_num < 0 Then obj_num = 0
        If obj_num > UBound(objs) Then obj_num = UBound(objs)
    End If
Next i

' load texture image file
var texture = SOIL_load_OGL_texture(IMG_FILE, SOIL_LOAD_AUTO, SOIL_CREATE_NEW_ID, SOIL_FLAG_POWER_OF_TWO)

' OpenGL Config
glViewport 0, 0, scr_w, scr_h
glMatrixMode(GL_PROJECTION)
glLoadIdentity()

glOrtho(0, scr_w, scr_h, 0, 5.0, -5.0)
' gluPerspective 45.0, w/h, 0.1, 100.0

glMatrixMode(GL_MODELVIEW)
glLoadIdentity()

glClearColor(0.15, 0.3, 0.6, 1)
glShadeModel(GL_SMOOTH)

glDisable(GL_DEPTH_TEST)
' glDepthFunc(GL_LEQUAL)
glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST)

glEnable(GL_BLEND)
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA)

glEnable(GL_TEXTURE_2D)
glBindTexture(GL_TEXTURE_2D, texture)

Dim As Double start_time, prev_time, now_time, next_time, delta
Dim As Integer frame_count, fps_count
Dim As Boolean running

start_time = Timer
prev_time = start_time
next_time = start_time + 1.0 / MAX_FPS
frame_count = 0
fps_count = 0
running = True

' main loop
While running
    ' get delta time
    now_time = Timer
    delta = now_time - prev_time
    If delta < 0 Then delta = 1.0 / MAX_FPS
    prev_time = now_time
    next_time = now_time + 1.0 / MAX_FPS

    ' count fps
    If now_time < start_time Then start_time = now_time
    If (now_time - start_time) >= 1.0 Then
        fps_count = frame_count  ' get FPS
        start_time += 1.0
        frame_count = 0
    End If
    frame_count += 1

    Dim As String k = inkey$
    If k = Chr$(27) Or k = "q" Or k = Chr$(255) + "k" Then
        running = False
    End If

    If MultiKey(SC_UP  ) Then obj_num += 20
    If MultiKey(SC_DOWN) Then obj_num -= 20
    If obj_num < 0 Then obj_num = 0
    If obj_num > UBound(objs) Then obj_num = UBound(objs)

    ' update objs
    For i As Integer = 0 To obj_num
        objs(i).update(delta)
    Next i

    ' draw
    glClear GL_COLOR_BUFFER_BIT

    For i As Integer = 0 To obj_num
        Dim As Integer swh = objs(i).w / 2, shh = objs(i).h / 2

        glLoadIdentity()
        glTranslatef(objs(i).x, objs(i).y, -1)

        glBegin GL_QUADS
        glTexCoord2f 0, 0 : glVertex3f -swh, -shh, 0
        glTexCoord2f 1, 0 : glVertex3f  swh, -shh, 0
        glTexCoord2f 1, 1 : glVertex3f  swh,  shh, 0
        glTexCoord2f 0, 1 : glVertex3f -swh,  shh, 0
        glEnd
    Next i

    ' draw String (10, 10), "FPS " & fps_count, RGB(255, 255, 255)
    WindowTitle("FPS:" & fps_count & " obj:" & obj_num)

    flip  ' double buffer flip

    ' wait
    If Timer < next_time Then
        Dim As Double wait_msec = cast( Integer, (next_time - Timer) * 1000.0)
        If wait_msec > 0 Then sleep wait_msec
    End If
Wend

#ifdef __FB_WIN32__
timeEndPeriod(1)
#endif

Usage: 
    opengl_sample1.exe [/s] [OBJ_NUM]

      * /s : Full screen
      * OBJ_NUM : objects number. 0 - 10000

• メインPC、AMD Ryzen 5 5600X (6C12T, 3.7 - 4.6GHz) + GeForec GTX 1060 6GB, デスクトップ解像度 1920x1080
• サブPC、Athlon 5350 (4C4T, 2GHz, TDP 25W, Jaguar Core) + On-board VGA (Radeon R3, GCN), デスクトップ解像度 1920x1200

• メインPC上では、128x128のスプライト相当を4,000個ほど出しても60FPSが出た。10,000個出すと50FPS台になった。
• サブPC上では、128x128個のスプライト相当を50個までなら60FPSが出たけれど、60個になると50FPS台になってしまった。100個ほど出すと30FPS台。

• 動作には Pillow が必要。
• Python 3.10.10 + Pillow 10.2.0 で動作確認した。
• License: CC0 / Public Domain

python png2bitsbas.py -i image.png

python png2bitsbas.py -i image.png > image.bi

#include once "fbgfx.bi"
Using FB
#include once "GL/gl.bi"
#include once "GL/glu.bi"

' include glbitmap binary data
#include "image_32x32.bi"
#include "image_lena.bi"

ChDir ExePath()

Const SCRW = 480
Const SCRH = 270
ScreenRes SCRW, SCRH, 32, ,GFX_OPENGL

' get window size
Dim shared As Integer scr_w, scr_h, sdepth
ScreenInfo scr_w, scr_h, sdepth

' OpenGL Config
glViewport 0, 0, scr_w, scr_h
glMatrixMode(GL_PROJECTION)
glLoadIdentity()

glOrtho(0, scr_w, scr_h, 0, 5.0, -5.0)
' gluPerspective 45.0, w/h, 0.1, 100.0

glMatrixMode(GL_MODELVIEW)
glLoadIdentity()

glClearColor(0, 0, 0, 1)
glShadeModel(GL_SMOOTH)

glDisable(GL_DEPTH_TEST)
' glDepthFunc(GL_LEQUAL)
glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST)

Dim As Boolean running = True

' main loop
While running
    
    ' ESC or Q key to exit
    Dim As String k = inkey$
    If k = Chr$(27) Or k = "q" Or k = Chr$(255) + "k" Then
        running = False
    End If

    ' draw start

    ' clear screen
    glClear(GL_COLOR_BUFFER_BIT)
    
    glPixelStorei(GL_UNPACK_ALIGNMENT, 1)

    Dim As GLsizei w, h
    Dim As GLfloat xorig, yorig, xmove, ymove

    ' draw arrow bitmap
    w = IMAGE_32X32_PNG_WIDTH
    h = IMAGE_32X32_PNG_HEIGHT
    xorig = 0.0
    yorig = 0.0
    xmove = 0.0
    ymove = 0.0
    glColor4f(1, 1, 1, 1)  ' set color
    glRasterPos2f(32, 32 + h)  ' set position
    glBitmap(w, h, xorig, yorig, xmove, ymove, @image_32x32_png(0))

    ' draw lena bitmap
    w = IMAGE_LENA_PNG_WIDTH
    h = IMAGE_LENA_PNG_HEIGHT
    xorig = 0.0
    yorig = 0.0
    xmove = 0.0
    ymove = 0.0
    glColor4f(1, 1, 1, 1)  ' set color
    glRasterPos2f(100, 32 + h)  ' set position
    glBitmap(w, h, xorig, yorig, xmove, ymove, @image_lena_png(0))

    flip  ' double buffer flip
    sleep 10
Wend

• プログラム部分の License は CC0 / Public Domain。
• 内包しているフォントデータについては各フォントのライセンスを確認のこと。

#include once "fbgfx.bi"
Using FB
#include once "GL/gl.bi"
#include once "GL/glu.bi"

' ...

Type glbitmapfontinfo
    w As GLsizei
    h As GLsizei
    clen As Integer
    adrs As UByte Ptr
End Type

Const GLBITMAPFONT_COURR18     = 0
Const GLBITMAPFONT_PET2015     = 1
Const GLBITMAPFONT_PROFONT     = 2
Const GLBITMAPFONT_SHNM8X16R   = 3
Const GLBITMAPFONT_SHNM8X16RX2 = 4
Const GLBITMAPFONT_TER_U24B    = 5

Const GLBITMAPFONT_MAX = 6

Dim Shared glBitmapFontInfoTbl( GLBITMAPFONT_MAX - 1 ) As glbitmapfontinfo => { _
  ( FONT_COURR18_PNG_WIDTH, FONT_COURR18_PNG_HEIGHT, FONT_COURR18_PNG_CHR_LEN, @font_courR18_png(0, 0)), _
  ( FONT_PET2015_PNG_WIDTH, FONT_PET2015_PNG_HEIGHT, FONT_PET2015_PNG_CHR_LEN, @font_pet2015_png(0, 0)), _
  ( FONT_PROFONT_PNG_WIDTH, FONT_PROFONT_PNG_HEIGHT, FONT_PROFONT_PNG_CHR_LEN, @font_profont_png(0, 0)), _
  ( FONT_SHNM8X16R_PNG_WIDTH, FONT_SHNM8X16R_PNG_HEIGHT, FONT_SHNM8X16R_PNG_CHR_LEN, @font_shnm8x16r_png(0, 0)), _
  ( FONT_SHNM8X16RX2_PNG_WIDTH, FONT_SHNM8X16RX2_PNG_HEIGHT, FONT_SHNM8X16RX2_PNG_CHR_LEN, @font_shnm8x16rx2_png(0, 0)), _
  ( FONT_TER_U24B_PNG_WIDTH, FONT_TER_U24B_PNG_HEIGHT, FONT_TER_U24B_PNG_CHR_LEN, @font_ter_u24b_png(0, 0)) _
  }

Sub glDrawBitmapText(ByVal text As string, ByVal kind As Integer)
    Dim As GLfloat xorig, yorig, xmove, ymove
    Dim As GLsizei w, h
    Dim As Integer clen
    Dim As ubyte ptr adrs

    If kind < 0 Then kind = 0
    If kind > GLBITMAPFONT_MAX - 1 Then kind = GLBITMAPFONT_MAX - 1

    w = glBitmapFontInfoTbl(kind).w
    h = glBitmapFontInfoTbl(kind).h
    clen = glBitmapFontInfoTbl(kind).clen
    adrs = glBitmapFontInfoTbl(kind).adrs

    xorig = 0
    yorig = 0
    xmove = w
    ymove = 0

    glPixelStorei(GL_UNPACK_ALIGNMENT, 1)

    Dim As Integer slen = Len(text)
    For i As Integer = 0 To slen - 1
        Dim As Integer c = text[i]
        If c = 0 Then Exit For

        If c < &H20 Or c > &H7f Then c = &H20
        c -= &H20
        glBitmap(w, h, xorig, yorig, xmove, ymove, adrs + clen * c)
    Next i
End Sub

#include once "fbgfx.bi"
Using FB
#include once "GL/gl.bi"
#include once "GL/glu.bi"

#include "glbitmapfont.bi"

ChDir ExePath()

Const SCRW = 480
Const SCRH = 270
ScreenRes SCRW, SCRH, 32, ,GFX_OPENGL

' get window size
Dim shared As Integer scr_w, scr_h, sdepth
ScreenInfo scr_w, scr_h, sdepth

' OpenGL Config
glViewport 0, 0, scr_w, scr_h
glMatrixMode(GL_PROJECTION)
glLoadIdentity()

glOrtho(0, scr_w, scr_h, 0, 5.0, -5.0)
' gluPerspective 45.0, w/h, 0.1, 100.0

glMatrixMode(GL_MODELVIEW)
glLoadIdentity()

glClearColor(0, 0, 0, 1)
glShadeModel(GL_SMOOTH)

glDisable(GL_DEPTH_TEST)
' glDepthFunc(GL_LEQUAL)
glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST)

Dim As Boolean running = True

Dim fontlist(GLBITMAPFONT_MAX - 1) As Integer => { _
  GLBITMAPFONT_COURR18, _
  GLBITMAPFONT_PET2015, _
  GLBITMAPFONT_PROFONT, _
  GLBITMAPFONT_SHNM8X16R, _
  GLBITMAPFONT_SHNM8X16RX2, _
  GLBITMAPFONT_TER_U24B _
  }

Dim As Integer fontkind = 0
Dim As Integer fontmax = UBound(fontlist) + 1

' main loop
While running

    ' ESC or Q key to exit
    Dim As String k = inkey$
    If k = Chr$(27) Or k = "q" Or k = Chr$(255) + "k" Then
        running = False
    ElseIf k = Chr$(255) + "H" Then
        ' up key
        fontkind = (fontkind + 1) Mod fontmax
    ElseIf k = Chr$(255) + "P" Then
        ' down key
        fontkind = (fontkind + fontmax - 1) Mod fontmax
    End If

    ' clear screen
    glClear(GL_COLOR_BUFFER_BIT)

    ' draw text
    glColor4f(1, 1, 1, 1)  ' set color
    glRasterPos2f(32, 64)  ' set position
    glDrawBitmapText("Hello World", fontlist(fontkind))

    flip  ' double buffer flip
    sleep 10
Wend

• #include "glbitmapfont.bi" をして、glDrawBitmapText() を呼び出せば使える。
• glColor4f() で色を、glRasterPos2f() で描画位置を指定して、glDrawBitmapText() で文字列を描画する。

• 動作には Pillow が必要。
• Python 3.10.10 + Pillow 10.2.0 で動作確認した。
• License : CC0 / Public Domain

python fontpng2bitsbas.py -i image.png

python fontpng2bitsbas.py -i image.png > image.bi

gcc 01_helloglfw.c -o 01_helloglfw.exe -static -lglfw3dll -lopengl32 -lwinmm -lgdi32 -mwindows

> objdump -p 01_helloglfw.exe | grep dll
        DLL Name: glfw3.dll
        DLL Name: KERNEL32.dll
        DLL Name: msvcrt.dll
        DLL Name: msvcrt.dll

$ objdump -p 01_helloglfw.exe | grep dll
        DLL Name: GDI32.dll
        DLL Name: KERNEL32.dll
        DLL Name: msvcrt.dll
        DLL Name: OPENGL32.dll
        DLL Name: SHELL32.dll
        DLL Name: USER32.dll

$ pacman -Ss glfw
...
mingw32/mingw-w64-i686-glfw 3.3.9-2 [インストール済み]
    A free, open source, portable framework for OpenGL application development (mingw-w64)
mingw64/mingw-w64-x86_64-glfw 3.3.9-2 [インストール済み]
    A free, open source, portable framework for OpenGL application development (mingw-w64)
...

Removed functions
glfwReadImage, glfwReadMemoryImage, glfwFreeImage, glfwLoadTexture2D, glfwLoadMemoryTexture2D and glfwLoadTextureImage2D.

GLFW: Moving from GLFW 2 to 3 より

• pacman -Ss hoge でパッケージの検索。
• pacman -S hoge でパッケージのインストール。

$ pacman -Ss soil
mingw32/mingw-w64-i686-soil 1.16.0-2 [インストール済み]
    C library used for loading image files into OpenGL (mingw-w64)
mingw64/mingw-w64-x86_64-soil 1.16.0-2 [インストール済み]
    C library used for loading image files into OpenGL (mingw-w64)
...

$ pacman -S mingw-w64-i686-soil mingw-w64-x86_64-soil

• libSOIL.a を、MinGWインストールフォルダ/lib/ にコピー。
• SOIL.h を、MinGWインストールフォルダ/include/ 内に、SOIL/ というディレクトリを作ってから、その中にコピー。

#include <SOIL/SOIL.h>

  // load texture image file. use SOIL
  tex_id = SOIL_load_OGL_texture("logo.png", SOIL_LOAD_AUTO, SOIL_CREATE_NEW_ID, SOIL_FLAG_POWER_OF_TWO);
  if (tex_id > 0)
  {
    glEnable(GL_TEXTURE_2D);
    glBindTexture(GL_TEXTURE_2D, tex_id);
  }
  else
  {
    glDisable(GL_TEXTURE_2D);
  }
  
  glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
  glEnable(GL_BLEND);

gcc 01_helloglfw.c -o 01_helloglfw.exe -static -lSOIL -lglfw3 -lopengl32 -lwinmm -lgdi32 -mwindows

#include <stdlib.h>
#include <stdio.h>
#include <GLFW/glfw3.h>
#include <SOIL/SOIL.h>

void error_callback(int error, const char *description)
{
  fprintf(stderr, "Error: %s\n", description);
}

static void key_callback(GLFWwindow *window, int key, int scancode, int action, int mods)
{
  if (key == GLFW_KEY_ESCAPE && action == GLFW_PRESS)
  {
    glfwSetWindowShouldClose(window, GLFW_TRUE);
  }
}

int main(void)
{
  GLFWwindow *window;
  GLuint tex_id;

  glfwSetErrorCallback(error_callback);

  if (!glfwInit())
  {
    // Initialization failed
    exit(EXIT_FAILURE);
  }

  glfwWindowHint(GLFW_CONTEXT_VERSION_MAJOR, 1); // set OpenGL 1.1
  glfwWindowHint(GLFW_CONTEXT_VERSION_MINOR, 1);

  // create window
  window = glfwCreateWindow(1280, 720, "Hello GLFW", NULL, NULL);
  if (!window)
  {
    // Window or OpenGL context creation failed
    glfwTerminate();
    exit(EXIT_FAILURE);
  }

  glfwSetKeyCallback(window, key_callback);

  glfwMakeContextCurrent(window);

  glfwSwapInterval(1);

  // load texture image file. use SOIL
  tex_id = SOIL_load_OGL_texture("logo.png", SOIL_LOAD_AUTO, SOIL_CREATE_NEW_ID, SOIL_FLAG_POWER_OF_TWO);
  if (tex_id > 0)
  {
    glEnable(GL_TEXTURE_2D);
    glBindTexture(GL_TEXTURE_2D, tex_id);
  }
  else
  {
    glDisable(GL_TEXTURE_2D);
  }

  glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
  glEnable(GL_BLEND);

  int scrw, scrh;
  glfwGetFramebufferSize(window, &scrw, &scrh);
  glViewport(0, 0, scrw, scrh);
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity();
  double a = (double)scrw / (double)scrh;
  glOrtho(-a, a, -1.0, 1.0, 1.0, -1.0);
  
  double angle = 0.0;

  // main loop
  while (!glfwWindowShouldClose(window))
  {
    angle += (45.0 / 60.0);

    glClearColor(0.1, 0.2, 0.4, 1.0);
    glClear(GL_COLOR_BUFFER_BIT);

    glMatrixMode(GL_MODELVIEW);
    glLoadIdentity();
    glRotatef(angle, 0, 0, 1);

    float w = 0.8;
    float h = 0.8;
    glColor4f(1.0, 1.0, 1.0, 1.0);
    glBegin(GL_QUADS);
    glTexCoord2f(0.0, 0.0);
    glVertex3f(-w, +h, -0.5);
    glTexCoord2f(1.0, 0.0);
    glVertex3f(+w, +h, -0.5);
    glTexCoord2f(1.0, 1.0);
    glVertex3f(+w, -h, -0.5);
    glTexCoord2f(0.0, 1.0);
    glVertex3f(-w, -h, -0.5);
    glEnd();

    glfwSwapBuffers(window);
    glfwPollEvents();
  }

  glfwDestroyWindow(window);
  glfwTerminate();
  exit(EXIT_SUCCESS);
}

01_helloglfw.exe: 01_helloglfw.c Makefile
    gcc 01_helloglfw.c -o 01_helloglfw.exe -static -lSOIL -lglfw3 -lopengl32 -lwinmm -lgdi32 -mwindows
#   gcc 01_helloglfw.c -o 01_helloglfw.exe -static -lSOIL -lglfw3dll -lopengl32 -lwinmm -lgdi32 -mwindows

.PHONY: clean
clean:
    rm -f *.exe
    rm -f *.o

$ pacman -S mingw-w64-i686-soil mingw-w64-x86_64-soil