;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)

(defvar meta-state nil)
(make-variable-buffer-local 'meta-state)

(defun meta-highlight (&optional beg end)
  (interactive)
  (if mark-active
    (setq beg (min (point) (mark)) end (max (point) (mark)))
    (setq beg (point-min) end (point-max)))
  (unless (and meta-state (eq buffer-undo-list (car meta-state)))
    (let ((modified (buffer-modified-p)) (buffer-undo-list t)
          (inhibit-read-only t) (inhibit-point-motion-hooks t)
          before-change-functions after-change-functions
          deactivate-mark buffer-file-name buffer-file-truename
          face meta meta-face next (faces '())
          (colors
           (if (equal (face-background 'default) "black")
             '("blue1" "blue2" "blue3" "blue4"
               "black"
               "red4" "red3" "red2" "red1")
             '("#4040FF" "#8080FF" "#C0C0FF" "#E0E0FF"
               "white"
               "#FFE0E0" "#FFC0C0" "#FF8080" "#FF4040"))))
      (save-excursion
        (dolist (ov (cdr meta-state)) (delete-overlay ov))
        (setq meta-state nil)
        ;; not needed if activated by font-lock functions (below)
        ;; (font-lock-fontify-buffer)
        ;; put meta properties
        (put-text-property beg end 'meta 0)
        (goto-char beg)
        (while (re-search-forward "[`,]" end t)
          (unless (memq (get-text-property (point) 'face)
                        '(font-lock-string-face font-lock-comment-face))
            (no-errors
             (alter-text-property
              (match-beginning 0) (save-excursion (forward-sexp) (point)) 'meta
              (if (equal (match-string-no-properties 0) "`") '1- '1+)))))
        ;; paint the properties
        (goto-char beg)
        (while (< (point) end)
          (setq face (get-text-property (point) 'face)
                meta (get-text-property (point) 'meta)
                meta-face (intern (format "%s---%s" face meta))
                next (min
                      (or (text-property-not-all (point) end 'face face) end)
                      (or (text-property-not-all (point) end 'meta meta) end)
                      end))
          (unless (memq meta-face faces)
            (let ((meta-bg
                   (nth (min (max (+ meta (/ (1- (length colors)) 2)) 0)
                             (1- (length colors)))
                        colors)))
              (copy-face (or face 'default) meta-face)
              (set-face-background meta-face meta-bg)
              (setq faces (cons meta-face faces))))
          (let ((ov (make-overlay (point) next)))
            (overlay-put ov 'face meta-face)
            (overlay-put ov 'priority 11110)
            (push ov meta-state))
          (goto-char next))
        (when (and (not modified) (buffer-modified-p))
          (set-buffer-modified-p nil)))
      (push buffer-undo-list meta-state))))

(defun meta-highlight-region (beg end &optional verbose)
  (prog1 (font-lock-default-fontify-region beg end verbose)
    (meta-highlight beg end)))
(defun meta-highlight-buffer ()
  (prog1 (font-lock-default-fontify-buffer)
    (meta-highlight (point-min) (point-max))))
(defun meta ()
  (interactive)
  (make-local-variable 'font-lock-fontify-region-function)
  (setq font-lock-fontify-region-function 'meta-highlight-region)
  (make-local-variable 'font-lock-fontify-buffer-function)
  (setq font-lock-fontify-buffer-function 'meta-highlight-buffer)
  (font-lock-fontify-buffer))

;; Old junk

'(defun meta-highlight (&optional no-kill)
  (interactive "P")
  (let ((code (current-buffer))
        (wstart (window-start))
        (pos (point))
        (buf (get-buffer-create (concat "Meta: " (buffer-name)))))
    (save-excursion
      (save-window-excursion
        ;;(font-lock-fontify-buffer)
        (switch-to-buffer buf)
        (erase-buffer)
        (insert-buffer code)
        (set-syntax-table scheme-mode-syntax-table)
        (paint-meta-properties)
        (set-buffer-modified-p (buffer-modified-p code))
        (set-window-start (selected-window) wstart)
        (goto-char pos)
        (sit-for (if no-kill 0 3600))
        (if no-kill
          buf
          (kill-buffer buf))))
    (if no-kill (switch-to-buffer buf))))

'(defun meta-print ()
  (interactive)
  (let ((foreground (frame-parameter nil 'foreground-color))
        (background (frame-parameter nil 'background-color))
        (def-fg     (face-foreground 'default))
        (def-bg     (face-background 'default)))
    (unwind-protect
        (progn (set-foreground-color "black")
               (set-background-color "white")
               (set-face-foreground 'default "black")
               (set-face-background 'default "white")
               (meta-highlight t)
               (ps-spool-buffer-with-faces)
               (kill-buffer (current-buffer)))
      (set-foreground-color foreground)
      (set-background-color background)
      (set-face-foreground 'default def-fg)
      (set-face-background 'default def-bg))))