SUPERSEDES 17793.34900.34462.589307(a)parhasard.net Fixes a bug in the Russian support; allows you to specify the language used for the conversion interactively. Ar an ceathrú lá déag de mí na Nollaig, scríobh Aidan Kehoe: --- morse.el.orig 2006-12-14 18:08:31.218750000 +0100 +++ morse.el 2006-12-15 13:57:37.921875000 +0100 ＠＠ -1,6 +1,7 ＠＠ -;;; morse.el --- convert text to morse code and back +;;; morse.el --- convert to Morse code and back -*- coding: iso-8859-1 -*- +;; -;; Copyright (C) 1995 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2006 Free Software Foundation, Inc. ;; Author: Rick Farnbach <rick_farnbach(a)MENTORG.COM&gt; ;; Keywords: games ＠＠ -24,77 +25,308 ＠＠ ;;; Commentary: -;; Converts text to Morse code and back with M-x morese-region and +;; Converts text to Morse code and back with M-x morse-region and ;; M-x unmorse-region (though Morse code is no longer official :-(). ;;; Code: -(defvar morse-code '(("a" . ".-") - ("b" . "-...") - ("c" . "-.-.") - ("d" . "-..") - ("e" . ".") - ("f" . "..-.") - ("g" . "--.") - ("h" . "....") - ("i" . "..") - ("j" . ".---") - ("k" . "-.-") - ("l" . ".-..") - ("m" . "--") - ("n" . "-.") - ("o" . "---") - ("p" . ".--.") - ("q" . "--.-") - ("r" . ".-.") - ("s" . "...") - ("t" . "-") - ("u" . "..-") - ("v" . "...-") - ("w" . ".--") - ("x" . "-..-") - ("y" . "-.--") - ("z" . "--..") - ;; Punctuation - ("=" . "-...-") - ("?" . "..--..") - ("/" . "-..-.") - ("," . "--..--") - ("." . ".-.-.-") - (":" . "---...") - ("'" . ".----.") - ("-" . "-....-") - ("(" . "-.--.-") - (")" . "-.--.-") - ;; Numbers - ("0" . "-----") - ("1" . ".----") - ("2" . "..---") - ("3" . "...--") - ("4" . "....-") - ("5" . ".....") - ("6" . "-....") - ("7" . "--...") - ("8" . "---..") - ("9" . "----.")) - "Morse code character set.") +(eval-when-compile (require 'cl)) + +(defvar digits-punctuation-morse-code '(("0" . "-----") + ("1" . ".----") + ("2" . "..---") + ("3" . "...--") + ("4" . "....-") + ("5" . ".....") + ("6" . "-....") + ("7" . "--...") + ("8" . "---..") + ("9" . "----.") + ;; Punctuation + ("=" . "-...-") + ("?" . "..--..") + ("/" . "-..-.") + ("," . "--..--") + ("." . ".-.-.-") + (":" . "---...") + ("'" . ".----.") + ("-" . "-....-") + ("(" . "-.--.-") + (")" . "-.--.-") + ("＠" . ".--.-.") + ("+" . ".-.-.")) + "The digits and punctuation in Morse code, as used internationally.") + +(defvar english-alphabet-morse-code '(("a" . ".-") + ("b" . "-...") + ("c" . "-.-.") + ("d" . "-..") + ("e" . ".") + ("f" . "..-.") + ("g" . "--.") + ("h" . "....") + ("i" . "..") + ("j" . ".---") + ("k" . "-.-") + ("l" . ".-..") + ("m" . "--") + ("n" . "-.") + ("o" . "---") + ("p" . ".--.") + ("q" . "--.-") + ("r" . ".-.") + ("s" . "...") + ("t" . "-") + ("u" . "..-") + ("v" . "...-") + ("w" . ".--") + ("x" . "-..-") + ("y" . "-.--") + ("z" . "--..")) + "Morse code, as used for the letters of English. ") + +(defvar german-alphabet-morse-code (nconc + '(("ä" . ".-.-") + ("ö" . "---.") + ("ü" . "..--") + ("ß" . "...--..") + ;; Bug; unmorse-region respects + ;; ch, morse-region doesn't. + ("ch". "----")) + english-alphabet-morse-code) + "Morse code, as used for the letters of German. ") + +(defvar spanish-alphabet-morse-code (nconc + '(("ch". "----") + ("ñ" . "--.--") + ("ü" . "..--")) + english-alphabet-morse-code) + "Morse code, as used for the letters of Spanish. ") + +(defvar french-alphabet-morse-code (nconc + '(("ç". "-.-..") + ("è". ".-..-") + ("é" . "..-..") + ("à" . ".--.-")) + english-alphabet-morse-code)) + +(defvar swedish-alphabet-morse-code (nconc + '(("ä" . ".-.-") + ("ö" . "---.") + ("å" . ".--.-")) + english-alphabet-morse-code) + "Morse code, as used for the letters of Swedish. ") + +(defvar danish-alphabet-morse-code (nconc + '(("æ" . ".-.-") + ("ø" . "---.") + ("å" . ".--.-")) + english-alphabet-morse-code) + "Morse code, as used for the letters of Danish. ") + +(defvar norwegian-alphabet-morse-code danish-alphabet-morse-code + "Morse code, as used for the letters of Norwegian. ") + +(when (featurep 'mule) + (defvar cyrillic-alphabet-morse-code + (loop + for (cyrillic morse) + in '((#xd0 ".-") + (#xd1 "-...") + (#xd2 ".--") + (#xd3 "--.") + (#xd4 "-..") + (#xd5 ".") + (#xd6 "...-") + (#xd7 "--..") + (#xd8 "..") + (#xd9 ".---") + (#xda "-.-") + (#xdb ".-..") + (#xdc "--") + (#xdd "-.") + (#xde "---") + (#xdf ".--.") + (#xe0 ".-.") + (#xe1 "...") + (#xe2 "-") + (#xe3 "..-") + (#xe4 "..-.") + (#xe5 "....") + (#xe6 "-.-.") + (#xe7 "---.") + (#xe8 "----") + (#xe9 "--.-") + (#xec "-..-") + (#xeb "-.--") + (#xed "..-..") + (#xee "..--") + (#xef ".-.-")) + collect (cons (string (make-char 'cyrillic-iso8859-5 cyrillic)) + morse)) + "Morse code, as used for the letters of Russian. ") + (defvar japanese-alphabet-morse-code + (loop + for (first-octet second-octet morse) + in '((37 36 ".-") + (37 78 "..--") + (37 109 ".-.-") + (37 42 ".-...") + (37 79 "-...") + (37 47 "...-") + (37 75 "-.-.") + (37 100 ".--") + (37 91 "-..") + (37 94 "-..-") + (37 88 ".") + (37 49 "-.--") + (37 72 "..-..") + (37 85 "--..") + (37 65 "..-.") + (37 51 "----") + (37 106 "--.") + (37 40 "-.---") + (37 76 "....") + (37 70 ".-.--") + (37 107 "-.--.") + (37 34 "--.--") + (37 114 ".---") + (37 53 "-.-.-") + (37 111 "-.-") + (37 45 "-.-..") + (37 43 ".-..") + (37 102 "-..--") + (37 104 "--") + (37 97 "-...-") + (37 63 "-.") + (37 95 "..-.-") + (37 108 "---") + (37 55 "--.-.") + (37 61 "---.") + (37 113 ".--..") + (37 68 ".--.") + (37 82 "--..-") + (37 77 "--.-") + (37 98 "-..-.") + (37 74 ".-.") + (37 59 ".---.") + (37 105 "...") + (37 57 "---.-") + (37 96 "-") + (37 115 ".-.-.") + (37 38 "..-") + (37 112 ".-..-") + (33 43 "..") + (33 44 "..--.") + (33 60 ".--.-") + (33 87 ".-.-..")) + collect (cons (string (make-char 'japanese-jisx0208 + first-octet second-octet)) + morse)) + "Morse code, as used for Katakana. ") + (defvar korean-alphabet-morse-code + (loop + for (first-octet second-octet morse) + in '((36 33 ".-..") + (36 62 ".---") + (36 36 "..-.") + (36 63 ".") + (36 39 "-...") + (36 65 "..") + (36 41 "...-") + (36 67 "-") + (36 49 "--") + (36 69 "...") + (36 50 ".--") + (36 71 ".-") + (36 53 "--.") + (36 75 "-.") + (36 55 "-.-") + (36 76 "....") + (36 56 ".--.") + (36 80 ".-.") + (36 58 "-.-.") + (36 81 "-..") + (36 59 "-..-") + (36 83 "..-") + (36 60 "--..") + (36 64 "--.-") + (36 61 "---") + (36 68 "-.--")) + collect (cons (string (make-char 'korean-ksc5601 + first-octet second-octet)) + morse)) + "Morse code, as used for Hangul. ")) + +(defvar active-morse-code nil + "The active Morse alphabet, digits, and puncuation, as an alist. ") + +(defun choose-active-morse-code () + "Work out what `active-morse-code' should be, and set it to that. +Depends on the current language environment. " + (let ((alphabet-sym (intern-soft + (format "%s-alphabet-morse-code" + (if (and (boundp 'current-language-environment) + current-language-environment) + (downcase + (car (split-string + current-language-environment + "[- ]"))) + "english"))))) + (if (and alphabet-sym (boundp alphabet-sym)) + (setq active-morse-code + (append (symbol-value alphabet-sym) + digits-punctuation-morse-code)) + (setq active-morse-code + (append english-alphabet-morse-code + digits-punctuation-morse-code))))) + +(add-hook 'set-language-environment-hook 'choose-active-morse-code) + +(choose-active-morse-code) + +(defun read-morse-args () + "Return a list of the beginning and end of the region, and a language. +The language will only be non-nil if the current command has a prefix +argument specified. " + (list + (if (and (boundp 'zmacs-regions) zmacs-regions (not zmacs-region-active-p)) + (error "The region is not active now") + (let ((tem (marker-buffer (apply 'mark-marker + (if (boundp 'zmacs-regions) + '(t)))))) + (unless (and tem (eq tem (current-buffer))) + (error "The mark is now set now")) + (region-beginning))) + (region-end) + (and current-prefix-arg + (if (fboundp 'read-language-name) + (read-language-name nil "Language environment: ") + (read-string "Language environment: "))))) ;;;###autoload -(defun morse-region (beg end) - "Convert all text in a given region to morse code." - (interactive "r") +(defun morse-region (beg end &optional lang) + "Convert all text in a given region to morse code. +Optional prefix arg LANG gives a language environment to use for conversion. " + (interactive (read-morse-args)) (if (integerp end) (setq end (copy-marker end))) (save-excursion (let ((sep "") + (current-language-environment current-language-environment) + (active-morse-code active-morse-code) str morse) + (when lang + ;; An actual use of dynamic binding in anger! + (setq current-language-environment lang) + (choose-active-morse-code)) (goto-char beg) (while (< (point) end) (setq str (downcase (buffer-substring (point) (1+ (point))))) (cond ((looking-at "\\s-+") (goto-char (match-end 0)) (setq sep "")) - ((setq morse (assoc str morse-code)) + ((setq morse (assoc str active-morse-code)) (delete-char 1) (insert sep (cdr morse)) (setq sep "/")) ＠＠ -103,19 +335,25 ＠＠ (setq sep ""))))))) ;;;###autoload -(defun unmorse-region (beg end) - "Convert morse coded text in region to ordinary ASCII text." - (interactive "r") +(defun unmorse-region (beg end &optional lang) + "Convert morse coded text in region to ordinary text. +Optional prefix arg LANG gives a language environment to use for conversion." + (interactive (read-morse-args)) (if (integerp end) (setq end (copy-marker end))) (save-excursion - (let (str paren morse) + (let ((current-language-environment current-language-environment) + (active-morse-code active-morse-code) + str paren morse) + (when lang + (setq current-language-environment lang) + (choose-active-morse-code)) (goto-char beg) (while (< (point) end) (if (null (looking-at "[-.]+")) (forward-char 1) (setq str (buffer-substring (match-beginning 0) (match-end 0))) - (if (null (setq morse (rassoc str morse-code))) + (if (null (setq morse (rassoc str active-morse-code))) (goto-char (match-end 0)) (replace-match (if (string-equal "(" (car morse)) -- “No one can guarantee that any course of action in Iraq at this point will stop sectarian warfare, growing violence, or a slide toward chaos.” (Iraq Study Group Report, Dec. 6, 2006) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches