; Mode for classifying and debugging words in wordlists
; Created by J. Stolfi em 92-10-21

; Basic tools

(defun dic-sort-this-buffer ()
  "Applies sort -u on the current buffer"
  (interactive)
  (end-of-buffer)
  (if (not (= (preceding-char) ?\n)) (insert-char ?\n 1))
  (call-process-region (dot-min) (dot-max) "/bin/sort" t t nil "-u")
)

(defun dic-at-tag ()
  "TRUE iff point is placed before a work tag"
  (and
    (bolp)
    (progn
      (forward-char)
      (let ((c1 (preceding-char)) (c2 (following-char)))
        (backward-char)
        (and 
          (= c2 ?\ ) 
          (or (= c1 ??)
              (= c1 ?+)
              (= c1 ?-)
              (= c1 ?.)
              (= c1 ?*)
              (= c1 ?@)
              (= c1 ?&)
          )
        )
      )
    )
  )
)

(defun dic-skip-tag ()
  "Skips over the word tag, if present. Assumes (bolp)."
  (if (dic-at-tag) (progn (forward-char) (forward-char)))
)

(defun dic-remove-tag ()
  "Removes the tag from this line and returns it, if any. Assumes (bolp)"
  (if (dic-at-tag)
    (let ((tag (following-char))) (delete-char 1) (delete-char 1) tag)
    0
  )
)  

; Intermediate tools

(defun dic-set-tag (tag)
  "Adds or replaces a classification tag in front of the current line"
  (let ((p-here (copy-marker (point))))
    (beginning-of-line)
    (dic-remove-tag)
    (if (> tag 0) (progn (insert-char tag 1) (insert-char ?\  1)))
    (goto-char p-here)
  )
)

; Interactive commands

(defun dic-untag ()
  "Removes the classification tag from this line, if any"
  (interactive)
  (let ((p-here (copy-marker (point))))
    (beginning-of-line)
    (dic-remove-tag)
    (goto-char p-here)
  )
)

(defun dic-tag-goods ()
  "tags current word as valid (+)"
  (interactive)
  (dic-set-tag ?+)
  (end-of-line)
  (forward-char)
)

(defun dic-tag-maybe ()
  "tags current word as dubious (?)"
  (interactive)
  (dic-set-tag ?\?)
  (end-of-line)
  (forward-char)
)

(defun dic-tag-trash ()
  "tags current word as invalid (-)"
  (interactive)
  (dic-set-tag ?\-)
  (end-of-line)
  (forward-char)
)

(defun dic-tag-grtin ()
  "tags current word as greek/latin (*)"
  (interactive)
  (dic-set-tag ?*)
  (end-of-line)
  (forward-char)
)

(defun dic-tag-brits ()
  "tags current word as un-American (&)"
  (interactive)
  (dic-set-tag ?&)
  (end-of-line)
  (forward-char)
)

(defun dic-tag-abbrs ()
  "tags current word as abbreviation (.)"
  (interactive)
  (dic-set-tag ?.)
  (end-of-line)
  (forward-char)
)

(defun dic-tag-names ()
  "tags current word as proper noun (@)"
  (interactive)
  (dic-set-tag ?@)
  (end-of-line)
  (forward-char)
)

(defun dic-elim-repeated ()
  "eliminates interactively repeated entries in a checked wordlist"
  (interactive)
  (query-replace-regexp "^\\(.\\) \\(.*\\)\n\\(.\\) \\2$" "\\1 \\2")
)

(defun dic-dupl ()
  "Duplicates preceding entry"
  (interactive)
  (backward-char)
  (beginning-of-line)
  (dic-skip-tag)
  (let ((p-beg (point)))
    (end-of-line)
    (forward-char)
    (let ((p-end (point)))
      (insert-string (buffer-substring p-beg p-end))
    )
    (backward-char)
  )
)

(defun dic-inflect-english-noun ()
  "Generates English plurals and possesives of current word"
  (interactive)
  (beginning-of-line)
  (dic-skip-tag)
  (let ((p-beg (point)))
    (end-of-line)
    (let ((p-end (point)))
      (let ((word (buffer-substring p-beg p-end)))
        (forward-char)
        (insert-string word)
        (if (= (preceding-char) ?s)
          (insert-char ?\' 1)
          (progn (insert-char ?\' 1) (insert-char ?s 1))
        )
        (insert-char ?\n 1)
        (dic-insert-english-plural word)
        (insert-char ?\n 1)
        (dic-insert-english-plural word)
        (if (= (preceding-char) ?s)
          (insert-char ?\' 1)
          (progn (insert-char ?\' 1) (insert-char ?s 1))
        )
        (insert-char ?\n 1)
      )
      (backward-char) (beginning-of-line)
      (backward-char) (beginning-of-line)
      (backward-char) (beginning-of-line)
      (backward-char) (beginning-of-line)
    )
  )
)

(defun dic-insert-english-plural (word)
  "Inserts at point the English plural of word"
  (insert-string word)
  (if 
    (or (= (preceding-char) ?s) (= (preceding-char) ?x)) 
    (insert-char ?e 1)
  )
  (if 
    (and 
      (= (preceding-char) ?h) 
      (prog2 
        (backward-char) 
        (and 
          (not (bobp)) 
          (or (= (preceding-char) ?c) (= (preceding-char) ?s))
        )
        (forward-char)
      )
    )
    (insert-char ?e 1)
  )
  
  (if
    (= (preceding-char) ?y)
    (progn (delete-char -1) (insert-char ?i 1) (insert-char ?e 1))
  )
  (insert-char ?s 1)
)

(make-variable-buffer-local 'dic-mode)

(defvar dic-mode-map nil
  "Keymap used in dic-mode.")

(let ((map (make-sparse-keymap)))
  (define-key map "&"  'dic-tag-brits)
  (define-key map "+"  'dic-tag-goods)
  (define-key map "_"  'dic-tag-trash)
  (define-key map "?"  'dic-tag-maybe)
  (define-key map ">"  'dic-tag-abbrs)
  (define-key map "*"  'dic-tag-grtin)
  (define-key map "@"  'dic-tag-names)
  (define-key map ":"  'dic-dupl)
  (define-key map ")"  'dic-untag)
  (define-key map "%"  'dic-inflect-english-noun)
  (define-key map [f2] 'dic-sort-this-buffer)
  (setq dic-mode-map map)
  nil
)

(defvar dic-mode nil
  "t means dic-mode keybindings are on.")

(make-local-variable 'dic-mode)

(defun dic-mode (arg)
  "Adds/removes key bindings for manual classification of word lists:
\\{dic-mode-map}
The mode is turned off with a nil or 0 argument, and on with any other argument.
When called interactively, the prefix argument is used; no prefix means toggle
the mode"
  (interactive "P")
  (or 
     (assq 'dic-mode minor-mode-alist)
     (setq minor-mode-alist
       (cons '(dic-mode " dic") minor-mode-alist)
     )
  )
  (or 
     (assq 'dic-mode minor-mode-map-alist)
     (setq minor-mode-map-alist
       (cons (cons 'dic-mode dic-mode-map) minor-mode-map-alist)
     )
  )
  (setq dic-mode
    (if (null arg) (not dic-mode)
        (> (prefix-numeric-value arg) 0)
    )
  )
)