Return to life.el CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp

Annotation of 43BSDReno/contrib/emacs-18.55/lisp/life.el, revision 1.1

1.1     ! root        1: ;; Conway's `Life' for GNU Emacs
        !             2: ;; Copyright (C) 1988 Free Software Foundation, Inc.
        !             3: ;; Contributed by Kyle Jones, [email protected]
        !             4: 
        !             5: ;; This file is part of GNU Emacs.
        !             6: 
        !             7: ;; GNU Emacs is distributed in the hope that it will be useful,
        !             8: ;; but WITHOUT ANY WARRANTY.  No author or distributor
        !             9: ;; accepts responsibility to anyone for the consequences of using it
        !            10: ;; or for whether it serves any particular purpose or works at all,
        !            11: ;; unless he says so in writing.  Refer to the GNU Emacs General Public
        !            12: ;; License for full details.
        !            13: 
        !            14: ;; Everyone is granted permission to copy, modify and redistribute
        !            15: ;; GNU Emacs, but only under the conditions described in the
        !            16: ;; GNU Emacs General Public License.   A copy of this license is
        !            17: ;; supposed to have been given to you along with GNU Emacs so you
        !            18: ;; can know your rights and responsibilities.  It should be in a
        !            19: ;; file named COPYING.  Among other things, the copyright notice
        !            20: ;; and this notice must be preserved on all copies.
        !            21: 
        !            22: (provide 'life)
        !            23: 
        !            24: (defconst life-patterns
        !            25:   [("@@@" " @@" "@@@")
        !            26:    ("@@@ @@@" "@@  @@ " "@@@ @@@")
        !            27:    ("@@@ @@@" "@@   @@" "@@@ @@@")
        !            28:    ("@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")
        !            29:    ("@@@@@@@@@@")
        !            30:    ("   @@@@@@@@@@       "
        !            31:     "     @@@@@@@@@@     "
        !            32:     "       @@@@@@@@@@   "
        !            33:     "@@@@@@@@@@          "
        !            34:     "@@@@@@@@@@          ")
        !            35:    ("@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@")
        !            36:    ("@               @" "@               @"  "@               @"
        !            37:     "@               @" "@               @"  "@               @"
        !            38:     "@               @" "@               @"  "@               @"
        !            39:     "@               @" "@               @"  "@               @"
        !            40:     "@               @" "@               @"  "@               @")
        !            41:    ("@@               " " @@              " "  @@             "
        !            42:     "   @@            " "    @@           " "     @@          "
        !            43:     "      @@         " "       @@        " "        @@       "
        !            44:     "         @@      " "          @@     " "           @@    "
        !            45:     "            @@   " "             @@  " "              @@ "
        !            46:     "               @@")
        !            47:    ("@@@@@@@@@" "@   @   @" "@ @@@@@ @" "@ @   @ @" "@@@   @@@" 
        !            48:     "@ @   @ @" "@ @@@@@ @" "@   @   @" "@@@@@@@@@")]
        !            49:   "Vector of rectangles containing some Life startup patterns.")
        !            50: 
        !            51: ;; Macros are used macros for manifest constants instead of variables
        !            52: ;; because the compiler will convert them to constants, which should
        !            53: ;; eval faster than symbols.
        !            54: ;;
        !            55: ;; The (require) wrapping forces the compiler to eval these macros at
        !            56: ;; compile time.  This would not be necessary if we did not use macros
        !            57: ;; inside of macros, which the compiler doesn't seem to check for.
        !            58: ;;
        !            59: ;; Don't change any of the life-* macro constants unless you thoroughly
        !            60: ;; understand the `life-grim-reaper' function.
        !            61: (require
        !            62:  (progn
        !            63:    (defmacro life-life-char () ?@)
        !            64:    (defmacro life-death-char () (1+ (life-life-char)))
        !            65:    (defmacro life-birth-char () 3)
        !            66:    (defmacro life-void-char () ?\ )
        !            67: 
        !            68:    (defmacro life-life-string () (char-to-string (life-life-char)))
        !            69:    (defmacro life-death-string () (char-to-string (life-death-char)))
        !            70:    (defmacro life-birth-string () (char-to-string (life-birth-char)))
        !            71:    (defmacro life-void-string () (char-to-string (life-void-char)))
        !            72:    (defmacro life-not-void-regexp () (concat "[^" (life-void-string) "\n]"))
        !            73: 
        !            74:    ;; try to optimize the (goto-char (point-min)) & (goto-char (point-max))
        !            75:    ;; idioms.  This depends on goto-char's not griping if we underrshoot
        !            76:    ;; or overshoot beginning or end of buffer.
        !            77:    (defmacro goto-beginning-of-buffer () '(goto-char 1))
        !            78:    (defmacro maxint () (lsh (lsh (lognot 0) 1) -1))
        !            79:    (defmacro goto-end-of-buffer () '(goto-char (maxint)))
        !            80: 
        !            81:    (defmacro increment (variable) (list 'setq variable (list '1+ variable)))
        !            82:    'life))
        !            83: 
        !            84: ;; list of numbers that tell how many characters to move to get to
        !            85: ;; each of a cell's eight neighbors.
        !            86: (defconst life-neighbor-deltas nil)
        !            87: 
        !            88: ;; window display always starts here.  Easier to deal with than
        !            89: ;; (scroll-up) and (scroll-down) when trying to center the display.
        !            90: (defconst life-window-start nil)
        !            91: 
        !            92: ;; For mode line
        !            93: (defconst life-current-generation nil)
        !            94: ;; Sadly, mode-line-format won't display numbers.
        !            95: (defconst life-generation-string nil)
        !            96: 
        !            97: (defun abs (n) (if (< n 0) (- n) n))
        !            98: 
        !            99: (defun life (&optional sleeptime)
        !           100:   "Run Conway's Life simulation.
        !           101: The starting pattern is randomly selected.  Prefix arg (optional first arg
        !           102: non-nil from a program) is the number of seconds to sleep between
        !           103: generations (this defaults to 1)."
        !           104:   (interactive "p")
        !           105:   (or sleeptime (setq sleeptime 1))
        !           106:   (life-setup)
        !           107:   (life-display-generation sleeptime)
        !           108:   (while t
        !           109:     (let ((inhibit-quit t))
        !           110:       (life-grim-reaper)
        !           111:       (life-expand-plane-if-needed)
        !           112:       (life-increment-generation)
        !           113:       (life-display-generation sleeptime))))
        !           114: 
        !           115: (fset 'life-mode 'life)
        !           116: (put 'life-mode 'mode-class 'special)
        !           117: 
        !           118: (random t)
        !           119: 
        !           120: (defun life-setup ()
        !           121:   (let (n)
        !           122:     (switch-to-buffer (get-buffer-create "*Life*") t)
        !           123:     (erase-buffer)
        !           124:     (kill-all-local-variables)
        !           125:     (setq case-fold-search nil
        !           126:          mode-name "Life"
        !           127:          major-mode 'life-mode
        !           128:          truncate-lines t
        !           129:          life-current-generation 0
        !           130:          life-generation-string "0"
        !           131:          mode-line-buffer-identification '("Life: generation "
        !           132:                                            life-generation-string)
        !           133:          fill-column (1- (window-width))
        !           134:          life-window-start 1)
        !           135:     (buffer-flush-undo (current-buffer))
        !           136:     ;; stuff in the random pattern
        !           137:     (life-insert-random-pattern)
        !           138:     ;; make sure (life-life-char) is used throughout
        !           139:     (goto-beginning-of-buffer)
        !           140:     (while (re-search-forward (life-not-void-regexp) nil t)
        !           141:       (replace-match (life-life-string) t t))
        !           142:     ;; center the pattern horizontally
        !           143:     (goto-beginning-of-buffer)
        !           144:     (setq n (/ (- fill-column (save-excursion (end-of-line) (point))) 2))
        !           145:     (while (not (eobp))
        !           146:       (indent-to n)
        !           147:       (forward-line))
        !           148:     ;; center the pattern vertically
        !           149:     (setq n (/ (- (1- (window-height))
        !           150:                  (count-lines (point-min) (point-max)))
        !           151:               2))
        !           152:     (goto-beginning-of-buffer)
        !           153:     (newline n)
        !           154:     (goto-end-of-buffer)
        !           155:     (newline n)
        !           156:     ;; pad lines out to fill-column
        !           157:     (goto-beginning-of-buffer)
        !           158:     (while (not (eobp))
        !           159:       (end-of-line)
        !           160:       (indent-to fill-column)
        !           161:       (move-to-column fill-column)
        !           162:       (delete-region (point) (progn (end-of-line) (point)))
        !           163:       (forward-line))
        !           164:     ;; expand tabs to spaces
        !           165:     (untabify (point-min) (point-max))
        !           166:     ;; before starting be sure the automaton has room to grow
        !           167:     (life-expand-plane-if-needed)
        !           168:     ;; compute initial neighbor deltas
        !           169:     (life-compute-neighbor-deltas)))
        !           170: 
        !           171: (defun life-compute-neighbor-deltas ()
        !           172:   (setq life-neighbor-deltas
        !           173:        (list -1 (- fill-column)
        !           174:              (- (1+ fill-column)) (- (+ 2 fill-column))
        !           175:              1 fill-column (1+ fill-column)
        !           176:              (+ 2 fill-column))))
        !           177: 
        !           178: (defun life-insert-random-pattern ()
        !           179:   (insert-rectangle
        !           180:    (elt life-patterns (% (abs (random)) (length life-patterns))))
        !           181:   (insert ?\n))
        !           182: 
        !           183: (defun life-increment-generation ()
        !           184:   (increment life-current-generation)
        !           185:   (setq life-generation-string (int-to-string life-current-generation)))
        !           186: 
        !           187: (defun life-grim-reaper ()
        !           188:   ;; Clear the match information.  Later we check to see if it
        !           189:   ;; is still clear, if so then all the cells have died.
        !           190:   (store-match-data nil)
        !           191:   (goto-beginning-of-buffer)
        !           192:   ;; For speed declare all local variable outside the loop.
        !           193:   (let (point char pivot living-neighbors list)
        !           194:     (while (search-forward (life-life-string) nil t)
        !           195:       (setq list life-neighbor-deltas
        !           196:            living-neighbors 0
        !           197:            pivot (1- (point)))
        !           198:       (while list
        !           199:        (setq point (+ pivot (car list))
        !           200:              char (char-after point))
        !           201:        (cond ((eq char (life-void-char))
        !           202:               (subst-char-in-region point (1+ point)
        !           203:                                     (life-void-char) 1 t))
        !           204:              ((< char 3)
        !           205:               (subst-char-in-region point (1+ point) char (1+ char) t))
        !           206:              ((< char 9)
        !           207:               (subst-char-in-region point (1+ point) char 9 t))
        !           208:              ((>= char (life-life-char))
        !           209:               (increment living-neighbors)))
        !           210:        (setq list (cdr list)))
        !           211:       (if (memq living-neighbors '(2 3))
        !           212:          ()
        !           213:        (subst-char-in-region pivot (1+ pivot)
        !           214:                            (life-life-char) (life-death-char) t))))
        !           215:   (if (null (match-beginning 0))
        !           216:       (life-extinct-quit))
        !           217:   (subst-char-in-region 1 (point-max) 9 (life-void-char) t)
        !           218:   (subst-char-in-region 1 (point-max) 1 (life-void-char) t)
        !           219:   (subst-char-in-region 1 (point-max) 2 (life-void-char) t)
        !           220:   (subst-char-in-region 1 (point-max) (life-birth-char) (life-life-char) t)
        !           221:   (subst-char-in-region 1 (point-max) (life-death-char) (life-void-char) t))
        !           222: 
        !           223: (defun life-expand-plane-if-needed ()
        !           224:   (catch 'done
        !           225:     (goto-beginning-of-buffer)
        !           226:     (while (not (eobp))
        !           227:       ;; check for life at beginning or end of line.  If found at
        !           228:       ;; either end, expand at both ends,
        !           229:       (cond ((or (eq (following-char) (life-life-char))
        !           230:                 (eq (progn (end-of-line) (preceding-char)) (life-life-char)))
        !           231:             (goto-beginning-of-buffer)
        !           232:             (while (not (eobp))
        !           233:               (insert (life-void-char))
        !           234:               (end-of-line)
        !           235:               (insert (life-void-char))
        !           236:               (forward-char))
        !           237:           (setq fill-column (+ 2 fill-column))
        !           238:           (scroll-left 1)
        !           239:           (life-compute-neighbor-deltas)
        !           240:           (throw 'done t)))
        !           241:       (forward-line)))
        !           242:   (goto-beginning-of-buffer)
        !           243:   ;; check for life within the first two lines of the buffer.
        !           244:   ;; If present insert two lifeless lines at the beginning..
        !           245:   (cond ((search-forward (life-life-string)
        !           246:                         (+ (point) fill-column fill-column 2) t)
        !           247:         (goto-beginning-of-buffer)
        !           248:         (insert-char (life-void-char) fill-column)
        !           249:         (insert ?\n)
        !           250:         (insert-char (life-void-char) fill-column)
        !           251:         (insert ?\n)
        !           252:         (setq life-window-start (+ life-window-start fill-column 1))))
        !           253:   (goto-end-of-buffer)
        !           254:   ;; check for life within the last two lines of the buffer.
        !           255:   ;; If present insert two lifeless lines at the end.
        !           256:   (cond ((search-backward (life-life-string)
        !           257:                          (- (point) fill-column fill-column 2) t)
        !           258:         (goto-end-of-buffer)
        !           259:         (insert-char (life-void-char) fill-column)
        !           260:         (insert ?\n)
        !           261:         (insert-char (life-void-char) fill-column)
        !           262:         (insert ?\n)
        !           263:         (setq life-window-start (+ life-window-start fill-column 1)))))
        !           264: 
        !           265: (defun life-display-generation (sleeptime)
        !           266:   (goto-char life-window-start)
        !           267:   (recenter 0)
        !           268:   (sit-for sleeptime))
        !           269: 
        !           270: (defun life-extinct-quit ()
        !           271:   (life-display-generation 0)
        !           272:   (signal 'life-extinct nil))
        !           273: 
        !           274: (put 'life-extinct 'error-conditions '(life-extinct quit))
        !           275: (put 'life-extinct 'error-message "All life has perished")
        !           276: 
        !           277: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.