;; major mode for trl-files
;; A. Kipp 11.02
;; S.Burger 11.03 english version
;; turnID, dlgID

(defvar ger-list '("#Knock"
                   "#Rustle"
                   "#Squeak"
                   "#"
                   "Throat"
                   "Smack"
                   "Swallow"
                   "Cough"
                   "Laugh"
                   "Noise" 14))

(defvar trl-font-lock-keywords nil
  "Keywords for trl-mode-sytax")

(defvar trl-mode-hook nil
  "Trl-Mode hook")

(defvar trl-mode-syntax-table nil
  "Syntax table in use in trl-mode buffers.")

(defvar ger-cache nil
  "Letztes verwendetes Gerausch")

(defvar dialog-cache nil
  "Name des Dialoges")

(defvar number-cache "-1"
  "Laufende Nummer")

(defvar spkr-id-cache nil
  "Letzter sprecher")

(defvar spkr-list nil
  "Sprecherliste")

(defvar chan-id-cache nil
  "Letzter kanal")


(defvar trl-menu-xemacs 
   `("trl"
    ("wrap"    
     [ "<#Knock>" 
       (wrap-sth-around-word "<:<#Knock> " ":>" ) :style nil ]
     [ "<#Rustle>" 
       (wrap-sth-around-word "<:<#Rustle> " ":>" ) :style nil ]
     [ "<#Squeak>" 
       (wrap-sth-around-word "<:<#Squeak> " ":>" ) :style nil ]
     [ "<#>" 
       (wrap-sth-around-word "<:<#> " ":>" ) :style nil ]
     [ "<Noise>" 
       (wrap-sth-around-word "<:<Noise> " ":>" ) :style nil ]
     [ "<Throat>" 
       (wrap-sth-around-word "<:<Throat> " ":>" ) :style nil ]
     [ "<Smack>" 
       (wrap-sth-around-word "<:<Smack> " ":>" ) :style nil ]
     [ "<Swallow>" 
       (wrap-sth-around-word "<:<Swallow> " ":>" ) :style nil ]
     [ "<Cough>" 
       (wrap-sth-around-word "<:<Cough> " ":>" ) :style nil ]
     [ "<Laugh>" 
       (wrap-sth-around-word "<:<Laugh> " ":>" ) :style nil ])
    ("insert"  
     [ "<#Knock>" (insert "<#Knock> ") :style nil ]
     [ "<#Rustle>" (insert "<#Rustle> ") :style nil ]
     [ "<#Squeak>" (insert "<#Squeak> ") :style nil ]
     [ "<#>" (insert "<#> ") :style nil ]
     [ "<Noise>" (insert "<Noise> ") :style nil ]
     [ "<Throat>" (insert "<Throat> ") :style nil ]
     [ "<Smack>" (insert "<Smack> ") :style nil ]
     [ "<Swallow>" (insert "<Swallow> ") :style nil ]
     [ "<Cough>" (insert "<Cough> ") :style nil ]
     [ "<Laugh>" (insert "<Laugh> ") :style nil ] )
    ("new turn"  
     ["new SpkrId..." new-turn-marker :style nil])
    ("hesi"  
     [ "<uh>" (insert "<uh> ") :style nil ]
     [ "<uhm>" (insert "<uhm> ") :style nil ]
     [ "<hm>" (insert "<hm> ") :style nil ]
     [ "<hes>" (insert "<hes> ") :style nil ] )
    ("event" 
     [ "<B>" (insert "<B> ") :style nil ]
     [ "<P>" (insert "<P> ") :style nil ]
     [ "<%>" (insert "<%> ") :style nil ]
     [ "<*T>" (insert "<*T> ") :style nil ] 
     [ "<*T>t" (insert "<*T>t ") :style nil])
    ("word_add"
     [ "<L>" (insert "<L>") :style nil ]
     [ "<T_>" 
       (wrap-sth-around-word "<T_>" "" ) :style nil ]
     [ "<_T>" 
       (wrap-sth-around-word "" "<_T> " ) :style nil ] )
    ["pron-comm" (progn (insert "<!> ") (backward-char 2)) :style nil]
    ["false start" wrap-false-start-around-region :style nil]
    ["repet/corr" wrap-wh-start-around-region :style nil]
    )
)

;;glyphs (whatever this is...) for new toolbar
(defvar aehm-glyph (toolbar-make-button-list [string :data "uhm"]))
(defvar aeh-glyph (toolbar-make-button-list [string :data "uh"]))
(defvar hm-glyph (toolbar-make-button-list [string :data "hm"]))
(defvar haes-glyph (toolbar-make-button-list [string :data "hes"]))
(defvar pau-glyph (toolbar-make-button-list [string :data "<P>"]))
(defvar zoe-glyph (toolbar-make-button-list [string :data "<L>"]))
(defvar atm-glyph (toolbar-make-button-list [string :data "<B>"]))
(defvar ak-glyph (toolbar-make-button-list [string :data "<!>"]))
(defvar tb-glyph (toolbar-make-button-list [string :data "<*T>t"]))
(defvar ws-glyph (toolbar-make-button-list [string :data "<::>"]))
(defvar kl-glyph (toolbar-make-button-list [string :data "Kn"]))
(defvar schm-glyph (toolbar-make-button-list [string :data "Sm"]))
(defvar ger-glyph (toolbar-make-button-list [string :data "Noi"]))
(defvar tger-glyph (toolbar-make-button-list [string :data " # "]))
(defvar rs-glyph (toolbar-make-button-list [string :data "Rs"]))

(defvar trl::toolbar
 '([ aehm-glyph 
     (insert "<uhm> ") 
     t "insert <uhm>"]
   [ aeh-glyph (insert "<uh> ") 
               t "insert <uh>"]
   [ hm-glyph (insert "<hm> ") 
              t "insert <hm>"]
   [ haes-glyph (insert "<hes> ") 
                t "insert <hes> "]
   [ pau-glyph (insert "<P> ") 
               t "insert <P> "]
   [ atm-glyph (insert "<B> ") 
               t "insert <B>"]
   [ zoe-glyph (insert "<L>") 
               t "insert <L>"]
   [ ak-glyph (progn (insert "<!> ") 
                     (backward-char 2))
              t "insert Aussprachekommentar"]
   [ tb-glyph (insert "<*T>t ") 
              t "insert <*T>t"]       
   [ ws-glyph (wrap-sth-around-word-and-stay
               "<:" ":>")
              t "ger-delimiters"]
   [ schm-glyph (insert "<Smack> ") 
                t "insert <Smack>"]
   [ ger-glyph (insert "<Noise> ") 
                t "insert <Noise>"]
   [ tger-glyph (insert "<#> ") 
                t "insert <#>"]
   [ kl-glyph (insert "<#Knock> ") 
              t "insert <#Knock>"]
   [ rs-glyph (insert "<#Rustle> ") 
              t "insert <#Rustle>"]           
   ))

(defvar trl::toolbar-local nil
  "for the buffer-specific buttons")

(defvar new-gls nil)



(if trl-mode-syntax-table
    ()
  (setq trl-mode-syntax-table (make-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" )
)

(defvar trl-mode-map nil
  "Local keymap for trl-mode")



(defun wrap-false-start-around-region( begin end)
  (interactive "r")
  (wrap-sth-around-region "-/" "/-" begin end))

(defun wrap-wh-start-around-region( begin end)
  (interactive "r")
  (wrap-sth-around-region "+/" "/+" begin end))

(setq trl-font-lock-keywords
  (list
   ;;Gerauschueberlagerungen
    '("<:" (0 font-lock-type-face) 
      (":>" nil nil (0 font-lock-type-face)))
    ;;Agrammatisches
    '("-/" (0 font-lock-comment-face) 
      ("/-" nil nil (0 font-lock-comment-face)))
    '("+/" (0 font-lock-comment-face) 
      ("/+" nil nil (0 font-lock-comment-face)))
    ;;Kommentare
    '("<\\(;\\|!\\)[^>]*>" . font-lock-comment-face)
    '("^;.*$" . font-lock-comment-face)
    ;;Elemente
    '("<\\(uh\\|uhm\\|hm\\|hes\\|B\\|L\\|P\\|PP\\)>" . font-lock-string-face)
    '("<\\(Smack\\|Swallow\\|Throat\\|Cough\\|Laugh\\|Noise\\)>" . font-lock-keyword-face )
    ;;
    '("<#[^>]*>" . font-lock-type-face )
    ;;Turnmarker
   '("^\\([A-Za-z0-9]*\\)_\\([A-Za-z0-9]*\\)_\\([A-Za-z0-9]*\\)_\\([A-Za-z0-9]*\\)_\\([A-Za-z0-9]*:\\|:\\)" .
font-lock-function-name-face)
    ;;Sonderzeichen am Wortanfang
    '("\\(_\\|%\\|\*\\|#\\|\~\\|<\\)" . font-lock-function-name-face )
    ;;Wortende
    '("\\(>\\|\=\\|_\\)" . font-lock-function-name-face)
    ;;Specherueberlagerung
    ;;aktiv
    '("<\@[0-9]" (0 font-lock-keyword-face) 
     (">" nil nil (0 font-lock-keyword-face)))
    '("\\(\@[0-9]\\|[0-9]\@\\)" . font-lock-keyword-face)
    ;;passiv
    '("<" (0 font-lock-keyword-face) 
      ("[0-9]\@>" nil nil (0 font-lock-keyword-face)))
    ))

(defun wrap-sth-around-word-and-stay ( fwr ewr )
  (interactive "sHead :\nsTail :")
  (forward-word 1)
  (insert ewr)
  (backward-char (length ewr))
  (backward-word 1)
  (insert fwr)
)

(defun wrap-sth-around-word ( fwr ewr )
  "Wrap something aroud the current word"
  (interactive "sHead :\nsTail :")
    (progn
      (backward-word 1)
      (insert fwr)
      (forward-word 1)
      (insert ewr)))

(defun wrap-sth-around-region ( fwr ewr begin end)
  "Wrap something around the current region"
  (interactive "sHead :\nsTail :\nr")
  (kill-region begin end)
  (insert fwr)
  (yank)
  (insert ewr))

(defun init-dlg ()
  (interactive)
  (goto-char (point-min))
  (while
    (re-search-forward "^\\(....\\)\\(..\\)_\\(...\\)_\\(...\\)[^:]*:" 
                       (point-max) t)
    (if dialog-cache
        (if (equal dialog-cache (match-string 1))
            ( )
          (message (concat "OOoops: error in turnmarker " dialog-cache "<->"
                            (match-string 1)))
          )
      (setq dialog-cache (match-string 1))
      )
    (setq number-cache (match-string 3))
    (setq spkr-id-cache (vector (match-string 4) (match-string 2)))
    (add-to-list 'spkr-list spkr-id-cache)
    )

  (let ((index 0) (max (length spkr-list)) )
   (while (< index max)
     (add-menu-button '("trl" "next turn")
                      (vector (elt (elt spkr-list index) 0)
                              (list 'new-turn-marker 
                                    (elt (elt spkr-list index) 0)
                                    (elt (elt spkr-list index) 1)) t ))
      (setq new-gls (cons  (toolbar-make-button-list 
                             (vector 'string :data 
                                     (elt (elt spkr-list index) 0)))
             new-gls))
      (setq trl::toolbar-local (cons  (vector (elt new-gls 0)
                                    (list 'new-turn-marker 
                                    (elt (elt spkr-list index) 0)
                                    (elt (elt spkr-list index) 1))
                                    t "New turn" ) trl::toolbar-local))

     (setq index (1+ index))))
)


  

(defun new-turn-marker (spkr-id chan-id)
  (interactive "sSpkrId: \nschan-id: ")

  (if (interactive-p)
      (progn
      (add-menu-button '("trl" "next turn")
                   (vector spkr-id (list 'new-turn-marker spkr-id chan-id) t))
      (setq new-gls (cons  (toolbar-make-button-list 
                             (vector 'string :data spkr-id)) new-gls))
      (add-to-list 'trl::toolbar-local (vector (elt new-gls 0)
                                         (list 'new-turn-marker 
                                               spkr-id chan-id)
                                         t "New Turn" ))
      (set-specifier default-toolbar 
                     (cons (current-buffer) trl::toolbar-local ))
      )
    ) 
  (if dialog-cache 
      ()
    (setq dialog-cache (read-string "Dialog:")))
                 

  (let ((turno (1+ (string-to-number number-cache)))) 
    (setq number-cache (format "%03d" turno)))

  (setq number-cache (read-string "Turn-No: " number-cache))
    
  (insert (concat dialog-cache "_" chan-id "_" number-cache "_" 
          spkr-id "_00: ")))
  

(defun trl-mode ()
  "Major Mode for editing trl-files bla bla
Key-bindings:
C-t g : wrap a Noise around selection"

  (interactive)
  (kill-all-local-variables)
  (make-local-variable 'font-lock-defaults)
  (setq trl::toolbar-local trl::toolbar)
  (make-local-variable 'trl::toolbar-local)
  (setq font-lock-defaults '(trl-font-lock-keywords t))
  (setq major-mode 'trl-mode)
  (setq mode-name "Transliteration")
  (setq trl-mode-hook
            '(lambda () (font-lock-mode 1)))

  (add-hook 'trl-mode-hook 'turn-on-auto-fill)
  (setq fill-prefix " ")

;;  (setq dialog-cache (substring (buffer-name) 0 4) )
  (if
      (or (string-match "Lucid" emacs-version)
          (string-match "XEmacs" emacs-version))
      (add-submenu nil trl-menu-xemacs)
      )
  (init-dlg)
  ;;init the toolbar
  (set-specifier default-toolbar (cons (current-buffer) trl::toolbar ))
  (run-hooks 'trl-mode-hook)
) 



