Added list-all-bindings.
[com-informatimago:emacs.git] / pjb-emacs.el
1 ;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               pjb-emacs.el
4 ;;;;LANGUAGE:           emacs lisp
5 ;;;;SYSTEM:             emacs
6 ;;;;USER-INTERFACE:     emacs
7 ;;;;DESCRIPTION
8 ;;;;
9 ;;;;    This module exports various functions usefull only in interactive
10 ;;;;    emacs sessions.
11 ;;;;
12 ;;;;AUTHORS
13 ;;;;    <PJB> Pascal J. Bourguignon 
14 ;;;;MODIFICATIONS
15 ;;;;    2010-10-30 <PJB> Renamed multifile-replace-string to recursive-replace-string,
16 ;;;;                     Added recursive-replace-regexp and multifile-replace-regexp.
17 ;;;;    2006-03-23 <PJB> Added fringe-width and scroll-bar-width for full-frame.
18 ;;;;    2004-10-15 <PJB> Added maximize-window.
19 ;;;;    2001-11-30 <PJB> Extracted from pjb-utilities.el.
20 ;;;;
21 ;;;;BUGS
22 ;;;;LEGAL
23 ;;;;    LGPL
24 ;;;;
25 ;;;;    Copyright Pascal J. Bourguignon 1990 - 2011
26 ;;;;
27 ;;;;    This library is free software; you can redistribute it and/or
28 ;;;;    modify it under the terms of the GNU Lesser General Public
29 ;;;;    License as published by the Free Software Foundation; either
30 ;;;;    version 2 of the License, or (at your option) any later version.
31 ;;;;
32 ;;;;    This library is distributed in the hope that it will be useful,
33 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
34 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
35 ;;;;    Lesser General Public License for more details.
36 ;;;;
37 ;;;;    You should have received a copy of the GNU Lesser General Public
38 ;;;;    License along with this library; if not, write to the Free Software
39 ;;;;    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
40 ;;;;
41 ;;;;****************************************************************************
42 (require 'cl)
43 (require 'devices nil t)
44 (require 'font nil t)
45 (require 'browse-url)
46 (require 'picture) ;; (import picture-vertical-step picture-horizontal-step)
47 (require 'sgml-mode)
48
49 (require 'pjb-cl)
50 (require 'eieio)
51 (require 'pjb-euro)
52 (require 'pjb-font)
53 (provide 'pjb-emacs)
54
55
56 (defvar html-quick-keys t )
57 (defvar html-mode-map
58   (let ((map (nconc (make-sparse-keymap) sgml-mode-map))
59         (menu-map (make-sparse-keymap "HTML")))
60     (define-key map "\C-c6" 'html-headline-6)
61     (define-key map "\C-c5" 'html-headline-5)
62     (define-key map "\C-c4" 'html-headline-4)
63     (define-key map "\C-c3" 'html-headline-3)
64     (define-key map "\C-c2" 'html-headline-2)
65     (define-key map "\C-c1" 'html-headline-1)
66     (define-key map "\C-c\r" 'html-paragraph)
67     (define-key map "\C-c\n" 'html-line)
68     ;;    (define-key map "\C-c\C-c-" 'html-horizontal-rule)
69     ;;    (define-key map "\C-c\C-co" 'html-ordered-list)
70     ;;    (define-key map "\C-c\C-cu" 'html-unordered-list)
71     ;;    (define-key map "\C-c\C-cr" 'html-radio-buttons)
72     ;;    (define-key map "\C-c\C-cc" 'html-checkboxes)
73     ;;    (define-key map "\C-c\C-cl" 'html-list-item)
74     ;;    (define-key map "\C-c\C-ch" 'html-href-anchor)
75     ;;    (define-key map "\C-c\C-cn" 'html-name-anchor)
76     ;;    (define-key map "\C-c\C-ci" 'html-image)
77     (if html-quick-keys
78         (progn
79           (define-key map "\C-c-" 'html-horizontal-rule)
80           (define-key map "\C-co" 'html-ordered-list)
81           (define-key map "\C-cu" 'html-unordered-list)
82           (define-key map "\C-cr" 'html-radio-buttons)
83           (define-key map "\C-cc" 'html-checkboxes)
84           (define-key map "\C-cl" 'html-list-item)
85           (define-key map "\C-ch" 'html-href-anchor)
86           (define-key map "\C-cn" 'html-name-anchor)
87           (define-key map "\C-ci" 'html-image)))
88     (define-key map "\C-c\C-s" 'html-autoview-mode)
89     (define-key map "\C-c\C-v" 'browse-url-of-buffer)
90     (define-key map [menu-bar html] (cons "HTML" menu-map))
91     (define-key menu-map [html-autoview-mode]
92       '("Toggle Autoviewing" . html-autoview-mode))
93     (define-key menu-map [browse-url-of-buffer]
94       '("View Buffer Contents" . browse-url-of-buffer))
95     (define-key menu-map [nil] '("--"))
96     ;;(define-key menu-map "6" '("Heading 6" . html-headline-6))
97     ;;(define-key menu-map "5" '("Heading 5" . html-headline-5))
98     ;;(define-key menu-map "4" '("Heading 4" . html-headline-4))
99     (define-key menu-map "3" '("Heading 3" . html-headline-3))
100     (define-key menu-map "2" '("Heading 2" . html-headline-2))
101     (define-key menu-map "1" '("Heading 1" . html-headline-1))
102     (define-key menu-map "l" '("Radio Buttons" . html-radio-buttons))
103     (define-key menu-map "c" '("Checkboxes" . html-checkboxes))
104     (define-key menu-map "l" '("List Item" . html-list-item))
105     (define-key menu-map "u" '("Unordered List" . html-unordered-list))
106     (define-key menu-map "o" '("Ordered List" . html-ordered-list))
107     (define-key menu-map "-" '("Horizontal Rule" . html-horizontal-rule))
108     (define-key menu-map "\n" '("Line Break" . html-line))
109     (define-key menu-map "\r" '("Paragraph" . html-paragraph))
110     (define-key menu-map "i" '("Image" . html-image))
111     (define-key menu-map "h" '("Href Anchor" . html-href-anchor))
112     (define-key menu-map "n" '("Name Anchor" . html-name-anchor))
113     map)
114   "Keymap for commands for use in HTML mode.") ;;html-mode-map
115
116
117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
118 ;; Random emacs specific elisp functions:
119
120
121 (defun recover-this-file ()
122   (interactive)
123   (let ((file-path  (buffer-file-name)))
124     (if (and file-path (file-exists-p file-path) (file-regular-p file-path))
125         (recover-file file-path)
126         (message "This buffer has no associated file."))))
127
128
129 (defvar buffer-name-map   nil)
130 (defvar buffer-list-cache nil)
131
132
133 (defun buffer-named (name)
134   "
135 RETURN: the buffer which has as name `name'.
136 "
137   (let ((bl (buffer-list)))
138     (unless (and buffer-list-cache buffer-name-map
139                  (equal buffer-list-cache bl))
140       (setf buffer-list-cache (copy-seq bl))
141       (setf buffer-name-map (make-hash-table :test (function equal)))
142       (dolist (buffer buffer-list-cache)
143         (let ((name (buffer-name buffer)))
144           (when name (setf (gethash name buffer-name-map) buffer)))
145         (let ((name (buffer-file-name buffer)))
146           (when name (setf (gethash name buffer-name-map) buffer))))))
147   (or (gethash name buffer-name-map)
148       (gethash (truename name) buffer-name-map)))
149
150             
151 (defun old-buffer-named (name)
152   "
153 RETURN: the buffer which has as name `name'.
154 "
155   (let ((buffers (buffer-list)) (result))
156     (while buffers
157       (when (or (when (buffer-name      (car buffers))
158                   (string-equal name (buffer-name      (car buffers))))
159                 (when (buffer-file-name (car buffers))
160                   (string-equal name (buffer-file-name (car buffers))))
161                 (when (and (truename name) (buffer-name      (car buffers)))
162                   (string-equal (truename name) 
163                                 (buffer-name      (car buffers))))
164                 (when (and (truename name) (buffer-file-name (car buffers)))
165                   (string-equal (truename name) 
166                                 (buffer-file-name (car buffers)))))
167         (setq result (car buffers))
168         (setq buffers nil))
169       (setq buffers (cdr buffers)))
170     result)
171   ) ;;old-buffer-named
172
173
174 (defun pjb-custom-set-variables (&rest l)
175   (while l
176     (custom-set-variables (append (car l) (list t)))
177     (setq l (cdr l)))
178   ) ;;pjb-custom-set-variables
179
180
181 (defun set-default-directory (path)
182   (interactive "DDirectory for this buffer: ")
183   (setf default-directory path))
184
185
186 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
187 ;; Editing functions:
188
189 (defun delete-region-and-yank (&optional arg)
190   "Deletes region if mark is active and yanks the last kill.
191 Always replaces the region with the yank, whether the region was
192 selected via keyboard or mouse.  Also works for normal
193 yank even with ARGS (thus it can be mapped to \C-y)"
194   (interactive "*P")                    ; raw, like yank.
195   (message "arg=%S" arg)
196   (cond
197     (mark-active                        ; delete region
198      (let ((str (buffer-substring (point) (mark))))
199        (delete-region (point) (mark))
200        (if (string=* str (current-kill 0 1))
201            (let ((str2 (current-kill 1 1)))
202              (kill-new str2 t))))
203      (if arg
204          (yank arg)
205          (yank)))
206     ;; else no region selected:
207     ((consp arg)                        ; delete forward sexp
208      (set-mark (point))
209      (forward-sexp 1)
210      (delete-region-and-yank))
211     (arg (yank arg))
212     (t   (yank))))
213
214
215 (defun exch-del-ctrl-h ()
216   "Exchange \C-h and <DEL>."
217   (interactive)
218   ;; Translate `C-h' to <DEL>.
219   (keyboard-translate ?\C-h ?\C-?)
220   ;; Translate <DEL> to `C-h'.
221   (keyboard-translate ?\C-? ?\C-h)
222   ) ;;exch-del-ctrl-h
223
224
225 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
226 ;; picture-mode functions:
227
228
229 (defun picture-draw-pixels (pix-list &optional pixel)
230   "
231 DO:    Draws the pixels of pix-list (a list of (cons x y))
232        from current position  as origin.
233        Default pixel is '*'.
234        Coordinate system is : increasing x to the right,
235                               increasing y to the bottom.
236 "
237   (let* ((sl     (picture-current-line))
238          (sc     (current-column))
239          ;;(pvs    picture-vertical-step)
240          ;;(phs    picture-horizontal-step)
241          ;;(c1     (progn (goto-char start) (current-column)))
242          ;;(r1     (picture-current-line))
243          ;;(c2     (progn (goto-char end) (current-column)))
244          ;;(r2     (picture-current-line))
245          ;;(right  (max c1 c2))
246          ;;(left   (min c1 c2))
247          ;;(top    (min r1 r2))
248          ;;(bottom (max r1 r2))
249          )
250     (unless pixel (setq pixel (character "*")))
251
252     (dolist (point pix-list)
253       (goto-line      (+ sl (cdr point))) ;; goto-line first for
254       (move-to-column (+ sc (car point)) t)
255       (picture-update-desired-column t)
256       (picture-insert pixel 1)
257       ) ;;dolist
258
259     (goto-line sl)
260     (move-to-column sc t)
261     ) ;;let*
262   nil
263   ) ;;picture-draw-pixels
264
265
266 (defun ellipse-quart (a b)
267   "
268 RETURN: A list of integer coordinates approximating a quart (x>=0, y>=0) of
269         an ellipse of half width a and half height b.
270 "
271   (let ( (step  (/ pi 4 (sqrt (+ (* a a) (* b b)))))
272         (limit (/ pi 2))
273          (alpha 0.0)
274          (result (list (cons 0 0)))
275          x y )
276
277     (while (<= alpha limit)
278       (setq x (round (* a (cos alpha)))
279             y (round (* b (sin alpha))) )
280       (if (or  (/= y (cdar result)) (/= x (caar result)))
281           (push (cons x y) result))
282       (setq alpha (+ alpha step)))
283     (cdr (nreverse result))
284     ) ;;let
285   )   ;;ellipse-quart
286
287
288 (defun ellipse-full (a b)
289   "
290 RETURN: A list of integer coordinates approximating the whole ellipse
291         of half width a and half height b.
292 "
293   (let ( (quart (ellipse-quart a b)) )
294     (append
295      quart
296      (mapcar (lambda (item) (cons (- 0 (car item)) (cdr item))) quart)
297      (mapcar (lambda (item) (cons (car item) (- 0 (cdr item)))) quart)
298      (mapcar (lambda (item) (cons (- 0 (car item)) (- 0 (cdr item)))) quart))))
299
300
301
302
303 (defun picture-draw-function (start end fun plot-char)
304   "
305 DO:     Draw a function in the given rectangle region.
306 "
307   (interactive "*r
308 xFunction f:[0,1]->[0,1]/x|-->f(x): 
309 cPlot character: ") ;; start <= end
310   (let* ((sl     (picture-current-line))
311          (sc     (current-column))
312          (pvs    picture-vertical-step)
313          (phs    picture-horizontal-step)
314          (c1     (progn (goto-char start) (current-column)))
315          (r1     (picture-current-line))
316          (c2     (progn (goto-char end) (current-column)))
317          (r2     (picture-current-line))
318          (right  (max c1 c2))
319          (left   (min c1 c2))
320          (top    (min r1 r2))
321          (bottom (max r1 r2))
322          (width  (+ 0.0 (- right left)))
323          (height (+ 0.0 (- bottom top)))
324          )
325     (goto-line            top)
326     (move-to-column left t)
327     (picture-update-desired-column t)
328     (flet ((fun (x) nil))
329       (fset 'fun `(function (lambda (x) ,fun)))
330       (picture-draw-pixels 
331        (do* ((xi 0 (1+ xi))
332              (x) (y) (yi)
333              (pixels nil)
334              )
335             ((> xi width) pixels)
336          (setq x  (/ xi width))
337          (setq y  (let ((y (unwind-protect (fun x))))
338                     (if (< y 0.0) 0.0 (if (< 1.0 y) 1.0 y))))
339          (setq yi (round (* height (- 1.0 y))))
340          (push (cons xi yi) pixels)) 
341        plot-char)
342       ) ;;flet
343     (goto-line sl)
344     (move-to-column sc t))
345   ) ;;picture-draw-function
346
347
348
349 (defun picture-draw-ellipse (start end)
350   "
351 DO:     Draw an ellipse around region.
352 BUG:    Only draws ellipse of even width and height.
353 "
354   (interactive "*r")                    ; start will be less than end
355   (let* ((sl     (picture-current-line))
356          (sc     (current-column))
357          (pvs    picture-vertical-step)
358          (phs    picture-horizontal-step)
359          (c1     (progn (goto-char start) (current-column)))
360          (r1     (picture-current-line))
361          (c2     (progn (goto-char end) (current-column)))
362          (r2     (picture-current-line))
363          (right  (max c1 c2))
364          (left   (min c1 c2))
365          (top    (min r1 r2))
366          (bottom (max r1 r2))
367          (a      (/ (- right left) 2))
368          (b      (/ (- bottom top) 2))
369          )
370
371     (goto-line            (+ top b))
372     (move-to-column (+ left a) t)
373     (picture-update-desired-column t)
374     (picture-draw-pixels (ellipse-full a b) ?*)
375
376     (goto-line sl)
377     (move-to-column sc t))
378   ) ;;picture-draw-ellipse
379
380
381 (defvar x-cell-size  7 "Width  in pixel of one cell.")
382 (defvar y-cell-size 14 "Height in pixel of one cell.")
383
384 (defun picture-draw-circle (start end)
385   "Draw a circle centered on region."
386   (interactive "*r")                    ; start will be less than end
387   (let* ((sl     (picture-current-line))
388          (sc     (current-column))
389          (pvs    picture-vertical-step)
390          (phs    picture-horizontal-step)
391          (c1     (progn (goto-char start) (current-column)))
392          (r1     (picture-current-line))
393          (c2     (progn (goto-char end) (current-column)))
394          (r2     (picture-current-line))
395          (right  (max c1 c2))
396          (left   (min c1 c2))
397          (top    (min r1 r2))
398          (bottom (max r1 r2))
399          (a      (/ (- right left) 2))
400          (b      (/ (- bottom top) 2))
401          (r      (min (* a (float x-cell-size)) (* b (float y-cell-size))))
402          )
403
404     (goto-line            (+ top b))
405     (move-to-column (+ left a) t)
406     (picture-update-desired-column t)
407     (picture-draw-pixels (ellipse-full (round (/ r x-cell-size))
408                                        (round (/ r y-cell-size)))?*)
409
410     (goto-line sl)
411     (move-to-column sc t)
412     ) ;;let*
413   )   ;;picture-draw-circle
414
415
416
417 (defvar picture-fill-pixel ?* 
418   "The default pixel used to fill forms.") ;;picture-fill-pixel
419
420
421 (defun picture-fill-rectangle (start end)
422   "Fills a rectangle with `picture-fill-pixel', or when a prefix
423   argument is given, with the character given in minibuf."
424   (interactive "*rP")                   ; start will be less than end
425     
426   (let* ((sl     (picture-current-line))
427          (sc     (current-column))
428          (pvs    picture-vertical-step)
429          (phs    picture-horizontal-step)
430          (c1     (progn (goto-char start) (current-column)))
431          (r1     (picture-current-line))
432          (c2     (progn (goto-char end) (current-column)))
433          (r2     (picture-current-line))
434          (right  (max c1 c2))
435          (left   (min c1 c2))
436          (top    (min r1 r2))
437          (bottom (max r1 r2))
438          (fill-pixel picture-fill-pixel)
439          (width  (- right left -1))
440          )
441     (when current-prefix-arg
442       (setq fill-pixel  (character (read-from-minibuffer
443                                     "What pixel: "  "*" nil nil nil "*"))))
444     (picture-movement-right)
445     (do ((line top (1+ line)))
446         ((< bottom line))
447       (goto-line            line)
448       (move-to-column left t)
449       (picture-update-desired-column t)
450       (picture-insert fill-pixel width))
451     (picture-set-motion  pvs phs)
452     (goto-line sl)
453     (move-to-column sc t)
454     ) ;;let*
455   )   ;;picture-fill-rectangle
456
457
458 (defun picture-horizontal-segment (line left right)
459   (goto-line            line)
460   (move-to-column right t)
461   (picture-update-desired-column t)
462   (buffer-substring (- (point) (- right left)) (1+ (point)))
463   ) ;;picture-horizontal-segment
464
465
466 (defun picture-draw-text (line column text)
467   "Draws given text from (line,column) toward the current picture-movement."
468   (let* ((sl     (picture-current-line))
469          (sc     (current-column))
470          )
471     (goto-line line)
472     (move-to-column column t)
473     (picture-update-desired-column t)
474     (do* ((i 0 (1+ i)))
475          ((<= (length text) i))
476       (picture-insert (char text i) 1))
477     (goto-line sl)
478     (move-to-column sc t)
479     )) ;;picture-draw-text
480
481
482 (defun picture-mirror-vertical (start end)
483   "Replace the region by it's vertical mirror."
484   (interactive "*r")
485   (let* ((sl     (picture-current-line))
486          (sc     (current-column))
487          (pvs    picture-vertical-step)
488          (phs    picture-horizontal-step)
489          (c1     (progn (goto-char start) (current-column)))
490          (r1     (picture-current-line))
491          (c2     (progn (goto-char end) (current-column)))
492          (r2     (picture-current-line))
493          (right  (max c1 c2))
494          (left   (min c1 c2))
495          (top    (min r1 r2))
496          (bottom (max r1 r2))
497          )
498     (picture-movement-left)
499     (do ((line top (1+ line)))
500         ((< bottom line))
501       (do* ((segment (prog1 (picture-horizontal-segment line left right)
502                        (move-to-column right t)
503                        (picture-update-desired-column t)))
504             (i 0 (1+ i)))
505            ((<= (length segment) i))
506         (picture-insert (char segment i) 1))
507       )
508     (picture-set-motion  pvs phs)
509     (goto-line sl)
510     (move-to-column sc t)
511     )) ;;picture-mirror-vertical
512
513
514 (defun picture-mirror-horizontal (start end)
515   "Replace the region by it's vertical mirror."
516   (interactive "*r")
517   (let* ((sl     (picture-current-line))
518          (sc     (current-column))
519          (pvs    picture-vertical-step)
520          (phs    picture-horizontal-step)
521          (c1     (progn (goto-char start) (current-column)))
522          (r1     (picture-current-line))
523          (c2     (progn (goto-char end) (current-column)))
524          (r2     (picture-current-line))
525          (right  (max c1 c2))
526          (left   (min c1 c2))
527          (top    (min r1 r2))
528          (bottom (max r1 r2))
529          )
530     (picture-movement-right)
531     (do* ((lines  (do ((line top (1+ line))
532                        (result '()))
533                       ((< bottom line) result)
534                     (push (picture-horizontal-segment line left right) result))
535                   (cdr lines))
536           (line top (1+ line)))
537          ((null lines))
538       (picture-draw-text line left (car lines)))
539     (picture-set-motion  pvs phs)
540     (goto-line sl)
541     (move-to-column sc t)
542     )) ;;picture-mirror-horizontal
543
544
545 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
546 ;; Various Editor functions:
547
548
549 (defun pjb-scratch ()
550   "
551 DO:      Goes to the *scratch* buffer, creating it if it does not exists.
552 "
553   (interactive)
554   (switch-to-buffer (get-buffer-create "*scratch*")))
555
556
557 (defun pjb-wc ()
558   "
559 DO:      Apply wc on the file visited in the current buffer.
560 "
561   (interactive)
562   (let ((file-name (buffer-file-name (current-buffer))))
563     (when file-name
564       (shell-command (format "wc %s" (shell-quote-argument file-name))))))
565
566
567 (defun pjb-search-in-all-buffers (string)
568   "
569
570 "
571   (interactive "sString: ")
572   (let ( (list (buffer-list)) 
573         buffer )
574     (save-excursion 
575       (while list
576         (setq buffer (car list)
577               list   (cdr list))
578         (set-buffer buffer)
579         (goto-char (point-min))
580         (if (search-forward string nil t nil)
581             (setq list nil)
582             (setq buffer nil))))
583     (when buffer (switch-to-buffer buffer))))
584     
585
586
587 (when nil
588   (defun url-retrieve-as-string (url)
589     "RETURN: A string containing the data found at the url."
590     ;; This version uses w3.
591     ;; An alternative could be:
592     ;; (shell-command-to-string (format "lynx -source '%s'" url))
593     (save-excursion
594       (let* ((status (url-retrieve url))
595              (cached (car status))
596              (url-working-buffer (cdr status)))
597         (set-buffer url-working-buffer)
598         (buffer-string)))))
599
600
601 (defun url-retrieve-as-string (url)
602   "RETURN: A string containing the data found at the url."
603   (shell-command-to-string (format "lynx -source '%s'" url)))
604
605
606 (defun pjb-browse-url-lynx-xterm (url &optional new-window)
607   ;; new-window ignored
608   "Ask the Lynx WWW browser to load URL.
609 Default to the URL around or before point.  A new Lynx process is run
610 in an Xterm window using the Xterm program named by `browse-url-xterm-program'
611 with possible additional arguments `browse-url-xterm-args'."
612   (interactive (browse-url-interactive-arg "Lynx URL: "))
613   (apply #'start-process `(,(concat "lynx" url) nil 
614                             "pjb-xterm" ; ,browse-url-xterm-program
615                             ,@browse-url-xterm-args 
616                             "-geometry" "80x40+10+0" "-bg" "#eeff99"
617                             "-e" "lynx" ,url)))
618
619
620 (defun pjb-auto-scroll-up (speed)
621   "DO:   Scroll down the current buffer until the end-of-buffer is visible,
622       at the specified speed. Depending on the data, and your reading speed,
623       speed values between 0.2 and 1 line/sec may be useful."
624   (interactive "nSpeed: ")
625   (let ((delay (/ 1.0  speed)))
626     (message "Auto-scrolling...")
627     (while (not (pos-visible-in-window-p (point-max)))
628       (sit-for delay)
629       (scroll-up 1)
630       (force-mode-line-update t))
631     (message "Done.")))
632
633
634 (defun pjb-regexp-nocase-region (start end)
635   (interactive "r")
636   (let* ( (s (string-to-vector (buffer-substring start end)))
637          (l (length s))
638           (r nil) 
639           (i 0) 
640           c C )
641     (while (< i l) 
642       (setq c (aref s i))
643       (setq C (upcase   c))
644       (setq c (downcase c))
645       (if (eq c C)
646           (setq r (cons (format "%c" c) r))
647           (setq r (cons (format "[%c%c]" C c) r)))
648       (setq i (1+ i))
649       ) ;;while
650     (delete-region start end)
651     (insert (apply 'concat (nreverse r)))))
652
653
654 (defun pjb-animate (speed)
655   (interactive "nSpeed: ")
656   (let ((delay (/ 1.0  speed))
657         (done  nil))
658     (widen)
659     (goto-char (point-min))
660     (message "Animating...")
661     (while (not done)
662       (widen)
663       (if (search-forward "\f" nil 'at-limit)
664           nil
665           (goto-char (point-max))
666           (setq done t))
667       (narrow-to-page)
668       (sit-for delay)
669       (force-mode-line-update t)
670       ) ;;while
671     (message "Done.")))
672
673
674
675
676 (defvar pjb-listing-light "LightBlue" 
677   "Background color of light listing area.") ;;pjb-listing-light
678
679 (defvar pjb-listing-dark "LightSteelBlue" 
680   "Background color of dark listing area.") ;;pjb-listing-dark
681
682 (defun pjb-colorize-listing-region (arg)
683   "
684 DO:      Colorize the region with group of lines (normaly 1 by 1)
685          with different background color).
686 "
687   (interactive "pGroup size: ")
688   (error "Sorry, it does not work yet.")
689   (setq arg (prefix-numeric-value arg))
690   (setq current-prefix-arg nil)
691   (let ( (lines-forward (1+ (or arg 1)))
692         (color (cons pjb-listing-light pjb-listing-dark)) 
693          (start (region-beginning))
694          (end   (region-end)) )
695     ;; round the end to the beginning of next line.
696     (goto-char end)
697     (when (/= end (line-beginning-position))
698       (beginning-of-line 2)
699       (setq end (point)))
700
701     ;; round the start to the beginning of first line.
702     (goto-char start)
703     (when (/= start (line-beginning-position))
704       (beginning-of-line)
705       (setq start (point)))
706
707     (while (< start end)
708       (goto-char start)
709       ;; (message "avant %S" (point))
710       (beginning-of-line lines-forward)
711       ;; (message "apres %S" (point))
712       (if (< end (point))
713           (progn (goto-char end) (beginning-of-line 2)))
714       ;;(message "%16s from %4d to %4d" (car color) start (point))
715       (set-mark start)
716       (goto-char (point))
717       (facemenu-set-background (car color) start (point))
718       (setq start (point))
719       (setq color (cons (cdr color) (car color))))))
720
721
722 (defun pjb-old-look ()
723   "
724 DO:      Set the background, foreground and font to look like an oldie tty.
725 "
726   (interactive)
727   (set-background-color "#000")
728   (set-foreground-color "#0f2")
729   (set-cursor-color     "#3f1")
730   (mouse-set-font "-adobe-courier-bold-r-normal--*-120-*-*-m-*-iso8859-1")
731   (setq global-font-lock-mode nil)
732   (save-excursion
733     (dolist (buffer (buffer-list))
734       (set-buffer buffer)
735       (font-lock-mode -1)))
736   ) ;;pjb-old-look
737
738
739 (defun pjb-address (pattern)
740   "
741 DO:      Search an address in my address book (~/private/info/personnes.form)
742 "
743   (interactive "MSearch address: ")
744   (let ((personnes-forms (buffer-named "personnes.forms")))
745     (if personnes-forms 
746         (switch-to-buffer personnes-forms)
747         (forms-find-file (format "%sprivate/info/personnes.forms"
748                            (namestring (user-homedir-pathname))))))
749   (forms-search-forward pattern))
750
751
752
753 (defvar pjb-cross-references-rejected-regexp
754   "\\(^\\.?#\\|~$\\|\\.\\(elc\\|o\\|a\\)$\\)"
755   "A regexp matching file names that should not be searched 
756 for cross references.") ;;pjb-cross-references-rejected-regexp
757
758
759 (defun pjb-cross-references ()
760   "
761 DO:      Grep current directory for sources containing the current word.
762 "
763   (interactive)
764   (let ( (word  (current-word))
765         (files (nremove-nil
766                 (mapcar (lambda (name) 
767                           (cond
768                             ((file-directory-p name) nil)
769                             ((string-match pjb-cross-references-rejected-regexp
770                                            name) nil)
771                             (t (shell-quote-argument name))) )
772                         (directory-files "." nil nil t)))) )
773     (grep (format "grep -n -e %s %s" 
774             (shell-quote-argument word) (unsplit-string files " ")))))
775
776
777
778
779 (defun pjb-eurotunnel ()
780   "
781 DO:      get-devises and insert some eurotunnel data.
782 "
783   (interactive)
784   (let ((today (calendar-current-date)))
785     (get-devises)
786     (mapcar
787      (lambda (line) 
788        (let* ((fields   (split-string line ";"))
789               (sym      (nth 0 fields))
790               (quo      (string-to-number 
791                          (replace-regexp-in-string "," "." (nth 1 fields) nil nil)))
792               )
793          (cond
794
795            ((string-match "22457" sym)
796             (printf
797              "  | %4d-%02d-%02d    %8.6f   %4d %10s = %7.2f %11s |\n"
798              (nth 2 today) (nth 0 today) (nth 1 today)
799              quo 4400 sym (* quo 4400) " "))
800
801            ((string-match "12537" sym)
802             (printf
803              "  | %4d-%02d-%02d    %8.6f        %10s    %18s |\n"
804              (nth 2 today) (nth 0 today) (nth 1 today)
805              quo  sym  " "))
806
807            ((string-equal sym "GBP=X")
808             (printf
809              "  | %4d-%02d-%02d    %8.6f          %3s      ~ %7.4f %11s |\n"
810              (nth 2 today) (nth 0 today) (nth 1 today)
811              (/ (euro-from-value 10000 UKL) 10000.0) 'UKL
812              (/ (+ (euro-from-value (* 1495 0.68) UKL) (* 1495 1.0214)) 1495)
813              "EUR/12537"))
814
815            (t))))
816
817      (split-string 
818       (url-retrieve-as-string 
819        "http://fr.finance.yahoo.com/d/quos.csv?s=22456+22457+12537+GBP=X&m=PA&f=sl1d1t1c1ohgv&e=.csv")))))
820
821
822
823
824
825 (defun pjb-backcolors ()
826   "
827 DO:     Insert in the current buffer a list of colors and 
828         facemenu-set-background them.
829 "
830   (interactive)
831   (let ((f (lambda (x) (+ 255 (* 6 (- x 15))))) )
832     (for
833      r 10 12
834      (for
835       g 10 12
836       (for
837        b 10 12
838        (let ((min (point)))
839          (set-mark min)
840          (printf " *   Color :  #%x%x%x   * \n" 
841                  (funcall f r) (funcall f g) (funcall f b))
842          (facemenu-set-background 
843           (format "#%x%x%x"
844             (funcall f r) (funcall f g) (funcall f b)) 
845           min (point))))))))
846
847
848
849
850 (defun chronometre (lambda-body &optional outstream)
851   "
852 DO:     Chronometre the execution of `lambda-body'. 
853         Writes a message indicating the time it took.
854 RETURN: (cons seconds the result of `lambda-body').
855 "
856   (let* ( (start  (current-time))
857          (result (funcall lambda-body))
858           (stop   (current-time)) 
859           (time   (- (emacs-time-to-seconds stop) 
860                      (emacs-time-to-seconds start))) )
861     (printf outstream "Took %f seconds." time)
862     (cons time result)
863     ) ;;let*
864   )   ;;chronometre
865
866
867
868
869 (defun fill-region (from to &optional justify nosqueeze to-eop)
870   "Fill each of the paragraphs in the region.
871 A prefix arg means justify as well.
872 Ordinarily the variable `fill-column' controls the width.
873
874 Noninteractively, the third argument JUSTIFY specifies which
875 kind of justification to do: `full', `left', `right', `center',
876 or `none' (equivalent to nil).  t means handle each paragraph
877 as specified by its text properties.
878
879 The fourth arg NOSQUEEZE non-nil means to leave
880 whitespace other than line breaks untouched, and fifth arg TO-EOP
881 non-nil means to keep filling to the end of the paragraph (or next
882 hard newline, if `use-hard-newlines' is on).
883
884 If `sentence-end-double-space' is non-nil, then period followed by one
885 space does not end a sentence, so don't break a line there."
886   (interactive (list (region-beginning) (region-end)
887                      (if current-prefix-arg 'full)))
888   (unless (memq justify '(t nil none full center left right))
889     (setq justify 'full))
890   (let (end beg)
891     (save-restriction
892       (goto-char (max from to))
893       (if to-eop
894           (progn (skip-chars-backward "\n")
895                  (forward-paragraph)))
896       (setq end (point))
897       (goto-char (setq beg (min from to)))
898       (beginning-of-line)
899       (narrow-to-region (point) end)
900       (while (not (eobp))
901         (let ((initial (point))
902               end)
903           ;; If using hard newlines, break at every one for filling
904           ;; purposes rather than using paragraph breaks. 
905           (if use-hard-newlines
906               (progn 
907                 (while (and (setq end (text-property-any (point) (point-max)
908                                                          'hard t))
909                             (not (= (character "\n") (char-after end)))
910                             (not (= end (point-max))))
911                   (goto-char (1+ end)))
912                 (setq end (if end (min (point-max) (1+ end)) (point-max)))
913                 (goto-char initial))
914               (forward-paragraph 1)
915               (setq end (point))
916               (forward-paragraph -1))
917           (if (< (point) beg)
918               (goto-char beg))
919           (if (>= (point) initial)
920               (fill-region-as-paragraph (point) end justify nosqueeze)
921               (goto-char end)))))))
922
923
924
925 (defun permutations (list)
926   "Retourne une liste de toutes les permutations de list."
927   (mapcan (lambda (item)
928             (if (= 1 (length list))
929                 (list (list item))
930                 (mapcar (lambda (rest) (cons item rest))
931                         (permutations (remove* item list :count 1)))))
932           list))
933
934
935 (defun perm-words ()
936   "Insère après la ligne courrante toutes les permutations des mots de la ligne courrante."
937   (interactive)
938   (let ((words (car (read-from-string
939                      (format "(%s)" (buffer-substring-no-properties
940                                      (progn (beginning-of-line) (point))
941                                      (progn (end-of-line)       (point))))))))
942     (end-of-line)
943     (insert "\n")
944     (dolist (line (permutations words))
945       (dolist (word line)
946         (insert (format "%s "
947                   (if (and (listp word) (eq 'quote (car word))) 
948                       (cadr word) word))))
949       (insert "\n")))) ;;perm-words
950
951
952 (defvar *fortune-file* "/data/cookies/bopcs.cookies")
953
954 (defun add-fortune (start end)
955   "
956 Add the selection to the local fortune file.
957 "
958   (interactive "r")
959   (let ((fortune (buffer-substring-no-properties
960                   (min start end) (max start end))))
961     (find-file *fortune-file*)
962     (goto-char (point-max))
963     (insert fortune)
964     (insert "\n#\n")
965     (save-buffer 1)
966     (bury-buffer))
967   ) ;;add-fortune
968 (defalias 'add-cookie 'add-fortune)
969
970
971 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
972 ;;; frames
973 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
974
975 (defvar *window-manager-above*
976   (if (boundp 'aquamacs-version)
977     (+ 22)
978     (+ 22 1))
979   "The number of vertical pixels eaten by the window manager
980    above the frame (window title).")
981
982 (defvar *window-manager-below*
983   (if (boundp 'aquamacs-version)
984       (+ 2)
985       (+ 8))
986   "The number of vertical pixels eaten by the window manager
987    below the frame (grow bar).")
988
989 (defvar *window-manager-y-offset*
990   (+ *window-manager-above* *window-manager-below*)
991   "The number of vertical pixels eaten by the window manager
992    (above and below).")
993
994 (defvar *window-manager-left* 1
995   "The number of horizontal pixels eaten by the window manager
996    on the left.")
997
998 (defvar *window-manager-right* 1
999   "The number of horizontal pixels eaten by the window manager
1000    on the right.")
1001
1002 (defvar *window-manager-x-offset*
1003   (+  *window-manager-left*  *window-manager-right*)
1004   "The number of horizontal pixels eaten by the window manager.")
1005
1006
1007 (defvar *current-frame* nil) 
1008
1009 (defun current-frame ()
1010   "
1011 RETURN: The current frame.
1012 "
1013   (selected-frame))
1014
1015
1016 (defmacro define-frame-parameter (name)
1017   `(defun ,(intern (format "frame-%s" name)) (&optional frame)
1018      (frame-parameter (or frame (selected-frame)) ',name)))
1019
1020 ;; (dolist (p (frame-parameters)) (insert (format "(define-frame-parameter %s)\n" (car p))))
1021
1022 (define-frame-parameter parent-id)
1023 (define-frame-parameter display)
1024 (define-frame-parameter visibility)
1025 (define-frame-parameter icon-name)
1026 (define-frame-parameter outer-window-id)
1027 (define-frame-parameter window-id)
1028 (define-frame-parameter top)
1029 (define-frame-parameter left)
1030 (define-frame-parameter buffer-list)
1031 (define-frame-parameter unsplittable)
1032 (define-frame-parameter minibuffer)
1033 (define-frame-parameter modeline)
1034 (define-frame-parameter width)
1035 (define-frame-parameter height)
1036 (define-frame-parameter name)
1037 (define-frame-parameter background-mode)
1038 (define-frame-parameter display-type)
1039 (define-frame-parameter horizontal-scroll-bars)
1040 (define-frame-parameter scroll-bar-width)
1041 (define-frame-parameter cursor-type)
1042 (define-frame-parameter auto-lower)
1043 (define-frame-parameter auto-raise)
1044 (define-frame-parameter icon-type)
1045 (define-frame-parameter wait-for-wm)
1046 (define-frame-parameter title)
1047 (define-frame-parameter buffer-predicate)
1048 (define-frame-parameter tool-bar-lines)
1049 (define-frame-parameter menu-bar-lines)
1050 (define-frame-parameter scroll-bar-background)
1051 (define-frame-parameter scroll-bar-foreground)
1052 (define-frame-parameter right-fringe)
1053 (define-frame-parameter left-fringe)
1054 (define-frame-parameter line-spacing)
1055 (define-frame-parameter screen-gamma)
1056 (define-frame-parameter border-color)
1057 (define-frame-parameter cursor-color)
1058 (define-frame-parameter mouse-color)
1059 (define-frame-parameter background-color)
1060 (define-frame-parameter foreground-color)
1061 (define-frame-parameter vertical-scroll-bars)
1062 (define-frame-parameter internal-border-width)
1063 (define-frame-parameter border-width)
1064 (define-frame-parameter font)
1065
1066
1067 (defalias 'frame-pixel-top  'frame-top)
1068 (defalias 'frame-pixel-left 'frame-left)
1069
1070
1071 (defun set-default-frame-parameter (name value)
1072   (let ((acell (assoc name default-frame-alist)))
1073     (if acell
1074         (setf (cdr acell) value)
1075         (push (cons name value)  default-frame-alist))
1076     value))
1077
1078 (when (fboundp 'set-background-color)
1079   (defadvice set-background-color (after sbc-fringe last (color-name) activate)
1080     (when (facep 'fringe) (set-face-background 'fringe color-name))))
1081
1082
1083
1084 (defun max-frame-line-number (&optional frame)
1085   "
1086 RETURN: The maximum number of line that can be displayed on this frame
1087         inside this screen.
1088 "
1089   (truncate
1090    (/ (- (x-display-pixel-height frame) *window-manager-y-offset*)
1091       (frame-char-height frame))))
1092
1093
1094 (defun max-frame-column-number (&optional frame margin)
1095   "
1096 MARGIN: Number of pixel to substract from the display width.
1097 RETURN: The maximum number of columns that can be displayed on this frame
1098         inside this screen.
1099 "
1100   (setf margin (or margin 0))
1101   (truncate
1102    (/ (- (x-display-pixel-width frame) margin *window-manager-x-offset*)
1103       (frame-char-width frame))))
1104
1105
1106 (defun maximize-frame ()
1107   "Enlarge the window to span the whole screen."
1108   (interactive)
1109   (let ((*current-frame* (current-frame)))
1110     (set-frame-width  *current-frame* 
1111                       (max-frame-column-number
1112                        *current-frame* (+ (if current-prefix-arg 64 0) 34)))
1113     (set-frame-height *current-frame* (max-frame-line-number *current-frame*))
1114     (set-frame-position *current-frame* 0 0)
1115     (delete-other-windows)))
1116
1117
1118 (defun char-to-pixel-width (w &optional frame)
1119   (* w (frame-char-width (or frame (current-frame)))))
1120
1121 (defun pixel-to-char-width (w &optional frame)
1122   (truncate (/ w (frame-char-width (or frame (current-frame))))))
1123
1124 (defun char-to-pixel-height (h &optional frame)
1125   (* h (frame-char-height (or frame (current-frame)))))
1126
1127 (defun pixel-to-char-height (h &optional frame)
1128   (truncate (/ h (frame-char-height (or frame (current-frame))))))
1129
1130
1131 (defun move-frame-right (offset)
1132   "Move the frame to the right (or the left with a negative offset)."
1133   (interactive "NOffset: ")
1134   (let ((*current-frame* (current-frame)))
1135     (set-frame-position *current-frame*
1136                         (+ offset (eval (frame-pixel-left *current-frame*)))
1137                         (eval (frame-pixel-top *current-frame*)))))
1138
1139
1140 (defun move-frame-down (offset)
1141   "Move the frame down (or up with a negative offset)."
1142   (interactive "NOffset: ")
1143   (let ((*current-frame* (current-frame)))
1144     (set-frame-position *current-frame*
1145                         (eval (frame-pixel-left *current-frame*))
1146                         (+ offset (eval (frame-pixel-top *current-frame*))))))
1147
1148 (defun move-frame-to (args)
1149   (interactive "X'(left top)= ")
1150   (let ((*current-frame* (current-frame)))
1151     (destructuring-bind (x y) args
1152       (set-frame-position *current-frame* x y))))
1153
1154
1155 (unless (fboundp 'scroll-bar-columns)
1156   (defun scroll-bar-columns (side)
1157     2) )
1158
1159 (defun scroll-bar-width (&optional frame)
1160   "Return the width of the vertical scroll bar in columns"
1161   (setf frame (or frame  (current-frame)))
1162   (if (frame-parameter frame 'vertical-scroll-bars)
1163       (scroll-bar-columns (frame-parameter frame 'vertical-scroll-bars))
1164       0))
1165
1166
1167 (unless (fboundp 'window-fringes)
1168   (defun window-fringes ()
1169     (list (frame-char-width) (* 2 (frame-char-width)) nil)) )
1170
1171 (unless (fboundp 'fringe-columns)
1172   (defun fringe-columns (side &optional real)
1173     "Return the width, measured in columns, of the fringe area on SIDE.
1174 If optional argument REAL is non-nil, return a real floating point
1175 number instead of a rounded integer value.
1176 SIDE must be the symbol `left' or `right'."
1177     (funcall (if real '/ 'ceiling)
1178              (or (funcall (if (eq side 'left) 'car 'cadr)
1179                           (window-fringes))
1180                  0)
1181              (float (frame-char-width)))) )
1182
1183 (defun fringe-width ()
1184   (round (+ (fringe-columns 'left 'real) (fringe-columns 'right 'real))))
1185
1186
1187
1188 (defun position-x (pos &optional frame)
1189   "
1190 POS:    Either an integer denoting a X window position,
1191         or a list (+ int) denoting a X window position starting out of screen.
1192         (+ -2) means two pixels out of the left side of the screen.
1193 RETURN: The X window position for the frame corresponding to pos on the x axis.
1194         A positive number is relative to the left screen border, and toward 
1195         the right,
1196         a negative number is relative to the right screen border, and
1197         toward the right too  (its absolute value, toward the left).
1198 SEE:   position-y"
1199   (let ((frame (or frame (current-frame))))
1200     (cond
1201       ((consp pos)
1202        (if (and (eq '+ (first pos)) (minusp (second pos)))
1203            (position-x (second pos) frame)
1204            (error "Unexpected x position: %S" pos)))
1205       ((minusp pos)
1206        (- (+ pos (frame-pixel-width frame))  (x-display-pixel-width  frame)))
1207       (t pos))))
1208
1209
1210 (defun position-y (pos &optional frame)
1211   "
1212 POS:    Either an integer denoting a X window position,
1213         or a list (+ int) denoting a X window position starting out of screen.
1214         (+ -2) means two pixels out of the top side of the screen.
1215 RETURN: The X window position for the frame corresponding to pos on the y axis.
1216         A positive number is relative to the top screen border, and down,
1217         a negative number is relative to the bottom screen border, and down too 
1218         (its absolute value, up).
1219 SEE:   position-x
1220 "
1221   (let ((frame (or frame (current-frame))))
1222     (cond
1223       ((consp pos)
1224        (if (and (eq '+ (first pos)) (minusp (second pos)))
1225            (position-y (second pos) frame)
1226            (error "Unexpected y position: %S" pos)))
1227       ((minusp pos)
1228        (- (+ pos (frame-pixel-height frame))  (x-display-pixel-height  frame)))
1229       (t pos))))
1230
1231
1232 (defun screen-usable-origin (&optional frame)
1233   "
1234 RETURN: The origin of the screen where the frame lies.
1235
1236 NOTE:   For multi-screen displays, the coordinate system could be such that
1237         the origin of a screen may be expressed in negative coordinates.
1238         In this case, the returned values may be lists of the form: 
1239         (+ -|x|) (+ -|y|).
1240 "
1241   (let ((frame (or frame (current-frame))))
1242     (let ((x (frame-pixel-left frame))
1243           (y (frame-pixel-top  frame)))
1244       (set-frame-position frame 0 0)
1245       (prog1 (list (frame-pixel-left frame) (frame-pixel-top frame))
1246         (set-frame-position frame (position-x x) (position-y y))))))
1247
1248 (defun screen-usable-area (&optional frame)
1249   "
1250 RETURN: The origin and width and height of the screen where the frame lies,
1251         expressed as non negative numbers.
1252 "
1253   (let* ((frame (or frame (current-frame)))
1254          (origin        (screen-usable-origin frame))
1255          (screen-width  (x-display-pixel-width  frame))
1256          (screen-height (x-display-pixel-height frame)))
1257     (list (eval (first origin))
1258           (eval (second origin))
1259           (- screen-width (eval (first origin)))
1260           (- screen-height (eval (second origin))))))
1261
1262
1263 ;; (list (frame-pixel-left) (frame-pixel-top) (frame-width) (frame-height))
1264 ;; (0 (+ -23) 179 78)
1265
1266 (defun full-frame (&optional prefix)
1267   "Spread the frame to cover the full screen, or parts of it.
1268
1269 The screens as managed on xinerama or mergedfb, with one coordinate system,
1270 so we just divide the screen size in two 'screens'.
1271
1272 Vertical decorations    Vertical decorations 
1273 in screen.              out of screen.
1274  
1275 +---------++---------+
1276 |         ..         |
1277 |         .. 1       |  -1
1278 |         ..         |
1279 +---------++---------+
1280
1281 +---------++---------+
1282 |         ||         |
1283 |    2    ||    3    |  -2 -3
1284 |         ||         |
1285 +---------++---------+
1286
1287 +----+----++----+----+
1288 |    |    ||    |    |
1289 |  4 |  5 ||  6 |  7 |  -4 -5 -6 -7
1290 |    |    ||    |    |
1291 +----+----++----+----+
1292
1293 +------+------+------+
1294 |      |      |      |
1295 |  11  |  12  |  13  |  -11 -12 -13
1296 |      |      |      |
1297 +------+------+------+
1298
1299
1300 +---------++---------+
1301 |    21   ||   31    |
1302 +---------++---------+  No decorationless here.
1303 |    22   ||   32    |
1304 +---------++---------+
1305
1306 +----+----++----+----+
1307 | 41 | 51 || 61 | 71 |  
1308 +----+----++----+----+  No decorationless here.
1309 | 42 | 52 || 62 | 72 |  
1310 +----+----++----+----+
1311
1312 +------+------+------+
1313 |  111 |  121 |  131 |
1314 +------+------+------+  No decorationless here.
1315 |  112 |  122 |  132 |
1316 +------+------+------+
1317 "
1318   (interactive "p")
1319   (let* ((frame (current-frame))
1320          (area (screen-usable-area frame))
1321          (screen-left   (first  area))
1322          (screen-top    (second area))
1323          (screen-width  (third  area))
1324          (screen-height (fourth area)))
1325     (if (not (member (abs prefix) '(1 2 3 4 5 6 7
1326                                     -1 -2 -3 -4 -5 -6 -7
1327                                     11 12 13 -11 -12 -13
1328                                     111 112 121 122 131 132 -111 -112 -121 -122 -131 -132
1329                                     21 22 31 32
1330                                     41 42 51 52 61 62 71 72)))
1331         (message "Invalid prefix %S; expecting: %s"
1332                  prefix
1333                  "[   1   ]   [ 2 | 3 ]*   [4|5|6|7]*   [11|12|13]*
1334 Multiply by -1 = without decoration.
1335 *: Multiply by 10 and add 1 for top half, and 2 for bottom half.
1336 ")
1337         (let* ((top-offset    (if (minusp prefix)
1338                                   (- *window-manager-above*) 0))
1339                (height-offset (if (minusp prefix)
1340                                   0 (- *window-manager-y-offset*)))
1341                (prefix (abs prefix))
1342                (hpref  (if (< prefix 20) prefix (truncate prefix 10))) ; 1..19
1343                (vpref  (if (< prefix 20) 0 (mod prefix 10))) ; 0,1,2
1344                (left   (+ screen-left
1345                           (case hpref
1346                             ((1 2 4 11) 0)
1347                             ((3 6)   (truncate screen-width 2))
1348                             ((5)     (truncate screen-width 4))
1349                             ((7)     (* 3 (truncate screen-width 4)))
1350                             ((12)    (truncate screen-width 3))
1351                             ((13)    (* 2 (truncate screen-width 3))))))
1352                (width  (truncate screen-width (case hpref
1353                                                 ((1)        1)
1354                                                 ((2 3)      2)
1355                                                 ((11 12 13) 3)
1356                                                 ((4 5 6 7)  4))))
1357                (top    (+ screen-top
1358                           (case vpref
1359                             ((0 1) 0)
1360                             ((2)   (truncate (- screen-height
1361                                                 *window-manager-y-offset*)
1362                                              2)))))
1363                (height (case vpref
1364                          ((0)   screen-height)
1365                          ((1 2) (truncate (- screen-height
1366                                              *window-manager-y-offset*) 2)))))
1367           (labels ((mesframe (frame)
1368                      (message "0: x=%8S y=%8S w=%8S h=%8S"
1369                               (frame-pixel-left frame)
1370                               (frame-pixel-top frame)
1371                               (frame-pixel-width frame)
1372                               (frame-pixel-height frame)))
1373                    (move-frame (x w y h)
1374                      (mesframe frame)
1375                      (message "1: x=%8S y=%8S w=%8S h=%8S" x y w h)
1376                      (set-frame-width
1377                       frame
1378                       (pixel-to-char-width
1379                        (- w (char-to-pixel-width
1380                              (+ (fringe-width) (scroll-bar-width frame))))
1381                        frame))
1382                      (set-frame-height frame (pixel-to-char-height h frame))
1383                      (mesframe frame)
1384                      (setf x (position-x x)
1385                            y (position-y y)
1386                            w (frame-pixel-width  frame)
1387                            h (frame-pixel-height frame))
1388                      (message "2: x=%8S y=%8S w=%8S h=%8S" x y w h)
1389                      (set-frame-position frame x y)
1390                      (mesframe frame)))
1391             (move-frame left width
1392                         (+ top top-offset) (+ height height-offset)))))))
1393
1394                
1395 (defun single-frame ()
1396   "Reduce the frame, to one 80-columns window."
1397   (interactive)
1398   (let ((*current-frame* (current-frame)))
1399     (set-frame-width *current-frame* 81)
1400     (set-frame-height *current-frame* (max-frame-line-number))
1401     (if current-prefix-arg
1402         (set-frame-position *current-frame* -1  0)
1403         (set-frame-position *current-frame* -64 0))
1404     (delete-other-windows)))
1405
1406
1407 (defun double-frame ()
1408   "Enlarge the frame, and split it horizontally in two 80-column windows."
1409   (interactive)
1410   (let ((*current-frame* (current-frame)))
1411     (setq truncate-partial-width-windows nil)
1412     (set-frame-width *current-frame* 167)
1413     (set-frame-height *current-frame* (max-frame-line-number))
1414     (set-frame-position *current-frame* 0 0)
1415     (delete-other-windows)
1416     (split-window-horizontally 86)
1417     (other-window 1)
1418     (switch-to-buffer
1419      (do ((buffers (buffer-list) (cdr buffers)))
1420          ((or (null buffers)
1421               (not (or (position (char (buffer-name (car buffers)) 0) " *")
1422                        (equal (current-buffer) (car buffers)))))
1423           (car buffers))))))
1424
1425
1426 (defun half-frame ()
1427   "Reduce the frame, to one 40-columns window."
1428   (interactive)
1429   (let ((*current-frame* (current-frame)))
1430     (set-frame-width *current-frame* 41)
1431     (set-frame-position *current-frame* -64 0)
1432     (delete-other-windows)))
1433
1434
1435 (defun naiad-frame ()
1436   ""
1437   (interactive)
1438   (let ((*current-frame* (current-frame)))
1439     (set-frame-width  *current-frame* 81)
1440     (set-frame-height *current-frame* 55)
1441     (set-frame-position *current-frame* -64 0)))
1442
1443
1444 (defvar *frame-maximized-states* (make-hash-table)
1445   "Maps frames to their maximized state: When not maximized = nil; 
1446                                          when maximized = ((x y) w h)")
1447
1448 ;; assuming each frame has its own state.
1449 ;; The following is to clean up the entry in the hash table when the 
1450 ;; frame is deleted:
1451
1452 (add-hook 'delete-frame-hook
1453           (lambda (frame) (setf (gethash frame *frame-maximized-states*) nil)))
1454
1455 ;; Now let's toggle:
1456
1457 (defun toggle-maximize-frame ()
1458   (interactive)
1459   (let* ((frame (selected-frame))
1460          (state (gethash frame *frame-maximized-states*)))
1461     (if state
1462         (progn
1463           (apply (function set-frame-position) frame (first state))
1464           (set-frame-width  frame (second state))
1465           (set-frame-height frame (third state))
1466           (setf state nil))
1467         (let ((fp (frame-parameters nil)))
1468           (setf state (list (list (cdr (assoc 'left fp))
1469                                   (cdr (assoc 'top fp)))
1470                             (cdr (assoc 'width fp))
1471                             (cdr (assoc 'height fp))))
1472           (set-frame-width  frame (max-frame-column-number frame 34))
1473           ;; I don't know where these 34 go?
1474           (set-frame-height frame (max-frame-line-number   frame))
1475           (set-frame-position frame 0 0)))
1476     (setf (gethash frame *frame-maximized-states*) state)))
1477
1478
1479 (defun main-frame ()
1480   "The current frame becomes the main frame, ie. the other frames will
1481 only display one window with the scratch buffer"
1482   (interactive)
1483   (let ((current-frame (current-frame)))
1484     (dolist (frame (remove current-frame (frame-list)))
1485       (select-frame frame)
1486       (delete-other-windows)
1487       (switch-to-buffer "*scratch*"))
1488     (select-frame current-frame)))
1489
1490
1491 (defun after-make-frame/full-frame-meat (&optional frame)
1492   "Move the new frame to an open area.
1493    +----+----+   +----+----+
1494    |    |    |   |  4 | 5  |
1495    |  2 | 3  |   +----+----+
1496    |    |    |   |  6 | 7  |
1497    +----+----+   +----+----+
1498 "
1499   ;; TODO: The magic constant 40 depends actually on the window manager decorations
1500   ;; TODO: Replace it with
1501   (interactive)
1502   (let* ((frame         (or frame (current-frame)))
1503          (area          (screen-usable-area frame))
1504          (screen-left   (first  area))
1505          (screen-top    (second area))
1506          (screen-width  (third  area))
1507          (screen-height (fourth area))
1508          (other-frames  (remove-if
1509                          (lambda (fr) (or (eq fr frame)
1510                                      (not (equal (frame-display fr)
1511                                                  (frame-display frame)))))
1512                          (frame-list))))
1513     (select-frame frame)
1514     (case (length other-frames)
1515       ((0) (full-frame 3))              ; by default go to the right.
1516       ((1) (let ((left (eval (frame-pixel-left (first other-frames)))))
1517              (if (< left (truncate (- screen-width 20) 2))
1518                  (full-frame 3)
1519                  (full-frame 2))))
1520       (otherwise
1521        (let ((used-squares '()))
1522          (dolist (fr other-frames)
1523            (let ((h (if (< (eval (frame-pixel-left fr))
1524                            (- (truncate screen-width  2) *window-manager-x-offset*))
1525                         ;; on the left 46 [+ 57]
1526                         (if (<= (frame-pixel-width fr) (truncate screen-width 2))
1527                             '(4 6)
1528                             '(4 6 5 7))
1529                         ;; on the right 57 whatever.
1530                         '(5 7)))
1531                  (v (if (< (eval (frame-pixel-top fr))
1532                            (- (truncate screen-height 2) *window-manager-y-offset*))
1533                         ;; on the top 45 [+ 67]
1534                         (if (<= (frame-pixel-height fr) (truncate screen-height 2))
1535                             '(4 5)
1536                             '(4 5 6 7))
1537                         ;; on the bottom whatever.
1538                         '(6 7))))
1539              (setf used-squares (union used-squares (intersection h v)))))
1540          (cond
1541            ((null (intersection '(5 7) used-squares)) (full-frame 3))
1542            ((null (intersection '(4 6) used-squares)) (full-frame 2))
1543            ((not (member 4 used-squares))             (full-frame 4))
1544            ((not (member 5 used-squares))             (full-frame 5))
1545            ((not (member 6 used-squares))             (full-frame 6))
1546            ((not (member 7 used-squares))             (full-frame 7))
1547            (t                                         (full-frame 3))))))))
1548
1549 (when (and window-system (not (getenv "RATPOISON")))
1550   (pushnew (function after-make-frame/full-frame-meat) after-make-frame-functions))
1551
1552 ;; (setf  after-make-frame-functions  (remove (function after-make-frame/full-frame-meat) after-make-frame-functions))
1553
1554
1555 (defvar *excluded-frames* '()
1556   "List of excluded frames, not considered by `other-frame-non-excluded'")
1557
1558 (defun exclude-frame ()
1559   "Remove the selected frame from the frames used by other-frame-non-excluded"
1560   (interactive)
1561   (pushnew (selected-frame) *excluded-frames*))
1562
1563 (defun include-frame ()
1564     "Add the selected frame to the frames used by other-frame-non-excluded"
1565     (setf *excluded-frames* (delete (selected-frame) *excluded-frames*)))
1566
1567 (defun other-frame-non-excluded (arg)
1568   "Select the argth different visible frame on current display, and raise it,
1569 but ignoring the frames listed in `*excluded-frames*'.
1570 All frames are arranged in a cyclic order.
1571 This command selects the frame arg steps away in that order.
1572 A negative arg moves in the opposite order.
1573
1574 To make this command work properly, you must tell Emacs
1575 how the system (or the window manager) generally handles
1576 focus-switching between windows.  If moving the mouse onto a window
1577 selects it (gives it focus), set `focus-follows-mouse' to t.
1578 Otherwise, that variable should be nil.
1579
1580 See also: `exclude-frame' and `include-frame'
1581 "
1582   (interactive "p")
1583   (let ((frame (selected-frame)))
1584     (while (> arg 0)
1585       (setq frame (next-frame frame))
1586       (while (not (eq (frame-visible-p frame) t))
1587         (setq frame (next-frame frame)))
1588       (unless  (member frame *excluded-frames*)
1589         (setq arg (1- arg))))
1590     (while (< arg 0)
1591       (setq frame (previous-frame frame))
1592       (while (not (eq (frame-visible-p frame) t))
1593         (setq frame (previous-frame frame)))
1594       (unless (member frame *excluded-frames*)
1595         (setq arg (1+ arg))))
1596     (select-frame-set-input-focus frame)))
1597
1598
1599
1600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1601 ;;; windows
1602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1603
1604 (defalias 'swap-windows 'rotate-buffers)
1605
1606
1607
1608
1609 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1610 ;;
1611 ;; Searching selected text
1612 ;;
1613
1614 (defvar *last-search-text* nil)
1615
1616 (defun pjb-search-backward-region ()
1617   (interactive)
1618   (let ((text *last-search-text*))
1619     (when mark-active
1620       (let ((start (min (mark) (point)))
1621             (end   (max (mark) (point))))
1622         (setq text (buffer-substring-no-properties start end))
1623         (setq *last-search-text* text)
1624         (goto-char start)))
1625     (cond
1626       ((null text) (error "No text to search."))
1627       ((search-backward text nil t)
1628        (set-mark (match-end 0)))
1629       (t (error "Can't find %S" text))))
1630   ) ;;pjb-search-backward-region
1631
1632
1633 (defun pjb-search-forward-region ()
1634   (interactive)
1635   (let ((text *last-search-text*))
1636     (when mark-active
1637       (let ((start (min (mark) (point)))
1638             (end   (max (mark) (point))))
1639         (setq text (buffer-substring-no-properties start end))
1640         (setq *last-search-text* text)
1641         (goto-char end)))
1642     (cond
1643       ((null text) (error "No text to search."))
1644       ((search-forward text nil t)
1645        (set-mark (match-beginning 0)))
1646       (t (error "Can't find %S" text))))
1647   ) ;;pjb-search-forward-region
1648
1649
1650 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1651 ;;
1652 ;; Masking private text
1653 ;;
1654
1655
1656 (defun filter-region (fun &optional start end)
1657   "
1658 DO:    Apply the function fun(character)->string to the region from 
1659        start or (min (point) (mark)) to end or (max (point) (mark)).
1660        The region is replaced at the end of the processing.
1661 "
1662   (setq start (or start (min (point) (mark))))
1663   (setq end (or end (max (point) (mark))))
1664   (do* ((pos start (1+ pos))
1665         (ch  (buffer-substring-no-properties pos (1+ pos))
1666              (buffer-substring-no-properties pos (1+ pos)))
1667         (replacement '()))
1668        ((<= end pos)
1669         (progn
1670           (delete-region start end)
1671           (insert (apply (function concatenate) 
1672                          'string (nreverse replacement)))))
1673     (push (funcall fun pos ch) replacement))
1674   ) ;;filter-region
1675
1676
1677 (defun is-space (c)
1678   "RETURN: Whether C is a space."
1679   (member c '(9 10 11 12 13 32))) ;;is-space
1680
1681
1682 (defun blind-text-region (start end)
1683   "
1684 DO:         Substitutes every alphanumeric text by a 'x'.
1685 SEE-ALSO:   activate-peril-sensitive-sunglasses
1686 "
1687   (interactive "*r")
1688   (filter-region 
1689    (lambda (pos ch) 
1690      (cond ((or (is-space (character ch))
1691                 (string=*  "\n" ch)
1692                 (string=* "=" ch)
1693                 (and (string/=* "\n" ch)
1694                      (string=* "=" (buffer-substring-no-properties 
1695                                     (- pos 1) pos)))
1696                 (and (string/=* "\n" (buffer-substring-no-properties 
1697                                       (- pos 1) pos))
1698                      (string=* "=" (buffer-substring-no-properties 
1699                                     (- pos 2) (- pos 1)))))
1700             ch)
1701            ((alphanumericp (character ch)) "x")
1702            (t ch)))
1703    start end))
1704
1705
1706 (defun activate-peril-sensitive-sunglasses ()
1707   "emergency protection from sight of ugly code
1708 With apologies to Zaphod Beeblebrox.
1709 SEE-ALSO:  blind-text-region
1710 "
1711   (interactive)
1712   (mapc (lambda (face)
1713           (set-face-foreground face "black")
1714           (set-face-background face "black"))
1715         (face-list)))
1716
1717
1718 ;; (mapcar (function window-buffer) (window-list nil nil))
1719
1720 (defun rotate-buffers ()
1721   "Rotate the buffers in the current windows."
1722   (interactive)
1723   (let ((buffers (mapcar (function window-buffer) (window-list nil nil))))
1724     (mapcar* (function set-window-buffer)
1725              (window-list nil nil)
1726              (if current-prefix-arg
1727                  (append (cdr buffers) (list (car buffers)))
1728                  (cons (car (last buffers)) (butlast buffers))))))
1729
1730 (defalias 'rotate-windows 'rotate-buffers)
1731
1732 ;;;----------------------------------------
1733 ;;; Keymaps:
1734 ;;;----------------------------------------
1735                                                               
1736 (defun make-keymap-local ()
1737   "Creates a buffer local keymap to have local-set-key define keys local 
1738 to the buffer instead of local to the mode."
1739   (interactive)
1740   (let ((km (make-keymap)))
1741     (set-keymap-parent km (current-local-map))
1742     (use-local-map km)))
1743
1744
1745 (defmacro rloop (clauses &rest body)
1746   (if (null clauses)
1747       `(progn ,@body)
1748       `(loop ,@(car clauses) do (rloop ,(cdr clauses) ,@body))))
1749
1750 (defun all-bindings ()
1751   (interactive)
1752   (message "all-bindings: wait a few seconds please...")
1753   (let ((data
1754          (with-output-to-string
1755              (let ((bindings '()))
1756                (rloop ((for C in '("" "C-"))       ; Control
1757                        (for M in '("" "M-"))       ; Meta
1758                        (for A in '("" "A-"))       ; Alt
1759                        (for S in '("" "S-"))       ; Shift
1760                        (for H in '("" "H-"))       ; Hyper
1761                        (for s in '("" "s-"))       ; super
1762                        (for x from 32 to 127))
1763                       (let* ((k (format "%s%s%s%s%s%s%c" C M A S H s x))
1764                              (key (ignore-errors (read-kbd-macro k))))
1765                         (when key
1766                           (push
1767                            (list k
1768                                  (format "%-12s  %-12s  %S\n" k key
1769                                          (or
1770                                           ;; (string-key-binding key)
1771                                           ;; What is this string-key-binding?
1772                                           (key-binding key))))
1773                            bindings))))
1774                (dolist (item
1775                          (sort bindings
1776                                (lambda (a b)
1777                                  (or (< (length (first a))
1778                                         (length (first b)))
1779                                      (and (= (length (first a))
1780                                              (length (first b)))
1781                                           (string< (first a)
1782                                                    (first b)))))))
1783                  (princ (second item)))))))  
1784     (switch-to-buffer (format "Keybindings in %s" (buffer-name)))
1785     (erase-buffer)
1786     (insert data)
1787     (goto-char (point-min))
1788     (values)))
1789
1790 (defun list-all-bindings ()
1791   "Return a list of all bound keys."
1792   (let ((bindings '()))
1793     (rloop ((for C in '("" "C-"))       ; Control
1794             (for M in '("" "M-"))       ; Meta
1795             (for A in '("" "A-"))       ; Alt
1796             (for S in '("" "S-"))       ; Shift
1797             (for H in '("" "H-"))       ; Hyper
1798             (for s in '("" "s-"))       ; super
1799             (for x from 32 to 127))
1800            (let* ((k (format "%s%s%s%s%s%s%c" C M A S H s x))
1801                   (key (ignore-errors (read-kbd-macro k))))
1802              (when key
1803                (push
1804                 (list k
1805                       (format "%-12s  %-12s  %S\n" k key
1806                               (or
1807                                ;; (string-key-binding key)
1808                                ;; What is this string-key-binding?
1809                                (key-binding key))))
1810                 bindings))))
1811     (sort bindings
1812           (lambda (a b)
1813             (or (< (length (first a))
1814                    (length (first b)))
1815                 (and (= (length (first a))
1816                         (length (first b)))
1817                      (string< (first a)
1818                               (first b))))))))
1819
1820
1821 ;;;----------------------------------------
1822 ;;; Properties:
1823 ;;;----------------------------------------
1824
1825 (defun plist-keys (plist)
1826   (if (null plist)
1827       plist
1828       (cons (car plist) (plist-keys (cddr plist)))))
1829
1830 (defun list-all-properties-in-buffer (buffer)
1831   (save-excursion
1832     (set-buffer buffer)
1833     (delete-duplicates
1834      (loop
1835         for i from (point-min) to (point-max)
1836         nconc  (delete-duplicates (plist-keys (text-properties-at i nil)))))))
1837
1838 (defun remove-all-properties ()
1839   (interactive)
1840   (remove-list-of-text-properties
1841    (point-min)
1842    (point-max)
1843    (list-all-properties-in-buffer (current-buffer))))
1844
1845
1846 ;;;----------------------------------------
1847 ;;; Morse
1848 ;;;----------------------------------------
1849
1850 (require 'morse)
1851 (defun morse-string (string)
1852   "Convert all text in a given string to morse code."
1853   (with-output-to-string
1854       (loop
1855          with sep = ""
1856          with morse = nil
1857          for ch across string do
1858          (cond
1859            ((is-space ch) (princ (format "%c" ch)))
1860            ((setq morse (assoc (string-upcase ch) morse-code))
1861             (princ sep)
1862             (princ (cdr morse))
1863             (setq sep "/"))
1864            (t
1865             (setq sep ""))))))
1866
1867
1868 ;;;----------------------------------------
1869 ;;; acronym
1870 ;;;----------------------------------------
1871
1872 (defun acronym ()
1873   (interactive)
1874   (w3m-browse-url
1875    (if (or (not mark-active) (eql (point) (mark)))
1876        (format "http://www.cygwin.com/acronyms/#%s"
1877                (read-from-minibuffer "Acronym: "))
1878        (buffer-substring-no-properties (min (point) (mark))
1879                                        (max (point) (mark))))))
1880
1881 ;;;----------------------------------------
1882 ;;; eppelle
1883 ;;;----------------------------------------
1884
1885 (defun eppelle ()
1886   (interactive)
1887   (let ((text 
1888          (if (or (not mark-active) (eql (point) (mark)))
1889              (read-from-minibuffer "Word: ")
1890              (buffer-substring-no-properties (min (point) (mark))
1891                                              (max (point) (mark)))))
1892         (alphabet '((?A . "Alpha")
1893                     (?B . "Bravo")
1894                     (?C . "Charlie")
1895                     (?D . "Delta")
1896                     (?E . "Echo")
1897                     (?F . "Foxtrot")
1898                     (?G . "Golf")
1899                     (?H . "Hotel")
1900                     (?I . "India")
1901                     (?J . "Juliet")
1902                     (?K . "Kilo")
1903                     (?L . "Lima")
1904                     (?M . "Mike")
1905                     (?N . "November")
1906                     (?O . "Oscar")
1907                     (?P . "Papa")
1908                     (?Q . "Quebec")
1909                     (?R . "Romeo")
1910                     (?S . "Sierra")
1911                     (?T . "Tango")
1912                     (?U . "Uniform")
1913                     (?V . "Victor")
1914                     (?W . "Whiskey")
1915                     (?X . "X-ray")
1916                     (?Y . "Yankee")
1917                     (?Z . "Zulu")
1918                     (?0 . "Nadazero")
1919                     (?1 . "Unaone")
1920                     (?2 . "Bissotwo")
1921                     (?3 . "Terrathree")
1922                     (?4 . "Kartefour")
1923                     (?5 . "Pantafive")
1924                     (?6 . "Soxisix")
1925                     (?7 . "Setteseven")
1926                     (?8 . "Oktoeight")
1927                     (?9 . "Novenine")
1928                     (?А . "Алексей")
1929                     (?Б . "Борис")
1930                     (?В . "Василий")
1931                     (?Г . "Григорий")
1932                     (?Д . "Димитрий")
1933                     (?Е . "Елена")
1934                     (?Ж . "Женя")
1935                     ;;(?  . "Зоя")
1936                     (?И . "Иван")
1937                     (?Й . "Иван Каткий")
1938                     (?К . "Киловат")
1939                     (?Л . "Леонид")
1940                     (?М . "Мариа")
1941                     (?Н . "Николай")
1942                     (?О . "Олга")
1943                     (?П . "Павел")
1944                     (?Р . "Роман")
1945                     (?С . "Сергей")
1946                     (?Т . "Татяна")
1947                     (?У . "Уляна")
1948                     (?Ф . "Фёдор")
1949                     (?Х . "Харитон")
1950                     (?З . "Запля")
1951                     (?Ч . "Человек")
1952                     (?Ш . "Шура")
1953                     (?Щ . "Щука")
1954                     (?ъ . "Твирдиы Знак")
1955                     ;;(?  . "Igrek")
1956                     (?Ь . "Мягкиы Знак Znak")
1957                     (?э . "Эмиля")
1958                     (?Ю . "Юри")
1959                     (?Я . "Яков")
1960
1961                     ;; Aleph Boaz Gimel David Hagar Vav Ze'ev Hava Tiach Yona
1962                     ;; Carmel Lea Moshe Nesher Samekh A'in Pesel Tsipor Korakh 
1963                     ;; Ruth Shamir Telem
1964                     ;; #+clisp
1965                     ;; (let ((codes '(("Aleph" "_ALEF")
1966                     ;;                ("Boaz" "_BET")
1967                     ;;                ("Gimel" "_GIMEL")
1968                     ;;                ("David" "_DALET")
1969                     ;;                ("Hagar" "_HE")
1970                     ;;                ("Vav" "_VAV")
1971                     ;;                ("Ze'ev" "_ZAYIN")
1972                     ;;                ("Hava" "_HET")
1973                     ;;                ("Tiach" "_TET")
1974                     ;;                ("Yona" "_YOD")
1975                     ;;                ("Carmel" "_KAF")
1976                     ;;                ("Lea" "_LAMED")
1977                     ;;                ("Moshe" "_MEM")
1978                     ;;                ("Nesher" "_NUN")
1979                     ;;                ("Samekh" "_SAMEKH")
1980                     ;;                ("A'in" "_AYIN")
1981                     ;;                ("Pesel" "_PE")
1982                     ;;                ("Tsipor" "_TSADI")
1983                     ;;                ("Korakh" "_QOF")
1984                     ;;                ("Ruth" "_RESH")
1985                     ;;                ("Shamir" "_SHIN")
1986                     ;;                ("Telem" "_TAV"))))
1987                     ;;   (dolist (ch (block nil
1988                     ;;                 (with-output-to-string (*standard-output*)
1989                     ;;                   (return (lschar :name "HEBREW")))))
1990                     ;;     (let* ((name (char-name ch))
1991                     ;;            (code (with-output-to-string (*standard-output*)
1992                     ;;                    (let ((sep ""))
1993                     ;;                      (dolist (code codes)
1994                     ;;                        (when (search (second code) name)
1995                     ;;                          (princ sep)
1996                     ;;                          (princ (first code))
1997                     ;;                          (setf sep " ")))))))
1998                     ;;       (when (string/= "" code)
1999                     ;;         (print (cons (intern (format nil "?~C" ch)) code))))))
2000
2001                     (?ׁ . "Shamir") 
2002                     (?א . "Aleph") 
2003                     (?ב . "Boaz") 
2004                     (?ג . "Gimel") 
2005                     (?ד . "David") 
2006                     (?ה . "Hagar") 
2007                     (?ו . "Vav") 
2008                     (?ז . "Ze'ev") 
2009                     (?ח . "Hagar Hava") 
2010                     (?ט . "Tiach") 
2011                     (?י . "Yona") 
2012                     (?ך . "Carmel") 
2013                     (?כ . "Carmel") 
2014                     (?ל . "Lea") 
2015                     (?ם . "Moshe") 
2016                     (?מ . "Moshe") 
2017                     (?ן . "Nesher") 
2018                     (?נ . "Nesher") 
2019                     (?ס . "Samekh") 
2020                     (?ע . "A'in") 
2021                     (?ף . "Pesel") 
2022                     (?פ . "Pesel") 
2023                     (?ץ . "Tsipor") 
2024                     (?צ . "Tsipor") 
2025                     (?ק . "Korakh") 
2026                     (?ר . "Ruth") 
2027                     (?ש . "Shamir") 
2028                     (?ת . "Telem") 
2029                     (?װ . "Vav Vav") 
2030                     (?ױ . "Vav Yona") 
2031                     (?ײ . "Yona Yona") 
2032                     (?יִ . "Yona") 
2033                     (?ײַ . "Yona") 
2034                     (?ﬠ . "A'in") 
2035                     (?ﬡ . "Aleph") 
2036                     (?ﬢ . "David") 
2037                     (?ﬣ . "Hagar") 
2038                     (?ﬤ . "Carmel") 
2039                     (?ﬥ . "Lea") 
2040                     (?ﬦ . "Moshe") 
2041                     (?ﬧ . "Ruth") 
2042                     (?ﬨ . "Telem") 
2043                     (?שׁ . "Shamir") 
2044                     (?שׂ . "Shamir") 
2045                     (?שּׁ . "Shamir") 
2046                     (?שּׂ . "Shamir") 
2047                     (?אַ . "Aleph") 
2048                     (?אָ . "Aleph") 
2049                     (?אּ . "Aleph") 
2050                     (?בּ . "Boaz") 
2051                     (?גּ . "Gimel") 
2052                     (?דּ . "David") 
2053                     (?הּ . "Hagar") 
2054                     (?וּ . "Vav") 
2055                     (?זּ . "Ze'ev") 
2056                     (?טּ . "Tiach") 
2057                     (?יּ . "Yona") 
2058                     (?ךּ . "Carmel") 
2059                     (?כּ . "Carmel") 
2060                     (?לּ . "Lea") 
2061                     (?מּ . "Moshe") 
2062                     (?נּ . "Nesher") 
2063                     (?סּ . "Samekh") 
2064                     (?ףּ . "Pesel") 
2065                     (?פּ . "Pesel") 
2066                     (?צּ . "Tsipor") 
2067                     (?קּ . "Korakh") 
2068                     (?רּ . "Ruth") 
2069                     (?שּ . "Shamir") 
2070                     (?תּ . "Telem") 
2071                     (?וֹ . "Vav") 
2072                     (?בֿ . "Boaz") 
2073                     (?כֿ . "Carmel") 
2074                     (?פֿ . "Pesel") 
2075                     (?ﭏ . "Aleph Lea") 
2076                     )))
2077     (switch-to-buffer "*Eppelle*")
2078     (goto-char (point-max))
2079     (insert "\n========================================\n"
2080             text
2081             "\n----------------------------------------\n")
2082     (loop
2083        for ch across text
2084        for tr = (assoc* (upcase ch) alphabet :test (function =))
2085        do  (insert (if tr (format "%s " (cdr tr)) (format "%c" ch))))
2086     (insert "\n")))
2087     
2088
2089
2090 ;;;----------------------------------------
2091 ;;; Radio Londre
2092 ;;;----------------------------------------
2093
2094 (defvar *radio-londre-messages*
2095   '("Andromaque se parfume à la lavande."
2096     "Athalie est restée en extase. Nous disons deux fois : Athalie est restée en extase."
2097     "Attention elle mord. Nous disons trois fois."
2098     "Baissez donc les paupières."
2099     "Bercent mon coeur d'une langueur monotone."
2100     "C'est évidemment un tort."
2101     "Clarisse a les yeux bleus, nous disons, Clarisse a les yeux bleus."
2102     "Clarisse sera vengée. Nous disons deux fois..."
2103     "Clémentine peut se curer les dents."
2104     "De Camille à Amicha : six amis trouveront qu'elle mord ce soir. Nous disons : six amis trouveront qu'elle mord ce soir."
2105     "De Marie-Thérèse à Marie-Louise : un ami viendra ce soir."
2106     "Demain, la mélasse deviendra du cognac."
2107     "Du bouledogue au sanglier : vous recevrez encore des amis ce soir. Le vent souffle les flambeaux. Nous disons : vous recevrez encore des amis ce soir. Le vent souffle les flambeaux.."
2108     "Écoute mon cœur qui pleure."
2109     "Elle est rasoir, Jeannie. Nous disons deux fois..."
2110     "Elle restera sur le dos."
2111     "Fréderick était roi de Prusse; nous disons quatre fois."
2112     "Gabrielle vous envoie ses amitiés."
2113     "Grand-Mère mange nos bonbons."
2114     "Gustave est très doux. Nous disons deux fois..."
2115     "Heureux qui comme Ulysse a fait un long voyage."
2116     "Il a pleuré de joie."
2117     "Il a une voix de fausset."
2118     "Il est sévère mais juste (+ code du département)."
2119     "Il est temps de cueillir des tomates."
2120     "Il fait chaud à Suez."
2121     "Il faut avoir des pipes pour trier les lentilles."
2122     "Il n'y a plus de tabac dans la tabatière."
2123     "Il pleut toujours en Angleterre."
2124     "J'aime les chats siamois."
2125     "Je n'aime pas la blanquette de veau."
2126     "Je n'aime pas les crêpes Suzette."
2127     "Je veux être parrain."
2128     "Jean a une moustache très longue."
2129     "Jeannette a du cran. Nous disons deux fois."
2130     "L'acide rougit le tournesol."
2131     "L'angora a les poils longs."
2132     "L'éléphant s'est cassé une défense."
2133     "L'heure des combats viendra."
2134     "L'infirme veut courir."
2135     "La Bénédictine est une liqueur douce."
2136     "La fortune vient en dormant."
2137     "La jeunesse est l'espoir du pays."
2138     "La mort de Turenne est irréparable."
2139     "La secrétaire est jolie."
2140     "La vache saute par dessus la lune."
2141     "La vertu réduit dans tous les yeux."
2142     "Le canapé se trouve au milieu du salon."
2143     "Le chacal n'aime pas le vermicelle. Nous disons : Le chacal n'aime pas le vermicelle."
2144     "Le chat a neuf vies."
2145     "Le chercheur d'or ira à la foire. Nous disons deux fois..."
2146     "Le cheval bleu se promène sur l'horizon."
2147     "Le chimpanzé est protocolaire. Nous disons trois fois..."
2148     "Le cocker est bon chasseur. Nous disons trois fois..."
2149     "Le coq chantera à minuit."
2150     "Le facteur s'est endormi."
2151     "Le grand blond s'appelle Bill."
2152     "Le musicien est enthousiaste."
2153     "Le père La Cerise est verni."
2154     "Le sapin est vert, je répète, le sapin est vert."
2155     "Le soleil se lève à l'Est le dimanche."
2156     "Les carottes sont cuites."
2157     "Les dés sont sur la table."
2158     "Les fraises sont dans leur jus."
2159     "Les girafes ne portent pas de faux-col."
2160     "Les noix sont sèches."
2161     "Les sanglots longs des violons de l'automne."
2162     "Lily embrasse Mimi. Nous disons : Lily embrasse Mimi..."
2163     "Lisette va bien."
2164     "Louis a deux cochons."
2165     "Ma femme à l'oeil vif."
2166     "Message très important pour Samuel : L'octogénaire ne se déride pas. Attendez deux voitures et des amis sur le bonbon. Nous disons : L'octogénaire ne se déride pas. Attendez deux voitures et des amis sur le bonbon..."
2167     "Messieurs faites vos jeux."
2168     "Michel-Ange et Raphael sont immortels."
2169     "Paul a du bon tabac."
2170     "Pierrot ressemble à son grand-père."
2171     "Rien ne m'est plus."
2172     "Saint Liguori fonda Naples."
2173     "Tambours, battez la charge, quatre fois. Nous disons : Tambours, battez la charge, quatre fois."
2174     "Tante Amélie fait du vélo en short."
2175     "Tu monteras la colline deux fois."
2176     "Une poule sur un mur picore du pain dur."
2177     "Véronèse était un peintre."
2178     "Yvette aime les grosses carottes."))
2179
2180 (defun radio-londre (&optional insertp)
2181   (interactive "P")
2182   (funcall (if insertp
2183                (function insert)
2184                (function message))
2185            (elt *radio-londre-messages* (random (length *radio-londre-messages*)))))
2186
2187
2188 ;;;----------------------------------------
2189 ;;; cedet
2190 ;;;----------------------------------------
2191 (defvar *pjb-load-noerror* nil)
2192 (defvar *pjb-load-silent*  nil)
2193
2194 (defun compile-cedet ()
2195   (interactive)
2196   (require 'ede)
2197   (load "ede-proj.el" *pjb-load-noerror* *pjb-load-silent*)
2198   (provide 'ede-proj)
2199   (let ((default-directory "/usr/local/share/emacs/site-lisp/cedet/ede/")
2200         (compilation-ask-about-save nil))
2201     (save-excursion
2202       (condition-case ignore
2203           (funcall 'ede-compile-project)
2204         (error :error)))))
2205
2206 (defun compile-eieio ()
2207   (interactive)
2208   (when (file-exists-p
2209          "/usr/local/share/emacs/site-lisp/cedet/eieio/eieio.el")
2210     (if (file-newer-than-file-p
2211          "/usr/local/share/emacs/site-lisp/cedet/eieio/eieio.elc"
2212          "/usr/local/share/emacs/site-lisp/cedet/eieio/eieio.el")
2213         (message ".EMACS: eieio.elc is up to date.")
2214         (progn
2215           (switch-to-buffer (get-buffer-create "*Compilation of eieio*"))
2216           (delete-other-windows)
2217           (erase-buffer)
2218           (insert "Did you run first: M-x compile-cedet RET ?")
2219           (split-window-vertically 5)
2220           (require 'ede)
2221           (load "ede-proj.el" *pjb-load-noerror* *pjb-load-silent*)
2222           (provide 'ede-proj)
2223           (let ((default-directory
2224                  "/usr/local/share/emacs/site-lisp/cedet/eieio/")
2225                 (compilation-ask-about-save nil))
2226             (save-excursion
2227               (condition-case ignore (ede-compile-project)
2228                 (error :error))))))))
2229
2230
2231
2232 ;;;----------------------------------------
2233 ;;; macros
2234 ;;;----------------------------------------
2235
2236 (defmacro* with-marker ((var position) &body body)
2237   (let ((vposition (gensym))) ; so (eq var position) still works.
2238     `(let* ((,vposition ,position)
2239             (,var (make-marker)))
2240        (set-marker ,var ,vposition)
2241        (unwind-protect (progn ,@body)
2242          (set-marker ,var nil)))))
2243
2244
2245 (defmacro* dolines (start-end &body body)
2246   "Executes the body with start-var and end-var bound to the start and the end of each lines of the current buffer in turn."
2247   (let ((vline (gensym)))
2248     (destructuring-bind (start-var end-var) start-end
2249       `(let ((sm (make-marker))
2250              (em (make-marker)))
2251          (unwind-protect
2252               (progn
2253                 (goto-char (point-min))
2254                 (while (< (point) (point-max))
2255                   (let ((,vline (point)))
2256                     (set-marker sm (point))
2257                     (set-marker em (progn (end-of-line) (point)))
2258                     (let ((,start-var  (marker-position sm))
2259                           (,end-var    (marker-position em)))
2260                       ,@body)
2261                     (goto-char ,vline)
2262                     (forward-line 1))))
2263            (set-marker sm nil)
2264            (set-marker em nil))
2265          nil))))
2266
2267
2268 (defmacro* with-file (file-and-options &body body)
2269   "
2270 find-file or find-file-literally, process body, and optionally save the buffer
2271 and kill it.
2272 save is not done if body exits exceptionnaly.
2273 kill is always done as specified.
2274 FILE-AND-OPTION: either an atom evaluated to a path,
2275                  or (path &key (save t) (kill t) (literal nil))
2276 "
2277   (if (atom file-and-options)
2278       `(with-file (,file-and-options) ,@body)
2279       ;; destructuring-bind is broken, we cannot give anything else than nil
2280       ;; as default values:
2281       (destructuring-bind (path &key (save nil savep) (kill nil killp)
2282                                 (literal nil literalp))
2283           file-and-options
2284         (unless savep (setf save t))
2285         (unless killp (setf kill t))
2286         `(unwind-protect
2287                 (progn
2288                   (,(if literal 'find-file-literally 'find-file) ,path)
2289                   (prog1 (save-excursion ,@body)
2290                          ,(when save `(save-buffer 1))))
2291            ,(when kill
2292                   `(kill-buffer (current-buffer)))))))
2293
2294
2295 (defun constantly (value) (byte-compile `(lambda (&rest arguments) ',value)))
2296
2297 (defun mapfiles (thunk directory &optional recursive exceptions)
2298   "
2299 THUNK:      a function of one argument called for each file pathname.
2300 DIRECTORY:  the pathname of the base directory.
2301 RECURSIVE:  a boolean indicating whether the directory will be walked recursively.
2302 EXCEPTIONS: either a list of pathnames that mustn't be processed,
2303             or a predicate indicating the pathnames that mustn't be processed.
2304 "
2305   (dolist (file (directory-files directory))
2306     (let* ((predicate (cond
2307                         ((null exceptions)
2308                          (constantly nil))
2309                         ((functionp exceptions)
2310                          exceptions)
2311                         ((listp exceptions)
2312                          (byte-compile `(lambda (x) (member* x ',exceptions :test (function string=)))))
2313                         (t (error "exceptions must be either a list or a function, not a ~S: ~S"
2314                                   (type-of exceptions) exceptions))))
2315            (path  (concat directory
2316                           (if (string= (subseq directory (1- (length directory)))
2317                                        "/")
2318                               "" "/")
2319                           file))
2320            (stat (file-attributes path)))
2321       ;; (message "\n\nstat      = %S" stat)
2322       ;; (message "recursive = %S" recursive)
2323       ;; (message "path      = %S" path)
2324       ;; (message "filter (funcall predicate path) -> %S" (funcall predicate path))
2325       (case (first stat)
2326         ((t)                            ; directory
2327          (unless (or (string= "." file) (string= ".." file))
2328            (when recursive
2329              (unless (funcall predicate path)
2330                (mapfiles thunk path recursive predicate)))))
2331         ((nil) ; file
2332          (unless (funcall predicate path)
2333            (funcall thunk path)))
2334         (otherwise ; symlink
2335          ;; NOP
2336          )))))
2337
2338
2339 (defmacro* with-files ((file-var directory-expr &optional recursive exceptions) &body body)
2340   `(mapfiles (lambda (,file-var) ,@body) ,directory-expr ,recursive ,exceptions))
2341
2342
2343
2344 ;;;----------------------------------------
2345 ;;; multi-file replace
2346 ;;;----------------------------------------
2347
2348
2349 (defvar *recursive-replace-ignored-directories* *ignorable-directories*)
2350
2351
2352 (defun recursive-replace-string (from-string to-string &optional directory recursive delimited)
2353   "Replace the all occurences of `from-string' by `to-string' in all the files in the directory.
2354 If `recursive' is true (or a prefix argument is given), then the files are searched recursively
2355 otherwise only the files directly in the given `directory' are modified.
2356 `*recursive-replace-ignored-directories*' is a list of directory names that are excluded from the
2357 recursive search.  Backup files (name ending in ~) are ignored too.
2358 `delimited', if non-nil, means replace only matches surrounded by word boundaries.
2359  "
2360   (interactive
2361    (let* ((directory (symbol-name (read-minibuffer "Directory: " default-directory)))
2362           (arguments (query-replace-read-args
2363                       (format "Replace string in all files in %s" directory)
2364                       nil)))
2365      (list (first arguments) (second arguments) directory (third arguments) nil)))
2366   (with-files (file directory recursive
2367                     (lambda (path)
2368                       (let ((name (basename path)))
2369                         (or (string= "~" (subseq name (1- (length name))))
2370                             (member* name *recursive-replace-ignored-directories*
2371                                      :test (function string=))))))
2372     (with-file (file)
2373       (message "Processing %S" file)
2374       (beginning-of-buffer)
2375       (replace-string from-string to-string delimited))))
2376
2377
2378 (defun recursive-replace-regexp (regexp to-string &optional directory recursive delimited)
2379   "Replace the all occurences of `regexp' by `to-string' in all the files in the directory.
2380 If `recursive' is true (or a prefix argument is given), then the files are searched recursively
2381 otherwise only the files directly in the given `directory' are modified.
2382 `*recursive-replace-ignored-directories*' is a list of directory names that are excluded from the
2383 recursive search.  Backup files (name ending in ~) are ignored too.
2384 `delimited', if non-nil, means replace only matches surrounded by word boundaries.
2385  "
2386   (interactive
2387    (let* ((directory (symbol-name (read-minibuffer "Directory: " default-directory)))
2388           (arguments (query-replace-read-args
2389                       (format "Replace string in all files in %s" directory)
2390                       nil)))
2391      (list (first arguments) (second arguments) directory (third arguments) nil)))
2392   (with-files (file directory recursive
2393                     (lambda (path)
2394                       (let ((name (basename path)))
2395                         (or (string= "~" (subseq name (1- (length name))))
2396                             (member* name *recursive-replace-ignored-directories*
2397                                      :test (function string=))))))
2398     (with-file (file)
2399       (message "Processing %S" file)
2400       (beginning-of-buffer)
2401       (replace-regexp regexp to-string delimited))))
2402
2403
2404 (defun multifile-replace-regexp (regexp to-string files &optional delimited)
2405   "Replace the all occurences of `regexp' by `to-string' in all the `files'.
2406 `delimited', if non-nil, means replace only matches surrounded by word boundaries.
2407  "
2408   (dolist (file files)
2409     (with-file (file :save t :kill nil)
2410       (message "Processing %S" file)
2411       (beginning-of-buffer)
2412       (replace-regexp regexp to-string delimited))))
2413
2414
2415 ;;;: THE END ;;;;