;; TetrisSquareクラスの定義
(defun TetrisSquare (x y color)
(list x y color))
(defun TetrisSquareGetX (square)
(nth 0 square))
(defun TetrisSquareGetY (square)
(nth 1 square))
(defun TetrisSquareGetColor (square)
(nth 2 square))
;; TetrisFieldクラスの定義
(defun TetrisField (/ width height squares)
(setq width 10
height 20
squares (make-array (list height width))))
(defun TetrisFieldGetWidth ()
width)
(defun TetrisFieldGetHeight ()
height)
(defun TetrisFieldGetSquare (x y)
(aref squares y x))
(defun TetrisFieldJudgeGameOver (block)
(setq noEmptyCord (list)
blockCord (list))
(repeat height
(repeat width
(if (/= "gray" (TetrisSquareGetColor (TetrisFieldGetSquare x y)))
(setq noEmptyCord (cons (cons x y) noEmptyCord)))
(setq x (+ x 1))
)
(setq x 0
y (+ y 1))
)
(foreach square (TetrisBlockGetSquares block)
(setq cord (TetrisSquareGetCord square))
(setq blockCord (cons (cons (car cord) (cadr cord)) blockCord))
)
(setq blockCord (vl-remove-if-not '(lambda (x) (member x noEmptyCord)) blockCord))
(> (length blockCord) 0)
)
(defun TetrisFieldJudgeCanMove (block direction)
(setq noEmptyCord (list))
(repeat height
(repeat width
(if (/= "gray" (TetrisSquareGetColor (TetrisFieldGetSquare x y)))
(setq noEmptyCord (cons (cons x y) noEmptyCord)))
(setq x (+ x 1))
)
(setq x 0
y (+ y 1))
)
(setq moveBlockCord (list))
(foreach square (TetrisBlockGetSquares block)
(setq cord (TetrisSquareGetMovedCord square direction))
(setq moveBlockCord (cons (cons (car cord) (cadr cord)) moveBlockCord))
(if (or (< (car cord) 0)
(>= (car cord) width)
(< (cadr cord) 0)
(>= (cadr cord) height))
(return nil)
)
)
(setq moveBlockCord (vl-remove-if-not '(lambda (x) (member x noEmptyCord)) moveBlockCord))
(= (length moveBlockCord) 0)
)
(defun TetrisFieldFixBlock (block)
(foreach square (TetrisBlockGetSquares block)
(setq x (car (TetrisSquareGetCord square))
y (cadr (TetrisSquareGetCord square))
color (TetrisSquareGetColor square))
(setq (nth y (nth x squares)) (TetrisSquare x y color))
)
)
(defun TetrisFieldDeleteLine ()
(setq y (- height 1))
(while (>= y 0)
(setq isFull T)
(setq x 0)
(while (< x width)
(if (= "gray" (TetrisSquareGetColor (TetrisFieldGetSquare x y)))
(setq isFull nil))
(setq x (+ x 1))
)
(if isFull
(progn
(setq yy y)
(while (> yy 0)
(setq x 0)
(while (< x width)
(setq (nth yy (nth x squares)) (TetrisSquareGetX (nth (- yy 1) (nth x squares)))
(TetrisSquareGetY (nth (- yy 1) (nth x squares)))
(TetrisSquareGetColor (nth (- yy 1) (nth x squares)))))
(setq x (+ x 1))
)
(setq yy (- yy 1))
)
(setq x 0)
(while (< x width)
(setq (nth 0 (nth x squares)) (TetrisSquare x 0 "gray"))
(setq x (+ x 1))
)
(setq y (+ y 1))
)
)
(setq y (- y 1))
)
)
;; TetrisBlockクラスの定義
(defun TetrisBlock (/ squares)
(setq squares (list))
(setq blockType (random 4))
(cond
((= blockType 0)
(setq color "red"
cords (list (list (/ 10 2) 0)
(list (/ 10 2) 1)
(list (/ 10 2) 2)
(list (/ 10 2) 3))))
((= blockType 1)
(setq color "blue"
cords (list (list (/ 10 2) 0)
(list (/ 10 2) 1)
(list (- (/ 10 2) 1) 0)
(list (- (/ 10 2) 1) 1))))
((= blockType 2)
(setq color "green"
cords (list (list (- (/ 10 2) 1) 0)
(list (/ 10 2) 0)
(list (/ 10 2) 1)
(list (/ 10 2) 2))))
((= blockType 3)
(setq color "orange"
cords (list (list (/ 10 2) 0)
(list (- (/ 10 2) 1) 0)
(list (- (/ 10 2) 1) 1)
(list (- (/ 10 2) 1) 2))))
(T
(setq color "gray"
cords nil))
)
(foreach cord cords
(setq squares (cons (TetrisSquare (car cord) (cadr cord) color) squares))
)
squares
)
(defun TetrisBlockGetSquares (block)
squares)
(defun TetrisBlockMove (block direction)
(setq newSquares (list))
(foreach square squares
(setq movedCord (TetrisSquareGetMovedCord square direction)
x (car movedCord)
y (cadr movedCord))
(setq newSquares (cons (TetrisSquare x y (TetrisSquareGetColor square)) newSquares))
)
(setq squares newSquares)
)
;; TetrisGameクラスの定義
(defun TetrisGame (/ field block canvas)
(setq field (TetrisField)
block nil
canvas nil))
(defun TetrisGameStart ()
(setq field (TetrisField)
block nil
canvas (TetrisCanvas field))
)
(defun TetrisGameNewBlock ()
(setq block (TetrisBlock))
(if (TetrisFieldJudgeGameOver block)
(progn
(princ "GAMEOVER")
(terpri))
)
)
(defun TetrisGameMoveBlock (direction)
(if (TetrisFieldJudgeCanMove block direction)
(progn
(TetrisBlockMove block direction)
(TetrisCanvasUpdate canvas field block))
(if (= direction 2)
(progn
(TetrisFieldFixBlock block)
(TetrisFieldDeleteLine)
(TetrisGameNewBlock)
(TetrisCanvasUpdate canvas field block))
)
)
)
;; TetrisCanvasクラスの定義
(defun TetrisCanvas (field)
(setq beforeField field
field field))
(defun TetrisCanvasUpdate (field block)
(setq beforeField field)
;; キャンバスを更新する処理
)
;; TetrisCommandsクラスの定義
(defun c:TETRIS ()
(setq field (TetrisField)
block nil
canvas (TetrisCanvas field)
game (TetrisGame))
(TetrisGameStart)
(while T
;; ユーザー入力を取得し、適切な方向で game.MoveBlock(direction) を呼び出す
)
)
さてどうなるか？
