(require 'cl)


(defvar ec-mode-map 
  (let ((map (make-sparse-keymap)))
    (define-key map "\M-o" 'ec-interp-pass)
    map)
  "Keymap used in `ec-mode' buffers.")

(defvar ec-mode-hook '()
  "Hooks to run upon turning on ec-mode.")

(defun ec-mode ()
  "Major mode for viewing/editing Emacscard files.

\\{ec-mode-map}
Turning on ec-mode runs the hook `ec-mode-hook'."
  (interactive)
  (kill-all-local-variables)
  (use-local-map ec-mode-map)
  (setq major-mode 'ec-mode
        mode-name  "Emacscard")
  (run-hooks 'ec-mode-hook))


;; The main interpreter

(defun ec-interp-pass (p)
  (interactive "p")
  (dotimes (i p)
    (save-excursion
      (goto-char (point-min))
      (ec-reset-variables)
      (ec-advancing))))

(defun ec-advancing ()
  (while (not (eobp))
    (when (looking-at "^ ")
      (catch 'complaint
	(ec-do-command)))
    (forward-line)))

(defun ec-do-command ()
  (let ((keyword (ec-next-symbol)))
    (case keyword
      (button (ec-do-button))
      (def (ec-do-def))
      (do (ec-do-do))
      (let (ec-do-let))
      (marker (ec-do-marker))
      (when (ec-do-when))
      (t (ec-complain "Unknown command")))))

(defun ec-complain (complaint)
  (message complaint)
;  (debug)
  (ec-copy-string (ec-find-target) (concat "Error: " complaint))
  (throw 'complaint nil))


;; Definitions and markers

(defun ec-do-def ()
  (ec-clear-target)
  (let ((var (ec-next-symbol)))
    (ec-bind var (ec-rest-of-line-slot))))

(defun ec-rest-of-line-slot ()
  (ec-make-slot (point) (line-end-position)))

(defun ec-do-marker ()
  (let ((var (ec-next-symbol)))
    (let ((marked 
	   (save-excursion (forward-line) (point))))
      (ec-bind var (ec-make-slot marked marked)))))


;; Conditionals

(defun ec-do-when ()
  (let ((test (ec-next-atom)))
    (when (ec-true-p test)
      (ec-do-command))))

(defun ec-true-p (slot)
  (not (equal "" (ec-slot-to-string slot))))


;; Expressions

(defun ec-do-let ()
  (let ((target (ec-find-target))
	(var (ec-next-symbol)))
    (ec-do-expr target)
    (ec-bind var target)))

(defun ec-do-expr (target)
  (let ((primitive (ec-next-symbol)))
    (case primitive
      (compare 
       (let ((text1 (ec-next-atom)))
	 (let ((text2 (ec-next-atom)))
	   (ec-compare target text1 text2))))
      (concat
       (ec-copy-string target "")
       (ec-concat target (ec-rest-atoms)))
      (copy
       (let ((text (ec-next-atom)))
	 (ec-copy-slot target text)))
      (count
       (let ((char (ec-next-atom)))
	 (let ((text (ec-next-atom)))
	   (ec-copy-number target (ec-count char text)))))
      (divide
       (let ((n1 (ec-next-atom)))
	 (let ((n2 (ec-next-atom)))
	   (ec-copy-number target 
			   (ec-divide (ec-slot-to-number n1)
				      (ec-slot-to-number n2))))))
      (first-word
       (let ((text (ec-next-atom)))
	 (ec-copy-slot target (ec-first-word text))))
      (length
       (let ((text (ec-next-atom)))
	 (ec-copy-number target (ec-slot-length text))))
      (notless
       (let ((n1 (ec-next-atom)))
	 (let ((n2 (ec-next-atom)))
	   (ec-copy-flag target 
			 (>= (ec-slot-to-number n1) (ec-slot-to-number n2))))))
      (random-element
       (let ((text (ec-next-atom)))
	 (ec-copy-slot target (ec-random-element text))))
      (random-index
       (let ((text (ec-next-atom)))
	 (ec-copy-number target (ec-random-index text))))
      (random-line
       (let ((text (ec-next-atom)))
	 (ec-copy-slot target (ec-random-line-slot text))))
      (rest-words
       (let ((text (ec-next-atom)))
	 (ec-copy-slot target (ec-rest-words text))))
      (t (ec-complain "Unknown function")))))

(defun ec-compare (target slot1 slot2)
  (save-excursion
    (goto-char (ec-slot-start target))
    (dotimes (i (min (ec-slot-length slot1) (ec-slot-length slot2)))
      (insert
       (string (ec-compare-chars (ec-slot-ref slot1 i)
				 (ec-slot-ref slot2 i)))))))

(defun ec-compare-chars (c1 c2)
  (cond ((< c1 c2) ?<)
	((= c1 c2) ?=)
	(t         ?>)))

(defun ec-count (slot1 slot)
  (let ((c (ec-slot-ref slot1 0))
	(n 0))
    (dotimes (i (ec-slot-length slot))
      (when (= c (ec-slot-ref slot i))
	(setq n (+ n 1))))
    n))

(defun ec-divide (n1 n2)
  (if (= n2 0)
      (ec-complain "Division by 0")
      (let ((q (/ n1 n2)))
	(if (= n1 (* q n2))
	    q
	    (/ (float n1) n2)))))

(defun ec-slot-ref (slot index)
  (char-after (ec-index-slot slot index)))

(defun ec-random-element (slot)
  (ec-char-at (ec-index-slot slot (ec-random-index slot))))

(defun ec-random-index (slot)
  (random (ec-slot-length slot)))

(defun ec-char-at (position)
  (ec-make-slot position (+ position 1)))

(defun ec-find-target ()
  (save-excursion
    ; FIXME: search should be syntax-sensitive (skipping literal strings)
    (cond ((search-forward "#" (line-end-position) t)
	   (ec-delete-to-end-of-line)
	   (ec-make-slot (point) (point)))
	  (t
	   (end-of-line)
	   (insert "\t#")
	   (ec-make-slot (point) (point))))))

(defun ec-clear-target ()
  (save-excursion
    ; FIXME: search should be syntax-sensitive (skipping literal strings)
    ; FIXME: I wanted the tab to be optional in the regex below, but
    ; for some reason "\t?#" doesn't match anything.
    (cond ((search-forward "\t#" (line-end-position) t)
	   (goto-char (match-beginning 0))
	   (ec-delete-to-end-of-line)))))

(defun ec-delete-to-end-of-line ()
  (delete-char (- (line-end-position) (point))))


;; Side-effect commands

(defun ec-do-do ()
  (ec-clear-target)
  (let ((primitive (ec-next-symbol)))
    (case primitive
      (fill-paragraph
       (let ((target (ec-next-atom)))
	 (ec-restrict target '(lambda () (fill-paragraph nil)))))
      (insert
       (let ((target (ec-next-atom)))
	 (let ((source (ec-next-atom)))
	   (ec-concat target (list source)))))
      (replace
       (let ((target (ec-next-atom)))
	 (let ((source (ec-next-atom)))
	   (ec-copy-slot target source))))
      (text-set 
       (let ((text (ec-next-atom)))
	 (let ((index (ec-next-atom)))
	   (let ((char (ec-next-atom)))
	     (ec-text-set text (ec-slot-to-number index) char)))))
      (t (ec-complain "Unknown function")))))

(defun ec-restrict (slot action)
  (save-excursion
    (save-restriction
      (narrow-to-region (ec-slot-start slot) (ec-slot-end slot))
      (goto-char (point-min))
      (funcall action))))

(defun ec-text-set (target index source)
  (ec-buffer-replace (ec-index-slot target index)
		     1
		     (substring (ec-slot-to-string source) 0 1)))


;; Atomic expressions

(defun ec-next-atom ()
  (ec-skip-blanks)
  (cond ((looking-at "[0-9]+")		  ; Integer literal
	 (ec-match-to-slot 0))
	((looking-at "[a-z0-9-]+")	  ; Variable
	 (goto-char (match-end 0))
	 (ec-look-up (intern (ec-matched-substring 0))))
	((looking-at "\"\\([^\"]*\\)\"")  ; String literal
	 (ec-match-to-slot 1))
	(t (ec-complain "Bad atom"))))
	
(defun ec-match-to-slot (n)
  (goto-char (match-end 0)) 
  (ec-make-slot (match-beginning n) (match-end n)))

(defun ec-rest-atoms ()
  (let ((slots '()))
    (while (or (looking-at " *[0-9]+")
	       (looking-at " *[a-z0-9-]+")
	       (looking-at " *\"\\([^\"]*\\)\""))
      (setq slots (cons (ec-next-atom) slots)))
    (nreverse slots)))


;; Lexical scanner

(defun ec-next-symbol ()
  (ec-skip-blanks)
  (cond ((looking-at "[a-z][a-z0-9-]*")
	 (let ((token (ec-matched-substring 0)))
	   (goto-char (match-end 0))
	   (when (looking-at " ")
	     (forward-char))
	   (intern token)))
	(t (ec-complain "Not a keyword or variable"))))

(defun ec-skip-blanks ()
  (skip-chars-forward " "))


;; Variable bindings

(defvar ec-bindings '())

(defun ec-bind (var slot)
  (setq ec-bindings (acons var slot ec-bindings)))

(defun ec-look-up (var)
  (or (cdr (assq var ec-bindings))
      (ec-complain "Unbound variable")))

(defun ec-reset-variables ()
  "Drop all the markers from ec-bindings."
  (dolist (binding ec-bindings)
    (ec-drop-slot (cdr binding)))
  (setq ec-bindings '()))


;; Slots

(defun ec-make-slot (lo hi)
  ; TODO: ensure that the range exists
  (list (copy-marker lo nil) (copy-marker hi t)))

(defun ec-slot-start (slot)
  (car slot))

(defun ec-slot-end (slot)
  (cadr slot))

(defun ec-drop-slot (slot)
  "Null out the slot's markers, for efficiency when it's no longer used."
  (set-marker (ec-slot-start slot) nil)
  (set-marker (ec-slot-end slot) nil))

(defun ec-slot-length (slot)
  (- (ec-slot-end slot) (ec-slot-start slot)))

(defun ec-index-slot (slot index)
  (+ (ec-slot-start slot) index))

(defun ec-copy-string (slot string)
  (ec-buffer-replace (ec-slot-start slot) (ec-slot-length slot) string))

(defun ec-copy-slot (target source)
  (ec-copy-string target
		  (buffer-substring (ec-slot-start source)
				    (ec-slot-end source))))

(defun ec-copy-number (slot number)
  (ec-copy-string slot (number-to-string number)))

(defun ec-copy-flag (slot boolean)
  (ec-copy-string slot (if boolean "true" "")))

(defun ec-slot-to-string (slot)
  (buffer-substring-no-properties (ec-slot-start slot) (ec-slot-end slot)))

(defun ec-slot-to-number (slot)
  ; FIXME: handle errors.
  ; Is there a way to catch them?  Or do we have to match a regexp first?
  (string-to-number (ec-slot-to-string slot)))

(defun ec-concat (target slots)
  (save-excursion
    (goto-char (ec-slot-start target))
    (dolist (slot slots)
      (insert (ec-slot-to-string slot)))))


;; Misc

(defun ec-matched-substring (n)
  (buffer-substring-no-properties (match-beginning n) (match-end n)))

(defun ec-buffer-replace (position length string)
  (save-excursion
    (goto-char position)		;FIXME: bounds-check?
    (delete-char length)
    (insert string)))

(defun ec-random-line-slot (slot)
  (let ((start (ec-random-line (ec-slot-start slot))))
    (let ((end (save-excursion
		 (goto-char start)
		 (end-of-line)
		 (point))))
      (ec-make-slot start end))))

(defun ec-random-line (start)
  (ec-find-line start (random (ec-line-count start))))

(defun ec-find-line (start index)
  (save-excursion
    (goto-char start)
    (forward-line index)
    (point)))

(defun ec-line-count (start)
  (let ((count 0))
    (save-excursion
      (goto-char start)
      (while (not (looking-at "^$"))
	(forward-line)
	(incf count))
      count)))

(defun ec-first-word (slot)
  (let ((w (ec-split-words slot)))
    (ec-make-slot (ec-slot-start slot) w)))

(defun ec-rest-words (slot)
  (let ((w (ec-split-words slot)))
    (ec-make-slot w (ec-slot-end slot))))

(defun ec-split-words (slot)
  (save-excursion
    (goto-char (ec-slot-start slot))
    (forward-word 1)
    (point)))


;; Wrap-up

(setq auto-mode-alist
      (append '(("\\.ec$" . ec-mode))
              auto-mode-alist))

(provide 'ec-mode)