;;; --------------------------------------------------------------------------
;;; File: with-wish.lisp    
;;; --------------------------------------------------------------------------
;;; Last Changed: Fri Mar 22 22:07:07 1996
;;; --------------------------------------------------------------------------
;;;
;;; This file is part of the Plopp! assistance planning system.
;;;
;;; Copyright (c) 1995, Matthias Lindner
;;;                     FG Intellektik, FB Informatik
;;;                     Technische Hochschule Darmstadt
;;;                     Germany
;;;
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted, as long as this copyright notice
;;; is left intact.
;;; 
;;; This software is made available AS IS, and the author makes no warranty
;;; about the software, its performance or its conformity to any specification.
;;; 
;;; Suggestions, comments and requests for improvements are welcome
;;; and should be mailed to matthias@intellektik.informatik.th-darmstadt.de
;;; 
;;; --------------------------------------------------------------------------
;;; HISTORY
;;;
;;;  6/04/95 Matthias Lindner (matthias) at plopp   
;;;   File Created
;;; 
;;; --------------------------------------------------------------------------

(in-package "USER")

#-:KCL
(defpackage WISH
  (:use LISP #+:ALLEGRO EXCL #+:LUCID LCL)
  (:shadowing-import-from USER TEST-WISH)
  (:export "*WISH*"
	   "*WISH-PROG*"
	   "*WISH-ARGS*"
	   "*WISH-EXIT-MSG*"
	   "*WISH-LISTENER*"
	   "SEND-TO-WISH"
	   "WITH-WISH"
	   "WITH-OUTPUT-TO-WISH"
	   "LISTEN-TO-WISH"
	   "DEFAULT-WISH-LISTENER"))

#+:KCL
(eval-when (load eval compile)
  (unless (find-package "WISH")
    'TEST-WISH
    (make-package "WISH")
    (in-package "WISH")
    (shadowing-import '(USER::TEST-WISH))
    (export (mapcar #'intern '("*WISH*"
			       "*WISH-PROG*"
			       "*WISH-ARGS*"
			       "*WISH-EXIT-MSG*"
			       "*WISH-LISTENER*"
			       "SEND-TO-WISH"
			       "WITH-WISH"
			       "WITH-OUTPUT-TO-WISH"
			       "LISTEN-TO-WISH"
			       "DEFAULT-WISH-LISTENER")))))

(in-package "WISH")

;;; --------------------------------------------------------------------------
;;; ---- Variables -----------------------------------------------------------
;;; --------------------------------------------------------------------------

(defvar *WISH-PROG* "wish"
  "The name of the program, that starts the wish process")

(defvar *WISH-ARGS* (list "-name" "LISP-WISH")
  "A list of command-line arguments to pass to the wish-program")

(defvar *WISH-EXIT-MSG* "after 500 exit"
  "The message we send to the wish process to close it")

(defvar *WISH* NIL
  "The two-way-stream to the wish process")

(defvar *WISH-LISTENER* NIL
  "The current interpreter for data from wish")

;;; --------------------------------------------------------------------------
;;; WITH-WISH (macro)
;;; This macro should be used, to wrap the complete interaction with the
;;; wish process. It creates the process and opens the I/O-pipes, which
;;; are bound within the body to the two-way stream *wish*. 
;;; When exiting from the body the *wish-exit-msg* is sent to the process
;;; to close it down. Do NOT kill the main window of the wish process manually,
;;; without resetting the value of *wish* to nil. Othewise your LISP 
;;; interpreter will probably die from a SIPIPE signal.
;;; --------------------------------------------------------------------------

(defmacro WITH-WISH (&body body)
  `(let ((*wish* (open-process-stream *wish-prog* *wish-args*)))
     (unwind-protect
	 (progn (read-exhausting *wish*)
		,@body)
       (when *wish*
	 (format *wish* "~A~%" *wish-exit-msg*)
	 (force-output *wish*)
	 (close-process-stream *wish*)
	 (setq *wish* NIL)))))

;;; --------------------------------------------------------------------------
;;; READ-EXHAUSTING (function)
;;; A little helper to read non-blocking everything that is availabale on
;;; a stream. 
;;; Returns the input in a string.
;;; --------------------------------------------------------------------------

(defun READ-EXHAUSTING (stream)
  (do ((s nil (cons (read-char-no-hang stream NIL NIL) s)))
      ((and (consp s) (null (car s)))
       (coerce (nreverse (cdr s)) 'string))))

;;; --------------------------------------------------------------------------
;;; SEND-TO-WISH (function)
;;; Sends an arbitrary expression to the wish process and waits for an 
;;; answer, if requested. You can use this to communicate synchronously.
;;; Example:
;;; (with-wish (send-to-wish "puts -nonewline [expr 1 + 2];flush stdout"
;;;	   		     :wait-for-answer t))
;;; => "3"
;;; Returns either the answer from wish or nil if used asynchronously.
;;; --------------------------------------------------------------------------

(defun SEND-TO-WISH (expr &key (wish *wish*) (wait-for-answer NIL))
  (clear-output wish)
  (format wish "~A~%" expr)
  (format wish "flush stdout~%")
  (force-output wish)
  (when wait-for-answer
    (loop (when (listen wish)
	    (return))
	  (sleep 0.1))
    (read-exhausting wish)))

;;; --------------------------------------------------------------------------
;;; WITH-OUTPUT-TO-WISH (macro)
;;; A simple wrapper for a set of output operations to to the wish process
;;; Basically guarantees that all output is flushed when the block is left.
;;; --------------------------------------------------------------------------

(defmacro WITH-OUTPUT-TO-WISH (&body body)
  `(unwind-protect
       (progn (clear-output *wish*)
	      ,@body)
     (when *wish*
       (force-output *wish*))))

;;; --------------------------------------------------------------------------
;;; LISTEN-TO-WISH (procedure)
;;; An interpreter for messages from wish. Waits until input from wish is
;;; available, reads this input and passes it to a listener function, which
;;; should be provided in the first agrument. If the listener returns non-nil
;;; LISTEN-TO-WISH returns, else the cycle starts again, waiting for input.
;;; A simple listener, that prints all read input and returns T iff EXIT
;;; is read is provided as a default for the listener function
;;; An optional second argument is the stream to read from.
;;; A typical application will thus look like this
;;;
;;; (with-wish
;;;  ;;
;;;  ;; Initialize the interface
;;;  ;;
;;;  (with-output-to-wish
;;;   (format *wish* "Tcl/Tk commands for initialisation ('source' e.al))")
;;;   .
;;;   .
;;;   .)
;;;  ;;
;;;  ;; Now sit and wait for the user to klick some buttons and handle these
;;;  ;; clicks with the "my-listener" function
;;;  ;;
;;;  (listen-to-wish 'my-listener))
;;; 
;;; --------------------------------------------------------------------------

(defun LISTEN-TO-WISH (&optional (listener 'default-wish-listener)
				 (wish     *wish*))
  (let ((*wish-listener* listener))
    (loop (do () ((listen wish)) (sleep 0.1))
	  (let ((instr (read-exhausting wish)))
	    (unless (string= instr "")
	      (when (funcall *wish-listener* instr)
		(return))))))
  (values))

;;; --------------------------------------------------------------------------
;;; DEFAULT-WISH-LISTENER (function)
;;; A simple listener function, which can be used as a template for your
;;; customized listener.
;;; --------------------------------------------------------------------------

(defun DEFAULT-WISH-LISTENER (string)
  ;;
  ;; ATTENTION: If the wish process ever sends some unreadable string,
  ;; this will bomb!!!
  ;; Maybe you should catch read-errors here.
  ;;
  (let ((expr (read-from-string string)))
    (cond (;;
	   ;; Dispatch on the type of expression, we've read
	   ;;
	   (symbolp expr)
	   (case expr
	     ;;
	     ;; Insert your callbacks here;
	     ;; e.g.: (MY-MESSAGE (DO-IT-TO-IT))
	     ;;
	     (EXIT (return-from DEFAULT-WISH-LISTENER T))
	     (otherwise (format *terminal-io* "WISH: ~S~%" expr))))
	  ((consp expr)
	   (case (car expr)
	     ;;
	     ;; Messages with arguments are handled like this
	     ;;
	     ;; (FORMAT (apply 'format T (cdr expr)))
	     ;;
	     (otherwise (format *terminal-io* "WISH: ~S~%" expr))))
	  (T (print expr))))
  NIL)

;;; --------------------------------------------------------------------------
;;; TEST-WISH (function)
;;; This is an example interface suitable for testing the above interface
;;; functions.
;;; Returns WISH::OK or an error message.
;;; --------------------------------------------------------------------------

(defun TEST-WISH ()
  (with-wish
   (with-output-to-wish
    ;;
    ;; First do some handshaking
    ;;
    ;;
    (format T "Handshaking ...")
    (format *wish* "puts {OK};flush stdout~%")
    #-(or ALLEGRO LUCID)
    (force-output *wish*)
    #+(or ALLEGRO LUCID)
    (multiple-value-bind (ret err) (ignore-errors (force-output *wish*))
      (when (or ret err)
	(format T "TEST-WISH:WARNING: ~
		   Could not flush *wish-stream during handshake!~%")))
    (let ((r (read-line *wish* NIL "TEST-WISH: No message from wish!")))
      (unless (string-equal "OK" r)
	(close-process-stream *wish*)
	(setq *wish* NIL)
	(return-from TEST-WISH r)))
    (format T " ok.~%")
    ;;
    ;; If we ever make it here, we should be properly connected to wish.
    ;; Now we do the initialisation
    ;;
    (format T "Initializing ...")
    (format *wish* "label .l -text {A simple LISP<->Tcl/Tk Interface}~%")
    (format *wish* "pack .l~%")
    (let ((i 0))
      (dolist (b '("Time" "Version" "QUIT"))
	(format *wish* "button .b~D -text {~A} ~
                                    -command {puts ~A;flush stdout}~%"
		i b b)
	(format *wish* "pack .b~D -fill x -expand yes~%" i)
	(incf i))))
   (format T " done.~%")
   ;;
   ;; The interface should now be ok, so we start listening to wish
   ;; and handle the button messages.
   ;;
   (format T "Listening:~%")
   (listen-to-wish
    #'(lambda (string)
	(format T "~&WISH says: ~A" string)
	(case (intern (string-upcase
		       ;; Drop trailing newlines
		       (string-right-trim (string #\Newline) string)) "WISH")
	  (TIME    (multiple-value-bind (sec min hour)
		       (decode-universal-time (get-universal-time))
		     (send-to-wish
		      (format NIL "puts [tk_dialog .tw {Time} ~
                                   {The current time is~%~D:~2,'0D:~2,'0D} ~
                                   {} {} Ok]" hour min sec)
		   :wait-for-answer t))
		   NIL)
	  (VERSION (send-to-wish
		    (format NIL "puts [tk_dialog .tw {Version} ~
                                 {Lisp Version:~%~A} {} {} Ok]"
			    (lisp-implementation-version))
		   :wait-for-answer t)
		   NIL)
	  (QUIT    (zerop
		    (read-from-string
		     (send-to-wish
		      (format NIL "puts [tk_dialog .tw {Quit?} ~
                                   {Really quit?} {} {} Ok Cancel]")
		      :wait-for-answer t))))
	  (otherwise
	   (format *error-output* "Ooops! Strange message from wish: ~S!~%"
		   string)
	   NIL))))
   (format T "~&Quitting ..."))
  (format T " Done~%")
  'ok)
      

;;; --------------------------------------------------------------------------
;;; ---- Process handling ----------------------------------------------------
;;; --------------------------------------------------------------------------

;;; --------------------------------------------------------------------------
;;; RUN-PROGRAM (function)
;;; This is a simple implementation for LISPs that do not have a function
;;; for running processes (or for those, that have broken ones e.g. KCL)
;;; --------------------------------------------------------------------------
#+:KCL
(defun RUN-PROGRAM (prog &optional arguments)
  (let* ((mkfifo "mknod ~A p")
	 (outf   (do ((pn (symbol-name (gensym "/tmp/kclrpO"))
			  (symbol-name (gensym "/tmp/kclrpO"))))
		     ((null (probe-file pn))
		      (unless (zerop
			       (system (format NIL mkfifo pn)))
			(error "Can't create fifo ~S - sorry!" pn))
		      pn)))
	 (inf    (do ((pn (symbol-name (gensym "/tmp/kclrpI"))
			  (symbol-name (gensym "/tmp/kclrpI"))))
		     ((null (probe-file pn))
		      (unless (zerop
			       (system (format NIL mkfifo pn)))
			(error "Can't create fifo ~S - sorry!" pn))
		      pn)))
	 (cmd    (format NIL "~A~{ ~A~} < ~A > ~A 2>&1 &"
			 prog arguments inf outf))
	 (res  (system (format NIL "/bin/sh -c ~S" cmd))))
    (setq inf  (open inf  :direction :output))
    (setq outf (open outf :direction :input))
    (values (make-two-way-stream outf inf) res)))

;;; --------------------------------------------------------------------------
;;; CLOSE-PROGRAM-STREAM (function)
;;; Close a process stream an free all ressources
;;; --------------------------------------------------------------------------
#+:KCL
(defun CLOSE-PROGRAM-STREAM (stream)
  (let ((inf  (namestring (truename (sys:fp-input-stream stream))))
	(outf (namestring (truename (sys:fp-output-stream stream)))))
    (close stream)
    (zerop (system (format NIL "rm -f ~A ~A" inf outf)))))

;;; --------------------------------------------------------------------------
;;; OPEN-PROCESS-STREAM (function)
;;; Uniform process forker for different LISPs
;;; --------------------------------------------------------------------------

(defun OPEN-PROCESS-STREAM (cmd &optional arguments)
  #+:CLISP    (run-program cmd
			   :arguments arguments
			   :input     :stream
			   :output    :stream)
  #+:LUCID    (lcl:run-program cmd
			       :arguments arguments
			       :input     :stream
			       :output    :stream
			       :wait      NIL)
  #+:ALLEGRO (run-shell-command
	      (format NIL "exec ~A~{ \"~A\"~}" cmd arguments)
	      :input        :stream
	      :output       :stream
	      :wait         NIL)
  #+:KCL     (run-program cmd arguments))

;;; --------------------------------------------------------------------------
;;; CLOSE-PROCESS-STREAM (function)
;;; Close a stream opened by OPEN-PROCESS-STREAM and free all ressources.
;;; --------------------------------------------------------------------------

(defun CLOSE-PROCESS-STREAM (stream)
  #-:KCL (when (typep stream 'two-way-stream)
           (close (two-way-stream-input-stream stream))
           (close (two-way-stream-output-stream stream)))
  #-:KCL (close stream)
  #+:KCL (close-program-stream stream)
  #+:ALLEGRO (sys:os-wait))
  
;;; --------------------------------------------------------------------------
;;; WITH-PROCESS-STREAM (macro)
;;; A wrapper macro. that opens a process and guarantees, that it will be
;;; closed properly.
;;; --------------------------------------------------------------------------

(defmacro WITH-PROCESS-STREAM ((var cmd &rest args) &body body)
  `(let ((,var (open-process-stream ,cmd ',args)))
     (unwind-protect (progn ,@body)
       (close-process-stream ,var))))

;;; --------------------------------------------------------------------------
;;; ---- THE END -------------------------------------------------------------
;;; --------------------------------------------------------------------------
