(require 'derived)

;;;  Copyright (c) 2004 Frank C. Sergeant 
;;;  frank@pygmy.utoh.org
;;;  Freely available under a modified BSD/MIT/X license.
;;;  Details at http://pygmy.utoh.org/license20040130.txt.

;;; Known bugs:
;;;  1.
;;;   There appears to be an interaction with auto-save that causes
;;;   auto-save to hang.  So, pygmy-mode turns auto-save off.  If
;;;   anyone can tell me what the problem is, I would appreciate it.

;(set-background-color "LightYellow2")
(set-background-color "white smoke")

;;; Following makes font larger and the green is much easier to read.
;;; Perhaps this should be made buffer local or perhaps set directly
;;; in your .emacs file.
(set-face-font 'default "-*-fixed-medium-r-normal--20-*")

(defvar pygmy-font-lock-keywords nil
  "Highlighting in pygmy-mode is not based on keywords")

;;; Color Forth color tagging
;;; Set your preferred colors here.  The comment shows the classic
;;;  ColorForth color and its tag number.  
;;; The following have been left out for the moment:
;;;    compile cyan  ??
;;;    capitalized white
;;;    all caps  white
;;;    
;;; Apparently hexadecimal literals are supposed to be in a darker
;;;  green than decimal literals.
;;; Note, we cannot use a white background with Chuck's colors.
;;; Try LightYellow2 for an approximation from a web page that looked ok.
(setq
 pygmy-execute-color  "darkgoldenrod"    ; 1 Yellow
 ;pygmy-execute-color  "yellow"    ; 1 Yellow
 pygmy-name-color     "red"              ; 3 Red
 ;pygmy-compile-color  "forestgreen"      ; 4 Green
 pygmy-compile-color  "forestgreen"      ; 4 Green
 pygmy-comment-color  "sienna"           ; 9 White
 ;pygmy-variable-color "purple"           ; c Magenta
 pygmy-variable-color "magenta"           ; c Magenta
)

; Set up the faces/colors for the different ColorForth tags
(make-face 'pygmy-execute-face)
(set-face-foreground 'pygmy-execute-face pygmy-execute-color)

(make-face 'pygmy-name-face)
(set-face-foreground 'pygmy-name-face pygmy-name-color)

(make-face 'pygmy-compile-face)
(set-face-foreground 'pygmy-compile-face pygmy-compile-color)

(make-face 'pygmy-comment-face)
(set-face-foreground 'pygmy-comment-face pygmy-comment-color)

(make-face 'pygmy-variable-face)
(set-face-foreground 'pygmy-variable-face pygmy-variable-color)

(defvar forth-word-regexp "[^[:space:]]+"
  "One or more non-white-space characters.")

(defun next-token ()
  "Answer next Forth word as a string."
  (interactive)
  (re-search-forward forth-word-regexp nil 'end)
  (let ((result
   (prin1-to-string
    (buffer-substring-no-properties (match-beginning 0) (match-end 0)))))
    (message "%s" result)
    result))

(defvar words nil)
(defun collect-words ()
  "Parse buffer into a list of Forth words, comments, strings."
  (interactive) 
  (setq words nil)
  (save-excursion 
      (goto-char (point-min)) 
      (while (not (eobp))
          (setq words (cons (next-token) words)))
      (setq words (reverse words))))

(defun pygmy-setup-hooks ()
    (add-hook 'find-file-hooks 'init-buffer nil t)
    ;; Add next two functions to global hooks.  The functions exit early
    ;; and do nothing if not in pygmy-mode.
    (add-hook 'write-region-annotate-functions 'pygmy-write-annotated-region)
    (add-hook 'after-insert-file-functions 'pygmy-apply-annotations-on-insertion))

(define-derived-mode pygmy-mode text-mode "Pygmy"
  "Major mode for editing Pygmy (ColorForth) \"block\" files.
Special commands:
\\(pygmy-mode-map)"
  (make-local-variable 'outline-regexp)
  (make-local-variable 'comment-start-skip)
  (make-local-variable 'comment-start)
  (make-local-variable 'comment-end)
  (make-local-variable 'comment-multi-line)
  (make-local-variable 'default-text-properties)
  (make-local-variable 'text-property-default-nonsticky)
  (setq    comment-start-skip "( "    comment-start "( "   
           comment-end ") "           comment-multi-line t)
  (pygmy-font-lock)
  (pygmy-modify-syntax-table)
;;   (setq default-text-properties 
;;         '(category compile 
;;           face pygmy-compile-face
;;           rear-nonsticky (category)))
  (setq default-text-properties 
        '(category compile 
          face pygmy-compile-face))
  (setq text-property-default-nonsticky '((category . t)))
  (setq outline-regexp "( ")  ; when using outline mode, show block comment lines
  (pygmy-setup-mode-line)
  (pygmy-setup-hooks)
  (auto-save-mode -1))   ;; turn off auto-save so it will not hang  ;(

(defun pygmy-setup-mode-line ()
  "Setup a local mode-line-format.
Copy the global mode-line-format and then modify it by inserting the 
block number string as the next-to-last element."
  (if (memq 'block-number-string mode-line-format)
      nil
    (let* ((rev (reverse mode-line-format))
           (last (car rev)))
      (make-local-variable 'mode-line-format)
      (setq mode-line-format 
            (reverse 
             (cons last
                   (cons 'block-number-string (cdr rev))))))))

(defun init-buffer ()
  "Do initial conversion of annotations to text properties and narrowing."
  (interactive)
  (widen)
  (goto-char (point-min))
  (pygmy-apply-annotations (buffer-size))
  (pygmy-build-block-structure)
  (goto-physical-block 0)
  (set-buffer-modified-p nil))

(defvar pygmy-block-table nil
  "A vector of block starting positions.
Each element is a marker which is the starting position of the
physical block whose number is this element's index.  Because
extending the file requires creating a new vector, we might
consider using a hash table instead.  For now, it is a vector.
This could be used two ways: 
  1. to find the start of a given block (yes)
  2. to find the block number of a given point (probably not).")

(defun pygmy-build-block-structure ()
  "Build or rebuild 'pygmy-block-table to hold block starting positions."
  (interactive)
  (save-excursion
    (save-restriction
      (widen)
      (goto-char (point-min))
      (setq pygmy-block-table (make-vector 0 0))
      (while 
          (progn
            (setq pygmy-block-table
                  (vconcat 
                   pygmy-block-table
                   (make-vector 1 (point-marker))))
            (re-search-forward page-delimiter nil t)))
      (if (shadowp (last-physical-block))   ; if last block number is odd
          nil                               ;    good
        (goto-char (point-max))             ; otherwise,
        (insert-block-separator)            ;    insert an ending shadow block
        (pygmy-build-block-structure))      ;    and rebuild the table
      )))

(defun last-physical-block ()
 (- (length pygmy-block-table) 1))

(defun last-block ()
  (/ (last-physical-block) 2))

(defun block-to-physical (logical-block-num)
  (* logical-block-num 2))

(defun block-to-logical (physical-block-num)
  (/ physical-block-num 2))

(defun goto-block (source-block-num)
  (interactive "NBlock# ")
  (goto-physical-block 
   (block-to-physical (min source-block-num (last-block)))))

(defun bad-block (num)
  "Answer true if block numbered NUM does not exist."
  (or (< num 0)
      (< (last-physical-block) num)))

(defun starting-position-of-block (num)
  "Answer starting position of the physical block or (point-max)."
  (if (bad-block num)
      (point-max)
    (aref pygmy-block-table num)))

(defun goto-physical-block (num)
  (if (bad-block num)
      (beep)
    (widen)
    (goto-char (starting-position-of-block num))
    (narrow-to-page)
    (block-number-update num)))

(defun sourcep (block-num)
  "Answer whether physical block-num is a source block.
Even-numbered physical blocks are source blocks and odd are shadow blocks."
  (eq (% block-num 2) 0))

(defun shadowp (block-num)
  "Answer whether physical block-num is a shadow block.
Even-numbered physical blocks are source blocks and odd are shadow blocks."
  (not (sourcep block-num)))

(defun alternate-block ()
  "Switch between source block and corresponding shadow block."
  (interactive)
  (if (sourcep block-number)
      (next-physical-block)
    (prev-physical-block)))

(defun next-physical-block ()
  (goto-physical-block (+ block-number 1)))

(defun prev-physical-block ()
  (goto-physical-block (- block-number 1)))

(defun forward-block ()
  (interactive)
  (goto-physical-block (+ block-number 2)))

(defun backward-block ()
  (interactive)
  (goto-physical-block (- block-number 2)))

(defun insert-new-block (count)
  "Insert one or more new logical blocks after the current block.
A logical block consists of a pair of physical blocks: one source and one shadow."
  (interactive "p")
  (if (sourcep block-number)
      (alternate-block))    ; move to shadow
  (let ((blk block-number))
    (widen)
    (goto-char (starting-position-of-block (+ blk 1)))
    (dotimes (i count)
      (insert-block-separator)
      (insert-block-separator))     ; insert two physical blocks for each count
    (pygmy-build-block-structure)   ; recalculate block starting positions
    (next-physical-block))) ; go to the new block

(defun remove-ending-formfeed ()
  "Remove ending formfeed if there is one.  Caller should widen first.
This is used only to trim the hanging \n\f from the new last block when
a block is slid to the bottom of the file."
  (goto-char (point-max))
  (if (string-equal (char-to-string (char-before)) "\f")
      (delete-char -2)))

(defun slide-block-down ()
  "Slide logical block down (both source and shadow) below following block."
  (interactive)
  (if (eq (last-block) (block-to-logical block-number))  ; already on last block?
      (beep)
    (let ((blk block-number))
      (if (shadowp blk)
          (alternate-block))
      (let ((start (goto-char (point-min))))
        (widen)
        (forward-page 2)
        (let ((end (point)))
          (forward-page 2)
          (if (eq (point) (point-max))
              ; if at end of buffer, before inserting add a formfeed
              ;;(insert "\n\f\n")
              (insert-block-separator))
          (insert (delete-and-extract-region start end))))
      (goto-char (point-max))
      (remove-ending-formfeed)
      (pygmy-build-block-structure)
      (goto-physical-block (+ blk 2)))))

(defun insert-block-separator ()
  (insert "\n\f"))

(defun slide-block-up ()
  "Slide logical block up (both source and shadow) above previous block."
  (interactive)
  (if (eq (block-to-logical block-number) 0)  ; already on first block?
      (beep)
    (let ((blk block-number))
      (if (shadowp blk)
          (alternate-block))
      (widen)
      (let ((last (eq (last-block) 
                      (block-to-logical block-number)))
            (start (starting-position-of-block block-number))
            (end (starting-position-of-block (+ block-number 2))))
        (goto-char (starting-position-of-block (- block-number 2)))
        (insert (delete-and-extract-region start end))
        (if last
            (progn
              (insert-block-separator)
              (goto-char (- (point-max) 1))
              (if (looking-at "\f")
                  (delete-char 1)
                (error "File did not end with pagefeed as expected")))))
      (pygmy-build-block-structure)
      (goto-physical-block (- blk 2)))))

(defvar block-number 0
  "Zero-based physical Forth block number.
The even-numbered blocks are source blocks and the odd are shadow blocks.")

(defvar block-number-string "--block-n-typ"
  "Used on mode line to show current block number.
Set by block-number-update from value of block-number.")

(defun block-number-update (&optional physical-block-number)
  "Update block-number-string to with logical block number and type.
There are two actual blocks per logical block number.  The first of
each pair is the source block and the second is the shadow block."
  (if physical-block-number
      (setq block-number physical-block-number))
  (let ((blk (block-to-logical block-number))
        (src (eq (% block-number 2) 0)))
    (setq block-number-string 
          (format "--block-%d-%s" 
                  blk
                  (if src "src" "dow"))))
  (force-mode-line-update))

(define-key pygmy-mode-map "\M-p" 'backward-block)
(define-key pygmy-mode-map "\M-n" 'forward-block)
(define-key pygmy-mode-map [prior] 'backward-block)  ; ie PgUp key
(define-key pygmy-mode-map [next]  'forward-block)   ; ie PgDn key
(define-key pygmy-mode-map "\C-c\C-p" 'pygmy-show-properties-at-point)
(define-key pygmy-mode-map "\C-c\C-e" 'pygmy-erase-text-properties)
(define-key pygmy-mode-map "\C-c\C-n" 'pygmy-set-category-name)
(define-key pygmy-mode-map "\C-c\C-c" 'pygmy-set-category-compile)
(define-key pygmy-mode-map "\C-c\C-v" 'pygmy-set-category-variable)
(define-key pygmy-mode-map "\C-c\C-a" 'alternate-block)
(define-key pygmy-mode-map "\C-c\C-i" 'insert-new-block)
;; for testing, temporarily attach following to C-c C-t
(define-key pygmy-mode-map "\C-c\C-t" 'next-token)
(define-key pygmy-mode-map "\C-c\C-d" 'slide-block-down)
(define-key pygmy-mode-map "\C-c\C-u" 'slide-block-up)
(define-key pygmy-mode-map "\C-c\C-g" 'goto-block)

(defun pygmy-show-properties-at-point ()
  "Display text properties.  For testing."
  (interactive)
  (message "%s" (text-properties-at (point))))

(defun pygmy-erase-text-properties (start end)
  "Clear out all text properties in region.  For testing."
  (interactive "r")
  (set-text-properties start end nil))

(defun pygmy-set-category (value)
  (let ((bounds (bounds-of-thing-at-point 'word)))
    (if bounds
      (put-text-property (car bounds) (cdr bounds) 'category value))))
(defun pygmy-set-category-name ()
  (interactive)
  (pygmy-set-category 'name))
(defun pygmy-set-category-compile ()
  (interactive)
  (pygmy-set-category 'compile))
(defun pygmy-set-category-execute ()
  (interactive)
  (pygmy-set-category 'execute))
(defun pygmy-set-category-variable ()
  (interactive)
  (pygmy-set-category 'variable))
(defun pygmy-set-category-decimal ()
  (interactive)
  (pygmy-set-category 'decimal))
(defun pygmy-set-category-hex ()
  (interactive)
  (pygmy-set-category 'hex))

(put 'name     'face 'pygmy-name-face)
(put 'compile  'face 'pygmy-compile-face)
(put 'execute  'face 'pygmy-execute-face)
(put 'variable 'face 'pygmy-variable-face)
(put 'decimal  'face 'pygmy-decimal-face)
(put 'hex      'face 'pygmy-hex-face)

(setq pygmy-font-lock-keywords
      `(
        ("( .*)" . 'pygmy-comment-face)
        ))

(defun pygmy-font-lock ()
  "Set font lock details for pygmy-mode.
For now, do not use font locking.  Instead, each Forth word
will have its text properties set to indicate its category
and that alone will determine its syntax color."
  (make-local-variable 'font-lock-defaults)
  (setq pygmy-font-lock-keywords nil)
  (setq font-lock-defaults
	'(pygmy-font-lock-keywords
	  t t nil beginning-of-defun))
  (font-lock-mode -1)
  ;(font-lock-mode)
  )

(defun pygmy-modify-syntax-table ()
  (modify-syntax-entry ?\.   "w")
  (modify-syntax-entry ?\@   "w")
  (modify-syntax-entry ?\#   "w")
  (modify-syntax-entry ?\$   "w")
  (modify-syntax-entry ?\%   "w")
  (modify-syntax-entry ?\^   "w")
  (modify-syntax-entry ?\&   "w")
  (modify-syntax-entry ?\*   "w")
  (modify-syntax-entry ?\(   "w")
  (modify-syntax-entry ?\)   "w")
  (modify-syntax-entry ?\+   "w")
  (modify-syntax-entry ?\-   "w")
  (modify-syntax-entry ?\{   "w")
  (modify-syntax-entry ?\}   "w")
  (modify-syntax-entry ?\[   "w")
  (modify-syntax-entry ?\]   "w")
  (modify-syntax-entry ?\=   "w")
  (modify-syntax-entry ?\/   "w")
  (modify-syntax-entry ?\\   "w")
  (modify-syntax-entry ?\'   "w")
  (modify-syntax-entry ?\"   "w")
  (modify-syntax-entry ?\<   "w")
  (modify-syntax-entry ?\>   "w")
  (modify-syntax-entry ?\:   "w")
  (modify-syntax-entry ?\;   "w")
  (modify-syntax-entry ?\,   "w")
  (modify-syntax-entry ?\|   "w")
  (modify-syntax-entry ?\?   "w")
  )

(defun annotation-for-category (symb)
  (progn
    ;(debug)
    (cond
     ((eq symb 'compile)   "%g" )
     ((eq symb 'name)      "%n" )
     ((eq symb 'execute)   "%e" )
     ((eq symb 'variable)  "%v" )
     ((eq symb 'decimal)   "%d" )
     ((eq symb 'hex)       "%h" )
     ((eq symb 'quote)     "%q" )
     (t                    "%u" )
     )))

(defun category-for-annotation (anno)
  "Convert an annotation string such as %n to a symbol such as 'name."
  (progn
    ;(debug)
    (cond
     ((string-equal anno "%n")      'name)
     ((string-equal anno "%e")   'execute)
     ((string-equal anno "%v")  'variable)
     ((string-equal anno "%d")   'decimal)
     ((string-equal anno "%h")       'hex)
     ((string-equal anno "%q")     'quote)
     ((string-equal anno "%g")   'compile)
     (t                          'compile)
     )))

(defun pygmy-write-annotated-region (start end)
  "Return a list of (POSITION . STRING) elements annotating the region.
In each element, POSITION is the beginning position of the text to be
annotated and STRING is the annotation.  The region itself is not modified.
Add this to the global 'write-region-annotate-functions hook.
If not in pygmy-mode then return an empty list.
We do not annotate 'compile, as that is the default.
Well, that is the goal, but it doesn't work at the moment, so we annote 'compile."
  (interactive "r")
  (let ((result '()))
    (if (not (eq major-mode 'pygmy-mode))
        nil
      (save-excursion
        (save-match-data
          (goto-char start)
          (skip-syntax-forward "^w")    ; skip non-word characters
          (while (< (point) end)
            (let ((pos (point)))
              (when (forward-word 1)
                (let ((cat (get-text-property pos 'category)))
                  (when (and cat (not (eq cat 'compile)))
                    (push 
                     (cons pos (annotation-for-category cat))
                     result)))))
            (skip-syntax-forward "^w"))))
      (setq result (reverse result)))
    result))

(defvar annotated-word-regexp "\\(%[nevdhqg]\\)\\([^[:space:]]+\\)"
  "%n or %v etc followed by at least one non-space character.")

(defun pygmy-apply-annotations-on-insertion (length)
  "Convert annotations to text properties starting at point for length.
Answer the new length.  Add this to 'after-insert-file-functions hook.
Do nothing but return original length unless in pygmy-mode."
  (if (not (eq major-mode 'pygmy-mode)) ;; (string-equal mode-name "Pygmy"))
      length
    (pygmy-apply-annotations length)))

(defun pygmy-apply-annotations (length)
  "Convert annotations to text properties starting at point for length.
Answer the new length.  Add this to 'after-insert-file-functions hook."
  (let ((start (point-marker))
        (new-length length))
    (save-excursion
      (while (re-search-forward annotated-word-regexp (+ start new-length) t)
        ;; Look for a percent sign following by either n or v etc followed
        ;;  by one or more non-white-space characters.
        (let ((cat (category-for-annotation (match-string 1))))
          (message "category is %s" cat)
          (replace-match "\\2" t)
          (pygmy-set-category cat)
          (setq new-length (- new-length 2))))
      new-length)))

(provide 'pygmy)