;; scheme_wish: A portable interface between Scheme and Tcl/Tk.
;; It is based on the idea to start a wish process from the Scheme process and
;; to communicate using pipes.
;; scheme_wish has been tested for the following Scheme systems:
;; Gambit, guile, and SCM.
;; version 0.1 - 1998-04-26
;; The current version is available from my home page
;; (http://www.informatik.fernuni-hagen.de/pi7/hartrumpf/).
;; I supply this file without any guarantees and for noncommercial use only.

;; Sven Hartrumpf (C) 1997-1998
;; Applied Computer Science VII, FernUniversität Hagen, 58084 Hagen, Germany
;; email: Sven.Hartrumpf@FernUni-Hagen.de

;; A small example is given in function test-wish.
;; To test it, do the following:
;; 1. Change the six global constants below (if necessary).
;; 2. Uncomment the necessary system-dependent part at the end of this file.
;; 3. Start Scheme.
;; 4. Load this file into Scheme.
;; 5. Type: (test-wish).


;; to do list
;;  - solve bigloo problem


;; global constants
;; One might have to adjust the following six definitions.

; A true value causes all data that flows from Scheme to wish to be written on
; standard output by Scheme.
(define *wish-debug-input #f)

; A true value causes all data that flows from wish to Scheme to be written on
; standard output by Scheme.
(define *wish-debug-output #f)

; The message that will be send to the wish process to close it.
(define *wish-exit-message "after 200 exit")

; The name of the file that will become the input of the wish process.
(define *wish-input-filename "/tmp/scheme_wish_i")

 ; The name of the file that will become the output of the wish process.
(define *wish-output-filename "/tmp/scheme_wish_o")

; The name of the shell command that starts a wish process.
(define *wish-program "wish")


;; global variables

(define *wish-input #f) ; The input stream of the wish process.

(define *wish-output #f) ; The output stream of the wish process.


;; functions
;;   relevant high level functions: start-wish, wish, read-wish, end-wish


;; (end-wish) = unspecified
;; Side effect: terminates the wish process.

(define end-wish (lambda ()
  (wish *wish-exit-message)))


;; (flush-wish) = unspecified
;; Flushes the output to wish.

(define flush-wish (lambda ()
  (flush-output *wish-input)))


;; (read-wish) =
;;   reads a term from wish.

(define read-wish (lambda ()
  (let ((term (read *wish-output)))
    (cond (*wish-debug-output
           (display "wish->scheme: ")
           (write term)
           (newline)))
    term)))


;; (read-wish-chars) =
;;   a line from wish as a list of characters.

(define read-wish-chars (lambda ()
  (read-bytes-until *wish-output '(#\newline))))

(define read-bytes-until (lambda (port stop-characters)
  (let ((char (read-char port)))
    (cond ((eof-object? char)
           '())
          ((memq char stop-characters)
           '())
          (else
           (cons char (read-bytes-until port stop-characters)))))))


;; (run-program p)
;; Side effect: runs the program p with input and output bound to streams.

(define run-program (lambda (program input-filename output-filename)
  (let ((command #f)
        (input #f)
        (output #f)
        (result #f))
    (delete-file-if-exists input-filename)
    ;(write "input file deleted")(newline)
    (delete-file-if-exists output-filename)
    ;(write "output file deleted")(newline)
    (set! result (system (string-append "mknod " input-filename " p")))
    ;(write result)(newline)
    (set! result (system (string-append "mknod " output-filename " p")))
    ;(write result)(newline)
    (set! command (string-append program " < " input-filename " > "
                                 output-filename " 2>&1"))
    ;; 2>&1 associates file descriptor 2 (standard error) with the file associated
    ;; with file descriptor 1.
    (set! result (system (string-append "/bin/sh -c \"" command "\" &")))
    ;(write result)(newline)
    (set! input (open-output-file input-filename))
    ;(write input)(newline)
    (set! output (open-input-file output-filename))
    ;(write output)(newline)
    (list input output))))


;; start-wish
;; Starts a wish process.

(define start-wish (lambda ()
  (let ((result (run-program *wish-program *wish-input-filename *wish-output-filename)))
    (set! *wish-input (car result))
    (set! *wish-output (cadr result)))))


;; test-wish
;; A simple test program.

(define test-wish (lambda ()
  (start-wish)

  ;; Tcl procedures

  ;; scm is used to send something from wish to Scheme.
  (w "
proc scm {s} {
  puts $s
  flush stdout
}
")

  ;; widget definitions

  (w
"
label .l -text \"scheme_wish: A portable interface between Scheme and Tcl/Tk; version 0.1; written by Sven Hartrumpf\"
frame .alternative
radiobutton .alternative.a -borderwidth 2 -relief raised -pady 4 -text \"A\" -value a -variable alternative -command {scm \"(alternative-value $alternative)\"} -foreground #0000af
radiobutton .alternative.b -borderwidth 2 -relief raised -pady 4 -text \"B\" -value b -variable alternative -command {scm \"(alternative-value $alternative)\"} -foreground #2060ff
radiobutton .alternative.c -borderwidth 2 -relief raised -pady 4 -text \"C\" -value c -variable alternative -command {scm \"(alternative-value $alternative)\"} -foreground #60d0ff
button .end -text \"Quit\" -command {scm \"(quit)\"}
")

 ;; widget placements
 (w "
pack .alternative.a .alternative.b .alternative.c -expand yes -fill x -side left
pack .l .alternative .end -expand yes -fill both -side top
")

  (test-wish-handler)
  (end-wish)
  ))

(define test-wish-handler (lambda ()
  (do ((alternative #f)
       (end #f))
      (end alternative)
    (let ((term (read-wish)))
      (display "test-wish-handler: term: ")(write term)(newline)
      (cond ((pair? term)
             (case (car term)
               ((alternative-value)
                (set! alternative (cadr term))
                (display "alternative: ")
                (write alternative)
                (newline))
               ((quit)
                (set! end #t))
               (else
                (display "test-wish-handler: unexpected term: ")
                (write term)
                (newline))))
            ((eof-object? term)
             (display "eof object received")
             (newline)
             (set! end #t))
            (else
             (display "test-wish-handler: unexpected term: ")
             (write term)
             (newline)))))))


;; (wish . l)
;; Sends all arguments to wish's input using display.

(define wish (lambda arguments
  (for-each (lambda (argument)
              (cond (*wish-debug-input
                     (display "scheme->wish: ")
                     (display argument)
                     (newline)))
              (display argument *wish-input)
              (newline *wish-input))
            arguments)
  (flush-wish)))


;; w
;; An abbreviation for wish.

(define w wish)


;; system-dependent functions: delete-file-if-exists, flush-output, system
;; Uncomment the part for the Scheme system you are using.


;; bigloo part: doesn't work because bigloo can't open a pipe as an input file.
;; builtin functions: system

;(define delete-file-if-exists (lambda (name)
;  (delete-file name)))

;(define flush-output flush-output-port)


;; gambit part
;; builtin functions: flush-output

;(define delete-file-if-exists (lambda (name)
;  (system (string-append "/bin/rm -f " name))))

;(define system ##shell-command)


;; guile part
;; builtin functions: system

(define delete-file-if-exists (lambda (name)
  (cond ((file-exists? name)  
         (delete-file name)))))

(define flush-output force-output)


;; SCM part
;; builtin functions: system

;(define delete-file-if-exists delete-file)

;(define flush-output force-output)