lisp/play/mpuz.el

   1 ;;; mpuz.el --- multiplication puzzle for GNU Emacs
   2
   3 ;; Copyright (C) 1990, 2001-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Philippe Schnoebelen <phs@lsv.ens-cachan.fr>
   6 ;; Overhauled: Daniel Pfeiffer <occitan@esperanto.org>
   7 ;; Keywords: games
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; `M-x mpuz' generates a random multiplication puzzle.  This is a
  27 ;; multiplication example in which each digit has been consistently replaced
  28 ;; with some letter.  Your job is to reconstruct the original digits.  Type
  29 ;; `?' while the mode is active for detailed help.
  30
  31 ;;; Code:
  32
  33 (defgroup mpuz nil
  34   "Multiplication puzzle."
  35   :prefix "mpuz-"
  36   :group 'games)
  37
  38 (defcustom mpuz-silent 'error
  39   "Set this to nil if you want dings on inputs.
  40 The value t means never ding, and `error' means only ding on wrong input."
  41   :type '(choice (const :tag "No" nil)
  42                  (const :tag "Yes" t)
  43                  (const :tag "If correct" error))
  44   :group 'mpuz)
  45
  46 (defcustom mpuz-solve-when-trivial t
  47   "Solve any row that can be trivially calculated from what you've found."
  48   :type 'boolean
  49   :group 'mpuz)
  50
  51 (defcustom mpuz-allow-double-multiplicator nil
  52   "Allow 2nd factors like 33 or 77."
  53   :type 'boolean
  54   :group 'mpuz)
  55
  56 (defface mpuz-unsolved
  57   '((default :weight bold)
  58     (((class color)) :foreground "red1"))
  59   "Face for letters to be solved."
  60   :group 'mpuz)
  61
  62 (defface mpuz-solved
  63   '((default :weight bold)
  64     (((class color)) :foreground "green1"))
  65   "Face for solved digits."
  66   :group 'mpuz)
  67
  68 (defface mpuz-trivial
  69   '((default :weight bold)
  70     (((class color)) :foreground "blue"))
  71   "Face for trivial digits solved for you."
  72   :group 'mpuz)
  73
  74 (defface mpuz-text
  75   '((t :inherit variable-pitch))
  76   "Face for text on right."
  77   :group 'mpuz)
  78
  79 \f
  80 ;; Mpuz mode and keymaps
  81 ;;----------------------
  82 (defcustom mpuz-mode-hook nil
  83   "Hook to run upon entry to mpuz."
  84   :type 'hook
  85   :group 'mpuz)
  86
  87 (defvar mpuz-mode-map
  88   (let ((map (make-sparse-keymap)))
  89     (mapc (lambda (ch)
  90             (define-key map (char-to-string ch) 'mpuz-try-letter))
  91           "abcdefghijABCDEFGHIJ")
  92     (define-key map "\C-g" 'mpuz-offer-abort)
  93     (define-key map "?" 'describe-mode)
  94     map)
  95   "Local keymap to use in Mult Puzzle.")
  96
  97
  98
  99 (define-derived-mode mpuz-mode fundamental-mode "Mult Puzzle"
 100   "Multiplication puzzle mode.
 101
 102 You have to guess which letters stand for which digits in the
 103 multiplication displayed inside the `*Mult Puzzle*' buffer.
 104
 105 You may enter a guess for a letter's value by typing first the letter,
 106 then the digit.  Thus, to guess that A=3, type `A 3'.
 107
 108 To leave the game to do other editing work, just switch buffers.
 109 Then you may resume the game with M-x mpuz.
 110 You may abort a game by typing \\<mpuz-mode-map>\\[mpuz-offer-abort]."
 111   (setq tab-width 30))
 112
 113 \f
 114 ;; Some variables for statistics
 115 ;;------------------------------
 116 (defvar mpuz-nb-errors 0
 117   "Number of errors made in current game.")
 118
 119 (defvar mpuz-nb-completed-games 0
 120   "Number of games completed.")
 121
 122 (defvar mpuz-nb-cumulated-errors 0
 123   "Number of errors made in previous games.")
 124
 125
 126 ;; Some variables for game tracking
 127 ;;---------------------------------
 128 (defvar mpuz-in-progress nil
 129   "True if a game is currently in progress.")
 130
 131 (defvar mpuz-found-digits (make-bool-vector 10 nil)
 132   "A vector recording which digits have been decrypted.")
 133
 134 (defvar mpuz-trivial-digits (make-bool-vector 10 nil)
 135   "A vector recording which digits have been solved for you.")
 136
 137 (defmacro mpuz-digit-solved-p (digit)
 138   `(or (aref mpuz-found-digits ,digit)
 139        (aref mpuz-trivial-digits ,digit)))
 140
 141
 142 ;; A puzzle uses a permutation of [0..9] into itself.
 143 ;; We use both the permutation and its inverse.
 144 ;;---------------------------------------------------
 145 (defvar mpuz-digit-to-letter (make-vector 10 0)
 146   "A permutation from [0..9] to [0..9].")
 147
 148 (defvar mpuz-letter-to-digit (make-vector 10 0)
 149   "The inverse of `mpuz-digit-to-letter'.")
 150
 151 (defmacro mpuz-to-digit (letter)
 152   (list 'aref 'mpuz-letter-to-digit letter))
 153
 154 (defmacro mpuz-to-letter (digit)
 155   (list 'aref 'mpuz-digit-to-letter digit))
 156
 157 (defun mpuz-build-random-perm ()
 158   "Initialize puzzle coding with a random permutation."
 159   (let ((letters (list 0 1 2 3 4 5 6 7 8 9)) ; new cons cells, because of delq
 160         (index 10)
 161         elem)
 162     (while letters
 163       (setq elem    (nth (random index) letters)
 164             letters (delq elem letters)
 165             index   (1- index))
 166       (aset mpuz-digit-to-letter index elem)
 167       (aset mpuz-letter-to-digit elem index))))
 168
 169
 170 ;; A puzzle also uses a board displaying a multiplication.
 171 ;; Every digit appears in the board, crypted or not.
 172 ;;------------------------------------------------------
 173 (defvar mpuz-board (make-vector 10 nil)
 174   "The board associates to any digit the list of squares where it appears.")
 175
 176 (defun mpuz-put-number-on-board (number row &rest columns)
 177   "Put (last digit of) NUMBER on ROW and COLUMNS of the puzzle board."
 178   (let (digit)
 179     (dolist (column columns)
 180       (setq digit (% number 10)
 181             number (/ number 10))
 182       (aset mpuz-board digit `((,row . ,column) ,@(aref mpuz-board digit))))))
 183
 184 (defun mpuz-check-all-solved (&optional row col)
 185   "Check whether all digits have been solved.  Return t if yes."
 186   (catch 'solved
 187     (let (A B1 B2 C D E squares)
 188       (and mpuz-solve-when-trivial
 189            (not row)
 190            (while
 191                (cond ((or (and (setq B1 (or B1 (mpuz-check-all-solved 4 7))
 192                                      B2 (or B2 (mpuz-check-all-solved 4 9))
 193                                      E (or E (mpuz-check-all-solved 10))
 194                                      A (or A (mpuz-check-all-solved 2)))
 195                                B1 B2)
 196                           (and E (or A (and B1 B2))))
 197                       (mpuz-solve)
 198                       (mpuz-paint-board)
 199                       (throw 'solved t))
 200                      ((and (setq D (or D (mpuz-check-all-solved 8))
 201                                  C (or C (mpuz-check-all-solved 6)))
 202                            D (not E))
 203                       (mpuz-solve 10))
 204                      ((and E (not (eq C D)))
 205                       (mpuz-solve (if D 6 8)))
 206                      ((and A (not (eq B2 C)))
 207                       (mpuz-solve (if C 4 6) (if C 9)))
 208                      ((and A (not (eq B1 D)))
 209                       (mpuz-solve (if D 4 8) (if D 7)))
 210                      ((and (not A) (or (and B2 C) (and B1 D)))
 211                       (mpuz-solve 2)))))
 212       (mpuz-paint-board)
 213       (mapc (lambda (digit)
 214               (and (not (mpuz-digit-solved-p digit)) ; unsolved
 215                    (setq squares (aref mpuz-board digit))
 216                    (if row
 217                        (if col
 218                            (member (cons row col) squares)
 219                          (assq row squares))
 220                      squares) ; and appearing in the puzzle!
 221                    (throw 'solved nil)))
 222             [0 1 2 3 4 5 6 7 8 9]))
 223     t))
 224
 225
 226 ;; To build a puzzle, we take two random numbers and multiply them.
 227 ;; We also take a random permutation for encryption.
 228 ;; The random numbers are only use to see which digit appears in which square
 229 ;; of the board. Everything is stored in individual squares.
 230 ;;---------------------------------------------------------------------------
 231 (defun mpuz-random-puzzle ()
 232   "Draw random values to be multiplied in a puzzle."
 233   (mpuz-build-random-perm)
 234   (fillarray mpuz-board nil)            ; erase the board
 235   ;; A,B,C,D & E, are the five rows of our multiplication.
 236   ;; Choose random values, discarding cases with leading zeros in C or D.
 237   (let* ((A (if mpuz-allow-double-multiplicator (+ 112 (random 888))
 238               (+ 125 (random 875))))
 239          (min (1+ (/ 999 A)))
 240          (B1 (+ min (random (- 10 min))))
 241          B2 C D E)
 242     (while (if (= B1 (setq B2 (+ min (random (- 10 min)))))
 243                (not mpuz-allow-double-multiplicator)))
 244     (setq C (* A B2)
 245           D (* A B1)
 246           E (+ C (* D 10)))
 247     ;; Individual digits are now put on their respective squares.
 248     ;; [NB: A square is a pair (row . column) of the screen.]
 249     (mpuz-put-number-on-board A 2                9 7 5)
 250     (mpuz-put-number-on-board (+ (* B1 10) B2) 4 9 7)
 251     (mpuz-put-number-on-board C 6                9 7 5 3)
 252     (mpuz-put-number-on-board D 8                  7 5 3 1)
 253     (mpuz-put-number-on-board E 10               9 7 5 3 1)))
 254 \f
 255 ;; Display
 256 ;;--------
 257 (defconst mpuz-framework
 258   "
 259      . . .
 260         Number of errors (this game):   0
 261     x  . .
 262    -------
 263    . . . .
 264         Number of completed games:      0
 265  . . . .
 266  ---------      Average number of errors:       0.00
 267  . . . . ."
 268   "The general picture of the puzzle screen, as a string.")
 269
 270 (defun mpuz-create-buffer ()
 271   "Create (or recreate) the puzzle buffer.  Return it."
 272   (let ((buf (get-buffer-create "*Mult Puzzle*"))
 273         (face '(face mpuz-text))
 274         buffer-read-only)
 275     (with-current-buffer buf
 276       (erase-buffer)
 277       (insert mpuz-framework)
 278       (set-text-properties 13 42 face)
 279       (set-text-properties 79 105 face)
 280       (set-text-properties 128 153 face)
 281       (mpuz-paint-board)
 282       (mpuz-paint-errors)
 283       (mpuz-paint-statistics))
 284     buf))
 285
 286 (defun mpuz-paint-number (n &optional eol words)
 287   (end-of-line eol)
 288   (let (buffer-read-only)
 289     (delete-region (point)
 290                    (progn (backward-word (or words 1)) (point)))
 291     (insert n)))
 292
 293 (defun mpuz-paint-errors ()
 294   "Paint error count on the puzzle screen."
 295   (mpuz-switch-to-window)
 296   (goto-char (point-min))
 297   (forward-line 2)
 298   (mpuz-paint-number (prin1-to-string mpuz-nb-errors)))
 299
 300 (defun mpuz-paint-statistics ()
 301   "Paint statistics about previous games on the puzzle screen."
 302   (goto-char (point-min))
 303   (forward-line 6)
 304   (mpuz-paint-number (prin1-to-string mpuz-nb-completed-games))
 305   (mpuz-paint-number
 306    (format "%.2f"
 307            (if (zerop mpuz-nb-completed-games)
 308                0
 309              (/ (+ 0.0 mpuz-nb-cumulated-errors)
 310                 mpuz-nb-completed-games)))
 311    3 2))
 312
 313 (defun mpuz-paint-board ()
 314   "Paint board situation on the puzzle screen."
 315   (mpuz-switch-to-window)
 316   (mapc 'mpuz-paint-digit [0 1 2 3 4 5 6 7 8 9])
 317   (goto-char (point-min)))
 318
 319 (defun mpuz-paint-digit (digit)
 320   "Paint all occurrences of DIGIT on the puzzle board."
 321   (let ((char (if (mpuz-digit-solved-p digit)
 322                   (+ digit ?0)
 323                 (+ (mpuz-to-letter digit) ?A)))
 324         (face `(face
 325                 ,(cond ((aref mpuz-trivial-digits digit) 'mpuz-trivial)
 326                        ((aref mpuz-found-digits digit) 'mpuz-solved)
 327                        ('mpuz-unsolved))))
 328         buffer-read-only)
 329     (mapc (lambda (square)
 330             (goto-char (point-min))
 331             (forward-line (1- (car square)))    ; line before column!
 332             (move-to-column (cdr square))
 333             (insert char)
 334             (set-text-properties (1- (point)) (point) face)
 335             (delete-char 1))
 336           (aref mpuz-board digit))))
 337
 338 (defun mpuz-get-buffer ()
 339   "Get the puzzle buffer if it exists."
 340   (get-buffer "*Mult Puzzle*"))
 341
 342 (defun mpuz-switch-to-window ()
 343   "Find or create the Mult-Puzzle buffer, and display it."
 344   (let ((buf (mpuz-get-buffer)))
 345     (or buf (setq buf (mpuz-create-buffer)))
 346     (switch-to-buffer buf)
 347     (setq buffer-read-only t)
 348     (mpuz-mode)))
 349
 350 \f
 351 ;; Game control
 352 ;;-------------
 353 (defun mpuz-start-new-game ()
 354   "Start a new puzzle."
 355   (message "Here we go...")
 356   (setq mpuz-nb-errors 0
 357         mpuz-in-progress t)
 358   (fillarray mpuz-found-digits nil)     ; initialize mpuz-found-digits
 359   (fillarray mpuz-trivial-digits nil)
 360   (mpuz-random-puzzle)
 361   (mpuz-switch-to-window)
 362   (mpuz-paint-board)
 363   (mpuz-paint-errors)
 364   (mpuz-ask-for-try))
 365
 366 ;;;###autoload
 367 (defun mpuz ()
 368   "Multiplication puzzle with GNU Emacs."
 369   ;; Main entry point
 370   (interactive)
 371   (mpuz-switch-to-window)
 372   (if mpuz-in-progress
 373       (mpuz-offer-abort)
 374     (mpuz-start-new-game)))
 375
 376 (defun mpuz-offer-abort ()
 377   "Ask if user wants to abort current puzzle."
 378   (interactive)
 379   (if (y-or-n-p "Abort game? ")
 380       (let ((buf (mpuz-get-buffer)))
 381         (message "Mult Puzzle aborted.")
 382         (setq mpuz-in-progress nil
 383               mpuz-nb-errors 0)
 384         (fillarray mpuz-board nil)
 385         (if buf (kill-buffer buf)))
 386     (mpuz-ask-for-try)))
 387
 388 (defun mpuz-ask-for-try ()
 389   "Ask for user proposal in puzzle."
 390   (message "Your try?"))
 391
 392 (defun mpuz-ding (error)
 393   "Dings, unless global variable `mpuz-silent' forbids it."
 394   (cond ((eq mpuz-silent t))
 395         ((not mpuz-silent) (ding t))
 396         (error (ding t))))
 397
 398 (defun mpuz-try-letter ()
 399   "Propose a digit for a letter in puzzle."
 400   (interactive)
 401   (if mpuz-in-progress
 402       (let (letter-char digit digit-char)
 403         (setq letter-char (upcase last-command-event)
 404               digit (mpuz-to-digit (- letter-char ?A)))
 405         (cond ((mpuz-digit-solved-p digit)
 406                (message "%c already solved." letter-char)
 407                (mpuz-ding t))
 408               ((null (aref mpuz-board digit))
 409                (message "%c does not appear." letter-char)
 410                (mpuz-ding t))
 411               ((progn (message "%c = " letter-char)
 412                       ;; <char> has been entered.
 413                       ;; Print "<char> =" and
 414                       ;; read <num> or = <num>
 415                       (setq digit-char (read-char))
 416                       (if (eq digit-char ?=)
 417                           (setq digit-char (read-char)))
 418                       (or (> digit-char ?9) (< digit-char ?0))) ; bad input
 419                (message "%c = %c" letter-char digit-char)
 420                (mpuz-ding t))
 421               (t
 422                (mpuz-try-proposal letter-char digit-char))))
 423     (if (y-or-n-p "Start a new game? ")
 424         (mpuz-start-new-game)
 425       (message "OK. I won't."))))
 426
 427 (defun mpuz-try-proposal (letter-char digit-char)
 428   "Propose LETTER-CHAR as code for DIGIT-CHAR."
 429   (let* ((letter (- letter-char ?A))
 430          (digit (- digit-char ?0))
 431          (correct-digit (mpuz-to-digit letter)))
 432     (cond ((mpuz-digit-solved-p correct-digit)
 433            (message "%c has already been found." (+ correct-digit ?0)))
 434           ((mpuz-digit-solved-p digit)
 435            (message "%c has already been placed." digit-char))
 436           ((= digit correct-digit)
 437            (message "%c = %c correct!" letter-char digit-char)
 438            (mpuz-ding nil)
 439            (aset mpuz-found-digits digit t)     ; Mark digit as solved
 440            (and (mpuz-check-all-solved)
 441                 (mpuz-close-game)))
 442           (t ;;; incorrect guess
 443            (message "%c = %c incorrect!" letter-char digit-char)
 444            (mpuz-ding t)
 445            (setq mpuz-nb-errors (1+ mpuz-nb-errors))
 446            (mpuz-paint-errors)))))
 447
 448 (defun mpuz-close-game ()
 449   "Housecleaning when puzzle has been solved."
 450   (setq mpuz-in-progress nil
 451         mpuz-nb-cumulated-errors (+ mpuz-nb-cumulated-errors mpuz-nb-errors)
 452         mpuz-nb-completed-games (1+ mpuz-nb-completed-games))
 453   (mpuz-paint-statistics)
 454   (let ((message (format "Puzzle solved with %d error%s. That's %s"
 455                          mpuz-nb-errors
 456                          (if (= mpuz-nb-errors 1) "" "s")
 457                          (cond ((= mpuz-nb-errors 0)    "perfect!")
 458                                ((= mpuz-nb-errors 1)    "very good!")
 459                                ((= mpuz-nb-errors 2)    "good.")
 460                                ((= mpuz-nb-errors 3)    "not bad.")
 461                                ((= mpuz-nb-errors 4)    "not too bad...")
 462                                ((< mpuz-nb-errors 10)   "bad!")
 463                                ((< mpuz-nb-errors 15)   "awful.")
 464                                (t                       "not serious.")))))
 465     (message "%s" message)
 466     (sit-for 4)
 467     (if (y-or-n-p (concat message "  Start a new game? "))
 468         (mpuz-start-new-game)
 469       (message "Good Bye!"))))
 470
 471 (defun mpuz-solve (&optional row col)
 472   "Find solution for autosolving."
 473   (mapc (lambda (digit)
 474           (or (mpuz-digit-solved-p digit)
 475               (if row
 476                   (not (if col
 477                            (member (cons row col) (aref mpuz-board digit))
 478                          (assq row (aref mpuz-board digit)))))
 479               (aset mpuz-trivial-digits digit t)))
 480         [0 1 2 3 4 5 6 7 8 9])
 481   t)
 482
 483 (defun mpuz-show-solution (row)
 484   "Display solution for debugging purposes."
 485   (interactive "P")
 486   (mpuz-switch-to-window)
 487   (mpuz-solve (if row (* 2 (prefix-numeric-value row))))
 488   (mpuz-paint-board)
 489   (if (mpuz-check-all-solved)
 490       (mpuz-close-game)))
 491
 492 (provide 'mpuz)
 493
 494 ;;; mpuz.el ends here