EXEにすると内部エラーの報告がおおざっぱになってしまうのを補助するスクリプト。
OnErrorFlagというフラグを利用、本体側ではonerrorを使用しないこと。
userdef.as内に埋め込んでもいいかも。
der.as// 内部エラー報告 詳細化 (DetailErrorReport)
// OnErrorFlagというフラグをグローバル空間にて使用しています。
#ifndef __DetailErrorReport__
#define __DetailErrorReport__
onerror goto *OnErrorFlag
goto *@f
#module
#deffunc derSetTitle str p1
sTitle = p1
return
#deffunc derSetURL str p1
sURL = p1
return
#deffunc derSetMail str p1
sAddress = p1
return
#deffunc derReport int p1, int p2, local sMessage
sMessage = {"プログラムの実行中にエラーを発見しました。プログラムは強制終了致します。
申し訳ありません。
プログラムの改善のため、以下のエラー情報を発行元にご報告ください。
*エラー情報
\tKind : "}
switch p1
case 1
sMessage += "システムエラーが発生しました"
swbreak
case 2
sMessage += "文法が間違っています"
swbreak
case 3
sMessage += "パラメータの値が異常です"
swbreak
case 4
sMessage += "計算式でエラーが発生しました"
swbreak
case 5
sMessage += "パラメータの省略はできません"
swbreak
case 6
sMessage += "パラメータの型が違います"
swbreak
case 7
sMessage += "配列の要素が無効です"
swbreak
case 8
sMessage += "有効なラベルが指定されていません"
swbreak
case 9
sMessage += "サブルーチンやループのネストが深すぎます"
swbreak
case 10
sMessage += "サブルーチン外でのreturnは無効です"
swbreak
case 11
sMessage += "repeat外でのloopは無効です"
swbreak
case 12
sMessage += "ファイルが見つからないか、無効な名前です"
swbreak
case 13
sMessage += "画像ファイルがありません"
swbreak
case 14
sMessage += "外部ファイル呼び出し中のエラーが発生しました"
swbreak
case 15
sMessage += "計算式でカッコの記述が違います"
swbreak
case 16
sMessage += "パラメータの数が多すぎます"
swbreak
case 17
sMessage += "文字列式で扱える文字数を超えました"
swbreak
case 18
sMessage += "代入できない変数名を指定しています"
swbreak
case 19
sMessage += "0で除算しました"
swbreak
case 20
sMessage += "バッファオーバーフローが発生しました"
swbreak
case 21
sMessage += "サポートされない機能を選択しました"
swbreak
case 22
sMessage += "計算式のカッコが深すぎます"
swbreak
case 23
sMessage += "変数名が指定されていません"
swbreak
case 24
sMessage += "整数以外が指定されています"
swbreak
case 25
sMessage += "配列の要素書式が間違っています"
swbreak
case 26
sMessage += "メモリの確保ができませんでした"
swbreak
case 27
sMessage += "タイプの初期化に失敗しました"
swbreak
case 28
sMessage += "関数に引数が設定されていません"
swbreak
case 29
sMessage += "スタック領域のオーバーフローが発生しました"
swbreak
case 30
sMessage += "無効な名前がパラメーターに指定されています"
swbreak
case 31
sMessage += "異なる型を持つ配列変数に代入しました"
swbreak
case 32
sMessage += "関数のパラメーター記述が不正です"
swbreak
case 33
sMessage += "オブジェクト数が多すぎます"
swbreak
case 34
sMessage += "配列・関数として使用できない型です"
swbreak
case 35
sMessage += "モジュール変数が指定されていません"
swbreak
case 36
sMessage += "モジュール変数の指定が無効です"
swbreak
case 37
sMessage += "変数型の変換に失敗しました"
swbreak
case 38
sMessage += "外部DLLの呼び出しに失敗しました"
swbreak
case 39
sMessage += "外部オブジェクトの呼び出しに失敗しました"
swbreak
case 40
sMessage += "関数の戻り値が設定されていません"
swbreak
default
sMessage += "未知のエラーです"
swend
sMessage += "(Error No. " + str(p1) + ")\n\tLine : " + str(p2)
if (sURL != "")|(sAddress != "") {
// URL またはアドレスが設定されている場合
sMessage += "\n\n*連絡先"
}
if sURL != "" {
sMessage += "\n\tURL : " + sURL
}
if sAddress != "" {
sMessage += "\n\tMail : " + sAddress
}
if sTitle = "" {
sTitle = "エラー"
} else {
sTitle = "エラー - " + sTitle
}
dialog sMessage, 1, sTitle
return
#global
*OnErrorFlag
onerror 0
derReport wparam, lparam
end
*@
derSetTitle ""
derSetURL ""
derSetMail ""
#endif
/* [sample]
derSetTitle "サンプルツール 人柱版"
derSetURL "http://www.sample.hsp/"
derSetMail "master@sample.hsp"
derReport 11, 0
end
*/
2007年5月29日火曜日
内部エラー報告詳細化スクリプト
AHTファイル（1）
いくつかかんたん入力用のAHTファイルを作成。
packopt自動記述.aht#aht class "hsp3"
#aht name "packopt自動記述"
#aht author "eller"
#aht ver "1.0"
#aht exp "#packoptの記述を補佐します。"
#define 実行ファイル名 "hsptmp" ;; str,help="※拡張子を除く"
#define 使用するランタイム "hsprt" ;; str
#define 実行ファイルのタイプ "0" ;; combox,pure,prm="0\n1\n2",opt="EXEファイル\nフルスクリーンEXE\nスクリーンセーバー"
#const 初期ウィンドウXサイズ 640 ;; int
#const 初期ウィンドウYサイズ 480 ;; int
#define 初期ウィンドウ非表示 "0" ;; combox,pure,prm="0\n1",opt="非表示にしない\n非表示にする"
#define 初期ディレクトリ維持 "0" ;; combox,pure,prm="0\n1",opt="維持しない\n維持する"
#ahtmes "\n// created by [packopt自動記述.aht]"
#ahtmes "#packopt name " + 実行ファイル名
#ahtmes "#packopt runtime " + 使用するランタイム
#ahtmes "#packopt type " + 実行ファイルのタイプ
#ahtmes "#packopt xsize " + 初期ウィンドウXサイズ
#ahtmes "#packopt ysize " + 初期ウィンドウYサイズ
#ahtmes "#packopt hide " + 初期ウィンドウ非表示
#ahtmes "#packopt orgpath " + 初期ディレクトリ維持
数学定数の定義.aht#aht class "hsp3"
#aht author "eller"
#aht exp "各種数学定数の宣言に使用します"
#aht ver "1.0"
#define 宣言する数学定数 "" ;; combox,pure,prm="3.14159265358979323846\n\
2.7182818284590452354",opt="円周率\n自然対数の底e"
#define マクロ名 "PI" ;; str,pure
#ahtmes "\n// created by [数学定数の定義.aht]"
#ahtmes "#const " + マクロ名 + " " + 宣言する数学定数
アニメーション.aht#aht class "hsp3"
#aht ver "0.1"
#aht author "eller"
#aht name "アニメーション用メインルーチン"
#aht exp "アニメーションで用いるメインルーチンを自動生成するAHTファイル"
#define メインループ用ラベル名 "MainLoop" ;; pure, name="メインループ用ラベル名"
#define 描画処理用ラベル名 "Draw" ;; pure, name="描画処理用ラベル名"
#define 演算処理用ラベル名 "Calc" ;; pure, name="演算処理用ラベル名"
#define 背景色 $ffffff ;; color, name="背景色", opt="rgb"
#const R成分 255 ;; help="赤色の輝度"
#const G成分 255 ;; help="緑色の輝度"
#const B成分 255 ;; help="青色の輝度"
#const AWAIT_TIME 16 ;; min=1, max=1000, name="フレームごとの待ち時間"
#ahtmes "\n// created by [アニメーション.aht]"
#ahtmes "*" + メインループ用ラベル名
#ahtmes "\tgosub *" + 演算処理用ラベル名
#ahtmes "\tredraw 0"
#ahtmes "\tcolor " + R成分 + ", " + G成分 + ", " + B成分
#ahtmes "\tboxf"
#ahtmes "\tgosub *" + 描画処理用ラベル名
#ahtmes "\tredraw 1"
#ahtmes "\tawait " + AWAIT_TIME
#ahtmes "\tgoto *" + メインループ用ラベル名
#ahtmes "\n*" + 演算処理用ラベル名
#ahtmes "\treturn"
#ahtmes "\n*" + 描画処理用ラベル名
#ahtmes "\treturn"
2007年5月24日木曜日
FizzBuzz問題
どうしてプログラマに・・・プログラムが書けないのか?にあるFizzBuzz問題を解くプログラム。
1から100までの数をプリントするプログラムを書け｡ただし3の倍数のときは数の代わりに｢Fizz｣と､5の倍数のときは｢Buzz｣とプリントし､3と5両方の倍数の場合には｢FizzBuzz｣とプリントすること｡
#runtime "hsp3cl"
repeat 100, 1
if (cnt \ 3) {
if (cnt \ 5) { mes cnt } else { mes "Buzz" }
} else {
if (cnt \ 5) { mes "Fizz" } else { mes "FizzBuzz" }
}
loop
stop
特に利点はないけど別解その１。
#runtime "hsp3cl"
repeat 100, 1
s = ""
if (cnt \ 3 == 0) : s = "Fizz"
if (cnt \ 5 == 0) : s += "Buzz"
if (s == "") : mes cnt : else : mes s
loop
stop
別解その２。if文を一切使わない方法。
#runtime "hsp3cl"
s = "", "Fizz", "Buzz", "FizzBuzz"
repeat 100, 1
s(0) = str(cnt)
mes s((cnt \ 3 == 0) + (cnt \ 5 == 0) * 2)
loop
stop
2007年5月22日火曜日
シェルピンスキーのギャスケット
シェルピンスキーのギャスケットを再帰を利用して描画。
そのままではつまらないので3D表示に。#include "d3m.hsp"
#module Gasket
#deffunc drawGasket double x1, double y1, double x2, double y2, double x3, double y3, int count
// X-Y平面上にシェルピンスキーのギャスケットを描く
if count {
drawGasket x1, y1, (x1 + x2)/2, (y1 + y2)/2, (x1 + x3)/2, (y1 + y3)/2, count - 1
drawGasket x2, y2, (x1 + x2)/2, (y1 + y2)/2, (x2 + x3)/2, (y2 + y3)/2, count - 1
drawGasket x3, y3, (x1 + x3)/2, (y1 + y3)/2, (x2 + x3)/2, (y2 + y3)/2, count - 1
} else {
d3initlineto
d3lineto x1, y1, 0
d3lineto x2, y2, 0
d3lineto x3, y3, 0
d3lineto x1, y1, 0
}
return
#global
redraw 0
d3setcam -30, -40, 90, 50, 43, 0
color : boxf
color 0, 128
drawGasket 0, 0, 100, 0, cos(3.14/3) * 100, sin(3.14/3) * 100, 4
redraw 1
stop
矩形の衝突判定
矩形の衝突判定。そのうち開発Wikiに公開できれば……。
【参考】
// 矩形1と矩形2が衝突しているか（重なっているか）を調べるアルゴリズム。
// 衝突時は必ず「矩形の左上の座標はもう一方の矩形の右下座標よりも左上にある」ことが
// 互いに成立することを利用。
#const global W1 100 // 矩形1の幅（width）
#const global H1 100 // 矩形1の高さ（height）
#const global W2 70
#const global H2 50
#module
// 肝心の衝突判定
#defcfunc hit int x1, int y1, int x2, int y2
return (x1 < x2 + W2)&(y1 < y2 + H2)&(x2 < x1 + W1)&(y2 < y1 + H1)
#global
x1 = 0 : y1 = 0
x2 = 200 : y2 = 100
*main
redraw 0
color 255, 255, 255 : boxf
stick key, 15 + 64
if key & 64 {
x2 += ((key >> 2) & 1) - (key & 1)
y2 += ((key >> 3) & 1) - ((key >> 1) & 1)
} else {
x1 += ((key >> 2) & 1) - (key & 1)
y1 += ((key >> 3) & 1) - ((key >> 1) & 1)
}
color 255
boxf x1, y1, x1 + W1, y1 + H1
color 0, 255
boxf x2, y2, x2 + W2, y2 + H2
if(hit(x1, y1, x2, y2)){
title "衝突"
} else {
title "..."
}
redraw 1
wait 1
goto *main
2007年5月14日月曜日
ツリービュー
ツリービューを作成する。
#include "comctl32.as"
#include "user32.as"
#define global TVM_INSERTITEM 0x1100
#module
#deffunc makeTree int _width, int _height
initCCEx = 8, 0x00000002
InitCommonControlsEx varptr(initCCEx)
style = 0x40000000 | 0x10000000 | 0x0001 | 0x0002 | 0x0200
CreateWindowEx 0, "SysTreeView32", "", style, ginfo_cx, ginfo_cy, _width, _height, hWnd, 0, 0, 0
hTree = stat
return hTree
#deffunc addTree str text, int hParent
dim tvins, 12
bufText = text
hIns = 0xFFFF0002 // TVI_LAST
tvins = hParent, hIns, 0x0001 // 親アイテムのハンドル、挿入位置のアイテムハンドル、TVIF_TEXT
tvins(6) = varptr(bufText), strlen(bufText)
sendmsg hTree, TVM_INSERTITEM, 0, varptr(tvins)
return stat
#global
boxf
makeTree 240, 480
addTree "sample1", 0
addTree "sample1の子供", stat
addTree "sample2", 0
addTree "sample2の子供", stat
addTree "sample2の孫", stat
stop
2007年5月13日日曜日
カーソルの移動範囲を制限する
ウィンドウの中にマウスカーソルを閉じ込める。
ウィンドウを移動させたりすると解除されるらしい。#uselib "user32.dll"
#func ClipCursor "ClipCursor" sptr
rect = ginfo(4), ginfo(5), ginfo(6), ginfo(7)
ClipCursor varptr(rect)
title "ウィンドウの外に出られない！"
button goto "解除", *a
stop
*a
ClipCursor 0
stop
2007年5月12日土曜日
インタプリンタ電卓もどき
文字列で四則演算を行うプログラム。
動作はするが、ロジックはあまりきれいではない。時間をおいて作り直したい。// コマンドライン電卓
#runtime "hsp3cl"
#module
// 文字列置換命令
// v1 : 置換する文字型変数
// s1 : 置換する文字列
// i1 : 開始インデックス
// i2 : 消去する文字列の数
#deffunc replace var v1, str s1, int i1, int i2, local s
sdim s, 20
if i1 : memcpy s, v1, i1, 0, 0
s += s1
memcpy s, v1, strlen(v1) - i1 - i2, i1 + strlen(s1), i1 + i2
v1 = s
return
#deffunc doCalc var s1, int i1, local target, local right, local r, local left, local l, local type, local i
target = s1
type = peek(target, i1)
result = ""
left = 0
right = 0
l = 0
r = 0
repeat i1
i = peek(target, i1 - cnt - 1) - '0'
if (0 <= i)&(i <= 9) {
repeat cnt
i *= 10
loop
left += i
l++
} else {
break
}
loop
repeat strlen(target) - i1 - 1
i = peek(target, i1 + cnt + 1) - '0'
if (0 <= i)&(i <= 9) {
r++
right = right * 10 + i
} else {
break
}
loop
if type != '-' {
if (l == 0)|(r == 0) {
error = "数式が不正です"
return 0
}
}
switch type
case '+'
result = str(left + right)
swbreak
case '-'
if r == 0 {
error = "数式が不正です"
return 0
}
if l == 0 {
result = "noExchange"
} else {
result = str(left - right)
}
swbreak
case '*'
result = str(left * right)
swbreak
case '/'
if right {
result = str(left / right)
} else {
error = "ゼロでは除算できません"
}
swbreak
default
error = "数式が不正です"
swbreak
swend
if error != "" : return 0
if result == "noExchange" : return 1
replace s1, result, i1 - l, l+1+r
return 0
// 内部で再帰的に用いる命令
// 括弧を判別して括弧内を対象に自らを呼び出す
#defcfunc subCalc str s1, local cmd, local i, local l, local s
cmd = s1
repeat
i = instr(cmd, 0, "(")
if i >= 0 {
l = instr(cmd, i+1, ")")
s = strmid(cmd, i + 1, l)
replace cmd, subCalc(s), i, l + 2 // ( と ) の分で+2
} else {
break
}
loop
// 括弧がない場合
// *, /を計算
repeat
i = instr(cmd, 0, "*")
l = instr(cmd, 0, "/")
if (i == -1)&(l == -1) : break
if (i == -1)&(0 <= l) : i = l
if 0 <= i {
if (0 <= l)&(l < i) : i = l // i にはiとlのうち小さい方が格納される
}
doCalc cmd, i // インデックスiにある演算子で演算を行う
if error != "" : break
loop
if error != "" : return error
// +, -を計算
k = 0
repeat
i = instr(cmd, k, "+")
l = instr(cmd, k, "-")
if (i == -1)&(l == -1) : break
if (i == -1) : i = l
if (0 <= l)&(0 <= i)&(l < i) : i = l
i += k
doCalc cmd, i // インデックスiにある演算子で演算を行う
if stat : k = i + 1
if error != "" : break
loop
if error != "" : return error
return cmd
// 外部から呼び出す命令 整数の数式を文字列として渡す
#deffunc calc str s1
error = ""
// 括弧の個数を調べる
lt = 0 : gt = 0
cmd = s1
repeat strlen(cmd)
tmp = peek(cmd, cnt)
if tmp == '(' : lt++
if tmp == ')' : gt++
loop
if lt != gt : error = "正しい数式ではありません"
if error != "" : return error
mes "Q:"+cmd
return subCalc(s1)
#global
calc "10*10+8/2*3"
mes " = " + refstr
2007年5月8日火曜日
点がパスの内部にあるか判定
任意の点から無限遠方に半直線を延ばした場合、
点がパスの内部なら奇数回、パスの外部なら偶数回パスと交差することを
利用。パスの時計回り・反時計回りは影響しない。
かなり古いコードなので、今ならもっと整理できるところがありそう。#module cross
#deffunc setline int p1, int p2, int p3, int p4
x1 = p1 : y1 = p2
x2 = p3 : y2 = p4
type1 = x1 != x2
if type1 {
// 傾きあり
a1 = double(y2 - y1)/(x2 - x1)
b1 = double(x2 * y1 - x1 * y2)/(x2 - x1)
}
return
#deffunc serchline int x3, int y3, int x4, int y4
result = 0
type2 = x3 != x4
if type2 {
a2 = double(y4 - y3)/(x4 - x3)
b2 = double(x4 * y3 - x3 * y4)/(x4 - x3)
}
if (type1 == 0)&(type2 == 0) {
// 共にY軸に並行
result = 0
}
if (type1 == 0)&(type2 == 1){
// OK
CrossX = int(x1)
CrossY = int(a2 * x1 + b2)
result = ((CrossY - y1)*(CrossY - y2)<=0) & ((CrossX - x3)*(CrossX - x4)<=0) & ((CrossY - y3)*(CrossY - y4)<=0)
}
if (type1 == 1)&(type2 == 0) {
CrossX = int(x3)
CrossY = int(a4 * x3 + b4)
result = ((CrossX - x1)*(CrossX - x2)<=0) & ((CrossY - y1)*(CrossY - y2)<=0) & ((CrossX - x3)*(CrossX - x4)<=0)
}
if (type1 == 1)&(type2 == 1){
if a1 == a2 {
result = 0
} else {
CrossX = -int((b1 - b2)/(a1 - a2))
CrossY = int((a1 * b2 - a2 * b1)/(a1 - a2))
result = ((CrossX - x1)*(CrossX - x2)<=0) & ((CrossY - y1)*(CrossY - y2)<=0) & ((CrossX - x3)*(CrossX - x4)<=0) & ((CrossY - y3)*(CrossY - y4)<=0)
}
}
return result
#defcfunc GetCrossX
return CrossX
#defcfunc GetCrossY
return CrossY
#global
#module path
#deffunc renew
index = 0
return
#deffunc addpoint int p1, int p2
x(index) = p1 : y(index) = p2
if index >= 2 {
// すでにあるパスと交差していないか？
setline x(index - 1), y(index - 1), x(index), y(index)
l = -1
repeat index - 2
serchline x(cnt), y(cnt), x(cnt + 1), y(cnt + 1)
if stat : l = cnt : break
loop
if l>=0 {
// 交点を新たなパスにする
x(index) = GetCrossX() // int(NewX)
y(index) = GetCrossY() // int(NewY)
// No.0～lまでを削除（l+1個点が消えることになる）
index -= l
repeat index
x(cnt) = x(cnt + l + 1)
y(cnt) = y(cnt + l + 1)
loop
return 1 // パスが完結しました！
}
}
index++
return 0
#deffunc drawpoint int p1
repeat index
circle x(cnt)-p1, y(cnt)-p1, x(cnt)+p1, y(cnt)+p1
loop
return
#define global drawedge(%1=-1, %2=0, %3=0) _drawedge %1, %2, %3
#deffunc _drawedge int p1, int p2, int p3
if index < 2 : return
pos x(0), y(0)
repeat index - 1, 1
line x(cnt), y(cnt)
loop
if p3{
if p1 >= 0 : line p1, p2
} else {
line x(0), y(0)
}
return
#defcfunc inner int p1, int p2
; 点と同じYだと異常動作
if index <= 2 : return 0
i = 0
repeat index ; 右に伸ばす
EdgeBack = cnt // ひとつ前の点
EdgeStart = (cnt + 1) \ index // この点は含む
EdgeEnd = (cnt + 2) \ index // この点は含まない
if (x(EdgeStart)<p1)&(x(EdgeEnd)<=p1) : continue
if (y(EdgeStart)<p2)&(y(EdgeEnd)<=p2) : continue
if (y(EdgeStart)>p2)&(y(EdgeEnd)>=p2) : continue
if y(EdgeStart) == y(EdgeEnd) {
if x(EdgeStart) > p1 : i++
}else{
if (x(EdgeEnd) + (x(EdgeStart) - x(EdgeEnd))*(p2 - y(EdgeEnd))/(y(EdgeStart) - y(EdgeEnd))) >= p1 {
i++
if (y(EdgeStart) == p2)&(y(EdgeStart) - y(EdgeEnd))*(y(EdgeStart) - y(EdgeBack)) > 0 : i++
}
}
loop
return i \ 2
#defcfunc lastx
if index : return x(index-1)
return 0
#defcfunc lasty
if index : return y(index-1)
return 0
#global
screen 0, 384, 288
renew
*main
wait 4
getkey MouseLeft, 1
if MouseLeft & Click {
R = sqrt((mousex-lastx())*(mousex-lastx()) + (mousey-lasty())*(mousey-lasty()))
if R > 15 : addpoint mousex, mousey
if stat == 1 : Click = 0 // パス完結
} else {
Click = 0
}
stick Key
if Key & 256 {
Click = 1
renew
addpoint mousex, mousey
}
redraw 0
color 255, 255, 255 : boxf
color 0, 64, 128 : drawedge mousex, mousey, Click
repeat ginfo_winx/48
x = cnt*48 + 24
repeat ginfo_winy/48
y = cnt*48 + 24
color 0, 0, 255
if inner(x, y) : color 255, 128, 0
circle x-3, y-3, x+3, y+3
loop
loop
redraw 1
if inner(mousex, mousey) {
title "マウスカーソルはパスの内部にあります"
} else {
title "マウスカーソルはパスの外部にあります"
}
goto *main
3Dモデルの表示
3Dモデルの表示。
CODEZINEを参考にHSP3へ移植させていただきました。
参考
3Dモデルファイル :
v 0.0 1.0 0.0
v 0.7 -1.0 0.7
v 1.0 -1.0 0.0
v 0.7 -1.0 -0.7
v 0.0 -1.0 -1.0
v -0.7 -1.0 -0.7
v -1.0 -1.0 0.0
v -0.7 -1.0 0.7
v 0.0 -1.0 1.0
v 0.0 -1.0 0.0
f 1 2 3
f 1 3 4
f 1 4 5
f 1 5 6
f 1 6 7
f 1 7 8
f 1 8 9
f 1 9 2
f 10 3 2
f 10 4 3
f 10 5 4
f 10 6 5
f 10 7 6
f 10 8 7
f 10 9 8
f 10 2 9
#include "hspda.as"
#include "gdi32.as"
#const global NUM_OF_VERTICES 6 // 頂点の数
#const global NUM_OF_FACES 8 // 面の数
#const global PI 3.14159 // 円周率
// **[↓VertexModule]*************************************************
#module VertexModule x, y, z
// 頂点の登録
#modinit double d1, double d2, double d3
x = d1 : y = d2 : z = d3
return
#modfunc _getRotX
return x*cos(theta) + z*sin(theta)
#modfunc _getRotY
return x * sin(phi) * sin(theta) + y * cos(phi) - z * sin(phi) * cos(theta)
#modfunc _getRotZ
return -x * cos(phi) * sin(theta) + y * sin(phi) + z * cos(phi) * cos(theta)
// 回転後の頂点座標を返す関数群
#defcfunc getRotX var modVar
_getRotX modVar : return refdval
#defcfunc getRotY var modVar
_getRotY modVar : return refdval
#defcfunc getRotZ var modVar
_getRotZ modVar : return refdval
// 画面上の頂点座標を返す関数群
#defcfunc getScreenX var modVar
_getRotX modVar : return int( refdval * scale + centerX)
#defcfunc getScreenY var modVar
_getRotY modVar : return int(-refdval * scale + centerY)
// 角度・倍率を設定
#define global setArgs(%1 = 0, %2 = 0) _setArgs %1, %2
#define global setScale(%1 = 0) _setScale %1
#deffunc _setArgs double d1, double d2
phi = limitf(d2, -PI/2, PI/2)
theta = d1
return
#deffunc _setScale double d1
if d1 {
scale = d1
} else {
scale = 0.8 * ginfo_winx / 2
}
return
// 角度・倍率に加算
#deffunc addArgs double d1, double d2
phi = limitf(phi + d2, -PI/2, PI/2)
theta += d1
return
#deffunc addScale double d1
scale = limitf(scale + d1, 10.0, 200)
return
// 中心座標と角度・倍率の初期化
#deffunc vInit
centerX = ginfo_winx / 2
centerY = ginfo_winy / 2
setArgs : setScale
return
#global
// **[end of VertexModule]********************************************
// **[↓FaceModule]***************************************************
#module FaceModule vertex, z, nx, ny, nz
// 面を登録
#modinit var v1, var v2, var v3
vertex = v1, v2, v3
return
// 面の重心の奥行き と 法線ベクトルを再計算
#modfunc renewData
z = getRotZ(vertex(0)) + getRotZ(vertex(1)) + getRotZ(vertex(2))
v1_v0_x = getRotX(vertex(1)) - getRotX(vertex(0))
v1_v0_y = getRotY(vertex(1)) - getRotY(vertex(0))
v1_v0_z = getRotZ(vertex(1)) - getRotZ(vertex(0))
v2_v0_x = getRotX(vertex(2)) - getRotX(vertex(0))
v2_v0_y = getRotY(vertex(2)) - getRotY(vertex(0))
v2_v0_z = getRotZ(vertex(2)) - getRotZ(vertex(0))
nx = v1_v0_y * v2_v0_z - v1_v0_z * v2_v0_y
ny = v1_v0_z * v2_v0_x - v1_v0_x * v2_v0_z
nz = v1_v0_x * v2_v0_y - v1_v0_y * v2_v0_x
len = sqrt(nx*nx + ny*ny + nz*nz)
nx /= len : ny /= len : nz /= len
return
// i5番目の辺の画面上の座標を返す
#modfunc getLine var v1, var v2, var v3, var v4, int i5
v1 = getScreenX(vertex(i5))
v2 = getScreenY(vertex(i5))
v3 = getScreenX(vertex((i5 + 1) \ 3))
v4 = getScreenY(vertex((i5 + 1) \ 3))
return
// 面を構成する頂点の画面上座標を配列に格納して返す
#modfunc getPoints array v1
repeat 3
v1(cnt * 2) = getScreenX(vertex(cnt)), getScreenY(vertex(cnt))
loop
return
// 重心のZ座標を返す関数
#modfunc _getZofFace
return z
#defcfunc getZofFace var modVar
_getZofFace modVar : return refdval
// 法線ベクトルのZ座標を返す関数
#modfunc _getNormalZofFace
return nz
#defcfunc getNormalZofFace var modVar
_getNormalZofFace modVar : return refdval
#global
// **[end of FaceModule]**********************************************
// **[↓Draw3dModule]*************************************************
#module Draw3dModule
// 初期化（各種変数の準備）
#deffunc init3d
vInit
CreatePen 0, 1, 0x000000
if stat == 0 : dialog "CreatePenが失敗しました", 1 : end
hPen = stat
SelectObject hDC, hPen
dim arr, NUM_OF_FACES
dim iPoint, NUM_OF_VERTICES
return
#deffunc drawModel array vertices, array faces, local x0, local x1, local y0, local y1
i = 0
foreach(faces)
renewData faces(cnt)
arr(i) = int(getZofFace(faces(cnt)) * 1000) // sortvalが実数を扱えないため、整数に変換
i++
loop
color
sortval@ arr, 0
foreach(arr)
sortget@ i, cnt
// 塗りつぶし＆線の描画
nz = getNormalZofFace(faces(i))
if nz < 0 : continue
getPoints faces(i), iPoint
hsvcolor 76, 128, nz * 255
CreateSolidBrush ginfo_r | (ginfo_g << 8) | (ginfo_b << 16)
if stat == 0 : dialog "CreateSolidBrushが失敗しました", 1 : end
hBrush = stat
SelectObject hDC, hBrush
Polygon hDC, varptr(iPoint), 3
DeleteObject hBrush
loop
return
#deffunc _creanUp onexit
DeleteObject hPen
return
#global
// **[end of Draw3dModule]********************************************
// **[↓メインスクリプト]*********************************************
// 各種初期化
screen 0, 300, 300
init3d // モジュールの初期化
title "3Dモデルを表示する"
dimtype vertices, 5, NUM_OF_VERTICES// 頂点（モジュール変数）を格納する配列を宣言
dimtype faces, 5, NUM_OF_FACES // 面（モジュール変数）を格納する配列を宣言
gosub *set // 点と面の登録
needToDraw = 1 // 描画フラグ：まず最初は描画する必要がある
*main
gosub *drag
gosub *draw
await 10
goto *main
*drag
stick key, 256, 1
if key & 256 {
if draging {
getkey shiftIsPushed, 16
if shiftIsPushed { // Shiftを押した状態では倍率の変更
addScale 1.0 * (ginfo(1) - logY)
} else { // 押していない時は回転
addArgs 0.01 * (ginfo(0) - logX), 0.01 * (ginfo(1) - logY)
}
} else {
needToDraw = 1
draging = 1
}
logX = ginfo(0) : logY = ginfo(1)
} else {
draging = 0
}
return
*draw
if needToDraw {
// 描画する必要があるときのみ実行
redraw 0
color 255, 255, 255 : boxf
drawModel vertices, faces
redraw 1
if draging == 0 : needToDraw = 0
}
return
*set
dialog "txt", 16, "3Dモデルデータ（wavefront objフォーマット）"
if stat == 0 : end
fileName = refstr
notesel data
noteload fileName
sdim prm, 16, 3
repeat notemax
noteget sLine, cnt
i = 2
repeat 3
getstr prm(cnt), sLine, i, ' '
i += strsize
loop
if peek(sLine, 0) == 'v' {
newmod vertices, vertexModule, double(prm(0)), double(prm(1)), double(prm(2))
continue
}
if peek(sLine, 0) == 'f' {
newmod faces, faceModule, vertices(int(prm(0))-1), vertices(int(prm(1))-1), vertices(int(prm(2))-1)
continue
}
loop
sdim data, 4
return
