Autolisp言語でテトリスを作れるかな？その２

《第二案》

(defun TetrisGame ()
;; フィールドの幅と高さ
(setq FIELD_WIDTH 10
FIELD_HEIGHT 20)

;; フィールドの初期化
(setq field (make-array '(20 10) :initial-element nil))

;; ブロックの初期化
(defun TetrisBlock ()
(setq shapes '(
((0 0) (0 1) (1 0) (1 1)) ; 四角
((0 0) (0 1) (0 2) (0 3)) ; 直線
((0 0) (0 1) (0 2) (1 2)) ; L字
((0 0) (1 0) (1 1) (1 2)) ; 逆L字
((0 0) (0 1) (1 1) (1 2)) ; S字
((0 1) (0 2) (1 0) (1 1)) ; 逆S字
((0 0) (0 1) (0 2) (1 1)) ; T字
))
(setq random-block (nth (random (length shapes)) shapes))
(setq x (/ (- FIELD_WIDTH (car (last random-block))) 2))
(setq y (- FIELD_HEIGHT 1))
(list random-block x y))

;; ブロックの描画
(defun DrawBlock (block)
(setq cords (cdr block))
(foreach cord cords
(setq x (+ (car cord) (car (cdr block))))
(setq y (+ (cadr cord) (cadr (cdr block))))
(setq field[y][x] 'X)))

;; ブロックの操作
(defun RotateBlock (block)
(setq cords (cdr block))
(setq rotated-block (list (car cords) (list (- (cadr cords)) (car (car cords))))
x (car (cddr block))
y (cadr (cddr block)))

;; 回転後のブロックがフィールド内に収まるかチェック
(if (or (< x 0) (> (+ x (car (last (car rotated-block)))) (- FIELD_WIDTH 1))
(setq rotated-block block))
(if (or (< y 0) (> (+ y (cadr (last (car rotated-block)))) (- FIELD_HEIGHT 1)))
(setq rotated-block block))

rotated-block)

(defun MoveBlock (block direction)
(setq cords (cdr block))
(setq new-cords '())
(setq x (car (cddr block))
y (cadr (cddr block)))

;; 移動後のブロックがフィールド内に収まるかチェック
(if (or (< x 0) (> (+ x (car (last (car cords)))) (- FIELD_WIDTH 1)))
(setq new-cords cords))
(if (or (< y 0) (> (+ y (cadr (last (car cords)))) (- FIELD_HEIGHT 1)))
(setq new-cords cords))

(if (equal direction 'MOVE_LEFT)
(progn
(foreach cord cords
(setq new-cords (cons (list (- (car cord) 1) (cadr cord)) new-cords))))
(progn
(foreach cord cords
(setq new-cords (cons (list (+ (car cord) 1) (cadr cord)) new-cords)))))

(list (car block) (car (cdr block)) (car (cddr block)) (list new-cords x y)))

;; ブロックの衝突判定
(defun CheckCollision (block)
(setq cords (cdr block))
(foreach cord cords
(setq x (+ (car cord) (car (cdr block))))
(setq y (+ (cadr cord) (cadr (cdr block))))
(if (or (< x 0) (> x (- FIELD_WIDTH 1)) (< y 0) (> y (- FIELD_HEIGHT 1)) (not (null field[y][x])))
(return t)))
nil)

;; ブロックの固定
(defun FixBlock (block)
(setq cords (cdr block))
(foreach cord cords
(setq x (+ (car cord) (car (cdr block))))
(setq y (+ (cadr cord) (cadr (cdr block))))
(setq field[y][x] 'X)))

;; ラインの消去判定とスコアの更新
(defun CheckLines ()
(setq full-lines nil)
(repeat FIELD_HEIGHT
(setq line-full t)
(repeat FIELD_WIDTH
(if (null field[row][col])
(setq line-full nil)))
(if line-full
(setq full-lines (cons row full-lines))))

(if full-lines
(progn
(foreach line full-lines
(setq row (- line (length full-lines)))
(repeat FIELD_WIDTH
(setq field[row][col] nil))
(setq score (+ score 100)))
(setq full-lines nil)
(setq line-shift 0)
(setq row (- FIELD_HEIGHT 2))
(while (>= row 0)
(if (null (nth row field))
(setq line-shift (+ line-shift 1))
(setq field[(- row line-shift)] (nth row field)))
(setq row (- row 1)))
(repeat line-shift
(setq field[(- FIELD_HEIGHT (- line-shift (- it 1)))] (make-array FIELD_WIDTH :initial-element nil))))))

;; ゲームオーバー判定
(defun CheckGameOver (block)
(setq cords (cdr block))
(foreach cord cords
(setq x (car cord)
y (cadr cord))
(if (< y 0)
(return t)))
nil)

;; ゲームオーバー時の処理
(defun GameOver ()
(princ " Game Over!")
(princ " Score: ")
(princ score)
(exit))

;; ゲームループ
(setq score 0)
(setq current-block (TetrisBlock))
(setq game-over nil)
(setq move-direction nil)

(while (not game-over)
(command "_.zoom" "_extents")

;; キー入力の取得
(setq key (getvar 'Error))

;; ブロックの操作
(cond
((equal key 'MOVE_LEFT) (setq move-direction 'MOVE_LEFT))
((equal key 'MOVE_RIGHT) (setq move-direction 'MOVE_RIGHT))
((equal key 'ROTATE) (setq current-block (RotateBlock current-block))))

;; ブロックの移動
(setq moved-block (MoveBlock current-block move-direction))

;; 衝突判定
(setq collision (CheckCollision moved-block))
(if collision
(progn
(if (equal move-direction 'MOVE_LEFT)
(setq moved-block (MoveBlock current-block 'MOVE_RIGHT))
(setq moved-block (MoveBlock current-block 'MOVE_LEFT)))
(setq collision (CheckCollision moved-block))))

;; ブロックの固定またはゲームオーバー判定
(if (or collision (CheckGameOver moved-block))
(progn
(FixBlock current-block)
(CheckLines)
(if (CheckGameOver (TetrisBlock))
(setq game-over t))
(setq current-block (TetrisBlock))
(setq move-direction nil))
(setq current-block moved-block))

;; フィールドの描画
(princ " ")
(repeat FIELD_HEIGHT
(princ " ")
(repeat FIELD_WIDTH
(if (null field[row][col])
(princ " ")
(princ "X")))
(princ " "))

;; スコアの表示
(princ " Score: ")
(princ score)
(princ " ")

;; 一時停止
(if (equal key 'PAUSE)
(progn
(setq key nil)
(while (not (equal key 'PAUSE))
(setq key (getvar 'Error))))))

(GameOver))

これもダメorz

参ったなぁ