;;; thogai.el --- Stenotyping software -*- lexical-binding: t -*-

;; Stenotyping software for Emacs
;; Copyright (C) 2022 Arun Isaac
;;
;; Author: Arun Isaac <arunisaac@systemreboot.net>
;; Version: 0.1.0
;; Keywords: abbrev, convenience, hardware
;; Homepage: https://git.systemreboot.net/thogai
;; Package-Requires: ((emacs "27.1"))

;; This file is part of thogai.

;; thogai 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 3 of the License, or
;; (at your option) any later version.

;; thogai 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 thogai.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; thogai is stenotyping software.  It interfaces with steno machines
;; using the Gemini protocol, and translates strokes using a steno
;; dictionary in the Plover dictionary format.
;;
;; Usage:
;;
;; Connect to your steno machine using the Gemini protocol with
;;
;; M-x thogai-gemini-connect
;; 
;; Chord away!

;;; Code:

(require 'map)
(require 'pcase)
(require 'seq)
(require 'subr-x)
(require 'term)

(require 'thogai-english-orthography)

(defvar thogai-dictionary-files
  (list "~/.config/plover/main.json"
        "~/.config/plover/commands.json")
  "List of dictionary files in order of increasing precedence.

All files should be in the Plover dictionary format, and are read
and loaded into memory when `thogai-load-dictionaries' is run.

The easiest way to get started is to \"steal\" Plover's
dictionary files.  In fact, the default value of this variable
are the paths where Plover stores its dictionaries.  To get them
there, you need to have run Plover at least once.  You may also
download the dictionaries from the upstream Plover repository at
https://github.com/openstenoproject/plover/blob/master/plover/assets/main.json
and
https://github.com/openstenoproject/plover/blob/master/plover/assets/commands.json")

(defvar thogai-global-map
  nil
  "Additional dictionary entries.

This is an association list specifying additional translations
not present in `thogai-dictionary-files'.  For example,

(setq thogai-global-map
      '((\"PER\" . \"perfect\")
        (\"THO/TKPWAOEU\" . \"thogai\")))")

(defvar thogai-dictionary
  (make-hash-table :test 'equal)
  "Hash table used as the steno dictionary by thogai.

This variable is loaded from files listed in
`thogai-dictionary-files' on running `thogai-load-dictionaries'.")

(defvar thogai-reverse-dictionary
  (make-hash-table :test 'equal)
  "Reverse steno dictionary mapping translations to strokes.

This variable is an exact inverse of the `thogai-dictionary' hash
table.  It is built when files listed in
`thogai-dictionary-files' are loaded using
`thogai-load-dictionaries'.")

(defvar thogai-stroke-ring-size
  1000
  "Size of `thogai-stroke-ring'.

This is the number of past strokes thogai keeps track of.  Among
other things, it affects the number of strokes one can undo back
to.")

(defvar thogai-stroke-ring
  (make-ring thogai-stroke-ring-size)
  "Ring tracking all past strokes.")

(defvar thogai-attach-next
  nil
  "Flag indicating whether to attach the next translation.

If non-nil, the next part of the translation is attached without
a space, and the variable is reset to nil.")

(defvar thogai-glue
  nil
  "Flag indicating whether to glue the next translation.

If non-nil and the next part of the translation also starts with
a glue operator, it is attached without a space, and the variable
is reset to nil.")

(defvar thogai-capitalize-next-word
  nil
  "Flag indicating whether to capitalize the next word.

If non-nil, the first letter of the next word is capitalized and
the variable is reset to nil.")

(defvar thogai-uncapitalize-next-word
  nil
  "Flag indicating whether to uncapitalize the next word.

If non-nil, the first letter of the next word is uncapitalized
and the variable is reset to nil.")

(defun thogai-load-dictionaries ()
  "Load dictionary files in THOGAI-DICTIONARY-FILES."
  (interactive)
  ;; Reset forward and reverse dictionaries.
  (clrhash thogai-dictionary)
  (clrhash thogai-reverse-dictionary)
  (let ((thogai-dictionary-longest-key 0))
    (dolist (dictionary-file thogai-dictionary-files)
      (maphash (lambda (key value)
                 ;; Load keys and values into forward and reverse
                 ;; dictionaries.
                 (puthash key value thogai-dictionary)
                 (puthash value
                          (cons key (gethash value thogai-reverse-dictionary))
                          thogai-reverse-dictionary)
                 ;; Update length of longest key.
                 (setq thogai-dictionary-longest-key
                       (max thogai-dictionary-longest-key
                            (length (split-string key "/")))))
               ;; Parse JSON dictionary file.
               (with-temp-buffer
                 (insert-file-contents dictionary-file)
                 (json-parse-buffer))))
    ;; Enlarge `thogai-stroke-ring' if it is too small.
    (when (< (ring-size thogai-stroke-ring)
             thogai-dictionary-longest-key)
      (ring-resize thogai-stroke-ring thogai-dictionary-longest-key)))
  (message "Loaded %d dictionary entries"
           (hash-table-count thogai-dictionary)))

(defun thogai-mode-map (mode)
  "Return thogai map specific to the MODE.

MODE should be a symbol representing either a major mode or a
minor mode.  The thogai map specific to foo-mode is the value of
the symbol thogai-foo-mode-map.  The return value is an
association list with the same structure as `thogai-global-map'."
  (let ((major-mode-map (intern (concat "thogai-" (symbol-name mode) "-map"))))
    (and (boundp major-mode-map)
         (symbol-value major-mode-map))))

(defun thogai-current-map ()
  "Return the union of all currently active thogai maps.

This includes, from highest precedence to lowest, the thogai maps
of all current minor modes, the thogai map of the current major
mode, and the global thogai map specified in `thogai-global-map'.
The return value is an association list with the same structure
as `thogai-global-map'."
  (append (seq-reduce (lambda (result minor-mode)
                        (append (thogai-mode-map minor-mode)
                                result))
                      local-minor-modes
                      nil)
          (thogai-mode-map major-mode)
          thogai-global-map))

(defun thogai-lookup (stroke)
  "Lookup STROKE in dictionary.

STROKE is looked up in the result of `thogai-current-map' and
`thogai-dictionary' with the result of `thogai-current-map'
having higher precedence.  If STROKE is in neither, nil is
returned."
  (or (map-elt (thogai-current-map) stroke)
      (map-elt thogai-dictionary stroke)))

(defun thogai-filter-map (function sequence)
  "Map FUNCTION over SEQUENCE and return only non-nil results.

Map FUNCTION over SEQUENCE using `seq-map', but return a list of
only the non-nil results."
  (seq-filter 'identity
              (seq-map function sequence)))

(defun thogai-reverse-lookup (translation)
  "Lookup TRANSLATION in reverse dictionary.

A list of all strokes producing TRANSLATION is returned.
TRANSLATION is looked up in the result of `thogai-current-map'
and `thogai-reverse-dictionary'."
  (append
   (thogai-filter-map (pcase-lambda (`(,key . ,value))
                        (and (equal value translation)
                             key))
                      (thogai-current-map))
   (gethash translation thogai-reverse-dictionary)))

(defun thogai-longest-match (state)
  "Return the longest sublist of STATE that maps to a stroke.

STATE is a list of strokes, oldest first.  STATE should typically
be the list of elements in `thogai-stroke-ring', or a subset
thereof."
  (if (thogai-lookup (string-join state "/"))
      state
    (pcase state
      (`(,_ . ,tail)
       (thogai-longest-match tail)))))

(defun thogai-delete (string)
  "Delete STRING before point, if it is present.

If STRING is not present before point, do nothing."
  (let ((start (- (point) (length string)))
        (end (point)))
    (when (and (>= start (point-min))
               (string= (buffer-substring start end)
                        string))
      (delete-region start end))))

(defun thogai-compose (&rest functions)
  "Return a composition of FUNCTIONS.

The last function in FUNCTIONS is applied first."
  (lambda (arg)
    (seq-reduce (lambda (result function)
                  (funcall function result))
                functions
                arg)))

(defun thogai-insert-space ()
  "Insert space at point if necessary.

Insert space at point unless at the beginning of a line or
`thogai-attach-next' is non-nil."
  (unless (or (= (line-beginning-position)
                 (point))
              thogai-attach-next)
    (insert " ")))

(defun thogai-insert-literal (literal-translation)
  "Insert LITERAL-TRANSLATION at point.

Insert LITERAL-TRANSLATION at point, respecting
`thogai-capitalize-next-word' and
`thogai-uncapitalize-next-word'."
  (insert (funcall (thogai-compose
                    ;; Capitalize first letter.
                    (if thogai-capitalize-next-word
                        (lambda (str)
                          (setq thogai-capitalize-next-word nil)
                          (concat (upcase (substring str 0 1))
                                  (substring str 1)))
                      'identity)
                    ;; Uncapitalize first letter.
                    (if thogai-uncapitalize-next-word
                        (lambda (str)
                          (setq thogai-uncapitalize-next-word nil)
                          (concat (downcase (substring str 0 1))
                                  (substring str 1)))
                      'identity))
                   literal-translation))
  ;; Reset `thogai-attach-next' and `thogai-glue'.
  (setq thogai-attach-next nil
        thogai-glue nil))

(defun thogai-insert-orthography-aware-suffix (suffix)
  "Insert orthography aware SUFFIX for current word."
  (let ((word (current-word t)))
    (backward-kill-word 1)
    (insert (or (seq-some (pcase-lambda (`(,pattern . ,replacement))
                            (save-match-data
                              (let ((string (concat word " ^ " suffix)))
                                (and (string-match pattern string)
                                     (replace-match replacement nil nil string)))))
                          thogai-english-orthography-rules)
                ;; We deleted a negative lookbehind assertion from
                ;; Plover's English orthography rules since elisp does
                ;; not support that in regular expressions. Implement
                ;; it here without regular expressions.
                ;;
                ;; The following examples illustrate this rule:
                ;; oligarch + s = oligarchs
                ;; patriarch + s = patriarchs
                ;; monarch + s = monarchs
                ;; birch + s = birches
                (and (string= suffix "s")
                     (string-suffix-p "rch" word)
                     (not (string-suffix-p "garch" word))
                     (not (string-suffix-p "iarch" word))
                     (not (string-suffix-p "narch" word))
                     (concat word "es"))
                ;; As a last resort, simply append the suffix.
                (concat word suffix)))))

(defun thogai-insert-translation (translation &optional non-first-part-p)
  "Insert TRANSLATION at point.

TRANSLATION is a string mapped to in a steno dictionary.

If NON-FIRST-PART-P is non-nil, no literal parts of TRANSLATION
have been processed yet.  This is an internal recursion variable.
External callers should always pass nil as the value."
  (pcase (save-match-data
           (string-match (rx string-start (or (one-or-more (not ?{))
                                              (sequence ?{ (zero-or-more (not ?{)) ?})))
                         translation)
           (list (match-string 0 translation)
                 (substring translation (match-end 0))))
    (`(,translation ,rest-of-translation)
     (pcase translation
       ;; Attach operator
       ("{^}"
        (setq thogai-attach-next t))
       ;; Infix
       ((pred (lambda (str)
                (and (string-prefix-p "{^" str)
                     (string-suffix-p "^}" str))))
        (thogai-insert-translation
         (concat "{^}{" (string-remove-prefix "{^" translation))
         non-first-part-p))
       ;; Prefix
       ((pred (lambda (str)
                (string-suffix-p "^}" str)))
        (thogai-insert-translation
         (concat
          (let ((unwrapped (string-remove-prefix "{" (string-remove-suffix "^}" translation))))
            ;; If `translation' is a capitalization carry prefix, wrap
            ;; it up again.
            (if (string-prefix-p "~|" unwrapped)
                (concat "{" unwrapped "}")
              unwrapped))
          "{^}")
         non-first-part-p))
       ;; Carry capitalization.
       ((pred (lambda (str)
                (string-prefix-p "{~|" str)))
        (let ((capitalization-state thogai-capitalize-next-word))
          (let ((thogai-capitalize-next-word nil))
            (thogai-insert-translation
             (string-remove-prefix "{~|" (string-remove-suffix "}" translation))
             non-first-part-p))
          (setq thogai-capitalize-next-word capitalization-state)))
       ;; Suffix and carry capitalization.
       ((pred (lambda (str)
                (string-prefix-p "{^~|" str)))
        (thogai-insert-translation
         (concat "{^}{" (string-remove-prefix "{^" translation))))
       ;; Orthography aware suffix
       ((pred (lambda (str)
                (string-prefix-p "{^" str)))
        (thogai-insert-orthography-aware-suffix
         (string-remove-prefix "{^" (string-remove-suffix "}" translation))))
       ;; Glue operator
       ((pred (lambda (str)
                (string-prefix-p "{&" str)))
        (thogai-insert-translation
         (concat (if thogai-glue "{^}" "")
                 (string-remove-prefix "{&" (string-remove-suffix "}" translation)))
         non-first-part-p)
        (setq thogai-glue t))
       ;; Cancel formatting.
       ("{}"
        (setq thogai-attach-next nil
              thogai-capitalize-next-word nil
              thogai-glue nil
              thogai-uncapitalize-next-word nil))
       ;; Period, comma, colon, question mark or exclamation mark
       ((or "{.}" "{,}" "{:}" "{?}" "{!}")
        (insert (string-remove-prefix "{" (string-remove-suffix "}" translation)))
        (insert " ")
        (setq thogai-capitalize-next-word t))
       ;; Capitalize next word.
       ("{-|}"
        (setq thogai-capitalize-next-word t))
       ;; Capitalize previous word.
       ("{*-|}"
        (save-excursion
          (left-word)
          (upcase-region (point) (1+ (point)))))
       ;; Uncapitalize next word.
       ("{>}"
        (setq thogai-uncapitalize-next-word t))
       ;; Uncapitalize previous word.
       ("{*>}"
        (save-excursion
          (left-word)
          (downcase-region (point) (1+ (point)))))
       ;; Retroactively delete space.
       ("{*!}"
        (save-excursion
          (left-word)
          (delete-char -1)))
       ;; Key
       ((pred (lambda (translation)
                (member (downcase translation)
                        (list "{#left}" "{#right}" "{#up}" "{#down}"
                              "{#backspace}" "{#delete}" "{#return}"
                              "{#space}" "{#tab}"))))
        (call-interactively
         (key-binding
          (kbd (pcase (downcase
                       (string-remove-prefix
                        "{#" (string-remove-suffix "}" translation)))
                 ("backspace" "DEL")
                 ("delete" "<deletechar>")
                 ("return" "RET")
                 ("space" "SPC")
                 ("tab" "TAB")
                 (key-name (concat "<" key-name ">")))))))
       ;; Simple literal translation
       (_
        (unless non-first-part-p
          (thogai-insert-space))
        (thogai-insert-literal translation)))
     ;; Recurse for rest of translation.
     (unless (string= rest-of-translation "")
       (thogai-insert-translation
        rest-of-translation
        ;; Carry through non-first-part-p on pure command translation
        ;; parts that do not insert anything.
        (if (member translation (list "{^}" "{-|}" "{*-|}" "{>}" "{*>}" "{*!}"))
            non-first-part-p
          t))))))

(defun thogai-reverse-strokes (strokes)
  "Reverse the effects of STROKES.

STROKES is a list of strokes, oldest first.  `thogai-stroke-ring'
is unaltered."
  (thogai-delete
   (with-temp-buffer
     (thogai-inject-strokes strokes (make-ring (length strokes)))
     (buffer-string)))
  ;; Delete space before strokes unless we are at the beginning of the
  ;; line. Note that attached and glued strokes do not emit
  ;; spaces. So, we cannot mindlessly delete a character without
  ;; checking if it is a space.
  (unless (= (line-beginning-position)
             (point))
    (thogai-delete " ")))

(defun thogai-inject-strokes (strokes &optional stroke-ring)
  "Inject STROKES into STROKE-RING.

Inject STROKES, a list of strokes, into STROKE-RING as though
they were really stroked on the steno machine.  If unspecified,
STROKE-RING is `thogai-stroke-ring'.  The first element of
STROKES is injected first."
  (let ((stroke-ring (or stroke-ring
                         thogai-stroke-ring)))
    ;; Inject strokes one by one.
    (dolist (stroke strokes)
      (ring-insert stroke-ring stroke)
      (thogai-process-stroke stroke-ring))))

(defun thogai-suggest ()
  "Suggest strokes for current word.

Suggest strokes for current word in the *thogai-suggestions*
buffer.  Suggestions are sorted shortest first."
  ;; TODO: Don't cheat by picking up the current word. The current
  ;; word may be a multi-word phrase.
  (let ((word (current-word))
        (suggestions-buffer (get-buffer-create "*thogai-suggestions*")))
    (when word
      (with-current-buffer suggestions-buffer
        ;; Explicitly go to end of buffer, just in case someone messed
        ;; up the point.
        (goto-char (point-max))
        (insert word)
        (insert "\n")
        ;; TODO: Suggest orthography-aware suffixes. For example,
        ;; suggest "SUFBGS/-S" for the word "suffixes", even though
        ;; "SUFBGS/-S" does not occur in the dictionary.
        (dolist (stroke (sort (thogai-reverse-lookup word)
                              (lambda (strokes1 strokes2)
                                ;; Sort by number of strokes, falling back
                                ;; to string length.
                                (let ((count1 (length (split-string strokes1 "/")))
                                      (count2 (length (split-string strokes2 "/"))))
                                  (if (= count1 count2)
                                      (< (length strokes1)
                                         (length strokes2))
                                    (< count1 count2))))))
          (insert (concat "\t" stroke "\n")))
        (insert "\n")
        ;; Scroll to the end of windows showing the suggestions
        ;; buffer.
        (dolist (window (get-buffer-window-list suggestions-buffer nil t))
          (set-window-point window (point-max)))))))

(defun thogai-process-stroke (stroke-ring)
  "Process the most recent stroke.

Process the most recent stroke, and insert its translation or
execute a command.  STROKE-RING is the ring representing the
current state, and should typically be `thogai-stroke-ring'."
  (undo-boundary)
  (if (string= (ring-ref stroke-ring 0) "*")
      ;; Special case to handle the undo operation
      (progn
        (undo-only)
        ;; Drop the "*" stroke and the stroke that was just undone.
        (dotimes (_ 2)
          (unless (zerop (ring-length stroke-ring))
            (ring-remove stroke-ring 0))))
    (let ((matched-strokes
           (thogai-longest-match (reverse (ring-elements stroke-ring)))))
      ;; Delete translation for earlier strokes that are captured by
      ;; this translation. If no strokes were matched, skip this step.
      (unless (null matched-strokes)
        (thogai-reverse-strokes (butlast matched-strokes)))
      ;; Insert literal stroke if it is not in the dictionary.
      (if (null matched-strokes)
          (thogai-insert-translation (ring-ref stroke-ring 0))
        ;; Else, insert or run the translation.
        (let ((translation (thogai-lookup (string-join matched-strokes "/"))))
          (cond
           ((stringp translation)
            (thogai-insert-translation translation)
            (thogai-suggest))
           ((commandp translation)
            (call-interactively translation))))))))

(defun thogai-byte-to-bits (byte)
  "Convert BYTE to a list of 8 bits.

Each element of the returned list is a boolean, and the first
element is the most significant bit."
  (seq-map (lambda (i)
             (not (zerop (logand byte (lsh 1 i)))))
           (number-sequence 7 0 -1)))

(defun thogai-filter-mapn (function &rest sequences)
  "Map FUNCTION over SEQUENCES and return only non-nil results.

Map FUNCTION over all SEQUENCES using `seq-mapn', but return a
list of only the non-nil results."
  (seq-filter 'identity
              (apply 'seq-mapn function sequences)))

(defun thogai-mapcatn (function &rest sequences)
  "Map FUNCTION over SEQUENCES and concatenate the results.

Map FUNCTION over all SEQUENCES using `seq-mapn', and concatenate
the results into a list."
  (apply 'seq-concatenate 'list
         (apply 'seq-mapn function sequences)))

;; See
;; https://github.com/openstenoproject/plover/blob/master/plover/machine/geminipr.py
;; for protocol documentation.
(defun thogai-gemini-decode-stroke (bytes)
  "Decode stroke represented by BYTES from the Gemini protocol.

BYTES is a list of 6 bytes in the Gemini protocol."
  (let* ((keys '(("Fn" "#1" "#2" "#3" "#4" "#5" "#6")
                 ("S1-" "S2-" "T-" "K-" "P-" "W-" "H-")
                 ("R-" "A-" "O-" "*1" "*2" "res1" "res2")
                 ("pwr" "*3" "*4" "-E" "-U" "-F" "-R")
                 ("-P" "-B" "-L" "-G" "-T" "-S" "-D")
                 ("#7" "#8" "#9" "#A" "#B" "#C" "-Z")))
         (pressed-keys
          (thogai-mapcatn (lambda (byte keys)
                            (thogai-filter-mapn (lambda (selectp key)
                                                  (and selectp key))
                                                (seq-drop (thogai-byte-to-bits byte)
                                                          1)
                                                keys))
                          bytes
                          keys)))
    ;; NOTE: We recognize only a subset of keys supported by the
    ;; Gemini protocol. For example, we recognize only a single S, not
    ;; S1 and S2.
    (let ((left (seq-mapcat (lambda (key)
                              (string-trim-right key (rx (one-or-more (or ?1 ?2 ?-)))))
                            (seq-filter (lambda (key)
                                          (or (string= key "#1")
                                              (and (not (member key (list "A-" "O-")))
                                                   (string-suffix-p "-" key))))
                                        pressed-keys)
                            'string))
          (vowel-or-star (seq-mapcat (lambda (key)
                                       (string-trim key "-" (rx (or ?- ?1))))
                                     (seq-filter (lambda (key)
                                                   (member key (list "A-" "O-" "*1" "-E" "-U")))
                                                 pressed-keys)
                                     'string))
          (right (seq-mapcat (lambda (key)
                               (string-remove-prefix "-" key))
                             (seq-filter (lambda (key)
                                           (and (not (member key (list "-E" "-U")))
                                                (string-prefix-p "-" key)))
                                         pressed-keys)
                             'string)))
      (concat left
              vowel-or-star
              ;; Add hyphen if there is no vowel but there are
              ;; right-side keys.
              (if (and (string= vowel-or-star "")
                       (not (string= right "")))
                  "-"
                "")
              right))))

(let ((bytes nil))
  (defun thogai-gemini-protocol-filter (process output)
    "Process filter for the Gemini serial protocol."
    (let ((bytes-per-stroke 6))
      (dolist (byte (string-to-list output))
        (push byte bytes)
        ;; The Gemini protocol represents each stroke by 6
        ;; bytes. Decode stroke once 6 bytes are received.
        (when (= (length bytes) bytes-per-stroke)
          ;; Stroke processing could result in errors, typically from
          ;; user commands bound to strokes. Hence, unwind-protect.
          (unwind-protect
              (let ((stroke (thogai-gemini-decode-stroke (reverse bytes))))
                ;; Log to paper tape.
                (with-current-buffer (process-buffer process)
                  ;; Explicitly go to end of buffer, just in case
                  ;; someone messed up the point.
                  (goto-char (point-max))
                  (insert stroke)
                  (insert "\n")
                  ;; Scroll to the end of windows showing the paper
                  ;; tape buffer.
                  (dolist (window (get-buffer-window-list (process-buffer process) nil t))
                    (set-window-point window (point-max))))
                ;; Insert into stroke ring, and process translation.
                (ring-insert thogai-stroke-ring stroke)
                (thogai-process-stroke thogai-stroke-ring))
            (setq bytes nil)))))))

(defun thogai-gemini-connect (port speed)
  "Connect to steno machine via the Gemini protocol.

PORT is the path or name of the serial port.  SPEED is the speed
of the port in bits per second, and is often known as the baud
rate."
  (interactive (list (serial-read-name)
                     (serial-read-speed)))
  (make-serial-process :port port
                       :buffer "*thogai-paper-tape*"
                       :speed speed
                       :filter 'thogai-gemini-protocol-filter)
  (message "Connected to steno machine at %s via the Gemini protocol"
           port))

(provide 'thogai)

;;; thogai.el ends here