;;
;; Surmulot TCP/IP manager code
;;================================================================

(require 'cl)

;;================================================================
;; Surmulot set-up

(defun extenv (var val)
  (if (getenv var)
      (setenv var (concat (getenv var) ";" val))
    (setenv var val)))

(defun wsetenv (var val)
  (if (eq system-type 'windows-nt)
    (setenv var val)))

(defmacro with-surmulot-environment (&rest body)
  `(with-temp-buffer 
     (let* ((vars '("SURMULOTDIR" 
		    "INCDIR" "OPCODEDIR" "OPCODEDIR64" 
		    "SADIR" "SFDIR" "SSDIR" "MFDIR"
		    "RAWWAVE_PATH" "CSOUNDRC"
		    "SURMULOTBUBBLE"))
	    (cache (mapcar 'getenv vars))
	    body-returned-value)
       (when (getenv "SURMULOTBUBBLE")
	 (mmessage "? nested Surmulot environments !"))
       (setenv "SURMULOTBUBBLE" "true")
       (setenv "SURMULOTDIR" 
	       (expand-file-name ".." default-directory)) 
       (extenv "INCDIR" 
	       (substitute-in-file-name "$SURMULOTDIR/csound/include"))
       (wsetenv "OPCODEDIR" 
		(substitute-in-file-name "$SURMULOTDIR/csound/plugins"))
       (wsetenv "OPCODEDIR64" 
		(substitute-in-file-name "$SURMULOTDIR/csound/plugins64"))
       (extenv "SADIR" 
	       (substitute-in-file-name "$SURMULOTDIR/csound/analysis"))
       (extenv "SFDIR" 
	       (substitute-in-file-name "$SURMULOTDIR/csound/rendered"))
       (extenv "SSDIR" 
	       (substitute-in-file-name 
		"$SURMULOTDIR/csound/samples;$SURMULOTDIR/soundfonts"))
       (extenv "MFDIR" 
	       (substitute-in-file-name "$SURMULOTDIR/midi"))
       (wsetenv "RAWWAVE_PATH" 
		(substitute-in-file-name "$SURMULOTDIR/csound/samples"))
       (wsetenv "CSOUNDRC" 
		(substitute-in-file-name "$SURMULOTDIR/csound/.csoundrc"))
       (unwind-protect
	   (setq body-returned-value ,@body)
	 (loop for var in vars
	       for value in cache
	       do (setenv var value)
	       finally return body-returned-value)))))

(defvar surmulot-directory
  (funcall (if (eq system-type 'windows-nt)
	       'w32-short-file-name 'identity)
	   (expand-file-name ".." default-directory)))

(defun manager-start-muO-and-die ()
  (manager-start-muO)
  (kill-emacs))

(defun manager-start-muO ()
  (with-surmulot-environment 
   (save-window-excursion
     (shell-command 
      (format "%s %s &"
	      (shell-quote-argument 
	       (expand-file-name "squeak/vm/squeak" surmulot-directory))
	      (shell-quote-argument 
	       (squeak-latest-image 
		(expand-file-name "squeak/muO" surmulot-directory)
		2)))
      (get-buffer-create "*squeak process*")))))

(defun squeak-image-vnum (image-name)
  (read (car (last (split-string (file-name-sans-extension image-name)
				 "\\.")))))

(defun squeak-latest-image (image-name &optional n-last)
  ""
   (let* ((versions 
	   (directory-files 
	    (file-name-directory image-name) 
	    t (format "%s\\.[0-9]+\\.image" 
		      (regexp-quote (file-name-nondirectory image-name)))))
	  (sorted-versions 
	   (sort versions 
		 (lambda (v1 v2) 
		   (< (squeak-image-vnum v1) 
		      (squeak-image-vnum v2))))))
     (if (and versions n-last (> n-last 0))
	 (x-popup-dialog 
	  (selected-frame) 
	  (append '("choose a Squeak image")
		  (mapcar
		   (lambda (s) (cons s s))
		   (append
		    (when (file-exists-p (concat image-name ".image"))  
		      (list (concat image-name ".image")))
		    (last sorted-versions (min n-last (length versions)))))))
       (if (and versions (or (null n-last) 
			     (zerop n-last)))
	   (car (last sorted-versions))
	 (if (file-exists-p (concat image-name ".image"))  
	     (concat image-name ".image")
	   "")))))

(defun manager-start-emacs ()
  (save-window-excursion
    (shell-command 
     (format "%s %s--debug-init -q --load=%s &"
	     (if (eq system-type 'gnu/linux)
		 "emacs"
	       (shell-quote-argument 
		(expand-file-name "emacs/bin/runemacs.exe" surmulot-directory)))
	     (if (and (fboundp 'font-family-list)
		      (member "Consolas" (font-family-list)))
		 "-fn Consolas "
	       "")
	     (shell-quote-argument 
	      (expand-file-name "emacs/surmulot.emacs" surmulot-directory))))
    (get-buffer-create "*emacs process*")))

;;================================================================


;;================================================================

(cua-mode)

(defvar local-ports 
  (with-temp-buffer
    (insert-file-contents 
     (expand-file-name "../localports.ini" default-directory))
    (goto-char (point-min))
    (loop while (re-search-forward "^\\(.*\\)=\\(.*\\)$" nil t)
	  collect (list (match-string 1)
			(read (match-string 2))) into ports
			finally return ports)))
	  
(defvar semaphore-port (cadr (assoc "semaphore-port" local-ports)))

(defvar managers-spec (loop for spec in local-ports 
			    if (not (string= "semaphore-port" (car spec)))
			    collect (list (car spec) nil)))

(defvar separator (make-string 1 11))
(defvar end-separator (make-string 2 11))

(defvar manager-log-p t)
(defun log-on () (setq  manager-log-p t))
(defun log-off () (setq  manager-log-p nil))

(defun short (manager)
  (first (split-string manager "_")))

(defun port (manager)
  (cadr (assoc manager local-ports)))

(defun msocket (manager)
    (nth 1 (assoc manager managers-spec)))

(defun set-msocket (manager socket)
  (setf (nth 1 (assoc manager managers-spec)) socket))

(defun managers () 
  (mapcar 'first managers-spec))

(defun mmessage (&rest args)
  (when manager-log-p
    (save-excursion
      (set-buffer (get-buffer-create "*log*"))
      (goto-char (point-max))
      (insert (propertize (apply 'format args) 
			  'face `(:foreground ,(mmessage-color))) 
	      "\n"))))

(defun mmessage-color-maker ()
  (lexical-let ((colors '("chartreuse1" "LightGoldenrod2"))
		(index 0))
    (lambda ()
      (setq index (- 1 index))
      (nth index colors))))

(fset 'mmessage-color (mmessage-color-maker))

(defun manager-login (manager connection message)
;  (mmessage "%s login" (short manager))
  (unless (and (msocket manager)
	       (eq 'open (process-status (msocket manager))))
    (process-put connection 'pending-input "") 
    (process-put connection 'manager manager)
    (set-msocket manager connection)))

(defun manager-sentinel (connection event)
  (mmessage "\n%s: %s" (short (process-get connection 'manager)) event))

(defun manager-filter (connection input)
  (let ((pinput (concat (process-get connection 'pending-input) input)))
    (process-put connection 'pending-input pinput)
    (while (and
	    (string-match end-separator pinput)
	    (string-match (concat "\\(.+?\\)" end-separator "\\(.*\\)") pinput))
      (process-put connection 'pending-input
		   (match-string-no-properties 2 pinput))
      (apply 'manager-dispatch connection 
	     (split-string (match-string-no-properties 1 pinput) separator))
      (setq pinput (process-get connection 'pending-input)))))

(defun manager-dispatch (connection data manager type id)
  (let ((sender (process-get connection 'manager)))
    (if (string= manager "super_listener")
	(manager-handle data id sender)
      (manager-send manager data sender type id))))

(defun manager-ping (data id manager)
  (let ((answer (if (and (msocket data)
			 (eq 'open (process-status (msocket data))))
		    "true"
		  "false")))
    (mmessage "Q%s (%s pings %s)" id (short manager) (short data))
    (manager-send manager answer "super_listener" "A" id)))

(defun manager-handle (data id manager)
  (if (member data (managers))
      (manager-ping data id manager)
    (mmessage "Q%s evaluating:\n%s" id data)
    (let* ((answer (prin1-to-string (eval (read data))))
	   (clear-answer answer))
      (when (string= manager "squeak_manager")
	(setq answer (base64-encode-string
		      (encode-coding-string answer 'iso-latin-1-mac))))
      (manager-send manager answer
		    "super_listener" "A" id clear-answer))))
    
(defun manager-send (manager data from-manager type id &optional display)
  (mmessage (concat type id
		    (format "[%s>%s] " (short from-manager) (short manager))
		   (if (<= (length data) 50)
		       (format "%60.60s" (or display data))
		     (format "%58.58s..." (or display data)))))
  (message (concat "\n" type id
		   "\n" (or display data)
		   "\n to:" (short manager)
		   " from:" (short from-manager) "\n"))
  (when (msocket manager) 
    (process-send-string (msocket manager) 
			 (concat data separator 
				 from-manager separator 
				 type separator id
				 end-separator "\n"))))


;;================================================================

(defun clean-command (command)
  (if (eq system-type 'windows-nt)
      (loop for ss in (split-string command "\"")
	    with s = ""
	    with doit = t
	    do (setq doit (not doit)
		     s (concat s 
			       (replace-regexp-in-string 
				"/" "\\\\" 
				(if doit 
				    (or (shortfn ss) (format "\"%s\"" ss))
				  ss))))
	    finally return s)
    command))

(defun shortfn (string)
  (if (not (file-name-absolute-p string))
      string
    (let (short)
      (condition-case nil
	  (unless  (file-exists-p string)
	    (with-temp-file string)
	    (setq short (w32-short-file-name string))
	    (delete-file short))
	(error nil))
      (or short (w32-short-file-name string)))))

(defun shell-do (command)
  (with-surmulot-environment 
   (let ((command (clean-command command)))
     (mmessage "Shell command:\n%s" command)
     (shell-command-to-string command))))

(defun shell-async-do (command)
  (with-surmulot-environment 
   (let ((command (concat (clean-command command) " &")))
     (mmessage "Shell command:\n%s" command)
     (save-window-excursion
       (shell-command command
		      (generate-new-buffer "*async shell command*")))
     (shell-async-clean))))

(defun shell-async-clean ()
  (dolist (b (buffer-list))
    (when (and (string-match "async" (buffer-name b))
	       (null (get-buffer-process b)))
      (kill-buffer b))))

;;================================================================

(defun manager-initialize-ok-p (&rest else-do)
  (let (semaphore)
    (if (setq semaphore
	      (condition-case nil
		  (open-network-stream "ping" nil "localhost" semaphore-port)
		(error nil)))
	(progn
	  (dolist (action else-do)
	    (process-send-string semaphore (symbol-name action)))
	  (kill-emacs))
      (iconify-frame)
      (setq frame-title-format "Surmulot Manager")
      (tool-bar-mode -1)
      (menu-bar-mode -1)
      (switch-to-buffer (get-buffer-create "*log*")))))

(defun semaphore-filter (connection input)
  (mmessage input)
  (funcall (intern input)))

(defun manager-start-with-emacs ()
  (manager-start 'manager-start-emacs))
(defun manager-start-with-muO ()
  (manager-start 'manager-start-muO))
(defun manager-start-with-surmulot ()
  (manager-start 'manager-start-emacs 'manager-start-muO))

(defun manager-start (&rest else-do)
  (apply 'manager-initialize-ok-p else-do)
  (set-process-filter
   (make-network-process :name "semaphore" :server t 
			 :host 'local :service semaphore-port)
   'semaphore-filter)
  (mmessage " ")
  (mmessage "Surmulot TCP/IP manager v2.3")
  (mmessage "============================")
  (mmessage " ")
  (dolist (mspec managers-spec)
    (let* ((name (car mspec))
	   (port (port name)))
      (set-process-filter
       (make-network-process :name name :server t :host 'local 
		             :service port 
			     :log `(lambda (s c m) (manager-login ,name c m))
			     :sentinel 'manager-sentinel)
       'manager-filter)))
  (mapcar 'funcall else-do))

(setq frame-title-format "Surmulot Manager")

(condition-case nil
    (when (eq system-type 'windows-nt)
      (set-default-font "Consolas 10"))
  (error nil))