Return to life.el CVS log

Up to [Apple XNU] / GNUtools / emacs / lisp

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

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