mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-01-30 12:21:25 -08:00
Initial revision
This commit is contained in:
Richard M. Stallman
parent
6b6dee47c9
commit
3d4ae13ee1
2 changed files with 1027 additions and 0 deletions
427
lisp/play/gamegrid.el
Normal file
427
lisp/play/gamegrid.el
Normal file
|
|
@ -0,0 +1,427 @@
|
|||
;;; gamegrid.el -- Library for implementing grid-based games on Emacs
|
||||
|
||||
;; Copyright (C) 1997, 1998 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Glynn Clements <glynn@sensei.co.uk>
|
||||
;; Version: 1.02
|
||||
;; Created: 1997-08-13
|
||||
;; Keywords: games
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
(eval-when-compile
|
||||
(require 'cl))
|
||||
|
||||
;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar gamegrid-use-glyphs t
|
||||
"Non-nil means use glyphs when available.")
|
||||
|
||||
(defvar gamegrid-use-color t
|
||||
"Non-nil means use color when available.")
|
||||
|
||||
(defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
|
||||
"Name of the font used in X mode.")
|
||||
|
||||
(defvar gamegrid-display-options nil)
|
||||
|
||||
(defvar gamegrid-buffer-width 0)
|
||||
(defvar gamegrid-buffer-height 0)
|
||||
(defvar gamegrid-blank 0)
|
||||
|
||||
(defvar gamegrid-timer nil)
|
||||
|
||||
(defvar gamegrid-display-mode nil)
|
||||
|
||||
(defvar gamegrid-display-table)
|
||||
|
||||
(defvar gamegrid-face-table nil)
|
||||
|
||||
(defvar gamegrid-buffer-start 1)
|
||||
|
||||
(defvar gamegrid-score-file-length 50
|
||||
"Number of high scores to keep")
|
||||
|
||||
(make-variable-buffer-local 'gamegrid-use-glyphs)
|
||||
(make-variable-buffer-local 'gamegrid-use-color)
|
||||
(make-variable-buffer-local 'gamegrid-font)
|
||||
(make-variable-buffer-local 'gamegrid-display-options)
|
||||
(make-variable-buffer-local 'gamegrid-buffer-width)
|
||||
(make-variable-buffer-local 'gamegrid-buffer-height)
|
||||
(make-variable-buffer-local 'gamegrid-blank)
|
||||
(make-variable-buffer-local 'gamegrid-timer)
|
||||
(make-variable-buffer-local 'gamegrid-display-mode)
|
||||
(make-variable-buffer-local 'gamegrid-display-table)
|
||||
(make-variable-buffer-local 'gamegrid-face-table)
|
||||
(make-variable-buffer-local 'gamegrid-buffer-start)
|
||||
(make-variable-buffer-local 'gamegrid-score-file-length)
|
||||
|
||||
;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar gamegrid-grid-x-face nil)
|
||||
(defvar gamegrid-mono-x-face nil)
|
||||
(defvar gamegrid-mono-tty-face nil)
|
||||
|
||||
;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defconst gamegrid-glyph-height 16)
|
||||
|
||||
(defconst gamegrid-xpm "\
|
||||
/* XPM */
|
||||
static char *noname[] = {
|
||||
/* width height ncolors chars_per_pixel */
|
||||
\"16 16 3 1\",
|
||||
/* colors */
|
||||
\"+ s col1\",
|
||||
\". s col2\",
|
||||
\"- s col3\",
|
||||
/* pixels */
|
||||
\"---------------+\",
|
||||
\"--------------++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"--............++\",
|
||||
\"-+++++++++++++++\",
|
||||
\"++++++++++++++++\"
|
||||
};
|
||||
"
|
||||
"XPM format image used for each square")
|
||||
|
||||
;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defsubst gamegrid-characterp (arg)
|
||||
(if (fboundp 'characterp)
|
||||
(characterp arg)
|
||||
(integerp arg)))
|
||||
|
||||
(defsubst gamegrid-event-x (event)
|
||||
(if (fboundp 'event-x)
|
||||
(event-x event)
|
||||
(car (posn-col-row (event-end event)))))
|
||||
|
||||
(defsubst gamegrid-event-y (event)
|
||||
(if (fboundp 'event-y)
|
||||
(event-y event)
|
||||
(cdr (posn-col-row (event-end event)))))
|
||||
|
||||
;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun gamegrid-color (color shade)
|
||||
(let* ((v (floor (* shade 255)))
|
||||
(r (* v (aref color 0)))
|
||||
(g (* v (aref color 1)))
|
||||
(b (* v (aref color 2))))
|
||||
(format "#%02x%02x%02x" r g b)))
|
||||
|
||||
(defun gamegrid-set-font (face)
|
||||
(if gamegrid-font
|
||||
(condition-case nil
|
||||
(set-face-font face gamegrid-font)
|
||||
('error nil))))
|
||||
|
||||
(defun gamegrid-setup-face (face color)
|
||||
(set-face-foreground face color)
|
||||
(set-face-background face color)
|
||||
(gamegrid-set-font face)
|
||||
(condition-case nil
|
||||
(set-face-background-pixmap face [nothing]);; XEmacs
|
||||
('error nil))
|
||||
(condition-case nil
|
||||
(set-face-background-pixmap face nil);; Emacs
|
||||
('error nil)))
|
||||
|
||||
(defun gamegrid-make-mono-tty-face ()
|
||||
(let ((face (make-face 'gamegrid-mono-tty-face)))
|
||||
(condition-case nil
|
||||
(set-face-property face 'reverse t)
|
||||
('error nil))
|
||||
face))
|
||||
|
||||
(defun gamegrid-make-color-tty-face (color)
|
||||
(let* ((hex (gamegrid-color color 1.0))
|
||||
(name (intern (format "gamegrid-color-tty-face-%s" hex)))
|
||||
(face (make-face name)))
|
||||
(gamegrid-setup-face face color)
|
||||
face))
|
||||
|
||||
(defun gamegrid-make-grid-x-face ()
|
||||
(let ((face (make-face 'gamegrid-x-border-face)))
|
||||
(gamegrid-set-font face)
|
||||
face))
|
||||
|
||||
(defun gamegrid-make-mono-x-face ()
|
||||
(let ((face (make-face 'gamegrid-mono-x-face))
|
||||
(color (face-foreground 'default)))
|
||||
(if (null color)
|
||||
(setq color
|
||||
(cdr-safe (assq 'foreground-color (frame-parameters)))))
|
||||
(gamegrid-setup-face face color)
|
||||
face))
|
||||
|
||||
(defun gamegrid-make-color-x-face (color)
|
||||
(let* ((hex (gamegrid-color color 1.0))
|
||||
(name (intern (format "gamegrid-color-x-face-%s" hex)))
|
||||
(face (make-face name)))
|
||||
(gamegrid-setup-face face (gamegrid-color color 1.0))
|
||||
face))
|
||||
|
||||
(defun gamegrid-make-face (data-spec-list color-spec-list)
|
||||
(let ((data (gamegrid-match-spec-list data-spec-list))
|
||||
(color (gamegrid-match-spec-list color-spec-list)))
|
||||
(case data
|
||||
('color-x
|
||||
(gamegrid-make-color-x-face color))
|
||||
('grid-x
|
||||
(unless gamegrid-grid-x-face
|
||||
(setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
|
||||
gamegrid-grid-x-face)
|
||||
('mono-x
|
||||
(unless gamegrid-mono-x-face
|
||||
(setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
|
||||
gamegrid-mono-x-face)
|
||||
('color-tty
|
||||
(gamegrid-make-color-tty-face color))
|
||||
('mono-tty
|
||||
(unless gamegrid-mono-tty-face
|
||||
(setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
|
||||
gamegrid-mono-tty-face))))
|
||||
|
||||
(defun gamegrid-colorize-glyph (color)
|
||||
(make-glyph
|
||||
(vector
|
||||
'xpm
|
||||
:data gamegrid-xpm
|
||||
:color-symbols (list (cons "col1" (gamegrid-color color 0.6))
|
||||
(cons "col2" (gamegrid-color color 0.8))
|
||||
(cons "col3" (gamegrid-color color 1.0))))))
|
||||
|
||||
(defun gamegrid-match-spec (spec)
|
||||
(let ((locale (car spec))
|
||||
(value (cadr spec)))
|
||||
(and (or (eq locale t)
|
||||
(and (listp locale)
|
||||
(memq gamegrid-display-mode locale))
|
||||
(and (symbolp locale)
|
||||
(eq gamegrid-display-mode locale)))
|
||||
value)))
|
||||
|
||||
(defun gamegrid-match-spec-list (spec-list)
|
||||
(and spec-list
|
||||
(or (gamegrid-match-spec (car spec-list))
|
||||
(gamegrid-match-spec-list (cdr spec-list)))))
|
||||
|
||||
(defun gamegrid-make-glyph (data-spec-list color-spec-list)
|
||||
(let ((data (gamegrid-match-spec-list data-spec-list))
|
||||
(color (gamegrid-match-spec-list color-spec-list)))
|
||||
(cond ((gamegrid-characterp data)
|
||||
(vector data))
|
||||
((eq data 'colorize)
|
||||
(gamegrid-colorize-glyph color))
|
||||
((vectorp data)
|
||||
(make-glyph data)))))
|
||||
|
||||
(defun gamegrid-color-display-p ()
|
||||
(if (fboundp 'device-class)
|
||||
(eq (device-class (selected-device)) 'color)
|
||||
(eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))
|
||||
|
||||
(defun gamegrid-display-type ()
|
||||
(let ((window-system-p
|
||||
(or (and (fboundp 'console-on-window-system-p)
|
||||
(console-on-window-system-p))
|
||||
window-system)))
|
||||
(cond ((and gamegrid-use-glyphs
|
||||
window-system-p
|
||||
(featurep 'xpm))
|
||||
'glyph)
|
||||
((and gamegrid-use-color
|
||||
window-system-p
|
||||
(gamegrid-color-display-p))
|
||||
'color-x)
|
||||
(window-system-p
|
||||
'mono-x)
|
||||
((and gamegrid-use-color
|
||||
(gamegrid-color-display-p))
|
||||
'color-tty)
|
||||
((fboundp 'set-face-property)
|
||||
'mono-tty)
|
||||
(t
|
||||
'emacs-tty))))
|
||||
|
||||
(defun gamegrid-set-display-table ()
|
||||
(if (fboundp 'specifierp)
|
||||
(add-spec-to-specifier current-display-table
|
||||
gamegrid-display-table
|
||||
(current-buffer)
|
||||
nil
|
||||
'remove-locale)
|
||||
(setq buffer-display-table gamegrid-display-table)))
|
||||
|
||||
(defun gamegrid-hide-cursor ()
|
||||
(if (fboundp 'specifierp)
|
||||
(set-specifier text-cursor-visible-p nil (current-buffer))))
|
||||
|
||||
(defun gamegrid-setup-default-font ()
|
||||
(cond ((eq gamegrid-display-mode 'glyph)
|
||||
(let* ((font-spec (face-property 'default 'font))
|
||||
(name (font-name font-spec))
|
||||
(max-height nil))
|
||||
(loop for c from 0 to 255 do
|
||||
(let ((glyph (aref gamegrid-display-table c)))
|
||||
(cond ((glyphp glyph)
|
||||
(let ((height (glyph-height glyph)))
|
||||
(if (or (null max-height)
|
||||
(< max-height height))
|
||||
(setq max-height height)))))))
|
||||
(if max-height
|
||||
(while (and (> (font-height font-spec) max-height)
|
||||
(setq name (x-find-smaller-font name)))
|
||||
(add-spec-to-specifier font-spec name (current-buffer))))))))
|
||||
|
||||
(defun gamegrid-initialize-display ()
|
||||
(setq gamegrid-display-mode (gamegrid-display-type))
|
||||
(setq gamegrid-display-table (make-display-table))
|
||||
(setq gamegrid-face-table (make-vector 256 nil))
|
||||
(loop for c from 0 to 255 do
|
||||
(let* ((spec (aref gamegrid-display-options c))
|
||||
(glyph (gamegrid-make-glyph (car spec) (caddr spec)))
|
||||
(face (gamegrid-make-face (cadr spec) (caddr spec))))
|
||||
(aset gamegrid-face-table c face)
|
||||
(aset gamegrid-display-table c glyph)))
|
||||
(gamegrid-setup-default-font)
|
||||
(gamegrid-set-display-table)
|
||||
(gamegrid-hide-cursor))
|
||||
|
||||
|
||||
(defun gamegrid-set-face (c)
|
||||
(unless (eq gamegrid-display-mode 'glyph)
|
||||
(put-text-property (1- (point))
|
||||
(point)
|
||||
'face
|
||||
(aref gamegrid-face-table c))))
|
||||
|
||||
(defun gamegrid-cell-offset (x y)
|
||||
(+ gamegrid-buffer-start
|
||||
(* (1+ gamegrid-buffer-width) y)
|
||||
x))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun gamegrid-get-cell (x y)
|
||||
(char-after (gamegrid-cell-offset x y)))
|
||||
|
||||
(defun gamegrid-set-cell (x y c)
|
||||
(save-excursion
|
||||
(let ((buffer-read-only nil))
|
||||
(goto-char (gamegrid-cell-offset x y))
|
||||
(delete-char 1)
|
||||
(insert-char c 1)
|
||||
(gamegrid-set-face c))))
|
||||
|
||||
(defun gamegrid-init-buffer (width height blank)
|
||||
(setq gamegrid-buffer-width width
|
||||
gamegrid-buffer-height height)
|
||||
(let ((line (concat
|
||||
(make-string width blank)
|
||||
"\n"))
|
||||
(buffer-read-only nil))
|
||||
(erase-buffer)
|
||||
(setq gamegrid-buffer-start (point))
|
||||
(dotimes (i height)
|
||||
(insert-string line))
|
||||
(goto-char (point-min))))
|
||||
|
||||
(defun gamegrid-init (options)
|
||||
(setq buffer-read-only t
|
||||
truncate-lines t
|
||||
gamegrid-display-options options)
|
||||
(buffer-disable-undo (current-buffer))
|
||||
(gamegrid-initialize-display))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun gamegrid-start-timer (period func)
|
||||
(setq gamegrid-timer
|
||||
(if (featurep 'itimer)
|
||||
(start-itimer "Gamegrid"
|
||||
func
|
||||
period
|
||||
period
|
||||
nil
|
||||
t
|
||||
(current-buffer))
|
||||
(run-with-timer period
|
||||
period
|
||||
func
|
||||
(current-buffer)))))
|
||||
|
||||
(defun gamegrid-set-timer (delay)
|
||||
(if gamegrid-timer
|
||||
(if (featurep 'itimer)
|
||||
(set-itimer-restart gamegrid-timer delay)
|
||||
(timer-set-time gamegrid-timer
|
||||
(list (aref gamegrid-timer 1)
|
||||
(aref gamegrid-timer 2)
|
||||
(aref gamegrid-timer 3))
|
||||
delay))))
|
||||
|
||||
(defun gamegrid-kill-timer ()
|
||||
(if gamegrid-timer
|
||||
(if (featurep 'itimer)
|
||||
(delete-itimer gamegrid-timer)
|
||||
(timer-set-time gamegrid-timer '(0 0 0) nil)))
|
||||
(setq gamegrid-timer nil))
|
||||
|
||||
;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun gamegrid-add-score (file score)
|
||||
"Add the current score to the high score file."
|
||||
(save-excursion
|
||||
(find-file-other-window file)
|
||||
(setq buffer-read-only nil)
|
||||
(goto-char (point-max))
|
||||
(insert (format "%05d\t%s\t%s <%s>\n"
|
||||
score
|
||||
(current-time-string)
|
||||
(user-full-name)
|
||||
(cond ((fboundp 'user-mail-address)
|
||||
(user-mail-address))
|
||||
((boundp 'user-mail-address)
|
||||
user-mail-address)
|
||||
(t ""))))
|
||||
(sort-numeric-fields 1 (point-min) (point-max))
|
||||
(reverse-region (point-min) (point-max))
|
||||
(goto-line (1+ gamegrid-score-file-length))
|
||||
(delete-region (point) (point-max))
|
||||
(setq buffer-read-only t)
|
||||
(save-buffer)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(provide 'gamegrid)
|
||||
600
lisp/play/tetris.el
Normal file
600
lisp/play/tetris.el
Normal file
|
|
@ -0,0 +1,600 @@
|
|||
;;; tetris.el -- Implementation of Tetris for Emacs
|
||||
|
||||
;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Glynn Clements <glynn@sensei.co.uk>
|
||||
;; Version: 2.01
|
||||
;; Created: 1997-08-13
|
||||
;; Keywords: games
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
(eval-when-compile
|
||||
(require 'cl))
|
||||
|
||||
(require 'gamegrid)
|
||||
|
||||
;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar tetris-use-glyphs t
|
||||
"Non-nil means use glyphs when available.")
|
||||
|
||||
(defvar tetris-use-color t
|
||||
"Non-nil means use color when available.")
|
||||
|
||||
(defvar tetris-draw-border-with-glyphs t
|
||||
"Non-nil means draw a border even when using glyphs.")
|
||||
|
||||
(defvar tetris-default-tick-period 0.3
|
||||
"The default time taken for a shape to drop one row.")
|
||||
|
||||
(defvar tetris-update-speed-function
|
||||
'tetris-default-update-speed-function
|
||||
"Function run whenever the Tetris score changes
|
||||
Called with two arguments: (SHAPES ROWS)
|
||||
SHAPES is the number of shapes which have been dropped
|
||||
ROWS is the number of rows which have been completed
|
||||
|
||||
If the return value is a number, it is used as the timer period.")
|
||||
|
||||
(defvar tetris-mode-hook nil
|
||||
"Hook run upon starting Tetris.")
|
||||
|
||||
(defvar tetris-tty-colors
|
||||
[nil "blue" "white" "yellow" "magenta" "cyan" "green" "red"]
|
||||
"Vector of colors of the various shapes in text mode
|
||||
Element 0 is ignored.")
|
||||
|
||||
(defvar tetris-x-colors
|
||||
[nil [0 0 1] [0.7 0 1] [1 1 0] [1 0 1] [0 1 1] [0 1 0] [1 0 0]]
|
||||
"Vector of colors of the various shapes
|
||||
Element 0 is ignored.")
|
||||
|
||||
(defvar tetris-buffer-name "*Tetris*"
|
||||
"Name used for Tetris buffer.")
|
||||
|
||||
(defvar tetris-buffer-width 30
|
||||
"Width of used portion of buffer.")
|
||||
|
||||
(defvar tetris-buffer-height 22
|
||||
"Height of used portion of buffer.")
|
||||
|
||||
(defvar tetris-width 10
|
||||
"Width of playing area.")
|
||||
|
||||
(defvar tetris-height 20
|
||||
"Height of playing area.")
|
||||
|
||||
(defvar tetris-top-left-x 3
|
||||
"X position of top left of playing area.")
|
||||
|
||||
(defvar tetris-top-left-y 1
|
||||
"Y position of top left of playing area.")
|
||||
|
||||
(defvar tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width)
|
||||
"X position of next shape.")
|
||||
|
||||
(defvar tetris-next-y tetris-top-left-y
|
||||
"Y position of next shape.")
|
||||
|
||||
(defvar tetris-score-x tetris-next-x
|
||||
"X position of score.")
|
||||
|
||||
(defvar tetris-score-y (+ tetris-next-y 6)
|
||||
"Y position of score.")
|
||||
|
||||
(defvar tetris-score-file "/tmp/tetris-scores"
|
||||
;; anybody with a well-connected server want to host this?
|
||||
;(defvar tetris-score-file "/anonymous@ftp.pgt.com:/pub/cgw/tetris-scores"
|
||||
"File for holding high scores.")
|
||||
|
||||
;; ;;;;;;;;;;;;; display options ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar tetris-border-options
|
||||
'(((glyph colorize)
|
||||
(t ?\+))
|
||||
((color-x color-x)
|
||||
(mono-x grid-x)
|
||||
(t nil))
|
||||
(((glyph color-x) [0.5 0.5 0.5])
|
||||
(t nil))))
|
||||
|
||||
(defvar tetris-blank-options
|
||||
'(((glyph colorize)
|
||||
(t ?\040))
|
||||
((color-x color-x)
|
||||
(mono-x grid-x)
|
||||
(color-tty color-tty)
|
||||
(t nil))
|
||||
(((glyph color-x) [0 0 0])
|
||||
(color-tty "black")
|
||||
(t nil))))
|
||||
|
||||
(defvar tetris-cell-options
|
||||
'(((glyph colorize)
|
||||
(emacs-tty ?O)
|
||||
(t ?\040))
|
||||
((color-x color-x)
|
||||
(mono-x mono-x)
|
||||
(color-tty color-tty)
|
||||
(mono-tty mono-tty)
|
||||
(t nil))
|
||||
;; color information is taken from tetris-x-colors and tetris-tty-colors
|
||||
))
|
||||
|
||||
(defvar tetris-space-options
|
||||
'(((t ?\040))
|
||||
nil
|
||||
nil))
|
||||
|
||||
;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defconst tetris-shapes
|
||||
[[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
|
||||
[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
|
||||
[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]
|
||||
[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
|
||||
|
||||
[[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]]
|
||||
[[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]]
|
||||
[[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]]
|
||||
[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
|
||||
|
||||
[[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]]
|
||||
[[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]]
|
||||
[[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]]
|
||||
[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
|
||||
|
||||
[[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]]
|
||||
[[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]]
|
||||
[[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]]
|
||||
[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
|
||||
|
||||
[[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]]
|
||||
[[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]]
|
||||
[[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]]
|
||||
[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
|
||||
|
||||
[[[0 6 0 0] [6 0 0 0] [6 6 6 0] [0 6 0 0]]
|
||||
[[6 6 6 0] [6 6 0 0] [0 6 0 0] [6 6 0 0]]
|
||||
[[0 0 0 0] [6 0 0 0] [0 0 0 0] [0 6 0 0]]
|
||||
[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
|
||||
|
||||
[[[7 7 7 7] [7 0 0 0] [7 7 7 7] [7 0 0 0]]
|
||||
[[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
|
||||
[[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
|
||||
[[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]]])
|
||||
|
||||
;;the scoring rules were taken from "xtetris". Blocks score differently
|
||||
;;depending on their rotation
|
||||
|
||||
(defconst tetris-shape-scores
|
||||
[ [6 6 6 6] [6 7 6 7] [6 7 6 7] [6 7 6 7] [6 7 6 7] [5 5 6 5] [5 8 5 8]] )
|
||||
|
||||
(defconst tetris-shape-dimensions
|
||||
[[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]])
|
||||
|
||||
(defconst tetris-blank 0)
|
||||
|
||||
(defconst tetris-border 8)
|
||||
|
||||
(defconst tetris-space 9)
|
||||
|
||||
(defun tetris-default-update-speed-function (shapes rows)
|
||||
(/ 20.0 (+ 50.0 rows)))
|
||||
|
||||
;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar tetris-shape 0)
|
||||
(defvar tetris-rot 0)
|
||||
(defvar tetris-next-shape 0)
|
||||
(defvar tetris-n-shapes 0)
|
||||
(defvar tetris-n-rows 0)
|
||||
(defvar tetris-score 0)
|
||||
(defvar tetris-pos-x 0)
|
||||
(defvar tetris-pos-y 0)
|
||||
(defvar tetris-paused nil)
|
||||
|
||||
(make-variable-buffer-local 'tetris-shape)
|
||||
(make-variable-buffer-local 'tetris-rot)
|
||||
(make-variable-buffer-local 'tetris-next-shape)
|
||||
(make-variable-buffer-local 'tetris-n-shapes)
|
||||
(make-variable-buffer-local 'tetris-n-rows)
|
||||
(make-variable-buffer-local 'tetris-score)
|
||||
(make-variable-buffer-local 'tetris-pos-x)
|
||||
(make-variable-buffer-local 'tetris-pos-y)
|
||||
(make-variable-buffer-local 'tetris-paused)
|
||||
|
||||
;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar tetris-mode-map
|
||||
(make-sparse-keymap 'tetris-mode-map))
|
||||
|
||||
(define-key tetris-mode-map "n" 'tetris-start-game)
|
||||
(define-key tetris-mode-map "q" 'tetris-end-game)
|
||||
(define-key tetris-mode-map "p" 'tetris-pause-game)
|
||||
|
||||
(define-key tetris-mode-map " " 'tetris-move-bottom)
|
||||
(define-key tetris-mode-map [left] 'tetris-move-left)
|
||||
(define-key tetris-mode-map [right] 'tetris-move-right)
|
||||
(define-key tetris-mode-map [up] 'tetris-rotate-prev)
|
||||
(define-key tetris-mode-map [down] 'tetris-rotate-next)
|
||||
|
||||
(defvar tetris-null-map
|
||||
(make-sparse-keymap 'tetris-null-map))
|
||||
|
||||
(define-key tetris-null-map "n" 'tetris-start-game)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun tetris-display-options ()
|
||||
(let ((options (make-vector 256 nil)))
|
||||
(loop for c from 0 to 255 do
|
||||
(aset options c
|
||||
(cond ((= c tetris-blank)
|
||||
tetris-blank-options)
|
||||
((and (>= c 1) (<= c 7))
|
||||
(append
|
||||
tetris-cell-options
|
||||
`((((glyph color-x) ,(aref tetris-x-colors c))
|
||||
(color-tty ,(aref tetris-tty-colors c))
|
||||
(t nil)))))
|
||||
((= c tetris-border)
|
||||
tetris-border-options)
|
||||
((= c tetris-space)
|
||||
tetris-space-options)
|
||||
(t
|
||||
'(nil nil nil)))))
|
||||
options))
|
||||
|
||||
(defun tetris-get-tick-period ()
|
||||
(if (boundp 'tetris-update-speed-function)
|
||||
(let ((period (apply tetris-update-speed-function
|
||||
tetris-n-shapes
|
||||
tetris-n-rows nil)))
|
||||
(and (numberp period) period))))
|
||||
|
||||
(defun tetris-get-shape-cell (x y)
|
||||
(aref (aref (aref (aref tetris-shapes
|
||||
tetris-shape)
|
||||
y)
|
||||
tetris-rot)
|
||||
x))
|
||||
|
||||
(defun tetris-shape-width ()
|
||||
(aref (aref tetris-shape-dimensions tetris-shape)
|
||||
(% tetris-rot 2)))
|
||||
|
||||
(defun tetris-shape-height ()
|
||||
(aref (aref tetris-shape-dimensions tetris-shape)
|
||||
(- 1 (% tetris-rot 2))))
|
||||
|
||||
(defun tetris-draw-score ()
|
||||
(let ((strings (vector (format "Shapes: %05d" tetris-n-shapes)
|
||||
(format "Rows: %05d" tetris-n-rows)
|
||||
(format "Score: %05d" tetris-score))))
|
||||
(loop for y from 0 to 2 do
|
||||
(let* ((string (aref strings y))
|
||||
(len (length string)))
|
||||
(loop for x from 0 to (1- len) do
|
||||
(gamegrid-set-cell (+ tetris-score-x x)
|
||||
(+ tetris-score-y y)
|
||||
(aref string x)))))))
|
||||
|
||||
(defun tetris-update-score ()
|
||||
(tetris-draw-score)
|
||||
(let ((period (tetris-get-tick-period)))
|
||||
(if period (gamegrid-set-timer period))))
|
||||
|
||||
(defun tetris-new-shape ()
|
||||
(setq tetris-shape tetris-next-shape)
|
||||
(setq tetris-rot 0)
|
||||
(setq tetris-next-shape (random 7))
|
||||
(setq tetris-pos-x (/ (- tetris-width (tetris-shape-width)) 2))
|
||||
(setq tetris-pos-y 0)
|
||||
(if (tetris-test-shape)
|
||||
(tetris-end-game)
|
||||
(tetris-draw-shape))
|
||||
(tetris-draw-next-shape)
|
||||
(tetris-update-score))
|
||||
|
||||
(defun tetris-draw-next-shape ()
|
||||
(loop for y from 0 to 3 do
|
||||
(loop for x from 0 to 3 do
|
||||
(gamegrid-set-cell (+ tetris-next-x x)
|
||||
(+ tetris-next-y y)
|
||||
(let ((tetris-shape tetris-next-shape)
|
||||
(tetris-rot 0))
|
||||
(tetris-get-shape-cell x y))))))
|
||||
|
||||
(defun tetris-draw-shape ()
|
||||
(loop for y from 0 to (1- (tetris-shape-height)) do
|
||||
(loop for x from 0 to (1- (tetris-shape-width)) do
|
||||
(let ((c (tetris-get-shape-cell x y)))
|
||||
(if (/= c tetris-blank)
|
||||
(gamegrid-set-cell (+ tetris-top-left-x
|
||||
tetris-pos-x
|
||||
x)
|
||||
(+ tetris-top-left-y
|
||||
tetris-pos-y
|
||||
y)
|
||||
c))))))
|
||||
|
||||
(defun tetris-erase-shape ()
|
||||
(loop for y from 0 to (1- (tetris-shape-height)) do
|
||||
(loop for x from 0 to (1- (tetris-shape-width)) do
|
||||
(let ((c (tetris-get-shape-cell x y))
|
||||
(px (+ tetris-top-left-x tetris-pos-x x))
|
||||
(py (+ tetris-top-left-y tetris-pos-y y)))
|
||||
(if (/= c tetris-blank)
|
||||
(gamegrid-set-cell px py tetris-blank))))))
|
||||
|
||||
(defun tetris-test-shape ()
|
||||
(let ((hit nil))
|
||||
(loop for y from 0 to (1- (tetris-shape-height)) do
|
||||
(loop for x from 0 to (1- (tetris-shape-width)) do
|
||||
(unless hit
|
||||
(setq hit
|
||||
(let* ((c (tetris-get-shape-cell x y))
|
||||
(xx (+ tetris-pos-x x))
|
||||
(yy (+ tetris-pos-y y))
|
||||
(px (+ tetris-top-left-x xx))
|
||||
(py (+ tetris-top-left-y yy)))
|
||||
(and (/= c tetris-blank)
|
||||
(or (>= xx tetris-width)
|
||||
(>= yy tetris-height)
|
||||
(/= (gamegrid-get-cell px py)
|
||||
tetris-blank))))))))
|
||||
hit))
|
||||
|
||||
(defun tetris-full-row (y)
|
||||
(let ((full t))
|
||||
(loop for x from 0 to (1- tetris-width) do
|
||||
(if (= (gamegrid-get-cell (+ tetris-top-left-x x)
|
||||
(+ tetris-top-left-y y))
|
||||
tetris-blank)
|
||||
(setq full nil)))
|
||||
full))
|
||||
|
||||
(defun tetris-shift-row (y)
|
||||
(if (= y 0)
|
||||
(loop for x from 0 to (1- tetris-width) do
|
||||
(gamegrid-set-cell (+ tetris-top-left-x x)
|
||||
(+ tetris-top-left-y y)
|
||||
tetris-blank))
|
||||
(loop for x from 0 to (1- tetris-width) do
|
||||
(let ((c (gamegrid-get-cell (+ tetris-top-left-x x)
|
||||
(+ tetris-top-left-y y -1))))
|
||||
(gamegrid-set-cell (+ tetris-top-left-x x)
|
||||
(+ tetris-top-left-y y)
|
||||
c)))))
|
||||
|
||||
(defun tetris-shift-down ()
|
||||
(loop for y0 from 0 to (1- tetris-height) do
|
||||
(if (tetris-full-row y0)
|
||||
(progn (setq tetris-n-rows (1+ tetris-n-rows))
|
||||
(loop for y from y0 downto 0 do
|
||||
(tetris-shift-row y))))))
|
||||
|
||||
(defun tetris-draw-border-p ()
|
||||
(or (not (eq gamegrid-display-mode 'glyph))
|
||||
tetris-draw-border-with-glyphs))
|
||||
|
||||
(defun tetris-init-buffer ()
|
||||
(gamegrid-init-buffer tetris-buffer-width
|
||||
tetris-buffer-height
|
||||
tetris-space)
|
||||
(let ((buffer-read-only nil))
|
||||
(if (tetris-draw-border-p)
|
||||
(loop for y from -1 to tetris-height do
|
||||
(loop for x from -1 to tetris-width do
|
||||
(gamegrid-set-cell (+ tetris-top-left-x x)
|
||||
(+ tetris-top-left-y y)
|
||||
tetris-border))))
|
||||
(loop for y from 0 to (1- tetris-height) do
|
||||
(loop for x from 0 to (1- tetris-width) do
|
||||
(gamegrid-set-cell (+ tetris-top-left-x x)
|
||||
(+ tetris-top-left-y y)
|
||||
tetris-blank)))
|
||||
(if (tetris-draw-border-p)
|
||||
(loop for y from -1 to 4 do
|
||||
(loop for x from -1 to 4 do
|
||||
(gamegrid-set-cell (+ tetris-next-x x)
|
||||
(+ tetris-next-y y)
|
||||
tetris-border))))))
|
||||
|
||||
(defun tetris-reset-game ()
|
||||
(gamegrid-kill-timer)
|
||||
(tetris-init-buffer)
|
||||
(setq tetris-next-shape (random 7))
|
||||
(setq tetris-shape 0
|
||||
tetris-rot 0
|
||||
tetris-pos-x 0
|
||||
tetris-pos-y 0
|
||||
tetris-n-shapes 0
|
||||
tetris-n-rows 0
|
||||
tetris-score 0
|
||||
tetris-paused nil)
|
||||
(tetris-new-shape))
|
||||
|
||||
(defun tetris-shape-done ()
|
||||
(tetris-shift-down)
|
||||
(setq tetris-n-shapes (1+ tetris-n-shapes))
|
||||
(setq tetris-score
|
||||
(+ tetris-score
|
||||
(aref (aref tetris-shape-scores tetris-shape) tetris-rot)))
|
||||
(tetris-update-score)
|
||||
(tetris-new-shape))
|
||||
|
||||
(defun tetris-update-game (tetris-buffer)
|
||||
"Called on each clock tick.
|
||||
Drops the shape one square, testing for collision."
|
||||
(if (and (not tetris-paused)
|
||||
(eq (current-buffer) tetris-buffer))
|
||||
(let (hit)
|
||||
(tetris-erase-shape)
|
||||
(setq tetris-pos-y (1+ tetris-pos-y))
|
||||
(setq hit (tetris-test-shape))
|
||||
(if hit
|
||||
(setq tetris-pos-y (1- tetris-pos-y)))
|
||||
(tetris-draw-shape)
|
||||
(if hit
|
||||
(tetris-shape-done)))))
|
||||
|
||||
(defun tetris-move-bottom ()
|
||||
"Drops the shape to the bottom of the playing area"
|
||||
(interactive)
|
||||
(let ((hit nil))
|
||||
(tetris-erase-shape)
|
||||
(while (not hit)
|
||||
(setq tetris-pos-y (1+ tetris-pos-y))
|
||||
(setq hit (tetris-test-shape)))
|
||||
(setq tetris-pos-y (1- tetris-pos-y))
|
||||
(tetris-draw-shape)
|
||||
(tetris-shape-done)))
|
||||
|
||||
(defun tetris-move-left ()
|
||||
"Moves the shape one square to the left"
|
||||
(interactive)
|
||||
(unless (= tetris-pos-x 0)
|
||||
(tetris-erase-shape)
|
||||
(setq tetris-pos-x (1- tetris-pos-x))
|
||||
(if (tetris-test-shape)
|
||||
(setq tetris-pos-x (1+ tetris-pos-x)))
|
||||
(tetris-draw-shape)))
|
||||
|
||||
(defun tetris-move-right ()
|
||||
"Moves the shape one square to the right"
|
||||
(interactive)
|
||||
(unless (= (+ tetris-pos-x (tetris-shape-width))
|
||||
tetris-width)
|
||||
(tetris-erase-shape)
|
||||
(setq tetris-pos-x (1+ tetris-pos-x))
|
||||
(if (tetris-test-shape)
|
||||
(setq tetris-pos-x (1- tetris-pos-x)))
|
||||
(tetris-draw-shape)))
|
||||
|
||||
(defun tetris-rotate-prev ()
|
||||
"Rotates the shape clockwise"
|
||||
(interactive)
|
||||
(tetris-erase-shape)
|
||||
(setq tetris-rot (% (+ 1 tetris-rot) 4))
|
||||
(if (tetris-test-shape)
|
||||
(setq tetris-rot (% (+ 3 tetris-rot) 4)))
|
||||
(tetris-draw-shape))
|
||||
|
||||
(defun tetris-rotate-next ()
|
||||
"Rotates the shape anticlockwise"
|
||||
(interactive)
|
||||
(tetris-erase-shape)
|
||||
(setq tetris-rot (% (+ 3 tetris-rot) 4))
|
||||
(if (tetris-test-shape)
|
||||
(setq tetris-rot (% (+ 1 tetris-rot) 4)))
|
||||
(tetris-draw-shape))
|
||||
|
||||
(defun tetris-end-game ()
|
||||
"Terminates the current game"
|
||||
(interactive)
|
||||
(gamegrid-kill-timer)
|
||||
(use-local-map tetris-null-map)
|
||||
(gamegrid-add-score tetris-score-file tetris-score))
|
||||
|
||||
(defun tetris-start-game ()
|
||||
"Starts a new game of Tetris"
|
||||
(interactive)
|
||||
(tetris-reset-game)
|
||||
(use-local-map tetris-mode-map)
|
||||
(let ((period (or (tetris-get-tick-period)
|
||||
tetris-default-tick-period)))
|
||||
(gamegrid-start-timer period 'tetris-update-game)))
|
||||
|
||||
(defun tetris-pause-game ()
|
||||
"Pauses (or resumes) the current game"
|
||||
(interactive)
|
||||
(setq tetris-paused (not tetris-paused))
|
||||
(message (and tetris-paused "Game paused (press p to resume)")))
|
||||
|
||||
(defun tetris-active-p ()
|
||||
(eq (current-local-map) tetris-mode-map))
|
||||
|
||||
(put 'tetris-mode 'mode-class 'special)
|
||||
|
||||
(defun tetris-mode ()
|
||||
"A mode for playing Tetris.
|
||||
|
||||
tetris-mode keybindings:
|
||||
\\{tetris-mode-map}
|
||||
"
|
||||
(kill-all-local-variables)
|
||||
|
||||
(make-local-hook 'kill-buffer-hook)
|
||||
(add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
|
||||
|
||||
(use-local-map tetris-null-map)
|
||||
|
||||
(setq major-mode 'tetris-mode)
|
||||
(setq mode-name "Tetris")
|
||||
|
||||
(setq mode-popup-menu
|
||||
'("Tetris Commands"
|
||||
["Start new game" tetris-start-game]
|
||||
["End game" tetris-end-game
|
||||
(tetris-active-p)]
|
||||
["Pause" tetris-pause-game
|
||||
(and (tetris-active-p) (not tetris-paused))]
|
||||
["Resume" tetris-pause-game
|
||||
(and (tetris-active-p) tetris-paused)]))
|
||||
|
||||
(setq gamegrid-use-glyphs tetris-use-glyphs)
|
||||
(setq gamegrid-use-color tetris-use-color)
|
||||
|
||||
(gamegrid-init (tetris-display-options))
|
||||
|
||||
(run-hooks 'tetris-mode-hook))
|
||||
|
||||
;;;###autoload
|
||||
(defun tetris ()
|
||||
"Play the Tetris game.
|
||||
Shapes drop from the top of the screen, and the user has to move and
|
||||
rotate the shape to fit in with those at the bottom of the screen so
|
||||
as to form complete rows.
|
||||
|
||||
tetris-mode keybindings:
|
||||
\\<tetris-mode-map>
|
||||
\\[tetris-start-game] Starts a new game of Tetris
|
||||
\\[tetris-end-game] Terminates the current game
|
||||
\\[tetris-pause-game] Pauses (or resumes) the current game
|
||||
\\[tetris-move-left] Moves the shape one square to the left
|
||||
\\[tetris-move-right] Moves the shape one square to the right
|
||||
\\[tetris-rotate-prev] Rotates the shape clockwise
|
||||
\\[tetris-rotate-next] Rotates the shape anticlockwise
|
||||
\\[tetris-move-bottom] Drops the shape to the bottom of the playing area
|
||||
|
||||
"
|
||||
(interactive)
|
||||
|
||||
(switch-to-buffer tetris-buffer-name)
|
||||
(gamegrid-kill-timer)
|
||||
(tetris-mode)
|
||||
(tetris-start-game))
|
||||
|
||||
(provide 'tetris)
|
||||
|
||||
;;; tetris.el ends here
|
||||
Loading…
Add table
Add a link
Reference in a new issue