2007年5月29日火曜日

内部エラー報告詳細化スクリプト

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 wparamlparam
    end

*@
    derSetTitle ""
    derSetURL   ""
    derSetMail  ""
#endif
/*  [sample]
    derSetTitle "サンプルツール 人柱版"
    derSetURL   "http://www.sample.hsp/"
    derSetMail  "master@sample.hsp"

    derReport 11, 0
    end
*/

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 1001
        if (cnt \ 3) {
            if (cnt \ 5) { mes cnt } else { mes "Buzz" }
        } else {
            if (cnt \ 5) { mes "Fizz" } else { mes "FizzBuzz" }
        }
    loop
    stop

特に利点はないけど別解その1。
#runtime "hsp3cl"
    repeat 1001
        s = ""
        if (cnt \ 3 == 0) : s  = "Fizz"
        if (cnt \ 5 == 0) : s += "Buzz"
        if (s == "") : mes cnt : else : mes s
    loop
    stop

別解その2。if文を一切使わない方法。#runtime "hsp3cl"
    s = """Fizz""Buzz""FizzBuzz"
    repeat 1001
        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, -409050430
    color : boxf
    color 0128
    drawGasket 001000cos(3.14/3) * 100sin(3.14/3) * 1004
    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 255255255 : 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 0255
    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 = 80x00000002
    InitCommonControlsEx varptr(initCCEx)
    style = 0x40000000 | 0x10000000 | 0x0001 | 0x0002 | 0x0200
    CreateWindowEx 0"SysTreeView32""", style, ginfo_cxginfo_cy, _width, _height, hWnd000
    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_INSERTITEM0varptr(tvins)
    return stat
#global

    boxf
    makeTree 240480
    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, 00
    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 - 11
        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 0384288
    renew

*main
    wait 4
    getkey MouseLeft, 1
    if MouseLeft & Click {
        R = sqrt((mousex-lastx())*(mousex-lastx()) + (mousey-lasty())*(mousey-lasty()))
        if R > 15 : addpoint mousexmousey
        if stat == 1 : Click = 0        // パス完結
    } else {
        Click = 0
    }

    stick Key
    if Key & 256 {
        Click = 1
        renew
        addpoint mousexmousey
    }

    redraw 0
    color 255255255 : boxf
    color 064128  : drawedge mousexmousey, Click

    repeat ginfo_winx/48
        x = cnt*48 + 24
        repeat ginfo_winy/48
            y = cnt*48 + 24
            color 00255
            if inner(x, y) : color 2551280
            circle x-3, y-3, x+3, y+3
        loop
    loop
    redraw 1

    if inner(mousexmousey) {
        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 intrefdval * 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/2PI/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/2PI/2)
    theta += d1
    return
#deffunc addScale double d1
    scale = limitf(scale + d1, 10.0200)
    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 010x000000
    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 76128, nz * 255
        CreateSolidBrush ginfo_r | (ginfo_g << 8) | (ginfo_b << 16)
        if stat == 0 : dialog "CreateSolidBrushが失敗しました"1 : end
        hBrush = stat
        SelectObject hDC, hBrush
        Polygon hDCvarptr(iPoint), 3
        DeleteObject hBrush
    loop
    return

#deffunc _creanUp onexit
    DeleteObject hPen
    return
#global

// **[end of Draw3dModule]********************************************

// **[↓メインスクリプト]*********************************************

    // 各種初期化
    screen 0300300
    init3d                              // モジュールの初期化
    title "3Dモデルを表示する"

    dimtype vertices, 5NUM_OF_VERTICES// 頂点(モジュール変数)を格納する配列を宣言
    dimtype faces,    5NUM_OF_FACES   // 面(モジュール変数)を格納する配列を宣言

    gosub *set                          // 点と面の登録
    needToDraw = 1                      // 描画フラグ:まず最初は描画する必要がある

*main
    gosub *drag
    gosub *draw
    await 10
    goto *main

*drag
    stick key, 2561
    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 255255255 : 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, 163

    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