Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv14617 Modified Files: callback.lisp demos.lisp Log Message: Not sure what I did! There is still a problem with text edit items, tho. Date: Wed Sep 29 05:09:59 2004 Author: ktilton Index: cell-cultures/celtic/callback.lisp diff -u cell-cultures/celtic/callback.lisp:1.3 cell-cultures/celtic/callback.lisp:1.4 --- cell-cultures/celtic/callback.lisp:1.3 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/callback.lisp Wed Sep 29 05:09:59 2004 @@ -61,6 +61,53 @@ (defun peek-char-no-hang (stream) (and (listen stream) (peek-char t stream))) +;;;<<<<<<< callback.lisp +;;;(defun peek-char-no-hang (stream) +;;; (and (listen stream) (peek-char nil stream))) +;;; +;;;(defun tk-eval-list (form$) +;;; ; +;;; ; clear stdin +;;; ; +;;; (trc "tk-eval-list > entry w eval form:" form$) +;;; (loop while (peek-char-no-hang *w*) +;;; do (if (eql #\( (peek-char t *w*)) +;;; (let ((msg (read *w*))) +;;; (trc "tk-eval-list > buffer not empty:" msg) +;;; (when (eql 'callback (first msg)) +;;; (trc "tk-eval-list > tending to callback:" (rest msg)) +;;; (dispatch-callback (rest msg)))) +;;; (c-break "tk-eval-list error 1: ~a" (read-line *w*)))) +;;; ; +;;; (trc "tk-eval-list > buffer clear, now evaluating (in Tk):" form$) +;;; ; +;;; (tk-send +;;; (format nil "puts -nonewline {(};puts -nonewline [~a];puts {)};flush stdout" +;;; form$)) +;;; ; +;;; ; retrieve result +;;; ; +;;; (if (eql #\( (peek-char t *w* nil nil)) +;;; (let ((*readtable* (copy-readtable))) +;;; (set-macro-character #\} (get-macro-character #\))) +;;; (set-macro-character #\{ +;;; #'(lambda (s c1) +;;; (declare (ignore c1)) +;;; (read-delimited-list #\} s t))) +;;; (return-from tk-eval-list (eko ("tk-eval-list > result:") +;;; (read *w*)))) +;;; (if (peek-char t *w* nil nil) +;;; (c-break "tk-eval-list error 2: ~a" (read-line *w*)) +;;; (trc "looks like wish exited")))) +;;; +;;;(def-c-output command ((self widget)) +;;; (when (and new-value (^command-is-callback)) +;;; (configure self "-command" +;;; (format nil +;;; "puts {(callback ~a)};flush stdout; list" ;; list cuz Tk feeds args to some +;;; ; widgets' commands and list will consume syntax +;;; (register-callback self "command" new-value))))) + (defun tk-eval-list (self form$) (let* ((id (copy-symbol 'eval-list)) result Index: cell-cultures/celtic/demos.lisp diff -u cell-cultures/celtic/demos.lisp:1.4 cell-cultures/celtic/demos.lisp:1.5 --- cell-cultures/celtic/demos.lisp:1.4 Thu Sep 2 05:19:16 2004 +++ cell-cultures/celtic/demos.lisp Wed Sep 29 05:09:59 2004 @@ -33,6 +33,27 @@ (defmodel all (window) () (:default-initargs +;;;<<<<<<< demos.lisp +;;; :md-value (c? (let ((ff (tk-eval-list "font families"))) +;;; (assert (consp ff)) +;;; ff)) +;;; :pady 2 :padx 4 +;;; :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") +;;; :kids (c? (list +;;; (mk-spinbox :md-name :font-face +;;; :md-value (c-in (car (^md-value))) +;;; :tk-values (c? (md-value .parent))) +;;; (mk-scale :md-name :font-size +;;; :md-value (c-in 14) +;;; :tk-label "Font Size" +;;; :from 7 :to 24 +;;; :orient 'horizontal) +;;; (mk-label :text "Four score and seven years ago today" +;;; :wraplength 600 +;;; :font (c? (list ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24} +;;; (md-value (fm^ :font-face)) +;;; (md-value (fm^ :font-size))))))))) + :kids (c? (list (demo-all-menubar)