;;; landmark.el --- neural-network robot that learns landmarks
-;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
-;; Author: Terrence Brannon <brannon@rana.usc.edu>
+;; Author: Terrence Brannon (was: <brannon@rana.usc.edu>)
;; Created: December 16, 1996 - first release to usenet
-;; Keywords: gomoku neural network adaptive search chemotaxis
+;; Keywords: gomoku, neural network, adaptive search, chemotaxis
;;;_* Usage
;;; Just type
-;;; M-x eval-current-buffer
+;;; M-x eval-buffer
;;; M-x lm-test-run
;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
-;;;_* Commentary
+;;; 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
;;; 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/~brannon/warez/yours-truly/lm/
;;; Many thanks to Yuri Pryadkin (yuri@rana.usc.edu) for this
;;; concise problem description.
-;;;_* Provide
-
-(provide 'lm)
-
;;;_* Require
-(require 'cl)
+(eval-when-compile (require 'cl))
;;;_* From Gomoku
+;;; Code:
+
(defgroup lm nil
"Neural-network robot that learns landmarks."
:prefix "lm-"
;; 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
+;; 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
(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)))
+ (define-key lm-mode-map [remap previous-line] 'lm-move-up)
+ (define-key lm-mode-map [remap next-line] 'lm-move-down)
+ (define-key lm-mode-map [remap beginning-of-line] 'lm-beginning-of-line)
+ (define-key lm-mode-map [remap end-of-line] 'lm-end-of-line)
+ (define-key lm-mode-map [remap undo] 'lm-human-takes-back)
+ (define-key lm-mode-map [remap advertised-undo] 'lm-human-takes-back))
(defvar lm-emacs-won ()
"*For making font-lock use the winner's face for the line.")
-(defvar lm-font-lock-face-O
- (if window-system
- (list (facemenu-get-face 'fg:red) 'bold))
- "*Face to use for Emacs' O.")
+(defface lm-font-lock-face-O '((((class color)) :foreground "red")
+ (t :weight bold))
+ "*Face to use for Emacs' O."
+ :version "22.1"
+ :group 'lm)
-(defvar lm-font-lock-face-X
- (if window-system
- (list (facemenu-get-face 'fg:green) 'bold))
- "*Face to use for your X.")
+(defface lm-font-lock-face-X '((((class color)) :foreground "green")
+ (t :weight bold))
+ "*Face to use for your X."
+ :version "22.1"
+ :group 'lm)
(defvar lm-font-lock-keywords
- '(("O" . lm-font-lock-face-O)
- ("X" . lm-font-lock-face-X)
+ '(("O" . 'lm-font-lock-face-O)
+ ("X" . 'lm-font-lock-face-X)
("[-|/\\]" 0 (if lm-emacs-won
- lm-font-lock-face-O
- lm-font-lock-face-X)))
+ 'lm-font-lock-face-O
+ 'lm-font-lock-face-X)))
"*Font lock rules for Lm.")
(put 'lm-mode 'front-sticky
(put 'lm-mode 'rear-nonsticky '(intangible)))
(put 'lm-mode 'intangible 1)
+;; This one is for when they set view-read-only to t: Landmark cannot
+;; allow View Mode to be activated in its buffer.
+(put 'lm-mode 'mode-class 'special)
(defun lm-mode ()
"Major mode for playing Lm against Emacs.
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)
+ (kill-all-local-variables)
(setq major-mode 'lm-mode
mode-name "Lm")
(lm-display-statistics)
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults '(lm-font-lock-keywords t))
(toggle-read-only t)
- (run-hooks 'lm-mode-hook))
+ (run-mode-hooks 'lm-mode-hook))
;;;_ + THE SCORE TABLE.
(let (square score)
(setq square (lm-point-square))
(cond ((null square)
- (error "Your point is not on a square. Retry !"))
+ (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 !"))
+ (error "Your point is not on a free square. Retry!"))
(t
(setq score (aref lm-score-table square))
(lm-play-move square 1)
(sit-for 4)
(lm-prompt-for-other-game))
((zerop lm-number-of-human-moves)
- (message "You have not played yet... Your move ?"))
+ (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
(lm-crash-game))
((not lm-game-in-progress)
(message "There is no game in progress"))
- ((y-or-n-p "You mean, you resign ")
+ ((y-or-n-p "You mean, you resign? ")
(lm-terminate-game 'human-resigned))
- ((y-or-n-p "You mean, we continue ")
+ ((y-or-n-p "You mean, we continue? ")
(lm-prompt-for-move))
(t
(lm-terminate-game 'human-resigned)))) ; OK. Accept it
(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 ?"))
+ "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 ")
+ (if (y-or-n-p "Another game? ")
(if (y-or-n-p "Retain learned weights ")
(lm 2)
(lm 1))
- (message "Chicken !")))
+ (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 ")
+ (or (y-or-n-p "I offer you a draw. Do you accept it? ")
(not (setq lm-human-refused-draw t))))
((= value 5) ?W)
((= value 6) ?^)))
- (and window-system
- (zerop value)
- (put-text-property (1- (point)) (point) 'mouse-face 'highlight))
+ (and (zerop value)
+ (add-text-properties (1- (point)) (point)
+ '(mouse-face highlight
+ help-echo "\
+mouse-1: get robot moving, mouse-2: play on this square")))
(delete-char 1)
(backward-char 1))
(sit-for 0)) ; Display NOW
(goto-char (point-max))))
(setq point (point))
(insert ?=)
- (if window-system
- (put-text-property point (point)
- 'mouse-face 'highlight)))
+ (add-text-properties point (point)
+ '(mouse-face highlight help-echo "\
+mouse-1: get robot moving, mouse-2: play on this square")))
(> (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)))))
+ (lambda (x y) (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))))
+ (lambda (x y) (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
(move-to-column (+ lm-x-offset
(* lm-square-width (1- lm-board-width)))))
-(provide 'lm)
-
;;;_ + Simulation variables
;;;_* Terry's mods to create lm.el
-;;;_ + Debugging things
-(setq debug-on-error t)
;;;(setq lm-debug nil)
(defvar lm-debug nil
"If non-nil, debugging is printed.")
;;(setq direction 'lm-n)
;;(get 'lm-n 'lm-s)
(defun lm-nslify-wts-int (direction)
- (mapcar '(lambda (target-direction)
+ (mapcar (lambda (target-direction)
(get direction target-direction))
lm-directions))
(eval (cons 'max l)) (eval (cons 'min l))))))
(defun lm-print-wts-int (direction)
- (mapc '(lambda (target-direction)
+ (mapc (lambda (target-direction)
(insert (format "%S %S %S "
direction
target-direction
(set-buffer "*lm-blackbox*")
(insert "==============================\n")
(insert "I smell: ")
- (mapc '(lambda (direction)
+ (mapc (lambda (direction)
(if (> (get direction 'smell) 0)
(insert (format "%S " direction))))
lm-directions)
(insert "\n")
(insert "I move: ")
- (mapc '(lambda (direction)
+ (mapc (lambda (direction)
(if (> (get direction 'y_t) 0)
(insert (format "%S " direction))))
lm-directions)
; (* (/ (random 900000) 900000.0) .0001)))
;;;_ : lm-randomize-weights-for (direction)
(defun lm-randomize-weights-for (direction)
- (mapc '(lambda (target-direction)
+ (mapc (lambda (target-direction)
(put direction
target-direction
(* (lm-flip-a-coin) (/ (random 10000) 10000.0))))
;;;_ : lm-fix-weights-for (direction)
(defun lm-fix-weights-for (direction)
- (mapc '(lambda (target-direction)
+ (mapc (lambda (target-direction)
(put direction
target-direction
lm-initial-wij))
0.0))))
(defun lm-update-normal-weights (direction)
- (mapc '(lambda (target-direction)
+ (mapc (lambda (target-direction)
(put direction target-direction
(+
(get direction target-direction)
lm-directions))
(defun lm-update-naught-weights (direction)
- (mapc '(lambda (target-direction)
+ (mapc (lambda (target-direction)
(put direction 'w0
(lm-f
(+
;;;_ + Statistics gathering and creating functions
(defun lm-calc-current-smells ()
- (mapc '(lambda (direction)
+ (mapc (lambda (direction)
(put direction 'smell (calc-smell-internal direction)))
lm-directions))
(setf lm-no-payoff 0)))
(defun lm-store-old-y_t ()
- (mapc '(lambda (direction)
+ (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))))
+ (apply '+
+ (get target-direction 'w0)
+ (mapcar (lambda (direction)
+ (*
+ (get direction target-direction)
+ (get direction 'smell)))
+ lm-directions)))
(defun lm-calc-confidences ()
- (mapc '(lambda (direction)
+ (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)
+ (mapc (lambda (dir) (put dir 'y_t 0)) lm-ns)
(if lm-debug
(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)
+ (mapc (lambda (dir) (put dir 'y_t 0)) lm-ew)
(if lm-debug
(message "e-w normalization"))))
- (mapc '(lambda (pair)
+ (mapc (lambda (pair)
(if (> (get (car pair) 'y_t) 0)
(funcall (car (cdr pair)))))
'(
(lm-plot-square (lm-point-square) 1)
(incf lm-number-of-moves)
(if lm-output-moves
- (message (format "Moves made: %d" lm-number-of-moves))))
+ (message "Moves made: %d" lm-number-of-moves)))
(defun lm-random-move ()
(mapc
- '(lambda (direction) (put direction 'y_t 0))
+ (lambda (direction) (put direction 'y_t 0))
lm-directions)
(dolist (direction (nth (random 8) lm-8-directions))
(put direction 'y_t 1.0))
(let (square score)
(setq square (lm-point-square))
(cond ((null square)
- (error "Your point is not on a square. Retry !"))
+ (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 !"))
+ (error "Your point is not on a free square. Retry!"))
(t
(progn
(lm-plot-square square 1)
(lm-set-landmark-signal-strengths)
- (mapc '(lambda (direction)
+ (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)
+ (mapc (lambda (direction)
(put direction 'w0 lm-initial-w0))
lm-directions))
(message "Weights preserved for this run."))
(setq lm-tree-r (* (sqrt (+ (square lm-cx) (square lm-cy))) 1.5))
- (mapc '(lambda (direction)
+ (mapc (lambda (direction)
(put direction 'r (* lm-cx 1.1)))
lm-ew)
- (mapc '(lambda (direction)
+ (mapc (lambda (direction)
(put direction 'r (* lm-cy 1.1)))
lm-ns)
(put 'lm-tree 'r lm-tree-r))
(if (and (> lm-m max-height)
(not (eq lm-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 " lm-m))))
+ (not (y-or-n-p (format "Do you really want %d rows? " lm-m))))
(setq lm-m max-height)))
(if lm-one-moment-please
(message "One moment, please..."))
;;;_ + Local variables
-;;; The following `outline-layout' local variable setting:
+;;; The following `allout-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)
+;;;allout-layout: (0 : -1 -1 0)
;;;End:
+(provide 'landmark)
+
+;;; arch-tag: ae5031be-96e6-459e-a3df-1df53117d3f2
;;; landmark.el ends here