;;; $Header: /tmp_mnt/ufs/pcn/carl/PCN/IF/el/RCS/pcn-if.el,v 1.20 90/11/08 14:25:27 carl Exp Locker: carl $

(provide 'pcn-if)

;(setq debug-on-error t)

(setq auto-mode-alist (cons '("\\.pcn$" . pcn-mode) auto-mode-alist))
(setq completion-ignored-extensions
      (cons ".pam" completion-ignored-extensions))

;;; Initialize epoch if the user is not a regular epoch user.
(defvar epoch::version nil)
(defvar running-epoch nil)

(if (not running-epoch)
    (progn 
      (setq running-epoch epoch::version)
      (if running-epoch (setq term-file-prefix nil)) ; don't load xterm stuff!

      ;; target-buffer is used by random bits of the epoch code.

      (setq target-buffer (get-buffer "*scratch*"))

      (if running-epoch
	  (progn
	    (load-library "epoch-util")
	    (load-library "epoch")
	    (load-library "button")
	    (load-library "mouse")
	    (load-library "motion")
	    (load-library "property")
	    (load-library "message")
	    (load-library "server")
	    (setq epoch::buttons-modify-buffer nil)
	    (setq auto-raise-screen nil)
	    )
	)
      )
  )

;;; Not normally loaded into epoch
(if running-epoch
    (progn
      (require 'scr-pool)
      )
)

(require 'cmupcn)

(defmacro with-buffer (buffer &rest body)
  (` (save-excursion
       (set-buffer (, buffer))
       (,@ body)
       )
     )
  )

(defun get-arg (arg lst)
  (cond ((null lst) nil)
	((equal arg (car lst)) (cadr lst))
	(t (get-arg arg (cdr lst)))))

(defun delete-arg (arg lst)
  (cond ((null lst) nil)
	((equal arg (car lst)) (cddr lst))
	(t (cons (car lst) (delete-arg arg (cdr lst))))))

(defun stringify (arg)
  (cond ((stringp arg) arg)
	((numberp arg) arg)
	(t (symbol-name arg))))


(defvar *pcn-emulator* "pcn")
(defvar *pcn-host* (system-name))
(defvar *pcn-nodes* 1)
(defvar *pcn-path* ".")

(defun pcn-command (&optional emulator nodes args)
  (if (not emulator) (setq emulator *pcn-emulator*))
  (if (not nodes) (setq nodes *pcn-nodes*))
  (if (> nodes 1) (setq args (cons '-n (cons nodes args))))
  (mapconcat (function stringify) (cons emulator args) " "))

(defun pcn-if () (interactive)
  (let* ((args (read (concat "(" (getenv "PCN_ARGS") ")")))
	 (pcn-host (get-arg '-h args))
	 (pcn-nodes (or (get-arg '-n args) 1))
	 (pcn-emulator (or (get-arg '-e args) "pcn"))
	 (pcn-dir (or (get-arg '-p args) "."))
	 (args (delete-arg '-n (delete-arg '-e (delete-arg '-h args))))
	 (pcn-cmd (mapconcat (function stringify) 
			     (cons pcn-emulator args) " ")))

    ;;    (global-set-key "\C-x\C-c" 'delete-screen)

    (get-buffer-create "*pcn-if*")
    (push-property "XPCN_CMD" (function xpcn-cmd-handler))
    (push '(geometry . "80x24+155+255") epoch::screen-properties)

    (set-property "XPCN_EDIT" (system-name) (minibuf-screen))
    (set-property "XPCN_EDIT" (xid-of-screen (minibuf-screen))
		  (car (query-tree)))
    )
  )

(defun create-edit-screen ()
  "Create a screen for PCN.  Use the current screen if it
is currently displaying a buffer such as *scratch or some
other non file associated buffer."
  (if (not (or (string-equal pcn-buffer (buffer-name))
	       (buffer-file-name)))
      (current-screen)
    (create-screen)
    )
)

(defun getcube (nodes memory)
  (with-buffer "*pcn-if*" 
	       (setq acknowledge
		     (shell-command
		      (format "getmc %s %dn mem=%s" nodes memory)))
	       (if (= acknowledge 1)
		   (setq acknowledge "OK"
			 *cube-allocated* nodes)
		 (setq acknowledge "GETMC_FAILED"))))

(defun freecube ()
  (and *cube-allocated*
       (with-buffer "*pcn-if*" (shell-command "freecube" t))
       (setq *cube-allocated* nil))
  )

(defun delete-pcn-screen ()
  "Destroy pcn process and associated pcn screen"
  (interactive)
  (kill-pcn)
  (freecube)
  (if pcn-buffer
      (progn
	(and (> (length (screen-list)) 1)
	     (delete-screen (car (screens-of-buffer pcn-buffer))))
	(kill-buffer pcn-buffer)
	(setq pcn-buffer nil))))

(defun delete-edit-screen (scr)
  "Destroy screen function for pool management"
  (let (screen-buffer)
	 (save-screen-excursion
	  (select-screen scr)
	  (kill-buffer (window-buffer (selected-window))))))

(defun kill-pcn ()
  (let* ((proc (get-buffer-process pcn-buffer)))
    (if (and proc (memq (process-status proc) '(run stop)))
	(progn
	  (process-send-eof proc)
	  (while (not (eq 'exit (process-status proc))))))))

(defun start-pcn (pcn-cmd nodes host path remote)
  (kill-pcn)
  (if (or (not path) (string-equal path ".") (string-equal path ""))
      (setq path (with-buffer "*pcn-if*" default-directory)))
  (and pcn-buffer
       (with-buffer pcn-buffer (setq default-directory path)))
  (with-buffer "*pcn-if*" (insert pcn-cmd "\n"))
  ;; Get the directory right
  (set-buffer (or pcn-buffer "*pcn-if*"))
  (if remote
      (run-pcn pcn-cmd host path)
    (run-pcn pcn-cmd))
  (goto-char (point-max))
  (epoch::title
   (format "%s @ %s  Nodes: %d"
	   (car (pcn-args-to-list pcn-cmd)) host nodes))
  )

(defun exit-from-pcn-if ()
  (interactive)
  (epoch::warp-mouse 20 0 (epoch::minibuf-screen))
  (if (yes-or-no-p "Do you want to exit PCN? ")
      (save-buffers-kill-emacs)))

(defun switch-to-buffer-other-screen (buffer)
  "Switch to BUFFER in other screen.  If buffer is already in another screen then select that, else make a new screen."
  (interactive "BSwitch to buffer other screen: ")
  (setq target-buffer (get-buffer buffer))
  (when (not target-buffer)
    (setq target-buffer (get-buffer-create buffer))
    (save-excursion
      (set-buffer target-buffer)
      (setq screens nil)
      )
    )
  (let
      ((scr (car (epoch::screens-of-buffer target-buffer)))
       (xname (concat (buffer-name target-buffer) (sys-name))))
    (when (null scr)
      (setq scr
	    (create-screen 
	     target-buffer
	     (list (cons 'title xname) (cons 'icon-name xname)))
	    )
      )
    (if (screen-mapped-p scr)
	(progn
	  (epoch::raise-screen scr)
	  (cursor-to-screen (select-screen scr))
	  )
      (progn
	(on-map-do scr 'cursor-to-screen)
	(mapraised-screen (select-screen scr))
	)
      )
    (select-window (get-buffer-window target-buffer))
    target-buffer			;return value
    )
  )

(defvar *pcn-peer* nil
  "Window ID of top level xpcn window")
(defvar *pcn-screens* nil
  "Window pool of screens created by xpcn")
(defvar *pcn-buffers* nil
  "List of buffers created by xpcn")
(defvar *cube-allocated* nil)

(defun xpcn-cmd-handler (type prop screen)
  (let* ((str (get-property prop screen))
	 (pcn-command (read str))
	 (epoch::event-handler-abort nil)
	 (acknowledge "OK")
	 command arguments)
    (condition-case ERR
	(progn
	  (with-buffer "*pcn-if*" (goto-char (point-max)) (insert str "\n"))
	  (setq command (car pcn-command)) 
	  (setq arguments (cdr pcn-command))
	  (cond
	   ((equal command 'CONNECT)
	    ;; Connect a epoch session to a xpcn top level windwo
	    (setq *pcn-screens*
		  (pool:create 10
			       (function create-edit-screen)
			       (function delete-edit-screen)))
	    (setq *pcn-peer* (string-to-resource (nth 0 arguments)
						 (intern-atom "WINDOW"))))
	   ((equal command 'EDIT)
	    (let ((filebuffer
		   (with-buffer "*pcn-if*"
				(find-file-noselect (nth 0 arguments))))
		  (scr (pool:get-screen-with-buffer *pcn-screens* filebuffer)))
	      (and (not (memq filebuffer *pcn-buffers*))
		   (push filebuffer *pcn-buffers*))
	      (select-screen scr)
	      (delete-other-windows)		;no other windows
	      (set-window-buffer (selected-window) filebuffer) ;display buffer
	      (if (screen-mapped-p scr)
		  (cursor-to-screen (raise-screen scr))
		(on-map-do (mapraised-screen scr) 'cursor-to-screen))))
	   ((equal command 'CD)
	    (with-buffer "*pcn-if*"
			 (setq default-directory (nth 0 arguments))))
	   ((equal command 'COMPILE)
	    (if (not (get-buffer-process pcn-buffer))
		(setq acknowledge "NOPCN")
	      (pcn-compile-file (nth 0 arguments))))
	   ((equal command 'PROFILE)
	    (if (not (get-buffer-process pcn-buffer))
		(setq acknowledge "NOPCN")
	      (apply 'pcn-profile arguments)))
	   ((equal command 'PCN)
	    (if (not (buffer-file-name))
		(switch-to-buffer "*pcn*" t))
	    (apply 'start-pcn arguments))
	   ((equal command 'KILLPCN) (kill-pcn))
	   ((equal command 'RUN)
	    (if (not (get-buffer-process pcn-buffer))
		(setq acknowledge "NOPCN")
	      (apply 'pcn-run-goal arguments)))
	   ((equal command 'USER)
	    (apply 'insert arguments))
	   ((equal command 'ALLOCATECUBE)
	    (apply 'getcube arguments))
	   ((equal command 'FREECUBE)
	    (freecube))
	   ((equal command 'DELETESCREENS)
	    (delete-pcn-screen)
	    ;; Arrange not to delete the last edit screen
	    (mapcar (function kill-buffer) *pcn-buffers*)
	    (if (= (length (screen-list)) (length (nth 1 *pcn-screens*)))
		(setcar (cdr *pcn-screens*) (cdr (nth 1 *pcn-screens*)))) ;extract one screen from pool.
	    (pool:delete *pcn-screens*))
	   ((equal command 'EXIT)
	    (set-property "XPCN_ACK" "1" *pcn-peer*)
	    (kill-emacs))
	   )
	  (set-property "XPCN_ACK" acknowledge *pcn-peer*)
	  )
      (error (set-property "XPCN_ACK" "ERROR" *pcn-peer*)
	     (signal 'error (cdr ERR)))
      (quit (set-property "XPCN_ACK" "ABORT" *pcn-peer*)
	    (signal 'quit (cdr ERR)))
      )
    )
  )