sasagawa::log7

sasagawa::log7

著作権の問題は?

Norvig先生のお蔭でSchemeの継続の概念が私にとって明確になったものの、Pythonに移っちゃったんですかぁ。残念。こんなにすごいLispの達人なのに。

Schemeの継続の仕組みを示すのにNorvig先生のコードをもとにGaucheで書き直せば、とふと思いついた。あれこれ言葉で説明するよりは仕組み、やってることを見てもらったらすぐに理解できるもの。でも、著作権の問題があるんだろうなぁ。許諾をもらうにはどうしたらいいものか。考え方だけをいただいて最初から書いてしまえば著作権の問題はないのだろかなぁ。2011/01/10 00:59:52 PST

わかった、わかった。

Norvig先生のコードを何度も読み返してやっとこさ、わかった気になることができました。 具体的なコードがあると違うなぁ。それにしてもNorvig先生、うまいコードを書くものですね。

博士の愛した数式風に物語にするとこんな風かいなぁ。

それはある暑い夏の夜だった。 博士は証明にとりかかっていた。それには副問題として補題1と補題2とがある。 それらの補題が証明できれば統合して証明が完結する。 補題1は証明できた。 しかし、もう今日は遅い。寝なければ。 まてよ、補題2を解決するには補題2-Aと補題2-Bとして分解して解けるかもしれない。 それがダメなら素直に補題2を単独で証明しよう。今の考えをメモしておかないといけないなぁ。

翌朝、博士はメモを見て昨夜の続きにとりかかった。 昨夜のことはすっかり記憶になかったが、今日やるべき仕事はメモに残っていた。 それにしたがって証明の仕事の続きを始めればよかった。 補題2-Aと2-Bはうまい解決法が見つけられなかった。 しかし、違うシンプルな方法で補題2の証明ができた。さて、昨夜のメモをみると 2-A,2-Bに分けた補題の証明がうまくいかなければもともとの補題2の証明を補題1に統合すれば いいと書いてある。そうか、これで証明は完了だ。

昨夜のメモは補題1まで解けたので次にやることの継続で、 それはメモにより記憶のない博士に引き継がれたのだった。 博士はそのメモを書いた昨日の博士に補題2の証明結果を渡してやればよかったのだ。

2011/01/09 01:08:22 PST

継続 博士の愛した数式

CLで書かれたSchemeが末尾再帰、継続を得ていくコードの変化を読み、感嘆の声を上げています。 ひょっとしたらわかってきたのかも。

継続の部分を考えながらなぜか小説(映画化もされた)「博士の愛した数式」を思い出しました。 博士は記憶していられる時間が限られているために一晩寝て起きると寝る前に考えていたことを忘れてしまっています。事故にあう前までのことしか長期記憶に残っていないのですから。博士は多くのメモを書いて寝て起きて忘れてしまっている自分に状況を伝えます。そして今やっていたこと、眠りから覚めた後にやりたいこと、やらなければならないことを他人のような自分に伝えます。今の自分には戻ってこれないのですから。

完全に理解したのちに10年ほど前に一度読んでみたスティール博士の論文を読み直そうかと思います。2011/01/08 19:20:41 PST

call/cc こんどこそ理解できそう。

以前、Scheme処理系をSchemeで書いてcall/ccの動作の仕組みを理解しようとしていました。 Shiroさんにもアドヴァイスもらってましたっけ。結局、あれからさっぱり進展してなかったのですが、今度こそ理解できそうです。Norvig先生の「実用CommonLisp」の22章にScheme処理系の説明があり、call/ccについても具体的に記述されています。うれしいことに次章ではコンパイラの作り方まで紹介されていますよ。この本、面白いなぁ。コードを動かしながら夢中になって読んでいます。2011/01/08 05:37:03 PST

法律 Prolog

前にも読んだような気がする。大学の先生の文書。

http://orion.t.hosei.ac.jp/hideaki/internet/programing_law.htm

仮に経済法をPrologで書き表せたとしても毎年の膨大な改正に追いつけないかも。2011/01/08 01:53:48 PST

給与所得控除一部縮小

給与収入が1500万円超の場合の給与所得控除が245万円でリミット。

法人の役員、国会議員、地方議員、特定の国家公務員、地方公務員で年収2000万円超の場合にはさらに給与所得控除が縮小される。

24年から。

現行バージョンだと今のところこんな風。(計算結果については無保証)2011/01/07 20:44:06 PST

(define (年調給与額 x)
  (cond ((<= x 1618999) x)
        ((<= x 1619999) (- x (modulo (- x 1619000) 1000)))
        ((<= x 1623999) (- x (modulo (- x 1620000) 2000)))
        ((<= x 6599999) (- x (modulo (- x 1624000) 4000)))
        (else x)))

(define (給与所得 x)
  (let ((x1 (年調給与額 x)))
    (cond ((<= x1 650999) x1)
          ((<= x1 1618999) (- x1 650000))
          ((<= x1 1619999) (- (* x1 0.6) 2400))
          ((<= x1 1621999) (- (* x1 0.6) 2000))
          ((<= x1 1623999) (- (* x1 0.6) 1200))
          ((<= x1 1627999) (- (* x1 0.6) 400))
          ((<= x1 1799999) (* x1 0.6))
          ((<= x1 3599999) (- (* x1 0.7) 180000))
          ((<= x1 6599999) (- (* x1 0.8) 540000))
          ((<= x1 9999999) (- (* x1 0.9) 1200000))
          (else (- (* x1 0.95) 1700000)))))

gosh> (給与所得 5812500)
4109600.0
gosh> 

法律が国会を通れば平成24年からはこんな風になるはず。

;;平成24年からはこうなる見込み
;;デバッグしてないんで。計算結果は無保証。
(define (給与所得 x . args)
  (define (f x opt)
    (if opt
        (min 2450000 (g x))
        (min 2450000 (+ (* x 0.05) 1700000))))
  (define (g x)
    (cond ((<= x 15000000) (+ (* x 0.05) 1700000))
          ((<= x 25000000) (- 2450000 (* (- x 20000000) 0.12)))
          ((<= x 35000000) 1850000)
          ((<= x 40000000) (- 1850000 (* (- x 35000000) 0.12)))
          (else 1250000)))
  (let-keywords args ((役員等 #f))
    (let ((x1 (年調給与額 x)))
      (cond ((<= x1 650999) x1)
            ((<= x1 1618999) (- x1 650000))
            ((<= x1 1619999) (- (* x1 0.6) 2400))
            ((<= x1 1621999) (- (* x1 0.6) 2000))
            ((<= x1 1623999) (- (* x1 0.6) 1200))
            ((<= x1 1627999) (- (* x1 0.6) 400))
            ((<= x1 1799999) (* x1 0.6))
            ((<= x1 3599999) (- (* x1 0.7) 180000))
            ((<= x1 6599999) (- (* x1 0.8) 540000))
            ((<= x1 9999999) (- (* x1 0.9) 1200000))
            (else (- x (f x 役員等)))))))
  
gosh> (給与所得 30000000)
27550000.0
gosh> (給与所得 30000000 :役員等 #t)
28150000
gosh>   

所得税法年齢判定

年少扶養控除が平成23年度より廃止で、24年からいわゆるニート、ひきこもりなどの成年扶養控除が 所得要件付きでなくなる。所得税法は原則としてその年12月31日現在の現況によるとされている。民法とその特別法の年齢に関する法律というのがあるそうで1月1日が誕生日の人はその前日の12月31日に年齢がひとつ加算されることになっている。一日違いで扶養になったりならなかったり、老齢者判定も同様。 Gaucheで書いてみた。(結果は無保証です。自己責任で)

成年扶養にしろ法人雇用増の優遇税制にしろ小手先の改正にすぎないのは日経新聞でも批判されてるとおり。税制でなんとかなるものではなくて根本的な制度、法律改正をしないとダメなのに現政権ときたら(ぼやき)2011/01/07 18:21:23 PST

(use srfi-19)

;;生年月日から所得税法のの年齢を算出
;;民法及び年齢に関する法律により翌年1月1日誕生日の者は12月31日において年齢加算される。
;;g元号(m,t,s,h) y生まれた年(和暦) m誕生月、d誕生日 yy判定しようとする和暦適用年度
(define (age g y m d yy)
  (let* ((c-y (japanese->christian g y))
         (c-yy (japanese->christian 'h yy))
         (birth (make-date 0 0 0 0 d m c-y (date-zone-offset (current-date))))
         (base (make-date 0 0 0 0 1 1 (+ c-yy 1) (date-zone-offset (current-date)))))
    (cond ((and (= (date-month birth) (date-month base))
                (= (date-day birth) (date-day base)))
           (- (date-year base) (date-year birth)))
          (else
            (- (date-year base) 1 (date-year birth))))))

;;和暦->西暦変換
(define (japanese->christian g y)
  (case g
    ((m) (+ 1867 y))
    ((t) (+ 1911 y))
    ((s) (+ 1925 y))
    ((h) (+ 1988 y))
    (else (error "g: y: " g y))))

gosh> (age 'h 8 1 2 23)
15
gosh> (age 'h 8 1 1 23)
16
gosh> (age 's 16 1 1 22)
70
gosh> (age 's 16 1 2 22)
69
gosh> (age 's 21 1 2 22)
64
gosh> (age 's 21 1 1 22)
65
gosh> (age 's 20 12 31 22)
65
gosh> 

本業

税制改正大綱も昨年12月にでておおよそは頭に入れたものの、細部の理解のためにGaucheで書いてみるかな。法人税の税率引き下げと引き換えに個人の細々とした増税かぁ。相続税も上がるなぁ。 Gauche用のPrologを使ってみようかな。2011/01/07 16:03:18 PST

買っちゃいました

「実用Common Lisp」買うか、我慢するか、それが問題だと悩んでおりましたが、エイ、ヤと勢いをつけて買ってしまいました。税込9660円也。収録されているどの話題も私にとって興味深いものばかりです。特に興味深いのはPrologの章です。中島先生のPrologは構造共有のデータを採用していましたが、こちらは変数名を書きかえる方法。こちらの方が主流なようです。コンパイラの書き方まであります。これはたまらん。値段以上の価値があります。買ってよかった。

すっかりPeter Norvigさんのファンになってしまいました。濃い内容なのに簡潔な説明、エレガントなコード。こんな良い本が20年も前からあるのに気がつかなかったとは。

2011/01/06 22:29:59 PST

ゲームライブラリ

甥っ子は「Rubyをやろうかと思うんだけど」というので「いやいや、Schemeの方がいいよ、Gaucheを始めなさい。」とSchemeの本を送ってあげたもののどうして彼はRubyに着目したのだろう?前から欲しかった「実用CommonLisp」(約1万円也)を買おうか買うまいか、悩んでいると隣の書棚にはRubyの本が、そしてMiyakoなるゲームライブラリを使ってゲームを作るという本が売られている。 「これか!」こういうのがあるからRubyに人気があるんじゃないのかな。もっともLisp/Scheme界隈にはすっごい達人がいるはずでもうGaucheゲームライブラリなどというものが存在するのかも。無くてもじゃあ、作りますなんてあっさり作っちゃう達人がいるんじゃないかなぁ。私にはとても作れそうもないけれども。2011/01/05 00:05:30 PST

πあそび

息子の冬休みの宿題ワークブックには円周率や円の面積が出題されてます。円周率にまったく興味を示そうとしないので、こりゃ口で説明するよりはグラフィカルにコンピューターに説明してもらった方がずっと効果的だろう、ということでShiroさんのスピンの例題コードを改造して正n角形を 表示、円に近づくにつれてπの数値に近づいていくというもの大急ぎで作りました。さあ、これでπの不思議さ、古代ギリシャ人の偉大さがわかってくれるとうれしいのですが。2011/01/03 22:21:35 PST

ご質問です。

グラフィック画面にビットマップで文字列を表示するときに日本語の表示は可能でしょうか?

;;πあそび
;;中学生向けに円周率πの不思議さをグラフィカルに見せるもの。


(use gl)
(use gl.glut)
(use math.const)

(define *n* 4) ;;正n角形、初期値は正方形(四角)
(define disk (make <glu-quadric>)) ;;正n角形のオブジェクト
(define *spin* 0.0)
(define *speed* 5.0)
(define *enable* #f)

(define (init)
  (gl-clear-color 1.0 1.0 1.0 1.0))

(define (disp)
  (gl-clear GL_COLOR_BUFFER_BIT)
  (gl-push-matrix)
  (gl-rotate *spin* 0.0 0.0 1.0)
  (gl-color '#f32(0.0 0.0 1.0))
  (regular-polygon *n*)
  (gl-pop-matrix)
  (line)
  (gl-color '#f32(0.0 0.0 0.0))
  (bitmap-string " ---- 1 ----" -0.5 1.0)
  (bitmap-string "regular n polygon " 1 2.5)
  (bitmap-string "n = "  1 2)
  (bitmap-string (number->string *n*) 1 1.5)
  (bitmap-string "length = " 1 1)
  (bitmap-string (number->string (sin (/ pi *n*)))  1 0.5)
  (bitmap-string "sum(length) =" 1 0)
  (bitmap-string (number->string (* *n* (sin (/ pi *n*)))) 1 -0.5)
  (glut-swap-buffers))

(define (line)
  (gl-begin GL_LINES)
  (gl-vertex -0.5 1)
  (gl-vertex 0.5 1)
  (gl-end))

(define (regular-polygon n)
  (glu-disk disk 0.49 0.5 n 1))


(define (bitmap-string str x y) 
  (gl-raster-pos x y)
  (for-each (lambda (c)
              (glut-bitmap-character GLUT_BITMAP_HELVETICA_18 (char->integer c)))
            (string->list str)))

(define (idle)
  (when *enable*
    (set! *spin* (modulo (+ *spin* *speed*) 360.0))
    (glut-post-redisplay)))

(define (reshape w h)
  (gl-viewport 0 0 w h)
  (gl-matrix-mode GL_PROJECTION)
  (gl-load-identity)
  (gl-ortho -1.0 3.0 -1.0 3.0 -1.0 1.0)
  (gl-matrix-mode GL_MODELVIEW)
  (gl-load-identity))

(define (keyboard key x y)
  (cond [(= key 27) (exit 0)]
        [(= key (char->integer #\n)) (set! *n* (+ *n* 2))(disp) ]
        [(= key (char->integer #\m)) (when (> *n* 4)(set! *n* (- *n* 2)))(disp) ]
        [(= key (char->integer #\s)) (if *enable* (set! *enable* #f) (set! *enable* #t)) ] ))


(define (main args)
  (glut-init args)
  (glut-init-display-mode (logior GLUT_DOUBLE GLUT_RGB))
  (glut-init-window-size 500 500)
  (glut-init-window-position 100 100)
  (glut-create-window *program-name*)
  (init)
  (glut-display-func disp)
  (glut-reshape-func reshape)
  (glut-keyboard-func keyboard)
  (glut-idle-func idle)
  (glut-main-loop)
  0)

プレゼント

SICPをプレゼントした甥っ子に最近、復刻版の出た「Scheme手習い」も買って送ってあげることにした。卒業後は工科系の大学への編入を望んでいるらしい。とすると旧帝大系ならSchemeは必須なはず。今から馴染んでおいた方がいいだろう。Gauche+Emacsの入手先も伝えておかないと。ChezEditはどうかなぁ、本物志向の彼はそれよりはEmacsだろうかな。

私の場合はなぜScheme/Lispなのか? その答えは簡単。楽しいから。(アマチュアならではの脳天気発言)

甥っ子が大学を卒業するころにはGaucheでアプリケーション開発なんてことになっているといいなぁ。2011/01/03 16:03:42 PST

glu-disk 使い方

先日、教えていただいたglu-diskの使い方です。こんな風にしたらできました。 少しずつわかってきたような気もします。2011/01/03 04:35:55 PST

;;線で円を描く
(define (line-circle x y r)
  (gl-push-matrix)
  (gl-translate x y 0)
  (glu-disk (make <glu-quadric>) (- r 1) r 360 1)
  (gl-pop-matrix))


;;円を描き塗りつぶす。
(define (painted-circle x y r)
  (gl-push-matrix)
  (gl-translate x y 0)
  (let ((disk (make <glu-quadric>)))
    (glu-quadric-draw-style disk GLU_FILL)
    (glu-disk disk 0 r 360 1))
  (gl-pop-matrix))
 

お蔭様で

ShiroさんからのListener使用の助言のお蔭で展望が開けてきました。2次元グラフィクスでの対話的なタートルグラフィクスができそうです。また、自分自身のグラフィクスの勉強、以前勉強した線形代数との結びつけ、これも楽しい。

久しぶりに会った高専に通う甥っ子にSICPやファインマン博士の本をプレゼント、SICPやるんならGaucheがあるよ~、とアドヴァイス。甥っ子はCを学校でやってるとのこと。ゲームでの衝突判定について聞かれて、空間ベクトルa,bがa=rb (rはスカラー)のことじゃないんかぁなどと談義。タートルグラフィクスも3次元に拡張して内積、外積、空間ベクトルの遊び感覚の勉強。そんなことを実現したいと思っています。

さらに私自身の課題として人生時間の終わりまでにはリーマン幾何学を理解したいなぁ。2011/01/03 03:13:01 PST

いまくいかないなぁ

Open-GLのmain-loopから制御を奪ってreplでS式を評価してその副作用が直ちにグラフィクスに 反映したら面白いのになぁ、とあれこれとやってみるものの、どうもそこまでにはならないようです。問題はreplで制御を奪った状態ではopen-glは描画をせずにOpen-GLに制御が戻ってくるまでは 動作していないことです。(exit)でreplを抜けてOpen-GLに制御を戻してやると描画が始まります。Shiroさんが言うようにスレッドがWindowsで動作可能になるのを待つほかないのかもしれません。書いていたのは↓こんなようなものです。2011/01/01 06:20:32 PST

;;対話しながら簡単にOpen-GLを試すことを目標。
;;当面は2次元に限定。いずれは3次元にも対応したい。
;;命令はChezEdit付属の簡易グラフィクスとコンパチ。
;;起動は gosh ./gleasy ESC キーで終了。
;;REPLを呼び出すにはTABキー。REPLを終了するには(exit)
;;ver0.1まだほとんど何もできないバージョン。

(use gl)
(use gl.glut)

;;色データ 
(define red #f32(1 0 0)) 
(define green #f32(0 1 0)) 
(define blue #f32(0 0 1)) 
(define black #f32(0 0 0)) 
(define white #f32(1 1 1)) 
(define yellow #f32(1 1 0)) 
(define aqua #f32(0 1 1))
(define purple #f32(0.5 0 0.5))
(define orange #f32(1 0.5 0))
(define yellow-green #f32(0.5 1 0))
(define gray #f32(0.5 0.5 0.5))
;;大域変数
(define *sexp* '());;描画されるS式が保存される。
(define *fore-color* black) ;;描画する色、f32ベクターとして変数に記憶される。
(define *turtle-x* 0);;タートルのx座標
(define *turtle-y* 0);;y座標
(define *turtle-degree* 0) ;;タートルの向いている方向、上が0度。
(define *pen* #t) ;;#tならペンは描画可能状態、#fなら描画しない状態。


;;再描画
(define (disp)
  (gl-clear GL_COLOR_BUFFER_BIT)
  (gl-color *fore-color*)
  (eval *sexp* interaction-environment)
  (gl-flush))


;;リサイズ
(define (resize w h)
  (gl-viewport 0 0 w h)
  (gl-load-identity)
  (gl-ortho -200 200 -200 200 -1 1))

;;キー入力
(define (keyboard key x y)
  (cond ((= key (char->integer #\escape)) (exit))
        ((= key (char->integer #\tab)) (repl))))


;;タブキーが押されたらreplを実行する。
(define (repl)
  (repl-init)
  (let loop ((e (read)))
    (if (equal? e '(exit))
        'done
        (begin (set! *sexp* e)
               (print (guard (e (else "error in replGL" ))
                        (eval e interaction-environment)))
               (prompt)
               (loop (read))))))

(define (repl-init)
  (begin 
    (display "Gauche in Open-GL")(newline)
    (prompt)))


(define (prompt)
  (display "gosh-gl> ")
  (flush)) 


;;初期化
;;背景色は白。
(define (init)
  (gl-clear-color 1 1 1 1)
  (gl-clear GL_COLOR_BUFFER_BIT))

(define (main args)
  (glut-init-window-position 0 0)
  (glut-init-window-size 400 400)
  (glut-init args)
  (glut-init-display-mode GLUT_RGBA)
  (glut-create-window "gleasy")
  (glut-display-func disp)
  (glut-reshape-func resize)
  ;;(glut-mouse-func mouse)
  (glut-keyboard-func keyboard)
  (init)
  (glut-main-loop)
  0)

;;以下、描画関数群

(use math.const)

;;画面消去
(define (cls)
  (set! *sexp* '())
  (gl-clear GL_COLOR_BUFFER_BIT))

;;描画色設定
(define (pen-color c)
  (set! *fore-color* c))

;;タートルをホーム位置(0,0)へ設定
(define (home)
  (set! *turtle-x* 0)
  (set! *turtle-y* 0)
  (set! *turtle-degree* 0))

;;タートルを上向きにする。
(define (north)
  (set! *turtle-degree* 0))

;;ペンを描画可能状態に
(define (pen-down)
  (set! *pen* #t))

;;ペンを描画しない状態に
(define (pen-up)
  (set! *pen* #f))

;;タートルを移動
(define (move x y)
  (cond (*pen* (line *turtle-x* *turtle-y* x y)
               (set! *turtle-x* x)
               (set! *turtle-y* y))
        (else (set! *turtle-x* x)
              (set! *turtle-y* y))))

;;線を引く(x1,y1)-(x2,y2)
(define (line x1 y1 x2 y2)
  (gl-begin GL_LINES)
  (gl-vertex x1 y1)
  (gl-vertex x2 y2)
  (gl-end))

;;四角く塗りつぶす
(define (box-fill x1 y1 x2 y2)
  (gl-begin GL_QUADS)
  (gl-vertex x1 y1)
  (gl-vertex x2 y1)
  (gl-vertex x2 y2)
  (gl-vertex x1 y2)
  (gl-end))

;;ペンの太さ
(define (pen-width x)
  (gl-line-width x))

;;度数法から弧度法へ変換
(define (degree->radian x)
  (* x pi/180))


;;位置(x,y)に半径rの円を描く
(define (circle x y r . args)
  (let-keywords args ((f #f))
    (if f
        (painted-circle x y r)
        (line-circle x y r))))

;;線で円を描く
(define (line-circle x y r)
  (do ((s 0 (+ s 1)))
      ((>= s 360))
      (let ((x1 (+ x (* r (cos (degree->radian s)))))
            (y1 (+ y(* r (sin (degree->radian s)))))
            (x2 (+ x (* r (cos (degree->radian (+ s 1))))))
            (y2 (+ y (* r (sin (degree->radian (+ s 1)))))))
        (gl-begin GL_LINES)
        (gl-vertex x1 y1)
        (gl-vertex x2 y2)
        (gl-end))))

;;位置(x,y)に半径rの円を描く
(define (painted-circle x y r)
  (do ((s 0 (+ s 1)))
      ((>= s 360))
      (let ((x1 (+ x (* r (cos (degree->radian s)))))
            (y1 (+ y (* r (sin (degree->radian s)))))
            (x2 (+ x (* r (cos (degree->radian (+ s 1))))))
            (y2 (+ y (* r (sin (degree->radian (+ s 1)))))))
        (gl-begin GL_POLYGON)
        (gl-vertex x1 y1)
        (gl-vertex x2 y2)))
  (gl-end))


Gauche-gl 対話型簡易グラフィクス

Open-GLの場合、main-loopで制御が移ってしまい、S式を与えて対話的にグラフィクス操作はできないものと諦めてました。キー入力イベントからreplに制御を戻す方法がわかってきました。これならタートルグラフィクスのように対話をしながら描画させることができます。それならいっそのこと以前、ChezEditに組み込んだ簡易グラフィクスと同じ命令体系にしてしまおうかと思います。これを使えばCカーブなどおなじみの再帰曲線も描画できますし。というわけで当初、TinyBasicコンパチにしようかと思ってたんですが予定変更です。竹内先生すみません。といってもTinyBasicもChezEditもDelphi製なのでグラフィクス命令もほとんど同じようなものなんですが。

2010/12/31 08:22:14 PST

JIS full Basic グラフィクス

2次元の簡易グラフィクス命令を書いています。どうも高校ではJIS規格のBasicが使われているようです。座標系も普通の数学で使われているものとの連続性があったほうが良さそうに思えてきました。MS系も参考にしつつもJIS規格に極力合わせるようにして、ともかく簡単に悩まずにと思っています。y軸が一番上が0で始まるというのはどうも苦手でして。2010/12/30 05:36:49 PST

グラフィクスの簡易化

パソコン黎明期のpc-8001みたいなグラフィクス命令が使えたらとてもお手軽です。line pset circle cls といった命令です。お世話になった新潟大学の竹内先生が作成なさったTiny Basic の命令に合わせて screen cls line pset circle glocate gprint を書いているところです。これならBasic並みに簡単に二次元グラフィクスが描けるのではないかと思っています。 2010/12/29 03:30:31 PST

glu-disk 絶対座標

できたものの、さて、こんな書き方でいいのかいなぁ。円を描く位置の指定が相対的な移動しか見つけられなかったためにちょっと変則的です。いっかい原点に戻してから原点からの移動をしています。2010/12/28 18:39:44 PST

;;絶対座標変更がわからなかったので相対座標のgl-translateを流用
(define locate
  (let ((x0 0)(y0 0))
    (lambda (x y)
      (gl-translate (- x0) (- y0) 0)
      (gl-translate x y 0)
      (set! x0 x)
      (set! y0 y))))

;;glu-diskを利用して円を描く。
(define (disk r x y)
  (locate x y)
  (glu-disk (make <glu-quadric>) (- r 1) r 360 1))

質問です。glu-disk

教えていただいたglu-diskですが、C言語によるコード例では第一引数にはglu-new-quadric で生成したものをポインタで与えているようでした。gauche-glにはglu-new-quadricというものを見つけられなかったのですが、glu-diskはどのように使うものなのでしょうか? 2010/12/28 05:44:35 PST

円を描く

グラフやゲームにまるい円を描くのは必須。さて、どうやって描くのかな。自分で関数を用意するようです。 2010/12/26 03:20:23 PST

(use math.const)

;;度数法から弧度法へ変換
(define (degree->radian x)
  (* x pi/180))

;;Open-GLで円を描く。
;;位置(x,y)に半径rの円を描く
(define (circle r x y)
  (do ((s 0 (+ s 1)))
      ((>= s 360))
      (let ((x1 (+ x (* r (cos (degree->radian s)))))
            (y1 (+ y(* r (sin (degree->radian s)))))
            (x2 (+ x (* r (cos (degree->radian (+ s 1))))))
            (y2 (+ y (* r (sin (degree->radian (+ s 1)))))))
        (gl-begin GL_LINES)
        (gl-vertex x1 y1)
        (gl-vertex x2 y2)
        (gl-end))))

;;Open-GLで円を描き塗りつぶす。
;;位置(x,y)に半径rの円を描く
(define (painted-circle r x y)
  (do ((s 0 (+ s 1)))
      ((>= s 360))
      (let ((x1 (+ x (* r (cos (degree->radian s)))))
            (y1 (+ y(* r (sin (degree->radian s)))))
            (x2 (+ x (* r (cos (degree->radian (+ s 1))))))
            (y2 (+ y (* r (sin (degree->radian (+ s 1)))))))
        (gl-begin GL_POLYGON)
        (gl-vertex x1 y1)
        (gl-vertex x2 y2)))
  (gl-end))

Open-GLでGraphvizに代わるものを

以前試してみたGraphvizは高機能なものの、どうも表示されるグラフの位置がしっくりきません。グラフの本、教科書にあるように完全グラフは円形状に、そうでないもおは格子状に頂点が配置されていた方がすっきりします。それと逆に入力用にマウスでグラフの図形を描くとそれが内部表現である グラフのリスト表記に変換されると便利です。なにしろオイラーのケーニヒスベルグの橋を リストにするだけでも一苦労ですから。

表示については頂点からでている辺の数が5以下なら格子状に配置し、5超の場合には円周上に配置 し、ということを各頂点についてやっていくとグラフの本にあるようなああいう図にならないだろうかとアルゴリズムを考えています。2010/12/25 19:07:43 PST

スタートレック アイディア

昔ながらのスタートレックそのままの再現ではショボイですし、単なるシューティングや殺傷ゲームが大嫌いなので自分なりにアイディアを練ってみました。

○宇宙は重み付きの無向グラフ、蜂の巣状のネットワークで表わす。ここが舞台となる。 ○重みの多き辺を宇宙船が移動するときには時間とエネルギーが費消される。 ○クリンゴン船はダイクストラの最短経路アルゴリズムを持っている。それでエンタープライズに接近、フェイザー砲を撃ってくる。ただし射程距離は短い。 ○エンタープライズ船はアルゴリズムをもっていない。人間が経路を判定する。代わりに フェイザー砲の射程距離は長い。 ○両者のフェイザー砲はグラフの辺にそってエネルギーが移動する。重みによって到達時間が変わる。 ○クリンゴン船は姿を消しレーダーから消える能力をもつ。ただしフェイザー砲を発射するときには 自分の位置がわかってしまう。 ○エンタープライズ船は防御スクリーンをもち数回程度の攻撃ではダメージを受けない。 ○防御スクリーンを使うとエネルギーが費消される。 ○クリンゴン船にフェイザーが当たると走行不能にはなるが破壊はされない。以後ネットワーク上の障害物となる。ゲームにおいて殺傷は私は絶対反対。 ○その他宇宙基地や宇宙時間なんかの設定は昔のと同じ。

グラフ、ネットワークのお勉強をしつつゲームが楽しめるってのが目標です。2010/12/25 18:55:20 PST

ゲーム作りは楽しいかも

Open-GLの使い方がわかってきたらグラフィクスを使って昔懐かしいゲームを作ってみたくなりました。私の場合、パソコン黎明期でスタートレックゲームが動いているのは見たものの実際に移植したりBasicで自分で書いてみるということはしたことがありませんでした。ほんとはサンダーバード国際救助隊が活躍するゲームというのを作ってみたい気もするのですが、これってミッションに失敗すると救助できなかった被害者が出てしまうのでストーリー的にはバツですし。そういうわけで懐かしのスタートレックゲームを蘇らせたいなぁ、なんて思っています。2010/12/24 21:36:29 PST

テトリス改良

Shiroさんに教わったglut-timer-funcで書き換え。なるほどこの方がすっきりします。 他にもあちこち書き直してだいぶすっきりしたかな。 2010/12/24 07:50:38 PST

テトリス

今後、のんびりとバグ取りやら改良をしつつOpen-GLの勉強材料にと思っています。

コードは下記においてあります。

http://homepage1.nifty.com/~skz/Entry/tetris.html

一部の古いマシンだとダブルバッファリングが使えないようです。その場合はダブルバッファリングの部分をダブルにしないように補正してください。

2010/12/23 05:47:40 PST

反応

息子をつかまえてテトリスとライフゲームをテストしてもらった。テトリスは落下が速過ぎるのと升目がないとわかりづらいのだそうだ。私がやってもさっぱり得点できなかったのだけど息子にとっても速過ぎるらしい。ムチャクチャなキー操作をするとたまにバグで落ちる。そこもコンピューターらしくて面白いらしい。ゲームはコンピューターが一生懸命に裏方でがんばってるというのが見えたらうれしいな。ブラックボックスというのはよくないもの。

ライフゲームは予想外に面白がっている。どういうパターンだと増殖するのか、あれこれと初期値を試している。これは予想外にウケた。

というわけで手作りソフトプレゼントはコミニュケーションもはかれるし大成功。

息子たちはスポーツの部活、練習に没頭していてオタクな親に似ず健全な発達なようで何より。

Gauche-glは手軽にグラフィクスができちゃうんでこれは素晴らしい。皆様もぜひぜひ。

2010/12/22 19:11:40 PST

一応の完成

得点計算してテトリミノの予告表示をつけて、一応の完成。ああ、クリスマスに間に合った。 あとはコードの汚いところを直して、バグとりだなぁ。2010/12/22 18:02:35 PST

;;起動はコマンドラインから gosh ./tetris 
;;Ver0.3
;;スペースキーをを押すとゲームスタート。 
;;ESCキーで終了。 
;;a キーで左移動、d キーで右移動。 
;;q キーで左回転、e キーで右回転。
;;x キーで下移動 s キーで一時停止。
;;r キーでリスタート。

(use gl) 
(use gl.glut) 
(use math.matrix) ;;自作行列ライブラリ 
(use srfi-27) ;;乱数利用のため 

(define t-row 0) ;;物体の位置行 
(define t-col 0) ;;物体の位置列 
(define next-row 0) ;;次に待機している物体の位置行
(define next-col 0) ;;次に待機している物体の位置列
(define quad-size 20) ;;描画するときの四角の1辺の長さ 
(define row 21);;盤面の行数、最下行は接地判定用
(define col 12);;盤面の列数  両脇はぶつかり判定用
(define mat (make-matrix row col)) ;;表示する盤面
(define submat (make-matrix row col)) ;;着地した物体を保存する盤面がセットされる。
(define block (make-matrix 4 4)) ;;落下物体を保存する行列がセットされる。
(define subblock (make-matrix 4 4));;block行列を回転するときに一時的に使う。
(define nextblock '()) ;;次に待機しているblock
(define enable #f) ;;物体を落下させていいかどうかのスイッチ。
(define game-over #f) ;;ゲームオーバーのフラグ。
(define score 0) ;;得点
(define multiscroll 0) ;;連続スクロールした回数

;;block テトリミノと言われているらしい。
;;各数に次の色を割り当てる。
;;水色1、黄色2、黄緑3、赤4、青5、オレンジ6、紫7
(define t-i 
  (list->matrix '((0 0 0 0)
                  (0 0 0 0)
                  (1 1 1 1)
                  (0 0 0 0))))

(define t-o
  (list->matrix '((0 0 0 0)
                  (0 2 2 0)
                  (0 2 2 0)
                  (0 0 0 0))))

(define t-s
  (list->matrix '((0 0 0 0)
                  (0 3 3 0)
                  (3 3 0 0)
                  (0 0 0 0))))

(define t-z
  (list->matrix '((0 0 0 0)
                  (4 4 0 0)
                  (0 4 4 0)
                  (0 0 0 0))))

(define t-j 
  (list->matrix '((0 0 0 0)
                  (5 0 0 0)
                  (5 5 5 0)
                  (0 0 0 0))))

(define t-l
  (list->matrix '((0 0 0 0)
                  (0 0 6 0)
                  (6 6 6 0)
                  (0 0 0 0))))

(define t-t
  (list->matrix '((0 0 0 0)
                  (0 7 0 0)
                  (7 7 7 0)
                  (0 0 0 0))))

 
;;色データ 
(define red #f32(1 0 0)) 
(define green #f32(0 1 0)) 
(define blue #f32(0 0 1)) 
(define black #f32(0 0 0)) 
(define white #f32(1 1 1)) 
(define yellow #f32(1 1 0)) 
(define aqua #f32(0 1 1))
(define purple #f32(0.5 0 0.5))
(define orange #f32(1 0.5 0))
(define yellow-green #f32(0.5 1 0))
(define gray #f32(0.5 0.5 0.5))

;;判定 

;;物体が下に落ちることができるか? 
(define (move-down?) 
  (let ((n 0)) ;;ぶつかるセル数 
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            (when (and (not (zero? (matrix-ref block i j)))
                       (not (zero? (matrix-ref submat (+ t-row i) (+ t-col j -1)))))
              (inc! n))))
    (zero? n)))

;;物体を右に移動できるか?
(define (move-right?)
  (let ((n 0))
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            (when (and (not (zero? (matrix-ref block i j)))
                       (not (zero? (matrix-ref submat (+ t-row i -1) (+ t-col j)))))
              (inc! n))))
    (zero? n)))

;;物体を左に移動できるか?
(define (move-left?)
  (let ((n 0))
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            (when (and (not (zero? (matrix-ref block i j)))
                       (not (zero? (matrix-ref submat (+ t-row i -1) (+ t-col j -2)))))
              (inc! n))))
    (zero? n)))


;;右回転可能か?
;;仮に右回転したblock行列をsubblock行列にコピーし、それがぶつからないなら#t
(define (rotate-right?)
  (rotate-r-to-subblock)
  (not (strike?)))

;;右回転可能か?
(define (rotate-left?)
  (rotate-l-to-subblock)
  (not (strike?)))

                    
;;現在位置のsubblock行列はぶつかるのか?
(define (strike?)
  (let ((n 0))
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            (when (and (not (zero? (matrix-ref subblock i j)))
                       (not (zero? (matrix-ref submat (+ t-row i -1) (+ t-col j -1)))))
              (inc! n))))
    (not (zero? n))))


;;ゲームオーバー?
;;現在の位置の行が1で下に下がれない場合にゲームオーバーとなる。
(define (game-over?)
  (and (= t-row 1) (not (move-down?))))

;;移動

;;物体を下に1行落とす。 
;;物体を消去して行を1プラスしてその位置にblock行列をコピーする。 
(define (move-down) 
  (block-clear mat t-row t-col)
  (inc! t-row)
  (block-copy mat t-row t-col))

;;bolck行列をm行列の(r c)位置にコピーする。
;;ただし0はコピーしない。
(define (block-copy m r c)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (let ((val (matrix-ref block i j)))
            (when (not (zero? val))
              (matrix-set! m (+ r i -1) (+ c j -1) val))))))

;;block行列があった場所を指定して消去する。block行列の0の部分は消去しない。
(define (block-clear m r c)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (when (not (zero? (matrix-ref block i j)))
            (matrix-set! m (+ r i -1) (+ c j -1) 0)))))

;;物体を右に移動する。 
;;物体を消去して列を1プラスしてその位置にblock行列をコピーする。 
(define (move-right) 
  (block-clear mat t-row t-col)
  (inc! t-col)
  (block-copy mat t-row t-col))

;;物体を左に移動する。 
;;物体を消去して列を1マイナスしてその位置にblock行列をコピーする。 
(define (move-left) 
  (block-clear mat t-row t-col)
  (dec! t-col)
  (block-copy mat t-row t-col))


;;右回転する。
;;判定に使ったsubblock行列をmat行列にコピーする。
(define (rotate-right)
  (block-clear mat t-row t-col)
  (block-copy-from-subblock)
  (block-copy mat t-row t-col))

;;左回転する。
(define (rotate-left)
  (block-clear mat t-row t-col)
  (block-copy-from-subblock)
  (block-copy mat t-row t-col))
  

;;行列の右回転
;;[1 2]    [3 1]
;;[3 4] -> [4 2] 
;;block行列を右回転したものをsubblockにコピー
(define (rotate-r-to-subblock)
  (do ((j 1 (+ j 1)))
      ((> j 4))
      (do ((i 1 (+ i 1)))
          ((> i 4))
          (matrix-set! subblock j (+ 4 (- i) 1) (matrix-ref block i j)))))

;;行列の左回転
;;[1 2]    [2 4]
;;[3 4] -> [1 3]
;;block行列を左回転したものをsubblockにコピー
(define (rotate-l-to-subblock)
  (do ((j 1 (+ j 1)))
      ((> j 4))
      (do ((i 1 (+ i 1)))
          ((> i 4))
          (matrix-set! subblock (+ 4 (- j) 1) i (matrix-ref block i j)))))

;;subblock行列からblock行列に要素をコピー
(define (block-copy-from-subblock)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (matrix-set! block i j (matrix-ref subblock i j)))))

;;matの指定行がすべて0以外か
;;連続してスクロール可能だった場合にはmultiscrollにその回数を記録する。得点計算用。
(define (scroll? r)
  (let ((n 0)) ;;要素が0の個数
    (do ((j 2 (+ j 1)))
        ((> j (- col 1)))
        (when (zero? (matrix-ref mat r j))
          (inc! n)))
    (cond ((zero? n) (inc! multiscroll) #t)
          (else #f))))

;;スクロール可能な行をみつけてスクロールするとともに得点計算をする。
(define (scroll)
  (define (iter n)
    (do ((i (- n 1) (- i 1)))
        ((< i 1))
        (do ((j 2 (+ j 1)))
            ((> j (- col 1)))
            (matrix-set! mat (+ i 1) j (matrix-ref mat i j))
            (matrix-set! submat (+ i 1) j (matrix-ref submat i j))))
    (do ((j 2 (+ j 1)))
        ((> j (- col 1)))
        (matrix-set! mat 1 j 0)
        (matrix-set! submat 1 j 0))
    (inc! t-row))
  
  ;;スクロール
  (do ((i (- row 1) (- i 1)))
      ((< i 1))
      (when (scroll? i) (iter i)))
  
  
  ;;得点計算
  (set! score (+ score (cond ((= multiscroll 1) 100)
                             ((= multiscroll 2) 300)
                             ((= multiscroll 3) 800)
                             ((= multiscroll 4) 1500)
                             (else 0))))
  (set! multiscroll 0) )



;;描画 
;;下に落ちることができるのなら下へ移動。
;;そうでなければぶつかり判定用submatに記録し新たな物体を出現させる。
;;最下行が0以外の数で埋まっていれば 1行下へスクロールする。
(define (disp)
  (disp-string)
  (disp-mat mat)
  (disp-block)
  (when enable
    (cond ((move-down?) (move-down))
          (else
            (cond ((game-over?) 
                   (set! game-over #t)
                   (set! enable #f)
                   (disp) ;;再描画して停止。
                   (glut-idle-func #f))
                  (else
                    (block-copy submat t-row t-col);;接地したものはsubmatに記録。
                    (scroll);;スクロール。
                    (go)
                    (new)))))
    (sys-nanosleep 200000000)))

;;急速描画 
;;スリープなしで急速に下降する。
;;うまく効いていない。
(define (disp-quick) 
  (disp-string)
  (disp-mat mat)
  (when enable
    (cond ((move-down?) (move-down))
          (else
            (block-copy submat t-row t-col)
            (when (scroll?) (scroll))
            (new)))))

;;盤面の行列を描画する。 
(define (disp-mat mat) 
  (clear-mat row col 0 0)
  (do ((i 1 (+ i 1))) 
      ((> i row)) 
      (do ((j 1 (+ j 1))) 
          ((> j col)) 
          (if (not (zero? (matrix-ref mat i j))) 
              (disp-quad i j (matrix-ref mat i j) 0 0))))
  (glut-swap-buffers))

;;予告用のblockを描画する。
(define (disp-block)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (if (not (zero? (matrix-ref nextblock i j)))
              (disp-quad i j (matrix-ref nextblock i j) 300 50))))
  (glut-swap-buffers))
      


;;新たな物体を準備する。
;;type 1=t-i 2=t-o 3=t-s 4=t-z 5=t-j 6=t-l 7=t-t
;;予告表示ようのnextblockにコピーしておく。
(define (new) 
  (let ((type (+ (random-integer 6) 1)))
    (cond ((= type 1) (set! nextblock t-i))
          ((= type 2) (set! nextblock t-o))
          ((= type 3) (set! nextblock t-s))
          ((= type 4) (set! nextblock t-z))
          ((= type 5) (set! nextblock t-j))
          ((= type 6) (set! nextblock t-l))
          ((= type 7) (set! nextblock t-t)))))

;;物体を発進させる。
;;nextblockからblockとmatにコピーしてスタート位置を設定する。
  (define (go)
    (let ((col (+ (random-integer 7) 2)));;置ける左端の列は2-8
      (do ((i 1 (+ i 1)))
          ((> i 4))
          (do ((j 1 (+ j 1)))
              ((> j 4))
              (matrix-set! block i j (matrix-ref nextblock i j))
              (matrix-set! mat i (+ col j -1) (matrix-ref nextblock i j))))
      (set! t-row 1)
      (set! t-col col)))


;;行列のi,j成分に相当する位置(x,yを起点として)に四角を描く。
;;水色1、黄色2、黄緑3、赤4、青5、オレンジ6、紫7 、グレー9
(define (disp-quad i j color x y) 
  (gl-begin GL_QUADS)
  (cond ((= color 1) (gl-color aqua))
        ((= color 2) (gl-color yellow))
        ((= color 3) (gl-color yellow-green))
        ((= color 4) (gl-color red))
        ((= color 5) (gl-color blue))
        ((= color 6) (gl-color orange))
        ((= color 7) (gl-color purple))
        ((= color 9) (gl-color gray)))
  
  (let* ((x1 (+ (* quad-size j) x)) (y1 (+ (* quad-size i) y)) 
         (x2 (+ x1 quad-size -1)) (y2 y1) 
         (x3 x2) (y3 (+ y1 quad-size -1)) 
         (x4 x1) (y4 y3)) 
    (gl-vertex x1 y1) 
    (gl-vertex x2 y2) 
    (gl-vertex x3 y3) 
    (gl-vertex x4 y4)) 
  (gl-end)) 

;;行列表示部分(位置(x,y)、大きさ(r,c))を背景色の白で塗りつぶす
(define (clear-mat r c x y)
  (let ((x1 x)(y1 y)
        (x2 (+ (* col quad-size) x)) (y2 y)
        (x3 (+ (* col quad-size) x)) (y3 (+ (* row quad-size) y))
        (x4 x) (y4 (+ (* row quad-size) y)))
    (gl-color white)
    (gl-begin GL_QUADS)
    (gl-vertex x1 y1)
    (gl-vertex x2 y2)
    (gl-vertex x3 y3)
    (gl-vertex x4 y4)))

;;文字列表示
;;x,yの位置に文字列strを表示する。
(define (bitmap-string str x y) 
  (gl-raster-pos x y)
  (for-each (lambda (c)
              (glut-bitmap-character GLUT_BITMAP_HELVETICA_18 (char->integer c)))
            (string->list str)))

;;次のblock、得点などの表示
(define (disp-string)
  ;;いったん消去しないと前の文字列表示が残ってしまう。
  (gl-clear GL_COLOR_BUFFER_BIT)
  
  (gl-color black)
  (bitmap-string "next" 300 50)
  (when game-over
    (bitmap-string "game over" 300 200)
    (bitmap-string "restart press r key" 300 220))
  (bitmap-string "score" 300 250)
  (bitmap-string (number->string score) 300 270))



;;全部要素を0クリアした後
;;mat,submatに接地判定用と両脇ぶつかり判定用の要素を書きこむ。
;;ぶつかり判定用には9をあてる。
(define (init-mat)
  ;;0クリア
  (do ((i 1 (+ i 1)))
      ((> i row))
      (do ((j 1 (+ j 1)))
          ((> j col))
          (matrix-set! mat i j 0)
          (matrix-set! submat i j 0)))
  ;;ぶつかり判定用要素を書き込む
  (do ((i 1 (+ i 1)))
      ((> i row))
      (matrix-set! mat i 1 9)
      (matrix-set! submat i 1 9)
      (matrix-set! mat i 12 9)
      (matrix-set! submat i 12 9))
  (do ((j 1 (+ j 1)))
      ((> j col))
      (matrix-set! mat row j 9)
      (matrix-set! submat row j 9)))
      


;;アイドル状態で呼び出される。 
(define (idle) 
  (glut-post-redisplay)) 


;;リサイズ 
(define (resize w h) 
  (gl-viewport 0 0 w h) 
  (gl-load-identity) 
  (gl-ortho -0.5 (- w 0.5) (- h 0.5) -0.5 -1.0 1.0)) 

;;キー入力 
(define (keyboard key x y) 
  (cond ((= key (char->integer #\escape)) (exit)) 
        
        ((= key (char->integer #\space))
         (set! enable #t)
         (glut-idle-func idle)) 
        
        ((= key (char->integer #\s))
         (set! enable #f) 
         (glut-idle-func #f))
        
        ((= key (char->integer #\r))
         (init-mat)
         (new)
         (set! game-over #f)
         (set! enable #t)
         (set! score 0)
         (glut-idle-func idle))
         
        ((= key (char->integer #\d)) 
         (when (move-right?) 
           (move-right))) 
        ((= key (char->integer #\a)) 
         (when (move-left?) 
           (move-left)))
        ((= key (char->integer #\e)) 
         (when (rotate-right?)
           (rotate-right)))
        ((= key (char->integer #\q))
         (when (rotate-left?)
           (rotate-left)))
        ((= key (char->integer #\x))
         (disp-quick))))
         


;;初期化 
;;背景色は白,物体をセット。 
(define (init) 
  (gl-clear-color 1 1 1 1)
  (gl-clear GL_COLOR_BUFFER_BIT) 
  (init-mat) 
  (new)
  (go)
  (new))

(define (main args) 
  (glut-init args) 
  (glut-init-window-position 100 100) 
  (glut-init-window-size 500 500) 
  (glut-init-display-mode (logior GLUT_RGBA GLUT_DOUBLE)) 
  (glut-create-window "tetris") 
  (glut-display-func disp) 
  (glut-reshape-func resize) 
  (glut-keyboard-func keyboard) 
  (init) 
  (glut-main-loop) 
  0) 



得点などを表示

文字列ってOpen-GLでどうやって表示するのかいなぁ?と調べてみたらちゃんとありました。 こうすればいいらしい。2010/12/22 15:15:58 PST

;;文字列表示
;;x,yの位置に文字列strを表示する。
(define (bitmap-string str x y) 
  (gl-raster-pos x y)
  (for-each (lambda (c)
              (glut-bitmap-character GLUT_BITMAP_HELVETICA_18 (char->integer c)))
            (string->list str)))

テトリス 一応動くバージョン

一応、動くものができたものの、ゲームが苦手な私はさっぱりクリアできない。2010/12/22 08:25:10 PST

;;起動はコマンドラインから gosh ./tetris 
;;Ver0.2 
;;スペースキーをを押すとゲームスタート。 
;;ESCキーで終了。 
;;a キーで左移動、d キーで右移動。 
;;q キーで左回転、e キーで右回転 
;;x キーで下移動 s キーで一時停止。

(use gl) 
(use gl.glut) 
(use math.matrix) ;;自作行列ライブラリ 
(use srfi-27) ;;乱数利用のため 

(define t-row 0) ;;物体の位置行 
(define t-col 0) ;;物体の位置列 
(define next-row 0) ;;次に待機している物体の位置行
(define next-col 0) ;;次に待機している物体の位置列
(define quad-size 20) ;;描画するときの四角の1辺の長さ 
(define row 21);;盤面の行数、最下行は接地判定用
(define col 12);;盤面の列数  両脇はぶつかり判定用
(define mat (make-matrix row col)) ;;表示する盤面
(define submat (make-matrix row col)) ;;着地した物体を保存する盤面がセットされる。
(define block '()) ;;落下物体を保存する行列がセットされる。
(define subblock (make-matrix 4 4));;block行列を回転するときに一時的に使う。
(define enable #f) ;;物体を落下させていいかどうかのスイッチ。

;;block テトリミノと言われているらしい。
;;各数に次の色を割り当てる。
;;水色1、黄色2、黄緑3、赤4、青5、オレンジ6、紫7
(define t-i 
  (list->matrix '((0 0 0 0)
                  (0 0 0 0)
                  (1 1 1 1)
                  (0 0 0 0))))

(define t-o
  (list->matrix '((0 0 0 0)
                  (0 2 2 0)
                  (0 2 2 0)
                  (0 0 0 0))))

(define t-s
  (list->matrix '((0 0 0 0)
                  (0 3 3 0)
                  (3 3 0 0)
                  (0 0 0 0))))

(define t-z
  (list->matrix '((0 0 0 0)
                  (4 4 0 0)
                  (0 4 4 0)
                  (0 0 0 0))))

(define t-j 
  (list->matrix '((0 0 0 0)
                  (5 0 0 0)
                  (5 5 5 0)
                  (0 0 0 0))))

(define t-l
  (list->matrix '((0 0 0 0)
                  (0 0 6 0)
                  (6 6 6 0)
                  (0 0 0 0))))

(define t-t
  (list->matrix '((0 0 0 0)
                  (0 7 0 0)
                  (7 7 7 0)
                  (0 0 0 0))))

 
;;色データ 
(define red #f32(1 0 0)) 
(define green #f32(0 1 0)) 
(define blue #f32(0 0 1)) 
(define black #f32(0 0 0)) 
(define white #f32(1 1 1)) 
(define yellow #f32(1 1 0)) 
(define aqua #f32(0 1 1))
(define purple #f32(0.5 0 0.5))
(define orange #f32(1 0.5 0))
(define yellow-green #f32(0.5 1 0))
(define gray #f32(0.5 0.5 0.5))

;;判定 

;;物体が下に落ちることができるか? 
(define (move-down?) 
  (let ((n 0)) ;;ぶつかるセル数 
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            (when (and (not (zero? (matrix-ref block i j)))
                       (not (zero? (matrix-ref submat (+ t-row i) (+ t-col j -1)))))
              (inc! n))))
    (zero? n)))

;;物体を右に移動できるか?
(define (move-right?)
  (let ((n 0))
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            (when (and (not (zero? (matrix-ref block i j)))
                       (not (zero? (matrix-ref submat (+ t-row i -1) (+ t-col j)))))
              (inc! n))))
    (zero? n)))

;;物体を左に移動できるか?
(define (move-left?)
  (let ((n 0))
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            (when (and (not (zero? (matrix-ref block i j)))
                       (not (zero? (matrix-ref submat (+ t-row i -1) (+ t-col j -2)))))
              (inc! n))))
    (zero? n)))


;;右回転可能か?
;;仮に右回転したblock行列をsubblock行列にコピーし、それがぶつからないなら#t
(define (rotate-right?)
  (rotate-r-to-subblock)
  (not (strike?)))

;;右回転可能か?
(define (rotate-left?)
  (rotate-l-to-subblock)
  (not (strike?)))

                    
;;現在位置のsubblock行列はぶつかるのか?
(define (strike?)
  (let ((n 0))
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            (when (and (not (zero? (matrix-ref subblock i j)))
                       (not (zero? (matrix-ref submat (+ t-row i -1) (+ t-col j -1)))))
              (inc! n))))
    (not (zero? n))))


;;ゲームオーバー?
;;現在の位置の行が1で下に下がれない場合にゲームオーバーとなる。
(define (game-over?)
  (and (= t-row 1) (not (move-down?))))

;;移動

;;物体を下に1行落とす。 
;;物体を消去して行を1プラスしてその位置にblock行列をコピーする。 
(define (move-down) 
  (block-clear mat t-row t-col)
  (inc! t-row)
  (block-copy mat t-row t-col))

;;bolck行列をm行列の(r c)位置にコピーする。
;;ただし0はコピーしない。
(define (block-copy m r c)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (let ((val (matrix-ref block i j)))
            (when (not (zero? val))
              (matrix-set! m (+ r i -1) (+ c j -1) val))))))

;;block行列があった場所を指定して消去する。block行列の0の部分は消去しない。
(define (block-clear m r c)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (when (not (zero? (matrix-ref block i j)))
            (matrix-set! m (+ r i -1) (+ c j -1) 0)))))

;;物体を右に移動する。 
;;物体を消去して列を1プラスしてその位置にblock行列をコピーする。 
(define (move-right) 
  (block-clear mat t-row t-col)
  (inc! t-col)
  (block-copy mat t-row t-col))

;;物体を左に移動する。 
;;物体を消去して列を1マイナスしてその位置にblock行列をコピーする。 
(define (move-left) 
  (block-clear mat t-row t-col)
  (dec! t-col)
  (block-copy mat t-row t-col))


;;右回転する。
;;判定に使ったsubblock行列をmat行列にコピーする。
(define (rotate-right)
  (block-clear mat t-row t-col)
  (block-copy-from-subblock)
  (block-copy mat t-row t-col))

;;左回転する。
(define (rotate-left)
  (block-clear mat t-row t-col)
  (block-copy-from-subblock)
  (block-copy mat t-row t-col))
  

;;行列の右回転
;;[1 2]    [3 1]
;;[3 4] -> [4 2] 
;;block行列を右回転したものをsubblockにコピー
(define (rotate-r-to-subblock)
  (do ((j 1 (+ j 1)))
      ((> j 4))
      (do ((i 1 (+ i 1)))
          ((> i 4))
          (matrix-set! subblock j (+ 4 (- i) 1) (matrix-ref block i j)))))

;;行列の左回転
;;[1 2]    [2 4]
;;[3 4] -> [1 3]
;;block行列を左回転したものをsubblockにコピー
(define (rotate-l-to-subblock)
  (do ((j 1 (+ j 1)))
      ((> j 4))
      (do ((i 1 (+ i 1)))
          ((> i 4))
          (matrix-set! subblock (+ 4 (- j) 1) i (matrix-ref block i j)))))

;;subblock行列からblock行列に要素をコピー
(define (block-copy-from-subblock)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (matrix-set! block i j (matrix-ref subblock i j)))))

;;matの最下行がすべて0以外か
(define (scroll?)
  (let ((n 0)) ;;要素が0の個数
    (do ((j 2 (+ j 1)))
        ((> j (- col 1)))
        (when (zero? (matrix-ref mat (- row 1) j))
          (inc! n)))
    (zero? n)))

;;matとsubmatを1行下にスクロールする。
(define (scroll)
  (do ((i (- row 2) (- i 1)))
      ((< i 1))
      (do ((j 2 (+ j 1)))
          ((> j (- col 1)))
          (matrix-set! mat (+ i 1) j (matrix-ref mat i j))
          (matrix-set! submat (+ i 1) j (matrix-ref submat i j))))
  (do ((j 2 (+ j 1)))
      ((> j (- col 1)))
      (matrix-set! mat 1 j 0)
      (matrix-set! submat 1 j 0))
  (inc! t-row))



;;描画 
;;下に落ちることができるのなら下へ移動。
;;そうでなければぶつかり判定用submatに記録し新たな物体を出現させる。
;;最下行が0以外の数で埋まっていれば 1行下へスクロールする。
(define (disp)
  (disp-mat mat)
  (when enable
    (cond ((move-down?) (move-down))
          (else
            (cond ((game-over?) 
                   (init-mat)
                   (new)
                   (glut-idle-func #f)
                   (set! enable #f))
                  (else
                    (block-copy submat t-row t-col);;接地したものはsubmatに記録。
                    (when (scroll?) (scroll));;最下行が埋まったらスクロール。
                    (new)))))
    (sys-nanosleep 200000000)))

;;急速描画 
;;スリープなしで急速に下降する。
;;うまく効いていない。
(define (disp-quick) 
  (disp-mat mat) 
  (when enable
    (cond ((move-down?) (move-down))
          (else
            (block-copy submat t-row t-col)
            (when (scroll?) (scroll))
            (new)))))

;;行列を描画する。 
(define (disp-mat mat) 
  (gl-clear GL_COLOR_BUFFER_BIT) 
  (do ((i 1 (+ i 1))) 
      ((> i row)) 
      (do ((j 1 (+ j 1))) 
          ((> j col)) 
          (if (not (zero? (matrix-ref mat i j))) 
              (disp-quad i j (matrix-ref mat i j))))) 
  (gl-flush)) 

;;物体をセットする。
(define (new) 
  (let ((type (+ (random-integer 6) 1))
        (col (+ (random-integer 7) 2)));;置ける左端の列は2-8
    (block-copy-init type col)
    (set! t-row 1)
    (set! t-col col)))


;;物体をblockにセットしその物体を盤面の一番上にコピーする。
;;type 1=t-i 2=t-o 3=t-s 4=t-z 5=t-j 6=t-l 7=t-t
(define (block-copy-init type col)
  (cond ((= type 1) (set! block t-i))
        ((= type 2) (set! block t-o))
        ((= type 3) (set! block t-s))
        ((= type 4) (set! block t-z))
        ((= type 5) (set! block t-j))
        ((= type 6) (set! block t-l))
        ((= type 7) (set! block t-t)))
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (matrix-set! mat i (+ col j -1) (matrix-ref block i j)))))


;;行列のi,j成分に相当する位置に四角を描く。
;;水色1、黄色2、黄緑3、赤4、青5、オレンジ6、紫7 、グレー9
(define (disp-quad i j color) 
  (gl-begin GL_QUADS)
  (cond ((= color 1) (gl-color aqua))
        ((= color 2) (gl-color yellow))
        ((= color 3) (gl-color yellow-green))
        ((= color 4) (gl-color red))
        ((= color 5) (gl-color blue))
        ((= color 6) (gl-color orange))
        ((= color 7) (gl-color purple))
        ((= color 9) (gl-color gray)))
  
  (let* ((x1 (* quad-size j)) 
         (y1 (* quad-size i)) 
         (x2 (+ x1 quad-size -1)) 
         (y2 y1) 
         (x3 x2) 
         (y3 (+ y1 quad-size -1)) 
         (x4 x1) 
         (y4 y3)) 
    (gl-vertex x1 y1) 
    (gl-vertex x2 y2) 
    (gl-vertex x3 y3) 
    (gl-vertex x4 y4)) 
  (gl-end)) 

;;全部要素を0クリアした後
;;mat,submatに接地判定用と両脇ぶつかり判定用の要素を書きこむ。
;;ぶつかり判定用には9をあてる。
(define (init-mat)
  ;;0クリア
  (do ((i 1 (+ i 1)))
      ((> i row))
      (do ((j 1 (+ j 1)))
          ((> j col))
          (matrix-set! mat i j 0)
          (matrix-set! submat i j 0)))
  ;;ぶつかり判定用要素を書き込む
  (do ((i 1 (+ i 1)))
      ((> i row))
      (matrix-set! mat i 1 9)
      (matrix-set! submat i 1 9)
      (matrix-set! mat i 12 9)
      (matrix-set! submat i 12 9))
  (do ((j 1 (+ j 1)))
      ((> j col))
      (matrix-set! mat row j 9)
      (matrix-set! submat row j 9)))
      


;;アイドル状態で呼び出される。 
(define (idle) 
  (glut-post-redisplay)) 


;;リサイズ 
(define (resize w h) 
  (gl-viewport 0 0 w h) 
  (gl-load-identity) 
  (gl-ortho -0.5 (- w 0.5) (- h 0.5) -0.5 -1.0 1.0)) 

;;キー入力 
(define (keyboard key x y) 
  (cond ((= key (char->integer #\escape)) (exit)) 
        ((= key (char->integer #\space))
         (set! enable #t)
         (glut-idle-func idle)) 
        ((= key (char->integer #\s))
         (set! enable #f) 
         (glut-idle-func #f)) 
        ((= key (char->integer #\d)) 
         (when (move-right?) 
           (move-right))) 
        ((= key (char->integer #\a)) 
         (when (move-left?) 
           (move-left)))
        ((= key (char->integer #\e)) 
         (when (rotate-right?)
           (rotate-right)))
        ((= key (char->integer #\q))
         (when (rotate-left?)
           (rotate-left)))
        ((= key (char->integer #\x))
         (disp-quick))))
         


;;初期化 
;;背景色は白,物体をセット。 
(define (init) 
  (gl-clear-color 1 1 1 1)
  (init-mat) 
  (new))

(define (main args) 
  (glut-init args) 
  (glut-init-window-position 100 100) 
  (glut-init-window-size 280 500) 
  (glut-init-display-mode GLUT_RGBA) 
  (glut-create-window "tetris") 
  (glut-display-func disp) 
  (glut-reshape-func resize) 
  (glut-keyboard-func keyboard) 
  (init) 
  (glut-main-loop) 
  0) 


テトリス とりあえず眺めるだけバージョン

あと、左右移動と回転とゲームオーバー判定、をつけるとそれらしくなるかなぁ。なんとか間に合いそう。2010/12/22 02:52:32 PST

;;まだキー操作できないバージョン。スペースを押してただひたすらブロックが積みあがるのを眺めるだけ。
;;起動はコマンドラインから gosh ./tetris 
;;Ver0.1 
;;スペースキーをを押すとゲームスタート。 
;;ESCキーで終了。 
;;a キーで左移動、d キーで右移動。 
;;q キーで左回転、e キーで右回転 

(use gl) 
(use gl.glut) 
(use math.matrix) ;;自作行列ライブラリ 
(use srfi-27) ;;乱数利用のため 

(define t-row 0) ;;物体の位置行 
(define t-col 0) ;;物体の位置列 
(define quad-size 20) ;;描画するときの四角の1辺の長さ 
(define row 25);;盤面の行数、上の4行は次の物体の予告用、最下行は接地判定用
(define col 12);;盤面の列数  両脇はぶつかり判定用
(define mat (make-matrix row col))
(define submat '()) ;;着地した物体を保存する盤面がセットされる。
(define block '()) ;;落下物体を保存する行列がセットされる。

;;block テトリミノと言われているらしい。
;;各数に次の色を割り当てる。
;;水色1、黄色2、黄緑3、赤4、青5、オレンジ6、紫7
(define t-i 
  (list->matrix '((0 0 0 0)
                  (0 0 0 0)
                  (1 1 1 1)
                  (0 0 0 0))))

(define t-o
  (list->matrix '((0 0 0 0)
                  (0 2 2 0)
                  (0 2 2 0)
                  (0 0 0 0))))

(define t-s
  (list->matrix '((0 0 0 0)
                  (0 3 3 0)
                  (3 3 0 0)
                  (0 0 0 0))))

(define t-z
  (list->matrix '((0 0 0 0)
                  (4 4 0 0)
                  (0 4 4 0)
                  (0 0 0 0))))

(define t-j 
  (list->matrix '((0 0 0 0)
                  (5 0 0 0)
                  (5 5 5 0)
                  (0 0 0 0))))

(define t-l
  (list->matrix '((0 0 0 0)
                  (0 0 6 0)
                  (6 6 6 0)
                  (0 0 0 0))))

(define t-t
  (list->matrix '((0 0 0 0)
                   (0 7 0 0)
                   (7 7 7 0)
                   (0 0 0 0))))

 
;;色データ 
(define red #f32(1 0 0)) 
(define green #f32(0 1 0)) 
(define blue #f32(0 0 1)) 
(define black #f32(0 0 0)) 
(define white #f32(1 1 1)) 
(define yellow #f32(1 1 0)) 
(define aqua #f32(0 1 1))
(define purple #f32(0.5 0 0.5))
(define orange #f32(1 0.5 0))
(define yellow-green #f32(0.5 1 0)) 

;;移動判定 

;;物体が下に落ちることができるか? 
(define (move-down?) 
  (let ((n 0)) ;;ぶつかるセル数 
    (do ((i 1 (+ i 1)))
        ((> i 4))
        (do ((j 1 (+ j 1)))
            ((> j 4))
            ;(print (matrix-ref block i j))
            ;(print (matrix-ref submat (+ t-row i) (+ t-col j -1)))
            (when (and (not (zero? (matrix-ref block i j)))
                       (not (zero? (matrix-ref submat (+ t-row i) (+ t-col j -1)))))
              ;(print "inc")
              (inc! n))))
    (zero? n)))
                    


;;物体を下に1行落とす。 
;;物体を消去して行を1プラスしてその位置にblock行列をコピーする。 
(define (move-down) 
  (block-clear mat t-row t-col)
  (inc! t-row)
  (block-copy mat t-row t-col))

;;bolck行列をm行列の(r c)位置にコピーする。
;;ただし0はコピーしない。
(define (block-copy m r c)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (let ((val (matrix-ref block i j)))
            (when (not (zero? val))
              (matrix-set! m (+ r i -1) (+ c j -1) val))))))

;;block行列があった場所を指定して消去する。block行列の0の部分は消去しない。
(define (block-clear m r c)
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (when (not (zero? (matrix-ref block i j)))
            (matrix-set! m (+ r i -1) (+ c j -1) 0)))))


;;描画 
;;下に落ちることができるのなら下へ移動。
;;そうでなければぶつかり判定用submatに記録し新たな物体を出現させる。 
(define (disp) 
  (disp-mat mat) 
  (cond ((move-down?) (move-down))
        (else
          (block-copy submat t-row t-col)
          (new))) 
  (sys-nanosleep 100000000)) 

;;行列を描画する。 
(define (disp-mat mat) 
  (gl-clear GL_COLOR_BUFFER_BIT) 
  (do ((i 1 (+ i 1))) 
      ((> i row)) 
      (do ((j 1 (+ j 1))) 
          ((> j col)) 
          (if (not (zero? (matrix-ref mat i j))) 
              (disp-quad i j (matrix-ref mat i j))))) 
  (gl-flush)) 

;;物体をセットする。 
(define (new) 
  (let ((type (+ (random-integer 6) 1))
        (col (+ (random-integer 7) 2)));;置ける左端の列は2-8
    (block-copy-init type col)
    (set! t-row 1)
    (set! t-col col)))


;;物体をblockにセットしその物体を盤面の一番上にコピーする。
;;type 1=t-i 2=t-o 3=t-s 4=t-z 5=t-j 6=t-l 7=t-t
(define (block-copy-init type col)
  (cond ((= type 1) (set! block t-i))
        ((= type 2) (set! block t-o))
        ((= type 3) (set! block t-s))
        ((= type 4) (set! block t-z))
        ((= type 5) (set! block t-j))
        ((= type 6) (set! block t-l))
        ((= type 7) (set! block t-t)))
  (do ((i 1 (+ i 1)))
      ((> i 4))
      (do ((j 1 (+ j 1)))
          ((> j 4))
          (matrix-set! mat i (+ col j -1) (matrix-ref block i j)))))


;;上記下請け関数 
;;行列のi,j成分に相当する位置に四角を描く。
;;水色1、黄色2、黄緑3、赤4、青5、オレンジ6、紫7 、黒9
(define (disp-quad i j color) 
  (gl-begin GL_QUADS)
  (cond ((= color 1) (gl-color aqua))
        ((= color 2) (gl-color yellow))
        ((= color 3) (gl-color yellow-green))
        ((= color 4) (gl-color red))
        ((= color 5) (gl-color blue))
        ((= color 6) (gl-color orange))
        ((= color 7) (gl-color purple))
        ((= color 9) (gl-color black)))
  
  (let* ((x1 (* quad-size j)) 
         (y1 (* quad-size i)) 
         (x2 (+ x1 quad-size -1)) 
         (y2 y1) 
         (x3 x2) 
         (y3 (+ y1 quad-size -1)) 
         (x4 x1) 
         (y4 y3)) 
    (gl-vertex x1 y1) 
    (gl-vertex x2 y2) 
    (gl-vertex x3 y3) 
    (gl-vertex x4 y4)) 
  (gl-end)) 


;;盤面に接地判定用と両脇ぶつかり判定用の要素を書きこむ。
;;ぶつかり判定用には9をあてる。
(define (init-mat)
  (do ((i 1 (+ i 1)))
      ((> i row))
      (matrix-set! mat i 1 9)
      (matrix-set! mat i 12 9))
  (do ((j 1 (+ j 1)))
      ((> j col))
      (matrix-set! mat row j 9))
  (set! submat (matrix-copy mat)))
      


;;アイドル状態で呼び出される。 
(define (idle) 
  (glut-post-redisplay)) 


;;リサイズ 
(define (resize w h) 
  (gl-viewport 0 0 w h) 
  (gl-load-identity) 
  (gl-ortho -0.5 (- w 0.5) (- h 0.5) -0.5 -1.0 1.0)) 

;;キー入力 
(define (keyboard key x y) 
  (cond ((= key (char->integer #\escape)) (exit)) 
        ((= key (char->integer #\space)) 
         (glut-idle-func idle)) 
        ((= key (char->integer #\s)) 
         (glut-idle-func #f)) 
        ((= key (char->integer #\d)) 
         (when (move-right?) 
           (move-right))) ;;まだ
        ((= key (char->integer #\a)) 
         (when (move-left?) 
           (move-left))) ;;まだ
        ((= key (char->integer #\e)) 
         (rotate-right)))) ;;まだ


;;初期化 
;;背景色は白,物体をセット。 
(define (init) 
  (gl-clear-color 1 1 1 1)
  (init-mat) 
  (new)) 

(define (main args) 
  (glut-init args) 
  (glut-init-window-position 100 100) 
  (glut-init-window-size 300 550) 
  (glut-init-display-mode GLUT_RGBA) 
  (glut-create-window "tetris") 
  (glut-display-func disp) 
  (glut-reshape-func resize) 
  (glut-keyboard-func keyboard) 
  (init) 
  (glut-main-loop) 
  0) 

sys-sleep sys-nanosleep

テトリスが落ちてくるスピードを調節しようと何かないかなと調べてみるとsys-sleepというのがありました。Windowsではこっちしか使えないようです。秒単位のスリープなので1秒じゃちょっと長すぎるしnanosleepは使えないし、さて、どうしたらいいのかなぁ。2010/12/21 04:56:20 PST

クリスマスプレゼント

息子たちには例年どおりにサンタさんから市販品のゲームが要望に従って届くことになっているのだけど、これではいかにも味気ない。確かに市販のゲームはとてもよくできているし素人が真似できる レベルじゃないんだけれども。手作りのプレゼントとして私自身が作ったテトリスゲームをプレゼントすることに決めた。仕事が終わってから残ってGauche-glでテトリス作成。なんかそれらしくなってきたかな。あと2日しかないなぁ。間に合うかなぁ。これはお父さんからのプレゼント。 「ふ~ん」で終わってしまうような気もするけれど。2010/12/21 04:45:49 PST

テトリス

息子たちへのウケを狙ってテトリスを作ってしまおうかと思ってます。これの作成、アルゴリズム考案は教育的題材に最適なのかもしれません。ピースの回転、移動、接地判定、考えるとけっこう面白そうです。Gaucheだと慣れた人なら1時間もあれば作れてしまいそうです。2010/12/20 16:12:18 PST

3D化 

ちょっと頑張ると3Dのライフゲームもできそうです。2Dもけっこう楽しい。単純な初期設定が思わぬ発展を見せ、奇妙な形になるってのは子供たちにもウケそうです。市販のゲームじゃなくって、こういうシンプルなので感動してくれて、自分でゲームを作ろうって気になってくれるとうれしいのですが。おっと、ゲームネタは危ないな。2010/12/20 01:05:32 PST

ライフゲームはOpen-GLの修得用に今後、あれこれと改良、改造の予定です。 コードは↓に置いてあります。

http://homepage1.nifty.com/~skz/Entry/lifegame.html

ああ、いけね、判定まだ間違えてた。2010/12/19 04:23:33 PST

;;生死判定。
;;死のセルに隣接するセルのうち3つが生ならば生。
;;生のセルに隣接するセルのうち2あるいは3個が生のときは生。
;;それ以外は死。
(define (life? m i j) 
  (let ((life-n 0)
        (life-ij (matrix-ref m i j))) 
    (do ((x (- i 1) (+ x 1))) 
        ((> x (+ i 1))) 
        (do ((y (- j 1) (+ y 1))) 
            ((> y (+ j 1))) 
            (cond ((and (= x i)(= y j)) #t) 
                  ((= (matrix-ref m x y) 1) (inc! life-n))))) 
    
    (cond ((and (= life-ij 0) (= life-n 3) #t))
          ((and (= life-ij 1) (or (= life-n 2)(= life-n 3))) #t)
          (else #f))))

ライフゲーム、補正しました。2010/12/19 03:54:39 PST

;;以前書いたOpenGLの演習用コードをベースにしてライフげゲームを書く。
;;OpenGL学習用のコード。
;;データは自作行列ライブラリの行列を使って世代交代を計算する。
;;世代交代の都度、アニメーションの要領でデータを画像表示する。

;;コマンドラインから gosh ./lifegame
;;Ver0.2
;;スペースキーをを押すと世代交代が進む。sキーで停止。
;;returnキーで1世代だけ計算して表示。
;; r キーで初期化。乱数で初期状態を生成、cキーでクリア。
;;左マウスボタンでセルを生きるに。右マウスボタンでセルを死に。
;;生死判定条件を修正。さっぱり増殖しなくなった。

(use gl)
(use gl.glut)
(use math.matrix) ;;自作行列ライブラリ 
(use srfi-27) ;;乱数利用のため

;;i,j要素について生死を判定する。 
;;端の要素でない通常の場合なら 
;; 0 0 0 (i-1,j-1)(i-1,j)(i-1,j+1) 
;; 0 1 0 (i,j-1)(i,j)(i,j+1) 
;; 0 0 0 (i+1,j-1)(i+1,j)(i+1,j+1) 
;;10*10 なら8*8の部分だけを使う。これにより端の要素の判定を簡素化できる。 

(define n 50) ;;生成するセルの大きさ n*n
(define quad-size (/ 500 n));;描画するときの四角の1辺の長さ
(define mat1 (make-matrix (+ n 2) (+ n 2))) 
(define mat2 (make-matrix (+ n 2) (+ n 2))) 
(define sw 1) ;スイッチ 最初はmat1をもとに判定するので1、その後2,1,2,1・・
(define enable #t);スイッチ、描画させるかどうかのスイッチ。停止状態#f、描画状態で#tとする。

;;生死判定。
;;死のセルに隣接するセルのうち3つが生ならば生。
;;生のセルに隣接するセルのうち2あるいは3個が生のときは生。
;;生のセルに隣接する生のセルが1以下なら死。
;;生のセルに隣接する生のセルが4以上なら死。
;;それ以外は死。
(define (life? m i j) 
  (let ((life-n 0)
        (life-ij (matrix-ref m i j))) 
    (do ((x (- i 1) (+ x 1))) 
        ((> x (+ i 1))) 
        (do ((y (- j 1) (+ y 1))) 
            ((> y (+ j 1))) 
            (cond ((= x y) #t) 
                  ((= (matrix-ref m x y) 1) (inc! life-n))))) 
    
    (cond ((and (= life-ij 0) (= life-n 3)) #t)
          ((and (= life-ij 1) (or (= life-n 2)(= life-n 3))) #t)
          ((and (= life-ij 1) (<= life-n 1)) #f)
          ((and (= life-ij 1) (>= life-n 4)) #f)
          (else #f))))

;;行列1の状態から次世代を行列2に生成する。 
(define (next-1->2) 
  (define start 2)
  (define end (- n 1))
  (do ((i start (+ i 1))) 
      ((> i end)) 
      (do ((j start (+ j 1))) 
          ((> j end))
          (if (life? mat1 i j) 
              (matrix-set! mat2 i j 1) 
              (matrix-set! mat2 i j 0))))) 

;;行列2の状態から次世代を行列1に生成する。 
(define (next-2->1)
  (define start 2)
  (define end (- n 1)) 
  (do ((i start (+ i 1))) 
      ((> i end)) 
      (do ((j start (+ j 1))) 
          ((> j end))
          (if (life? mat2 i j) 
              (matrix-set! mat1 i j 1) 
              (matrix-set! mat1 i j 0))))) 

;;乱数で0-9を発生させて0のときだけ生としてmat1に要素1を書き込む。他は0。 
(define (set-random)
  (define start 2)
  (define end (- n 1))
  
  (matrix-map! (lambda (x) 0) mat1) 
  (do ((i start (+ i 1))) 
      ((> i end))
      (do ((j start (+ j 1))) 
          ((> j end)) 
          (if (= (random-integer 10) 0) 
              (matrix-set! mat1 i j 1))))) 


;;描画
;;画面を500*500とみて行列を指定して描かせる。これをmat1,mat2について交互に行う。
;;マウスボタンにより再描画がかかるのを防ぐためにenable=#tのときだけ描画が行われる。
(define (disp)
  (when enable
    (cond ((= sw 1)
           (next-1->2)
           (disp-mat mat2)
           (set! sw 2))
          ((= sw 2)
           (next-2->1)
           (disp-mat mat1)
           (set! sw 1)))))

;;行列を描画する。
(define (disp-mat mat)
  (gl-clear GL_COLOR_BUFFER_BIT)
  (gl-color 0 0 1)
  (do ((i 2 (+ i 1)))
      ((> i n))
      (do ((j 2 (+ j 1)))
          ((> j n))
          (if (= (matrix-ref mat i j) 1)
              (disp-quad i j))))
  (gl-flush))

                           
;;上記下請け関数
;;行列のi,j成分に相当する位置に四角を描く。
(define (disp-quad i j)
  (gl-begin GL_QUADS)
  (let* ((x1 (* quad-size (- i 1)))
         (y1 (* quad-size (- j 1)))
         (x2 (+ x1 quad-size -1))
         (y2 y1)
         (x3 x2)
         (y3 (+ y1 quad-size -1))
         (x4 x1)
         (y4 y3))
    (gl-vertex x1 y1)
    (gl-vertex x2 y2)
    (gl-vertex x3 y3)
    (gl-vertex x4 y4))
  (gl-end))

;;アイドル状態で呼び出される。
(define (idle)
  (glut-post-redisplay))


;;リサイズ
(define (resize w h)
  (gl-viewport 0 0 w h)
  (gl-load-identity)
  (gl-ortho -0.5 (- w 0.5)  (- h 0.5) -0.5 -1.0 1.0))

;;キー入力
(define (keyboard key x y)
  (cond ((= key (char->integer #\escape)) (exit))
        ((= key (char->integer #\r)) (reset))
        ((= key (char->integer #\space)) 
         (set! enable #t)
         (glut-idle-func idle))
        ((= key (char->integer #\s)) 
         (set! enable #f)
         (glut-idle-func #f))
        ((= key (char->integer #\return)) 
         (set! enable #t)
         (disp)
         (set! enable #f))
        ((= key (char->integer #\c)) (clear))))

;;リセット
;;初期行列を乱数で生成し描画する。
(define (reset)
  (set-random)
  (set! sw 1)
  (disp-mat mat1))

;;クリア
;;行列1の要素を全部0とし再描画する。
(define (clear)
  (matrix-map! (lambda (x) 0) mat1)
  (set! sw 1)
  (disp-mat mat1))

;;マウス操作
(define (mouse button state x y)
  (cond ((= button GLUT_LEFT_BUTTON)
         (cond ((= state GLUT_DOWN)
                (let ((i (+ (quotient x quad-size) 1));;マウスの位置を行列要素に変換
                      (j (+ (quotient y quad-size) 1)))
                  (matrix-set! mat1 i j 1)
                  (set! sw 1)
                  (disp-mat mat1)))))
             
        ((= button GLUT_RIGHT_BUTTON)
         (cond ((= state GLUT_DOWN)
                (let ((i (+ (quotient x quad-size) 1))
                      (j (+ (quotient y quad-size) 1)))
                  (matrix-set! mat1 i j 0)
                  (set! sw 1)
                  (disp-mat mat1)))))))



;;初期化
;;背景色は白
(define (init)
  (gl-clear-color 1 1 1 1)
  (set-random))

(define (main args)
  (glut-init args)
  (glut-init-window-position 100 100)
  (glut-init-window-size 500 500)
  (glut-init-display-mode GLUT_RGBA)
  (glut-create-window "lifegame")
  (glut-display-func disp)
  (glut-reshape-func resize)
  (glut-mouse-func mouse)
  (glut-keyboard-func keyboard)
  (init)
  (glut-main-loop)
  0)



Last modified : 2012/03/18 11:10:41 UTC