Commit | Line | Data |
---|---|---|
5abdc915 | 1 | ;;; landmark.el --- neural-network robot that learns landmarks |
a7b88742 | 2 | |
67d110f1 | 3 | ;; Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, |
114f9c96 | 4 | ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
178fc2d3 | 5 | |
9781053a | 6 | ;; Author: Terrence Brannon (was: <brannon@rana.usc.edu>) |
178fc2d3 | 7 | ;; Created: December 16, 1996 - first release to usenet |
16bb1a63 | 8 | ;; Keywords: games, gomoku, neural network, adaptive search, chemotaxis |
178fc2d3 | 9 | |
a7b88742 KH |
10 | ;;;_* Usage |
11 | ;;; Just type | |
ac052b48 | 12 | ;;; M-x eval-buffer |
a7b88742 KH |
13 | ;;; M-x lm-test-run |
14 | ||
15 | ||
178fc2d3 RS |
16 | ;; This file is part of GNU Emacs. |
17 | ||
b1fc2b50 | 18 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
178fc2d3 | 19 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
20 | ;; the Free Software Foundation, either version 3 of the License, or |
21 | ;; (at your option) any later version. | |
178fc2d3 RS |
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 | |
b1fc2b50 | 29 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
178fc2d3 | 30 | |
178fc2d3 | 31 | |
6e44da43 | 32 | ;;; Commentary: |
80cb310d SM |
33 | ;; Lm is a relatively non-participatory game in which a robot |
34 | ;; attempts to maneuver towards a tree at the center of the window | |
35 | ;; based on unique olfactory cues from each of the 4 directions. If | |
36 | ;; the smell of the tree increases, then the weights in the robot's | |
37 | ;; brain are adjusted to encourage this odor-driven behavior in the | |
38 | ;; future. If the smell of the tree decreases, the robots weights are | |
39 | ;; adjusted to discourage a correct move. | |
40 | ||
41 | ;; In laymen's terms, the search space is initially flat. The point | |
42 | ;; of training is to "turn up the edges of the search space" so that | |
43 | ;; the robot rolls toward the center. | |
44 | ||
45 | ;; Further, do not become alarmed if the robot appears to oscillate | |
46 | ;; back and forth between two or a few positions. This simply means | |
47 | ;; it is currently caught in a local minimum and is doing its best to | |
48 | ;; work its way out. | |
49 | ||
50 | ;; The version of this program as described has a small problem. a | |
51 | ;; move in a net direction can produce gross credit assignment. for | |
52 | ;; example, if moving south will produce positive payoff, then, if in | |
53 | ;; a single move, one moves east,west and south, then both east and | |
54 | ;; west will be improved when they shouldn't | |
55 | ||
56 | ;; Many thanks to Yuri Pryadkin (yuri@rana.usc.edu) for this | |
57 | ;; concise problem description. | |
178fc2d3 | 58 | |
178fc2d3 | 59 | ;;;_* Require |
c0df1972 | 60 | (eval-when-compile (require 'cl)) |
178fc2d3 | 61 | |
178fc2d3 RS |
62 | ;;;_* From Gomoku |
63 | ||
6e44da43 PJ |
64 | ;;; Code: |
65 | ||
323f7c49 SE |
66 | (defgroup lm nil |
67 | "Neural-network robot that learns landmarks." | |
68 | :prefix "lm-" | |
69 | :group 'games) | |
70 | ||
178fc2d3 RS |
71 | ;;;_ + THE BOARD. |
72 | ||
178fc2d3 RS |
73 | ;; The board is a rectangular grid. We code empty squares with 0, X's with 1 |
74 | ;; and O's with 6. The rectangle is recorded in a one dimensional vector | |
75 | ;; containing padding squares (coded with -1). These squares allow us to | |
4fffd73b | 76 | ;; detect when we are trying to move out of the board. We denote a square by |
178fc2d3 RS |
77 | ;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The |
78 | ;; leftmost topmost square has coords (1,1) and index lm-board-width + 2. | |
79 | ;; Similarly, vectors between squares may be given by two DX, DY coords or by | |
80 | ;; one DEPL (the difference between indexes). | |
81 | ||
82 | (defvar lm-board-width nil | |
83 | "Number of columns on the Lm board.") | |
84 | (defvar lm-board-height nil | |
85 | "Number of lines on the Lm board.") | |
86 | ||
87 | (defvar lm-board nil | |
88 | "Vector recording the actual state of the Lm board.") | |
89 | ||
90 | (defvar lm-vector-length nil | |
91 | "Length of lm-board vector.") | |
92 | ||
93 | (defvar lm-draw-limit nil | |
94 | ;; This is usually set to 70% of the number of squares. | |
95 | "After how many moves will Emacs offer a draw?") | |
96 | ||
a7b88742 KH |
97 | (defvar lm-cx 0 |
98 | "This is the x coordinate of the center of the board.") | |
99 | ||
100 | (defvar lm-cy 0 | |
101 | "This is the y coordinate of the center of the board.") | |
102 | ||
103 | (defvar lm-m 0 | |
104 | "This is the x dimension of the playing board.") | |
105 | ||
106 | (defvar lm-n 0 | |
107 | "This is the y dimension of the playing board.") | |
108 | ||
109 | ||
178fc2d3 RS |
110 | (defun lm-xy-to-index (x y) |
111 | "Translate X, Y cartesian coords into the corresponding board index." | |
112 | (+ (* y lm-board-width) x y)) | |
113 | ||
114 | (defun lm-index-to-x (index) | |
115 | "Return corresponding x-coord of board INDEX." | |
116 | (% index (1+ lm-board-width))) | |
117 | ||
118 | (defun lm-index-to-y (index) | |
119 | "Return corresponding y-coord of board INDEX." | |
120 | (/ index (1+ lm-board-width))) | |
121 | ||
122 | (defun lm-init-board () | |
123 | "Create the lm-board vector and fill it with initial values." | |
124 | (setq lm-board (make-vector lm-vector-length 0)) | |
125 | ;; Every square is 0 (i.e. empty) except padding squares: | |
126 | (let ((i 0) (ii (1- lm-vector-length))) | |
127 | (while (<= i lm-board-width) ; The squares in [0..width] and in | |
128 | (aset lm-board i -1) ; [length - width - 1..length - 1] | |
129 | (aset lm-board ii -1) ; are padding squares. | |
130 | (setq i (1+ i) | |
131 | ii (1- ii)))) | |
132 | (let ((i 0)) | |
133 | (while (< i lm-vector-length) | |
134 | (aset lm-board i -1) ; and also all k*(width+1) | |
135 | (setq i (+ i lm-board-width 1))))) | |
136 | ||
a7b88742 | 137 | ;;;_ + DISPLAYING THE BOARD. |
178fc2d3 | 138 | |
a7b88742 KH |
139 | ;; You may change these values if you have a small screen or if the squares |
140 | ;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1). | |
141 | ||
142 | (defconst lm-square-width 2 | |
143 | "*Horizontal spacing between squares on the Lm board.") | |
144 | ||
145 | (defconst lm-square-height 1 | |
146 | "*Vertical spacing between squares on the Lm board.") | |
147 | ||
148 | (defconst lm-x-offset 3 | |
149 | "*Number of columns between the Lm board and the side of the window.") | |
178fc2d3 | 150 | |
a7b88742 KH |
151 | (defconst lm-y-offset 1 |
152 | "*Number of lines between the Lm board and the top of the window.") | |
178fc2d3 RS |
153 | |
154 | ||
155 | ;;;_ + LM MODE AND KEYMAP. | |
156 | ||
323f7c49 SE |
157 | (defcustom lm-mode-hook nil |
158 | "If non-nil, its value is called on entry to Lm mode." | |
159 | :type 'hook | |
160 | :group 'lm) | |
178fc2d3 | 161 | |
a0310a6c DN |
162 | (defvar lm-mode-map |
163 | (let ((map (make-sparse-keymap))) | |
164 | ;; Key bindings for cursor motion. | |
165 | (define-key map "y" 'lm-move-nw) ; y | |
166 | (define-key map "u" 'lm-move-ne) ; u | |
167 | (define-key map "b" 'lm-move-sw) ; b | |
168 | (define-key map "n" 'lm-move-se) ; n | |
169 | (define-key map "h" 'backward-char) ; h | |
170 | (define-key map "l" 'forward-char) ; l | |
171 | (define-key map "j" 'lm-move-down) ; j | |
172 | (define-key map "k" 'lm-move-up) ; k | |
173 | ||
174 | (define-key map [kp-7] 'lm-move-nw) | |
175 | (define-key map [kp-9] 'lm-move-ne) | |
176 | (define-key map [kp-1] 'lm-move-sw) | |
177 | (define-key map [kp-3] 'lm-move-se) | |
178 | (define-key map [kp-4] 'backward-char) | |
179 | (define-key map [kp-6] 'forward-char) | |
180 | (define-key map [kp-2] 'lm-move-down) | |
181 | (define-key map [kp-8] 'lm-move-up) | |
182 | ||
183 | (define-key map "\C-n" 'lm-move-down) ; C-n | |
184 | (define-key map "\C-p" 'lm-move-up) ; C-p | |
185 | ||
186 | ;; Key bindings for entering Human moves. | |
187 | (define-key map "X" 'lm-human-plays) ; X | |
188 | (define-key map "x" 'lm-human-plays) ; x | |
189 | ||
190 | (define-key map " " 'lm-start-robot) ; SPC | |
191 | (define-key map [down-mouse-1] 'lm-start-robot) | |
192 | (define-key map [drag-mouse-1] 'lm-click) | |
193 | (define-key map [mouse-1] 'lm-click) | |
194 | (define-key map [down-mouse-2] 'lm-click) | |
195 | (define-key map [mouse-2] 'lm-mouse-play) | |
196 | (define-key map [drag-mouse-2] 'lm-mouse-play) | |
197 | ||
198 | (define-key map [remap previous-line] 'lm-move-up) | |
199 | (define-key map [remap next-line] 'lm-move-down) | |
200 | (define-key map [remap beginning-of-line] 'lm-beginning-of-line) | |
201 | (define-key map [remap end-of-line] 'lm-end-of-line) | |
202 | (define-key map [remap undo] 'lm-human-takes-back) | |
203 | (define-key map [remap advertised-undo] 'lm-human-takes-back) | |
204 | map) | |
178fc2d3 RS |
205 | "Local keymap to use in Lm mode.") |
206 | ||
a0310a6c | 207 | |
178fc2d3 RS |
208 | |
209 | (defvar lm-emacs-won () | |
210 | "*For making font-lock use the winner's face for the line.") | |
211 | ||
2af34f25 RS |
212 | (defface lm-font-lock-face-O '((((class color)) :foreground "red") |
213 | (t :weight bold)) | |
67d110f1 | 214 | "Face to use for Emacs' O." |
2af34f25 RS |
215 | :version "22.1" |
216 | :group 'lm) | |
178fc2d3 | 217 | |
2af34f25 RS |
218 | (defface lm-font-lock-face-X '((((class color)) :foreground "green") |
219 | (t :weight bold)) | |
67d110f1 | 220 | "Face to use for your X." |
2af34f25 RS |
221 | :version "22.1" |
222 | :group 'lm) | |
178fc2d3 RS |
223 | |
224 | (defvar lm-font-lock-keywords | |
2af34f25 RS |
225 | '(("O" . 'lm-font-lock-face-O) |
226 | ("X" . 'lm-font-lock-face-X) | |
178fc2d3 | 227 | ("[-|/\\]" 0 (if lm-emacs-won |
2af34f25 RS |
228 | 'lm-font-lock-face-O |
229 | 'lm-font-lock-face-X))) | |
178fc2d3 RS |
230 | "*Font lock rules for Lm.") |
231 | ||
232 | (put 'lm-mode 'front-sticky | |
233 | (put 'lm-mode 'rear-nonsticky '(intangible))) | |
234 | (put 'lm-mode 'intangible 1) | |
c52b27c8 EZ |
235 | ;; This one is for when they set view-read-only to t: Landmark cannot |
236 | ;; allow View Mode to be activated in its buffer. | |
33c572f1 | 237 | (put 'lm-mode 'mode-class 'special) |
178fc2d3 RS |
238 | |
239 | (defun lm-mode () | |
240 | "Major mode for playing Lm against Emacs. | |
241 | You and Emacs play in turn by marking a free square. You mark it with X | |
242 | and Emacs marks it with O. The winner is the first to get five contiguous | |
243 | marks horizontally, vertically or in diagonal. | |
244 | ||
245 | You play by moving the cursor over the square you choose and hitting \\[lm-human-plays]. | |
246 | ||
247 | Other useful commands: | |
248 | \\{lm-mode-map} | |
249 | Entry to this mode calls the value of `lm-mode-hook' if that value | |
250 | is non-nil. One interesting value is `turn-on-font-lock'." | |
251 | (interactive) | |
c83c9654 | 252 | (kill-all-local-variables) |
178fc2d3 RS |
253 | (setq major-mode 'lm-mode |
254 | mode-name "Lm") | |
255 | (lm-display-statistics) | |
256 | (use-local-map lm-mode-map) | |
257 | (make-local-variable 'font-lock-defaults) | |
d2ce10d2 GM |
258 | (setq font-lock-defaults '(lm-font-lock-keywords t) |
259 | buffer-read-only t) | |
c83c9654 | 260 | (run-mode-hooks 'lm-mode-hook)) |
178fc2d3 RS |
261 | |
262 | ||
178fc2d3 RS |
263 | ;;;_ + THE SCORE TABLE. |
264 | ||
265 | ||
266 | ;; Every (free) square has a score associated to it, recorded in the | |
267 | ;; LM-SCORE-TABLE vector. The program always plays in the square having | |
268 | ;; the highest score. | |
269 | ||
270 | (defvar lm-score-table nil | |
271 | "Vector recording the actual score of the free squares.") | |
272 | ||
273 | ||
274 | ;; The key point point about the algorithm is that, rather than considering | |
275 | ;; the board as just a set of squares, we prefer to see it as a "space" of | |
276 | ;; internested 5-tuples of contiguous squares (called qtuples). | |
277 | ;; | |
278 | ;; The aim of the program is to fill one qtuple with its O's while preventing | |
279 | ;; you from filling another one with your X's. To that effect, it computes a | |
280 | ;; score for every qtuple, with better qtuples having better scores. Of | |
281 | ;; course, the score of a qtuple (taken in isolation) is just determined by | |
282 | ;; its contents as a set, i.e. not considering the order of its elements. The | |
283 | ;; highest score is given to the "OOOO" qtuples because playing in such a | |
284 | ;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because | |
285 | ;; not playing in it is just loosing the game, and so on. Note that a | |
286 | ;; "polluted" qtuple, i.e. one containing at least one X and at least one O, | |
287 | ;; has score zero because there is no more any point in playing in it, from | |
288 | ;; both an attacking and a defending point of view. | |
289 | ;; | |
290 | ;; Given the score of every qtuple, the score of a given free square on the | |
291 | ;; board is just the sum of the scores of all the qtuples to which it belongs, | |
292 | ;; because playing in that square is playing in all its containing qtuples at | |
293 | ;; once. And it is that function which takes into account the internesting of | |
294 | ;; the qtuples. | |
295 | ;; | |
296 | ;; This algorithm is rather simple but anyway it gives a not so dumb level of | |
297 | ;; play. It easily extends to "n-dimensional Lm", where a win should not | |
298 | ;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !) | |
299 | ;; should be preferred. | |
300 | ||
301 | ||
302 | ;; Here are the scores of the nine "non-polluted" configurations. Tuning | |
303 | ;; these values will change (hopefully improve) the strength of the program | |
304 | ;; and may change its style (rather aggressive here). | |
305 | ||
80cb310d | 306 | (defconst lm-nil-score 7 "Score of an empty qtuple.") |
178fc2d3 RS |
307 | |
308 | (defconst lm-score-trans-table | |
80cb310d SM |
309 | (let ((Xscore 15) ; Score of a qtuple containing one X. |
310 | (XXscore 400) ; Score of a qtuple containing two X's. | |
311 | (XXXscore 1800) ; Score of a qtuple containing three X's. | |
312 | (XXXXscore 100000) ; Score of a qtuple containing four X's. | |
313 | (Oscore 35) ; Score of a qtuple containing one O. | |
314 | (OOscore 800) ; Score of a qtuple containing two O's. | |
315 | (OOOscore 15000) ; Score of a qtuple containing three O's. | |
316 | (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. | |
333 | ;; Other conditions are required to obtain sensible moves, but the | |
334 | ;; previous example should illustrate the point. If you manage to | |
335 | ;; improve on these values, please send me a note. Thanks. | |
336 | ||
337 | ||
338 | ;; As we chose values 0, 1 and 6 to denote empty, X and O squares, | |
339 | ;; the contents of a qtuple are uniquely determined by the sum of | |
340 | ;; its elements and we just have to set up a translation table. | |
341 | (vector lm-nil-score Xscore XXscore XXXscore XXXXscore 0 | |
342 | Oscore 0 0 0 0 0 | |
343 | OOscore 0 0 0 0 0 | |
344 | OOOscore 0 0 0 0 0 | |
345 | OOOOscore 0 0 0 0 0 | |
346 | 0)) | |
178fc2d3 RS |
347 | "Vector associating qtuple contents to their score.") |
348 | ||
349 | ||
350 | ;; If you do not modify drastically the previous constants, the only way for a | |
351 | ;; square to have a score higher than OOOOscore is to belong to a "OOOO" | |
352 | ;; qtuple, thus to be a winning move. Similarly, the only way for a square to | |
353 | ;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX" | |
354 | ;; qtuple. We may use these considerations to detect when a given move is | |
355 | ;; winning or loosing. | |
356 | ||
80cb310d SM |
357 | (defconst lm-winning-threshold |
358 | (aref lm-score-trans-table (+ 6 6 6 6)) ;; OOOOscore | |
178fc2d3 RS |
359 | "Threshold score beyond which an Emacs move is winning.") |
360 | ||
80cb310d SM |
361 | (defconst lm-loosing-threshold |
362 | (aref lm-score-trans-table (+ 1 1 1 1)) ;; XXXXscore | |
178fc2d3 RS |
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 | |
80cb310d | 428 | (make-vector lm-vector-length (* 20 lm-nil-score))) |
178fc2d3 RS |
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) | |
a7b88742 KH |
516 | "Update scores for all squares in the qtuples in range. |
517 | That is, those between the LEFTth square and the RIGHTth after SQUARE, | |
518 | along the DX, DY direction, considering that DVAL has been added on SQUARE." | |
178fc2d3 RS |
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)) | |
a7b88742 KH |
598 | (setq lm-emacs-won nil |
599 | lm-game-history nil | |
600 | lm-number-of-moves 0 | |
178fc2d3 RS |
601 | lm-number-of-human-moves 0 |
602 | lm-emacs-played-first nil | |
a7b88742 | 603 | lm-human-took-back nil |
178fc2d3 RS |
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 | ||
178fc2d3 RS |
645 | ;;;_ + SESSION CONTROL. |
646 | ||
a7b88742 KH |
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.") | |
178fc2d3 RS |
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." | |
a7b88742 KH |
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...")) | |
178fc2d3 RS |
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 | ||
178fc2d3 RS |
682 | ;;;_ + INTERACTIVE COMMANDS. |
683 | ||
178fc2d3 RS |
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)))) | |
a7b88742 | 746 | |
178fc2d3 RS |
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. | |
755 | You must have put the cursor on the square where you want to play. | |
756 | If 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) | |
ce5a3ac0 | 768 | (error "Your point is not on a square. Retry!")) |
178fc2d3 | 769 | ((not (zerop (aref lm-board square))) |
ce5a3ac0 | 770 | (error "Your point is not on a free square. Retry!")) |
178fc2d3 RS |
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) | |
ce5a3ac0 | 795 | (message "You have not played yet... Your move?")) |
178fc2d3 RS |
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")) | |
ce5a3ac0 | 816 | ((y-or-n-p "You mean, you resign? ") |
178fc2d3 | 817 | (lm-terminate-game 'human-resigned)) |
ce5a3ac0 | 818 | ((y-or-n-p "You mean, we continue? ") |
178fc2d3 RS |
819 | (lm-prompt-for-move)) |
820 | (t | |
821 | (lm-terminate-game 'human-resigned)))) ; OK. Accept it | |
822 | ||
178fc2d3 RS |
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) | |
ce5a3ac0 RF |
828 | "Your move? (move to a free square and hit X, RET ...)" |
829 | "Your move?")) | |
178fc2d3 RS |
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. | |
937e6a56 | 832 | ;; FIXME: this can't be right!! --Stef |
178fc2d3 RS |
833 | (save-excursion (set-buffer (other-buffer)))) |
834 | ||
835 | (defun lm-prompt-for-other-game () | |
836 | "Ask for another game, and start it." | |
ce5a3ac0 | 837 | (if (y-or-n-p "Another game? ") |
a7b88742 KH |
838 | (if (y-or-n-p "Retain learned weights ") |
839 | (lm 2) | |
840 | (lm 1)) | |
ce5a3ac0 | 841 | (message "Chicken!"))) |
178fc2d3 RS |
842 | |
843 | (defun lm-offer-a-draw () | |
a7b88742 | 844 | "Offer a draw and return t if Human accepted it." |
ce5a3ac0 | 845 | (or (y-or-n-p "I offer you a draw. Do you accept it? ") |
178fc2d3 RS |
846 | (not (setq lm-human-refused-draw t)))) |
847 | ||
848 | ||
178fc2d3 RS |
849 | (defun lm-max-width () |
850 | "Largest possible board width for the current window." | |
851 | (1+ (/ (- (window-width (selected-window)) | |
852 | lm-x-offset lm-x-offset 1) | |
853 | lm-square-width))) | |
854 | ||
855 | (defun lm-max-height () | |
856 | "Largest possible board height for the current window." | |
857 | (1+ (/ (- (window-height (selected-window)) | |
858 | lm-y-offset lm-y-offset 2) | |
859 | ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line ! | |
860 | lm-square-height))) | |
861 | ||
862 | (defun lm-point-y () | |
863 | "Return the board row where point is." | |
864 | (let ((inhibit-point-motion-hooks t)) | |
865 | (1+ (/ (- (count-lines 1 (point)) lm-y-offset (if (bolp) 0 1)) | |
866 | lm-square-height)))) | |
178fc2d3 RS |
867 | |
868 | (defun lm-point-square () | |
869 | "Return the index of the square point is on." | |
870 | (let ((inhibit-point-motion-hooks t)) | |
871 | (lm-xy-to-index (1+ (/ (- (current-column) lm-x-offset) | |
872 | lm-square-width)) | |
873 | (lm-point-y)))) | |
874 | ||
875 | (defun lm-goto-square (index) | |
876 | "Move point to square number INDEX." | |
877 | (lm-goto-xy (lm-index-to-x index) (lm-index-to-y index))) | |
878 | ||
879 | (defun lm-goto-xy (x y) | |
880 | "Move point to square at X, Y coords." | |
881 | (let ((inhibit-point-motion-hooks t)) | |
9b4c5ecd GM |
882 | (goto-char (point-min)) |
883 | (forward-line (+ lm-y-offset (* lm-square-height (1- y))))) | |
178fc2d3 RS |
884 | (move-to-column (+ lm-x-offset (* lm-square-width (1- x))))) |
885 | ||
886 | (defun lm-plot-square (square value) | |
887 | "Draw 'X', 'O' or '.' on SQUARE depending on VALUE, leave point there." | |
888 | (or (= value 1) | |
889 | (lm-goto-square square)) | |
890 | (let ((inhibit-read-only t) | |
891 | (inhibit-point-motion-hooks t)) | |
892 | (insert-and-inherit (cond ((= value 1) ?.) | |
893 | ((= value 2) ?N) | |
894 | ((= value 3) ?S) | |
895 | ((= value 4) ?E) | |
896 | ((= value 5) ?W) | |
897 | ((= value 6) ?^))) | |
898 | ||
ec45b7bb | 899 | (and (zerop value) |
366be0de EZ |
900 | (add-text-properties (1- (point)) (point) |
901 | '(mouse-face highlight | |
902 | help-echo "\ | |
903 | mouse-1: get robot moving, mouse-2: play on this square"))) | |
178fc2d3 RS |
904 | (delete-char 1) |
905 | (backward-char 1)) | |
906 | (sit-for 0)) ; Display NOW | |
907 | ||
908 | (defun lm-init-display (n m) | |
909 | "Display an N by M Lm board." | |
910 | (buffer-disable-undo (current-buffer)) | |
911 | (let ((inhibit-read-only t) | |
912 | (point 1) opoint | |
913 | (intangible t) | |
914 | (i m) j x) | |
915 | ;; Try to minimize number of chars (because of text properties) | |
916 | (setq tab-width | |
917 | (if (zerop (% lm-x-offset lm-square-width)) | |
918 | lm-square-width | |
919 | (max (/ (+ (% lm-x-offset lm-square-width) | |
920 | lm-square-width 1) 2) 2))) | |
921 | (erase-buffer) | |
922 | (newline lm-y-offset) | |
923 | (while (progn | |
924 | (setq j n | |
925 | x (- lm-x-offset lm-square-width)) | |
926 | (while (>= (setq j (1- j)) 0) | |
927 | (insert-char ?\t (/ (- (setq x (+ x lm-square-width)) | |
928 | (current-column)) | |
929 | tab-width)) | |
930 | (insert-char ? (- x (current-column))) | |
931 | (if (setq intangible (not intangible)) | |
932 | (put-text-property point (point) 'intangible 2)) | |
933 | (and (zerop j) | |
934 | (= i (- m 2)) | |
935 | (progn | |
936 | (while (>= i 3) | |
937 | (append-to-buffer (current-buffer) opoint (point)) | |
938 | (setq i (- i 2))) | |
939 | (goto-char (point-max)))) | |
940 | (setq point (point)) | |
941 | (insert ?=) | |
366be0de EZ |
942 | (add-text-properties point (point) |
943 | '(mouse-face highlight help-echo "\ | |
944 | mouse-1: get robot moving, mouse-2: play on this square"))) | |
178fc2d3 RS |
945 | (> (setq i (1- i)) 0)) |
946 | (if (= i (1- m)) | |
947 | (setq opoint point)) | |
948 | (insert-char ?\n lm-square-height)) | |
949 | (or (eq (char-after 1) ?.) | |
950 | (put-text-property 1 2 'point-entered | |
906f211e | 951 | (lambda (x y) (if (bobp) (forward-char))))) |
178fc2d3 RS |
952 | (or intangible |
953 | (put-text-property point (point) 'intangible 2)) | |
954 | (put-text-property point (point) 'point-entered | |
906f211e | 955 | (lambda (x y) (if (eobp) (backward-char)))) |
178fc2d3 RS |
956 | (put-text-property (point-min) (point) 'category 'lm-mode)) |
957 | (lm-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board | |
958 | (sit-for 0)) ; Display NOW | |
959 | ||
960 | (defun lm-display-statistics () | |
961 | "Obnoxiously display some statistics about previous games in mode line." | |
962 | ;; We store this string in the mode-line-process local variable. | |
963 | ;; This is certainly not the cleanest way out ... | |
964 | (setq mode-line-process | |
a7b88742 KH |
965 | (format ": Trials: %d, Avg#Moves: %d" |
966 | lm-number-of-trials | |
967 | (if (zerop lm-number-of-trials) | |
968 | 0 | |
969 | (/ lm-sum-of-moves lm-number-of-trials)))) | |
178fc2d3 RS |
970 | (force-mode-line-update)) |
971 | ||
972 | (defun lm-switch-to-window () | |
973 | "Find or create the Lm buffer, and display it." | |
974 | (interactive) | |
975 | (let ((buff (get-buffer "*Lm*"))) | |
976 | (if buff ; Buffer exists: | |
977 | (switch-to-buffer buff) ; no problem. | |
978 | (if lm-game-in-progress | |
979 | (lm-crash-game)) ; buffer has been killed or something | |
980 | (switch-to-buffer "*Lm*") ; Anyway, start anew. | |
981 | (lm-mode)))) | |
982 | ||
983 | ||
178fc2d3 RS |
984 | ;;;_ + CROSSING WINNING QTUPLES. |
985 | ||
986 | ;; When someone succeeds in filling a qtuple, we draw a line over the five | |
987 | ;; corresponding squares. One problem is that the program does not know which | |
988 | ;; squares ! It only knows the square where the last move has been played and | |
989 | ;; who won. The solution is to scan the board along all four directions. | |
990 | ||
991 | (defun lm-find-filled-qtuple (square value) | |
a7b88742 | 992 | "Return t if SQUARE belongs to a qtuple filled with VALUEs." |
178fc2d3 RS |
993 | (or (lm-check-filled-qtuple square value 1 0) |
994 | (lm-check-filled-qtuple square value 0 1) | |
995 | (lm-check-filled-qtuple square value 1 1) | |
996 | (lm-check-filled-qtuple square value -1 1))) | |
997 | ||
998 | (defun lm-check-filled-qtuple (square value dx dy) | |
a7b88742 | 999 | "Return t if SQUARE belongs to a qtuple filled with VALUEs along DX, DY." |
178fc2d3 RS |
1000 | (let ((a 0) (b 0) |
1001 | (left square) (right square) | |
1002 | (depl (lm-xy-to-index dx dy))) | |
1003 | (while (and (> a -4) ; stretch tuple left | |
1004 | (= value (aref lm-board (setq left (- left depl))))) | |
1005 | (setq a (1- a))) | |
1006 | (while (and (< b (+ a 4)) ; stretch tuple right | |
1007 | (= value (aref lm-board (setq right (+ right depl))))) | |
1008 | (setq b (1+ b))) | |
1009 | (cond ((= b (+ a 4)) ; tuple length = 5 ? | |
1010 | (lm-cross-qtuple (+ square (* a depl)) (+ square (* b depl)) | |
1011 | dx dy) | |
1012 | t)))) | |
1013 | ||
1014 | (defun lm-cross-qtuple (square1 square2 dx dy) | |
1015 | "Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction." | |
1016 | (save-excursion ; Not moving point from last square | |
1017 | (let ((depl (lm-xy-to-index dx dy)) | |
1018 | (inhibit-read-only t) | |
1019 | (inhibit-point-motion-hooks t)) | |
1020 | ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1 | |
1021 | (while (/= square1 square2) | |
1022 | (lm-goto-square square1) | |
1023 | (setq square1 (+ square1 depl)) | |
1024 | (cond | |
1025 | ((= dy 0) ; Horizontal | |
1026 | (forward-char 1) | |
1027 | (insert-char ?- (1- lm-square-width) t) | |
1028 | (delete-region (point) (progn | |
1029 | (skip-chars-forward " \t") | |
1030 | (point)))) | |
1031 | ((= dx 0) ; Vertical | |
a7b88742 | 1032 | (let ((lm-n 1) |
178fc2d3 | 1033 | (column (current-column))) |
a7b88742 KH |
1034 | (while (< lm-n lm-square-height) |
1035 | (setq lm-n (1+ lm-n)) | |
178fc2d3 RS |
1036 | (forward-line 1) |
1037 | (indent-to column) | |
1038 | (insert-and-inherit ?|)))) | |
1039 | ((= dx -1) ; 1st Diagonal | |
1040 | (indent-to (prog1 (- (current-column) (/ lm-square-width 2)) | |
1041 | (forward-line (/ lm-square-height 2)))) | |
1042 | (insert-and-inherit ?/)) | |
1043 | (t ; 2nd Diagonal | |
1044 | (indent-to (prog1 (+ (current-column) (/ lm-square-width 2)) | |
1045 | (forward-line (/ lm-square-height 2)))) | |
1046 | (insert-and-inherit ?\\)))))) | |
1047 | (sit-for 0)) ; Display NOW | |
1048 | ||
1049 | ||
178fc2d3 RS |
1050 | ;;;_ + CURSOR MOTION. |
1051 | ||
1052 | ;; previous-line and next-line don't work right with intangible newlines | |
1053 | (defun lm-move-down () | |
1054 | "Move point down one row on the Lm board." | |
1055 | (interactive) | |
1056 | (if (< (lm-point-y) lm-board-height) | |
97546017 | 1057 | (forward-line 1)));;; lm-square-height))) |
178fc2d3 RS |
1058 | |
1059 | (defun lm-move-up () | |
1060 | "Move point up one row on the Lm board." | |
1061 | (interactive) | |
1062 | (if (> (lm-point-y) 1) | |
97546017 | 1063 | (forward-line (- lm-square-height)))) |
178fc2d3 RS |
1064 | |
1065 | (defun lm-move-ne () | |
1066 | "Move point North East on the Lm board." | |
1067 | (interactive) | |
1068 | (lm-move-up) | |
1069 | (forward-char)) | |
1070 | ||
1071 | (defun lm-move-se () | |
1072 | "Move point South East on the Lm board." | |
1073 | (interactive) | |
1074 | (lm-move-down) | |
1075 | (forward-char)) | |
1076 | ||
1077 | (defun lm-move-nw () | |
1078 | "Move point North West on the Lm board." | |
1079 | (interactive) | |
1080 | (lm-move-up) | |
1081 | (backward-char)) | |
1082 | ||
1083 | (defun lm-move-sw () | |
1084 | "Move point South West on the Lm board." | |
1085 | (interactive) | |
1086 | (lm-move-down) | |
1087 | (backward-char)) | |
1088 | ||
1089 | (defun lm-beginning-of-line () | |
1090 | "Move point to first square on the Lm board row." | |
1091 | (interactive) | |
1092 | (move-to-column lm-x-offset)) | |
1093 | ||
1094 | (defun lm-end-of-line () | |
1095 | "Move point to last square on the Lm board row." | |
1096 | (interactive) | |
1097 | (move-to-column (+ lm-x-offset | |
1098 | (* lm-square-width (1- lm-board-width))))) | |
1099 | ||
178fc2d3 | 1100 | |
a7b88742 | 1101 | ;;;_ + Simulation variables |
178fc2d3 | 1102 | |
a7b88742 KH |
1103 | ;;;_ - lm-nvar |
1104 | (defvar lm-nvar 0.0075 | |
1105 | "Not used. | |
1106 | Affects a noise generator which was used in an earlier incarnation of | |
1107 | this program to add a random element to the way moves were made.") | |
1108 | ;;;_ - lists of cardinal directions | |
1109 | ;;;_ : | |
1110 | (defvar lm-ns '(lm-n lm-s) | |
1111 | "Used when doing something relative to the north and south axes.") | |
1112 | (defvar lm-ew '(lm-e lm-w) | |
1113 | "Used when doing something relative to the east and west axes.") | |
1114 | (defvar lm-directions '(lm-n lm-s lm-e lm-w) | |
1115 | "The cardinal directions.") | |
1116 | (defvar lm-8-directions | |
1117 | '((lm-n) (lm-n lm-w) (lm-w) (lm-s lm-w) | |
1118 | (lm-s) (lm-s lm-e) (lm-e) (lm-n lm-e)) | |
1119 | "The full 8 possible directions.") | |
1120 | ||
1121 | (defvar lm-number-of-moves | |
1122 | "The number of moves made by the robot so far.") | |
178fc2d3 RS |
1123 | |
1124 | ||
1125 | ;;;_* Terry's mods to create lm.el | |
1126 | ||
178fc2d3 | 1127 | ;;;(setq lm-debug nil) |
a7b88742 KH |
1128 | (defvar lm-debug nil |
1129 | "If non-nil, debugging is printed.") | |
323f7c49 | 1130 | (defcustom lm-one-moment-please nil |
a7b88742 KH |
1131 | "If non-nil, print \"One moment please\" when a new board is generated. |
1132 | The drawback of this is you don't see how many moves the last run took | |
323f7c49 SE |
1133 | because it is overwritten by \"One moment please\"." |
1134 | :type 'boolean | |
1135 | :group 'lm) | |
1136 | (defcustom lm-output-moves t | |
1137 | "If non-nil, output number of moves so far on a move-by-move basis." | |
1138 | :type 'boolean | |
1139 | :group 'lm) | |
178fc2d3 | 1140 | |
178fc2d3 | 1141 | |
a7b88742 KH |
1142 | (defun lm-weights-debug () |
1143 | (if lm-debug | |
1144 | (progn (lm-print-wts) (lm-blackbox) (lm-print-y,s,noise) | |
1145 | (lm-print-smell)))) | |
178fc2d3 RS |
1146 | |
1147 | ;;;_ - Printing various things | |
1148 | (defun lm-print-distance-int (direction) | |
1149 | (interactive) | |
1150 | (insert (format "%S %S " direction (get direction 'distance)))) | |
1151 | ||
1152 | ||
1153 | (defun lm-print-distance () | |
1154 | (insert (format "tree: %S \n" (calc-distance-of-robot-from 'lm-tree))) | |
1155 | (mapc 'lm-print-distance-int lm-directions)) | |
1156 | ||
1157 | ||
1158 | ;;(setq direction 'lm-n) | |
1159 | ;;(get 'lm-n 'lm-s) | |
1160 | (defun lm-nslify-wts-int (direction) | |
c0df1972 | 1161 | (mapcar (lambda (target-direction) |
178fc2d3 RS |
1162 | (get direction target-direction)) |
1163 | lm-directions)) | |
1164 | ||
1165 | ||
1166 | (defun lm-nslify-wts () | |
1167 | (interactive) | |
1168 | (let ((l (apply 'append (mapcar 'lm-nslify-wts-int lm-directions)))) | |
1169 | (insert (format "set data_value WTS \n %s \n" l)) | |
1170 | (insert (format "/* max: %S min: %S */" | |
1171 | (eval (cons 'max l)) (eval (cons 'min l)))))) | |
1172 | ||
1173 | (defun lm-print-wts-int (direction) | |
c0df1972 | 1174 | (mapc (lambda (target-direction) |
178fc2d3 RS |
1175 | (insert (format "%S %S %S " |
1176 | direction | |
1177 | target-direction | |
1178 | (get direction target-direction)))) | |
1179 | lm-directions) | |
1180 | (insert "\n")) | |
1181 | ||
1182 | (defun lm-print-wts () | |
1183 | (interactive) | |
937e6a56 | 1184 | (with-current-buffer "*lm-wts*" |
178fc2d3 RS |
1185 | (insert "==============================\n") |
1186 | (mapc 'lm-print-wts-int lm-directions))) | |
1187 | ||
1188 | (defun lm-print-moves (moves) | |
1189 | (interactive) | |
937e6a56 | 1190 | (with-current-buffer "*lm-moves*" |
178fc2d3 RS |
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) | |
937e6a56 | 1204 | (with-current-buffer "*lm-y,s,noise*" |
178fc2d3 RS |
1205 | (insert "==============================\n") |
1206 | (mapc 'lm-print-y,s,noise-int lm-directions))) | |
1207 | ||
1208 | (defun lm-print-smell-int (direction) | |
1209 | (insert (format "%S: smell: %S \n" | |
1210 | (symbol-name direction) | |
1211 | (get direction 'smell)))) | |
1212 | ||
1213 | (defun lm-print-smell () | |
1214 | (interactive) | |
937e6a56 | 1215 | (with-current-buffer "*lm-smell*" |
178fc2d3 RS |
1216 | (insert "==============================\n") |
1217 | (insert (format "tree: %S \n" (get 'z 't))) | |
1218 | (mapc 'lm-print-smell-int lm-directions))) | |
1219 | ||
1220 | (defun lm-print-w0-int (direction) | |
1221 | (insert (format "%S: w0: %S \n" | |
1222 | (symbol-name direction) | |
1223 | (get direction 'w0)))) | |
1224 | ||
1225 | (defun lm-print-w0 () | |
1226 | (interactive) | |
937e6a56 | 1227 | (with-current-buffer "*lm-w0*" |
178fc2d3 RS |
1228 | (insert "==============================\n") |
1229 | (mapc 'lm-print-w0-int lm-directions))) | |
1230 | ||
1231 | (defun lm-blackbox () | |
937e6a56 | 1232 | (with-current-buffer "*lm-blackbox*" |
178fc2d3 RS |
1233 | (insert "==============================\n") |
1234 | (insert "I smell: ") | |
c0df1972 | 1235 | (mapc (lambda (direction) |
178fc2d3 RS |
1236 | (if (> (get direction 'smell) 0) |
1237 | (insert (format "%S " direction)))) | |
1238 | lm-directions) | |
1239 | (insert "\n") | |
1240 | ||
1241 | (insert "I move: ") | |
c0df1972 | 1242 | (mapc (lambda (direction) |
178fc2d3 RS |
1243 | (if (> (get direction 'y_t) 0) |
1244 | (insert (format "%S " direction)))) | |
1245 | lm-directions) | |
1246 | (insert "\n") | |
1247 | (lm-print-wts-blackbox) | |
1248 | (insert (format "z_t-z_t-1: %S" (- (get 'z 't) (get 'z 't-1)))) | |
1249 | (lm-print-distance) | |
1250 | (insert "\n"))) | |
1251 | ||
1252 | (defun lm-print-wts-blackbox () | |
1253 | (interactive) | |
1254 | (mapc 'lm-print-wts-int lm-directions)) | |
1255 | ||
178fc2d3 | 1256 | ;;;_ - learning parameters |
323f7c49 SE |
1257 | (defcustom lm-bound 0.005 |
1258 | "The maximum that w0j may be." | |
1259 | :type 'number | |
1260 | :group 'lm) | |
1261 | (defcustom lm-c 1.0 | |
a7b88742 | 1262 | "A factor applied to modulate the increase in wij. |
323f7c49 SE |
1263 | Used in the function lm-update-normal-weights." |
1264 | :type 'number | |
1265 | :group 'lm) | |
1266 | (defcustom lm-c-naught 0.5 | |
a7b88742 | 1267 | "A factor applied to modulate the increase in w0j. |
323f7c49 SE |
1268 | Used in the function lm-update-naught-weights." |
1269 | :type 'number | |
1270 | :group 'lm) | |
178fc2d3 RS |
1271 | (defvar lm-initial-w0 0.0) |
1272 | (defvar lm-initial-wij 0.0) | |
323f7c49 | 1273 | (defcustom lm-no-payoff 0 |
a7b88742 | 1274 | "The amount of simulation cycles that have occurred with no movement. |
323f7c49 SE |
1275 | Used to move the robot when he is stuck in a rut for some reason." |
1276 | :type 'integer | |
1277 | :group 'lm) | |
1278 | (defcustom lm-max-stall-time 2 | |
a7b88742 | 1279 | "The maximum number of cycles that the robot can remain stuck in a place. |
323f7c49 SE |
1280 | After this limit is reached, lm-random-move is called to push him out of it." |
1281 | :type 'integer | |
1282 | :group 'lm) | |
178fc2d3 RS |
1283 | |
1284 | ||
1285 | ;;;_ + Randomizing functions | |
1286 | ;;;_ - lm-flip-a-coin () | |
1287 | (defun lm-flip-a-coin () | |
1288 | (if (> (random 5000) 2500) | |
1289 | -1 | |
1290 | 1)) | |
1291 | ;;;_ : lm-very-small-random-number () | |
a7b88742 KH |
1292 | ;(defun lm-very-small-random-number () |
1293 | ; (/ | |
1294 | ; (* (/ (random 900000) 900000.0) .0001))) | |
178fc2d3 RS |
1295 | ;;;_ : lm-randomize-weights-for (direction) |
1296 | (defun lm-randomize-weights-for (direction) | |
c0df1972 | 1297 | (mapc (lambda (target-direction) |
178fc2d3 | 1298 | (put direction |
a7b88742 | 1299 | target-direction |
178fc2d3 RS |
1300 | (* (lm-flip-a-coin) (/ (random 10000) 10000.0)))) |
1301 | lm-directions)) | |
1302 | ;;;_ : lm-noise () | |
1303 | (defun lm-noise () | |
1304 | (* (- (/ (random 30001) 15000.0) 1) lm-nvar)) | |
1305 | ||
178fc2d3 RS |
1306 | ;;;_ : lm-fix-weights-for (direction) |
1307 | (defun lm-fix-weights-for (direction) | |
c0df1972 | 1308 | (mapc (lambda (target-direction) |
178fc2d3 | 1309 | (put direction |
a7b88742 | 1310 | target-direction |
178fc2d3 RS |
1311 | lm-initial-wij)) |
1312 | lm-directions)) | |
178fc2d3 RS |
1313 | |
1314 | ||
1315 | ;;;_ + Plotting functions | |
1316 | ;;;_ - lm-plot-internal (sym) | |
1317 | (defun lm-plot-internal (sym) | |
a7b88742 | 1318 | (lm-plot-square (lm-xy-to-index |
178fc2d3 RS |
1319 | (get sym 'x) |
1320 | (get sym 'y)) | |
1321 | (get sym 'sym))) | |
1322 | ;;;_ - lm-plot-landmarks () | |
1323 | (defun lm-plot-landmarks () | |
1324 | (setq lm-cx (/ lm-board-width 2)) | |
1325 | (setq lm-cy (/ lm-board-height 2)) | |
1326 | ||
a7b88742 KH |
1327 | (put 'lm-n 'x lm-cx) |
1328 | (put 'lm-n 'y 1) | |
178fc2d3 RS |
1329 | (put 'lm-n 'sym 2) |
1330 | ||
1331 | (put 'lm-tree 'x lm-cx) | |
1332 | (put 'lm-tree 'y lm-cy) | |
1333 | (put 'lm-tree 'sym 6) | |
1334 | ||
1335 | (put 'lm-s 'x lm-cx) | |
1336 | (put 'lm-s 'y lm-board-height) | |
1337 | (put 'lm-s 'sym 3) | |
1338 | ||
1339 | (put 'lm-w 'x 1) | |
1340 | (put 'lm-w 'y (/ lm-board-height 2)) | |
1341 | (put 'lm-w 'sym 5) | |
1342 | ||
1343 | (put 'lm-e 'x lm-board-width) | |
1344 | (put 'lm-e 'y (/ lm-board-height 2)) | |
1345 | (put 'lm-e 'sym 4) | |
1346 | ||
1347 | (mapc 'lm-plot-internal '(lm-n lm-s lm-e lm-w lm-tree))) | |
1348 | ||
1349 | ||
1350 | ||
1351 | ;;;_ + Distance-calculation functions | |
1352 | ;;;_ - square (a) | |
1353 | (defun square (a) | |
1354 | (* a a)) | |
1355 | ||
1356 | ;;;_ - distance (x x0 y y0) | |
1357 | (defun distance (x x0 y y0) | |
1358 | (sqrt (+ (square (- x x0)) (square (- y y0))))) | |
1359 | ||
1360 | ;;;_ - calc-distance-of-robot-from (direction) | |
1361 | (defun calc-distance-of-robot-from (direction) | |
1362 | (put direction 'distance | |
1363 | (distance (get direction 'x) | |
1364 | (lm-index-to-x (lm-point-square)) | |
1365 | (get direction 'y) | |
1366 | (lm-index-to-y (lm-point-square))))) | |
1367 | ||
1368 | ;;;_ - calc-smell-internal (sym) | |
1369 | (defun calc-smell-internal (sym) | |
1370 | (let ((r (get sym 'r)) | |
1371 | (d (calc-distance-of-robot-from sym))) | |
1372 | (if (> (* 0.5 (- 1 (/ d r))) 0) | |
1373 | (* 0.5 (- 1 (/ d r))) | |
1374 | 0))) | |
1375 | ||
1376 | ||
178fc2d3 RS |
1377 | ;;;_ + Learning (neural) functions |
1378 | (defun lm-f (x) | |
a7b88742 | 1379 | (cond |
178fc2d3 RS |
1380 | ((> x lm-bound) lm-bound) |
1381 | ((< x 0.0) 0.0) | |
1382 | (t x))) | |
1383 | ||
1384 | (defun lm-y (direction) | |
1385 | (let ((noise (put direction 'noise (lm-noise)))) | |
1386 | (put direction 'y_t | |
1387 | (if (> (get direction 's) 0.0) | |
1388 | 1.0 | |
1389 | 0.0)))) | |
1390 | ||
1391 | (defun lm-update-normal-weights (direction) | |
c0df1972 | 1392 | (mapc (lambda (target-direction) |
178fc2d3 RS |
1393 | (put direction target-direction |
1394 | (+ | |
1395 | (get direction target-direction) | |
a7b88742 KH |
1396 | (* lm-c |
1397 | (- (get 'z 't) (get 'z 't-1)) | |
178fc2d3 RS |
1398 | (get target-direction 'y_t) |
1399 | (get direction 'smell))))) | |
1400 | lm-directions)) | |
a7b88742 | 1401 | |
178fc2d3 | 1402 | (defun lm-update-naught-weights (direction) |
c0df1972 | 1403 | (mapc (lambda (target-direction) |
178fc2d3 | 1404 | (put direction 'w0 |
a7b88742 | 1405 | (lm-f |
178fc2d3 RS |
1406 | (+ |
1407 | (get direction 'w0) | |
1408 | (* lm-c-naught | |
a7b88742 | 1409 | (- (get 'z 't) (get 'z 't-1)) |
178fc2d3 RS |
1410 | (get direction 'y_t)))))) |
1411 | lm-directions)) | |
1412 | ||
1413 | ||
178fc2d3 RS |
1414 | ;;;_ + Statistics gathering and creating functions |
1415 | ||
1416 | (defun lm-calc-current-smells () | |
c0df1972 | 1417 | (mapc (lambda (direction) |
178fc2d3 RS |
1418 | (put direction 'smell (calc-smell-internal direction))) |
1419 | lm-directions)) | |
1420 | ||
1421 | (defun lm-calc-payoff () | |
1422 | (put 'z 't-1 (get 'z 't)) | |
1423 | (put 'z 't (calc-smell-internal 'lm-tree)) | |
1424 | (if (= (- (get 'z 't) (get 'z 't-1)) 0.0) | |
1425 | (incf lm-no-payoff) | |
1426 | (setf lm-no-payoff 0))) | |
1427 | ||
1428 | (defun lm-store-old-y_t () | |
c0df1972 | 1429 | (mapc (lambda (direction) |
178fc2d3 RS |
1430 | (put direction 'y_t-1 (get direction 'y_t))) |
1431 | lm-directions)) | |
1432 | ||
1433 | ||
a7b88742 | 1434 | ;;;_ + Functions to move robot |
178fc2d3 RS |
1435 | |
1436 | (defun lm-confidence-for (target-direction) | |
c0df1972 SM |
1437 | (apply '+ |
1438 | (get target-direction 'w0) | |
1439 | (mapcar (lambda (direction) | |
1440 | (* | |
1441 | (get direction target-direction) | |
1442 | (get direction 'smell))) | |
1443 | lm-directions))) | |
178fc2d3 RS |
1444 | |
1445 | ||
1446 | (defun lm-calc-confidences () | |
c0df1972 | 1447 | (mapc (lambda (direction) |
178fc2d3 RS |
1448 | (put direction 's (lm-confidence-for direction))) |
1449 | lm-directions)) | |
1450 | ||
1451 | (defun lm-move () | |
1452 | (if (and (= (get 'lm-n 'y_t) 1.0) (= (get 'lm-s 'y_t) 1.0)) | |
1453 | (progn | |
c0df1972 | 1454 | (mapc (lambda (dir) (put dir 'y_t 0)) lm-ns) |
a7b88742 KH |
1455 | (if lm-debug |
1456 | (message "n-s normalization.")))) | |
178fc2d3 RS |
1457 | (if (and (= (get 'lm-w 'y_t) 1.0) (= (get 'lm-e 'y_t) 1.0)) |
1458 | (progn | |
c0df1972 | 1459 | (mapc (lambda (dir) (put dir 'y_t 0)) lm-ew) |
a7b88742 KH |
1460 | (if lm-debug |
1461 | (message "e-w normalization")))) | |
178fc2d3 | 1462 | |
c0df1972 | 1463 | (mapc (lambda (pair) |
178fc2d3 RS |
1464 | (if (> (get (car pair) 'y_t) 0) |
1465 | (funcall (car (cdr pair))))) | |
1466 | '( | |
1467 | (lm-n lm-move-up) | |
1468 | (lm-s lm-move-down) | |
1469 | (lm-e forward-char) | |
1470 | (lm-w backward-char))) | |
1471 | (lm-plot-square (lm-point-square) 1) | |
a7b88742 KH |
1472 | (incf lm-number-of-moves) |
1473 | (if lm-output-moves | |
8c307e0f | 1474 | (message "Moves made: %d" lm-number-of-moves))) |
178fc2d3 RS |
1475 | |
1476 | ||
1477 | (defun lm-random-move () | |
a7b88742 | 1478 | (mapc |
c0df1972 | 1479 | (lambda (direction) (put direction 'y_t 0)) |
178fc2d3 RS |
1480 | lm-directions) |
1481 | (dolist (direction (nth (random 8) lm-8-directions)) | |
1482 | (put direction 'y_t 1.0)) | |
1483 | (lm-move)) | |
1484 | ||
1485 | (defun lm-amble-robot () | |
1486 | (interactive) | |
1487 | (while (> (calc-distance-of-robot-from 'lm-tree) 0) | |
1488 | ||
1489 | (lm-store-old-y_t) | |
1490 | (lm-calc-current-smells) | |
1491 | ||
1492 | (if (> lm-no-payoff lm-max-stall-time) | |
1493 | (lm-random-move) | |
1494 | (progn | |
1495 | (lm-calc-confidences) | |
1496 | (mapc 'lm-y lm-directions) | |
1497 | (lm-move))) | |
1498 | ||
1499 | (lm-calc-payoff) | |
1500 | ||
1501 | (mapc 'lm-update-normal-weights lm-directions) | |
1502 | (mapc 'lm-update-naught-weights lm-directions) | |
178fc2d3 | 1503 | (if lm-debug |
a7b88742 KH |
1504 | (lm-weights-debug))) |
1505 | (lm-terminate-game nil)) | |
1506 | ||
178fc2d3 RS |
1507 | |
1508 | ;;;_ - lm-start-robot () | |
1509 | (defun lm-start-robot () | |
1510 | "Signal to the Lm program that you have played. | |
1511 | You must have put the cursor on the square where you want to play. | |
1512 | If the game is finished, this command requests for another game." | |
1513 | (interactive) | |
1514 | (lm-switch-to-window) | |
1515 | (cond | |
1516 | (lm-emacs-is-computing | |
1517 | (lm-crash-game)) | |
1518 | ((not lm-game-in-progress) | |
1519 | (lm-prompt-for-other-game)) | |
1520 | (t | |
1521 | (let (square score) | |
1522 | (setq square (lm-point-square)) | |
1523 | (cond ((null square) | |
ce5a3ac0 | 1524 | (error "Your point is not on a square. Retry!")) |
178fc2d3 | 1525 | ((not (zerop (aref lm-board square))) |
ce5a3ac0 | 1526 | (error "Your point is not on a free square. Retry!")) |
178fc2d3 RS |
1527 | (t |
1528 | (progn | |
1529 | (lm-plot-square square 1) | |
1530 | ||
1531 | (lm-store-old-y_t) | |
1532 | (lm-calc-current-smells) | |
1533 | (put 'z 't (calc-smell-internal 'lm-tree)) | |
1534 | ||
1535 | (lm-random-move) | |
1536 | ||
1537 | (lm-calc-payoff) | |
1538 | ||
1539 | (mapc 'lm-update-normal-weights lm-directions) | |
1540 | (mapc 'lm-update-naught-weights lm-directions) | |
178fc2d3 RS |
1541 | (lm-amble-robot) |
1542 | ))))))) | |
1543 | ||
1544 | ||
178fc2d3 RS |
1545 | ;;;_ + Misc functions |
1546 | ;;;_ - lm-init (auto-start save-weights) | |
a7b88742 KH |
1547 | (defvar lm-tree-r "") |
1548 | ||
178fc2d3 RS |
1549 | (defun lm-init (auto-start save-weights) |
1550 | ||
a7b88742 | 1551 | (setq lm-number-of-moves 0) |
178fc2d3 RS |
1552 | |
1553 | (lm-plot-landmarks) | |
1554 | ||
1555 | (if lm-debug | |
937e6a56 SM |
1556 | (save-current-buffer |
1557 | (set-buffer (get-buffer-create "*lm-w0*")) | |
1558 | (erase-buffer) | |
1559 | (set-buffer (get-buffer-create "*lm-moves*")) | |
1560 | (set-buffer (get-buffer-create "*lm-wts*")) | |
1561 | (erase-buffer) | |
1562 | (set-buffer (get-buffer-create "*lm-y,s,noise*")) | |
1563 | (erase-buffer) | |
1564 | (set-buffer (get-buffer-create "*lm-smell*")) | |
1565 | (erase-buffer) | |
1566 | (set-buffer (get-buffer-create "*lm-blackbox*")) | |
1567 | (erase-buffer) | |
1568 | (set-buffer (get-buffer-create "*lm-distance*")) | |
1569 | (erase-buffer))) | |
178fc2d3 RS |
1570 | |
1571 | ||
1572 | (lm-set-landmark-signal-strengths) | |
1573 | ||
937e6a56 SM |
1574 | (dolist (direction lm-directions) |
1575 | (put direction 'y_t 0.0)) | |
178fc2d3 RS |
1576 | |
1577 | (if (not save-weights) | |
1578 | (progn | |
1579 | (mapc 'lm-fix-weights-for lm-directions) | |
937e6a56 SM |
1580 | (dolist (direction lm-directions) |
1581 | (put direction 'w0 lm-initial-w0))) | |
178fc2d3 RS |
1582 | (message "Weights preserved for this run.")) |
1583 | ||
1584 | (if auto-start | |
1585 | (progn | |
1586 | (lm-goto-xy (1+ (random lm-board-width)) (1+ (random lm-board-height))) | |
1587 | (lm-start-robot)))) | |
a7b88742 | 1588 | |
178fc2d3 RS |
1589 | |
1590 | ;;;_ - something which doesn't work | |
1591 | ; no-a-worka!! | |
1592 | ;(defum lm-sum-list (list) | |
1593 | ; (if (> (length list) 0) | |
1594 | ; (+ (car list) (lm-sum-list (cdr list))) | |
1595 | ; 0)) | |
1596 | ; this a worka! | |
1597 | ; (eval (cons '+ list)) | |
1598 | ;;;_ - lm-set-landmark-signal-strengths () | |
1599 | ;;; on a screen higher than wide, I noticed that the robot would amble | |
1600 | ;;; left and right and not move forward. examining *lm-blackbox* | |
1601 | ;;; revealed that there was no scent from the north and south | |
1602 | ;;; landmarks, hence, they need less factoring down of the effect of | |
1603 | ;;; distance on scent. | |
1604 | ||
1605 | (defun lm-set-landmark-signal-strengths () | |
1606 | ||
1607 | (setq lm-tree-r (* (sqrt (+ (square lm-cx) (square lm-cy))) 1.5)) | |
1608 | ||
c0df1972 | 1609 | (mapc (lambda (direction) |
178fc2d3 RS |
1610 | (put direction 'r (* lm-cx 1.1))) |
1611 | lm-ew) | |
c0df1972 | 1612 | (mapc (lambda (direction) |
178fc2d3 RS |
1613 | (put direction 'r (* lm-cy 1.1))) |
1614 | lm-ns) | |
1615 | (put 'lm-tree 'r lm-tree-r)) | |
1616 | ||
1617 | ||
178fc2d3 RS |
1618 | ;;;_ + lm-test-run () |
1619 | ||
998c789c RS |
1620 | ;;;###autoload |
1621 | (defalias 'landmark-repeat 'lm-test-run) | |
1622 | ;;;###autoload | |
178fc2d3 | 1623 | (defun lm-test-run () |
998c789c | 1624 | "Run 100 Lm games, each time saving the weights from the previous game." |
178fc2d3 RS |
1625 | (interactive) |
1626 | ||
1627 | (lm 1) | |
1628 | ||
1629 | (dotimes (scratch-var 100) | |
1630 | ||
1631 | (lm 2))) | |
1632 | ||
1633 | ||
178fc2d3 RS |
1634 | ;;;_ + lm: The function you invoke to play |
1635 | ||
998c789c RS |
1636 | ;;;###autoload |
1637 | (defalias 'landmark 'lm) | |
1638 | ;;;###autoload | |
a7b88742 | 1639 | (defun lm (parg) |
998c789c | 1640 | "Start or resume an Lm game. |
178fc2d3 RS |
1641 | If a game is in progress, this command allows you to resume it. |
1642 | Here is the relation between prefix args and game options: | |
1643 | ||
1644 | prefix arg | robot is auto-started | weights are saved from last game | |
1645 | --------------------------------------------------------------------- | |
1646 | none / 1 | yes | no | |
1647 | 2 | yes | yes | |
1648 | 3 | no | yes | |
1649 | 4 | no | no | |
1650 | ||
998c789c RS |
1651 | You start by moving to a square and typing \\[lm-start-robot], |
1652 | if you did not use a prefix arg to ask for automatic start. | |
178fc2d3 | 1653 | Use \\[describe-mode] for more info." |
65569e52 | 1654 | (interactive "p") |
178fc2d3 | 1655 | |
a7b88742 | 1656 | (setf lm-n nil lm-m nil) |
178fc2d3 RS |
1657 | (lm-switch-to-window) |
1658 | (cond | |
1659 | (lm-emacs-is-computing | |
1660 | (lm-crash-game)) | |
1661 | ((or (not lm-game-in-progress) | |
1662 | (<= lm-number-of-moves 2)) | |
1663 | (let ((max-width (lm-max-width)) | |
1664 | (max-height (lm-max-height))) | |
a7b88742 KH |
1665 | (or lm-n (setq lm-n max-width)) |
1666 | (or lm-m (setq lm-m max-height)) | |
1667 | (cond ((< lm-n 1) | |
178fc2d3 | 1668 | (error "I need at least 1 column")) |
a7b88742 | 1669 | ((< lm-m 1) |
178fc2d3 | 1670 | (error "I need at least 1 row")) |
a7b88742 KH |
1671 | ((> lm-n max-width) |
1672 | (error "I cannot display %d columns in that window" lm-n))) | |
1673 | (if (and (> lm-m max-height) | |
1674 | (not (eq lm-m lm-saved-board-height)) | |
178fc2d3 | 1675 | ;; Use EQ because SAVED-BOARD-HEIGHT may be nil |
ce5a3ac0 | 1676 | (not (y-or-n-p (format "Do you really want %d rows? " lm-m)))) |
a7b88742 KH |
1677 | (setq lm-m max-height))) |
1678 | (if lm-one-moment-please | |
1679 | (message "One moment, please...")) | |
1680 | (lm-start-game lm-n lm-m) | |
1681 | (eval (cons 'lm-init | |
1682 | (cond | |
1683 | ((= parg 1) '(t nil)) | |
1684 | ((= parg 2) '(t t)) | |
1685 | ((= parg 3) '(nil t)) | |
1686 | ((= parg 4) '(nil nil)) | |
1687 | (t '(nil t)))))))) | |
1688 | ||
1689 | ||
178fc2d3 RS |
1690 | ;;;_ + Local variables |
1691 | ||
5a6c1d87 | 1692 | ;;; The following `allout-layout' local variable setting: |
178fc2d3 RS |
1693 | ;;; - closes all topics from the first topic to just before the third-to-last, |
1694 | ;;; - shows the children of the third to last (config vars) | |
1695 | ;;; - and the second to last (code section), | |
1696 | ;;; - and closes the last topic (this local-variables section). | |
1697 | ;;;Local variables: | |
5a6c1d87 | 1698 | ;;;allout-layout: (0 : -1 -1 0) |
178fc2d3 RS |
1699 | ;;;End: |
1700 | ||
d2fe6685 GM |
1701 | (random t) |
1702 | ||
7130b08f KH |
1703 | (provide 'landmark) |
1704 | ||
178fc2d3 | 1705 | ;;; landmark.el ends here |