;;; -*- mode:emacs-lisp -*-
;;; Copyright (c) 1998-2004
;;;   John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen, 
;;;   Benjamin Waldron, Francis Bond; see `LICENSE' for conditions
;;;
;;; lkb_fos/emacs/lkb.el

;;; JAC Nov-2017: for the fully open source LKB with SWANK/SLIME - based heavily
;;; on the version of lkb.el for Franz Inc's Emacs-Lisp Interface (ELI).
;;; Requires GNU Emacs version 23.4 or above; XEmacs is not supported.
;;;
;;; Comments below point out notable differences from the ELI version of lkb.el.


;;; Allow the use of swank:eval-in-emacs from the CL side

(setq slime-enable-evaluate-in-emacs t)


;;; Add an LKB menu to the emacs menu bar

(setq lkb-menu-installed nil)
(make-variable-buffer-local 'lkb-menu-installed)

;;;
;;; interface to common lisp
;;;

(defun eval-in-lisp (sexpr)
  ;; NB this expects the argument to be an evaluable s-expression, not a string as in
  ;; the ELI version
  (slime-eval-with-transcript sexpr))

			 
;;;
;;; menu construction
;;;

(defun install-lkb-menu (map)
  (unless lkb-menu-installed
    (install-lkb-menu-aux map)
    (setf lkb-menu-installed t)))

(defun install-lkb-menu-aux (map)
  (define-key map [menu-bar lkb] (name-keymap "LKB"))
  ;;
  ;; begin level 1
  (define-key map [menu-bar lkb redefine-type]
    (lkb-menu "Redefine type"
	      'redefine-type)) ; JAC - was lkb::redefine-type (incorrect)
  (define-key map [menu-bar lkb break] (name-keymap "---"))
  (define-key map [menu-bar lkb lexicon] (name-keymap "Lexicon"))
  (define-key map [menu-bar lkb generate] (name-keymap "Generate"))
  (define-key map [menu-bar lkb parse] (name-keymap "Parse"))
  (define-key map [menu-bar lkb view] (name-keymap "View"))
  (define-key map [menu-bar lkb load] (name-keymap "Load"))
  ;;
  ;; begin level 2
  ;; (lexicon)
  (define-key map [menu-bar lkb lexicon batch_check]
    (lkb-menu "Batch Check Lexicon"
	      'lkb::batch-check-lexicon))
  (define-key map [menu-bar lkb lexicon load_tdl]
    (lkb-menu "Import TDL Entries to LexDB"
	      'lkb::command-load-tdl-to-scratch))
  ;; (generate)
  (define-key map [menu-bar lkb generate index]
    (lkb-menu "Index"
	      'lkb::index-for-generator))
  (define-key map [menu-bar lkb generate start_generator_server]
    (lkb-menu "Start Generator Server"
	      'lkb::start-generator-server))
;;  (define-key map [menu-bar lkb generate print_chart] ; JAC - commented out (spurious)
;;    (lkb-menu "Print chart input"
;;	      'lkb::print-gen-chart-input))
  (define-key map [menu-bar lkb generate print_chart]
    (lkb-menu "Print chart"
	      'lkb::print-gen-chart))
  (define-key map [menu-bar lkb generate show_chart]
    (lkb-menu "Show chart"
	      'lkb::show-gen-chart))
  (define-key map [menu-bar lkb generate redisplay]
    (lkb-menu "Redisplay realization"
	      'lkb::show-gen-result))
  (define-key map [menu-bar lkb generate from_edge]
    (lkb-menu "Generate..."
	      'lkb::generate-from-edge))
  ;; (parse)
  (define-key map [menu-bar lkb parse batch_parse]
    (lkb-menu "Batch parse..."
	      'clim-user::parse-sentences-batch)) ; JAC - was lkb::... (wrong package)
  (define-key map [menu-bar lkb parse print_chart]
    (lkb-menu "Print chart"
	      'lkb::print-chart))
  (define-key map [menu-bar lkb parse show_chart]
    (lkb-menu "Show chart"
	      'lkb::show-chart))
  (define-key map [menu-bar lkb parse redisplay_parse]
    (lkb-menu "Redisplay parse"
	      'lkb::show-parse))
  (define-key map [menu-bar lkb parse parse_input]
    (lkb-menu "Parse input..."
	      'lkb::do-parse)) ; JAC - was clim-user::do-parse-batch (not defined)
  ;; (view)
  (define-key map [menu-bar lkb view lexical_rule]
    (lkb-menu "Lexical rule..."
	      'lkb::show-lex-rule))
  (define-key map [menu-bar lkb view grammar_rule]
    (lkb-menu "Grammar rule..."
	      'lkb::show-grammar-rule))
  (define-key map [menu-bar lkb view word_entries]
    (lkb-menu "Word entries..."
	      'lkb::show-words))
  (define-key map [menu-bar lkb view lex_entry]
    (lkb-menu "Lex entry..."
	      'lkb::show-lex))
  (define-key map [menu-bar lkb view type_expanded]
    (lkb-menu "Expanded type..."
	      'lkb::show-type))
  (define-key map [menu-bar lkb view type_definition]
    (lkb-menu "Type definition..."
	      'lkb::show-type-spec))
  (define-key map [menu-bar lkb view type_hierarchy]
    (lkb-menu "Type hierarchy..."
	      'lkb::show-type-tree))
  ;; (load)
  (define-key map [menu-bar lkb load reload]
    (lkb-menu "Reload grammar"
	      'lkb::reload-script-file))
  (define-key map [menu-bar lkb load complete]
    (lkb-menu "Complete grammar..."
	      'lkb::read-script-file)))

(defun lkb-menu (name fn) (cons name fn))

(defun name-keymap (str) 
  (cons str (make-sparse-keymap str)))

(add-hook 'slime-repl-mode-hook 
	  (function (lambda ()
		      (install-lkb-menu-aux slime-repl-mode-map))))

(add-hook 'comint-mode-hook 
	  (function (lambda ()
		      (install-lkb-menu-aux comint-mode-map))))

(add-hook 'tdl-mode-hook 
	  (function (lambda ()
		      (install-lkb-menu-aux tdl-mode-map))))


(defun define-lisp-commands (commands)
  (dolist (com commands)
    (eval `(defun ,com ()
	     (interactive)
	     (eval-in-lisp '(cl:progn (,com) nil))))))

(define-lisp-commands 
    '(;; load commands
      lkb::read-script-file 
      lkb::reload-script-file 
      ;; view commands
      lkb::show-type-tree
      lkb::show-type-spec 
      lkb::show-type 
      lkb::show-lex
      lkb::show-words
      lkb::show-grammar-rule 
      lkb::show-lex-rule 
      ;; parse commands
      lkb::do-parse ; JAC - was clim-user::do-parse-batch 
      lkb::show-parse 
      lkb::show-chart 
      lkb::print-chart 
      clim-user::parse-sentences-batch ; JAC - was lkb::parse-sentences-batch
      ;; generate commands
      lkb::generate-from-edge 
      lkb::show-gen-result 
      lkb::show-gen-chart 
      lkb::print-gen-chart
;;      lkb::print-gen-chart-input ; JAC - spurious
      lkb::index-for-generator
      lkb::start-generator-server
      ;; lexicon commands
      lkb::batch-check-lexicon
      lkb::command-load-tdl-to-scratch))


(defun redefine-type (arg)
  (interactive "P")
  (let ((beg 0)
        (end 0)
        (pos (point)))
    (setq beg (calc-begin-of-tdl-expression))
    (goto-char pos)
    (setq end (calc-end-of-tdl-expression))
    (eval-in-lisp
      `(lkb::redefine-type ,(buffer-substring-no-properties beg (min (1+ end) (point-max))))) 
    (goto-char pos)))


(defun find-tdl-definition (thing file)
  (lkb-ensure-buffer-visible (find-file file)) 
  (goto-char 0)
  (re-search-forward (format "\\_<%s\\W+:" (regexp-quote thing))) ; JAC added \\_<
  (goto-char (match-beginning 0)))

(defun lkb-ensure-buffer-visible (buffer)
  (let ((window (get-buffer-window buffer)))
    (when window
      (let ((frame (window-frame window)))
	(when frame (raise-frame frame))))))


;;; To avoid user frustration, replace the standard comint mode binding of C-d to
;;; comint-delchar-or-maybe-eof in order to prevent a simple C-d exiting the LKB
;;; session. To actually send EOF the user can enter C-c C-d. JAC Nov-2017

(add-hook 'comint-mode-hook
  (function (lambda ()
               (define-key comint-mode-map
		  "\C-d" 'delete-char))))


;;;
;;; Some key bindings for those having trouble with encodings
;;; FCB 2003-12-25

(add-hook 'comint-mode-hook
	  (function (lambda ()
		      ;;; add parse key
		      (define-key comint-mode-map
			"\C-cp" 'lkb-do-parse)
		      (define-key comint-mode-map 
			"\C-cl" 'lkb-show-words)
		      (define-key comint-mode-map
			"\C-cL" 'lkb-show-words-expanded)
		      (define-key comint-mode-map
			"\C-cu" 'lkb-tsdb-cpu)
		      (define-key comint-mode-map
			"\C-cr" 'lkb-mt-interactive)
		      (define-key comint-mode-map
			"\C-cg" 'lkb-rsa)
		      (define-key comint-mode-map
			"\C-cG" 'lkb-reload)
		      (define-key comint-mode-map
			"\C-ci" 'lkb-index)
		      (define-key comint-mode-map
			"\C-cI" 'lkb-reload-and-index)
		      )))

(if (not (fboundp 'insert-string)) (fset 'insert-string 'insert))

(defun lkb-do-parse ()
    "prompt for sentence to parse"
  (interactive)
  (goto-char (point-max))
  (insert-string "(lkb::do-parse-tty \"\")")
  (backward-char 2))

(defun lkb-show-words ()
    "prompt for list of words to look up (unexpanded)"
  (interactive)
  (goto-char (point-max))
  (insert-string "(lkb::show-word-aux-tty \"\" nil)")
  (backward-char 6))

(defun lkb-show-words-expanded ()
    "prompt for list of words to look up (expanded)"
  (interactive)
  (goto-char (point-max))
  (insert-string "(lkb::show-word-aux-tty \"\" t)")
  (backward-char 4))

(defun lkb-tsdb-cpu ()
    "prompt for [incr tsdb()] cpu"
  (interactive)
  (goto-char (point-max))
  (insert-string "(tsdb::tsdb :cpu : :file t)")
  (backward-char 9))

(defun lkb-mt-interactive ()
    "prompt for [incr tsdb()] cpu"
  (interactive)
  (goto-char (point-max))
  (insert-string "(mt::parse-interactively \"\")")
  (backward-char 2))

(defun lkb-rsa ()
    "prompt for grammar"
  (interactive)
  (goto-char (point-max))
  (insert-string "(lkb::read-script-file-aux \"~//lkb/script\")")
  (backward-char 13))

(defun lkb-reload ()
    "reload the current grammar and put the command in the ring"
  (interactive)
  (goto-char (point-max))
  (insert-string "(lkb::reload-script-file)") ; JAC - waits for user to press return
  )

(defun lkb-index ()
    "reload the current grammar and put the command in the ring"
  (interactive)
  (goto-char (point-max))
  (insert-string "(lkb::index-for-generator)")
  )

(defun lkb-reload-and-index ()
    "reload the current grammar and put the command in the ring"
  (interactive)
  (goto-char (point-max))
  (insert-string "(progn (lkb::reload-script-file) (lkb::index-for-generator))")
  )



;;; RMRS display utility

(defun display-rmrs (arg)
  (interactive "P")
  (let ((beg 0)
        (end 0)
        (pos (point)))
    (setq beg (calc-begin-of-rmrs-expression))
    (goto-char pos)
    (setq end (calc-end-of-rmrs-expression))
    (eval-in-lisp
      `(lkb::display-rmrs-from-string
         ,(buffer-substring-no-properties beg (min (1+ end) (point-max))))) 
    (goto-char pos)))

(defun calc-begin-of-rmrs-expression ()
  "calculates begin of a rmrs expression in XML"
  (or (re-search-backward "<rmrs " nil t)
               (point-min)))

(defun calc-end-of-rmrs-expression ()
  "calculates end of an rmrs expression"
    (or (re-search-forward "</rmrs>" nil t)
                 (point-max)))

(defun select-rmrs (arg)
  (interactive "P")
  (let ((beg 0)
        (end 0)
        (pos (point)))
    (setq beg (calc-begin-of-rmrs-expression))
    (goto-char pos)
    (setq end (calc-end-of-rmrs-expression))
    (eval-in-lisp
      `(lkb::select-rmrs-from-emacs
         ,(buffer-substring-no-properties beg (min (1+ end) (point-max)))))
    (goto-char pos)))

(defun generate-from-rmrs (arg)
  (interactive "P")
  (let ((beg 0)
        (end 0)
        (pos (point)))
    (setq beg (calc-begin-of-rmrs-expression))
    (goto-char pos)
    (setq end (calc-end-of-rmrs-expression))
    (eval-in-lisp
      `(lkb::generate-rmrs-from-emacs
         ,(buffer-substring-no-properties beg (min (1+ end) (point-max)))))
    (goto-char pos)))

;;; By putting
;;; (add-to-list 'auto-mode-alist '("\\.mrs\\'" . sgml-mode))
;;; (add-to-list 'auto-mode-alist '("\\.rmrs\\'" . sgml-mode))
;;; in the .emacs, SGML mode will be invoked for .(r)mrs extensions

;;; The following makes these commands available via keystrokes
;;; in sgml mode (includes .xml files)

(add-hook 'sgml-mode-hook
	  (function (lambda ()
		      (define-key sgml-mode-map 
			  "\C-cr" 'display-rmrs)
		      (define-key sgml-mode-map 
			  "\C-cs" 'select-rmrs)
		      (define-key sgml-mode-map 
			  "\C-cg" 'generate-from-rmrs)
		      )))

;;; following would make them global but should remain commented
;;; out because of possible overlap with other commands

; (global-set-key "\C-cr" 'display-rmrs)
; (global-set-key "\C-cs" 'select-rmrs)
; (global-set-key "\C-cg" 'generate-from-rmrs)

;;; MRS display utility

(defun display-mrs (arg)
  (interactive "P")
  (let ((beg 0)
        (end 0)
        (pos (point)))
    (setq beg (calc-begin-of-mrs-expression))
    (goto-char pos)
    (setq end (calc-end-of-mrs-expression))
    (eval-in-lisp
      `(lkb::display-mrs-from-string
         ,(buffer-substring-no-properties beg (min (1+ end) (point-max)))))
    (goto-char pos)))

(defun calc-begin-of-mrs-expression ()
  "calculates begin of a mrs expression in XML"
  (or (re-search-backward "<mrs>" nil t)
               (point-min)))

(defun calc-end-of-mrs-expression ()
  "calculates end of an mrs expression"
    (or (re-search-forward "</mrs>" nil t)
                 (point-max)))

; as above


(add-hook 'sgml-mode-hook
	  (function (lambda ()
		      (define-key sgml-mode-map 
			  "\C-cm" 'display-mrs))))

; (global-set-key "\C-cm" 'display-mrs)


;;; DMRS display utility

(defun display-dmrs (arg)
  (interactive "P")
  (let ((beg 0)
        (end 0)
        (pos (point)))
    (setq beg (calc-begin-of-dmrs-expression))
    (goto-char pos)
    (setq end (calc-end-of-dmrs-expression))
    (eval-in-lisp
      `(lkb::display-dmrs-from-string
         ,(buffer-substring-no-properties beg (min (1+ end) (point-max)))))
    (goto-char pos)))

(defun calc-begin-of-dmrs-expression ()
  "calculates begin of a mrs expression in XML"
  (or (re-search-backward "<dmrs" nil t)
               (point-min)))

(defun calc-end-of-dmrs-expression ()
  "calculates end of an dmrs expression"
    (or (re-search-forward "</dmrs>" nil t)
                 (point-max)))

; as above


(add-hook 'sgml-mode-hook
	  (function (lambda ()
		      (define-key sgml-mode-map 
			  "\C-cd" 'display-dmrs))))

; (global-set-key "\C-cd" 'display-dmrs)


;;;
;;; open a file in a new buffer, killing its existing buffer, if necessary
;;;
(defun rogue-find-file (file)
  (if (file-exists-p file)
    (let ((buffer (get-file-buffer file))
          (find-file-hooks nil))
      (if buffer (kill-buffer buffer))
      (find-file file))))