HOME | 2. 多重評価と変数捕捉 | Common Lisp | 4. 代入を簡略化するマクロ | 書き込む |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; change *gtk-server* according to your system (defvar *gtk-server* "C:\\bin\\gtk-server\\gtk-server.exe") (defvar *gtk-socket* 50000) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; macro with-gtk (defmacro let+fn (fn argvs &body body) (if argvs `(let ((,(first (car argvs)) (,fn ,@(second (car argvs))))) ,@(mapcar #'(lambda (x) `(,fn ,@x)) (nthcdr 2 (car argvs))) (let+fn ,fn ,(cdr argvs) ,@body)) `(progn ,@body))) (defmacro with-gtk (widgets &body body) (let ((socket (gensym))) `(let ((,socket (gtk-start *gtk-server* *gtk-socket*))) ;; gtk is defined in a closure, so that it refers socket. ;; gtk can be used like "format" function (defun gtk (&rest av) (princ (apply #'format nil av) ,socket) (read-line ,socket)) (gtk "gtk_init(NULL, NULL)") (let+fn gtk ,widgets ,@body) (princ "gtk_exit(0)" ,socket)))) ;;; Start the gtk-server, it returns socket ;; (gtk-start *gtk-server* *gtk-socket*) (defun gtk-start (server nsocket) (ext:run-program server :arguments (list (format nil "localhost:~D" nsocket)) :wait nil) (sleep 1) ; Wait a little so the server can initialize (socket:socket-connect nsocket)) ;;;; Design the GUI (with-gtk ((win ("gtk_window_new(0)") ("gtk_window_set_title (~A, This is a title)" win) ("gtk_window_set_default_size (~A, 100, 100)" win) ("gtk_window_set_position (~A, 1)" win)) (table ("gtk_table_new(30, 30, 1 )") ("gtk_container_add (~A,~A)" win table)) (button1 ("gtk_button_new_with_label (Exit)") ("gtk_table_attach_defaults(~A,~A, 17, 28, 20, 25)" table button1)) (button2 ("gtk_button_new_with_label (Print text)") ("gtk_table_attach_defaults (~A,~A, 2, 13, 20, 25)" table button2)) (entry ("gtk_entry_new()") ("gtk_table_attach_defaults (~A,~A, 2, 28, 5, 15)" table entry))) ;;;; body (gtk "gtk_widget_show_all(~A)" win) (terpri) ;;;; This is the mainloop (loop (gtk "gtk_main_iteration()") ; this should be at the top of the loop (if (or (< 0 (parse-integer (gtk "gtk_server_callback(~A)" button1))) (< 0 (parse-integer (gtk "gtk_server_callback(~A)" win)))) (return)) (if (< 0 (parse-integer (gtk "gtk_server_callback(~A)" button2))) (format t "This is the contents: ~A~%" (gtk "gtk_entry_get_text(~A)" entry)))))このプログラムを起動すると右図の様な widget が現れ、entry から入力された文字列を clisp に送ります。 TicTacToe, Eight Queens などもあります。 よろしかったら gtk-server home page をみてください。
;;; getting values from log file (defmacro with-vars-in-log ((logfile . lpandr) &body body) (with-gensyms (in line str1 me0) (let ((vars (mapcar #'(lambda (x) (car x)) lpandr))) `(let ,vars (with-open-file (,in (concat (default-directory) ,logfile) :direction :input) (do ((,line (read-line ,in nil nil) (read-line ,in nil nil))) ((or (and ,@vars) (not ,line))) ,@(mapcar #'(lambda (p) `(when (string-match ,(second p) ,line) (let ((,me0 (match-end 0))) (setq ,(car p) (read-from-string ,(if (cddr p) `(substring ,line ,me0 (position ,(third p) ,line :start (1+ ,me0))) `(substring ,line ,me0))))))) lpandr))) (or (and ,@vars) (error "some variables are not bound.")) ,@body)))) ;;; macro expansion (pme (with-vars-in-log ("lorentz.log" (a "a += +")(b "b += +")(c "c += +")) (list a b c)))[ctrl-j] (let (a b c) (with-open-file (#:G1 (concat (default-directory) "lorentz.log") :direction :input) (do ((#:G2 (read-line #:G1 nil nil) (read-line #:G1 nil nil))) ((or (and a b c) (not #:G2))) (when (string-match "a += +" #:G2) (let ((#:G4 (match-end 0))) (setq a (read-from-string (substring #:G2 #:G4))))) (when (string-match "b += +" #:G2) (let ((#:G4 (match-end 0))) (setq b (read-from-string (substring #:G2 #:G4))))) (when (string-match "c += +" #:G2) (let ((#:G4 (match-end 0))) (setq c (read-from-string (substring #:G2 #:G4))))))) (or (and a b c) (error "some variables are not bound.")) (list a b c))
;;; writing plot file and send it to gnuplot (defmacro with-plot ((pfile) &body body) (with-gensyms (out) `(progn (setq *last-plot* ,pfile) (with-open-file (,out ,pfile :direction :output) ,@(mapcar #'(lambda (x) `(format ,out ,@x)) body)) (gplot ,(format nil "load \"~A\"" pfile))))) ;;; macro expansion (pme (with-plot ("lorentz.plt") ("set title \"Lorentz's attractor\\n a = ~A, b = ~A, c = ~A\"~%" a b c) ("set ticslevel 0~%") ("set xlabel \"X\"~%") ("set ylabel \"Y\"~%") ("set zlabel \"Z\"~%") ("set view 78,221~%") ("splot \"lorentz.dat\" us 2:3:4 t \"trajectory\" w l 1~%")))[ctrl-j] (progn (setq *last-plot* "lorentz.plt") (with-open-file (#:G5 "lorentz.plt" :direction :output) (format #:G5 "set title \"Lorentz's attractor\\n a = ~A, b = ~A, c = ~A\"~%" a b c) (format #:G5 "set ticslevel 0~%") (format #:G5 "set xlabel \"X\"~%") (format #:G5 "set ylabel \"Y\"~%") (format #:G5 "set zlabel \"Z\"~%") (format #:G5 "set view 78,221~%") (format #:G5 "splot \"lorentz.dat\" us 2:3:4 t \"trajectory\" w l 1~%")) (gplot "load \"lorentz.plt\""))
;;; calling an external command with temporary files (defmacro call-with-temp-files (tempfiles cmd er before after) (let ((val (gensym))) `(unwind-protect (let ,(delete nil (mapcar #'(lambda (x) (and x `(,x (make-temp-file-name)))) tempfiles)) ,@before (unless (zerop (call-process ,cmd :input ,(first tempfiles) :output ,(second tempfiles) :error ,(third tempfiles) :show :hide :environ (and (not (si:getenv "HOME")) (list (cons "HOME" (user-homedir-pathname)))) :wait t)) ,er) (let ((,val ,(if after `(progn ,@after)))) ,@(delete nil (mapcar #'(lambda(x) (and x `(and ,x (delete-file ,x :in-does-not-exist :skip)))) tempfiles)) ,val))))) ;;; macro expansion (pme (call-with-temp-files (fin fout nil) (concat *aspell-command* " " op) (error "cannot spawn aspell") ((write-region p1 p2 fin nil *encoding-euc-jp*)) ((aspell-create-hash fout))))[ctrl-j] (unwind-protect (let ((fin (make-temp-file-name)) (fout (make-temp-file-name))) (write-region p1 p2 fin nil *encoding-euc-jp*) (unless (zerop (call-process (concat *aspell-command* " " op) :input fin :output fout :error nil :show :hide :environ (and (not (system:getenv "HOME")) (list (cons "HOME" (user-homedir-pathname)))) :wait t)) (error "cannot spawn aspell")) (let ((#:G6 (progn (aspell-create-hash fout)))) (and fin (delete-file fin :in-does-not-exist :skip)) (and fout (delete-file fout :in-does-not-exist :skip)) #:G6)))
不明な点、不正確な点などがありましたら紫藤まで お知らせいただけたら幸いです。(shido_takafumi@ybb.ne.jp)
HOME | 2. 多重評価と変数捕捉 | Common Lisp | 4. 代入を簡略化するマクロ | 書き込む |