Mercurial > emacs
changeset 17905:07602ad4416d
Initial revision
| author | Richard M. Stallman <rms@gnu.org> |
|---|---|
| date | Tue, 20 May 1997 21:48:58 +0000 |
| parents | 954352993fa2 |
| children | a8d2103ea2b4 |
| files | lisp/mail/mspools.el lisp/play/landmark.el |
| diffstat | 2 files changed, 2189 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/mspools.el Tue May 20 21:48:58 1997 +0000 @@ -0,0 +1,394 @@ +;;; MSPOOLS.EL --- Show mail spools waiting to be read + +;; Copyright (C) 1997 Stephen Eglen + +;; Author: Stephen Eglen <stephene@cogs.susx.ac.uk> +;; Maintainer: Stephen Eglen <stephene@cogs.susx.ac.uk> +;; Created: 22 Jan 1997 +;; Version: 1.0 +;; Keywords: + + +;; This program 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. + +;; This program 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: + +;; If you use a mail filter (e.g. procmail, filter) to put mail messages in +;; folders, this file will let you see which folders have mail waiting +;; to be read in them. It assumes that new mail for the file `folder' +;; is written by the filter to a file called `folder.spool'. (If the +;; file writes directly to `folder' you may lose mail if new mail +;; arrives whilst you are reading the folder in emacs, hence the use +;; of a spool file.) For example, the following procmail recipe puts +;; any mail with `emacs' in the subject line into the spool file +;; `apple.spool', ready to go into the folder `emacs'. +;:0: +;* ^Subject.*emacs +;emacs.spool + +;; It also assumes that all of your spool files and mail folders live +;; in the directory pointed to by `mspools-folder-directory', so you must +;; set this (see Installation). + +;; When you run `mspools-show', it creates a *spools* buffer containing +;; all of the spools in the folder directory that are waiting to be +;; read. On each line is the spool name and its size in bytes. Move +;; to the line of the folder that you would like to read, and then +;; press return or space. The mailer (VM or RMAIL) should then read +;; that folder and get the new mail for you. When you return to the +;; *spools* buffer, you will either see "*" to indicate that the spool +;; has been read, or the remaining unread spools, depending on the +;; value of `mspools-update'. + +;; This file should work with both VM and RMAIL. See the variable +;; `mspools-using-vm' for details. + + +;;; Installation + +;; Basic +;(autoload 'mspools-show "mspools" "Show outstanding mail spools." t) +; Point to directory where spool files and folders are: +; (setq mspools-folder-directory "~/MAIL/") + +;; Extras +; possibly bind it to a key: +;(global-set-key '[S-f1] 'mspools-show) +;(setq mspools-update t) + +;; Interface with the mail filter +; We assume that the mail filter drops new mail into the spool +; `folder.spool'. If your spool files are something like folder.xyz +; for inbox `folder', then do +; (setq spool-suffix "xyz") +; If you use other conventions for your spool files, this code will +; need rewriting. + +;;; Warning for VM users +;; Dont use if you are not sure what you are doing! The value of +;; vm-spool-files is altered, so you may not be able to read incoming +;; mail with VM if this is incorrectly set. + +;; Useful settings for VM +;vm-auto-get-new-mail should be t (default t) + +;;; Acknowledgements +;; The code for setting up vm-spool-files came from +;;http://www-users.informatik.rwth-aachen.de/~berg/archive/procmail/0047.html +;; Thanks to jond@mitre.org (Jonathan Doughty) + +;;; TODO + +;; What if users have mail spools in more than one directory? Extend +;; mspools-folder-directory to be a list of files? + +;; I was going to add mouse support so that you could click on a line +;; to visit the buffer. Tell me if you want it, and I can put the +;; code in (I dont use the mouse much, so I havent bothered with it so +;; far). + + +;; Rather than showing size in bytes, could we see the number of msgs +;; waiting? (Could be more time demanding / system dependent). +;; Perl script counts the number of /^From / occurences. +;; ? +;; Include date +;; (substring (current-time-string (nth 4 (file-attributes "~/INBOX"))) 4 19) +;; Maybe just call a perl script to do all the hard work, and +;; visualise the results in the buffer. + +;; Shrink wrap the buffer to remove excess white-space? + + +;;; User Variables + + +(defvar mspools-update nil + "*Non-nil means update *spools* buffer after visiting any folder.") + +(defvar mspools-suffix "spool" + "*Extension used for spool files (not including full stop).") + +;;; Internal Variables + +(defvar mspools-vm-system-mail (getenv "MAIL") + "Main mailbox used. Only used by VM.") + +(defvar mspools-vm-system-mail-crash + (concat mspools-vm-system-mail ".crash") + "Crash box for main mailbox. See also `mspools-vm-system-mail'. +Only used by VM." ) + + +(defvar mspools-files nil + "List of entries (SPOOL . SIZE) giving spool name and file size.") + +(defvar mspools-files-len nil + "Length of `mspools-files' list.") + +(defvar mspools-buffer "*spools*" + "Name of buffer for displaying spool info.") + +(defvar mspools-mode-map nil + "Keymap for the *spools* buffer.") + +(defvar mspools-folder-directory + (if (boundp 'vm-folder-directory) + vm-folder-directory + nil) + "Directory where mail folders are kept. Defaults to +`vm-folder-directory' if bound else nil. Make sure it has a trailing / +at the end. ") + + +(defvar mspools-using-vm + (fboundp 'vm) + "*Non-nil if VM is used as mail reader, otherwise RMAIL is used.") + + +;;; Code + +;;; VM Specific code +(if mspools-using-vm + (require 'vm-vars)) + +(defun mspools-set-vm-spool-files () + "Set value of `vm-spool-files'. Only needed for VM." + (setq + vm-spool-files + (append + (list + ;; Main mailbox + (list vm-primary-inbox + mspools-vm-system-mail; your mailbox + mspools-vm-system-mail-crash ; crash for mailbox + )) + + ;; Mailing list inboxes + (mapcar '(lambda (s) + "make the appropriate entry for vm-spool-files" + (list + (concat vm-folder-directory s) + (concat vm-folder-directory s "." mspools-suffix) + (concat vm-folder-directory s ".crash"))) + ;; So I create a vm-spool-files entry for each of those mail drops + (mapcar 'file-name-sans-extension + (directory-files vm-folder-directory nil + (format "^[^.]+\\.%s" mspools-suffix))) + )) + )) + + + +;;; MSPOOLS-SHOW -- the main function +(defun mspools-show ( &optional noshow) + "Show the list of non-empty spool files in the *spools* buffer. +Buffer is not displayed if SHOW is non-nil." + (interactive) + (if (get-buffer mspools-buffer) + ;; buffer exists + (progn + (set-buffer mspools-buffer) + (setq buffer-read-only nil) + (delete-region (point-min) (point-max))) + ;; else buff. doesnt exist so create it + (get-buffer-create mspools-buffer)) + + ;; generate the list of spool files + (if mspools-using-vm + (mspools-set-vm-spool-files)) + + (mspools-get-spool-files) + (if (not noshow) (pop-to-buffer mspools-buffer)) + + (setq buffer-read-only t) + (mspools-mode) + ) + + + + +(defun mspools-visit-spool () + "Visit the folder on the current line of the *spools* buffer." + (interactive) + (let ( spool-name folder-name) + (setq spool-name (mspools-get-spool-name)) + (setq folder-name (mspools-get-folder-from-spool spool-name)) + + ;; put in a little "*" to indicate spool file has been read. + (if (not mspools-update) + (save-excursion + (setq buffer-read-only nil) + (beginning-of-line) + (insert "*") + (delete-char 1) + (setq buffer-read-only t) + )) + + + (message "folder %s spool %s" folder-name spool-name) + (if (eq (count-lines (point-min) + (save-excursion + (end-of-line) + (point))) + mspools-files-len) + (next-line (- 1 mspools-files-len)) ;back to top of list + ;; else just on to next line + (next-line 1)) + + ;; Choose whether to use VM or RMAIL for reading folder. + (if mspools-using-vm + (vm-visit-folder (concat mspools-folder-directory folder-name)) + ;; else using RMAIL + (rmail (concat mspools-folder-directory folder-name)) + (setq rmail-inbox-list + (list (concat mspools-folder-directory spool-name))) + (rmail-get-new-mail)) + + + (if mspools-update + ;; generate new list of spools. + (save-excursion + (mspools-show-again 'noshow))) + )) + + + + +(defun mspools-get-folder-from-spool (name) + "Return folder name corresponding to the spool file NAME." + ;; Simply strip of the extension. + (file-name-sans-extension name)) + +;; Alternative version if you have more complicated mapping of spool name +;; to file name. +;(defun get-folder-from-spool-safe (name) +; "Return the folder name corresponding to the spool file NAME." +; (if (string-match "^\\(.*\\)\.spool$" name) +; (substring name (match-beginning 1) (match-end 1)) +; (error "Could not extract folder name from spool name %s" name))) + +; test +;(mspools-get-folder-from-spool "happy.spool") +;(mspools-get-folder-from-spool "happy.sp") + + + +(defun mspools-get-spool-name () + "Return the name of the spool on the current line." + (let ((line-num (1- (count-lines (point-min) + (save-excursion + (end-of-line) + (point)) + )))) + (car (nth line-num mspools-files)))) + +;;; Keymap + +(if mspools-mode-map + () + (setq mspools-mode-map (make-sparse-keymap)) + + (define-key mspools-mode-map "\C-c\C-c" 'mspools-visit-spool) + (define-key mspools-mode-map "\C-m" 'mspools-visit-spool) + (define-key mspools-mode-map " " 'mspools-visit-spool) + (define-key mspools-mode-map "?" 'mspools-help) + (define-key mspools-mode-map "q" 'mspools-quit) + (define-key mspools-mode-map "g" 'revert-buffer)) + + +;;; Spools mode functions + +(defun mspools-revert-buffer (ignore noconfirm) + "Re-run mspools-show to revert the *spools* buffer." + (mspools-show 'noshow)) + +(defun mspools-show-again (&optional noshow) + "Update the *spools* buffer. This is useful if mspools-update is +nil." + (interactive) + (mspools-show noshow)) + +(defun mspools-help () + "Show help for `mspools-mode'." + (interactive) + (describe-function 'mspools-mode)) + +(defun mspools-quit () + "Quit the *spools* buffer." + (interactive) + (kill-buffer mspools-buffer)) + + +(defun mspools-mode () + "Major mode for output from mspools-show. +\\<mspools-mode-map>Move point to one of the items in this buffer, then use +\\[mspools-visit-spool] to go to the spool that the current line refers to. +\\[mspools-show-again] to regenerate the list of spools. +\\{mspools-mode-map}" + (kill-all-local-variables) + (make-local-variable 'revert-buffer-function) + (setq revert-buffer-function 'mspools-revert-buffer) + (use-local-map mspools-mode-map) + (setq major-mode 'mspools-mode) + (setq mode-name "MSpools") + ) + + +(defun mspools-get-spool-files () + "Find the list of spool files and display them in *spools* buffer." + (let (folders head spool len beg end any) + (setq folders (directory-files mspools-folder-directory nil + (format "^[^.]+\\.%s" mspools-suffix))) + + + (setq folders (mapcar 'mspools-size-folder folders)) + (setq folders (delq nil folders)) + (setq mspools-files folders) + (setq mspools-files-len (length mspools-files)) + (set-buffer mspools-buffer) + (while folders + (setq any t) + (setq head (car folders)) + (setq spool (car head)) + (setq len (cdr head)) + (setq folders (cdr folders)) + (setq beg (point)) + (insert (format " %10d %s" len spool)) + (setq end (point)) + (insert "\n") + ;;(put-text-property beg end 'mouse-face 'highlight) + ) + (if any + (delete-char -1)) ;delete last RET + (goto-char (point-min)) + )) + + + +(defun mspools-size-folder (spool) + "Return (SPOOL . SIZE ) iff SIZE of spool file is non-zero." + ;; 7th file attribute is the size of the file in bytes. + (let ((size (nth 7 + (file-attributes (concat mspools-folder-directory spool))))) + ;; todo (if (and (not (null size)) (> size 0)) + (if (> size 0) + (cons spool size) + ;; else SPOOL is empty + nil))) + +(provide 'mspools) +;;; MSPOOLS.EL ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/play/landmark.el Tue May 20 21:48:58 1997 +0000 @@ -0,0 +1,1795 @@ +;;;_* landmark.el --- Landmark learning neural network +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Terrence Brannon <brannon@rana.usc.edu> +;; Maintainer: same +;; Created: December 16, 1996 - first release to usenet +;; Keywords: gomoku neural network adaptive search chemotaxis + +;; 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. + +;;;_* Usage +;;; Just type +;;; M-x eval-current-buffer +;;; M-x lm-test-run + +;;;_* Commentary +;;; Lm is a relatively non-participatory game in which a robot +;;; attempts to maneuver towards a tree at the center of the window +;;; based on unique olfactory cues from each of the 4 directions. If +;;; the smell of the tree increases, then the weights in the robot's +;;; brain are adjusted to encourage this odor-driven behavior in the +;;; future. If the smell of the tree decreases, the robots weights are +;;; adjusted to discourage a correct move. + +;;; In layman's terms, the search space is initially flat. The point +;;; of training is to "turn up the edges of the search space" so that +;;; the robot rolls toward the center. + +;;; Further, do not become alarmed if the robot appears to oscillate +;;; back and forth between two or a few positions. This simply means +;;; it is currently caught in a local minimum and is doing its best to +;;; work its way out. + +;;; The version of this program as described has a small problem. a +;;; move in a net direction can produce gross credit assignment. for +;;; example, if moving south will produce positive payoff, then, if in +;;; a single move, one moves east,west and south, then both east and +;;; west will be improved when they shouldn't + +;;; For further references see +;;; http://rana.usc.edu:8376/~yuri/CS564/hw5.html + + + + + + + + + + + +;;;_* Provide + +(provide 'lm) + + + + + + + +;;;_* Require +(require 'cl) + + + + + + +;;;_* From Gomoku + + + + + +;;;_ + THE BOARD. + + +;; The board is a rectangular grid. We code empty squares with 0, X's with 1 +;; and O's with 6. The rectangle is recorded in a one dimensional vector +;; containing padding squares (coded with -1). These squares allow us to +;; detect when we are trying to move out of the board. We denote a square by +;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The +;; leftmost topmost square has coords (1,1) and index lm-board-width + 2. +;; Similarly, vectors between squares may be given by two DX, DY coords or by +;; one DEPL (the difference between indexes). + +(defvar lm-board-width nil + "Number of columns on the Lm board.") +(defvar lm-board-height nil + "Number of lines on the Lm board.") + +(defvar lm-board nil + "Vector recording the actual state of the Lm board.") + +(defvar lm-vector-length nil + "Length of lm-board vector.") + +(defvar lm-draw-limit nil + ;; This is usually set to 70% of the number of squares. + "After how many moves will Emacs offer a draw?") + +(defun lm-xy-to-index (x y) + "Translate X, Y cartesian coords into the corresponding board index." + (+ (* y lm-board-width) x y)) + +(defun lm-index-to-x (index) + "Return corresponding x-coord of board INDEX." + (% index (1+ lm-board-width))) + +(defun lm-index-to-y (index) + "Return corresponding y-coord of board INDEX." + (/ index (1+ lm-board-width))) + +(defun lm-init-board () + "Create the lm-board vector and fill it with initial values." + (setq lm-board (make-vector lm-vector-length 0)) + ;; Every square is 0 (i.e. empty) except padding squares: + (let ((i 0) (ii (1- lm-vector-length))) + (while (<= i lm-board-width) ; The squares in [0..width] and in + (aset lm-board i -1) ; [length - width - 1..length - 1] + (aset lm-board ii -1) ; are padding squares. + (setq i (1+ i) + ii (1- ii)))) + (let ((i 0)) + (while (< i lm-vector-length) + (aset lm-board i -1) ; and also all k*(width+1) + (setq i (+ i lm-board-width 1))))) + + + + + +;;;_ + LM MODE AND KEYMAP. + +(defvar lm-mode-hook nil + "If non-nil, its value is called on entry to Lm mode.") + +(defvar lm-mode-map nil + "Local keymap to use in Lm mode.") + +(if lm-mode-map nil + (setq lm-mode-map (make-sparse-keymap)) + + ;; Key bindings for cursor motion. + (define-key lm-mode-map "y" 'lm-move-nw) ; y + (define-key lm-mode-map "u" 'lm-move-ne) ; u + (define-key lm-mode-map "b" 'lm-move-sw) ; b + (define-key lm-mode-map "n" 'lm-move-se) ; n + (define-key lm-mode-map "h" 'backward-char) ; h + (define-key lm-mode-map "l" 'forward-char) ; l + (define-key lm-mode-map "j" 'lm-move-down) ; j + (define-key lm-mode-map "k" 'lm-move-up) ; k + + (define-key lm-mode-map [kp-7] 'lm-move-nw) + (define-key lm-mode-map [kp-9] 'lm-move-ne) + (define-key lm-mode-map [kp-1] 'lm-move-sw) + (define-key lm-mode-map [kp-3] 'lm-move-se) + (define-key lm-mode-map [kp-4] 'backward-char) + (define-key lm-mode-map [kp-6] 'forward-char) + (define-key lm-mode-map [kp-2] 'lm-move-down) + (define-key lm-mode-map [kp-8] 'lm-move-up) + + (define-key lm-mode-map "\C-n" 'lm-move-down) ; C-n + (define-key lm-mode-map "\C-p" 'lm-move-up) ; C-p + + ;; Key bindings for entering Human moves. + (define-key lm-mode-map "X" 'lm-human-plays) ; X + (define-key lm-mode-map "x" 'lm-human-plays) ; x + + (define-key lm-mode-map " " 'lm-start-robot) ; SPC + (define-key lm-mode-map [down-mouse-1] 'lm-start-robot) + (define-key lm-mode-map [drag-mouse-1] 'lm-click) + (define-key lm-mode-map [mouse-1] 'lm-click) + (define-key lm-mode-map [down-mouse-2] 'lm-click) + (define-key lm-mode-map [mouse-2] 'lm-mouse-play) + (define-key lm-mode-map [drag-mouse-2] 'lm-mouse-play) + + (substitute-key-definition 'previous-line 'lm-move-up + lm-mode-map (current-global-map)) + (substitute-key-definition 'next-line 'lm-move-down + lm-mode-map (current-global-map)) + (substitute-key-definition 'beginning-of-line 'lm-beginning-of-line + lm-mode-map (current-global-map)) + (substitute-key-definition 'end-of-line 'lm-end-of-line + lm-mode-map (current-global-map)) + (substitute-key-definition 'undo 'lm-human-takes-back + lm-mode-map (current-global-map)) + (substitute-key-definition 'advertised-undo 'lm-human-takes-back + lm-mode-map (current-global-map))) + +(defvar lm-emacs-won () + "*For making font-lock use the winner's face for the line.") + +(defvar lm-font-lock-O-face + (if window-system + (list (facemenu-get-face 'fg:red) 'bold)) + "*Face to use for Emacs' O.") + +(defvar lm-font-lock-X-face + (if window-system + (list (facemenu-get-face 'fg:green) 'bold)) + "*Face to use for your X.") + +(defvar lm-font-lock-keywords + '(("O" . lm-font-lock-O-face) + ("X" . lm-font-lock-X-face) + ("[-|/\\]" 0 (if lm-emacs-won + lm-font-lock-O-face + lm-font-lock-X-face))) + "*Font lock rules for Lm.") + +(put 'lm-mode 'front-sticky + (put 'lm-mode 'rear-nonsticky '(intangible))) +(put 'lm-mode 'intangible 1) + +(defun lm-mode () + "Major mode for playing Lm against Emacs. +You and Emacs play in turn by marking a free square. You mark it with X +and Emacs marks it with O. The winner is the first to get five contiguous +marks horizontally, vertically or in diagonal. + +You play by moving the cursor over the square you choose and hitting \\[lm-human-plays]. + +Other useful commands: +\\{lm-mode-map} +Entry to this mode calls the value of `lm-mode-hook' if that value +is non-nil. One interesting value is `turn-on-font-lock'." + (interactive) + (setq major-mode 'lm-mode + mode-name "Lm") + (lm-display-statistics) + (use-local-map lm-mode-map) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(lm-font-lock-keywords t)) + (toggle-read-only t) + (run-hooks 'lm-mode-hook)) + + + + + +;;;_ + THE SCORE TABLE. + + +;; Every (free) square has a score associated to it, recorded in the +;; LM-SCORE-TABLE vector. The program always plays in the square having +;; the highest score. + +(defvar lm-score-table nil + "Vector recording the actual score of the free squares.") + + +;; The key point point about the algorithm is that, rather than considering +;; the board as just a set of squares, we prefer to see it as a "space" of +;; internested 5-tuples of contiguous squares (called qtuples). +;; +;; The aim of the program is to fill one qtuple with its O's while preventing +;; you from filling another one with your X's. To that effect, it computes a +;; score for every qtuple, with better qtuples having better scores. Of +;; course, the score of a qtuple (taken in isolation) is just determined by +;; its contents as a set, i.e. not considering the order of its elements. The +;; highest score is given to the "OOOO" qtuples because playing in such a +;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because +;; not playing in it is just loosing the game, and so on. Note that a +;; "polluted" qtuple, i.e. one containing at least one X and at least one O, +;; has score zero because there is no more any point in playing in it, from +;; both an attacking and a defending point of view. +;; +;; Given the score of every qtuple, the score of a given free square on the +;; board is just the sum of the scores of all the qtuples to which it belongs, +;; because playing in that square is playing in all its containing qtuples at +;; once. And it is that function which takes into account the internesting of +;; the qtuples. +;; +;; This algorithm is rather simple but anyway it gives a not so dumb level of +;; play. It easily extends to "n-dimensional Lm", where a win should not +;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !) +;; should be preferred. + + +;; Here are the scores of the nine "non-polluted" configurations. Tuning +;; these values will change (hopefully improve) the strength of the program +;; and may change its style (rather aggressive here). + +(defconst nil-score 7 "Score of an empty qtuple.") +(defconst Xscore 15 "Score of a qtuple containing one X.") +(defconst XXscore 400 "Score of a qtuple containing two X's.") +(defconst XXXscore 1800 "Score of a qtuple containing three X's.") +(defconst XXXXscore 100000 "Score of a qtuple containing four X's.") +(defconst Oscore 35 "Score of a qtuple containing one O.") +(defconst OOscore 800 "Score of a qtuple containing two O's.") +(defconst OOOscore 15000 "Score of a qtuple containing three O's.") +(defconst OOOOscore 800000 "Score of a qtuple containing four O's.") + +;; These values are not just random: if, given the following situation: +;; +;; . . . . . . . O . +;; . X X a . . . X . +;; . . . X . . . X . +;; . . . X . . . X . +;; . . . . . . . b . +;; +;; you want Emacs to play in "a" and not in "b", then the parameters must +;; satisfy the inequality: +;; +;; 6 * XXscore > XXXscore + XXscore +;; +;; because "a" mainly belongs to six "XX" qtuples (the others are less +;; important) while "b" belongs to one "XXX" and one "XX" qtuples. Other +;; conditions are required to obtain sensible moves, but the previous example +;; should illustrate the point. If you manage to improve on these values, +;; please send me a note. Thanks. + + +;; As we chose values 0, 1 and 6 to denote empty, X and O squares, the +;; contents of a qtuple are uniquely determined by the sum of its elements and +;; we just have to set up a translation table. + +(defconst lm-score-trans-table + (vector nil-score Xscore XXscore XXXscore XXXXscore 0 + Oscore 0 0 0 0 0 + OOscore 0 0 0 0 0 + OOOscore 0 0 0 0 0 + OOOOscore 0 0 0 0 0 + 0) + "Vector associating qtuple contents to their score.") + + +;; If you do not modify drastically the previous constants, the only way for a +;; square to have a score higher than OOOOscore is to belong to a "OOOO" +;; qtuple, thus to be a winning move. Similarly, the only way for a square to +;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX" +;; qtuple. We may use these considerations to detect when a given move is +;; winning or loosing. + +(defconst lm-winning-threshold OOOOscore + "Threshold score beyond which an Emacs move is winning.") + +(defconst lm-loosing-threshold XXXXscore + "Threshold score beyond which a human move is winning.") + + +(defun lm-strongest-square () + "Compute index of free square with highest score, or nil if none." + ;; We just have to loop other all squares. However there are two problems: + ;; 1/ The SCORE-TABLE only gives correct scores to free squares. To speed + ;; up future searches, we set the score of padding or occupied squares + ;; to -1 whenever we meet them. + ;; 2/ We want to choose randomly between equally good moves. + (let ((score-max 0) + (count 0) ; Number of equally good moves + (square (lm-xy-to-index 1 1)) ; First square + (end (lm-xy-to-index lm-board-width lm-board-height)) + best-square score) + (while (<= square end) + (cond + ;; If score is lower (i.e. most of the time), skip to next: + ((< (aref lm-score-table square) score-max)) + ;; If score is better, beware of non free squares: + ((> (setq score (aref lm-score-table square)) score-max) + (if (zerop (aref lm-board square)) ; is it free ? + (setq count 1 ; yes: take it ! + best-square square + score-max score) + (aset lm-score-table square -1))) ; no: kill it ! + ;; If score is equally good, choose randomly. But first check freeness: + ((not (zerop (aref lm-board square))) + (aset lm-score-table square -1)) + ((zerop (random (setq count (1+ count)))) + (setq best-square square + score-max score))) + (setq square (1+ square))) ; try next square + best-square)) + +;;;_ - INITIALIZING THE SCORE TABLE. + +;; At initialization the board is empty so that every qtuple amounts for +;; nil-score. Therefore, the score of any square is nil-score times the number +;; of qtuples that pass through it. This number is 3 in a corner and 20 if you +;; are sufficiently far from the sides. As computing the number is time +;; consuming, we initialize every square with 20*nil-score and then only +;; consider squares at less than 5 squares from one side. We speed this up by +;; taking symmetry into account. +;; Also, as it is likely that successive games will be played on a board with +;; same size, it is a good idea to save the initial SCORE-TABLE configuration. + +(defvar lm-saved-score-table nil + "Recorded initial value of previous score table.") + +(defvar lm-saved-board-width nil + "Recorded value of previous board width.") + +(defvar lm-saved-board-height nil + "Recorded value of previous board height.") + + +(defun lm-init-score-table () + "Create the score table vector and fill it with initial values." + (if (and lm-saved-score-table ; Has it been stored last time ? + (= lm-board-width lm-saved-board-width) + (= lm-board-height lm-saved-board-height)) + (setq lm-score-table (copy-sequence lm-saved-score-table)) + ;; No, compute it: + (setq lm-score-table + (make-vector lm-vector-length (* 20 nil-score))) + (let (i j maxi maxj maxi2 maxj2) + (setq maxi (/ (1+ lm-board-width) 2) + maxj (/ (1+ lm-board-height) 2) + maxi2 (min 4 maxi) + maxj2 (min 4 maxj)) + ;; We took symmetry into account and could use it more if the board + ;; would have been square and not rectangular ! + ;; In our case we deal with all (i,j) in the set [1..maxi2]*[1..maxj] U + ;; [maxi2+1..maxi]*[1..maxj2]. Maxi2 and maxj2 are used because the + ;; board may well be less than 8 by 8 ! + (setq i 1) + (while (<= i maxi2) + (setq j 1) + (while (<= j maxj) + (lm-init-square-score i j) + (setq j (1+ j))) + (setq i (1+ i))) + (while (<= i maxi) + (setq j 1) + (while (<= j maxj2) + (lm-init-square-score i j) + (setq j (1+ j))) + (setq i (1+ i)))) + (setq lm-saved-score-table (copy-sequence lm-score-table) + lm-saved-board-width lm-board-width + lm-saved-board-height lm-board-height))) + +(defun lm-nb-qtuples (i j) + "Return the number of qtuples containing square I,J." + ;; This function is complicated because we have to deal + ;; with ugly cases like 3 by 6 boards, but it works. + ;; If you have a simpler (and correct) solution, send it to me. Thanks ! + (let ((left (min 4 (1- i))) + (right (min 4 (- lm-board-width i))) + (up (min 4 (1- j))) + (down (min 4 (- lm-board-height j)))) + (+ -12 + (min (max (+ left right) 3) 8) + (min (max (+ up down) 3) 8) + (min (max (+ (min left up) (min right down)) 3) 8) + (min (max (+ (min right up) (min left down)) 3) 8)))) + +(defun lm-init-square-score (i j) + "Give initial score to square I,J and to its mirror images." + (let ((ii (1+ (- lm-board-width i))) + (jj (1+ (- lm-board-height j))) + (sc (* (lm-nb-qtuples i j) (aref lm-score-trans-table 0)))) + (aset lm-score-table (lm-xy-to-index i j) sc) + (aset lm-score-table (lm-xy-to-index ii j) sc) + (aset lm-score-table (lm-xy-to-index i jj) sc) + (aset lm-score-table (lm-xy-to-index ii jj) sc))) +;;;_ - MAINTAINING THE SCORE TABLE. + + +;; We do not provide functions for computing the SCORE-TABLE given the +;; contents of the BOARD. This would involve heavy nested loops, with time +;; proportional to the size of the board. It is better to update the +;; SCORE-TABLE after each move. Updating needs not modify more than 36 +;; squares: it is done in constant time. + +(defun lm-update-score-table (square dval) + "Update score table after SQUARE received a DVAL increment." + ;; The board has already been updated when this function is called. + ;; Updating scores is done by looking for qtuples boundaries in all four + ;; directions and then calling update-score-in-direction. + ;; Finally all squares received the right increment, and then are up to + ;; date, except possibly for SQUARE itself if we are taking a move back for + ;; its score had been set to -1 at the time. + (let* ((x (lm-index-to-x square)) + (y (lm-index-to-y square)) + (imin (max -4 (- 1 x))) + (jmin (max -4 (- 1 y))) + (imax (min 0 (- lm-board-width x 4))) + (jmax (min 0 (- lm-board-height y 4)))) + (lm-update-score-in-direction imin imax + square 1 0 dval) + (lm-update-score-in-direction jmin jmax + square 0 1 dval) + (lm-update-score-in-direction (max imin jmin) (min imax jmax) + square 1 1 dval) + (lm-update-score-in-direction (max (- 1 y) -4 + (- x lm-board-width)) + (min 0 (- x 5) + (- lm-board-height y 4)) + square -1 1 dval))) + +(defun lm-update-score-in-direction (left right square dx dy dval) + "Update scores for all squares in the qtuples starting between the LEFTth +square and the RIGHTth after SQUARE, along the DX, DY direction, considering +that DVAL has been added on SQUARE." + ;; We always have LEFT <= 0, RIGHT <= 0 and DEPL > 0 but we may very well + ;; have LEFT > RIGHT, indicating that no qtuple contains SQUARE along that + ;; DX,DY direction. + (cond + ((> left right)) ; Quit + (t ; Else .. + (let (depl square0 square1 square2 count delta) + (setq depl (lm-xy-to-index dx dy) + square0 (+ square (* left depl)) + square1 (+ square (* right depl)) + square2 (+ square0 (* 4 depl))) + ;; Compute the contents of the first qtuple: + (setq square square0 + count 0) + (while (<= square square2) + (setq count (+ count (aref lm-board square)) + square (+ square depl))) + (while (<= square0 square1) + ;; Update the squares of the qtuple beginning in SQUARE0 and ending + ;; in SQUARE2. + (setq delta (- (aref lm-score-trans-table count) + (aref lm-score-trans-table (- count dval)))) + (cond ((not (zerop delta)) ; or else nothing to update + (setq square square0) + (while (<= square square2) + (if (zerop (aref lm-board square)) ; only for free squares + (aset lm-score-table square + (+ (aref lm-score-table square) delta))) + (setq square (+ square depl))))) + ;; Then shift the qtuple one square along DEPL, this only requires + ;; modifying SQUARE0 and SQUARE2. + (setq square2 (+ square2 depl) + count (+ count (- (aref lm-board square0)) + (aref lm-board square2)) + square0 (+ square0 depl))))))) + +;;; +;;; GAME CONTROL. +;;; + +;; Several variables are used to monitor a game, including a GAME-HISTORY (the +;; list of all (SQUARE . PREVSCORE) played) that allows to take moves back +;; (anti-updating the score table) and to compute the table from scratch in +;; case of an interruption. + +(defvar lm-game-in-progress nil + "Non-nil if a game is in progress.") + +(defvar lm-game-history nil + "A record of all moves that have been played during current game.") + +(defvar lm-number-of-moves nil + "Number of moves already played in current game.") + +(defvar lm-number-of-human-moves nil + "Number of moves already played by human in current game.") + +(defvar lm-emacs-played-first nil + "Non-nil if Emacs played first.") + +(defvar lm-human-took-back nil + "Non-nil if Human took back a move during the game.") + +(defvar lm-human-refused-draw nil + "Non-nil if Human refused Emacs offer of a draw.") + +(defvar lm-emacs-is-computing nil + ;; This is used to detect interruptions. Hopefully, it should not be needed. + "Non-nil if Emacs is in the middle of a computation.") + + +(defun lm-start-game (n m) + "Initialize a new game on an N by M board." + (setq lm-emacs-is-computing t) ; Raise flag + (setq lm-game-in-progress t) + (setq lm-board-width n + lm-board-height m + lm-vector-length (1+ (* (+ m 2) (1+ n))) + lm-draw-limit (/ (* 7 n m) 10)) + (setq lm-emacs-won nil + lm-game-history nil + lm-number-of-moves 0 + lm-number-of-human-moves 0 + lm-emacs-played-first nil + lm-human-took-back nil + lm-human-refused-draw nil) + (lm-init-display n m) ; Display first: the rest takes time + (lm-init-score-table) ; INIT-BOARD requires that the score + (lm-init-board) ; table be already created. + (setq lm-emacs-is-computing nil)) + +(defun lm-play-move (square val &optional dont-update-score) + "Go to SQUARE, play VAL and update everything." + (setq lm-emacs-is-computing t) ; Raise flag + (cond ((= 1 val) ; a Human move + (setq lm-number-of-human-moves (1+ lm-number-of-human-moves))) + ((zerop lm-number-of-moves) ; an Emacs move. Is it first ? + (setq lm-emacs-played-first t))) + (setq lm-game-history + (cons (cons square (aref lm-score-table square)) + lm-game-history) + lm-number-of-moves (1+ lm-number-of-moves)) + (lm-plot-square square val) + (aset lm-board square val) ; *BEFORE* UPDATE-SCORE ! + (if dont-update-score nil + (lm-update-score-table square val) ; previous val was 0: dval = val + (aset lm-score-table square -1)) + (setq lm-emacs-is-computing nil)) + +(defun lm-take-back () + "Take back last move and update everything." + (setq lm-emacs-is-computing t) + (let* ((last-move (car lm-game-history)) + (square (car last-move)) + (oldval (aref lm-board square))) + (if (= 1 oldval) + (setq lm-number-of-human-moves (1- lm-number-of-human-moves))) + (setq lm-game-history (cdr lm-game-history) + lm-number-of-moves (1- lm-number-of-moves)) + (lm-plot-square square 0) + (aset lm-board square 0) ; *BEFORE* UPDATE-SCORE ! + (lm-update-score-table square (- oldval)) + (aset lm-score-table square (cdr last-move))) + (setq lm-emacs-is-computing nil)) + + + +;;;_ + SESSION CONTROL. + + +(defvar lm-number-of-emacs-wins 0 + "Number of games Emacs won in this session.") + +(defvar lm-number-of-human-wins 0 + "Number of games you won in this session.") + +(defvar lm-number-of-draws 0 + "Number of games already drawn in this session.") + + +(defun lm-terminate-game (result) + "Terminate the current game with RESULT." + (message + (cond + ((eq result 'emacs-won) + (setq lm-number-of-emacs-wins (1+ lm-number-of-emacs-wins)) + (cond ((< lm-number-of-moves 20) + "This was a REALLY QUICK win.") + (lm-human-refused-draw + "I won... Too bad you refused my offer of a draw !") + (lm-human-took-back + "I won... Taking moves back will not help you !") + ((not lm-emacs-played-first) + "I won... Playing first did not help you much !") + ((and (zerop lm-number-of-human-wins) + (zerop lm-number-of-draws) + (> lm-number-of-emacs-wins 1)) + "I'm becoming tired of winning...") + ("I won."))) + ((eq result 'human-won) + (setq lm-number-of-human-wins (1+ lm-number-of-human-wins)) + (concat "OK, you won this one." + (cond + (lm-human-took-back + " I, for one, never take my moves back...") + (lm-emacs-played-first + ".. so what ?") + (" Now, let me play first just once.")))) + ((eq result 'human-resigned) + (setq lm-number-of-emacs-wins (1+ lm-number-of-emacs-wins)) + "So you resign. That's just one more win for me.") + ((eq result 'nobody-won) + (setq lm-number-of-draws (1+ lm-number-of-draws)) + (concat "This is a draw. " + (cond + (lm-human-took-back + "I, for one, never take my moves back...") + (lm-emacs-played-first + "Just chance, I guess.") + ("Now, let me play first just once.")))) + ((eq result 'draw-agreed) + (setq lm-number-of-draws (1+ lm-number-of-draws)) + (concat "Draw agreed. " + (cond + (lm-human-took-back + "I, for one, never take my moves back...") + (lm-emacs-played-first + "You were lucky.") + ("Now, let me play first just once.")))) + ((eq result 'crash-game) + "Sorry, I have been interrupted and cannot resume that game..."))) + (lm-display-statistics) + ;;(ding) + (setq lm-game-in-progress nil)) + +(defun lm-crash-game () + "What to do when Emacs detects it has been interrupted." + (setq lm-emacs-is-computing nil) + (lm-terminate-game 'crash-game) + (sit-for 4) ; Let's see the message + (lm-prompt-for-other-game)) + + + + + +;;;_ + INTERACTIVE COMMANDS. + + + +(defun lm-emacs-plays () + "Compute Emacs next move and play it." + (interactive) + (lm-switch-to-window) + (cond + (lm-emacs-is-computing + (lm-crash-game)) + ((not lm-game-in-progress) + (lm-prompt-for-other-game)) + (t + (message "Let me think...") + (let (square score) + (setq square (lm-strongest-square)) + (cond ((null square) + (lm-terminate-game 'nobody-won)) + (t + (setq score (aref lm-score-table square)) + (lm-play-move square 6) + (cond ((>= score lm-winning-threshold) + (setq lm-emacs-won t) ; for font-lock + (lm-find-filled-qtuple square 6) + (lm-terminate-game 'emacs-won)) + ((zerop score) + (lm-terminate-game 'nobody-won)) + ((and (> lm-number-of-moves lm-draw-limit) + (not lm-human-refused-draw) + (lm-offer-a-draw)) + (lm-terminate-game 'draw-agreed)) + (t + (lm-prompt-for-move))))))))) + +;; For small square dimensions this is approximate, since though measured in +;; pixels, event's (X . Y) is a character's top-left corner. +(defun lm-click (click) + "Position at the square where you click." + (interactive "e") + (and (windowp (posn-window (setq click (event-end click)))) + (numberp (posn-point click)) + (select-window (posn-window click)) + (setq click (posn-col-row click)) + (lm-goto-xy + (min (max (/ (+ (- (car click) + lm-x-offset + 1) + (window-hscroll) + lm-square-width + (% lm-square-width 2) + (/ lm-square-width 2)) + lm-square-width) + 1) + lm-board-width) + (min (max (/ (+ (- (cdr click) + lm-y-offset + 1) + (let ((inhibit-point-motion-hooks t)) + (count-lines 1 (window-start))) + lm-square-height + (% lm-square-height 2) + (/ lm-square-height 2)) + lm-square-height) + 1) + lm-board-height)))) + +(defun lm-mouse-play (click) + "Play at the square where you click." + (interactive "e") + (if (lm-click click) + (lm-human-plays))) + +(defun lm-human-plays () + "Signal to the Lm program that you have played. +You must have put the cursor on the square where you want to play. +If the game is finished, this command requests for another game." + (interactive) + (lm-switch-to-window) + (cond + (lm-emacs-is-computing + (lm-crash-game)) + ((not lm-game-in-progress) + (lm-prompt-for-other-game)) + (t + (let (square score) + (setq square (lm-point-square)) + (cond ((null square) + (error "Your point is not on a square. Retry !")) + ((not (zerop (aref lm-board square))) + (error "Your point is not on a free square. Retry !")) + (t + (setq score (aref lm-score-table square)) + (lm-play-move square 1) + (cond ((and (>= score lm-loosing-threshold) + ;; Just testing SCORE > THRESHOLD is not enough for + ;; detecting wins, it just gives an indication that + ;; we confirm with LM-FIND-FILLED-QTUPLE. + (lm-find-filled-qtuple square 1)) + (lm-terminate-game 'human-won)) + (t + (lm-emacs-plays))))))))) + +(defun lm-human-takes-back () + "Signal to the Lm program that you wish to take back your last move." + (interactive) + (lm-switch-to-window) + (cond + (lm-emacs-is-computing + (lm-crash-game)) + ((not lm-game-in-progress) + (message "Too late for taking back...") + (sit-for 4) + (lm-prompt-for-other-game)) + ((zerop lm-number-of-human-moves) + (message "You have not played yet... Your move ?")) + (t + (message "One moment, please...") + ;; It is possible for the user to let Emacs play several consecutive + ;; moves, so that the best way to know when to stop taking back moves is + ;; to count the number of human moves: + (setq lm-human-took-back t) + (let ((number lm-number-of-human-moves)) + (while (= number lm-number-of-human-moves) + (lm-take-back))) + (lm-prompt-for-move)))) + +(defun lm-human-resigns () + "Signal to the Lm program that you may want to resign." + (interactive) + (lm-switch-to-window) + (cond + (lm-emacs-is-computing + (lm-crash-game)) + ((not lm-game-in-progress) + (message "There is no game in progress")) + ((y-or-n-p "You mean, you resign ") + (lm-terminate-game 'human-resigned)) + ((y-or-n-p "You mean, we continue ") + (lm-prompt-for-move)) + (t + (lm-terminate-game 'human-resigned)))) ; OK. Accept it + + + +;;;_ + PROMPTING THE HUMAN PLAYER. + +(defun lm-prompt-for-move () + "Display a message asking for Human's move." + (message (if (zerop lm-number-of-human-moves) + "Your move ? (move to a free square and hit X, RET ...)" + "Your move ?")) + ;; This may seem silly, but if one omits the following line (or a similar + ;; one), the cursor may very well go to some place where POINT is not. + (save-excursion (set-buffer (other-buffer)))) + +(defun lm-prompt-for-other-game () + "Ask for another game, and start it." + (if (y-or-n-p "Another game ") + (lm lm-board-width lm-board-height) + (message "Chicken !"))) + +(defun lm-offer-a-draw () + "Offer a draw and return T if Human accepted it." + (or (y-or-n-p "I offer you a draw. Do you accept it ") + (not (setq lm-human-refused-draw t)))) + + + +;;;_ + DISPLAYING THE BOARD. + +;; You may change these values if you have a small screen or if the squares +;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1). + +(defconst lm-square-width 2 + "*Horizontal spacing between squares on the Lm board.") + +(defconst lm-square-height 1 + "*Vertical spacing between squares on the Lm board.") + +(defconst lm-x-offset 3 + "*Number of columns between the Lm board and the side of the window.") + +(defconst lm-y-offset 1 + "*Number of lines between the Lm board and the top of the window.") + + +(defun lm-max-width () + "Largest possible board width for the current window." + (1+ (/ (- (window-width (selected-window)) + lm-x-offset lm-x-offset 1) + lm-square-width))) + +(defun lm-max-height () + "Largest possible board height for the current window." + (1+ (/ (- (window-height (selected-window)) + lm-y-offset lm-y-offset 2) + ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line ! + lm-square-height))) + +(defun lm-point-y () + "Return the board row where point is." + (let ((inhibit-point-motion-hooks t)) + (1+ (/ (- (count-lines 1 (point)) lm-y-offset (if (bolp) 0 1)) + lm-square-height)))) +(defun my-lm-point-y () + (interactive) + "Return the board row where point is." + (let ((inhibit-point-motion-hooks t)) + (message (format "%S" + (1+ (/ (- (count-lines 1 (point)) lm-y-offset (if (bolp) 0 1)) + lm-square-height)))))) + +(defun lm-point-square () + "Return the index of the square point is on." + (let ((inhibit-point-motion-hooks t)) + (lm-xy-to-index (1+ (/ (- (current-column) lm-x-offset) + lm-square-width)) + (lm-point-y)))) + +(defun lm-goto-square (index) + "Move point to square number INDEX." + (lm-goto-xy (lm-index-to-x index) (lm-index-to-y index))) + +(defun lm-goto-xy (x y) + "Move point to square at X, Y coords." + (let ((inhibit-point-motion-hooks t)) + (goto-line (+ 1 lm-y-offset (* lm-square-height (1- y))))) + (move-to-column (+ lm-x-offset (* lm-square-width (1- x))))) + +(defun lm-plot-square (square value) + "Draw 'X', 'O' or '.' on SQUARE depending on VALUE, leave point there." + (or (= value 1) + (lm-goto-square square)) + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (insert-and-inherit (cond ((= value 1) ?.) + ((= value 2) ?N) + ((= value 3) ?S) + ((= value 4) ?E) + ((= value 5) ?W) + ((= value 6) ?^))) + + (and window-system + (zerop value) + (put-text-property (1- (point)) (point) 'mouse-face 'highlight)) + (delete-char 1) + (backward-char 1)) + (sit-for 0)) ; Display NOW + +(defun lm-init-display (n m) + "Display an N by M Lm board." + (buffer-disable-undo (current-buffer)) + (let ((inhibit-read-only t) + (point 1) opoint + (intangible t) + (i m) j x) + ;; Try to minimize number of chars (because of text properties) + (setq tab-width + (if (zerop (% lm-x-offset lm-square-width)) + lm-square-width + (max (/ (+ (% lm-x-offset lm-square-width) + lm-square-width 1) 2) 2))) + (erase-buffer) + (newline lm-y-offset) + (while (progn + (setq j n + x (- lm-x-offset lm-square-width)) + (while (>= (setq j (1- j)) 0) + (insert-char ?\t (/ (- (setq x (+ x lm-square-width)) + (current-column)) + tab-width)) + (insert-char ? (- x (current-column))) + (if (setq intangible (not intangible)) + (put-text-property point (point) 'intangible 2)) + (and (zerop j) + (= i (- m 2)) + (progn + (while (>= i 3) + (append-to-buffer (current-buffer) opoint (point)) + (setq i (- i 2))) + (goto-char (point-max)))) + (setq point (point)) + (insert ?=) + (if window-system + (put-text-property point (point) + 'mouse-face 'highlight))) + (> (setq i (1- i)) 0)) + (if (= i (1- m)) + (setq opoint point)) + (insert-char ?\n lm-square-height)) + (or (eq (char-after 1) ?.) + (put-text-property 1 2 'point-entered + (lambda (x x) (if (bobp) (forward-char))))) + (or intangible + (put-text-property point (point) 'intangible 2)) + (put-text-property point (point) 'point-entered + (lambda (x x) (if (eobp) (backward-char)))) + (put-text-property (point-min) (point) 'category 'lm-mode)) + (lm-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board + (sit-for 0)) ; Display NOW + +(defun lm-display-statistics () + "Obnoxiously display some statistics about previous games in mode line." + ;; We store this string in the mode-line-process local variable. + ;; This is certainly not the cleanest way out ... + (setq mode-line-process + (format ": Won %d, lost %d%s" + lm-number-of-human-wins + lm-number-of-emacs-wins + (if (zerop lm-number-of-draws) + "" + (format ", drew %d" lm-number-of-draws)))) + (force-mode-line-update)) + +(defun lm-switch-to-window () + "Find or create the Lm buffer, and display it." + (interactive) + (let ((buff (get-buffer "*Lm*"))) + (if buff ; Buffer exists: + (switch-to-buffer buff) ; no problem. + (if lm-game-in-progress + (lm-crash-game)) ; buffer has been killed or something + (switch-to-buffer "*Lm*") ; Anyway, start anew. + (lm-mode)))) + + + +;;;_ + CROSSING WINNING QTUPLES. + +;; When someone succeeds in filling a qtuple, we draw a line over the five +;; corresponding squares. One problem is that the program does not know which +;; squares ! It only knows the square where the last move has been played and +;; who won. The solution is to scan the board along all four directions. + +(defun lm-find-filled-qtuple (square value) + "Return T if SQUARE belongs to a qtuple filled with VALUEs." + (or (lm-check-filled-qtuple square value 1 0) + (lm-check-filled-qtuple square value 0 1) + (lm-check-filled-qtuple square value 1 1) + (lm-check-filled-qtuple square value -1 1))) + +(defun lm-check-filled-qtuple (square value dx dy) + "Return T if SQUARE belongs to a qtuple filled with VALUEs along DX, DY." + (let ((a 0) (b 0) + (left square) (right square) + (depl (lm-xy-to-index dx dy))) + (while (and (> a -4) ; stretch tuple left + (= value (aref lm-board (setq left (- left depl))))) + (setq a (1- a))) + (while (and (< b (+ a 4)) ; stretch tuple right + (= value (aref lm-board (setq right (+ right depl))))) + (setq b (1+ b))) + (cond ((= b (+ a 4)) ; tuple length = 5 ? + (lm-cross-qtuple (+ square (* a depl)) (+ square (* b depl)) + dx dy) + t)))) + +(defun lm-cross-qtuple (square1 square2 dx dy) + "Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction." + (save-excursion ; Not moving point from last square + (let ((depl (lm-xy-to-index dx dy)) + (inhibit-read-only t) + (inhibit-point-motion-hooks t)) + ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1 + (while (/= square1 square2) + (lm-goto-square square1) + (setq square1 (+ square1 depl)) + (cond + ((= dy 0) ; Horizontal + (forward-char 1) + (insert-char ?- (1- lm-square-width) t) + (delete-region (point) (progn + (skip-chars-forward " \t") + (point)))) + ((= dx 0) ; Vertical + (let ((n 1) + (column (current-column))) + (while (< n lm-square-height) + (setq n (1+ n)) + (forward-line 1) + (indent-to column) + (insert-and-inherit ?|)))) + ((= dx -1) ; 1st Diagonal + (indent-to (prog1 (- (current-column) (/ lm-square-width 2)) + (forward-line (/ lm-square-height 2)))) + (insert-and-inherit ?/)) + (t ; 2nd Diagonal + (indent-to (prog1 (+ (current-column) (/ lm-square-width 2)) + (forward-line (/ lm-square-height 2)))) + (insert-and-inherit ?\\)))))) + (sit-for 0)) ; Display NOW + + + +;;;_ + CURSOR MOTION. + +;; previous-line and next-line don't work right with intangible newlines +(defun lm-move-down () + "Move point down one row on the Lm board." + (interactive) + (if (< (lm-point-y) lm-board-height) + (next-line 1)));;; lm-square-height))) + +(defun lm-move-up () + "Move point up one row on the Lm board." + (interactive) + (if (> (lm-point-y) 1) + (previous-line lm-square-height))) + +(defun lm-move-ne () + "Move point North East on the Lm board." + (interactive) + (lm-move-up) + (forward-char)) + +(defun lm-move-se () + "Move point South East on the Lm board." + (interactive) + (lm-move-down) + (forward-char)) + +(defun lm-move-nw () + "Move point North West on the Lm board." + (interactive) + (lm-move-up) + (backward-char)) + +(defun lm-move-sw () + "Move point South West on the Lm board." + (interactive) + (lm-move-down) + (backward-char)) + +(defun lm-beginning-of-line () + "Move point to first square on the Lm board row." + (interactive) + (move-to-column lm-x-offset)) + +(defun lm-end-of-line () + "Move point to last square on the Lm board row." + (interactive) + (move-to-column (+ lm-x-offset + (* lm-square-width (1- lm-board-width))))) + +(provide 'lm) + + +(defun lm-xy-to-index (x y) + "Translate X, Y cartesian coords into the corresponding board index." + (+ (* y lm-board-width) x y)) + +(defun lm-index-to-x (index) + "Return corresponding x-coord of board INDEX." + (% index (1+ lm-board-width))) + +(defun lm-index-to-y (index) + "Return corresponding y-coord of board INDEX." + (/ index (1+ lm-board-width))) + + + + + + + + + +;;;_* Terry's mods to create lm.el + + + + + +;;;_ + Debugging things +(setq debug-on-error t) +;;;(setq lm-debug nil) +(setq lm-debug t) + +(defun lm-maybe-debug () + + (if lm-debug + (progn (lm-print-wts) (lm-blackbox) (lm-print-y,s,noise) + (lm-print-smell)))) + +;;;_ - Printing various things +(defun lm-print-distance-int (direction) + (interactive) + (insert (format "%S %S " direction (get direction 'distance)))) + + +(defun lm-print-distance () + (insert (format "tree: %S \n" (calc-distance-of-robot-from 'lm-tree))) + (mapc 'lm-print-distance-int lm-directions)) + + +;;(setq direction 'lm-n) +;;(get 'lm-n 'lm-s) +(defun lm-nslify-wts-int (direction) + (mapcar '(lambda (target-direction) + (get direction target-direction)) + lm-directions)) + + +(defun lm-nslify-wts () + (interactive) + (let ((l (apply 'append (mapcar 'lm-nslify-wts-int lm-directions)))) + (insert (format "set data_value WTS \n %s \n" l)) + (insert (format "/* max: %S min: %S */" + (eval (cons 'max l)) (eval (cons 'min l)))))) + +(defun lm-print-wts-int (direction) + (mapc '(lambda (target-direction) + (insert (format "%S %S %S " + direction + target-direction + (get direction target-direction)))) + lm-directions) + (insert "\n")) + +(defun lm-print-wts () + (interactive) + (save-excursion + (set-buffer "*lm-wts*") + (insert "==============================\n") + (mapc 'lm-print-wts-int lm-directions))) + +(defun lm-print-moves (moves) + (interactive) + (save-excursion + (set-buffer "*lm-moves*") + (insert (format "%S\n" moves)))) + + +(defun lm-print-y,s,noise-int (direction) + (insert (format "%S:lm-y %S, s %S, noise %S \n" + (symbol-name direction) + (get direction 'y_t) + (get direction 's) + (get direction 'noise) + ))) + +(defun lm-print-y,s,noise () + (interactive) + (save-excursion + (set-buffer "*lm-y,s,noise*") + (insert "==============================\n") + (mapc 'lm-print-y,s,noise-int lm-directions))) + +(defun lm-print-smell-int (direction) + (insert (format "%S: smell: %S \n" + (symbol-name direction) + (get direction 'smell)))) + +(defun lm-print-smell () + (interactive) + (save-excursion + (set-buffer "*lm-smell*") + (insert "==============================\n") + (insert (format "tree: %S \n" (get 'z 't))) + (mapc 'lm-print-smell-int lm-directions))) + +(defun lm-print-w0-int (direction) + (insert (format "%S: w0: %S \n" + (symbol-name direction) + (get direction 'w0)))) + +(defun lm-print-w0 () + (interactive) + (save-excursion + (set-buffer "*lm-w0*") + (insert "==============================\n") + (mapc 'lm-print-w0-int lm-directions))) + +(defun lm-blackbox () + (save-excursion + (set-buffer "*lm-blackbox*") + (insert "==============================\n") + (insert "I smell: ") + (mapc '(lambda (direction) + (if (> (get direction 'smell) 0) + (insert (format "%S " direction)))) + lm-directions) + (insert "\n") + + (insert "I move: ") + (mapc '(lambda (direction) + (if (> (get direction 'y_t) 0) + (insert (format "%S " direction)))) + lm-directions) + (insert "\n") + (lm-print-wts-blackbox) + (insert (format "z_t-z_t-1: %S" (- (get 'z 't) (get 'z 't-1)))) + (lm-print-distance) + (insert "\n"))) + +(defun lm-print-wts-blackbox () + (interactive) + (mapc 'lm-print-wts-int lm-directions)) + + + + + +;;;_ + Simulation variables + +;;;_ - lm-nvar +(defvar lm-nvar 0.0075 "affects a noise generator which was used in an +earlier incarnation of this program to add a random element to the way +moves were made. not used") +;;;_ - lists of cardinal directions +;;;_ : +(defvar lm-ns '(lm-n lm-s) "used when doing something relative to the + north and south axes") +(defvar lm-ew '(lm-e lm-w) "used when doing something relative to the + north and south axes") +(defvar lm-directions '(lm-n lm-s lm-e lm-w) "the cardinal directions") +(defvar lm-8-directions '( + (lm-n) (lm-n lm-w) (lm-s) + (lm-s lm-w) (lm-e) (lm-s lm-e) + (lm-n lm-w) (lm-w)) + "the full 8 possible directions.") +;;;_ - learning parameters +(defvar lm-bound 0.005 "the maximum that w0j may be.") +(defvar lm-c 1.0 "a factor applied to modulate the increase in +wij. used in the function lm-update-normal-weights") +(defvar lm-c-naught 0.5 "a factor applied to modulate the increase in +w0j. used in the function lm-update-naught-weights" ) +(defvar lm-initial-w0 0.0) +(defvar lm-initial-wij 0.0) +(defvar lm-no-payoff 0 "the amount of simulation cycles that have +occurred with no movement. used to move the robot when he is stuck in +a rut for some reason") +(defvar lm-max-stall-time 3 "the maximum of amount of simulation +cycles that the robot can get stuck in a place before lm-random-move +is called to push him out of it") + + + + + + + +;;;_ + Randomizing functions +;;;_ - lm-flip-a-coin () +(defun lm-flip-a-coin () + (if (> (random 5000) 2500) + -1 + 1)) +;;;_ : lm-very-small-random-number () +(defun lm-very-small-random-number () + (/ + (* (/ (random 900000) 900000.0) .0001))) +;;;_ : lm-randomize-weights-for (direction) +(defun lm-randomize-weights-for (direction) + (mapc '(lambda (target-direction) + (put direction + target-direction + (* (lm-flip-a-coin) (/ (random 10000) 10000.0)))) + lm-directions)) +;;;_ : lm-noise () +(defun lm-noise () + (* (- (/ (random 30001) 15000.0) 1) lm-nvar)) + +(defun lm-randomize-weights-for (direction) + (mapc '(lambda (target-direction) + (put direction + target-direction + (* (lm-flip-a-coin) (/ (random 10000) 10000.0)))) + lm-directions)) + + + + +;;;_ : lm-fix-weights-for (direction) +(defun lm-fix-weights-for (direction) + (mapc '(lambda (target-direction) + (put direction + target-direction + lm-initial-wij)) + lm-directions)) + + + + +;;;_ + Plotting functions +;;;_ - lm-plot-internal (sym) +(defun lm-plot-internal (sym) + (lm-plot-square (lm-xy-to-index + (get sym 'x) + (get sym 'y)) + (get sym 'sym))) +;;;_ - lm-plot-landmarks () +(defun lm-plot-landmarks () + (setq lm-cx (/ lm-board-width 2)) + (setq lm-cy (/ lm-board-height 2)) + + (put 'lm-n 'x lm-cx) + (put 'lm-n 'y 1) + (put 'lm-n 'sym 2) + + (put 'lm-tree 'x lm-cx) + (put 'lm-tree 'y lm-cy) + (put 'lm-tree 'sym 6) + + (put 'lm-s 'x lm-cx) + (put 'lm-s 'y lm-board-height) + (put 'lm-s 'sym 3) + + (put 'lm-w 'x 1) + (put 'lm-w 'y (/ lm-board-height 2)) + (put 'lm-w 'sym 5) + + (put 'lm-e 'x lm-board-width) + (put 'lm-e 'y (/ lm-board-height 2)) + (put 'lm-e 'sym 4) + + (mapc 'lm-plot-internal '(lm-n lm-s lm-e lm-w lm-tree))) + + + +;;;_ + Distance-calculation functions +;;;_ - square (a) +(defun square (a) + (* a a)) + +;;;_ - distance (x x0 y y0) +(defun distance (x x0 y y0) + (sqrt (+ (square (- x x0)) (square (- y y0))))) + +;;;_ - calc-distance-of-robot-from (direction) +(defun calc-distance-of-robot-from (direction) + (put direction 'distance + (distance (get direction 'x) + (lm-index-to-x (lm-point-square)) + (get direction 'y) + (lm-index-to-y (lm-point-square))))) + +;;;_ - calc-smell-internal (sym) +(defun calc-smell-internal (sym) + (let ((r (get sym 'r)) + (d (calc-distance-of-robot-from sym))) + (if (> (* 0.5 (- 1 (/ d r))) 0) + (* 0.5 (- 1 (/ d r))) + 0))) + + + +;;;_ + Learning (neural) functions +(defun lm-f (x) + (cond + ((> x lm-bound) lm-bound) + ((< x 0.0) 0.0) + (t x))) + +(defun lm-y (direction) + (let ((noise (put direction 'noise (lm-noise)))) + (put direction 'y_t + (if (> (get direction 's) 0.0) + 1.0 + 0.0)))) + +(defun lm-update-normal-weights (direction) + (mapc '(lambda (target-direction) + (put direction target-direction + (+ + (get direction target-direction) + (* lm-c + (- (get 'z 't) (get 'z 't-1)) + (get target-direction 'y_t) + (get direction 'smell))))) + lm-directions)) + +(defun lm-update-naught-weights (direction) + (mapc '(lambda (target-direction) + (put direction 'w0 + (lm-f + (+ + (get direction 'w0) + (* lm-c-naught + (- (get 'z 't) (get 'z 't-1)) + (get direction 'y_t)))))) + lm-directions)) + + + +;;;_ + Statistics gathering and creating functions + +(defun lm-calc-current-smells () + (mapc '(lambda (direction) + (put direction 'smell (calc-smell-internal direction))) + lm-directions)) + +(defun lm-calc-payoff () + (put 'z 't-1 (get 'z 't)) + (put 'z 't (calc-smell-internal 'lm-tree)) + (if (= (- (get 'z 't) (get 'z 't-1)) 0.0) + (incf lm-no-payoff) + (setf lm-no-payoff 0))) + +(defun lm-store-old-y_t () + (mapc '(lambda (direction) + (put direction 'y_t-1 (get direction 'y_t))) + lm-directions)) + + + +;;;_ + Functions to move robot + + +(defun lm-confidence-for (target-direction) + (+ + (get target-direction 'w0) + (reduce '+ + (mapcar '(lambda (direction) + (* + (get direction target-direction) + (get direction 'smell)) + ) + lm-directions)))) + + +(defun lm-calc-confidences () + (mapc '(lambda (direction) + (put direction 's (lm-confidence-for direction))) + lm-directions)) + +(defun lm-move () + (if (and (= (get 'lm-n 'y_t) 1.0) (= (get 'lm-s 'y_t) 1.0)) + (progn + (mapc '(lambda (dir) (put dir 'y_t 0)) lm-ns) + (message "n-s normalization."))) + (if (and (= (get 'lm-w 'y_t) 1.0) (= (get 'lm-e 'y_t) 1.0)) + (progn + (mapc '(lambda (dir) (put dir 'y_t 0)) lm-ew) + (message "e-w normalization"))) + + (mapc '(lambda (pair) + (if (> (get (car pair) 'y_t) 0) + (funcall (car (cdr pair))))) + '( + (lm-n lm-move-up) + (lm-s lm-move-down) + (lm-e forward-char) + (lm-w backward-char))) + (lm-plot-square (lm-point-square) 1) + (incf lm-moves)) + + +(defun lm-random-move () + (mapc + '(lambda (direction) (put direction 'y_t 0)) + lm-directions) + (dolist (direction (nth (random 8) lm-8-directions)) + (put direction 'y_t 1.0)) + (lm-move)) + +(defun lm-amble-robot () + (interactive) + (while (> (calc-distance-of-robot-from 'lm-tree) 0) + + (lm-store-old-y_t) + (lm-calc-current-smells) + + (if (> lm-no-payoff lm-max-stall-time) + (lm-random-move) + (progn + (lm-calc-confidences) + (mapc 'lm-y lm-directions) + (lm-move))) + + (lm-calc-payoff) + + (mapc 'lm-update-normal-weights lm-directions) + (mapc 'lm-update-naught-weights lm-directions) + (lm-maybe-debug)) + + (let ((lm-res-str (format "%S moves." lm-moves))) + (if lm-debug + (lm-print-moves lm-res-str)) + (message (format "%S moves." lm-moves)))) + +;;;_ - lm-start-robot () +(defun lm-start-robot () + "Signal to the Lm program that you have played. +You must have put the cursor on the square where you want to play. +If the game is finished, this command requests for another game." + (interactive) + (lm-switch-to-window) + (cond + (lm-emacs-is-computing + (lm-crash-game)) + ((not lm-game-in-progress) + (lm-prompt-for-other-game)) + (t + (let (square score) + (setq square (lm-point-square)) + (cond ((null square) + (error "Your point is not on a square. Retry !")) + ((not (zerop (aref lm-board square))) + (error "Your point is not on a free square. Retry !")) + (t + (progn + (lm-plot-square square 1) + + (lm-store-old-y_t) + (lm-calc-current-smells) + (put 'z 't (calc-smell-internal 'lm-tree)) + + (lm-random-move) + + (lm-calc-payoff) + + (mapc 'lm-update-normal-weights lm-directions) + (mapc 'lm-update-naught-weights lm-directions) + (lm-maybe-debug) + (lm-amble-robot) + ))))))) + + + +;;;_ + Misc functions +;;;_ - lm-init (auto-start save-weights) +(defun lm-init (auto-start save-weights) + + (setq lm-moves 0) + + (lm-plot-landmarks) + + (if lm-debug + (progn + (save-excursion + (set-buffer (get-buffer-create "*lm-w0*")) + (erase-buffer) + (set-buffer (get-buffer-create "*lm-moves*")) + (set-buffer (get-buffer-create "*lm-wts*")) + (erase-buffer) + (set-buffer (get-buffer-create "*lm-y,s,noise*")) + (erase-buffer) + (set-buffer (get-buffer-create "*lm-smell*")) + (erase-buffer) + (set-buffer (get-buffer-create "*lm-blackbox*")) + (erase-buffer) + (set-buffer (get-buffer-create "*lm-distance*")) + (erase-buffer)))) + + + (lm-set-landmark-signal-strengths) + + (mapc '(lambda (direction) + (put direction 'y_t 0.0)) + lm-directions) + + (if (not save-weights) + (progn + (mapc 'lm-fix-weights-for lm-directions) + (mapc '(lambda (direction) + (put direction 'w0 lm-initial-w0)) + lm-directions)) + (message "Weights preserved for this run.")) + + (if auto-start + (progn + (lm-goto-xy (1+ (random lm-board-width)) (1+ (random lm-board-height))) + (lm-start-robot)))) + + + +;;;_ - something which doesn't work +; no-a-worka!! +;(defum lm-sum-list (list) +; (if (> (length list) 0) +; (+ (car list) (lm-sum-list (cdr list))) +; 0)) +; this a worka! +; (eval (cons '+ list)) +;;;_ - lm-set-landmark-signal-strengths () +;;; on a screen higher than wide, I noticed that the robot would amble +;;; left and right and not move forward. examining *lm-blackbox* +;;; revealed that there was no scent from the north and south +;;; landmarks, hence, they need less factoring down of the effect of +;;; distance on scent. + +(defun lm-set-landmark-signal-strengths () + + (setq lm-tree-r (* (sqrt (+ (square lm-cx) (square lm-cy))) 1.5)) + + (mapc '(lambda (direction) + (put direction 'r (* lm-cx 1.1))) + lm-ew) + (mapc '(lambda (direction) + (put direction 'r (* lm-cy 1.1))) + lm-ns) + (put 'lm-tree 'r lm-tree-r)) + + + + + +;;;_ + lm-test-run () + +(defun lm-test-run () + + (interactive) + + (lm 1) + + (dotimes (scratch-var 100) + + (lm 2))) + + + +;;;_ + lm: The function you invoke to play + +;;;###autoload +(defun landmark (parg) + "Start an Lm game. +If a game is in progress, this command allows you to resume it. +Here is the relation between prefix args and game options: + +prefix arg | robot is auto-started | weights are saved from last game +--------------------------------------------------------------------- +none / 1 | yes | no + 2 | yes | yes + 3 | no | yes + 4 | no | no + +You start by moving to a square and typing \\[lm-start-robot]. +Use \\[describe-mode] for more info." + (interactive "p") + + (setf n nil m nil) + (lm-switch-to-window) + (cond + (lm-emacs-is-computing + (lm-crash-game)) + ((or (not lm-game-in-progress) + (<= lm-number-of-moves 2)) + (let ((max-width (lm-max-width)) + (max-height (lm-max-height))) + (or n (setq n max-width)) + (or m (setq m max-height)) + (cond ((< n 1) + (error "I need at least 1 column")) + ((< m 1) + (error "I need at least 1 row")) + ((> n max-width) + (error "I cannot display %d columns in that window" n))) + (if (and (> m max-height) + (not (eq m lm-saved-board-height)) + ;; Use EQ because SAVED-BOARD-HEIGHT may be nil + (not (y-or-n-p (format "Do you really want %d rows " m)))) + (setq m max-height))) + (message "One moment, please...") + (lm-start-game n m))) + (eval (cons 'lm-init + (cond + ((= parg 1) '(t nil)) + ((= parg 2) '(t t)) + ((= parg 3) '(nil t)) + ((= parg 4) '(nil nil)) + (t '(nil t)))))) + +;;;_ + Local variables + +;;; The following `outline-layout' local variable setting: +;;; - closes all topics from the first topic to just before the third-to-last, +;;; - shows the children of the third to last (config vars) +;;; - and the second to last (code section), +;;; - and closes the last topic (this local-variables section). +;;;Local variables: +;;;outline-layout: (0 : -1 -1 0) +;;;End: + + +;;; landmark.el ends here