[gtk-server] Updated script

I've updated demo-stdin.clisp. It does the same as before, but has a 
couple of convenience functions. This makes the code easier to 
understand, and quicker for others to hack.

;; Tested with clisp-2.33.1 on Windows XP
;; Tested with clisp-2.33.2 on Debian 2.4.27-1-386
;;
;; Usage: clisp demo-stdin.clisp
;;
;; Requirements: gtk-server installion in this scripts' directory
;; http://www.gtk-server.org/
;; April 21, 2004 by Jörg Kalsbach.
;;
;; Revised for GTK-server 1.2 October 8, 2004 by PvE.
;; Revised for CLISP and GTK-server 1.2.2 November 3, 2004 by Mark Carter
;; Code cleanup November 9, 2004 by Mark Carter
;;---------------------------------------------------

(setf *gs-socket* (ext:run-program "gtk-server" :arguments '("stdin" "log")
    :input :stream :output :stream :wait t))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CONVENIENCE FUNCTION

(defun send-gs-socket (text)
        (format *gs-socket* "~A~%" text)
          (force-output *gs-socket*))
         

;; Define communication function
(defun gtk (str)
  (send-gs-socket str )
  (write-line (read-line  *gs-socket*)))

(defun as-string (arg)
  (format nil "~A" arg))

(defun join3 (word-list separator)
    (apply #'concatenate 'string
           (first word-list)
           (mapcan #'(lambda(x)(list separator x))
                   (rest word-list))))

(defun create-func (func  args)
  (let (string-args arg-list result)
    (setq string-args (mapcar #'as-string args))
    (setq arg-list (join3 string-args ","))
    (setq result (concatenate 'string func "(" arg-list ")"))
    ;(print result)
    result))

(defun send-gtk (func &rest args)
  (gtk (create-func func args)))

(defun eventp (event widget)
  (= event (parse-integer widget)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DESIGN THE GUI

;; Design the GUI
;; Use new improved method
(send-gtk "gtk_init" "NULL" "NULL")
(setq win (send-gtk "gtk_window_new" 0))
(send-gtk "gtk_window_set_title" win "Clisp Demo")
(send-gtk "gtk_window_set_default_size" win 100 100)
(send-gtk "gtk_window_set_position" win 1)
(setq table (send-gtk "gtk_table_new" 30 30 1))
(send-gtk "gtk_container_add" win table)
(setq button1 (send-gtk "gtk_button_new_with_label" "Exit"))
(send-gtk "gtk_table_attach_defaults" table button1 17 28 20 25)
(setq button2 (send-gtk "gtk_button_new_with_label" "Print text"))
(send-gtk "gtk_table_attach_defaults" table button2 2 13 20 25)
(setq entry (send-gtk "gtk_entry_new"))
(send-gtk "gtk_table_attach_defaults" table entry 2 28 5 15)
(send-gtk "gtk_widget_show_all" win)

;; This is the mainloop
(do ((event 0 (setq event (parse-integer
               (gtk "gtk_server_callback(WAIT)")))))   
    ((or (= event (parse-integer button1)) (= event (parse-integer win))))
  (when (or (eventp event button2) (eventp event entry))
    (setq tmp (gtk (concatenate 'string "gtk_entry_get_text(" entry ")")))
    (print (concatenate 'string "This is the contents: " tmp)))
  )

;; Exit GTK explicitly only with a write
(send-gs-socket "gtk_exit(0)" )

(close *gs-socket*)

;; end of file

Other related posts: