再帰による折れ線描画

再帰を利用してランダムな折れ線を描くスクリプト。
コメントを外せば、磁石に吸いつく砂鉄のような模様ができます。

関連：

• シェルピンスキーのギャスケット

#module
#const RADIUS 10
#deffunc draw int sx, int sy, int ex, int ey, int count, local rx, local ry
    if count > 0 {
        theta = 3.14 * rnd(100) / 50
;       theta = atan(mousey - sy, mousex - sx) + 0.01 * (15 - rnd(30))
        rx = int(cos(theta) * RADIUS)
        ry = int(sin(theta) * RADIUS)
        draw sx, sy, (sx + ex)/2 + rx, (sy + ey)/2 + ry, count - 1
        draw (sx + ex)/2 + rx, (sy + ey)/2 + ry, ex, ey, count - 1
    } else {
        hsvcolor 191 * sx / ginfo_winx, 255, 255
        line sx, sy, ex, ey
    }
    return
#global

    randomize
*main
    redraw 0
    color : boxf
    repeat 6, 1
        draw ginfo_winx, cnt*70, 0, cnt*70, 5
        // ↑の5を1以上の整数に変えると線が変わる。重いけど10とか面白い。
    loop
    redraw 1
    wait 4
    goto *main

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

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
*/


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"

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

シェルピンスキーのギャスケット

シェルピンスキーのギャスケットを再帰を利用して描画。
そのままではつまらないので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に公開できれば……。
【参考】

• Wikipedia

// 矩形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


ツリービュー

ツリービューを作成する。

• http://yokohama.cool.ne.jp/chokuto/urawaza/treeview1.html

#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