1;;; landmark.el --- neural-network robot that learns landmarks 2 3;; Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Terrence Brannon (was: <brannon@rana.usc.edu>) 7;; Created: December 16, 1996 - first release to usenet 8;; Keywords: gomoku, neural network, adaptive search, chemotaxis 9 10;;;_* Usage 11;;; Just type 12;;; M-x eval-buffer 13;;; M-x lm-test-run 14 15 16;; This file is part of GNU Emacs. 17 18;; GNU Emacs is free software; you can redistribute it and/or modify 19;; it under the terms of the GNU General Public License as published by 20;; the Free Software Foundation; either version 2, or (at your option) 21;; any later version. 22 23;; GNU Emacs is distributed in the hope that it will be useful, 24;; but WITHOUT ANY WARRANTY; without even the implied warranty of 25;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 26;; GNU General Public License for more details. 27 28;; You should have received a copy of the GNU General Public License 29;; along with GNU Emacs; see the file COPYING. If not, write to the 30;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 31;; Boston, MA 02110-1301, USA. 32 33 34;;; Commentary: 35;;; Lm is a relatively non-participatory game in which a robot 36;;; attempts to maneuver towards a tree at the center of the window 37;;; based on unique olfactory cues from each of the 4 directions. If 38;;; the smell of the tree increases, then the weights in the robot's 39;;; brain are adjusted to encourage this odor-driven behavior in the 40;;; future. If the smell of the tree decreases, the robots weights are 41;;; adjusted to discourage a correct move. 42 43;;; In laymen's terms, the search space is initially flat. The point 44;;; of training is to "turn up the edges of the search space" so that 45;;; the robot rolls toward the center. 46 47;;; Further, do not become alarmed if the robot appears to oscillate 48;;; back and forth between two or a few positions. This simply means 49;;; it is currently caught in a local minimum and is doing its best to 50;;; work its way out. 51 52;;; The version of this program as described has a small problem. a 53;;; move in a net direction can produce gross credit assignment. for 54;;; example, if moving south will produce positive payoff, then, if in 55;;; a single move, one moves east,west and south, then both east and 56;;; west will be improved when they shouldn't 57 58;;; Many thanks to Yuri Pryadkin (yuri@rana.usc.edu) for this 59;;; concise problem description. 60 61;;;_* Require 62(eval-when-compile (require 'cl)) 63 64;;;_* From Gomoku 65 66;;; Code: 67 68(defgroup lm nil 69 "Neural-network robot that learns landmarks." 70 :prefix "lm-" 71 :group 'games) 72 73;;;_ + THE BOARD. 74 75;; The board is a rectangular grid. We code empty squares with 0, X's with 1 76;; and O's with 6. The rectangle is recorded in a one dimensional vector 77;; containing padding squares (coded with -1). These squares allow us to 78;; detect when we are trying to move out of the board. We denote a square by 79;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The 80;; leftmost topmost square has coords (1,1) and index lm-board-width + 2. 81;; Similarly, vectors between squares may be given by two DX, DY coords or by 82;; one DEPL (the difference between indexes). 83 84(defvar lm-board-width nil 85 "Number of columns on the Lm board.") 86(defvar lm-board-height nil 87 "Number of lines on the Lm board.") 88 89(defvar lm-board nil 90 "Vector recording the actual state of the Lm board.") 91 92(defvar lm-vector-length nil 93 "Length of lm-board vector.") 94 95(defvar lm-draw-limit nil 96 ;; This is usually set to 70% of the number of squares. 97 "After how many moves will Emacs offer a draw?") 98 99(defvar lm-cx 0 100 "This is the x coordinate of the center of the board.") 101 102(defvar lm-cy 0 103 "This is the y coordinate of the center of the board.") 104 105(defvar lm-m 0 106 "This is the x dimension of the playing board.") 107 108(defvar lm-n 0 109 "This is the y dimension of the playing board.") 110 111 112(defun lm-xy-to-index (x y) 113 "Translate X, Y cartesian coords into the corresponding board index." 114 (+ (* y lm-board-width) x y)) 115 116(defun lm-index-to-x (index) 117 "Return corresponding x-coord of board INDEX." 118 (% index (1+ lm-board-width))) 119 120(defun lm-index-to-y (index) 121 "Return corresponding y-coord of board INDEX." 122 (/ index (1+ lm-board-width))) 123 124(defun lm-init-board () 125 "Create the lm-board vector and fill it with initial values." 126 (setq lm-board (make-vector lm-vector-length 0)) 127 ;; Every square is 0 (i.e. empty) except padding squares: 128 (let ((i 0) (ii (1- lm-vector-length))) 129 (while (<= i lm-board-width) ; The squares in [0..width] and in 130 (aset lm-board i -1) ; [length - width - 1..length - 1] 131 (aset lm-board ii -1) ; are padding squares. 132 (setq i (1+ i) 133 ii (1- ii)))) 134 (let ((i 0)) 135 (while (< i lm-vector-length) 136 (aset lm-board i -1) ; and also all k*(width+1) 137 (setq i (+ i lm-board-width 1))))) 138 139;;;_ + DISPLAYING THE BOARD. 140 141;; You may change these values if you have a small screen or if the squares 142;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1). 143 144(defconst lm-square-width 2 145 "*Horizontal spacing between squares on the Lm board.") 146 147(defconst lm-square-height 1 148 "*Vertical spacing between squares on the Lm board.") 149 150(defconst lm-x-offset 3 151 "*Number of columns between the Lm board and the side of the window.") 152 153(defconst lm-y-offset 1 154 "*Number of lines between the Lm board and the top of the window.") 155 156 157;;;_ + LM MODE AND KEYMAP. 158 159(defcustom lm-mode-hook nil 160 "If non-nil, its value is called on entry to Lm mode." 161 :type 'hook 162 :group 'lm) 163 164(defvar lm-mode-map nil 165 "Local keymap to use in Lm mode.") 166 167(if lm-mode-map nil 168 (setq lm-mode-map (make-sparse-keymap)) 169 170 ;; Key bindings for cursor motion. 171 (define-key lm-mode-map "y" 'lm-move-nw) ; y 172 (define-key lm-mode-map "u" 'lm-move-ne) ; u 173 (define-key lm-mode-map "b" 'lm-move-sw) ; b 174 (define-key lm-mode-map "n" 'lm-move-se) ; n 175 (define-key lm-mode-map "h" 'backward-char) ; h 176 (define-key lm-mode-map "l" 'forward-char) ; l 177 (define-key lm-mode-map "j" 'lm-move-down) ; j 178 (define-key lm-mode-map "k" 'lm-move-up) ; k 179 180 (define-key lm-mode-map [kp-7] 'lm-move-nw) 181 (define-key lm-mode-map [kp-9] 'lm-move-ne) 182 (define-key lm-mode-map [kp-1] 'lm-move-sw) 183 (define-key lm-mode-map [kp-3] 'lm-move-se) 184 (define-key lm-mode-map [kp-4] 'backward-char) 185 (define-key lm-mode-map [kp-6] 'forward-char) 186 (define-key lm-mode-map [kp-2] 'lm-move-down) 187 (define-key lm-mode-map [kp-8] 'lm-move-up) 188 189 (define-key lm-mode-map "\C-n" 'lm-move-down) ; C-n 190 (define-key lm-mode-map "\C-p" 'lm-move-up) ; C-p 191 192 ;; Key bindings for entering Human moves. 193 (define-key lm-mode-map "X" 'lm-human-plays) ; X 194 (define-key lm-mode-map "x" 'lm-human-plays) ; x 195 196 (define-key lm-mode-map " " 'lm-start-robot) ; SPC 197 (define-key lm-mode-map [down-mouse-1] 'lm-start-robot) 198 (define-key lm-mode-map [drag-mouse-1] 'lm-click) 199 (define-key lm-mode-map [mouse-1] 'lm-click) 200 (define-key lm-mode-map [down-mouse-2] 'lm-click) 201 (define-key lm-mode-map [mouse-2] 'lm-mouse-play) 202 (define-key lm-mode-map [drag-mouse-2] 'lm-mouse-play) 203 204 (define-key lm-mode-map [remap previous-line] 'lm-move-up) 205 (define-key lm-mode-map [remap next-line] 'lm-move-down) 206 (define-key lm-mode-map [remap beginning-of-line] 'lm-beginning-of-line) 207 (define-key lm-mode-map [remap end-of-line] 'lm-end-of-line) 208 (define-key lm-mode-map [remap undo] 'lm-human-takes-back) 209 (define-key lm-mode-map [remap advertised-undo] 'lm-human-takes-back)) 210 211(defvar lm-emacs-won () 212 "*For making font-lock use the winner's face for the line.") 213 214(defface lm-font-lock-face-O '((((class color)) :foreground "red") 215 (t :weight bold)) 216 "*Face to use for Emacs' O." 217 :version "22.1" 218 :group 'lm) 219 220(defface lm-font-lock-face-X '((((class color)) :foreground "green") 221 (t :weight bold)) 222 "*Face to use for your X." 223 :version "22.1" 224 :group 'lm) 225 226(defvar lm-font-lock-keywords 227 '(("O" . 'lm-font-lock-face-O) 228 ("X" . 'lm-font-lock-face-X) 229 ("[-|/\\]" 0 (if lm-emacs-won 230 'lm-font-lock-face-O 231 'lm-font-lock-face-X))) 232 "*Font lock rules for Lm.") 233 234(put 'lm-mode 'front-sticky 235 (put 'lm-mode 'rear-nonsticky '(intangible))) 236(put 'lm-mode 'intangible 1) 237;; This one is for when they set view-read-only to t: Landmark cannot 238;; allow View Mode to be activated in its buffer. 239(put 'lm-mode 'mode-class 'special) 240 241(defun lm-mode () 242 "Major mode for playing Lm against Emacs. 243You and Emacs play in turn by marking a free square. You mark it with X 244and Emacs marks it with O. The winner is the first to get five contiguous 245marks horizontally, vertically or in diagonal. 246 247You play by moving the cursor over the square you choose and hitting \\[lm-human-plays]. 248 249Other useful commands: 250\\{lm-mode-map} 251Entry to this mode calls the value of `lm-mode-hook' if that value 252is non-nil. One interesting value is `turn-on-font-lock'." 253 (interactive) 254 (kill-all-local-variables) 255 (setq major-mode 'lm-mode 256 mode-name "Lm") 257 (lm-display-statistics) 258 (use-local-map lm-mode-map) 259 (make-local-variable 'font-lock-defaults) 260 (setq font-lock-defaults '(lm-font-lock-keywords t)) 261 (toggle-read-only t) 262 (run-mode-hooks 'lm-mode-hook)) 263 264 265;;;_ + THE SCORE TABLE. 266 267 268;; Every (free) square has a score associated to it, recorded in the 269;; LM-SCORE-TABLE vector. The program always plays in the square having 270;; the highest score. 271 272(defvar lm-score-table nil 273 "Vector recording the actual score of the free squares.") 274 275 276;; The key point point about the algorithm is that, rather than considering 277;; the board as just a set of squares, we prefer to see it as a "space" of 278;; internested 5-tuples of contiguous squares (called qtuples). 279;; 280;; The aim of the program is to fill one qtuple with its O's while preventing 281;; you from filling another one with your X's. To that effect, it computes a 282;; score for every qtuple, with better qtuples having better scores. Of 283;; course, the score of a qtuple (taken in isolation) is just determined by 284;; its contents as a set, i.e. not considering the order of its elements. The 285;; highest score is given to the "OOOO" qtuples because playing in such a 286;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because 287;; not playing in it is just loosing the game, and so on. Note that a 288;; "polluted" qtuple, i.e. one containing at least one X and at least one O, 289;; has score zero because there is no more any point in playing in it, from 290;; both an attacking and a defending point of view. 291;; 292;; Given the score of every qtuple, the score of a given free square on the 293;; board is just the sum of the scores of all the qtuples to which it belongs, 294;; because playing in that square is playing in all its containing qtuples at 295;; once. And it is that function which takes into account the internesting of 296;; the qtuples. 297;; 298;; This algorithm is rather simple but anyway it gives a not so dumb level of 299;; play. It easily extends to "n-dimensional Lm", where a win should not 300;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !) 301;; should be preferred. 302 303 304;; Here are the scores of the nine "non-polluted" configurations. Tuning 305;; these values will change (hopefully improve) the strength of the program 306;; and may change its style (rather aggressive here). 307 308(defconst nil-score 7 "Score of an empty qtuple.") 309(defconst Xscore 15 "Score of a qtuple containing one X.") 310(defconst XXscore 400 "Score of a qtuple containing two X's.") 311(defconst XXXscore 1800 "Score of a qtuple containing three X's.") 312(defconst XXXXscore 100000 "Score of a qtuple containing four X's.") 313(defconst Oscore 35 "Score of a qtuple containing one O.") 314(defconst OOscore 800 "Score of a qtuple containing two O's.") 315(defconst OOOscore 15000 "Score of a qtuple containing three O's.") 316(defconst OOOOscore 800000 "Score of a qtuple containing four O's.") 317 318;; These values are not just random: if, given the following situation: 319;; 320;; . . . . . . . O . 321;; . X X a . . . X . 322;; . . . X . . . X . 323;; . . . X . . . X . 324;; . . . . . . . b . 325;; 326;; you want Emacs to play in "a" and not in "b", then the parameters must 327;; satisfy the inequality: 328;; 329;; 6 * XXscore > XXXscore + XXscore 330;; 331;; because "a" mainly belongs to six "XX" qtuples (the others are less 332;; important) while "b" belongs to one "XXX" and one "XX" qtuples. Other 333;; conditions are required to obtain sensible moves, but the previous example 334;; should illustrate the point. If you manage to improve on these values, 335;; please send me a note. Thanks. 336 337 338;; As we chose values 0, 1 and 6 to denote empty, X and O squares, the 339;; contents of a qtuple are uniquely determined by the sum of its elements and 340;; we just have to set up a translation table. 341 342(defconst lm-score-trans-table 343 (vector nil-score Xscore XXscore XXXscore XXXXscore 0 344 Oscore 0 0 0 0 0 345 OOscore 0 0 0 0 0 346 OOOscore 0 0 0 0 0 347 OOOOscore 0 0 0 0 0 348 0) 349 "Vector associating qtuple contents to their score.") 350 351 352;; If you do not modify drastically the previous constants, the only way for a 353;; square to have a score higher than OOOOscore is to belong to a "OOOO" 354;; qtuple, thus to be a winning move. Similarly, the only way for a square to 355;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX" 356;; qtuple. We may use these considerations to detect when a given move is 357;; winning or loosing. 358 359(defconst lm-winning-threshold OOOOscore 360 "Threshold score beyond which an Emacs move is winning.") 361 362(defconst lm-loosing-threshold XXXXscore 363 "Threshold score beyond which a human move is winning.") 364 365 366(defun lm-strongest-square () 367 "Compute index of free square with highest score, or nil if none." 368 ;; We just have to loop other all squares. However there are two problems: 369 ;; 1/ The SCORE-TABLE only gives correct scores to free squares. To speed 370 ;; up future searches, we set the score of padding or occupied squares 371 ;; to -1 whenever we meet them. 372 ;; 2/ We want to choose randomly between equally good moves. 373 (let ((score-max 0) 374 (count 0) ; Number of equally good moves 375 (square (lm-xy-to-index 1 1)) ; First square 376 (end (lm-xy-to-index lm-board-width lm-board-height)) 377 best-square score) 378 (while (<= square end) 379 (cond 380 ;; If score is lower (i.e. most of the time), skip to next: 381 ((< (aref lm-score-table square) score-max)) 382 ;; If score is better, beware of non free squares: 383 ((> (setq score (aref lm-score-table square)) score-max) 384 (if (zerop (aref lm-board square)) ; is it free ? 385 (setq count 1 ; yes: take it ! 386 best-square square 387 score-max score) 388 (aset lm-score-table square -1))) ; no: kill it ! 389 ;; If score is equally good, choose randomly. But first check freeness: 390 ((not (zerop (aref lm-board square))) 391 (aset lm-score-table square -1)) 392 ((zerop (random (setq count (1+ count)))) 393 (setq best-square square 394 score-max score))) 395 (setq square (1+ square))) ; try next square 396 best-square)) 397 398;;;_ - INITIALIZING THE SCORE TABLE. 399 400;; At initialization the board is empty so that every qtuple amounts for 401;; nil-score. Therefore, the score of any square is nil-score times the number 402;; of qtuples that pass through it. This number is 3 in a corner and 20 if you 403;; are sufficiently far from the sides. As computing the number is time 404;; consuming, we initialize every square with 20*nil-score and then only 405;; consider squares at less than 5 squares from one side. We speed this up by 406;; taking symmetry into account. 407;; Also, as it is likely that successive games will be played on a board with 408;; same size, it is a good idea to save the initial SCORE-TABLE configuration. 409 410(defvar lm-saved-score-table nil 411 "Recorded initial value of previous score table.") 412 413(defvar lm-saved-board-width nil 414 "Recorded value of previous board width.") 415 416(defvar lm-saved-board-height nil 417 "Recorded value of previous board height.") 418 419 420(defun lm-init-score-table () 421 "Create the score table vector and fill it with initial values." 422 (if (and lm-saved-score-table ; Has it been stored last time ? 423 (= lm-board-width lm-saved-board-width) 424 (= lm-board-height lm-saved-board-height)) 425 (setq lm-score-table (copy-sequence lm-saved-score-table)) 426 ;; No, compute it: 427 (setq lm-score-table 428 (make-vector lm-vector-length (* 20 nil-score))) 429 (let (i j maxi maxj maxi2 maxj2) 430 (setq maxi (/ (1+ lm-board-width) 2) 431 maxj (/ (1+ lm-board-height) 2) 432 maxi2 (min 4 maxi) 433 maxj2 (min 4 maxj)) 434 ;; We took symmetry into account and could use it more if the board 435 ;; would have been square and not rectangular ! 436 ;; In our case we deal with all (i,j) in the set [1..maxi2]*[1..maxj] U 437 ;; [maxi2+1..maxi]*[1..maxj2]. Maxi2 and maxj2 are used because the 438 ;; board may well be less than 8 by 8 ! 439 (setq i 1) 440 (while (<= i maxi2) 441 (setq j 1) 442 (while (<= j maxj) 443 (lm-init-square-score i j) 444 (setq j (1+ j))) 445 (setq i (1+ i))) 446 (while (<= i maxi) 447 (setq j 1) 448 (while (<= j maxj2) 449 (lm-init-square-score i j) 450 (setq j (1+ j))) 451 (setq i (1+ i)))) 452 (setq lm-saved-score-table (copy-sequence lm-score-table) 453 lm-saved-board-width lm-board-width 454 lm-saved-board-height lm-board-height))) 455 456(defun lm-nb-qtuples (i j) 457 "Return the number of qtuples containing square I,J." 458 ;; This function is complicated because we have to deal 459 ;; with ugly cases like 3 by 6 boards, but it works. 460 ;; If you have a simpler (and correct) solution, send it to me. Thanks ! 461 (let ((left (min 4 (1- i))) 462 (right (min 4 (- lm-board-width i))) 463 (up (min 4 (1- j))) 464 (down (min 4 (- lm-board-height j)))) 465 (+ -12 466 (min (max (+ left right) 3) 8) 467 (min (max (+ up down) 3) 8) 468 (min (max (+ (min left up) (min right down)) 3) 8) 469 (min (max (+ (min right up) (min left down)) 3) 8)))) 470 471(defun lm-init-square-score (i j) 472 "Give initial score to square I,J and to its mirror images." 473 (let ((ii (1+ (- lm-board-width i))) 474 (jj (1+ (- lm-board-height j))) 475 (sc (* (lm-nb-qtuples i j) (aref lm-score-trans-table 0)))) 476 (aset lm-score-table (lm-xy-to-index i j) sc) 477 (aset lm-score-table (lm-xy-to-index ii j) sc) 478 (aset lm-score-table (lm-xy-to-index i jj) sc) 479 (aset lm-score-table (lm-xy-to-index ii jj) sc))) 480;;;_ - MAINTAINING THE SCORE TABLE. 481 482 483;; We do not provide functions for computing the SCORE-TABLE given the 484;; contents of the BOARD. This would involve heavy nested loops, with time 485;; proportional to the size of the board. It is better to update the 486;; SCORE-TABLE after each move. Updating needs not modify more than 36 487;; squares: it is done in constant time. 488 489(defun lm-update-score-table (square dval) 490 "Update score table after SQUARE received a DVAL increment." 491 ;; The board has already been updated when this function is called. 492 ;; Updating scores is done by looking for qtuples boundaries in all four 493 ;; directions and then calling update-score-in-direction. 494 ;; Finally all squares received the right increment, and then are up to 495 ;; date, except possibly for SQUARE itself if we are taking a move back for 496 ;; its score had been set to -1 at the time. 497 (let* ((x (lm-index-to-x square)) 498 (y (lm-index-to-y square)) 499 (imin (max -4 (- 1 x))) 500 (jmin (max -4 (- 1 y))) 501 (imax (min 0 (- lm-board-width x 4))) 502 (jmax (min 0 (- lm-board-height y 4)))) 503 (lm-update-score-in-direction imin imax 504 square 1 0 dval) 505 (lm-update-score-in-direction jmin jmax 506 square 0 1 dval) 507 (lm-update-score-in-direction (max imin jmin) (min imax jmax) 508 square 1 1 dval) 509 (lm-update-score-in-direction (max (- 1 y) -4 510 (- x lm-board-width)) 511 (min 0 (- x 5) 512 (- lm-board-height y 4)) 513 square -1 1 dval))) 514 515(defun lm-update-score-in-direction (left right square dx dy dval) 516 "Update scores for all squares in the qtuples in range. 517That is, those between the LEFTth square and the RIGHTth after SQUARE, 518along the DX, DY direction, considering that DVAL has been added on SQUARE." 519 ;; We always have LEFT <= 0, RIGHT <= 0 and DEPL > 0 but we may very well 520 ;; have LEFT > RIGHT, indicating that no qtuple contains SQUARE along that 521 ;; DX,DY direction. 522 (cond 523 ((> left right)) ; Quit 524 (t ; Else .. 525 (let (depl square0 square1 square2 count delta) 526 (setq depl (lm-xy-to-index dx dy) 527 square0 (+ square (* left depl)) 528 square1 (+ square (* right depl)) 529 square2 (+ square0 (* 4 depl))) 530 ;; Compute the contents of the first qtuple: 531 (setq square square0 532 count 0) 533 (while (<= square square2) 534 (setq count (+ count (aref lm-board square)) 535 square (+ square depl))) 536 (while (<= square0 square1) 537 ;; Update the squares of the qtuple beginning in SQUARE0 and ending 538 ;; in SQUARE2. 539 (setq delta (- (aref lm-score-trans-table count) 540 (aref lm-score-trans-table (- count dval)))) 541 (cond ((not (zerop delta)) ; or else nothing to update 542 (setq square square0) 543 (while (<= square square2) 544 (if (zerop (aref lm-board square)) ; only for free squares 545 (aset lm-score-table square 546 (+ (aref lm-score-table square) delta))) 547 (setq square (+ square depl))))) 548 ;; Then shift the qtuple one square along DEPL, this only requires 549 ;; modifying SQUARE0 and SQUARE2. 550 (setq square2 (+ square2 depl) 551 count (+ count (- (aref lm-board square0)) 552 (aref lm-board square2)) 553 square0 (+ square0 depl))))))) 554 555;;; 556;;; GAME CONTROL. 557;;; 558 559;; Several variables are used to monitor a game, including a GAME-HISTORY (the 560;; list of all (SQUARE . PREVSCORE) played) that allows to take moves back 561;; (anti-updating the score table) and to compute the table from scratch in 562;; case of an interruption. 563 564(defvar lm-game-in-progress nil 565 "Non-nil if a game is in progress.") 566 567(defvar lm-game-history nil 568 "A record of all moves that have been played during current game.") 569 570(defvar lm-number-of-moves nil 571 "Number of moves already played in current game.") 572 573(defvar lm-number-of-human-moves nil 574 "Number of moves already played by human in current game.") 575 576(defvar lm-emacs-played-first nil 577 "Non-nil if Emacs played first.") 578 579(defvar lm-human-took-back nil 580 "Non-nil if Human took back a move during the game.") 581 582(defvar lm-human-refused-draw nil 583 "Non-nil if Human refused Emacs offer of a draw.") 584 585(defvar lm-emacs-is-computing nil 586 ;; This is used to detect interruptions. Hopefully, it should not be needed. 587 "Non-nil if Emacs is in the middle of a computation.") 588 589 590(defun lm-start-game (n m) 591 "Initialize a new game on an N by M board." 592 (setq lm-emacs-is-computing t) ; Raise flag 593 (setq lm-game-in-progress t) 594 (setq lm-board-width n 595 lm-board-height m 596 lm-vector-length (1+ (* (+ m 2) (1+ n))) 597 lm-draw-limit (/ (* 7 n m) 10)) 598 (setq lm-emacs-won nil 599 lm-game-history nil 600 lm-number-of-moves 0 601 lm-number-of-human-moves 0 602 lm-emacs-played-first nil 603 lm-human-took-back nil 604 lm-human-refused-draw nil) 605 (lm-init-display n m) ; Display first: the rest takes time 606 (lm-init-score-table) ; INIT-BOARD requires that the score 607 (lm-init-board) ; table be already created. 608 (setq lm-emacs-is-computing nil)) 609 610(defun lm-play-move (square val &optional dont-update-score) 611 "Go to SQUARE, play VAL and update everything." 612 (setq lm-emacs-is-computing t) ; Raise flag 613 (cond ((= 1 val) ; a Human move 614 (setq lm-number-of-human-moves (1+ lm-number-of-human-moves))) 615 ((zerop lm-number-of-moves) ; an Emacs move. Is it first ? 616 (setq lm-emacs-played-first t))) 617 (setq lm-game-history 618 (cons (cons square (aref lm-score-table square)) 619 lm-game-history) 620 lm-number-of-moves (1+ lm-number-of-moves)) 621 (lm-plot-square square val) 622 (aset lm-board square val) ; *BEFORE* UPDATE-SCORE ! 623 (if dont-update-score nil 624 (lm-update-score-table square val) ; previous val was 0: dval = val 625 (aset lm-score-table square -1)) 626 (setq lm-emacs-is-computing nil)) 627 628(defun lm-take-back () 629 "Take back last move and update everything." 630 (setq lm-emacs-is-computing t) 631 (let* ((last-move (car lm-game-history)) 632 (square (car last-move)) 633 (oldval (aref lm-board square))) 634 (if (= 1 oldval) 635 (setq lm-number-of-human-moves (1- lm-number-of-human-moves))) 636 (setq lm-game-history (cdr lm-game-history) 637 lm-number-of-moves (1- lm-number-of-moves)) 638 (lm-plot-square square 0) 639 (aset lm-board square 0) ; *BEFORE* UPDATE-SCORE ! 640 (lm-update-score-table square (- oldval)) 641 (aset lm-score-table square (cdr last-move))) 642 (setq lm-emacs-is-computing nil)) 643 644 645;;;_ + SESSION CONTROL. 646 647(defvar lm-number-of-trials 0 648 "The number of times that landmark has been run.") 649 650(defvar lm-sum-of-moves 0 651 "The total number of moves made in all games.") 652 653(defvar lm-number-of-emacs-wins 0 654 "Number of games Emacs won in this session.") 655 656(defvar lm-number-of-human-wins 0 657 "Number of games you won in this session.") 658 659(defvar lm-number-of-draws 0 660 "Number of games already drawn in this session.") 661 662 663(defun lm-terminate-game (result) 664 "Terminate the current game with RESULT." 665 (setq lm-number-of-trials (1+ lm-number-of-trials)) 666 (setq lm-sum-of-moves (+ lm-sum-of-moves lm-number-of-moves)) 667 (if (eq result 'crash-game) 668 (message 669 "Sorry, I have been interrupted and cannot resume that game...")) 670 (lm-display-statistics) 671 ;;(ding) 672 (setq lm-game-in-progress nil)) 673 674(defun lm-crash-game () 675 "What to do when Emacs detects it has been interrupted." 676 (setq lm-emacs-is-computing nil) 677 (lm-terminate-game 'crash-game) 678 (sit-for 4) ; Let's see the message 679 (lm-prompt-for-other-game)) 680 681 682;;;_ + INTERACTIVE COMMANDS. 683 684(defun lm-emacs-plays () 685 "Compute Emacs next move and play it." 686 (interactive) 687 (lm-switch-to-window) 688 (cond 689 (lm-emacs-is-computing 690 (lm-crash-game)) 691 ((not lm-game-in-progress) 692 (lm-prompt-for-other-game)) 693 (t 694 (message "Let me think...") 695 (let (square score) 696 (setq square (lm-strongest-square)) 697 (cond ((null square) 698 (lm-terminate-game 'nobody-won)) 699 (t 700 (setq score (aref lm-score-table square)) 701 (lm-play-move square 6) 702 (cond ((>= score lm-winning-threshold) 703 (setq lm-emacs-won t) ; for font-lock 704 (lm-find-filled-qtuple square 6) 705 (lm-terminate-game 'emacs-won)) 706 ((zerop score) 707 (lm-terminate-game 'nobody-won)) 708 ((and (> lm-number-of-moves lm-draw-limit) 709 (not lm-human-refused-draw) 710 (lm-offer-a-draw)) 711 (lm-terminate-game 'draw-agreed)) 712 (t 713 (lm-prompt-for-move))))))))) 714 715;; For small square dimensions this is approximate, since though measured in 716;; pixels, event's (X . Y) is a character's top-left corner. 717(defun lm-click (click) 718 "Position at the square where you click." 719 (interactive "e") 720 (and (windowp (posn-window (setq click (event-end click)))) 721 (numberp (posn-point click)) 722 (select-window (posn-window click)) 723 (setq click (posn-col-row click)) 724 (lm-goto-xy 725 (min (max (/ (+ (- (car click) 726 lm-x-offset 727 1) 728 (window-hscroll) 729 lm-square-width 730 (% lm-square-width 2) 731 (/ lm-square-width 2)) 732 lm-square-width) 733 1) 734 lm-board-width) 735 (min (max (/ (+ (- (cdr click) 736 lm-y-offset 737 1) 738 (let ((inhibit-point-motion-hooks t)) 739 (count-lines 1 (window-start))) 740 lm-square-height 741 (% lm-square-height 2) 742 (/ lm-square-height 2)) 743 lm-square-height) 744 1) 745 lm-board-height)))) 746 747(defun lm-mouse-play (click) 748 "Play at the square where you click." 749 (interactive "e") 750 (if (lm-click click) 751 (lm-human-plays))) 752 753(defun lm-human-plays () 754 "Signal to the Lm program that you have played. 755You must have put the cursor on the square where you want to play. 756If the game is finished, this command requests for another game." 757 (interactive) 758 (lm-switch-to-window) 759 (cond 760 (lm-emacs-is-computing 761 (lm-crash-game)) 762 ((not lm-game-in-progress) 763 (lm-prompt-for-other-game)) 764 (t 765 (let (square score) 766 (setq square (lm-point-square)) 767 (cond ((null square) 768 (error "Your point is not on a square. Retry!")) 769 ((not (zerop (aref lm-board square))) 770 (error "Your point is not on a free square. Retry!")) 771 (t 772 (setq score (aref lm-score-table square)) 773 (lm-play-move square 1) 774 (cond ((and (>= score lm-loosing-threshold) 775 ;; Just testing SCORE > THRESHOLD is not enough for 776 ;; detecting wins, it just gives an indication that 777 ;; we confirm with LM-FIND-FILLED-QTUPLE. 778 (lm-find-filled-qtuple square 1)) 779 (lm-terminate-game 'human-won)) 780 (t 781 (lm-emacs-plays))))))))) 782 783(defun lm-human-takes-back () 784 "Signal to the Lm program that you wish to take back your last move." 785 (interactive) 786 (lm-switch-to-window) 787 (cond 788 (lm-emacs-is-computing 789 (lm-crash-game)) 790 ((not lm-game-in-progress) 791 (message "Too late for taking back...") 792 (sit-for 4) 793 (lm-prompt-for-other-game)) 794 ((zerop lm-number-of-human-moves) 795 (message "You have not played yet... Your move?")) 796 (t 797 (message "One moment, please...") 798 ;; It is possible for the user to let Emacs play several consecutive 799 ;; moves, so that the best way to know when to stop taking back moves is 800 ;; to count the number of human moves: 801 (setq lm-human-took-back t) 802 (let ((number lm-number-of-human-moves)) 803 (while (= number lm-number-of-human-moves) 804 (lm-take-back))) 805 (lm-prompt-for-move)))) 806 807(defun lm-human-resigns () 808 "Signal to the Lm program that you may want to resign." 809 (interactive) 810 (lm-switch-to-window) 811 (cond 812 (lm-emacs-is-computing 813 (lm-crash-game)) 814 ((not lm-game-in-progress) 815 (message "There is no game in progress")) 816 ((y-or-n-p "You mean, you resign? ") 817 (lm-terminate-game 'human-resigned)) 818 ((y-or-n-p "You mean, we continue? ") 819 (lm-prompt-for-move)) 820 (t 821 (lm-terminate-game 'human-resigned)))) ; OK. Accept it 822 823;;;_ + PROMPTING THE HUMAN PLAYER. 824 825(defun lm-prompt-for-move () 826 "Display a message asking for Human's move." 827 (message (if (zerop lm-number-of-human-moves) 828 "Your move? (move to a free square and hit X, RET ...)" 829 "Your move?")) 830 ;; This may seem silly, but if one omits the following line (or a similar 831 ;; one), the cursor may very well go to some place where POINT is not. 832 (save-excursion (set-buffer (other-buffer)))) 833 834(defun lm-prompt-for-other-game () 835 "Ask for another game, and start it." 836 (if (y-or-n-p "Another game? ") 837 (if (y-or-n-p "Retain learned weights ") 838 (lm 2) 839 (lm 1)) 840 (message "Chicken!"))) 841 842(defun lm-offer-a-draw () 843 "Offer a draw and return t if Human accepted it." 844 (or (y-or-n-p "I offer you a draw. Do you accept it? ") 845 (not (setq lm-human-refused-draw t)))) 846 847 848(defun lm-max-width () 849 "Largest possible board width for the current window." 850 (1+ (/ (- (window-width (selected-window)) 851 lm-x-offset lm-x-offset 1) 852 lm-square-width))) 853 854(defun lm-max-height () 855 "Largest possible board height for the current window." 856 (1+ (/ (- (window-height (selected-window)) 857 lm-y-offset lm-y-offset 2) 858 ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line ! 859 lm-square-height))) 860 861(defun lm-point-y () 862 "Return the board row where point is." 863 (let ((inhibit-point-motion-hooks t)) 864 (1+ (/ (- (count-lines 1 (point)) lm-y-offset (if (bolp) 0 1)) 865 lm-square-height)))) 866 867(defun lm-point-square () 868 "Return the index of the square point is on." 869 (let ((inhibit-point-motion-hooks t)) 870 (lm-xy-to-index (1+ (/ (- (current-column) lm-x-offset) 871 lm-square-width)) 872 (lm-point-y)))) 873 874(defun lm-goto-square (index) 875 "Move point to square number INDEX." 876 (lm-goto-xy (lm-index-to-x index) (lm-index-to-y index))) 877 878(defun lm-goto-xy (x y) 879 "Move point to square at X, Y coords." 880 (let ((inhibit-point-motion-hooks t)) 881 (goto-line (+ 1 lm-y-offset (* lm-square-height (1- y))))) 882 (move-to-column (+ lm-x-offset (* lm-square-width (1- x))))) 883 884(defun lm-plot-square (square value) 885 "Draw 'X', 'O' or '.' on SQUARE depending on VALUE, leave point there." 886 (or (= value 1) 887 (lm-goto-square square)) 888 (let ((inhibit-read-only t) 889 (inhibit-point-motion-hooks t)) 890 (insert-and-inherit (cond ((= value 1) ?.) 891 ((= value 2) ?N) 892 ((= value 3) ?S) 893 ((= value 4) ?E) 894 ((= value 5) ?W) 895 ((= value 6) ?^))) 896 897 (and (zerop value) 898 (add-text-properties (1- (point)) (point) 899 '(mouse-face highlight 900 help-echo "\ 901mouse-1: get robot moving, mouse-2: play on this square"))) 902 (delete-char 1) 903 (backward-char 1)) 904 (sit-for 0)) ; Display NOW 905 906(defun lm-init-display (n m) 907 "Display an N by M Lm board." 908 (buffer-disable-undo (current-buffer)) 909 (let ((inhibit-read-only t) 910 (point 1) opoint 911 (intangible t) 912 (i m) j x) 913 ;; Try to minimize number of chars (because of text properties) 914 (setq tab-width 915 (if (zerop (% lm-x-offset lm-square-width)) 916 lm-square-width 917 (max (/ (+ (% lm-x-offset lm-square-width) 918 lm-square-width 1) 2) 2))) 919 (erase-buffer) 920 (newline lm-y-offset) 921 (while (progn 922 (setq j n 923 x (- lm-x-offset lm-square-width)) 924 (while (>= (setq j (1- j)) 0) 925 (insert-char ?\t (/ (- (setq x (+ x lm-square-width)) 926 (current-column)) 927 tab-width)) 928 (insert-char ? (- x (current-column))) 929 (if (setq intangible (not intangible)) 930 (put-text-property point (point) 'intangible 2)) 931 (and (zerop j) 932 (= i (- m 2)) 933 (progn 934 (while (>= i 3) 935 (append-to-buffer (current-buffer) opoint (point)) 936 (setq i (- i 2))) 937 (goto-char (point-max)))) 938 (setq point (point)) 939 (insert ?=) 940 (add-text-properties point (point) 941 '(mouse-face highlight help-echo "\ 942mouse-1: get robot moving, mouse-2: play on this square"))) 943 (> (setq i (1- i)) 0)) 944 (if (= i (1- m)) 945 (setq opoint point)) 946 (insert-char ?\n lm-square-height)) 947 (or (eq (char-after 1) ?.) 948 (put-text-property 1 2 'point-entered 949 (lambda (x y) (if (bobp) (forward-char))))) 950 (or intangible 951 (put-text-property point (point) 'intangible 2)) 952 (put-text-property point (point) 'point-entered 953 (lambda (x y) (if (eobp) (backward-char)))) 954 (put-text-property (point-min) (point) 'category 'lm-mode)) 955 (lm-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board 956 (sit-for 0)) ; Display NOW 957 958(defun lm-display-statistics () 959 "Obnoxiously display some statistics about previous games in mode line." 960 ;; We store this string in the mode-line-process local variable. 961 ;; This is certainly not the cleanest way out ... 962 (setq mode-line-process 963 (format ": Trials: %d, Avg#Moves: %d" 964 lm-number-of-trials 965 (if (zerop lm-number-of-trials) 966 0 967 (/ lm-sum-of-moves lm-number-of-trials)))) 968 (force-mode-line-update)) 969 970(defun lm-switch-to-window () 971 "Find or create the Lm buffer, and display it." 972 (interactive) 973 (let ((buff (get-buffer "*Lm*"))) 974 (if buff ; Buffer exists: 975 (switch-to-buffer buff) ; no problem. 976 (if lm-game-in-progress 977 (lm-crash-game)) ; buffer has been killed or something 978 (switch-to-buffer "*Lm*") ; Anyway, start anew. 979 (lm-mode)))) 980 981 982;;;_ + CROSSING WINNING QTUPLES. 983 984;; When someone succeeds in filling a qtuple, we draw a line over the five 985;; corresponding squares. One problem is that the program does not know which 986;; squares ! It only knows the square where the last move has been played and 987;; who won. The solution is to scan the board along all four directions. 988 989(defun lm-find-filled-qtuple (square value) 990 "Return t if SQUARE belongs to a qtuple filled with VALUEs." 991 (or (lm-check-filled-qtuple square value 1 0) 992 (lm-check-filled-qtuple square value 0 1) 993 (lm-check-filled-qtuple square value 1 1) 994 (lm-check-filled-qtuple square value -1 1))) 995 996(defun lm-check-filled-qtuple (square value dx dy) 997 "Return t if SQUARE belongs to a qtuple filled with VALUEs along DX, DY." 998 (let ((a 0) (b 0) 999 (left square) (right square) 1000 (depl (lm-xy-to-index dx dy))) 1001 (while (and (> a -4) ; stretch tuple left 1002 (= value (aref lm-board (setq left (- left depl))))) 1003 (setq a (1- a))) 1004 (while (and (< b (+ a 4)) ; stretch tuple right 1005 (= value (aref lm-board (setq right (+ right depl))))) 1006 (setq b (1+ b))) 1007 (cond ((= b (+ a 4)) ; tuple length = 5 ? 1008 (lm-cross-qtuple (+ square (* a depl)) (+ square (* b depl)) 1009 dx dy) 1010 t)))) 1011 1012(defun lm-cross-qtuple (square1 square2 dx dy) 1013 "Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction." 1014 (save-excursion ; Not moving point from last square 1015 (let ((depl (lm-xy-to-index dx dy)) 1016 (inhibit-read-only t) 1017 (inhibit-point-motion-hooks t)) 1018 ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1 1019 (while (/= square1 square2) 1020 (lm-goto-square square1) 1021 (setq square1 (+ square1 depl)) 1022 (cond 1023 ((= dy 0) ; Horizontal 1024 (forward-char 1) 1025 (insert-char ?- (1- lm-square-width) t) 1026 (delete-region (point) (progn 1027 (skip-chars-forward " \t") 1028 (point)))) 1029 ((= dx 0) ; Vertical 1030 (let ((lm-n 1) 1031 (column (current-column))) 1032 (while (< lm-n lm-square-height) 1033 (setq lm-n (1+ lm-n)) 1034 (forward-line 1) 1035 (indent-to column) 1036 (insert-and-inherit ?|)))) 1037 ((= dx -1) ; 1st Diagonal 1038 (indent-to (prog1 (- (current-column) (/ lm-square-width 2)) 1039 (forward-line (/ lm-square-height 2)))) 1040 (insert-and-inherit ?/)) 1041 (t ; 2nd Diagonal 1042 (indent-to (prog1 (+ (current-column) (/ lm-square-width 2)) 1043 (forward-line (/ lm-square-height 2)))) 1044 (insert-and-inherit ?\\)))))) 1045 (sit-for 0)) ; Display NOW 1046 1047 1048;;;_ + CURSOR MOTION. 1049 1050;; previous-line and next-line don't work right with intangible newlines 1051(defun lm-move-down () 1052 "Move point down one row on the Lm board." 1053 (interactive) 1054 (if (< (lm-point-y) lm-board-height) 1055 (next-line 1)));;; lm-square-height))) 1056 1057(defun lm-move-up () 1058 "Move point up one row on the Lm board." 1059 (interactive) 1060 (if (> (lm-point-y) 1) 1061 (previous-line lm-square-height))) 1062 1063(defun lm-move-ne () 1064 "Move point North East on the Lm board." 1065 (interactive) 1066 (lm-move-up) 1067 (forward-char)) 1068 1069(defun lm-move-se () 1070 "Move point South East on the Lm board." 1071 (interactive) 1072 (lm-move-down) 1073 (forward-char)) 1074 1075(defun lm-move-nw () 1076 "Move point North West on the Lm board." 1077 (interactive) 1078 (lm-move-up) 1079 (backward-char)) 1080 1081(defun lm-move-sw () 1082 "Move point South West on the Lm board." 1083 (interactive) 1084 (lm-move-down) 1085 (backward-char)) 1086 1087(defun lm-beginning-of-line () 1088 "Move point to first square on the Lm board row." 1089 (interactive) 1090 (move-to-column lm-x-offset)) 1091 1092(defun lm-end-of-line () 1093 "Move point to last square on the Lm board row." 1094 (interactive) 1095 (move-to-column (+ lm-x-offset 1096 (* lm-square-width (1- lm-board-width))))) 1097 1098 1099;;;_ + Simulation variables 1100 1101;;;_ - lm-nvar 1102(defvar lm-nvar 0.0075 1103 "Not used. 1104Affects a noise generator which was used in an earlier incarnation of 1105this program to add a random element to the way moves were made.") 1106;;;_ - lists of cardinal directions 1107;;;_ : 1108(defvar lm-ns '(lm-n lm-s) 1109 "Used when doing something relative to the north and south axes.") 1110(defvar lm-ew '(lm-e lm-w) 1111 "Used when doing something relative to the east and west axes.") 1112(defvar lm-directions '(lm-n lm-s lm-e lm-w) 1113 "The cardinal directions.") 1114(defvar lm-8-directions 1115 '((lm-n) (lm-n lm-w) (lm-w) (lm-s lm-w) 1116 (lm-s) (lm-s lm-e) (lm-e) (lm-n lm-e)) 1117 "The full 8 possible directions.") 1118 1119(defvar lm-number-of-moves 1120 "The number of moves made by the robot so far.") 1121 1122 1123;;;_* Terry's mods to create lm.el 1124 1125;;;(setq lm-debug nil) 1126(defvar lm-debug nil 1127 "If non-nil, debugging is printed.") 1128(defcustom lm-one-moment-please nil 1129 "If non-nil, print \"One moment please\" when a new board is generated. 1130The drawback of this is you don't see how many moves the last run took 1131because it is overwritten by \"One moment please\"." 1132 :type 'boolean 1133 :group 'lm) 1134(defcustom lm-output-moves t 1135 "If non-nil, output number of moves so far on a move-by-move basis." 1136 :type 'boolean 1137 :group 'lm) 1138 1139 1140(defun lm-weights-debug () 1141 (if lm-debug 1142 (progn (lm-print-wts) (lm-blackbox) (lm-print-y,s,noise) 1143 (lm-print-smell)))) 1144 1145;;;_ - Printing various things 1146(defun lm-print-distance-int (direction) 1147 (interactive) 1148 (insert (format "%S %S " direction (get direction 'distance)))) 1149 1150 1151(defun lm-print-distance () 1152 (insert (format "tree: %S \n" (calc-distance-of-robot-from 'lm-tree))) 1153 (mapc 'lm-print-distance-int lm-directions)) 1154 1155 1156;;(setq direction 'lm-n) 1157;;(get 'lm-n 'lm-s) 1158(defun lm-nslify-wts-int (direction) 1159 (mapcar (lambda (target-direction) 1160 (get direction target-direction)) 1161 lm-directions)) 1162 1163 1164(defun lm-nslify-wts () 1165 (interactive) 1166 (let ((l (apply 'append (mapcar 'lm-nslify-wts-int lm-directions)))) 1167 (insert (format "set data_value WTS \n %s \n" l)) 1168 (insert (format "/* max: %S min: %S */" 1169 (eval (cons 'max l)) (eval (cons 'min l)))))) 1170 1171(defun lm-print-wts-int (direction) 1172 (mapc (lambda (target-direction) 1173 (insert (format "%S %S %S " 1174 direction 1175 target-direction 1176 (get direction target-direction)))) 1177 lm-directions) 1178 (insert "\n")) 1179 1180(defun lm-print-wts () 1181 (interactive) 1182 (save-excursion 1183 (set-buffer "*lm-wts*") 1184 (insert "==============================\n") 1185 (mapc 'lm-print-wts-int lm-directions))) 1186 1187(defun lm-print-moves (moves) 1188 (interactive) 1189 (save-excursion 1190 (set-buffer "*lm-moves*") 1191 (insert (format "%S\n" moves)))) 1192 1193 1194(defun lm-print-y,s,noise-int (direction) 1195 (insert (format "%S:lm-y %S, s %S, noise %S \n" 1196 (symbol-name direction) 1197 (get direction 'y_t) 1198 (get direction 's) 1199 (get direction 'noise) 1200 ))) 1201 1202(defun lm-print-y,s,noise () 1203 (interactive) 1204 (save-excursion 1205 (set-buffer "*lm-y,s,noise*") 1206 (insert "==============================\n") 1207 (mapc 'lm-print-y,s,noise-int lm-directions))) 1208 1209(defun lm-print-smell-int (direction) 1210 (insert (format "%S: smell: %S \n" 1211 (symbol-name direction) 1212 (get direction 'smell)))) 1213 1214(defun lm-print-smell () 1215 (interactive) 1216 (save-excursion 1217 (set-buffer "*lm-smell*") 1218 (insert "==============================\n") 1219 (insert (format "tree: %S \n" (get 'z 't))) 1220 (mapc 'lm-print-smell-int lm-directions))) 1221 1222(defun lm-print-w0-int (direction) 1223 (insert (format "%S: w0: %S \n" 1224 (symbol-name direction) 1225 (get direction 'w0)))) 1226 1227(defun lm-print-w0 () 1228 (interactive) 1229 (save-excursion 1230 (set-buffer "*lm-w0*") 1231 (insert "==============================\n") 1232 (mapc 'lm-print-w0-int lm-directions))) 1233 1234(defun lm-blackbox () 1235 (save-excursion 1236 (set-buffer "*lm-blackbox*") 1237 (insert "==============================\n") 1238 (insert "I smell: ") 1239 (mapc (lambda (direction) 1240 (if (> (get direction 'smell) 0) 1241 (insert (format "%S " direction)))) 1242 lm-directions) 1243 (insert "\n") 1244 1245 (insert "I move: ") 1246 (mapc (lambda (direction) 1247 (if (> (get direction 'y_t) 0) 1248 (insert (format "%S " direction)))) 1249 lm-directions) 1250 (insert "\n") 1251 (lm-print-wts-blackbox) 1252 (insert (format "z_t-z_t-1: %S" (- (get 'z 't) (get 'z 't-1)))) 1253 (lm-print-distance) 1254 (insert "\n"))) 1255 1256(defun lm-print-wts-blackbox () 1257 (interactive) 1258 (mapc 'lm-print-wts-int lm-directions)) 1259 1260;;;_ - learning parameters 1261(defcustom lm-bound 0.005 1262 "The maximum that w0j may be." 1263 :type 'number 1264 :group 'lm) 1265(defcustom lm-c 1.0 1266 "A factor applied to modulate the increase in wij. 1267Used in the function lm-update-normal-weights." 1268 :type 'number 1269 :group 'lm) 1270(defcustom lm-c-naught 0.5 1271 "A factor applied to modulate the increase in w0j. 1272Used in the function lm-update-naught-weights." 1273 :type 'number 1274 :group 'lm) 1275(defvar lm-initial-w0 0.0) 1276(defvar lm-initial-wij 0.0) 1277(defcustom lm-no-payoff 0 1278 "The amount of simulation cycles that have occurred with no movement. 1279Used to move the robot when he is stuck in a rut for some reason." 1280 :type 'integer 1281 :group 'lm) 1282(defcustom lm-max-stall-time 2 1283 "The maximum number of cycles that the robot can remain stuck in a place. 1284After this limit is reached, lm-random-move is called to push him out of it." 1285 :type 'integer 1286 :group 'lm) 1287 1288 1289;;;_ + Randomizing functions 1290;;;_ - lm-flip-a-coin () 1291(defun lm-flip-a-coin () 1292 (if (> (random 5000) 2500) 1293 -1 1294 1)) 1295;;;_ : lm-very-small-random-number () 1296;(defun lm-very-small-random-number () 1297; (/ 1298; (* (/ (random 900000) 900000.0) .0001))) 1299;;;_ : lm-randomize-weights-for (direction) 1300(defun lm-randomize-weights-for (direction) 1301 (mapc (lambda (target-direction) 1302 (put direction 1303 target-direction 1304 (* (lm-flip-a-coin) (/ (random 10000) 10000.0)))) 1305 lm-directions)) 1306;;;_ : lm-noise () 1307(defun lm-noise () 1308 (* (- (/ (random 30001) 15000.0) 1) lm-nvar)) 1309 1310;;;_ : lm-fix-weights-for (direction) 1311(defun lm-fix-weights-for (direction) 1312 (mapc (lambda (target-direction) 1313 (put direction 1314 target-direction 1315 lm-initial-wij)) 1316 lm-directions)) 1317 1318 1319;;;_ + Plotting functions 1320;;;_ - lm-plot-internal (sym) 1321(defun lm-plot-internal (sym) 1322 (lm-plot-square (lm-xy-to-index 1323 (get sym 'x) 1324 (get sym 'y)) 1325 (get sym 'sym))) 1326;;;_ - lm-plot-landmarks () 1327(defun lm-plot-landmarks () 1328 (setq lm-cx (/ lm-board-width 2)) 1329 (setq lm-cy (/ lm-board-height 2)) 1330 1331 (put 'lm-n 'x lm-cx) 1332 (put 'lm-n 'y 1) 1333 (put 'lm-n 'sym 2) 1334 1335 (put 'lm-tree 'x lm-cx) 1336 (put 'lm-tree 'y lm-cy) 1337 (put 'lm-tree 'sym 6) 1338 1339 (put 'lm-s 'x lm-cx) 1340 (put 'lm-s 'y lm-board-height) 1341 (put 'lm-s 'sym 3) 1342 1343 (put 'lm-w 'x 1) 1344 (put 'lm-w 'y (/ lm-board-height 2)) 1345 (put 'lm-w 'sym 5) 1346 1347 (put 'lm-e 'x lm-board-width) 1348 (put 'lm-e 'y (/ lm-board-height 2)) 1349 (put 'lm-e 'sym 4) 1350 1351 (mapc 'lm-plot-internal '(lm-n lm-s lm-e lm-w lm-tree))) 1352 1353 1354 1355;;;_ + Distance-calculation functions 1356;;;_ - square (a) 1357(defun square (a) 1358 (* a a)) 1359 1360;;;_ - distance (x x0 y y0) 1361(defun distance (x x0 y y0) 1362 (sqrt (+ (square (- x x0)) (square (- y y0))))) 1363 1364;;;_ - calc-distance-of-robot-from (direction) 1365(defun calc-distance-of-robot-from (direction) 1366 (put direction 'distance 1367 (distance (get direction 'x) 1368 (lm-index-to-x (lm-point-square)) 1369 (get direction 'y) 1370 (lm-index-to-y (lm-point-square))))) 1371 1372;;;_ - calc-smell-internal (sym) 1373(defun calc-smell-internal (sym) 1374 (let ((r (get sym 'r)) 1375 (d (calc-distance-of-robot-from sym))) 1376 (if (> (* 0.5 (- 1 (/ d r))) 0) 1377 (* 0.5 (- 1 (/ d r))) 1378 0))) 1379 1380 1381;;;_ + Learning (neural) functions 1382(defun lm-f (x) 1383 (cond 1384 ((> x lm-bound) lm-bound) 1385 ((< x 0.0) 0.0) 1386 (t x))) 1387 1388(defun lm-y (direction) 1389 (let ((noise (put direction 'noise (lm-noise)))) 1390 (put direction 'y_t 1391 (if (> (get direction 's) 0.0) 1392 1.0 1393 0.0)))) 1394 1395(defun lm-update-normal-weights (direction) 1396 (mapc (lambda (target-direction) 1397 (put direction target-direction 1398 (+ 1399 (get direction target-direction) 1400 (* lm-c 1401 (- (get 'z 't) (get 'z 't-1)) 1402 (get target-direction 'y_t) 1403 (get direction 'smell))))) 1404 lm-directions)) 1405 1406(defun lm-update-naught-weights (direction) 1407 (mapc (lambda (target-direction) 1408 (put direction 'w0 1409 (lm-f 1410 (+ 1411 (get direction 'w0) 1412 (* lm-c-naught 1413 (- (get 'z 't) (get 'z 't-1)) 1414 (get direction 'y_t)))))) 1415 lm-directions)) 1416 1417 1418;;;_ + Statistics gathering and creating functions 1419 1420(defun lm-calc-current-smells () 1421 (mapc (lambda (direction) 1422 (put direction 'smell (calc-smell-internal direction))) 1423 lm-directions)) 1424 1425(defun lm-calc-payoff () 1426 (put 'z 't-1 (get 'z 't)) 1427 (put 'z 't (calc-smell-internal 'lm-tree)) 1428 (if (= (- (get 'z 't) (get 'z 't-1)) 0.0) 1429 (incf lm-no-payoff) 1430 (setf lm-no-payoff 0))) 1431 1432(defun lm-store-old-y_t () 1433 (mapc (lambda (direction) 1434 (put direction 'y_t-1 (get direction 'y_t))) 1435 lm-directions)) 1436 1437 1438;;;_ + Functions to move robot 1439 1440(defun lm-confidence-for (target-direction) 1441 (apply '+ 1442 (get target-direction 'w0) 1443 (mapcar (lambda (direction) 1444 (* 1445 (get direction target-direction) 1446 (get direction 'smell))) 1447 lm-directions))) 1448 1449 1450(defun lm-calc-confidences () 1451 (mapc (lambda (direction) 1452 (put direction 's (lm-confidence-for direction))) 1453 lm-directions)) 1454 1455(defun lm-move () 1456 (if (and (= (get 'lm-n 'y_t) 1.0) (= (get 'lm-s 'y_t) 1.0)) 1457 (progn 1458 (mapc (lambda (dir) (put dir 'y_t 0)) lm-ns) 1459 (if lm-debug 1460 (message "n-s normalization.")))) 1461 (if (and (= (get 'lm-w 'y_t) 1.0) (= (get 'lm-e 'y_t) 1.0)) 1462 (progn 1463 (mapc (lambda (dir) (put dir 'y_t 0)) lm-ew) 1464 (if lm-debug 1465 (message "e-w normalization")))) 1466 1467 (mapc (lambda (pair) 1468 (if (> (get (car pair) 'y_t) 0) 1469 (funcall (car (cdr pair))))) 1470 '( 1471 (lm-n lm-move-up) 1472 (lm-s lm-move-down) 1473 (lm-e forward-char) 1474 (lm-w backward-char))) 1475 (lm-plot-square (lm-point-square) 1) 1476 (incf lm-number-of-moves) 1477 (if lm-output-moves 1478 (message "Moves made: %d" lm-number-of-moves))) 1479 1480 1481(defun lm-random-move () 1482 (mapc 1483 (lambda (direction) (put direction 'y_t 0)) 1484 lm-directions) 1485 (dolist (direction (nth (random 8) lm-8-directions)) 1486 (put direction 'y_t 1.0)) 1487 (lm-move)) 1488 1489(defun lm-amble-robot () 1490 (interactive) 1491 (while (> (calc-distance-of-robot-from 'lm-tree) 0) 1492 1493 (lm-store-old-y_t) 1494 (lm-calc-current-smells) 1495 1496 (if (> lm-no-payoff lm-max-stall-time) 1497 (lm-random-move) 1498 (progn 1499 (lm-calc-confidences) 1500 (mapc 'lm-y lm-directions) 1501 (lm-move))) 1502 1503 (lm-calc-payoff) 1504 1505 (mapc 'lm-update-normal-weights lm-directions) 1506 (mapc 'lm-update-naught-weights lm-directions) 1507 (if lm-debug 1508 (lm-weights-debug))) 1509 (lm-terminate-game nil)) 1510 1511 1512;;;_ - lm-start-robot () 1513(defun lm-start-robot () 1514 "Signal to the Lm program that you have played. 1515You must have put the cursor on the square where you want to play. 1516If the game is finished, this command requests for another game." 1517 (interactive) 1518 (lm-switch-to-window) 1519 (cond 1520 (lm-emacs-is-computing 1521 (lm-crash-game)) 1522 ((not lm-game-in-progress) 1523 (lm-prompt-for-other-game)) 1524 (t 1525 (let (square score) 1526 (setq square (lm-point-square)) 1527 (cond ((null square) 1528 (error "Your point is not on a square. Retry!")) 1529 ((not (zerop (aref lm-board square))) 1530 (error "Your point is not on a free square. Retry!")) 1531 (t 1532 (progn 1533 (lm-plot-square square 1) 1534 1535 (lm-store-old-y_t) 1536 (lm-calc-current-smells) 1537 (put 'z 't (calc-smell-internal 'lm-tree)) 1538 1539 (lm-random-move) 1540 1541 (lm-calc-payoff) 1542 1543 (mapc 'lm-update-normal-weights lm-directions) 1544 (mapc 'lm-update-naught-weights lm-directions) 1545 (lm-amble-robot) 1546 ))))))) 1547 1548 1549;;;_ + Misc functions 1550;;;_ - lm-init (auto-start save-weights) 1551(defvar lm-tree-r "") 1552 1553(defun lm-init (auto-start save-weights) 1554 1555 (setq lm-number-of-moves 0) 1556 1557 (lm-plot-landmarks) 1558 1559 (if lm-debug 1560 (progn 1561 (save-excursion 1562 (set-buffer (get-buffer-create "*lm-w0*")) 1563 (erase-buffer) 1564 (set-buffer (get-buffer-create "*lm-moves*")) 1565 (set-buffer (get-buffer-create "*lm-wts*")) 1566 (erase-buffer) 1567 (set-buffer (get-buffer-create "*lm-y,s,noise*")) 1568 (erase-buffer) 1569 (set-buffer (get-buffer-create "*lm-smell*")) 1570 (erase-buffer) 1571 (set-buffer (get-buffer-create "*lm-blackbox*")) 1572 (erase-buffer) 1573 (set-buffer (get-buffer-create "*lm-distance*")) 1574 (erase-buffer)))) 1575 1576 1577 (lm-set-landmark-signal-strengths) 1578 1579 (mapc (lambda (direction) 1580 (put direction 'y_t 0.0)) 1581 lm-directions) 1582 1583 (if (not save-weights) 1584 (progn 1585 (mapc 'lm-fix-weights-for lm-directions) 1586 (mapc (lambda (direction) 1587 (put direction 'w0 lm-initial-w0)) 1588 lm-directions)) 1589 (message "Weights preserved for this run.")) 1590 1591 (if auto-start 1592 (progn 1593 (lm-goto-xy (1+ (random lm-board-width)) (1+ (random lm-board-height))) 1594 (lm-start-robot)))) 1595 1596 1597;;;_ - something which doesn't work 1598; no-a-worka!! 1599;(defum lm-sum-list (list) 1600; (if (> (length list) 0) 1601; (+ (car list) (lm-sum-list (cdr list))) 1602; 0)) 1603; this a worka! 1604; (eval (cons '+ list)) 1605;;;_ - lm-set-landmark-signal-strengths () 1606;;; on a screen higher than wide, I noticed that the robot would amble 1607;;; left and right and not move forward. examining *lm-blackbox* 1608;;; revealed that there was no scent from the north and south 1609;;; landmarks, hence, they need less factoring down of the effect of 1610;;; distance on scent. 1611 1612(defun lm-set-landmark-signal-strengths () 1613 1614 (setq lm-tree-r (* (sqrt (+ (square lm-cx) (square lm-cy))) 1.5)) 1615 1616 (mapc (lambda (direction) 1617 (put direction 'r (* lm-cx 1.1))) 1618 lm-ew) 1619 (mapc (lambda (direction) 1620 (put direction 'r (* lm-cy 1.1))) 1621 lm-ns) 1622 (put 'lm-tree 'r lm-tree-r)) 1623 1624 1625;;;_ + lm-test-run () 1626 1627;;;###autoload 1628(defalias 'landmark-repeat 'lm-test-run) 1629;;;###autoload 1630(defun lm-test-run () 1631 "Run 100 Lm games, each time saving the weights from the previous game." 1632 (interactive) 1633 1634 (lm 1) 1635 1636 (dotimes (scratch-var 100) 1637 1638 (lm 2))) 1639 1640 1641;;;_ + lm: The function you invoke to play 1642 1643;;;###autoload 1644(defalias 'landmark 'lm) 1645;;;###autoload 1646(defun lm (parg) 1647 "Start or resume an Lm game. 1648If a game is in progress, this command allows you to resume it. 1649Here is the relation between prefix args and game options: 1650 1651prefix arg | robot is auto-started | weights are saved from last game 1652--------------------------------------------------------------------- 1653none / 1 | yes | no 1654 2 | yes | yes 1655 3 | no | yes 1656 4 | no | no 1657 1658You start by moving to a square and typing \\[lm-start-robot], 1659if you did not use a prefix arg to ask for automatic start. 1660Use \\[describe-mode] for more info." 1661 (interactive "p") 1662 1663 (setf lm-n nil lm-m nil) 1664 (lm-switch-to-window) 1665 (cond 1666 (lm-emacs-is-computing 1667 (lm-crash-game)) 1668 ((or (not lm-game-in-progress) 1669 (<= lm-number-of-moves 2)) 1670 (let ((max-width (lm-max-width)) 1671 (max-height (lm-max-height))) 1672 (or lm-n (setq lm-n max-width)) 1673 (or lm-m (setq lm-m max-height)) 1674 (cond ((< lm-n 1) 1675 (error "I need at least 1 column")) 1676 ((< lm-m 1) 1677 (error "I need at least 1 row")) 1678 ((> lm-n max-width) 1679 (error "I cannot display %d columns in that window" lm-n))) 1680 (if (and (> lm-m max-height) 1681 (not (eq lm-m lm-saved-board-height)) 1682 ;; Use EQ because SAVED-BOARD-HEIGHT may be nil 1683 (not (y-or-n-p (format "Do you really want %d rows? " lm-m)))) 1684 (setq lm-m max-height))) 1685 (if lm-one-moment-please 1686 (message "One moment, please...")) 1687 (lm-start-game lm-n lm-m) 1688 (eval (cons 'lm-init 1689 (cond 1690 ((= parg 1) '(t nil)) 1691 ((= parg 2) '(t t)) 1692 ((= parg 3) '(nil t)) 1693 ((= parg 4) '(nil nil)) 1694 (t '(nil t)))))))) 1695 1696 1697;;;_ + Local variables 1698 1699;;; The following `allout-layout' local variable setting: 1700;;; - closes all topics from the first topic to just before the third-to-last, 1701;;; - shows the children of the third to last (config vars) 1702;;; - and the second to last (code section), 1703;;; - and closes the last topic (this local-variables section). 1704;;;Local variables: 1705;;;allout-layout: (0 : -1 -1 0) 1706;;;End: 1707 1708(random t) 1709 1710(provide 'landmark) 1711 1712;;; arch-tag: ae5031be-96e6-459e-a3df-1df53117d3f2 1713;;; landmark.el ends here 1714