;;; morse.el --- convert to Morse code and back  -*- coding: iso-8859-1 -*- 

;; Copyright (C) 1995, 2002, 2005, 2006 Free Software Foundation, Inc.

;; Author: Rick Farnbach <rick_farnbach@MENTORG.COM>
;; Keywords: games

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; 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:

(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 punctuation, 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 &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 
           (and (boundp '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 active-morse-code))
	       (delete-char 1)
	       (insert sep (cdr morse))
	       (setq sep "/"))
	      (t
	       (forward-char 1)
	       (setq sep "")))))))

;;;###autoload
(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 ((current-language-environment 
           (and (boundp '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 active-morse-code)))
	      (goto-char (match-end 0))
	    (replace-match
		  (if (string-equal "(" (car morse))
		      (if (setq paren (null paren)) "(" ")")
		    (car morse)) t)
	    (if (looking-at "/")
		(delete-char 1))))))))

(provide 'morse)

;;; morse.el ends here
