22388
|
1 ;;; landmark.el --- neural-network robot that learns landmarks
|
18290
|
2
|
64701
|
3 ;; Copyright (C) 1996, 1997, 2000, 2002, 2003, 2004,
|
68634
836785857446
Update copyright notices of all files in the lisp/play directory.
Romain Francoise <romain@orebokech.com>
diff
changeset
|
4 ;; 2005, 2006 Free Software Foundation, Inc.
|
17905
|
5
|
38455
|
6 ;; Author: Terrence Brannon (was: <brannon@rana.usc.edu>)
|
17905
|
7 ;; Created: December 16, 1996 - first release to usenet
|
54484
|
8 ;; Keywords: gomoku, neural network, adaptive search, chemotaxis
|
17905
|
9
|
18290
|
10 ;;;_* Usage
|
|
11 ;;; Just type
|
71625
|
12 ;;; M-x eval-buffer
|
18290
|
13 ;;; M-x lm-test-run
|
|
14
|
|
15
|
17905
|
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
|
64085
|
30 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
31 ;; Boston, MA 02110-1301, USA.
|
17905
|
32
|
|
33
|
38425
|
34 ;;; Commentary:
|
17905
|
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
|
18290
|
43 ;;; In laymen's terms, the search space is initially flat. The point
|
17905
|
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
|
18290
|
58 ;;; Many thanks to Yuri Pryadkin (yuri@rana.usc.edu) for this
|
|
59 ;;; concise problem description.
|
17905
|
60
|
|
61 ;;;_* Require
|
30888
|
62 (eval-when-compile (require 'cl))
|
17905
|
63
|
|
64 ;;;_* From Gomoku
|
|
65
|
38425
|
66 ;;; Code:
|
|
67
|
21363
|
68 (defgroup lm nil
|
|
69 "Neural-network robot that learns landmarks."
|
|
70 :prefix "lm-"
|
|
71 :group 'games)
|
|
72
|
17905
|
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
|
18290
|
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
|
17905
|
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
|
18290
|
139 ;;;_ + DISPLAYING THE BOARD.
|
17905
|
140
|
18290
|
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).
|
17905
|
143
|
18290
|
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.")
|
17905
|
155
|
|
156
|
|
157 ;;;_ + LM MODE AND KEYMAP.
|
|
158
|
21363
|
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)
|
17905
|
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
|
49174
|
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))
|
17905
|
210
|
|
211 (defvar lm-emacs-won ()
|
|
212 "*For making font-lock use the winner's face for the line.")
|
|
213
|
69895
|
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)
|
17905
|
219
|
69895
|
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)
|
17905
|
225
|
|
226 (defvar lm-font-lock-keywords
|
69895
|
227 '(("O" . 'lm-font-lock-face-O)
|
|
228 ("X" . 'lm-font-lock-face-X)
|
17905
|
229 ("[-|/\\]" 0 (if lm-emacs-won
|
69895
|
230 'lm-font-lock-face-O
|
|
231 'lm-font-lock-face-X)))
|
17905
|
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)
|
41317
a33250d752d4
Mark lm-mode as special. Suggested by Klaus Straubinger <ksnetz@arcor.de>
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
237 ;; This one is for when they set view-read-only to t: Landmark cannot
|
a33250d752d4
Mark lm-mode as special. Suggested by Klaus Straubinger <ksnetz@arcor.de>
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
238 ;; allow View Mode to be activated in its buffer.
|
41320
|
239 (put 'lm-mode 'mode-class 'special)
|
17905
|
240
|
|
241 (defun lm-mode ()
|
|
242 "Major mode for playing Lm against Emacs.
|
|
243 You and Emacs play in turn by marking a free square. You mark it with X
|
|
244 and Emacs marks it with O. The winner is the first to get five contiguous
|
|
245 marks horizontally, vertically or in diagonal.
|
|
246
|
|
247 You play by moving the cursor over the square you choose and hitting \\[lm-human-plays].
|
|
248
|
|
249 Other useful commands:
|
|
250 \\{lm-mode-map}
|
|
251 Entry to this mode calls the value of `lm-mode-hook' if that value
|
|
252 is non-nil. One interesting value is `turn-on-font-lock'."
|
|
253 (interactive)
|
62770
|
254 (kill-all-local-variables)
|
17905
|
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)
|
62770
|
262 (run-mode-hooks 'lm-mode-hook))
|
17905
|
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)
|
18290
|
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."
|
17905
|
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))
|
18290
|
598 (setq lm-emacs-won nil
|
|
599 lm-game-history nil
|
|
600 lm-number-of-moves 0
|
17905
|
601 lm-number-of-human-moves 0
|
|
602 lm-emacs-played-first nil
|
18290
|
603 lm-human-took-back nil
|
17905
|
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
|
18290
|
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.")
|
17905
|
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."
|
18290
|
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..."))
|
17905
|
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))))
|
18290
|
746
|
17905
|
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)
|
65689
|
768 (error "Your point is not on a square. Retry!"))
|
17905
|
769 ((not (zerop (aref lm-board square)))
|
65689
|
770 (error "Your point is not on a free square. Retry!"))
|
17905
|
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)
|
65689
|
795 (message "You have not played yet... Your move?"))
|
17905
|
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"))
|
65689
|
816 ((y-or-n-p "You mean, you resign? ")
|
17905
|
817 (lm-terminate-game 'human-resigned))
|
65689
|
818 ((y-or-n-p "You mean, we continue? ")
|
17905
|
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)
|
65689
|
828 "Your move? (move to a free square and hit X, RET ...)"
|
|
829 "Your move?"))
|
17905
|
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."
|
65689
|
836 (if (y-or-n-p "Another game? ")
|
18290
|
837 (if (y-or-n-p "Retain learned weights ")
|
|
838 (lm 2)
|
|
839 (lm 1))
|
65689
|
840 (message "Chicken!")))
|
17905
|
841
|
|
842 (defun lm-offer-a-draw ()
|
18290
|
843 "Offer a draw and return t if Human accepted it."
|
65689
|
844 (or (y-or-n-p "I offer you a draw. Do you accept it? ")
|
17905
|
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
|
30542
|
897 (and (zerop value)
|
38076
30c899dc34c4
(lm-plot-square, lm-init-display): Add help-echo to mouse-highlighted text.
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
898 (add-text-properties (1- (point)) (point)
|
30c899dc34c4
(lm-plot-square, lm-init-display): Add help-echo to mouse-highlighted text.
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
899 '(mouse-face highlight
|
30c899dc34c4
(lm-plot-square, lm-init-display): Add help-echo to mouse-highlighted text.
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
900 help-echo "\
|
30c899dc34c4
(lm-plot-square, lm-init-display): Add help-echo to mouse-highlighted text.
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
901 mouse-1: get robot moving, mouse-2: play on this square")))
|
17905
|
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 ?=)
|
38076
30c899dc34c4
(lm-plot-square, lm-init-display): Add help-echo to mouse-highlighted text.
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
940 (add-text-properties point (point)
|
30c899dc34c4
(lm-plot-square, lm-init-display): Add help-echo to mouse-highlighted text.
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
941 '(mouse-face highlight help-echo "\
|
30c899dc34c4
(lm-plot-square, lm-init-display): Add help-echo to mouse-highlighted text.
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
942 mouse-1: get robot moving, mouse-2: play on this square")))
|
17905
|
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
|
39866
|
949 (lambda (x y) (if (bobp) (forward-char)))))
|
17905
|
950 (or intangible
|
|
951 (put-text-property point (point) 'intangible 2))
|
|
952 (put-text-property point (point) 'point-entered
|
39866
|
953 (lambda (x y) (if (eobp) (backward-char))))
|
17905
|
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
|
18290
|
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))))
|
17905
|
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)
|
18290
|
990 "Return t if SQUARE belongs to a qtuple filled with VALUEs."
|
17905
|
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)
|
18290
|
997 "Return t if SQUARE belongs to a qtuple filled with VALUEs along DX, DY."
|
17905
|
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
|
18290
|
1030 (let ((lm-n 1)
|
17905
|
1031 (column (current-column)))
|
18290
|
1032 (while (< lm-n lm-square-height)
|
|
1033 (setq lm-n (1+ lm-n))
|
17905
|
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
|
18290
|
1099 ;;;_ + Simulation variables
|
17905
|
1100
|
18290
|
1101 ;;;_ - lm-nvar
|
|
1102 (defvar lm-nvar 0.0075
|
|
1103 "Not used.
|
|
1104 Affects a noise generator which was used in an earlier incarnation of
|
|
1105 this 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.")
|
17905
|
1118
|
18290
|
1119 (defvar lm-number-of-moves
|
|
1120 "The number of moves made by the robot so far.")
|
17905
|
1121
|
|
1122
|
|
1123 ;;;_* Terry's mods to create lm.el
|
|
1124
|
|
1125 ;;;(setq lm-debug nil)
|
18290
|
1126 (defvar lm-debug nil
|
|
1127 "If non-nil, debugging is printed.")
|
21363
|
1128 (defcustom lm-one-moment-please nil
|
18290
|
1129 "If non-nil, print \"One moment please\" when a new board is generated.
|
|
1130 The drawback of this is you don't see how many moves the last run took
|
21363
|
1131 because 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)
|
17905
|
1138
|
18290
|
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))))
|
17905
|
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)
|
30888
|
1159 (mapcar (lambda (target-direction)
|
17905
|
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)
|
30888
|
1172 (mapc (lambda (target-direction)
|
17905
|
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: ")
|
30888
|
1239 (mapc (lambda (direction)
|
17905
|
1240 (if (> (get direction 'smell) 0)
|
|
1241 (insert (format "%S " direction))))
|
|
1242 lm-directions)
|
|
1243 (insert "\n")
|
|
1244
|
|
1245 (insert "I move: ")
|
30888
|
1246 (mapc (lambda (direction)
|
17905
|
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
|
21363
|
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
|
18290
|
1266 "A factor applied to modulate the increase in wij.
|
21363
|
1267 Used in the function lm-update-normal-weights."
|
|
1268 :type 'number
|
|
1269 :group 'lm)
|
|
1270 (defcustom lm-c-naught 0.5
|
18290
|
1271 "A factor applied to modulate the increase in w0j.
|
21363
|
1272 Used in the function lm-update-naught-weights."
|
|
1273 :type 'number
|
|
1274 :group 'lm)
|
17905
|
1275 (defvar lm-initial-w0 0.0)
|
|
1276 (defvar lm-initial-wij 0.0)
|
21363
|
1277 (defcustom lm-no-payoff 0
|
18290
|
1278 "The amount of simulation cycles that have occurred with no movement.
|
21363
|
1279 Used 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
|
18290
|
1283 "The maximum number of cycles that the robot can remain stuck in a place.
|
21363
|
1284 After this limit is reached, lm-random-move is called to push him out of it."
|
|
1285 :type 'integer
|
|
1286 :group 'lm)
|
17905
|
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 ()
|
18290
|
1296 ;(defun lm-very-small-random-number ()
|
|
1297 ; (/
|
|
1298 ; (* (/ (random 900000) 900000.0) .0001)))
|
17905
|
1299 ;;;_ : lm-randomize-weights-for (direction)
|
|
1300 (defun lm-randomize-weights-for (direction)
|
30888
|
1301 (mapc (lambda (target-direction)
|
17905
|
1302 (put direction
|
18290
|
1303 target-direction
|
17905
|
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)
|
30888
|
1312 (mapc (lambda (target-direction)
|
17905
|
1313 (put direction
|
18290
|
1314 target-direction
|
17905
|
1315 lm-initial-wij))
|
|
1316 lm-directions))
|
|
1317
|
|
1318
|
|
1319 ;;;_ + Plotting functions
|
|
1320 ;;;_ - lm-plot-internal (sym)
|
|
1321 (defun lm-plot-internal (sym)
|
18290
|
1322 (lm-plot-square (lm-xy-to-index
|
17905
|
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
|
18290
|
1331 (put 'lm-n 'x lm-cx)
|
|
1332 (put 'lm-n 'y 1)
|
17905
|
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)
|
18290
|
1383 (cond
|
17905
|
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)
|
30888
|
1396 (mapc (lambda (target-direction)
|
17905
|
1397 (put direction target-direction
|
|
1398 (+
|
|
1399 (get direction target-direction)
|
18290
|
1400 (* lm-c
|
|
1401 (- (get 'z 't) (get 'z 't-1))
|
17905
|
1402 (get target-direction 'y_t)
|
|
1403 (get direction 'smell)))))
|
|
1404 lm-directions))
|
18290
|
1405
|
17905
|
1406 (defun lm-update-naught-weights (direction)
|
30888
|
1407 (mapc (lambda (target-direction)
|
17905
|
1408 (put direction 'w0
|
18290
|
1409 (lm-f
|
17905
|
1410 (+
|
|
1411 (get direction 'w0)
|
|
1412 (* lm-c-naught
|
18290
|
1413 (- (get 'z 't) (get 'z 't-1))
|
17905
|
1414 (get direction 'y_t))))))
|
|
1415 lm-directions))
|
|
1416
|
|
1417
|
|
1418 ;;;_ + Statistics gathering and creating functions
|
|
1419
|
|
1420 (defun lm-calc-current-smells ()
|
30888
|
1421 (mapc (lambda (direction)
|
17905
|
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 ()
|
30888
|
1433 (mapc (lambda (direction)
|
17905
|
1434 (put direction 'y_t-1 (get direction 'y_t)))
|
|
1435 lm-directions))
|
|
1436
|
|
1437
|
18290
|
1438 ;;;_ + Functions to move robot
|
17905
|
1439
|
|
1440 (defun lm-confidence-for (target-direction)
|
30888
|
1441 (apply '+
|
|
1442 (get target-direction 'w0)
|
|
1443 (mapcar (lambda (direction)
|
|
1444 (*
|
|
1445 (get direction target-direction)
|
|
1446 (get direction 'smell)))
|
|
1447 lm-directions)))
|
17905
|
1448
|
|
1449
|
|
1450 (defun lm-calc-confidences ()
|
30888
|
1451 (mapc (lambda (direction)
|
17905
|
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
|
30888
|
1458 (mapc (lambda (dir) (put dir 'y_t 0)) lm-ns)
|
18290
|
1459 (if lm-debug
|
|
1460 (message "n-s normalization."))))
|
17905
|
1461 (if (and (= (get 'lm-w 'y_t) 1.0) (= (get 'lm-e 'y_t) 1.0))
|
|
1462 (progn
|
30888
|
1463 (mapc (lambda (dir) (put dir 'y_t 0)) lm-ew)
|
18290
|
1464 (if lm-debug
|
|
1465 (message "e-w normalization"))))
|
17905
|
1466
|
30888
|
1467 (mapc (lambda (pair)
|
17905
|
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)
|
18290
|
1476 (incf lm-number-of-moves)
|
|
1477 (if lm-output-moves
|
65585
|
1478 (message "Moves made: %d" lm-number-of-moves)))
|
17905
|
1479
|
|
1480
|
|
1481 (defun lm-random-move ()
|
18290
|
1482 (mapc
|
30888
|
1483 (lambda (direction) (put direction 'y_t 0))
|
17905
|
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)
|
18290
|
1507 (if lm-debug
|
|
1508 (lm-weights-debug)))
|
|
1509 (lm-terminate-game nil))
|
17905
|
1510
|
|
1511
|
|
1512 ;;;_ - lm-start-robot ()
|
|
1513 (defun lm-start-robot ()
|
|
1514 "Signal to the Lm program that you have played.
|
|
1515 You must have put the cursor on the square where you want to play.
|
|
1516 If 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)
|
65689
|
1528 (error "Your point is not on a square. Retry!"))
|
17905
|
1529 ((not (zerop (aref lm-board square)))
|
65689
|
1530 (error "Your point is not on a free square. Retry!"))
|
17905
|
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)
|
18290
|
1551 (defvar lm-tree-r "")
|
|
1552
|
17905
|
1553 (defun lm-init (auto-start save-weights)
|
|
1554
|
18290
|
1555 (setq lm-number-of-moves 0)
|
17905
|
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
|
30888
|
1579 (mapc (lambda (direction)
|
17905
|
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)
|
30888
|
1586 (mapc (lambda (direction)
|
17905
|
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))))
|
18290
|
1595
|
17905
|
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
|
30888
|
1616 (mapc (lambda (direction)
|
17905
|
1617 (put direction 'r (* lm-cx 1.1)))
|
|
1618 lm-ew)
|
30888
|
1619 (mapc (lambda (direction)
|
17905
|
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
|
18951
|
1627 ;;;###autoload
|
|
1628 (defalias 'landmark-repeat 'lm-test-run)
|
|
1629 ;;;###autoload
|
17905
|
1630 (defun lm-test-run ()
|
18951
|
1631 "Run 100 Lm games, each time saving the weights from the previous game."
|
17905
|
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
|
18951
|
1643 ;;;###autoload
|
|
1644 (defalias 'landmark 'lm)
|
|
1645 ;;;###autoload
|
18290
|
1646 (defun lm (parg)
|
18951
|
1647 "Start or resume an Lm game.
|
17905
|
1648 If a game is in progress, this command allows you to resume it.
|
|
1649 Here is the relation between prefix args and game options:
|
|
1650
|
|
1651 prefix arg | robot is auto-started | weights are saved from last game
|
|
1652 ---------------------------------------------------------------------
|
|
1653 none / 1 | yes | no
|
|
1654 2 | yes | yes
|
|
1655 3 | no | yes
|
|
1656 4 | no | no
|
|
1657
|
18951
|
1658 You start by moving to a square and typing \\[lm-start-robot],
|
|
1659 if you did not use a prefix arg to ask for automatic start.
|
17905
|
1660 Use \\[describe-mode] for more info."
|
37840
|
1661 (interactive "p")
|
17905
|
1662
|
18290
|
1663 (setf lm-n nil lm-m nil)
|
17905
|
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)))
|
18290
|
1672 (or lm-n (setq lm-n max-width))
|
|
1673 (or lm-m (setq lm-m max-height))
|
|
1674 (cond ((< lm-n 1)
|
17905
|
1675 (error "I need at least 1 column"))
|
18290
|
1676 ((< lm-m 1)
|
17905
|
1677 (error "I need at least 1 row"))
|
18290
|
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))
|
17905
|
1682 ;; Use EQ because SAVED-BOARD-HEIGHT may be nil
|
65689
|
1683 (not (y-or-n-p (format "Do you really want %d rows? " lm-m))))
|
18290
|
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
|
17905
|
1697 ;;;_ + Local variables
|
|
1698
|
68866
|
1699 ;;; The following `allout-layout' local variable setting:
|
17905
|
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:
|
68866
|
1705 ;;;allout-layout: (0 : -1 -1 0)
|
17905
|
1706 ;;;End:
|
|
1707
|
25227
|
1708 (provide 'landmark)
|
|
1709
|
52401
|
1710 ;;; arch-tag: ae5031be-96e6-459e-a3df-1df53117d3f2
|
17905
|
1711 ;;; landmark.el ends here
|