--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/misc/gadict.el Sun Oct 18 12:25:22 2020 +0300
@@ -0,0 +1,429 @@
+;;; gadict.el --- major mode for editing gadict dictionary source files -*- lexical-binding: t -*-
+
+;; Copyright (C) 2016 by Oleksandr Gavenko <gavenkoa@gmail.com>
+
+;; You can do anything with this file without any warranty.
+
+;; Author: Oleksandr Gavenko <gavenkoa@gmail.com>
+;; Maintainer: Oleksandr Gavenko <gavenkoa@gmail.com>
+;; Created: 2016
+;; Version: 0.1
+;; Keywords: dict, dictionary
+
+;;; Commentary:
+;;
+;; Mode can be installed by:
+;;
+;; (autoload 'gadict-mode "gadict")
+;;
+;; File association can be registered by:
+;;
+;; (add-to-list 'auto-mode-alist (cons "\\.gadict$" 'gadict-mode))
+
+;;; Code:
+
+(defun gadict--trim-left (s)
+ "Remove whitespace at the beginning of S."
+ (if (string-match "\\`[ \t\n\r]+" s)
+ (replace-match "" t t s)
+ s))
+
+(defun gadict--trim-right (s)
+ "Remove whitespace at the end of S."
+ (if (string-match "[ \t\n\r]+\\'" s)
+ (replace-match "" t t s)
+ s))
+
+(defun gadict--trim (s)
+ "Remove whitespace at the beginning and end of S."
+ (gadict--trim-left (gadict--trim-right s)))
+
+
+
+(defconst gadict--vowels-re "[o$(O+8+:+7+9(Ba$(O+3+0,Af(Be,0#$(O+1(Bi,0!(Bu$(O+5+C+U+S+T(B]+")
+
+(defun gadict--vowel-group-count (s)
+ (let ( (cnt 0) (start 0) )
+ (while (string-match gadict--vowels-re s start)
+ (setq cnt (1+ cnt))
+ (setq start (match-end 0)))
+ cnt))
+
+(defun gadict--espeak-cleanup-accent (s)
+ "Remove accent if only one syllable in word."
+ (if (<= (gadict--vowel-group-count s) 1)
+ (replace-regexp-in-string "[$,1$h$l(B]" "" s)
+ s))
+
+(defun gadict--espeak-cleanup-accent-in-sentence (s)
+ "Remove accent if only one syllable in word."
+ (mapconcat #'gadict--espeak-cleanup-accent (split-string s " ") " "))
+
+(defun gadict--espeak-cleanup (s)
+ "Cleanup espeak IPA output."
+ (mapc (lambda (fn) (setq s (funcall fn s)))
+ (list
+ ;; UTF symbol between t$(O*h(B to make ligature.
+ (lambda (str) (replace-regexp-in-string "[\x200D]" "" str))
+ (lambda (str) (replace-regexp-in-string "t$(O*h(B" "$,1$G(B" str))
+ (lambda (str) (replace-regexp-in-string "$,1k{(B" ",0!(B" str))
+ #'gadict--trim
+ #'gadict--espeak-cleanup-accent-in-sentence))
+ s)
+
+(defvar gadict-espeak-enabled nil
+ "Is espeak used.")
+
+(defvar gadict-espeak-program "espeak")
+(defvar gadict-espeak-program-ipa-args "-q --ipa=2")
+;; "en" "en-gb" "en-us" "en-sc"
+(defvar gadict-espeak-voices-list '("en-gb" "en-us")
+ "What voices to show. Look to 'espeak --voices' for full list.")
+(defvar gadict-espeak-default-voice "en-us"
+ "Default voice for espeak. Used in article template.")
+
+(defun gadict-espeak-ipa (str &optional voice)
+ (gadict--espeak-cleanup
+ (shell-command-to-string
+ (format "%s %s %s %s"
+ gadict-espeak-program
+ gadict-espeak-program-ipa-args
+ (if (stringp voice) (concat "-v" (shell-quote-argument voice)) "")
+ (shell-quote-argument str)))))
+
+(defun gadict-espeak-headline-line (headword)
+ (mapconcat (lambda (voice) (format "%s: %s"
+ (propertize voice 'face '(:foreground "red"))
+ (gadict-espeak-ipa headword voice)))
+ (if (listp gadict-espeak-voices-list) gadict-espeak-voices-list '(nil))
+ " | "))
+
+;; (defun gadict-espeak-headline-display ()
+;; (interactive)
+;; (message (gadict-espeak-headline-line)))
+
+(defvar gadict-espeak-headline-headword nil)
+
+(defun gadict-espeak-headline-display ()
+ (when (eq major-mode 'gadict-mode)
+ (let ( (headword (condition-case nil (gadict-nearest-headword) (error nil))) )
+ (unless (eq headword gadict-espeak-headline-headword)
+ (setq gadict-espeak-headline-headword headword)
+ (setq header-line-format (if headword (gadict-espeak-headline-line headword) nil))
+ (force-mode-line-update)))))
+
+(defvar gadict-espeak-headline-timer nil)
+(defun gadict-espeak-headline-enable ()
+ "Enable headline with espeak IPA pronunciation."
+ (interactive)
+ (unless gadict-espeak-headline-timer
+ (setq gadict-espeak-headline-timer (run-with-idle-timer 1 t #'gadict-espeak-headline-display))))
+(defun gadict-espeak-headline-disable ()
+ "Enable headline with espeak IPA pronunciation."
+ (interactive)
+ (when gadict-espeak-headline-timer
+ (cancel-timer gadict-espeak-headline-timer))
+ (setq gadict-espeak-headline-timer nil)
+ (setq header-line-format nil))
+
+
+
+(defconst gadict--pos '("n" "v" "adj" "adv" "pron" "det" "prep" "num" "conj" "int" "phr" "phr.v" "contr" "abbr" "prefix")
+ "Defined parts of speech.")
+
+(defconst gadict--art-lang-regex (regexp-opt '("en" "ru" "uk" "la")))
+(defconst gadict--art-rel-regex (regexp-opt '("cnt" "ant" "syn" "rel" "topic" "hyper" "hypo" "col")))
+(defconst gadict--art-var-regex (regexp-opt '("rare" "v1" "v2" "v3" "s" "pl" "male" "female" "baby" "abbr" "comp" "super" "Am" "Br" "Au")))
+(defconst gadict--art-pos-regex (regexp-opt gadict--pos))
+
+(defgroup gadict nil
+ "gadict-mode customization."
+ :group 'wp)
+
+(defface gadict-tr-face '((t :foreground "#40a040" :slant italic))
+ "Face for marker of translation."
+ :group 'gadict)
+(defface gadict-ex-face '((t :foreground "#20a0c0" :slant italic))
+ "Face for marker of example."
+ :group 'gadict)
+(defface gadict-glos-face '((t :foreground "#a04040" :slant italic))
+ "Face for marker of explanation."
+ :group 'gadict)
+
+(defvar gadict-font-lock-keywords
+ `( ("^\\(__\\)\n\n\\(\\w.*\\)$" (1 font-lock-function-name-face) (2 font-lock-keyword-face))
+ ("^ .*\n\\(\\w.*\\)" (1 font-lock-keyword-face))
+ ("^#.*" . font-lock-comment-face)
+ ("^ +\\[[^]\n:]+]" . font-lock-type-face)
+ ("^ +homo: " . 'gadict-tr-face)
+ (,(format "^%s: " gadict--art-lang-regex) . 'gadict-tr-face)
+ (,(format "^%s> " gadict--art-lang-regex) . 'gadict-ex-face)
+ (,(format "^%s= " gadict--art-lang-regex) . 'gadict-glos-face)
+ (,(format "^%s: " gadict--art-rel-regex) . font-lock-doc-face)
+ (,(format "^ +%s$" gadict--art-var-regex) . font-lock-doc-face)
+ (,(format "^%s$" gadict--art-pos-regex) . font-lock-warning-face) ))
+
+(defun gadict-setup-fontlock ()
+ "Setup gadict fontlock."
+ (setq font-lock-defaults
+ '(gadict-font-lock-keywords
+ t nil nil nil
+ (font-lock-multiline . t) ))
+ (add-hook 'font-lock-extend-region-functions 'gadict-font-lock-extend-region t) )
+
+(defun gadict-setup-syntax ()
+ "Setup gadict characters syntax."
+ (modify-syntax-entry ?' "w"))
+
+(defun gadict-setup-comment ()
+ "Setup gadict comment commands."
+ (set (make-local-variable 'comment-start) "#")
+ (set (make-local-variable 'comment-continue) nil)
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-end-skip) nil)
+ (set (make-local-variable 'comment-multi-line) nil)
+ (set (make-local-variable 'comment-use-syntax) nil) )
+
+(defun gadict-setup-paragraph ()
+ "Setup gadict sentence/paragraph definition."
+ (set (make-local-variable 'paragraph-separate) "__$")
+ (set (make-local-variable 'paragraph-start) "__$")
+ (set (make-local-variable 'sentence-end) "\n"))
+
+(defun gadict-setup-page ()
+ "Setup gadict page definition."
+ (set (make-local-variable 'page-delimiter) "__$") )
+
+(defvar gadict-indent-offset 2
+ "Indent level.")
+
+(defun gadict-indent-line ()
+ "Indent line in gdict mode."
+ (if (eq (current-indentation) gadict-indent-offset)
+ (indent-line-to 0)
+ (indent-line-to gadict-indent-offset)))
+
+(defun gadict-setup-indent ()
+ "Setup indenting for gdict mode."
+ (set (make-local-variable 'indent-line-function) 'gadict-indent-line))
+
+(defun gadict-mark-article ()
+ "Mark current article."
+ (end-of-line)
+ (re-search-backward "^__$")
+ (set-mark (point))
+ (forward-line)
+ (if (re-search-forward "^__$" nil t)
+ (forward-line 0)
+ (goto-char (point-max)))
+ (exchange-point-and-mark))
+
+(defun gadict-mark-line ()
+ "Mark current line."
+ (forward-line 0)
+ (set-mark (point))
+ (forward-line 1)
+ (exchange-point-and-mark))
+
+(defvar er/try-expand-list)
+(defun gadict-setup-expansions ()
+ "Add `gadict-mode' specific expansions."
+ (set (make-local-variable 'er/try-expand-list) (list #'er/mark-word #'gadict-mark-line #'gadict-mark-article)))
+
+(defvar font-lock-beg)
+(defvar font-lock-end)
+(defun gadict-font-lock-extend-region ()
+ "Look for '__' expression and extend `font-lock-beg' and `font-lock-end'."
+ ;; (message "%d:%d, %d lines" font-lock-beg font-lock-end (count-lines font-lock-beg font-lock-end))
+ (cond
+ ((and
+ (< (count-lines font-lock-beg font-lock-end) 5)
+ (not (and (<= (point-max) font-lock-end) (<= font-lock-beg (point-min)) )))
+ (save-excursion
+ (goto-char font-lock-beg)
+ (forward-line -2)
+ (setq font-lock-beg (point))
+ (goto-char font-lock-end)
+ (forward-line 3)
+ (setq font-lock-end (point)))
+ t)
+ (t nil) ))
+
+(defvar-local gadict-tr nil
+ "Translation markers as string separated by comma. Define own
+ values in .dir-local.el or as -*- gadict-tr: \"...\" -*- file prelude")
+(put 'gadict-tr 'safe-local-variable 'string-or-null-p)
+
+(defun gadict-insert-article (headword pos)
+ "Insert new article after the current place.
+
+If `gadict-espeak-enabled' is `t' pronunciation will be filled
+with espeak `gadict-espeak-default-voice'."
+ (if (re-search-forward "^__" nil t)
+ (beginning-of-line)
+ (goto-char (point-max)))
+ (while (eq (char-before) ?\n)
+ (delete-char -1))
+ (insert-char ?\n)
+ (insert-char ?_ 2)
+ (insert-char ?\n 3)
+ (forward-char -1)
+ (insert headword)
+ (insert "\n [")
+ (when gadict-espeak-enabled
+ (insert (gadict-espeak-ipa headword gadict-espeak-default-voice)))
+ (insert "]")
+ (insert-char ?\n 2)
+ (insert pos)
+ (gadict--insert-tr))
+
+(defun gadict-search-floor (headword)
+ "Move to HEADWORD definition or place on posiiton for new corresponding
+definition. Check for headwords ordering during search.
+
+Return `t' if definition found, `nil' if no such headword."
+ (let ( prev curr )
+ (catch 'exit
+ (goto-char (point-min))
+ (unless (re-search-forward "^__$" nil t)
+ (throw 'exit nil))
+ (forward-line 2)
+ (setq prev (buffer-substring-no-properties (point) (line-end-position)))
+ (when (string= headword prev)
+ (throw 'exit t))
+ (when (string< headword prev)
+ (goto-char (point-min))
+ (throw 'exit nil))
+ (while t
+ (unless (re-search-forward "^__$" nil t)
+ (throw 'exit nil))
+ (forward-line 2)
+ (setq curr (buffer-substring-no-properties (point) (line-end-position)))
+ (when (string> prev curr)
+ (error (format "%s < %s" curr prev)))
+ (when (string= headword curr)
+ (throw 'exit t))
+ (when (string< headword curr)
+ (forward-line -2)
+ (re-search-backward "^__$")
+ (forward-line 2)
+ (throw 'exit nil))
+ (setq prev curr)) )))
+
+(defun gadict-search (headword)
+ "Move to HEADWORD definition or place on posiiton for new corresponding
+definition. Check for headwords ordering during search."
+ (interactive (list (read-string "Headword: ")))
+ (gadict-search-floor headword)
+ (recenter))
+
+(defun gadict-insert-article-in-order ()
+ "Insert new article template with respect of headword order."
+ (interactive)
+ (let (headword pos)
+ (setq headword (read-string "Headword: "))
+ (unless (gadict-search-floor headword)
+ (setq pos (completing-read "POS: " gadict--pos nil t))
+ (gadict-insert-article headword pos)
+ (recenter))))
+
+(defun gadict--find-headword-end ()
+ (save-excursion
+ (end-of-line)
+ (re-search-backward "^__$")
+ (re-search-forward "^$")
+ (forward-char)
+ (re-search-forward "^$")
+ (point)))
+
+(defun gadict-insert-translation (pos)
+ "Insert translation template using value of `gadict-tr'."
+ (interactive (list (completing-read "POS: " gadict--pos nil t)))
+ (let ( (headword-end (gadict--find-headword-end)) )
+ (if (< (point) headword-end)
+ (goto-char headword-end)
+ (re-search-forward "^\\(?:\\|__\\)$")
+ (when (eq (char-before) ?_)
+ (beginning-of-line)))
+ (insert-char ?\n 2)
+ (forward-char -1)
+ (insert pos)
+ (gadict--insert-tr) ))
+
+(defun gadict--insert-tr ()
+ "Insert `gadict-tr' as multiline template on next line. Place point on the end of the first new line."
+ (when (stringp gadict-tr)
+ (save-excursion
+ (end-of-line)
+ (mapc (lambda (lang)
+ (insert-char ?\n)
+ (insert lang)
+ (insert ": "))
+ (split-string gadict-tr ",")))
+ (end-of-line 2)))
+
+(defun gadict-nearest-headword ()
+ "Return nearest headword looking upward."
+ (save-excursion
+ (let ( (orig (point)) limit )
+ (re-search-backward "^__$")
+ (forward-line 1)
+ (unless (and (eq (char-before) ?\n) (eq (char-after) ?\n))
+ (error "Syntax error: there is not empty line after '__'..."))
+ (forward-line 1)
+ (when (< orig (point))
+ (setq orig (point)))
+ (setq limit (point))
+ (re-search-forward "^$")
+ (when (< orig (point))
+ (goto-char orig)
+ (end-of-line))
+ (re-search-backward "^\\([^ ].*\\)$" limit)
+ (match-string 1)
+ )))
+
+(defun gadict-copy-pronunciation (&optional headword)
+ "Copy existing pronunciation of selected region or current word to `kill-ring'."
+ (interactive
+ (list (if (use-region-p)
+ (buffer-substring (region-beginning) (region-end))
+ (thing-at-point 'word))))
+ (save-excursion
+ (gadict-search-floor headword)
+ (when (search-forward-regexp "\\[\\([^]]+\\)]")
+ (kill-new (match-string 1)))))
+
+(defun gadict-copy-espeak-pronunciation (&optional headword)
+ "Copy espeak pronunciation of selected region or current word to `kill-ring'."
+ (interactive
+ (list (if (use-region-p)
+ (buffer-substring (region-beginning) (region-end))
+ (thing-at-point 'word))))
+ (kill-new (gadict-espeak-headline-line headword)))
+
+(defun gadict-setup-keymap ()
+ "Setup gadict keymap."
+ (define-key (current-local-map) [S-return] 'gadict-insert-translation)
+ (define-key (current-local-map) [C-return] 'gadict-insert-article-in-order)
+ (define-key (current-local-map) [C-S-return] 'gadict-search)
+ (define-key (current-local-map) [M-return] 'gadict-copy-pronunciation)
+ (define-key (current-local-map) [M-S-return] 'gadict-copy-espeak-pronunciation))
+
+;;;###autoload
+(define-derived-mode gadict-mode fundamental-mode "gadict"
+ "Derived mode for editing gadict dictionary source files."
+ (gadict-setup-fontlock)
+ (gadict-setup-keymap)
+ (gadict-setup-syntax)
+ (gadict-setup-paragraph)
+ (gadict-setup-page)
+ (gadict-setup-comment)
+ (gadict-setup-indent)
+ (gadict-setup-expansions)
+ (when (executable-find gadict-espeak-program)
+ (setq gadict-espeak-enabled t)
+ (gadict-espeak-headline-enable)))
+
+(provide 'gadict)
+
+;;; gadict.el ends here