lisp/play/cookie1.el

   1 ;;; cookie1.el --- retrieve random phrases from fortune cookie files
   2
   3 ;; Copyright (C) 1993, 2001-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
   6 ;; Maintainer: FSF
   7 ;; Keywords: games, extensions
   8 ;; Created: Mon Mar 22 17:06:26 1993
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Support for random cookie fetches from phrase files, used for such
  28 ;; critical applications as confounding the NSA Trunk Trawler.
  29 ;;
  30 ;; The two entry points are `cookie' and `cookie-insert'.  The helper
  31 ;; function `cookie-shuffle-vector' may be of interest to programmers.
  32 ;;
  33 ;; The code expects phrase files to be in one of two formats:
  34 ;;
  35 ;; * ITS-style LINS format (strings terminated by ASCII 0 characters,
  36 ;; leading whitespace ignored).
  37 ;;
  38 ;; * UNIX fortune file format (quotes terminated by %% on a line by itself).
  39 ;;
  40 ;; Everything up to the first delimiter is treated as a comment.  Other
  41 ;; formats could be supported by adding alternates to the regexp
  42 ;; `cookie-delimiter'.
  43 ;;
  44 ;; strfile(1) is the program used to compile the files for fortune(6).
  45 ;; In order to achieve total compatibility with strfile(1), cookie files
  46 ;; should start with two consecutive delimiters (and no comment).
  47 ;;
  48 ;; This code derives from Steve Strassmann's 1987 spook.el package, but
  49 ;; has been generalized so that it supports multiple simultaneous
  50 ;; cookie databases and fortune files.  It is intended to be called
  51 ;; from other packages such as spook.el.
  52
  53 ;;; Code:
  54
  55 (defgroup cookie nil
  56   "Random cookies from phrase files."
  57   :prefix "cookie-"
  58   :group 'games)
  59
  60 (defcustom cookie-file nil
  61   "Default phrase file for cookie functions."
  62   :type '(choice (const nil) file)
  63   :group 'cookie
  64   :version "24.4")
  65
  66 (defconst cookie-delimiter "\n%%\n\\|\n%\n\\|\0"
  67   "Delimiter used to separate cookie file entries.")
  68
  69 (defvar cookie-cache (make-vector 511 0)
  70   "Cache of cookie files that have already been snarfed.")
  71
  72 (defun cookie-check-file (file)
  73   "Return either FILE or `cookie-file'.
  74 Signal an error if the result is nil or not readable."
  75   (or (setq file (or file cookie-file)) (user-error "No phrase file specified"))
  76   (or (file-readable-p file) (user-error "Cannot read file `%s'" file))
  77   file)
  78
  79 ;;;###autoload
  80 (defun cookie (phrase-file &optional startmsg endmsg)
  81   "Return a random phrase from PHRASE-FILE.
  82 When the phrase file is read in, display STARTMSG at the beginning
  83 of load, ENDMSG at the end.
  84 Interactively, PHRASE-FILE defaults to `cookie-file', unless that
  85 is nil or a prefix argument is used."
  86   (interactive (list (if (or current-prefix-arg (not cookie-file))
  87                          (read-file-name "Cookie file: " nil
  88                                          cookie-file t cookie-file)
  89                        cookie-file) nil nil))
  90   (setq phrase-file (cookie-check-file phrase-file))
  91   (let ((cookie-vector (cookie-snarf phrase-file startmsg endmsg))
  92         res)
  93     (cookie-shuffle-vector cookie-vector)
  94     (setq res (aref cookie-vector 0))
  95     (if (called-interactively-p 'interactive)
  96         (message "%s" res)
  97       res)))
  98
  99 ;;;###autoload
 100 (defun cookie-insert (phrase-file &optional count startmsg endmsg)
 101   "Insert random phrases from PHRASE-FILE; COUNT of them.
 102 When the phrase file is read in, display STARTMSG at the beginning
 103 of load, ENDMSG at the end."
 104   (setq phrase-file (cookie-check-file phrase-file))
 105   (let ((cookie-vector (cookie-snarf phrase-file startmsg endmsg)))
 106     (cookie-shuffle-vector cookie-vector)
 107     (let ((start (point)))
 108       (insert ?\n)
 109       (cookie1 (min (- (length cookie-vector) 1) (or count 1)) cookie-vector)
 110       (insert ?\n)
 111       (fill-region-as-paragraph start (point) nil))))
 112
 113 (defun cookie1 (arg cookie-vec)
 114   "Inserts a cookie phrase ARG times."
 115   (cond ((zerop arg) t)
 116         (t (insert (aref cookie-vec arg))
 117            (insert " ")
 118            (cookie1 (1- arg) cookie-vec))))
 119
 120 ;;;###autoload
 121 (defun cookie-snarf (phrase-file &optional startmsg endmsg)
 122   "Reads in the PHRASE-FILE, returns it as a vector of strings.
 123 Emit STARTMSG and ENDMSG before and after.  Caches the result; second
 124 and subsequent calls on the same file won't go to disk."
 125   (setq phrase-file (cookie-check-file phrase-file))
 126   (let ((sym (intern-soft phrase-file cookie-cache)))
 127     (and sym (not (equal (symbol-function sym)
 128                          (nth 5 (file-attributes phrase-file))))
 129          (yes-or-no-p (concat phrase-file
 130                               " has changed.  Read new contents? "))
 131          (setq sym nil))
 132     (if sym
 133         (symbol-value sym)
 134       (setq sym (intern phrase-file cookie-cache))
 135       (if startmsg (message "%s" startmsg))
 136       (fset sym (nth 5 (file-attributes phrase-file)))
 137       (let (result)
 138         (with-temp-buffer
 139           (insert-file-contents (expand-file-name phrase-file))
 140           (re-search-forward cookie-delimiter)
 141           (while (progn (skip-chars-forward " \t\n\r\f") (not (eobp)))
 142             (let ((beg (point)))
 143               (re-search-forward cookie-delimiter)
 144               (setq result (cons (buffer-substring beg (match-beginning 0))
 145                                  result)))))
 146         (if endmsg (message "%s" endmsg))
 147         (set sym (apply 'vector result))))))
 148
 149 (defun cookie-read (prompt phrase-file &optional startmsg endmsg require-match)
 150   "Prompt with PROMPT and read with completion among cookies in PHRASE-FILE.
 151 STARTMSG and ENDMSG are passed along to `cookie-snarf'.
 152 Argument REQUIRE-MATCH non-nil forces a matching cookie."
 153   (setq phrase-file (cookie-check-file phrase-file))
 154   ;; Make sure the cookies are in the cache.
 155   (or (intern-soft phrase-file cookie-cache)
 156       (cookie-snarf phrase-file startmsg endmsg))
 157   (completing-read prompt
 158                    (let ((sym (intern phrase-file cookie-cache)))
 159                      ;; We cache the alist form of the cookie in a property.
 160                      (or (get sym 'completion-alist)
 161                          (let* ((alist nil)
 162                                 (vec (cookie-snarf phrase-file
 163                                                    startmsg endmsg))
 164                                 (i (length vec)))
 165                            (while (>= (setq i (1- i)) 0)
 166                              (setq alist (cons (list (aref vec i)) alist)))
 167                            (put sym 'completion-alist alist))))
 168                    nil require-match nil nil))
 169
 170 (define-obsolete-function-alias 'read-cookie 'cookie-read "24.4")
 171
 172 ;; Thanks to Ian G Batten <BattenIG@CS.BHAM.AC.UK>
 173 ;; [of the University of Birmingham Computer Science Department]
 174 ;; for the iterative version of this shuffle.
 175 (defun cookie-shuffle-vector (vector)
 176   "Randomly permute the elements of VECTOR (all permutations equally likely)."
 177   (let ((len (length vector))
 178         j temp)
 179     (dotimes (i len vector)
 180       (setq j (+ i (random (- len i)))
 181             temp (aref vector i))
 182       (aset vector i (aref vector j))
 183       (aset vector j temp))))
 184
 185 (define-obsolete-function-alias 'shuffle-vector 'cookie-shuffle-vector "24.4")
 186
 187
 188 (defun cookie-apropos (regexp phrase-file &optional display)
 189   "Return a list of all entries matching REGEXP from PHRASE-FILE.
 190 Interactively, PHRASE-FILE defaults to `cookie-file', unless that
 191 is nil or a prefix argument is used.
 192 If called interactively, or if DISPLAY is non-nil, display a list of matches."
 193   (interactive (list (read-regexp "Apropos phrase (regexp): ")
 194                      (if (or current-prefix-arg (not cookie-file))
 195                          (read-file-name "Cookie file: " nil
 196                                          cookie-file t cookie-file)
 197                        cookie-file) t))
 198   (setq phrase-file (cookie-check-file phrase-file))
 199   ;; Make sure phrases are loaded.
 200   (cookie phrase-file)
 201   (let* ((case-fold-search t)
 202          (cookie-table-symbol (intern phrase-file cookie-cache))
 203          (string-table (symbol-value cookie-table-symbol))
 204          (matches nil))
 205     (and (dotimes (i (length string-table) matches)
 206            (and (string-match-p regexp (aref string-table i))
 207                 (setq matches (cons (aref string-table i) matches))))
 208          (setq matches (sort matches 'string-lessp)))
 209     (and display
 210          (if matches
 211              (let ((l matches))
 212                (with-output-to-temp-buffer "*Cookie Apropos*"
 213                  (while l
 214                    (princ (car l))
 215                    (setq l (cdr l))
 216                    (and l (princ "\n\n")))
 217                  (help-print-return-message)))
 218            (message "No matches found.")))
 219     matches))
 220
 221
 222 (declare-function doctor-ret-or-read "doctor" (arg))
 223
 224 (defun cookie-doctor (phrase-file)
 225   "Feed cookie phrases from PHRASE-FILE to the doctor.
 226 Interactively, PHRASE-FILE defaults to `cookie-file', unless that
 227 is nil or a prefix argument is used."
 228   (interactive (list (if (or current-prefix-arg (not cookie-file))
 229                          (read-file-name "Cookie file: " nil
 230                                          cookie-file t cookie-file)
 231                        cookie-file)))
 232   (setq phrase-file (cookie-check-file phrase-file))
 233   (doctor)                              ; start the psychotherapy
 234   (message "")
 235   (switch-to-buffer "*doctor*")
 236   (sit-for 0)
 237   (while (not (input-pending-p))
 238     (insert (cookie phrase-file))
 239     (sit-for 0)
 240     (doctor-ret-or-read 1)
 241     (doctor-ret-or-read 1)))
 242
 243
 244 (provide 'cookie1)
 245
 246 ;;; cookie1.el ends here