--- /dev/null
+;;; 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
+;;;_* 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
projects / emacs.git / commitdiff