ゲームを作りたい人のための　ソースコード集

バッファに値を格納するとき、格納位置がバッファ長を超えるとエラーになります

以下はエラー時にバッファ長を再確保することで、途中終了せずに正常に処理させるプログラムです

pos ginfo_winx,ginfo_winy:mes"a"
charlen=ginfo(14)
sdim test,64        ;文字列型変数作成
onerror gosub *error    ;エラー時に実行するイベント
poke test,70,"a"    ;エラー発生
repeat 70            ;メモリブロックが再確保されたことを確認
    poke test,cnt,"a"
loop
pos 0,0:mes""+test
repeat 7,1
    lx=charlen*(cnt*10-1)
    pos lx,20:mes"^"
    pos lx,30:mes""+(cnt*10)
loop
stop
*error
    err_str="#Error "+wparam+" in line "+lparam+" (???)¥n"
    err_str+="-->バッファオーバーフローが発生しました"
    dialog""+err_str,1,"Error"
    memexpand test,varsize(test)*2    ;変数の長さを倍にする
    return

画面上のキャラクター（赤いマス）はマウス（目標マス）に追従しますが、

キャラクターと目標の間に壁（黒いマス）がある場合、キャラクターは壁の向こう側に置いてけぼりにされます

ブレゼンハムアルゴリズムを用いることで実装しました

#module
#defcfunc bresenham array map,var gx,var gy,var px,var py
    bool=0
    if gx=px&gy=py:return bool
    ;ブレゼンハム（初期設定）
    x=px:y=py
    if gx-px>0{vx=1}else:if gx-px<0{vx=-1}else{vx=0}
    if gy-py>0{vy=1}else:if gy-py<0{vy=-1}else{vy=0}
    ww=abs(gx-px):hh=abs(gy-py)
    if ww>hh{dup llen,ww:dup slen,hh:dup lh,x:dup sh,y:dup lv,vx:dup sv,vy:e=ww/2}
    else{dup llen,hh:dup slen,ww:dup lh,y:dup sh,x:dup lv,vy:dup sv,vx:e=hh/2}
    ;ブレゼンハム（処理）
    repeat
        if (e>=llen){
            e-llen
            sh+sv
        }else{
            e+slen
            lh+lv
        }
        await
        if map(x,y)=1:break
        if x=gx&y=gy{
            bool=1
            break
        }
    loop
    return bool
#global

randomize
;マップチップ生成
csz=32
mc=24:mr=16
buffer 2,csz*4,csz:celdiv 2,csz,csz
x=0
color 255,255,255
boxf x,0,x+csz,csz:x+csz
color 1
boxf x,0,x+csz,csz:x+csz
color 255
boxf x,0,x+csz,csz:x+csz
color ,,255
boxf x,0,x+csz,csz
color
boxf x+4,4,x+csz-5,csz-5
;壁生成
dim map,mc,mr
buffer 3,mc*csz,mr*csz
repeat 20
    if rnd(2){
        sx=rnd(mc)
        ex=sx
        sy=rnd(mr)
        ey=rnd(mr)
    }else{
        sx=rnd(mc)
        ex=rnd(mc)
        sy=rnd(mr)
        ey=sy
    }
    if ex-sx>=0{
        xdir=1
    }else{
        xdir=-1
    }
    if ey-sy>=0{
        ydir=1
    }else{
        ydir=-1
    }
    j=sy:i=sx
    repeat abs(ey-sy)/2+1
        repeat abs(ex-sx)/2+1
            map(i,j)=1
            i+xdir
        loop
        i=sx:j+ydir
    loop
loop
flg=0
repeat mr:j=cnt
    repeat mc:i=cnt
        if flg=0&map(i,j)=0{
            objx=i:objy=j:flg=1
        }
        pos i*csz,j*csz:celput 2,map(i,j)
    loop
loop
;処理開始
screen 0,mc*csz,mr*csz
gmode 2
repeat
    pos 0,0:gcopy 3,,,mc*csz,mr*csz
    if 0<=mousex&mousex<ginfo_winx&0<=mousey&mousey<ginfo_winy{
        mpx=mousex/csz:mpy=mousey/csz
        pos objx*csz,objy*csz:celput 2,2
        pos mpx*csz,mpy*csz:celput 2,3
        flg=bresenham(map,mpx,mpy,objx,objy)
        if flg{
            objx=mpx:objy=mpy
        }
    }
    redraw:await 17:redraw 0
loop

文字列型変数は「int」関数を使うことで数字に変換することが出来ますが

半角英字などを変換した場合「0」という数値が返されます

そのため元の文字が"0"という文字だったのか、それ以外の文字だったのは判別がつきません

以下のコードは、変換前の文字列を調べてその文字列が数値だったかどうかを判定するプログラムです

#module
#defcfunc str_num str p1
    tp1=p1
    numflg=0
    dblflg=0
    repeat strlen(tp1)
        code=peek(tp1,cnt)
        if ((code>=129)&(code<=159))|((code>=224)&(code<=252)){    ;2byte文字
            break
        }else:if code=43|code=45{    ;+or-
        }else:if code=46{    ;.
            dblflg=1
        }else:if code<48|57<code{    ;半角文字    
            break
        }else{
            numflg=1
        }
    loop
    mref _stat,64
    _stat = numflg
    if dblflg{
        return double(tp1)
    }else{
        return int(tp1)
    }
#deffunc check str p1
    ans=str_num(p1)
    if stat{
        mes""+p1+"¥t->¥t"+ans+"¥t数値"
    }else{
        mes""+p1+"¥t->¥t¥t数値ではない"
    }
    return
#global
check("012")
check("-12")
check("-12a3")
check("-a3")
check("a3")
check(".12")
check(".a12")
check("-.a12")

六角形を均等に積み重ねて配置するプログラムです

;Win32 APIを用いて六角形を作成
#define global NULL_BRUSH    $00000005
#define global DC_BRUSH        $00000012
#define global DC_PEN        $00000013
#uselib "gdi32"
# func global _Polygon          "Polygon" sptr,sptr,sptr
# func global SetDCPenColor     "SetDCPenColor" sptr,sptr
# func global SetDCBrushColor   "SetDCBrushColor" sptr,sptr
#cfunc global SelectObject      "SelectObject" sptr,sptr
# func global CreateSolidBrush  "CreateSolidBrush" sptr
# func global DeleteObject      "DeleteObject" sptr
#cfunc global GetStockObject    "GetStockObject" sptr
#uselib "user32"
# func global InvalidateRect    "InvalidateRect" sptr,sptr,sptr
#module
#deffunc SetDraw int flg,int col,int col2
    SetDCPenColor hdc,col
    SetDCBrushColor hdc,col2
    hPen=SelectObject(hDC,GetStockObject(DC_PEN))
    if flg=0{
        hBrush=SelectObject(hDC,GetStockObject(NULL_BRUSH))
    }else{
        hBrush=SelectObject(hDC,GetStockObject(DC_BRUSH))
    }
    return
#deffunc Polygon array nleft,int ntop,int col,int col2,int flg
    SetDraw flg,col,col2
    _Polygon hdc,varptr(nleft),ntop
    dim rect,2
    rp.0=varptr(nleft),ntop
    InvalidateRect hwnd,varptr(rp),0
    return
#global
randomize
;マス作成
mcsz=48
m2csz=mcsz+2    ;少し大きめにしないと境目が目立ってしまう
m2cszh=m2csz/2
buffer 2,m2csz*3,m2csz:celdiv 2,m2csz,m2csz
boxf
dim a,12
x=m2cszh
col=$ff
repeat 3
    deg=0
    repeat 6:i=cnt
        rad=deg2rad(deg)
        a(i*2)=0+cos(rad)*m2cszh+x,0+sin(rad)*m2cszh+m2cszh
        deg+60
    loop
    Polygon a,6,$000001,col,1
    col<<8
    x+m2csz
loop
redraw
;描写
screen:gmode 2
mc=10:mr=10
hexw=mcsz/4*3
hexh=sqrt(3)*mcsz/2    ;六角形の幅
x=0:y=0
repeat mr:j=cnt
    repeat mc:i=cnt
        tx=x:ty=y
        if i¥2=1{
            ty+=hexh/2
        }
        pos tx,ty
        celput 2,rnd(3)
        x+=hexw
    loop
    x=0
    y+=hexh
loop

指定の色を判定して、赤っぽい色なら「Red」、青っぽい色なら「Blue」という風に

色の名前を表示するプログラムです

取得した色をHSVモデルに変換し、どの色に属するかを調べます

cx=double(ginfo(26))/2.0    ;中心の座標X
cy=double(ginfo(27))/2.0    ;中心の座標Y
outr=150.0            ;外側の半径
ntrad=deg2rad(1)
ntc_h=192.0/360
ntc_s=255.0/outr
setc_v=255.0
ddim harea,6
ntharea=192.0/6
stharea=ntharea/2
repeat 6        ;色判定エリア
    harea(cnt)=stharea
    stharea+ntharea
loop
color:boxf
redraw 0
gosub *hsvcircledraw
redraw
oncmd gosub *mousewheel, $20A    ;マウスホイールで明度（Ｖ）を変更
oncmd gosub *mousemove, $200    ;カーソル移動で座標の色を調べる
stop
*mousemove
    oncmd 0
    redraw 0
    gosub *hsvget
    gosub *hsvcheck
    redraw
    oncmd 1
    return
*mousewheel
    tmousew=0f+(wparam >> 16 & $ffffffff)
    oncmd 0
    redraw 0
    setc_v=limitf(setc_v+(tmousew/2),0,255)
    gosub *hsvcircledraw
    gosub *hsvget
    gosub *hsvcheck
    redraw
    oncmd 1
    return
*hsvget    ;RGB->HSV
    pget mousex,mousey
    dim rgbdt,3:rgbdt=ginfo(16),ginfo(17),ginfo(18)
    ;V値
    max=0:min=255
    repeat 3
        if max<rgbdt(cnt){max=rgbdt(cnt)}
        if min>rgbdt(cnt){min=rgbdt(cnt)}
    loop
    v=max
    ;S値
    if v{ s=255.0*(v-min)/v }
    else{ s=0.0 }
    ;H値
    if v=rgbdt(0){
        if v-min{ h=32.0*(rgbdt(1)-rgbdt(2))/(v-min) }
        else{ h=32.0*(rgbdt(1)-rgbdt(2)) }
    }else:if v=rgbdt(1){
        if v-min{ h=32.0*(2.0+double(rgbdt(2)-rgbdt(0))/(v-min)) }
        else{ h=32.0*(2.0+double(rgbdt(2)-rgbdt(0))) }
    }else{
        if v-min{ h=32.0*(4.0+double(rgbdt(0)-rgbdt(1))/(v-min)) }
        else{ h=32.0*(4.0+double(rgbdt(0)-rgbdt(1)))}
    }
    if h<0.0:h+192.0
    hsvcolor h,s,v
    boxf 30,30,130,130
    return
*hsvcheck    ;色判定
    repeat 6
        flg=0
        if cnt=0{
            if harea(length(harea)-1)<h|h<=harea(cnt){ flg=1 }
        }else{
            if harea(cnt-1)<h&h<harea(cnt){ flg=1}
        }
        if flg=1{
            c_hid=cnt
            break
        }
    loop
    color 255,255,255 : boxf 150,30,250,60 : color
    pos 160,35
    if s<100{
        if v<128{
            mes"Black"
        }else{
            mes"White"
        }
    }else{
        switch c_hid
        case 0 : mes"Red" : swbreak
        case 1 : mes"Yellow" : swbreak
        case 2 : mes"Green" : swbreak
        case 3 : mes"Cyan" : swbreak
        case 4 : mes"Blue" : swbreak
        case 5 : mes"Magenta" : swbreak
        swend
    }
    return
*hsvcircledraw    ;HSV円描写
    r2=outr : r1=r2-1.0
    c_h=0.0 : c_s=255.0 : c_v=255.0
    rad0=0.0 : rad1=ntrad
    ntc_v=(255.0-setc_v)/outr
    repeat r2
        repeat 360
            p1x=cx+r1*cos(rad0) : p1y=cy+r1*sin(rad0)
            p2x=cx+r2*cos(rad0) : p2y=cy+r2*sin(rad0)
            p4x=cx+r1*cos(rad1) : p4y=cy+r1*sin(rad1)
            p3x=cx+r2*cos(rad1) : p3y=cy+r2*sin(rad1)
            x=int(p1x),int(p2x),int(p3x),int(p4x)
            y=int(p1y),int(p2y),int(p3y),int(p4y)
            ;四角形描写
            hsvcolor int(c_h),int(c_s),int(c_v)
            gsquare -1,x,y
            rad0=rad1 : rad1+ntrad : c_h+ntc_h
        loop
        r2-1.0 : r1-1.0
        c_s-ntc_s : c_v-ntc_v
    loop
    return

整数と実数をそれぞれ比べて、同じ値かどうかを確認するソースコードです

h_i=11
h_d=11.25
if double(h_i)-double(h_d)=0{
    mes"同じ数字"
}else{
    mes"異なる数字"
}

文字列配列の中を調べ、同じ文字列の位置を取得するプログラムです

第一引数：検索結果（重複文字列の位置）を格納する配列

第二引数：検索する文字列配列

第三引数：初めから数えて指定した要素番号の値が何回繰り返されたか調べる

第四引数：指定した数を検索（10を指定すると要素番号0〜9まで検索）

戻り値：繰り返された回数を返す

#module
#defcfunc duplicatenum array resarr,array arr,int uid,int max
    if uid>=max|uid>=length(arr)|uid>=length(resarr){dialog"第2引数が大きすぎます":return -1}
    memset resarr,length(resarr)*4,0
    my=arr(uid)
    setid=0:ordid=0
    repeat max:chkid=cnt
        if my!=arr(chkid):continue
        if setid=1{
            resarr(0)=bfid
        }
        if setid>=1{
            resarr(setid)=chkid
        }
        setid++:bfid=chkid
        if uid=chkid{
            ordid=setid
        }
    loop
    return ordid
#global
randomize
len=20
sdim arr,len
repeat len
    r=rnd(3)
    if r=0{
        arr(cnt)="「番号」"
    }else:if r=1{
        arr(cnt)="「ID」"
    }else{
        arr(cnt)="「No.」"
    }
loop
dim resarr,len
repeat len
    num=duplicatenum(resarr,arr,cnt,len)
    y=cnt*20
    pos 0,y:mes""+cnt+". "+arr(cnt)
    pos 120,y:mes""+num+"番目¥t¥t"
    if num>1{
        pos 200,y:mes"重複あり"
    }
    repeat num
        pos 300+cnt*20,y:mes""+resarr(cnt)
    loop
loop

2次元文字列型配列をソートするプログラムです

keyの値を指定することで、指定された一次元要素番号を基準に並べ替えます

#module
;二次元文字列配列並べ替え（対象配列変数名、基準となる要素番号、並び順）
#deffunc sortstr2 array arr,int key,int order
    len1=length(arr):if len1<=key{key=len1-1}
    len2=length2(arr)
    sdim tmp,varsize(arr),len2
    sdim toarr,varsize(arr),len1,len2
    repeat len2
        tmp(cnt)=arr(key,cnt)
    loop
    sortstr tmp,order    ;配列変数を文字列でソート
    repeat len2:j=cnt
        sortget n,j    ;ソート元のインデックスを取得
        repeat len1:i=cnt
            toarr(i,j)=arr(i,n)
        loop
    loop
    ;元の配列に並び替えた結果を代入
    repeat len2:j=cnt
        repeat len1:i=cnt
            arr(i,j)=toarr(i,j)
        loop
    loop
    return
#global
;文字列配列作成
randomize
sdim a,,3,10
repeat 10:j=cnt
    repeat 3:i=cnt
        pt=0
        repeat 10    ;一要素の最大文字数
            if rnd(2){
                if i{
                    poke a(i,j),pt,rnd(122-96)+97
                }else{
                    poke a(i,j),pt,rnd(90-64)+65
                }
                pt++
            }
        loop
    loop
    mes""+a(0,j)+"¥t"+a(1,j)+"¥t"+a(2,j)
loop
;並べ替え後
pos 320,0
sortstr2 a,0,1
repeat 10:j=cnt
    mes""+a(0,j)+"¥t"+a(1,j)+"¥t"+a(2,j)
loop

HSPには、文字列の長さをバイト単位で取得したり（strlen）、

バイト数を指定して文字列を取得する関数（memcpy）があります

しかし文字数を指定し、それが何バイト分になるかを確認する関数はありません

以下のプログラムは、1バイト文字と2バイト文字が混ざった文字列を元に

指定の文字数のバイト数がいくつになるかを求めています

#define global ctype peekget(%1="",%2=0,%3=0) _peekget(%1,%2,%3)
#module
#defcfunc _peekget var p1,int p2,int p3
    if p2<0:return 0
    id=0
    add=1
    repeat p2,p3
        code=peek(p1,id+p3)
        if ((code>=129)&(code<=159))|((code>=224)&(code<=252)){
            id+add
        }else:if code=0{
            break
        }
        id+add
    loop
    return id
#global
title"5文字ずつ表示"
text="ﾊﾝｶｸとゼンカクの文字数のbyte数を数える"
mes""+text+"¥n"
sdim val
id=0
repeat 5
    len=peekget(text,5,id)    ;指定文字数のバイト数を取得（開始位置はバイトで指定）
    memcpy val,text,len,0,id
    poke val,len
    mes""+val+"¥t"+len
    id+=len
loop

3DダンジョンRPGの視点を再現したプログラムです

十字キーで移動、旋回ができます

#const c_parts 15
#enum e_empty=0
#enum e_wl
gw=640:gh=480
gwh=gw/2:ghh=gh/2
buffer 2,gw,gh
buffer 3,gw,gh
;迷路作成
randomize
mc=5:mr=5
dim mapdt,mc,mr
repeat mr:j=cnt
    repeat mc:i=cnt
        mapdt(i,j)=e_wl
    loop
loop
dim dx,4:dx=-1,0,1,0
dim dy,4:dy=0,-1,0,1
mapdt(0,0)=1,1,1,1,1
mapdt(0,1)=1,0,0,0,1
mapdt(0,2)=1,1,0,1,1
mapdt(0,3)=1,0,0,0,1
mapdt(0,4)=1,1,1,1,1
;壁データ作成
cx=gw/2:cy=gh/2
wldir=40
wlpt0=550
wlpt1=wlpt0-250
wlpt2=wlpt1-150
wlpt3=wlpt2-100
ddim wllndtx,4,c_parts
ddim wllndty,4,c_parts
lurad=deg2rad(180-wldir)
lbrad=deg2rad(180+wldir)
lurad2=lurad
lbrad2=lbrad
rurad=deg2rad(wldir)
rbrad=deg2rad(-wldir)
rurad2=rurad
rbrad2=rbrad
;左壁大
wllndtx(0,0)=cos(lurad)*wlpt1+cx,cos(lurad)*wlpt0+cx,cos(lbrad)*wlpt0+cx,cos(lbrad)*wlpt1+cx
wllndty(0,0)=sin(lurad)*wlpt1+cy,sin(lurad)*wlpt0+cy,sin(lbrad)*wlpt0+cy,sin(lbrad)*wlpt1+cy
;右壁大
wllndtx(0,1)=cos(rurad)*wlpt1+cx,cos(rurad)*wlpt0+cx,cos(rbrad)*wlpt0+cx,cos(rbrad)*wlpt1+cx
wllndty(0,1)=sin(rurad)*wlpt1+cy,sin(rurad)*wlpt0+cy,sin(rbrad)*wlpt0+cy,sin(rbrad)*wlpt1+cy
;正面大
wllndtx(0,2)=cos(lurad)*wlpt1+cx,cos(rurad)*wlpt1+cx,cos(rbrad)*wlpt1+cx,cos(lbrad)*wlpt1+cx
wllndty(0,2)=sin(lurad)*wlpt1+cy,sin(rurad)*wlpt1+cy,sin(rbrad)*wlpt1+cy,sin(lbrad)*wlpt1+cy
;左壁中
wllndtx(0,3)=cos(lurad)*wlpt2+cx,cos(lurad)*wlpt1+cx,cos(lbrad)*wlpt1+cx,cos(lbrad)*wlpt2+cx
wllndty(0,3)=sin(lurad)*wlpt2+cy,sin(lurad)*wlpt1+cy,sin(lbrad)*wlpt1+cy,sin(lbrad)*wlpt2+cy
;右壁中
wllndtx(0,4)=cos(rurad)*wlpt2+cx,cos(rurad)*wlpt1+cx,cos(rbrad)*wlpt1+cx,cos(rbrad)*wlpt2+cx
wllndty(0,4)=sin(rurad)*wlpt2+cy,sin(rurad)*wlpt1+cy,sin(rbrad)*wlpt1+cy,sin(rbrad)*wlpt2+cy
;正面中
wllndtx(0,5)=cos(lurad)*wlpt2+cx,cos(rurad)*wlpt2+cx,cos(rbrad)*wlpt2+cx,cos(lbrad)*wlpt2+cx
wllndty(0,5)=sin(lurad)*wlpt2+cy,sin(rurad)*wlpt2+cy,sin(rbrad)*wlpt2+cy,sin(lbrad)*wlpt2+cy
;左壁小
wllndtx(0,6)=cos(lurad)*wlpt3+cx,cos(lurad)*wlpt2+cx,cos(lbrad)*wlpt2+cx,cos(lbrad)*wlpt3+cx
wllndty(0,6)=sin(lurad)*wlpt3+cy,sin(lurad)*wlpt2+cy,sin(lbrad)*wlpt2+cy,sin(lbrad)*wlpt3+cy
;右壁小
wllndtx(0,7)=cos(rurad)*wlpt3+cx,cos(rurad)*wlpt2+cx,cos(rbrad)*wlpt2+cx,cos(rbrad)*wlpt3+cx
wllndty(0,7)=sin(rurad)*wlpt3+cy,sin(rurad)*wlpt2+cy,sin(rbrad)*wlpt2+cy,sin(rbrad)*wlpt3+cy
;正面小
wllndtx(0,8)=cos(lurad)*wlpt3+cx,cos(rurad)*wlpt3+cx,cos(rbrad)*wlpt3+cx,cos(lbrad)*wlpt3+cx
wllndty(0,8)=sin(lurad)*wlpt3+cy,sin(rurad)*wlpt3+cy,sin(rbrad)*wlpt3+cy,sin(lbrad)*wlpt3+cy
;左側奥
wllndtx(0,9)=cos(lurad)*wlpt2+cx,cos(lurad2)*wlpt3+cx,cos(lbrad2)*wlpt3+cx,cos(lbrad)*wlpt2+cx
wllndty(0,9)=sin(lurad)*wlpt3+cy,sin(lurad2)*wlpt3+cy,sin(lbrad2)*wlpt3+cy,sin(lbrad)*wlpt3+cy
;右側奥
wllndtx(0,10)=cos(rurad2)*wlpt3+cx,cos(rurad)*wlpt2+cx,cos(rbrad)*wlpt2+cx,cos(rbrad2)*wlpt3+cx
wllndty(0,10)=sin(rurad2)*wlpt3+cy,sin(rurad)*wlpt3+cy,sin(rbrad)*wlpt3+cy,sin(rbrad2)*wlpt3+cy
;左側小
wllndtx(0,11)=cos(lurad)*wlpt1+cx,cos(lurad2)*wlpt2+cx,cos(lbrad2)*wlpt2+cx,cos(lbrad)*wlpt1+cx
wllndty(0,11)=sin(lurad)*wlpt2+cy,sin(lurad2)*wlpt2+cy,sin(lbrad2)*wlpt2+cy,sin(lbrad)*wlpt2+cy
;右側小
wllndtx(0,12)=cos(rurad2)*wlpt2+cx,cos(rurad)*wlpt1+cx,cos(rbrad)*wlpt1+cx,cos(rbrad2)*wlpt2+cx
wllndty(0,12)=sin(rurad2)*wlpt2+cy,sin(rurad)*wlpt2+cy,sin(rbrad)*wlpt2+cy,sin(rbrad2)*wlpt2+cy
;左側中
wllndtx(0,13)=cos(lurad)*wlpt0+cx,cos(lurad2)*wlpt1+cx,cos(lbrad2)*wlpt1+cx,cos(lbrad)*wlpt0+cx
wllndty(0,13)=sin(lurad)*wlpt1+cy,sin(lurad2)*wlpt1+cy,sin(lbrad2)*wlpt1+cy,sin(lbrad)*wlpt1+cy
;右側中
wllndtx(0,14)=cos(rurad2)*wlpt1+cx,cos(rurad)*wlpt0+cx,cos(rbrad)*wlpt0+cx,cos(rbrad2)*wlpt1+cx
wllndty(0,14)=sin(rurad2)*wlpt1+cy,sin(rurad)*wlpt1+cy,sin(rbrad)*wlpt1+cy,sin(rbrad2)*wlpt1+cy
;チェックマスデータ作成
dim chkdx,c_parts
dim chkdy,c_parts
dim patternx,c_parts,4
dim patterny,c_parts,4
patternx(0,0)=0,0,-1,-1,-1,-2,-2,-2,-3,-3,-3
patterny(0,0)=1,-1,0,1,-1,0,1,-1,0,1,-1
patternx(0,1)=-1,1,0,-1,1,0,-1,1,0,-1,1
patterny(0,1)=0,0,-1,-1,-1,-2,-2,-2,-3,-3,-3
patternx(0,2)=0,0,1,1,1,2,2,2,3,3,3
patterny(0,2)=-1,1,0,-1,1,0,-1,1,0,-1,1
patternx(0,3)=1,-1,0,1,-1,0,1,-1,0,1,-1
patterny(0,3)=0,0,1,1,1,2,2,2,3,3,3
repeat 4
    patternx(11,cnt)=patternx(6,cnt),patternx(7,cnt),patternx(3,cnt),patternx(4,cnt)
    patterny(11,cnt)=patterny(6,cnt),patterny(7,cnt),patterny(3,cnt),patterny(4,cnt)
loop
;処理開始
gsel 0
startx=1:starty=1:startdir=2
plrx=startx:plry=starty:plrdir=startdir
oncmd gosub *on_keydown,0x0100
gosub *mazedraw
stop
*on_keydown
    oncmd 0
    tplrx=plrx
    tplry=plry
    if wparam=37{    ;左旋回
        plrdir=(plrdir-1)&3
        sceneid=0
    }else:if wparam=38{    ;前進
        tplrx=plrx+dx(plrdir)
        tplry=plry+dy(plrdir)
        sceneid=1
    }else:if wparam=39{    ;右旋回
        plrdir=(plrdir+1)&3
        sceneid=2
    }else:if wparam=40{    ;後退
        tplrx=plrx-dx(plrdir)
        tplry=plry-dy(plrdir)
        sceneid=3
    }
    if mapdt(tplrx,tplry)=0{
        plrx=tplrx
        plry=tplry
        gosub *mazedraw
    }
    oncmd 1
    return
*mazedraw
    redraw 0:color:boxf:color 255,255,255
    memcpy chkdx,patternx,c_parts*4,0,plrdir*c_parts*4
    memcpy chkdy,patterny,c_parts*4,0,plrdir*c_parts*4
    dim chkflg,c_parts
    repeat c_parts
        chkdx(cnt)+plrx
        chkdy(cnt)+plry
        x=chkdx(cnt):y=chkdy(cnt)
        if 0<=x&x<mc&0<=y&y<mr{
            chkflg(cnt)=mapdt(chkdx(cnt),chkdy(cnt))
        }else{
            chkflg(cnt)=e_wl
        }
    loop
    if chkflg(2)=e_wl{
        repeat 10,3
            chkflg(cnt)=e_empty
        loop
    }else{
        if chkflg(5)=e_wl{
            repeat 5,6
                chkflg(cnt)=e_empty
            loop
        }else{
            repeat 2,6
                if chkflg(cnt)=e_wl:chkflg(cnt+3)=0
            loop
        }
        repeat 2,3
            if chkflg(cnt)=e_wl:chkflg(cnt+8)=0
        loop
    }
    repeat 2
        if chkflg(cnt)=e_wl:chkflg(cnt+13)=0
    loop
    repeat c_parts:id=cnt
        if chkflg(id)=e_wl{
            pos wllndtx(3,id),wllndty(3,id)
            repeat 4,0
                line wllndtx(cnt,id),wllndty(cnt,id)
            loop
        }
    loop
    redraw
    return

参考資料：http://hp.vector.co.jp/authors/VA054130/%E8%BF%B7%E8%B7%AF%E6%8F%8F%E7%94%BB%E3%82%A2%E3%83%AB%E3%82%B4%E3%83%AA%E3%82%BA%E3%83%A0%EF%BC%92.txt

「うそつきクイズ」とは論理パズルの一種で、発言内容から誰が嘘つきかを当てる問題です

このプログラムはその論理パズルを自動で作ります

上二行の数字を書き換えることで出てくるキャラクターの人数を変えられます

#define membermax 3    ;総数
#define fakenum 1    ;嘘つき人数
randomize
;発言内容は誰を対象とするか
dim taisyou,membermax
repeat membermax
    val=rnd(cnt+1)
    taisyou.cnt=taisyou.val
    taisyou.val=cnt
loop
repeat membermax
    if taisyou(cnt)=cnt{
        id=cnt
        repeat membermax
            if id!=cnt{
                tmp=taisyou(cnt)
                taisyou(cnt)=taisyou(id)
                taisyou(id)=tmp
                break
            }
        loop
    }
loop
;誰を嘘つきにするか
dim usotsuki,membermax
repeat membermax
    val=rnd(cnt+1)
    usotsuki.cnt=usotsuki.val
    usotsuki.val=cnt
loop
dim usohonto,membermax
repeat fakenum
    usohonto(usotsuki(cnt))=1
loop
;メンバーの名前
sdim namelist,membermax
repeat membermax
    namelist(cnt)=strf("%c",cnt+65)
loop
;処理開始
title"うそつきの人数："+fakenum
repeat membermax
    name=namelist(taisyou(cnt))
    if usohonto(cnt){
        if usohonto(taisyou(cnt)){
            mes""+namelist(cnt)+" 「 "+name+" は正直」"
        }else{
            mes""+namelist(cnt)+" 「 "+name+" はうそつき」"
        }
    }else{
        if usohonto(taisyou(cnt)){
            mes""+namelist(cnt)+" 「 "+name+" はうそつき」"
        }else{
            mes""+namelist(cnt)+" 「 "+name+" は正直」"
        }
    }
loop
pos 320,0
button gosub "答え",*kotae
stop
*kotae
    repeat membermax
        if usohonto(cnt){
            mes"うそつきは"+namelist(cnt)
        }
    loop
    return

こちらのサイトに「マーブリング」という表現技法を再現したプログラムがあったので、HSPでも実装してみました

ソースコードはこちらのサイトをパクら参考にさせていただきました

処理が重すぎたり、もっとキャンパスをでかくしたい場合はgwとghのサイズを変更してみてください

VRAMを利用したりマシン語を用いたりすれば動作がさらに軽くなります

もっと軽快にしたい方は挑戦してみてください

randomize
gw=250:gh=250
screen 0,gw,gh,1
oncmd gosub *on_EXITSIZEMOVE, 0x0232
oncmd gosub *on_KEYDOWN, 0x0100
winx=ginfo(4):winy=ginfo(5)
;パレットカラー設定
colmax=10
repeat colmax-1,1
    hsvcolor (cnt-1)*19,255,255
    palette cnt,ginfo_r,ginfo_g,ginfo_b
loop
palette 0,255,255,255,1
;処理開始
dim board,gw,gh
dim tboard,gw,gh
tr=10.0
ncl=1
repeat
    getkey k1,1
    getkey k2,2
    muw=mousew
    if k1{    ;左クリックで滴下
        if k1flg=0{
            ;ncl=rnd(colmax-1)+1    ;色をランダム指定する場合はコメント解除
            r=tr
            k1flg=1
        }
        if x!=mousex|y!=mousey{
            r=tr
        }
        x=mousex:y=mousey
        gosub *drawcircle
        r+=1.0
    }else{
        r=tr
        k1flg=0
    }
    if k2{    ;右クリックしたままドラッグで引っ張り
        if k2flg=0{
            x=mousex:y=mousey
        }
        k2flg=1
    }else{
        if k2flg{
            tx=mousex:ty=mousey
            if tx!=x|ty!=y{
                theta=atan(ty-y,tx-x)
                ex=cos(theta)
                ey=sin(theta)
                rx=cos(theta+M_PI/2)
                ry=sin(theta+M_PI/2)
                alpha=sqrt(powf(ty-y,2)+powf(tx-x,2))
                beta=sqrt(alpha)
                gosub *drawline
                k2flg=0
            }
        }
    }
    if muw!=0{    ;マウスホイールを動かすと攪拌
        x=mousex:y=mousey
        r=0f+rnd(100)
        if muw>0{
            alpha=0f+muw
        }else{
            alpha=-0f+muw
        }
        beta=10.0
        gosub *drawspiral
    }
    redraw:wait:redraw 0
loop
*on_KEYDOWN
    if 48<=wparam&wparam<=57{    ;テンキーで描写する色を変更
        ncl=wparam-48
    }
    return
*on_EXITSIZEMOVE
    if winx!=ginfo(4)|winy!=ginfo(5){    ;ウィンドウを動かすと波打つ
        A=sqrt(powf(winx-ginfo(4),2)+powf(winy-ginfo(5),2))/50
        t=atan(ginfo(5)-winy,ginfo(4)-winx)
        fai=deg2rad(rnd(180))
        omega=0.5
        gosub *drawwave
    }
    winx=ginfo(4):winy=ginfo(5)
    return
*drawcircle
    memcpy tboard,board,gw*gh*4
    repeat gh:j=cnt
        repeat gw:i=cnt
            if powf(i-x,2)+powf(j-y,2)<=powf(r,2){
                board(i,j)=ncl
            }else{
                tmp=sqrt(1.0-powf(r,2)/(powf(i-x,2)+powf(j-y,2)))
                fx=0+(0.5+tmp*(i-x)+x)
                fy=0+(0.5+tmp*(j-y)+y)
                if 0<=fx&fx<gw&0<=fy&fy<gh{
                    board(i,j)=tboard(fx,fy)
                }
            }
            palcolor board(i,j)
            pset i,j
        loop
    loop
    return
*drawline
    memcpy tboard,board,gw*gh*4
    repeat gh:j=cnt
        repeat gw:i=cnt
            tmp=alpha*beta/(beta+absf(rx*(i-x)+ry*(j-y)))
            fx=0+((0.5+i)-tmp*ex)
            fy=0+((0.5+j)-tmp*ey)
            if 0<=fx&fx<gw&0<=fy&fy<gh{
                board(i,j)=tboard(fx,fy)
            }
            palcolor board(i,j)
            pset i,j
        loop
    loop
    return
*drawspiral
    memcpy tboard,board,gw*gh*4
    repeat gh:j=cnt
        repeat gw:i=cnt
            len=powf(i-x,2)+powf(j-y,2)
            if len>0{
                d=absf(sqrt(len)-r)
                theta=alpha*beta/((d+beta)*(sqrt(len)))
                fx=0+((cos(theta)*(i-x)+x+sin(theta)*(j-y))+0.5)
                fy=0+(((-sin(theta))*(i-x)+y+cos(theta)*(j-y))+0.5)
                if 0<=fx&fx<gw&0<=fy&fy<gh{
                    board(i,j)=tboard(fx,fy)
                }
            }
            palcolor board(i,j)
            pset i,j
        loop
    loop
    return
*drawwave
    memcpy tboard,board,gw*gh*4
    repeat gh:j=cnt
        repeat gw:i=cnt
            theta=omega*(sin(t)*i-cos(t)*j)+fai
            fx=0+((0f+i)-A*sin(theta)*cos(t)+0.5)
            fy=0+((0f+j)-A*sin(theta)*sin(t)+0.5)
            if 0<=fx&fx<gw&0<=fy&fy<gh{
                board(i,j)=tboard(fx,fy)
            }
            palcolor board(i,j)
            pset i,j
        loop
    loop
    return

ウィンドウ自体を移動させたとき、移動前と移動後でどのくらい座標が変化したかを取得するプログラムです

#define WM_EXITSIZEMOVE 0x0232    
oncmd gosub *on_EXITSIZEMOVE, WM_EXITSIZEMOVE
winx=ginfo(4):winy=ginfo(5)
stop
*on_EXITSIZEMOVE
    if winx!=ginfo(4)|winy!=ginfo(5){
        mes"winx = "+(ginfo(4)-winx)+", winy = "+(ginfo(5)-winy)
    }
    winx=ginfo(4):winy=ginfo(5)
    return

キャラクターの吹き出しを描写するプログラムです

端に近い位置のキャラの吹き出しは、見切れないよう描写位置を調整しています

randomize
;キャラクター
chcsz=64
buffer 2,chcsz,chcsz:celdiv 2,chcsz,chcsz,chcsz/2,chcsz/2
color:boxf:color 255
circle chcsz/4,0,chcsz-chcsz/4,chcsz/2
xzh=chcsz/2,chcsz/2,chcsz,0
yzh=chcsz/4,chcsz/4,chcsz,chcsz
gsquare -1,xzh,yzh
;初期設定
charamax=8
dim charadt,4,charamax
gsel
gmode 2
repeat charamax
    cenx=rnd(560)+40
    ceny=rnd(400)+40
    charadt(0,cnt)=cenx-chcsz/2,ceny-chcsz/2,cenx+chcsz/2,ceny+chcsz/2
loop
repeat charamax
    pos charadt(0,cnt)+chcsz/2,charadt(1,cnt)+chcsz/2
    celput 2,0
loop
;背景
buffer 3,640,480
pos 0,0:gcopy 0,,,640,480
gsel 0
;処理開始
oncmd gosub *mousemove, $200
stop
*mousemove
    pos 0,0:gcopy 3,,,640,480
    mux=mousex:muy=mousey
    putid=-1
    repeat charamax
        ltx=charadt(0,cnt)
        lty=charadt(1,cnt)
        rbx=charadt(2,cnt)
        rby=charadt(3,cnt)
        if ltx<=mux&mux<=rbx&lty<=muy&muy<=rby{
            putid=cnt
            break
        }
        await
    loop
    title""+putid
    if putid>=0{
        gosub *fukidasi
    }
    return
*fukidasi
    x=ltx-80:y=lty-50
    xdir=0:ydir=0
    if ltx<=120{x=rbx:xdir=1}
    if lty<=120{y=rby:ydir=1}
    color ,,255
    boxf x,y,x+80,y+50
    if xdir{
        xzh=rbx,rbx-20,rbx-20,rbx
    }else{
        xzh=ltx,ltx+20,ltx+20,ltx
    }
    if ydir{
        yzh=rby+20,rby-10,rby-10,rby
    }else{
        yzh=lty-20,lty+10,lty+10,lty
    }
    gsquare -1,xzh,yzh
    return

Splitを用いて文字列を分割するとき、区切り用の文字は一度に一種類しか指定できません

この問題（？）に対処するため、正規表現を用いることで複数の区切り文字を指定できる関数を作成しました

8/22  2バイト文字に対応

;正規表現モジュール
#define global ctype twobytenum(%1="",%2=0,%3=0) _twobytenum(%1,%2,%3)
#ifndef __mod_regexp_r
#define __mod_regexp_r
#module
#deffunc _startregexp_r
    newcom oReg,"VBScript.RegExp"
    return
#deffunc matches_r array retvar,array resindex,var target,str Pattern,int IgnoreCase,int Global,int Multiline
    oReg("IgnoreCase") = (IgnoreCase==0)
    oReg("Global") = (Global==0)
    oReg("Multiline") = (Multiline==0)
    oReg("Pattern") = Pattern
    comres oMatches
    oReg->"Execute" target
    if stat<0:sdim retvar,1,1:return 0
    num1=oMatches("count")
    if num1==0:sdim retvar,1,1:    delcom oMatches:return 0
    oMatch=oMatches("item",0)
    sdim retvar,64,num1,num2+1
    dim resindex,num1,num2+1
    id=0
    plus=0
    for i,0,num1,1
        oMatch=oMatches("item",i)
        retvar.i=oMatch("value")
        resindex.i=oMatch("FirstIndex")+plus
        plus=twobytenum(target,resindex.i,id)
        resindex.i+=plus
    next
    variant=0
    delcom oMatch
    delcom oMatches
    return num1
    return
#defcfunc _twobytenum var p1,int p2,int p3
    if p2<0:return 0
    id=0
    add=1
    two=0
    repeat p2,p3
        code=peek(p1,id+p3)
        if ((code>=129)&(code<=159))|((code>=224)&(code<=252)){
            id+add
            two++
        }
        id+add
    loop
    return two
#global
_startregexp_r
#endif
;正規表現対応split
#module
#deffunc splitr var sentence,str symbol,array clause
    sdim clause
    sdim punctuation
    dim index
    matches_r punctuation,index,sentence,symbol
    matchnum=stat
    cid=0:sid=0
    repeat matchnum
        memcpy clause(cid),sentence,index(cnt)-sid,0,sid
        clause(cid)=str(clause(cid))
        cid++:sid=index(cnt)+strlen(punctuation(cnt))
    loop
    memcpy clause(cid),sentence,strlen(sentence)-sid,0,sid
    mref _stat,64
    _stat = matchnum+1
    return
#global
;処理開始
sentence="aaa,いいい-ccc/ddd"
splitr sentence,"[,-/]",clause
repeat stat
    mes""+clause(cnt)
loop

こちらの記事を参考に「noteget」の代わりに「instr & memcpy」でサイズが大きいテキストファイルを読み込むプログラムを作成しました

処理時間を計測し、どのくらい早くなったかを比較しています

また、複数の種類の改行コードにも対応させました

#include "mod_regexp.as"
sdim filestr
sdim tfilestr
sdim linestr,1000    ;一行につき千文字まで取得可能
;処理時間を計測するのに必要な諸々の設定
#uselib "kernel32"
#func QueryPFreq "QueryPerformanceFrequency" var
#func QueryPCount "QueryPerformanceCounter" var
dim lgint,4    ;LARGE_INTEGER構造体
#define _start QueryPFreq nFreq : QueryPCount nBefore
#define _goal QueryPCount lgint(2) : dwTime=strf("%%.3fmSec",1000.*(lgint(2)-nBefore)/nFreq)
;テキストファイル読み込み
dialog "",16
if stat{
    filedir=refstr
    chdir getpath(filedir,32)
    exist filedir
    filesize=strsize
    if filesize<0:end
    filename=getpath(filedir,1+8+2)
    notesel filestr
    noteload filedir
}else{
    end
}
;改行コードの取得
lf=strf("%c",10)
cr=strf("%c",13)
crlf=cr+lf
newlinecode=""
newlineln=0
if instr(filestr,0,crlf)>=0{
    newlinecode=crlf
    newlineln=2
}else:if instr(filestr,0,cr)>=0{
    newlinecode=cr
    newlineln=1
}else:if instr(filestr,0,lf)>=0{
    newlinecode=lf
    newlineln=1
}
;noteget の処理時間
_start    ;計測開始
id=0
lineln=0
tfilestr=""
nmax=notemax
repeat nmax
    noteget linestr,cnt
    gosub *lineprocess
loop
_goal    ;計測終了
pos 0:mes"noteget の処理時間 ："+dwTime
;instr & memcpy の処理時間
_start    ;計測開始
id=0
lineln=0
tfilestr=""
repeat
    lineln=instr(filestr,id,newlinecode)
    if lineln<0{
        if id<filesize{
            lineln=filesize-id
            bkflg=1
        }else{
            break
        }
    }
    memset linestr,0,1000    ;初期化しないと出力結果がおかしくなる
    memcpy linestr,filestr,lineln,0,id
    gosub *lineprocess
    if bkflg:break
    id+=lineln+newlineln
loop
_goal    ;計測終了
filestr=tfilestr
notesave "t_"+filename    ;変換ファイル出力
pos 0:mes"instr & memcpy の処理時間："+dwTime
noteunsel
stop

;取得行処理
*lineprocess
    ;置換処理（a->b, あ->い）
    linestr=replace(linestr,"a","b")
    linestr=replace(linestr,"あ","い")
    tfilestr+=linestr+newlinecode    ;変換行を代入
    return

テキストファイルをプログラム上で操作する場合「repeat notemax 〜 loop」とすると、すべての行に対して処理が行えます

しかし、処理の途中で「noteadd」などを使用すると行数が変わってしまい、終わりの数行が編集できない場合があります

このプログラムではテキストの行数をループ中でも取得することで、上記の問題点に対処できるようにしました

a="aa¥nbb¥n¥ncc¥n"
notesel a
repeat
    nmax=notemax
    if nmax<=cnt:break
    if cnt=2|cnt=4{
        noteadd "add",cnt,0
    }
    noteget b,cnt
    mes b
loop

横並びの単語を一定数のtabで区切ると、右側の単語が揃わずバラバラになることがあります

このプログラムはそれを解消するプログラムです

左側に変換元の文字列を入れてボタンを押すと、右側に変換された文字列が表示されます

bfstr={"

Programming		Language
HSP				Script
Hello		World

"}

;変換前
pos 0,0:mesbox bfstr,320,400
afstr=""
;変換後
pos 320,0:mesbox afstr,320,400:stat_afstr=stat:hwnd_afstr = objinfo(stat_afstr, 2)
pos 320,400:objsize 320,50:button gosub "Arrangement",*arrangement
sdim lstdt,,10,10000:lstlid=0
sdim bfstrline,,10000
sdim bfstrcell,,10
tablen=8    ;タブの幅
bfstrsize=strlen(bfstr)
stop
*arrangement
    chksize=0
    split bfstr,"¥n",bfstrline
    ;一行ごとにタブで区切られた文節を取得
    repeat length(bfstrline):lcnt=cnt
        repeat length(bfstrcell)
            bfstrcell(cnt)=""
        loop
        chksize+(strlen(bfstrline(cnt))+2)
        split bfstrline(cnt),"¥t",bfstrcell
        id=0
        repeat length(bfstrcell)
            if bfstrcell(cnt)!=""{
                lstdt(id,lcnt)=bfstrcell(cnt)
                id++
            }
        loop
        if chksize>bfstrsize:break
        lstlid++
    loop
    ;文節の最大長を取得
    max=0
    repeat lstlid
        if max<strlen(lstdt(0,cnt)){
            max=strlen(lstdt(0,cnt))
        }
    loop
    ;一行ごとに右側が揃うタブ数を計算して追加
    rightid=(max/tablen+1)*tablen
    repeat lstlid:lcnt=cnt
        trid=0
        repeat length(lstdt)-1
            if lstdt(cnt,lcnt)!=""{
                afstr+=lstdt(cnt,lcnt)
                if lstdt(cnt+1,lcnt)!=""{
                    lpnum=(rightid-strlen(lstdt(cnt,lcnt)))/tablen+1
                    repeat lpnum
                        afstr+="¥t"
                    loop
                }
            }
        loop
        afstr+"¥n"
    loop
    objprm stat_afstr,afstr
    sendmsg hwnd_afstr, $B1, , -1    ;EM_SETSEL (文字列の全選択)
    sendmsg hwnd_afstr, $0301        ;WM_COPY (クリップボードに転送)
    return

コマンドプロンプト上で実行させるバッチファイルを作成し、動かすプログラムです

dircur=dir_cur
resfile=dircur+"¥¥result.txt"    ;出力先ファイル
batfile=dircur+"¥¥command.bat"    ;実行バッチファイル
hs=""
notesel hs
hs="cd "+dircur+"¥n"
;標準出力と標準エラー出力を両方ともファイルへ出力する
;コマンド > ファイル名 2>&1
hs+="ipconfig /all > "+resfile+" 2>&1"
notesave batfile
;バッチファイルが作成されたかチェック
mes"作成中・・・"
repeat
    exist batfile
    if strsize>=0{
        break
    }
    wait 1
loop
exec "cmd /c "+batfile    ;Windowsのファイルを実行
mes"バッチファイル¥n "+batfile
mes"保存先¥n "+resfile

コントロール（サンプルではリッチエディットコントロール）のサイズをウィンドウの大きさに合わせるプログラムです

ウィンドウのサイズが変わる度にWM_COMMANDメッセージを通知し、MoveWindow関数を利用してサイズを変更しています

#uselib "kernel32"
#cfunc LoadLibrary "LoadLibraryA" str
#func FreeLibrary "FreeLibrary" int
#uselib "user32"
#func GetWindowLong "GetWindowLongA" int,int
#func SetWindowLong "SetWindowLongA" int, int, int
#func MoveWindow "MoveWindow" int, int, int, int, int, int
;ウィンドウ
screen 0, ginfo(20), ginfo(21), 0, , , 640, 480
;最大化、サイズ変更に対応
GetWindowLong hwnd, -16
SetWindowLong hwnd, -16, stat | $10000 | $40000
;リッチエディットコントロール
hModRichEd32 = LoadLibrary("Riched20.dll") ;DLL読み込み&初期化
pos 0,0:winobj "RichEdit20A", "", 0, 0x50b000c4 , 0, 0, 1, 10000
stat_re=stat:hwnd_re = objinfo_hwnd(stat_re)
;WM_COMMANDメッセージ
oncmd gosub *command, $111
;終了処理
onexit gosub *exit
stop
*command
    MoveWindow hwnd_re, 0,0,ginfo(12),ginfo(13), 1
    return
*exit
    FreeLibrary hModRichEd32 ;DLLの開放
    end

繰り返し自乗法を用いて余りを求めるプログラムです

再帰関数を用いて実装されています

#module
#defcfunc repeatsquaring double n, double p, double m
    if p=0:return 1
    if p¥2=0{
        t=repeatsquaring(n, p/2, m)
        return t*t¥m
    }
    return n*repeatsquaring(n, p-1, m)
#global
n=13    ;乗数
p=300    ;指数
m=33    ;除数
mes""+n+" の "+p+" 乗≡ "+strf("%d",repeatsquaring(n,p,m))+" (mod "+m+" )"
;確認用
ans=1
repeat p
    ans*n
    ans¥m
loop
mes""+n+" の "+p+" 乗≡ "+ans+" (mod "+m+" )"

aのn乗を素数で割った余りを求めるプログラムです

以下の記事の「周期性を使う方法」を参考にさせていただきました

「3の100乗を19で割ったあまりは？」を４通りの方法で計算する

a=3        ;乗数
n=100    ;指数
p=19    ;除数
t=1        ;剰余
dim mlst,p
repeat p-1    ;周期性リスト
    if cnt>=n:break
    t*a
    if t>p{
        t¥p
    }
    mlst(cnt)=t
    mes""+a+" の "+(cnt+1)+" 乗≡ "+t+" (mod "+p+" )"
loop
mes"・¥n・¥n・¥n"
pos 300,0
if p>n{
    tt=n-1
}else{
    tt=n¥(p-1)-1
}
mes""+a+" の "+n+" 乗≡ "+mlst(tt)+" (mod "+p+" )"

SLG（シューティングゲーム）のような弾幕を再現したプログラムです

クリックすることで弾幕のパターンが切り替わります

#include "hgimg3.as"
hgsetreq SYSREQ_MAXOBJ,10000    ;オブジェクト最大数変更
hgini

#const patnum 1
#const csz 16

oncmd gosub *wm_lbuttondown, $0201
oncmd gosub *wm_lbuttonup, $0202

buffer 2,csz,csz*patnum
;アニメーション画像作成
boxf
x=0:y=0:deg=0
color 255,255,255:circle 0,0,csz-1,csz-1
setuv 0,0,csz-1,csz-1    ;登録テクスチャUV座標を指定
addspr sp0,1    ;2Dスプライトモデルを作成
settex csz,csz,0,-1    ;テクスチャを登録
;イベント作成
newevent evid    ;イベントリストを作成
event_prmon evid,PRMSET_MODE,OBJ_MOVE|OBJ_XFRONT    ;パラメータービット設定イベントを追加
event_wait evid,1    ;ウェイト
event_jump  evid,0    ;イベントの最初に戻る
;処理開始
screen 0
dim objiddt,1000:objfcsid=0
repeat length(objiddt)
    regobj objiddt(cnt),sp0    ;オブジェクトの登録
    setpos objiddt(cnt),-400,0
loop
spd=4
*main
    hgdraw:hgsync 17
    title"パターン："+(flg+1)
    if wparam>0{
        gosub *mouseclick
    }
    goto *main
*wm_lbuttondown    ;マウスボタンを押す
    time=0
    return
*wm_lbuttonup    ;マウスボタンを離す
    flg++
    if flg>2:flg=0
    return
*mouseclick
    if flg=0{
        if time{
            time--
        }else{
            repeat 18
                rad=deg2rad(cnt*20)
                setevent objiddt(objfcsid),evid,0
                setpos objiddt(objfcsid),0,0
                setdir objiddt(objfcsid),cos(rad)*spd,sin(rad)*spd,0
                objfcsid++
                if objfcsid>=length(objiddt):objfcsid=0
            loop
            time=20
        }
    }else:if flg=1{
        if time{
            time--
        }else{
            rad=deg2rad(c1*10)
            setevent objiddt(objfcsid),evid,0
            setpos objiddt(objfcsid),0,0
            setdir objiddt(objfcsid),cos(rad)*spd,sin(rad)*spd,0
            objfcsid++
            if objfcsid>=length(objiddt):objfcsid=0
            rad=deg2rad(c1*10+180)
            setevent objiddt(objfcsid),evid,0
            setpos objiddt(objfcsid),0,0
            setdir objiddt(objfcsid),cos(rad)*spd,sin(rad)*spd,0
            objfcsid++
            if objfcsid>=length(objiddt):objfcsid=0
            c1++
        }
    }else:if flg=2{
        if time{
            time--
        }else{
            repeat 18
                rad=deg2rad(cnt*20+c1)
                setevent objiddt(objfcsid),evid,0
                setpos objiddt(objfcsid),0,0
                setdir objiddt(objfcsid),cos(rad)*spd,sin(rad)*spd,0
                objfcsid++
                if objfcsid>=length(objiddt):objfcsid=0
            loop
            time=6:c1+10
        }
    }
    return

リッチエディットコントロール（リッチエディタ、リッチテキストエディタなど）を作成、表示するプログラムです

#include "kernel32.as"
#const style    0x50b000c4 
/*
ES_MULTILINE    0x00000004
ES_AUTOVSCROLL    0x00000040
ES_AUTOHSCROLL    0x00000080
WS_HSCROLL        0x00100000
WS_VSCROLL        0x00200000
WS_BORDER        0x00800000
WS_VISIBLE        0x10000000
WS_CHILD        0x40000000
*/
onexit *exit
Loadlibrary "RICHED20.DLL"    ;DLLを読み込む
plib=stat
pos 0,0
winobj "RichEdit20A","",0,style,ginfo_winx,ginfo_winy
stop
*exit
    FreeLibrary plib    ;読み込んだDLLを介抱
    end

VRAMの値を書き換えて矩形を描写するプログラムです

領域の幅が4の倍数でない場合や範囲外を指定した場合でも、正常に表示されます

#module
#deffunc areacheck var p,var l,var te,int ge
    if l<0{
        p=p+l
        l=l*(-1)
    }
    te=l+p
    if te<0{
        te=0
    }else:if te>ge{
        te=ge
    }
    if p<0{
        p=0
    }
    return
#global
#module
#deffunc vramset array vram,int tx,int ty,int tw,int th,int tc,int tgw,int tgh
    x=tx:y=ty:w=tw:h=th:c=tc:gw=tgw:gh=tgh
    r=c&0xff
    g=(c>>8)&0xff
    b=(c>>16)&0xff
    areacheck x,w,tew,gw
    areacheck y,h,teh,gh
    if (gw*3)¥4!=0{
        fx=1
        ix=1-((gw*3)¥4)
    }else{
        fx=0:ix=0
    }
    ;横一行分のデータ作成
    sdim wdata,(tew-x)*3
    repeat tew-x
        index=cnt*3
        poke wdata,index,r
        poke wdata,index+1,g
        poke wdata,index+2,b
    loop
    ;四角形描写
    j=y
    w=(tew-x)*3
    repeat
        if j>=teh:break
        tj=(gh-j-1)
        sfx=fx*tj
        six=ix*tj
        i=x+sfx
        index=(tj*gw+i)*3+six
        memcpy vram,wdata,w,index,0
        j++
    loop
    return
#global
boxf
mref vram,66
vramset vram,50,50,100,100,$ffffff,ginfo(12),ginfo(13)
redraw

「大津の手法」と呼ばれる二値化の画像フィルタ処理です

以下のサイトに詳しい情報が載っています

http://imagingsolution.blog.fc2.com/blog-entry-113.html

HSPにはOpenCVを利用した拡張プラグインがデフォルトで入っているので

それを用いて処理を行っています

#const gmw 640
#const gmh 480
#include "hspcv.as"
randomize
screen 2:title"入力画像"
repeat 10
    repeat 4:col(cnt)=0:loop
    repeat 2:col(rnd(4))=0xffffff:loop
    repeat 4
        x(cnt)=rnd(gmw),rnd(gmw),rnd(gmw),rnd(gmw)
        y(cnt)=rnd(gmh),rnd(gmh),rnd(gmh),rnd(gmh)
    loop
    gsquare -257,x,y,col
loop
gsel 0:title"出力画像"
wait 100
;2値化処理
cvbuffer 0,gmw,gmh
gsel 2
cvputimg 0
cvthreshold CV_THRESH_OTSU,,255,0    ;判別分析法
gsel 0,1
cvgetimg 0

HSPの拡張プラグイン「hgimg3」を用いて作成した、ただ歩き回るだけのオブジェクトです

マウスの左ボタンを押すことでオブジェクトの数を増やすことができます

#include "hgimg3.as"
hgini

#const patnum 16
#const csz 32

oncmd gosub *wm_lbuttondown, $201    ;マウスの左クリックされた時

buffer 2,csz,csz*patnum
;アニメーション画像作成
boxf
x=0:y=0:deg=0
repeat patnum
    color 255,,255:circle x+1,y+9,x+csz-1,y+csz-9
    color ,,255:circle x+7,y+7,x+csz-7,y+csz-7
    rad=deg2rad(deg)
    color 255
    circle 0,y+csz/2-sin(rad)*16,4,y+csz/2+sin(rad)*4
    circle csz-5,y+csz/2+sin(rad)*16,csz,y+csz/2-sin(rad)*4
    y+csz:deg+(360/16)
loop
setuv 0,0,csz-1,csz-1    ;登録テクスチャUV座標を指定
addspr sp0,1    ;2Dスプライトモデルを作成
settex csz,csz,0,-1    ;テクスチャを登録
;イベント作成
newevent evid    ;イベントリストを作成
repeat patnum
    event_uv evid,0,cnt*csz    ;UV設定イベントを追加
    event_prmon evid,PRMSET_MODE,OBJ_MOVE|OBJ_XFRONT    ;パラメータービット設定イベントを追加
    event_wait evid,1    ;ウェイト
loop
event_jump  evid,0    ;イベントの最初に戻る
;処理開始
screen 0
dim objiddt,1000:objfcsid=0
gosub *wm_lbuttondown
*main
    hgdraw:hgsync 17
    repeat objfcsid
        getposi objiddt(cnt),x,y,z
        if x<=-128&y<=-128{
            setpos objiddt(cnt),-128,-128        ;再配置
            setdir objiddt(cnt),(0.01*rnd(20)+0.9),0,0    ;移動量設定
            setang objiddt(cnt),0,0,deg2rad(90)    ;画像回転
        }else:if x>=128&y<=-128{
            setpos objiddt(cnt),128,-128
            setdir objiddt(cnt),0,(0.01*rnd(20)+0.9),0
            setang objiddt(cnt),0,0,deg2rad(180)
        }else:if x>=128&y>=128{
            setpos objiddt(cnt),128,128
            setdir objiddt(cnt),-(0.01*rnd(20)+0.9),0,0
            setang objiddt(cnt),0,0,deg2rad(270)
        }else:if x<=-128&y>=128{
            setpos objiddt(cnt),-128,128
            setdir objiddt(cnt),0,-(0.01*rnd(20)+0.9),0
            setang objiddt(cnt),0,0,deg2rad(0)
        }
    loop
    goto *main
*wm_lbuttondown    ;マウスを左クリックでオブジェクト生成
    if objfcsid<length(objiddt){
        regobj objiddt(objfcsid),sp0    ;オブジェクトの登録
        setevent objiddt(objfcsid),evid ;イベントセット
        setpos objiddt(objfcsid),-csz*4,csz*4
        setdir objiddt(objfcsid),0,-(0.01*rnd(20)+0.9),0
        objfcsid++
    }
    return

テキストボックスに数式を入力し、その数式を計算して解答を求めるプログラムです

実数の計算も行えます

2019/3/2 バグを見つけたので修正しました

calctext="(2+3*4+(10-5))"
pos 20,20:input calctext,240,24
pos 300,20:button goto "=",*calc
pos 370,20:input answertext,70,24:objid=stat
pos 20,50
mes"※使用可能な文字は「.0123456789+-*/()」です"
mes"※半角文字で入力してください"
mes"※「＝」を押すと結果が表示されます"
stop
*calc
    sdim fmldt,,100
    dim symdt,100
    id=0:dtid=0
    errflg=0
    blocknum=0
    repeat
        val=peek(calctext,id)
        numstr=strmid(calctext,id,1)
        if val=46|(48<=val&val<=57){    ;.0〜9
            repeat
                tval=peek(calctext,id)
                tnumstr=strmid(calctext,id,1)
                if tval=46|(48<=tval&tval<=57){
                    fmldt(dtid)+=tnumstr
                    id++
                }else{
                    id--
                    break
                }
                await
            loop
            if dtid>=2{
                repeat
                    if dtid-1<0:break
                    if symdt(dtid-1)=1{
                        gosub *calcprogram
                        if errflg:break
                    }else{
                        break
                    }
                loop
            }
        }else:if val=41{    ;)
            if blocknum>=1{
                dtid--
                if symdt(dtid-1)=2{
                    fmldt(dtid-1)=fmldt(dtid)
                    fmldt(dtid)=""
                    symdt(dtid-1)=0
                    dtid--
                }else{
                    repeat
                        gosub *calcprogram
                        if errflg:break
                        if symdt(dtid-1)=2{
                            fmldt(dtid-1)=fmldt(dtid)
                            fmldt(dtid)=""
                            symdt(dtid-1)=0
                            dtid--
                            break
                        }
                        await
                    loop
                }
                if dtid>=2{
                    repeat
                        if dtid-1<0:break
                        if symdt(dtid-1)=1{
                            gosub *calcprogram
                            if errflg:break
                        }else{
                            break
                        }
                    loop
                }
            }else{
                errflg=1
            }
            blocknum--
        }else:if val=40{    ;(
            fmldt(dtid)=numstr
            symdt(dtid)=2
            blocknum++
        }else:if val=42|val=47{    ;*/^
            fmldt(dtid)=numstr
            symdt(dtid)=1
        }else:if val=43|val=45{    ;-+
            fmldt(dtid)=numstr
        }else{    ;式の終わり
            dtid--
            repeat
                gosub *calcprogram
                if errflg:break
                if dtid<=0:break
                await
            loop
            break
        }
        id++:dtid++
        if errflg:break
        await
    loop
    answertext=double(fmldt(0))    ;答え
    objprm objid,answertext
    if errflg{
        dialog"式が正しくありません"
    }
    stop
*calcprogram    ;計算処理
    if dtid=0{
        return
    }else:if dtid=1{
        errflg=1
        return
    }
    num1=double(fmldt(dtid))
    ope=fmldt(dtid-1)
    num2=double(fmldt(dtid-2))
    if ope="+"{
        set=num2+num1
    }else:if ope="-"{
        set=num2-num1
    }else:if ope="*"{
        set=num2*num1
    }else:if ope="/"{
        set=num2/num1
    }else{
        errflg=1
    }
    fmldt(dtid)=""
    fmldt(dtid-1)=""
    fmldt(dtid-2)=str(set)
    symdt(dtid)=0
    symdt(dtid-1)=0
    symdt(dtid-2)=0
    dtid-2
    return

ダイクストラアルゴリズムのソースコードです

任意の地点と始点の最短経路を求めます

#module
#deffunc dijkstra array rootflg,array invcost,int sourid
    sum=length(invcost)
    ddim rootcost,sum
    sid=0:eid=0
    dim confflg,sum
    dim stack,sum*sum
    repeat sum*sum
        stack(cnt)=-1
    loop
    stack(sid)=sourid
    repeat
        num=sid
        cost=990999.0
        repeat eid-sid,sid
            if cost>rootcost(stack(cnt)){
                cost=rootcost(stack(cnt))
                num=cnt
            }
        loop
        if num!=sid{
            tmp=stack(num)
            stack(num)=stack(sid)
            stack(sid)=tmp
        }
        chkid=stack(sid)
        confflg(chkid)=1
        dis=rootcost(chkid)
        repeat sum
            icost=invcost(cnt,chkid)
            if confflg(cnt)=0&icost>0{
                if (rootcost(cnt)<=0|rootcost(cnt)>dis+icost){
                    rootcost(cnt)=dis+icost
                    rootflg(cnt)=chkid
                    eid++
                    stack(eid)=cnt
                }
            }
        loop
        sid++
        if sid>eid{break}
    loop
    return
#global
;画像作成
csz=32
buffer 2,csz*2,csz:celdiv 2,csz,csz,csz/2,csz/2:x=0
color:boxf
color 255:circle x,0,x+csz-1,csz-1:x+csz
color 255,255:circle x,0,x+csz-1,csz-1:x+csz
;処理開始
randomize
gsel 0:gmode 2
sum=10
ddim unitinvcost,sum,sum    ;オブジェクト間の距離（最大：200）
dim unitrootflg,sum            ;接続情報
;オブジェクト配置
repeat sum:i=cnt
    unitrootflg(i)=-1
loop
dim unitdt,4,sum
repeat sum
    if cnt=0{
        unitdt(0,cnt)=1,ginfo_winx/2,ginfo_winy/2,0
    }else{
        unitdt(0,cnt)=1,rnd(ginfo_winx),rnd(ginfo_winy),1
    }
loop
;経路情報
repeat sum:ct0=cnt
    repeat sum:ct1=cnt
        if unitdt(0,ct1)&ct0!=ct1{
            cost=sqrt(powf(unitdt(1,ct0)-unitdt(1,ct1),2)+powf(unitdt(2,ct0)-unitdt(2,ct1),2))
            if cost<200{
                unitinvcost(ct0,ct1)=cost
                unitinvcost(ct1,ct0)=cost
            }
        }
    loop
loop
;ダイクストラ経路探索
dijkstra unitrootflg,unitinvcost,0
;表示
buf=""
repeat sum:i=cnt
    buf+", ["+cnt+"]="+unitrootflg(i)
loop
title""+buf
color:boxf
gosub *drawunitline
gosub *drawunitobj
redraw
stop
*drawunitobj
    color
    repeat sum
        if unitdt(0,cnt){
            pos unitdt(1,cnt),unitdt(2,cnt):celput 2,unitdt(3,cnt)
            pos unitdt(1,cnt)-5,unitdt(2,cnt)-10:mes""+cnt
        }
    loop
    return
*drawunitline
    color 255,255,255
    repeat sum:ct0=cnt
        repeat sum:ct1=cnt
            if unitinvcost(ct0,ct1)>0{
                line unitdt(1,ct0),unitdt(2,ct0),unitdt(1,ct1),unitdt(2,ct1)
            }
        loop
    loop
    return
 

ヘクス（ヘックス）マップという六角形のマスで埋め尽くしたボードを表示するプログラムです

;Win32 APIを用いて六角形を作成
#define global NULL_BRUSH    $00000005
#define global DC_BRUSH        $00000012
#define global DC_PEN        $00000013
#uselib "gdi32"
# func global _Polygon          "Polygon" sptr,sptr,sptr
# func global SetDCPenColor     "SetDCPenColor" sptr,sptr
# func global SetDCBrushColor   "SetDCBrushColor" sptr,sptr
#cfunc global SelectObject      "SelectObject" sptr,sptr
# func global CreateSolidBrush  "CreateSolidBrush" sptr
# func global DeleteObject      "DeleteObject" sptr
#cfunc global GetStockObject    "GetStockObject" sptr
#uselib "user32"
# func global InvalidateRect    "InvalidateRect" sptr,sptr,sptr
#module
#deffunc SetDraw int flg,int col,int col2
    SetDCPenColor hdc,col
    SetDCBrushColor hdc,col2
    hPen=SelectObject(hDC,GetStockObject(DC_PEN))
    if flg=0{
        hBrush=SelectObject(hDC,GetStockObject(NULL_BRUSH))
    }else{
        hBrush=SelectObject(hDC,GetStockObject(DC_BRUSH))
    }
    return
#deffunc Polygon array nleft,int ntop,int col,int col2,int flg
    SetDraw flg,col,col2
    _Polygon hdc,varptr(nleft),ntop
    dim rect,2
    rp.0=varptr(nleft),ntop
    InvalidateRect hwnd,varptr(rp),0
    return
#global

;マス作成
csz=32
cszh=csz/2
buffer 2,csz*2,csz:celdiv 2,csz,csz
boxf
dim a,12
x=cszh
deg=0
repeat 6:i=cnt
    rad=deg2rad(deg)
    a(i*2)=0+cos(rad)*cszh+x,0+sin(rad)*cszh+cszh
    deg+60
loop
Polygon a,6,$000001,$00ff00,1
x+csz
deg=0
repeat 6:i=cnt
    rad=deg2rad(deg)
    a(i*2)=0+cos(rad)*cszh+x,0+sin(rad)*cszh+cszh
    deg+60
loop
Polygon a,6,$000001,$0000ff,1
;描写
screen:gmode 2
mcsz=24
mc=10:mr=10
dim map,mc,mr
map(4,4)=1
repeat mr:j=cnt
    repeat mc:i=cnt
        x=i*mcsz:y=j*mcsz
        if i¥2=1{
            y+=mcsz/2
        }
        pos x,y
        if map(i,j)=0{
            celput 2,0
        }else{
            celput 2,1
        }
    loop
loop