;;; Find the emacs version.  This is important for some commands
;;;

(setq load-path (cons "." load-path))
(setq search-exit-char 13)
(setq emacs-major-version (string-to-int emacs-version))

(if (= emacs-major-version 19)
    (progn
      (standard-display-european 1)
      (setq next-line-add-newlines nil)
      (require 'paren)
      (menu-bar-mode -1)
      )
  )

(display-time)

(if (= emacs-major-version 18)
    (server-start))

(setq display-time-day-and-date nil)

(defun goto-next-window ()
  (interactive)
  (other-window 1))

(defun goto-previous-window ()
  (interactive)
  (other-window -1))

(defun andrew-other-buffer ()
  (interactive)
  (show-buffer (selected-window) (other-buffer (window-buffer))))

(defvar andrew-buffer-list nil "Buffer list used to cycle through buffers")

(defun andrew-forward-buffer (n)
  (let (bufs tbufs (answer nil) (i 0) len (found nil))
    (setq this-command 'andrew-forward-buffer)
    (if (eq last-command 'andrew-forward-buffer)
	(setq bufs andrew-buffer-list)
      (progn (setq bufs (buffer-list))
	     (setq andrew-buffer-list bufs)
	     ;; (message "New buffer list: %s" last-command)
	     ))
      
    (setq tbufs bufs)
    
    (while (and (not answer) bufs)
      (if (eq (car bufs) (window-buffer))
	  (setq answer i))
      (setq bufs (cdr bufs))
      (setq i (+ i 1))
      )
    
    (setq bufs tbufs)
    (setq len (length bufs))
    (setq found answer)
    (setq answer (+ answer n))
    (if (>= answer len)
	(setq answer (- answer len))
      (if (< answer 0)
	  (setq answer (+ answer len))))

    (while (> answer 0)
      (setq bufs (cdr bufs))
      (setq answer (- answer 1)))
    (message "Move to buffer %s" (prin1-to-string (car bufs)))
    (show-buffer (selected-window) (car bufs))
    )
  )

(defun andrew-next-buffer (n)
  (interactive "p")
  (andrew-forward-buffer (if n n 1))
  )

(defun andrew-prev-buffer (n)
  (interactive "p")
  (andrew-forward-buffer (if n (- n) -1))
  )
   
(defun andrew-pop-mark ()
  (interactive)
  (pop-mark)
  (goto-char (mark)))

(defun andrew-scroll-up (&optional n)
  (interactive)
  (if (pos-visible-in-window-p (point-max))
      (goto-char (point-max))
    (scroll-up n)))

(defun andrew-scroll-down (&optional n)
  (interactive)
  (if (pos-visible-in-window-p (point-min))
      (goto-char (point-min))
    (scroll-down n)))

(defun andrew-blink-match ()
  (interactive)
  (blink-matching-open))

;
; Set up all the keys the way I like them
;

(defun after-term-setup ()
  (progn
    (if (= emacs-major-version 18)
	(load-library "term/qnx-keys-18")
      (load-library "term/qnx-keys-19"))
    (if (= emacs-major-version 18)
	(progn
	  (global-set-key "\M-\^?\M-:" 'goto-next-window)
	  (global-set-key "\M-\^?\M-2" 'goto-previous-window)
	  (global-set-key "\C-m" 'newline-and-indent)
	  (global-set-key "\C-j" 'newline)
	  (global-set-key "\M-\^?\M-\C-a" 'c++-mode)		; f1
	  (global-set-key "\M-\^?\M-\C-b" 'shell)		; f2
	  (global-set-key "\M-\^?\M-\C-c" 'run-lisp)		; f3
	  (global-set-key "\M-\^?\M-\C-d" 'get-function-prototype) ; f4
	  (global-set-key "\M-\^?\M-\C-e" 'compare-windows)	; f5
	  (global-set-key "\M-\^?\M-\C-f" 'document-function)	; f6
	  (global-set-key "\M-\^?\M-\C-g" 'document-file)	; f7
	  (global-set-key "\M-\^?\M-\C-h" 'revert-buffer)	; f8
	  (global-set-key "\M-\^?\M-\C-i" 'server-edit)		; f9
	  (global-set-key "\M-\^?\M-\C-j" 'andrew-other-buffer)	; f10
	  (global-set-key "\M-\^?\M-." 'indented-text-mode)	; f11
	  (global-set-key "\M-\^?\M-/" 'andrew-pop-mark)	; f12
	  ;;(global-set-key "\M-\^?\M-b" 'andrew-prev-buffer)	; Alt-PgUp
	  ;;(global-set-key "\M-\^?\M-j" 'andrew-next-buffer)	; Alt-PgUp
	  (global-set-key "\M-\^?\M-@" 'andrew-prev-buffer)	; Alt-Home
	  (global-set-key "\M-\^?\M-h" 'andrew-next-buffer)	; Alt-End
	  (global-set-key "\C-v" 'andrew-scroll-up)
	  (global-set-key "\C-x " 'set-mark-command)
	  (global-set-key "\C-x4a" 'andrew-add-log)
	  (global-set-key "\C-x\C-]" 'andrew-blink-match)
	  (global-set-key "\M-v" 'andrew-scroll-down)
	  (global-set-key "\M-g" 'goto-line)
	  (global-set-key "\M-m" 'compile)
	  (global-set-key "\M-n" 'next-error)

	  (global-set-key "\M-\^?\M-v" 'andrew-scroll-down)
	  (global-set-key "\M-\^?\M-g" 'goto-line)
	  (global-set-key "\M-\^?\M-m" 'compile)
	  (global-set-key "\M-\^?\M-{" 'shell)
	  )
      (progn
	(global-set-key [C-prior] 'goto-next-window)
	(global-set-key [C-next] 'goto-previous-window)
	(global-set-key "\C-m" 'newline-and-indent)
	(global-set-key "\C-j" 'newline)
	(global-set-key [f1] 'c++-mode)
	(global-set-key [f2] 'shell)
	(global-set-key [f3] 'run-lisp)
	(global-set-key [f4] 'get-function-prototype)
	(global-set-key [f5] 'compare-windows)
	(global-set-key [f6] 'document-function)
	(global-set-key [f7] 'document-file)
	(global-set-key [f8] 'revert-buffer)
	(global-set-key [f9] 'server-edit)
	(global-set-key [f10] 'andrew-other-buffer)
	(global-set-key [f11] 'indented-text-mode)
	(global-set-key [f12] 'andrew-pop-mark)
	(global-set-key [A-home] 'andrew-prev-buffer)
	(global-set-key [A-end] 'andrew-next-buffer)
	(global-set-key [A-backspace] 'kill-word-previous)
	(global-set-key "\C-v" 'andrew-scroll-up)
	(global-set-key "\C-x " 'set-mark-command)
	(global-set-key "\C-x4a" 'andrew-add-log)
	(global-set-key "\C-x\C-]" 'andrew-blink-match)
	(global-set-key "\M-v" 'andrew-scroll-down)
	(global-set-key "\M-g" 'goto-line)
	(global-set-key "\M-m" 'compile)
	(global-set-key "\M-n" 'next-error)

;;	(global-set-key "\M-\^?\M-v" 'andrew-scroll-down)
;;	(global-set-key "\M-\^?\M-g" 'goto-line)
;;	(global-set-key "\M-\^?\M-m" 'compile)
;;	(global-set-key "\M-\^?\M-{" 'shell)
	)
      )
    (if (= emacs-major-version 19)
	(cond
	 ( (or (eq window-system 'pc) nil)
	   (progn
	     ;;
	     ;; Set PC text display colors
	     ;;
	     (if t
		 (progn			; Blue background
		   (set-face-foreground 'default "yellow")
		   (set-face-background 'default "blue")
		   (set-face-foreground 'bold "brightwhite")
		   (set-face-background 'bold "blue")
		   (set-face-foreground 'italic "lightgreen")
		   (set-face-background 'italic "blue")
		   (set-face-foreground 'region "black")
		   (set-face-background 'region "brown")
		   (set-face-foreground 'underline "lightcyan")
		   (set-face-background 'underline "blue")
		   (set-face-foreground 'bold-italic "brightwhite")
		   (set-face-background 'bold-italic "blue")
		   (set-face-foreground 'highlight "red")
		   (set-face-background 'highlight "white")
		   (set-face-foreground 'modeline "lightgreen")
		   (set-face-background 'modeline "black")
		   (set-face-foreground 'secondary-selection "green")
		   (set-face-background 'secondary-selection "black"))
	       (progn			; Black background
		 (set-face-foreground 'default "lightgreen")
		 (set-face-background 'default "black")
		 (set-face-foreground 'bold "brightwhite")
		 (set-face-background 'bold "black")
		 (set-face-foreground 'italic "lightcyan")
		 (set-face-background 'italic "black")
		 (set-face-foreground 'region "yellow")
		 (set-face-background 'region "blue")
		 (set-face-foreground 'underline "yellow")
		 (set-face-background 'underline "black")
		 (set-face-foreground 'bold-italic "yellow")
		 (set-face-background 'bold-italic "black")
		 (set-face-foreground 'highlight "white")
		 (set-face-background 'highlight "red")
		 (set-face-foreground 'modeline "yellow")
		 (set-face-background 'modeline "lightblue")
		 (set-face-foreground 'secondary-selection "white")
		 (set-face-background 'secondary-selection "blue")
		 )
	       )
	     ))
	 ( (eq window-system 'x)
	   (progn
	     ;;
	     ;; Set X11 (DESQview/X) keybindings
	     ;;
	     (global-set-key [home] 'beginning-of-line)
	     (global-set-key [end] 'end-of-line)
	     (global-set-key [C-home] 'beginning-of-buffer)
	     (global-set-key [C-end] 'end-of-buffer)
	     ;;
	     ;; Set X11 default foreground and background colors
	     ;;
	     (set-face-foreground 'default "gray60")
	     (set-face-background 'default "blue")
	     ;;
	     ;; Turn off the scroll bar display
	     ;;
	     (scroll-bar-mode -1)
	     ;;
	     ;; Turn off the menu bar display
	     ;;
	     (menu-bar-mode -1)
	     ))
	 )
      )
    )
  )


;;;
;;; Set up for GNUS
;;;

(provide 'lisp-mode)
(setq gnus-nntp-server "news.ican.net")
;;(setq gnus-nntp-server "::")
(setq gnus-local-domain "cogent.ca")
(setq gnus-local-organization "Cogent Real-Time Systems Inc.")
;;(setq gnus-nntp-service 119)
(setq gnus-use-generic-from t)
(autoload 'gnus "gnus" "Read network news." t)
(autoload 'gnus-post-news "gnuspost" "Post a news article." t)
(setq system-configuration "none")
(setq gnus-user-full-name "Andrew Thomas")
(setq gnus-user-login-name "andrew")
(setq gnus-read-active-file nil)
(setq gnus-use-cache 'passive)

;;;
;;; My Hooks
;;;

(setq term-setup-hook 'after-term-setup)

(defun andrew-c-mode ()
  (interactive)
  (setq c-indent-level 4)
  (setq c-auto-newline t)
  (setq c-brace-offset 0)
  (setq c-tab-always-indent nil)
  (setq c-brace-imaginary-offset 0)
  (setq c-label-offset -2)
  (setq c-continued-statement-offset 4)
  (setq c-continued-brace-offset -4)
  (setq tab-width 4)
  ;;(if (= emacs-major-version 19)
  ;;    (font-lock-mode))
  
  ;;(if (= emacs-major-version 19)
  ;;    (progn
  ;;	(local-set-key "\M-n" 'compilation-next-error)
  ;;	(local-set-key "\M-p" 'compilation-previous-error)
  ;;	)
    (progn
      (local-set-key "\M-n" 'next-error)
      (local-set-key "\M-\^?\M-n" 'next-error)
      )
  ;;)
  (message "%s" (prin1-to-string (current-buffer)))
  ;; (server-buffer-done (current-buffer))
  )

(defun andrew-c-modex ()
  (interactive)
  (setq c-indent-level 4)
  (setq c-auto-newline t)
  (setq c-brace-offset 0)
  (setq c-tab-always-indent nil)
  (setq c-brace-imaginary-offset 0)
  (setq c-label-offset -2)
  (setq c-continued-statement-offset 4)
  (setq c-continued-brace-offset -4)
  (setq tab-width 4)
  (message "%s" (prin1-to-string (current-buffer)))
  )

(defun andrew-makefile-mode ()
  (interactive)
  (setq tab-width 4)
  (local-set-key "$" 'self-insert-command)
  )

(defun andrew-text-mode ()
  (interactive)
  (auto-fill-mode 1)
  (setq tab-width 8)
  )

(defun andrew-add-log ()
  (interactive)
  (add-change-log-entry nil "./ChangeLog" nil t)
  (beginning-of-line)
  (delete-horizontal-space)
  (indent-to 4)
  (if (> left-margin 4)
      (setq left-margin 4))
  (end-of-line))

(defun andrew-lisp-mode ()
  (interactive)
  ;;(local-set-key "\M-\^?\M-." 'lisp-send-defun)		; f11
  ;;(local-set-key "\M-\^?\M-/" 'lisp-send-defun-and-go)	; f12
  )

(defun andrew-fundamental-mode ()
  (interactive)
  (setq tab-width 4)
  )

(defun andrew-strip-ctrl-m ()
  (interactive)
  (save-excursion
    (goto-char 1)
    (while (re-search-forward "\r+$" (point-max) t)
      (replace-match "" t t))
    )
  )

;;(setq c-mode-common-hook 'andrew-c-mode)
(setq c-mode-hook 'andrew-c-mode)
(setq c++-mode-hook 'andrew-c-mode)
(setq makefile-mode-hook 'andrew-makefile-mode)
(setq text-mode-hook 'andrew-text-mode)
(setq lisp-mode-hook 'andrew-lisp-mode)
(setq fundamental-mode-hook 'andrew-fundamental-mode)

(setq compilation-filter-hook 'andrew-strip-ctrl-m)
(setq comint-output-filter-functions
      (list 'comint-strip-ctrl-m 'comint-postoutput-scroll-to-bottom))
(setq shell-popd-regexp "pop\\\|popd")
(setq shell-pushd-regexp "pd\\\|pushd")

(setq auto-mode-alist (cons (cons "\\.y$" 'c++-mode) auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\.mac$" 'c++-mode) auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\.hpp$" 'c++-mode) auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\.cpp$" 'c++-mode) auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\.h$" 'c++-mode) auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\.c$" 'c++-mode) auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\.slg$" 'c++-mode) auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\makefile$" 'makefile-mode)
			    auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\Makefile$" 'makefile-mode)
			    auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\.txt$" 'text-mode) auto-mode-alist))
(setq auto-mode-alist (cons (cons "\\.doc$" 'text-mode) auto-mode-alist))

;;;
;;; Fake the add-hook function from version 19
;;;

(autoload 'c++-mode "cplus-md" nil t)
(autoload 'quics "quicsrd" nil t)
(autoload 'vm "vm" "Start VM on your primary inbox." t)
(autoload 'vm-other-frame "vm" "Like `vm' but starts in another frame." t)
(autoload 'vm-visit-folder "vm" "Start VM on an arbitrary folder." t)
(autoload 'vm-visit-virtual-folder "vm" "Visit a VM virtual folder." t)
(autoload 'vm-mode "vm" "Run VM major mode on a buffer" t)
(autoload 'vm-mail "vm" "Send a mail message using VM." t)
(autoload 'vm-submit-bug-report "vm" "Send a bug report about VM." t)

(setq vm-primary-inbox "~/Mail/incoming")
(setq vm-folder-directory "~/Mail/")
(setq vm-mime-base64-decoder-program "/usr/local/bin/mimedecode")
(setq mail-archive-file-name "~/Mail/sent")
(setq mail-interactive t)
(setq mail-yank-prefix "> ")
(setq user-mail-address "andrew@cogent.ca")
(setq mail-host-address "cogent.ca")
(setq mail-user-agent 'vm-user-agent)
(setq sendmail-program "sendmail")

(setq compile-command "make -k")
(setq inferior-lisp-program "/usr/local/bin/phlisp")
(setq inferior-lisp-flag "-q")
;;; (concat "/home/" (user-login-name) "/devel/lisp/phlisp")

(defun andrew-shell-ctrld ()
  (interactive)
  (if (= (point) (point-max))
      (shell-send-eof)
    (delete-char 1)))

(defun andrew-shell-mode ()
  (interactive)
  (local-set-key "\C-d" 'andrew-shell-ctrld)
  (setq comint-output-filter-functions
	(cons 'comint-strip-ctrl-m comint-output-filter-functions)))

;;;(setq shell-mode-hook 'andrew-shell-mode)

;;; Auto-documentation function

(setq username (user-full-name))

(defun date-string ()
  (let ((s (current-time-string)) beg end day year)
    (setq beg (string-match " " s))
    (setq beg (string-match "[^ ]" s beg))
    (setq end (string-match " " s (1+ beg)))
    (setq end (string-match "[^ ]" s end))
    (setq end (string-match " " s end))
    (setq day (substring s beg end))
    (setq end (string-match "[^ ]" s end))
    (setq end (string-match " " s end))
    (setq end (string-match "[^ ]" s end))
    (setq year (substring s end))
    (concat day ", " year)))

(defun short-name ()
  (let ((s (buffer-file-name)) (slash 0) (last 0))
    (while slash
      (setq last slash)
      (setq slash (string-match "/" s (1+ slash))))
    (substring s (1+ last))))

(defun insert-header ()
  (interactive)
  (save-excursion
    (beginning-of-buffer)
    (insert "/*--------------------------------------------------------------------\n")
    (insert " * File:        " (short-name) "\n")
    (insert " *\n")
    (insert " * Description: \n")
    (insert " *\n")
    (insert " * Functions:\n")
    (insert " *\n")
    (insert " *------------------------------------------------------------------*/\n")
    (insert "\n")
    )
  )

(defun insert-function-name (fname)
  (save-excursion
    (beginning-of-buffer)
    (if (and (search-forward " * Functions:" (point-max) t)
	     (search-forward " *-----------" (point-max) t))
	(progn
	  (beginning-of-line)
	  (previous-line 1)
	  (insert " *\t\t" fname "\n"))
      )
    )
  )
  

(defun document-function ()
  (interactive)
  (let (begargs begname begtype endargs endname endtype fargs fname ftype)
    (beginning-of-line)
    (setq begtype (point))
    (if (search-forward "(" (point-max) t)
	(progn
	  (setq begargs (point))
	  (backward-char)
	  (forward-list)
	  (backward-char)
	  (setq endargs (point))
	  (goto-char (- begargs 1))
	  (if (re-search-backward "[^ \t\n]" begtype t)
	      (progn
	       (forward-char)
	       (setq endname (point))
	       (if (re-search-backward "[ \t\n*]" begtype t)
		   (progn
		    (forward-char)
		    (setq begname (point))
		    (re-search-backward "[^ \t\n]" begtype t)
		    (setq endtype (1+ (point))))
		 (setq begname begtype)
		 (setq endtype begtype))
	       (setq fargs (buffer-substring begargs endargs))
	       (setq fname (buffer-substring begname endname))
	       (setq ftype (buffer-substring begtype endtype))
	       (if (not (equal fargs ""))
		   (let (beg (fin -1) (arglst nil))
		     (while (< fin (length fargs))
		       (setq beg (string-match "[^ \t\n]" fargs (1+ fin)))
		       (if (not (setq fin (string-match "," fargs beg)))
			   (setq fin (length fargs)))
		       (setq arglst (cons (substring fargs beg fin) arglst))
		       )
		     (setq fargs (reverse arglst))
		     )
		 (setq fargs nil)
		 )
	       (goto-char begtype)
	       (insert "/*--------------------------------------------------------------------\n")
	       (insert " * Function:    " fname "\n")
	       (insert " *\n")
	       (insert " * Author:      " username "\n")
	       (insert " *\n")
	       (insert " * Date:        " (date-string) "\n")
	       (insert " *\n")
	       (insert " * Returns:     " ftype "\n")
	       (insert " *\n")
	       (if fargs
		   (progn
		     (insert " * Arguments:   " (car fargs) "\n")
		     (setq fargs (cdr fargs))
		     (while fargs
		       (insert " *              " (car fargs) "\n")
		       (setq fargs (cdr fargs)))
		     )
		 (insert " * Arguments:   none\n"))
	       (insert " *\n")
	       (insert " * Description: " "\n")
	       (insert " *\n")
	       (insert " *------------------------------------------------------------------*/\n")
	       (save-excursion
		 (insert-function-name fname))
	       (search-backward "Description:")
	       (end-of-line)
	       )
	    )
	  )
      )
    )
  )

(defun document-file ()
  (interactive)
  (save-excursion
    (insert-header)
    (beginning-of-buffer)
    (let (bod)
      (while (beginning-of-defun -1)
	(setq bod (point))
	(backward-paragraph)
	(if (search-forward "(" bod t)
	    (document-function))
	(end-of-defun)
	)
      )
    )
  )

;;;
;;; Grab function names and put them in the other buffer
;;;

(defun get-function-prototype ()
  (interactive)
  (if (beginning-of-defun -1)
      (let (beg end stuff)
	(backward-paragraph)
	(forward-char)
	(setq beg (point))
	(search-forward "{")
	(backward-char)
	(setq stuff (buffer-substring beg (point)))
	(other-window -1)
	(insert "extern ")
	(insert stuff)
	(backward-char)
	(insert ";")
	(forward-char)
	(other-window 1)
	(end-of-defun)
	)
    )
  )

;;;
;;; Mappings for ESC-/ mouse cursor handling in a Photon pterm or a QNX
;;; Windows wterm.  Looks for qnxm and qnxw terminal types. 
;;;
;;; Button commands look like: <ESC>/31;4;31;4;1t
;;;     ESC / 31 row ; col ; button ; #clicks t		; button down
;;;     ESC / 32 row ; col ; button ; #clicks t		; button up
;;;
;;; 't' = 116,  ';'=59,  '0'=48
;;;
;;; to start mouse: ESC / > 1 h ESC / > 6 h
;;; to stop  mouse: ESC / 0 t
;;;
;;; Mouse commands are:
;;;
;;;    Left Button                    Move cursor to mouse
;;;    Right Button                   Set mark, but do not move cursor
;;;    Left Button click/drag         Copy from DOWN to UP, set mark at DOWN
;;;    Right Button click/drag        Kill from DOWN to UP, set mark at DOWN
;;;    Left and Right together        Yank at the mouse position
;;;

;;;
;;; Colors are:
;;;	0 - black / grey
;;;	1 - blue / sky blue
;;;	2 - green / bright green
;;;	3 - cyan / bright cyan
;;;	4 - red / pink
;;;	5 - purple / magenta
;;;	6 - brown / yellow
;;;	7 - grey / white

(defvar compl-alist '(("black" 0 nil) ("blue" 1 nil) ("green" 2 t)
		      ("cyan" 3 t) ("red" 4 nil) ("magenta" 5 t)
		      ("yellow" 6 t) ("white" 7 t))
  "Association list of colors:
	(color-name vga-value foreground-highlight-flag)")


(defun photon-color-set ()
  (vga-set-colors "white" "blue"))

(defun vga-set-colors (fore back)
  "Set colors given the color names"
  (setq fore (assoc fore compl-alist))
  (setq back (assoc back compl-alist))
  (if (not fore) (setq fore (car (cdr (cdr compl-alist)))))
  (if (not back) (setq back (car compl-alist)))
  (send-string-to-terminal
   (concat ">"
	   (if (caddr fore) "<" "")
	   "@" (int-to-string (cadr fore)) (int-to-string (cadr back))
	   "!" (int-to-string (cadr fore)) (int-to-string (cadr back))
	   "S"))
  (redraw-display)
  )

(defun andrew-set-colors ()
  ;;(interactive "SEnter foreground: \nSEnter background: ")
  (interactive)
  (let (fore back)
    (setq fore (completing-read "Enter foreground: " compl-alist nil t nil))
    (setq back (completing-read "Enter background: " compl-alist nil t nil))
    (vga-set-colors fore back)
    )
  )
    
(defun photon-mouse-init ()
  (interactive)
  (global-set-key "\e/" 'photon-mouse-handler)
  (send-string-to-terminal "/>1h/>6h")
  (setq kill-emacs-hook 'photon-mouse-stop))

(defun qwindows-mouse-init ()
  (interactive)
  (global-set-key "\e/" 'photon-mouse-handler)
  (send-string-to-terminal "/>1h/>6h/>9l")
  (setq kill-emacs-hook 'qwindows-mouse-stop))

(defun photon-mouse-stop ()
  (interactive)
  (send-string-to-terminal "/0t"))

(defun qwindows-mouse-stop ()
  (interactive)
  (send-string-to-terminal "/0t/>9h"))

(defun read-number (termin)
  (let ((result 0) ch)
    (while (not (= (setq ch (read-char)) termin))
      (setq result (+ (* result 10) (- ch 48))))
    result
    )
  )

(defun cadr (x) (car (cdr x)))
(defun caddr (x) (car (cdr (cdr x))))
(defun cadddr (x) (car (cdr (cdr (cdr x)))))

(defun pos-in-window (window col row)
  (let ((edges (window-edges window)))
    (if (and (>= col (car edges)) (< col (caddr edges))
	     (>= row (cadr edges)) (< row (cadddr edges)))
	t nil)))

(defun which-window (col row)
  (save-excursion
    (let ((win (next-window (selected-window))) (startwin (selected-window))
	  retval)
      (if (pos-in-window startwin col row) (setq retval startwin)
	(while (and (not (eq win startwin)) (not retval))
	  (if (pos-in-window win col row)
	      (setq retval win)
	    (setq win (next-window win)))))
      retval)))

(defun photon-mouse-pos (col row)
  (let (newwin result)
    (setq newwin (which-window col row))
    (if newwin
	(let ((wincur (current-window-configuration))
	      (edges (window-edges newwin)))
	  (save-excursion
	    (select-window newwin)
	    (move-to-window-line (- row (cadr edges)))
	    (move-to-column (+ (current-column) col))
	    (setq result (point)))
	  (set-window-configuration wincur)))
    result))

(defun photon-set-point (col row)
  (let ((pos (photon-mouse-pos col row)))
    (if pos
	(progn
	  (let ((newwin (which-window col row)))
	    (select-window newwin)
	    (set-window-point newwin pos)
	    (message (setq photon-last-message "")))))
    pos))

(defun photon-set-mark (col row)
  (let ((pos (photon-mouse-pos col row)))
    (if pos
	(let ((newwin (which-window col row)))
	  (set-buffer (window-buffer newwin))
	  (set-mark pos)
	  (message (setq photon-last-message "Mark set"))))
    pos))

(defvar photon-mouse-down 0 "Position at which the mouse button was pushed")
(defvar photon-last-message "" "Message to display after photon mouse event")
(defvar photon-left-down nil "True if the left mouse button is down")
(defvar photon-right-down nil "True if the right mouse button is down")

(defun photon-mouse-down-handler ()
  (let (row col buttons downnum)
    (setq row (read-number 59))
    (setq col (read-number 59))
    (setq buttons (read-number 59))
    (setq downnum (read-number 116))
    (if (= buttons 4)
	(setq photon-left-down t))
    (if (= buttons 1)
	(setq photon-right-down t))
    (if (and photon-left-down photon-right-down)
	(progn
	  (photon-set-point col row)
	  (message (setq photon-last-message "Yanked."))
	  (yank)
	  (setq photon-right-down nil)
	  (setq photon-left-down nil)
	  )
      (progn
	(setq photon-mouse-down (photon-mouse-pos col row))
	(message (setq photon-last-message ""))
	)
      )
    ))

(defun photon-mouse-up-handler ()
  (let (row col buttons downnum)
    (setq row (read-number 59))
    (setq col (read-number 59))
    (setq buttons (read-number 116))

    (if (or (and photon-left-down (= buttons 4))
	    (and photon-right-down (= buttons 1)))
	(if (not (= (photon-mouse-pos col row) photon-mouse-down))
	    (progn
	      (photon-set-point col row)
	      (set-mark photon-mouse-down)
	      (if (= buttons 4)
		  (progn
		    (message (setq photon-last-message "Mark set, Copied."))
		    (copy-region-as-kill (point) (mark)))
		(progn
		  (message (setq photon-last-message "Mark set, Killed."))
		  (kill-region (point) (mark)))
		)
	      )
	  (if (= buttons 1)
	      (photon-set-mark col row)
	    (photon-set-point col row))
	  )
      )

    ;; Clear both buttons if either is lifted.
    (setq photon-left-down nil)
    (setq photon-right-down nil)
    )
  )

(defun photon-mouse-move-handler ()
  (let (row col buttons downnum)
    (setq row (read-number 59))
    (setq col (read-number 59))
    (setq buttons (read-number 116))
    (message photon-last-message)
    )
  )

(defun photon-mouse-handler ()
  (interactive)
  (let (ch col row buttons downnum command)
    (setq command (read-number 59))
    (if (= command 31)			; mouse down
	(photon-mouse-down-handler)
      (if (= command 32)		; mouse up
	  (photon-mouse-up-handler)
	(if (= command 3)		; mouse motion?
	    (photon-mouse-move-handler)
	  (read-number 116)
	  )
	)
      )
    )
  )

(if (or (equal (getenv "TERM") "qnxm")
	(equal (getenv "TERM") "qansi-m"))
    (progn
      (if (string= (user-real-login-name) "root")
	  (vga-set-colors "black" "white")
	(photon-color-set))
      (photon-mouse-init)
      )
  (if (equal (getenv "TERM") "qnxw")
      (qwindows-mouse-init)
    )
  )

;;;
;;; Extract the function names and arguments from a SCADALisp source file
;;; containing function setup calls to liCLFunction.  Place the function
;;; prototype in the buffer *lispfuns*
;;;
;;; To use this correctly, cat *.c > allc.c, then call the function
;;; funchead repeatedly until you reach the end.
;;;

(defun nextword (maxpoint)
  (let ((dq "\"") front back)
    (if (search-forward dq maxpoint t)
	(progn
	  (setq front (point))
	  (if (search-forward dq maxpoint t)
	      (setq back (- (point) 1))
	    )
	  )
      )
    
    (if (and front back)
	(buffer-substring front back)
      nil)
    )
  )

(defun nextmodifier (maxpoint)
  (let ((dq ",\\|)") front back)
    (if (re-search-forward dq maxpoint t)
	(progn
	  (setq front (point))
	  (if (re-search-forward dq maxpoint t)
	      (setq back (- (point) 1))
	    )
	  )
      )
    
    (if (and front back)
	(buffer-substring front back)
      nil)
    )
  )

(defun bufinsert (buffer str)
  (save-excursion
    (set-buffer buffer)
    (insert str)
    )
  )
  
(defun funchead ()
  (interactive)
  (if (search-forward "liCLFunction" (point-max) t)
      (let (here eol word other modif)
	(save-excursion
	  (setq here (point))
	  (search-forward ")")
	  (setq eol (point)))
	(setq other (get-buffer-create "*lispfuns*"))
	(save-excursion
	  (set-buffer other)
	  (end-of-buffer))

	(if (setq word (nextword eol))
	    (progn
	      (bufinsert other "(")
	      (bufinsert other word)
	      (while (setq word (nextword eol))
		(setq modif (nextmodifier eol))
		(if (string-match "OPTIONAL" modif)
		    (progn
		      (bufinsert other " ")
		      (bufinsert other "&optional")))
		(if (string-match "REST" modif)
		    (progn
		      (bufinsert other " ")
		      (bufinsert other "&rest")))
		(if (string-match "NOEVAL" modif)
		    (progn
		      (bufinsert other " ")
		      (bufinsert other "&noeval")))
		(bufinsert other " ")
		(bufinsert other word)
		)
	      (bufinsert other ")\n")
	      )
	  )
	)
    )
  )
