; PS/Tk -- A Portable Scheme Interface to the Tk GUI Toolkit ; Copyright (C) 2008 Kenneth A Dickey ; Copyright (C) 2006-2008 Nils M Holm ; Copyright (C) 2004 Wolf-Dieter Busch ; All rights reserved. ; ; Redistribution and use in source and binary forms, with or without ; modification, are permitted provided that the following conditions ; are met: ; 1. Redistributions of source code must retain the above copyright ; notice, this list of conditions and the following disclaimer. ; 2. Redistributions in binary form must reproduce the above copyright ; notice, this list of conditions and the following disclaimer in the ; documentation and/or other materials provided with the distribution. ; ; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE ; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS ; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ; SUCH DAMAGE. ; ; PS/Tk is based on Chicken/Tk by Wolf-Dieter Busch (2004): ; http://wolf-dieter-busch.de/html/Software/Tools/ChickenTk.htm ; which is in turn based on Scheme_wish by Sven Hartrumpf (1997, 1998): ; http://pi7.fernuni-hagen.de/hartrumpf/scheme_wish.scm ; ; These are the changes that I (Nils) made to turn Chicken/Tk into PS/Tk: ; ; - Removed all Chicken-isms except for PROCESS. ; - All PS/Tk function names begin with TK/ or TK-: ; EVAL-WISH --> TK-EVAL-WISH ; GET-TK-VAR --> TK-GET-VAR ; SET-TK-VAR! --> TK-SET-VAR! ; START-TK --> TK-START ; END-TK --> TK-END ; EVENT-LOOP --> TK-EVENT-LOOP ; - Added TK-DISPATCH-EVENT. ; - Added TK-WAIT-FOR-WINDOW because TK/WAIT returned too early. ; - Removed some unused functions and variables. ; - Replaced keyword lists with property lists. ; - Removed ScrolledText compound widget. ; - Removed :WIDGET-NAME option. ; - Added a PLT Scheme version of RUN-PROGRAM. ; ; Contributions (in order of appearance): ; - Jens Axel Soegaard: PLT Scheme/Windows RUN-PROGRAM. ; - Taylor R Campbell: Scheme48 RUN-PROGRAM, portable GENSYM, and some R5RS ; portability fixes. ; - Jeffrey T. Read: Gambit hacks (RUN-PROGRAM, keyword hack). ; - Marc Feeley: Various versions of RUN-PROGRAM (Bigloo, Gauche, Guile, ; Kawa, Scsh, Stklos), SRFI-88 keyword auto-detection, some bug fixes. ; - David St-Hilaire: suggested catching unspecific value in form->string. ; - Ken Dickey: added Ikarus Scheme ; - Ken Dickey: added Larceny Scheme ; Thank you! ; ; Change Log: ; 2010-07-03 Optional argument to 'start' for inputting name of wish/tclsh ; 2010-06-30 Repackaged for Chicken, removing alternate run-program's. ; 2008-06-22 Added Larceny Scheme support. ; 2008-02-29 Added R6RS (Ikarus Scheme) support, added TTK/STYLE. ; 2007-06-27 Renamed source file to pstk.scm. ; 2007-06-27 Re-factored some large procedures, applied some cosmetics. ; 2007-06-26 FORM->STRING catches unspecific values now, so event handlers ; no longer have to return specific values. ; 2007-06-26 Re-imported the following ports from the processio/v1 snowball: ; Bigloo, Gauche, Guile, Kawa, Scsh, Stklos. ; 2007-06-26 Added auto-detection of SRFI-88 keywords. ; 2007-03-03 Removed callback mutex, because it blocked some redraw ; operations. Use TK-WITH-LOCK to protect critical sections. ; 2007-02-03 Added Tile support: TTK-MAP-WIDGETS, TTK/AVAILABLE-THEMES, ; TTK/SET-THEME. ; 2007-01-20 Added (Petite) Chez Scheme port. ; 2007-01-06 Fix: TK-WAIT-FOR-WINDOW requires nested callbacks. ; 2007-01-05 Added code to patch through fatal TCL messages. ; 2007-01-05 Protected call-backs by a mutex, so accidental double ; clicks, etc cannot mess up program state. ; 2006-12-21 Made FORM->STRING accept '(). ; 2006-12-18 Installing WM_DELETE_WINDOW handler in TK-START now, so it does ; not get reset in TK-EVENT-LOOP. ; 2006-12-18 Made TK-START and TK-END return () instead of # ; (which crashes FORM->STRING). ; 2006-12-12 Fixed some wrong Tcl quotation (introduced by myself). ; 2006-12-09 Added TK/BELL procedure. ; 2006-12-08 Replaced ATOM->STRING by FORM->STRING. ; 2006-12-06 Added TK-WAIT-UNTIL-VISIBLE. ; 2006-12-03 Made more variables local to outer LETREC. ; 2006-12-03 Added Gambit port and keywords hack. ; 2006-12-02 Added Scheme 48 port, portable GENSYM, R5RS fixes. ; 2006-12-02 Added PLT/Windows port. (module pstk (export tk tk-dispatch-event tk-end tk-eval tk-event-loop tk-get-var tk-id->widget tk-set-var! tk-start tk-var tk-wait-for-window tk-wait-until-visible tk-with-lock tk/after tk/appname tk/bell tk/bgerror tk/bind tk/bindtags tk/caret tk/choose-color tk/choose-directory tk/clipboard tk/destroy tk/dialog tk/event tk/focus tk/focus-follows-mouse tk/focus-next tk/focus-prev tk/get-open-file tk/get-save-file tk/grab tk/grid tk/image tk/lower tk/message-box tk/option tk/pack tk/place tk/popup tk/raise tk/scaling tk/selection tk/update tk/useinputmethods tk/wait tk/windowingsystem tk/winfo tk/wm ttk-map-widgets ttk/available-themes ttk/set-theme ttk/style ) (import scheme chicken posix) (use posix) (define *wish-program* "tclsh8.5") (define *wish-debug-input* #f) (define *wish-debug-output* #f) (define *use-keywords?* (or (not (symbol? 'text:)) (not (symbol? ':text)) (string=? "text" (symbol->string 'text:)) (string=? "text" (symbol->string ':text)))) (define tk #f) (define tk-dispatch-event #f) (define tk-end #f) (define tk-eval #f) (define tk-event-loop #f) (define tk-get-var #f) (define tk-id->widget #f) (define tk-set-var! #f) (define tk-start #f) (define tk-var #f) (define tk-wait-for-window #f) (define tk-wait-until-visible #f) (define tk-with-lock #f) (define tk/after #f) (define tk/appname #f) (define tk/bell #f) (define tk/bgerror #f) (define tk/bind #f) (define tk/bindtags #f) (define tk/caret #f) (define tk/choose-color #f) (define tk/choose-directory #f) (define tk/clipboard #f) (define tk/destroy #f) (define tk/dialog #f) (define tk/event #f) (define tk/focus #f) (define tk/focus-follows-mouse #f) (define tk/focus-next #f) (define tk/focus-prev #f) (define tk/get-open-file #f) (define tk/get-save-file #f) (define tk/grab #f) (define tk/grid #f) (define tk/image #f) (define tk/lower #f) (define tk/message-box #f) (define tk/option #f) (define tk/pack #f) (define tk/place #f) (define tk/popup #f) (define tk/raise #f) (define tk/scaling #f) (define tk/selection #f) (define tk/update #f) (define tk/useinputmethods #f) (define tk/wait #f) (define tk/windowingsystem #f) (define tk/winfo #f) (define tk/wm #f) (define ttk-map-widgets #f) (define ttk/available-themes #f) (define ttk/set-theme #f) (define ttk/style #f) (letrec ((nl (string #\newline)) (wish-input #f) (wish-output #f) (tk-is-running #f) (tk-ids+widgets '()) (tk-widgets '()) (commands-invoked-by-tk '()) (inverse-commands-invoked-by-tk '()) (in-callback #f) (callback-mutex #t) (ttk-widget-map '()) (tk-init-string (apply string-append (apply append (map (lambda (s) (list s (string #\newline))) '("package require Tk" "if {[package version tile] != \"\"} {" " package require tile" "}" "" "namespace eval AutoName {" " variable c 0" " proc autoName {{result \\#\\#}} {" " variable c" " append result [incr c]" " }" " namespace export *" "}" "" "namespace import AutoName::*" "" "proc callToScm {callKey args} {" " global scmVar" " set resultKey [autoName]" " puts \"(call $callKey \\\"$resultKey\\\" $args)\"" " flush stdout" " vwait scmVar($resultKey)" " set result $scmVar($resultKey)" " unset scmVar($resultKey)" " set result" "}" "" "proc tclListToScmList {l} {" " switch [llength $l] {" " 0 {" " return ()" " }" " 1 {" " if {[string range $l 0 0] eq \"\\#\"} {" " return $l" " }" " if {[regexp {^[0-9]+$} $l]} {" " return $l" " }" " if {[regexp {^[.[:alpha:]][^ ,\\\"\\'\\[\\]\\\\;]*$} $l]} {" " return $l" " }" " set result \\\"" " append result\\" " [string map [list \\\" \\\\\\\" \\\\ \\\\\\\\] $l]" " append result \\\"" "" " }" " default {" " set result {}" " foreach el $l {" " append result \" \" [tclListToScmList $el]" " }" " set result [string range $result 1 end]" " return \"($result)\"" " }" " }" "}" "" "proc evalCmdFromScm {cmd {properly 0}} {" " if {[catch {" " set result [uplevel \\#0 $cmd]" " } err]} {" " puts \"(error \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $err]\\\")\"" " } elseif $properly {" " puts \"(return [tclListToScmList $result])\"" " } else {" " puts \"(return \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $result]\\\")\"" " }" " flush stdout" "}"))))) (report-error (lambda (x) (newline) (display x) (newline))) (run-program (lambda (program) (call-with-values (lambda () (process (string-append "/bin/sh -c \"exec " program " 2>&1\""))) (lambda (in out pid) (list in out))))) (flush-output-port flush-output) (flush-wish (lambda () (flush-output-port wish-input))) (option? (lambda (x) (or (and *use-keywords?* (keyword? x)) (and (symbol? x) (let* ((s (symbol->string x)) (n (string-length s))) (char=? #\: (string-ref s (- n 1)))))))) (make-option-string (lambda (x) (if (and *use-keywords?* (keyword? x)) (string-append " -" (keyword->string x)) (let ((s (symbol->string x))) (string-append " -" (substring s 0 (- (string-length s) 1))))))) (improper-list->string (lambda (a first) (cond ((pair? a) (cons (string-append (if first "" " ") (form->string (car a))) (improper-list->string (cdr a) #f))) ((null? a) '()) (else (list (string-append " . " (form->string a))))))) (form->string (lambda (x) (cond ((eq? #t x) "#t") ((eq? #f x) "#f") ((number? x) (number->string x)) ((symbol? x) (symbol->string x)) ((string? x) x) ((null? x) "()") ((pair? x) (string-append "(" (apply string-append (improper-list->string x #t)) ")")) ((eof-object? x) "#") (else "#")))) (string-translate (lambda (s map) (letrec ((s-prepend (lambda (s1 s2) (cond ((null? s1) s2) (else (s-prepend (cdr s1) (cons (car s1) s2)))))) (s-xlate (lambda (s r) (cond ((null? s) (reverse r)) (else (let ((n (assv (car s) map))) (cond (n (s-xlate (cdr s) (s-prepend (string->list (cdr n)) r))) (else (s-xlate (cdr s) (cons (car s) r)))))))))) (list->string (s-xlate (string->list s) '()))))) (string-trim-left (lambda (str) (cond ((string=? str "") "") ((string=? (substring str 0 1) " ") (string-trim-left (substring str 1 (string-length str)))) (else str)))) (get-property (lambda (key args . thunk) (cond ((null? args) (cond ((null? thunk) #f) (else ((car thunk))))) ((eq? key (car args)) (cond ((pair? (cdr args)) (cadr args)) (else (report-error (list 'get-property key args))))) ((or (not (pair? (cdr args))) (not (pair? (cddr args)))) (report-error (list 'get-property key args))) (else (apply get-property key (cddr args) thunk))))) (tcl-true? (let ((false-values `(0 "0" 'false "false" ,(string->symbol "0")))) (lambda (obj) (not (memv obj false-values))))) (widget? (lambda (x) (and (memq x tk-widgets) #t))) (call-by-key (lambda (key resultvar . args) (cond ((and in-callback (pair? callback-mutex)) #f) (else (set! in-callback (cons #t in-callback)) (let* ((cmd (get-property key commands-invoked-by-tk)) (result (apply cmd args)) (str (string-trim-left (scheme-arglist->tk-argstring (list result))))) (set-var! resultvar str) (set! in-callback (cdr in-callback)) result))))) (gen-symbol (let ((counter 0)) (lambda () (let ((sym (string-append "g" (number->string counter)))) (set! counter (+ counter 1)) (string->symbol sym))))) (widget-name (lambda (x) (let ((name (form->string x))) (cond ((member name ttk-widget-map) (string-append "ttk::" name)) (else name))))) (make-widget-by-id (lambda (type id . options) (let ((result (lambda (command . args) (case command ((get-id) id) ((create-widget) (let* ((widget-type (widget-name (car args))) (id-prefix (if (string=? id ".") "" id)) (id-suffix (form->string (gen-symbol))) (new-id (string-append id-prefix "." id-suffix)) (options (cdr args))) (eval-wish (string-append widget-type " " new-id (scheme-arglist->tk-argstring options))) (apply make-widget-by-id (append (list widget-type new-id) options)))) ((configure) (cond ((null? args) (eval-wish (string-append id " " (form->string command)))) ((null? (cdr args)) (eval-wish (string-append id " " (form->string command) (scheme-arglist->tk-argstring args)))) (else (eval-wish (string-append id " " (form->string command) (scheme-arglist->tk-argstring args))) (do ((args args (cddr args))) ((null? args) '()) (let ((key (car args)) (val (cadr args))) (cond ((null? options) (set! options (list key val))) ((not (memq key options)) (set! options (cons key (cons val options)))) (else (set-car! (cdr (memq key options)) val)))))))) ((cget) (let ((key (car args))) (get-property key options (lambda () (eval-wish (string-append id " cget" (scheme-arglist->tk-argstring args))))))) ((call exec) (eval-wish (string-trim-left (scheme-arglist->tk-argstring args)))) (else (eval-wish (string-append id " " (form->string command) (scheme-arglist->tk-argstring args)))))))) (set! tk-widgets (cons result tk-widgets)) (set! tk-ids+widgets (cons (string->symbol id) (cons result tk-ids+widgets))) result))) (scheme-arg->tk-arg (lambda (x) (cond ((eq? x #f) " 0") ((eq? x #t) " 1") ((eq? x '()) " {}") ((option? x) (make-option-string x)) ((widget? x) (string-append " " (x 'get-id))) ((and (pair? x) (procedure? (car x))) (let* ((lambda-term (car x)) (rest (cdr x)) (l (memq lambda-term inverse-commands-invoked-by-tk)) (keystr (if l (form->string (cadr l)) (symbol->string (gen-symbol))))) (if (not l) (let ((key (string->symbol keystr))) (set! inverse-commands-invoked-by-tk (cons lambda-term (cons key inverse-commands-invoked-by-tk))) (set! commands-invoked-by-tk (cons key (cons lambda-term commands-invoked-by-tk))))) (string-append " {callToScm " keystr (scheme-arglist->tk-argstring rest) "}"))) ((procedure? x) (scheme-arglist->tk-argstring `((,x)))) ((list? x) (cond ((eq? (car x) '+) (let ((result (string-trim-left (scheme-arglist->tk-argstring (cdr x))))) (cond ((string=? result "") " +") ((string=? "{" (substring result 0 1)) (string-append " {+ " (substring result 1 (string-length result)))) (else (string-append " +" result))))) ((and (= (length x) 3) (equal? (car x) (string->symbol "@")) (number? (cadr x)) (number? (caddr x))) (string-append "@" (number->string (cadr x)) "," (number->string (caddr x)))) (else (string-append " {" (string-trim-left (scheme-arglist->tk-argstring x)) "}")))) ((pair? x) (string-append " " (form->string (car x)) "." (form->string (cdr x)))) ((string? x) (if (string->number x) (string-append " " x) (string-append " \"" (string-translate x '((#\\ . "\\\\") (#\" . "\\\"") (#\[ . "\\u005b") (#\] . "\\]") (#\$ . "\\u0024") (#\{ . "\\{") (#\} . "\\}"))) "\""))) (else (string-append " " (form->string x)))))) (scheme-arglist->tk-argstring (lambda (args) (apply string-append (map scheme-arg->tk-arg args)))) (make-wish-func (lambda (tkname) (let ((name (form->string tkname))) (lambda args (eval-wish (string-append name (scheme-arglist->tk-argstring args))))))) (read-wish (lambda () (let ((term (read wish-output))) (cond (*wish-debug-output* (display "wish->scheme: ") (write term) (newline))) term))) (wish (lambda arguments (for-each (lambda (argument) (cond (*wish-debug-input* (display "scheme->wish: ") (display argument) (newline))) (display argument wish-input) (newline wish-input) (flush-wish)) arguments))) (start-wish (lambda () (let ((result (run-program *wish-program*))) (set! wish-input (cadr result)) (set! wish-output (car result))))) (read-line (lambda (in) (letrec ((collect-chars (lambda (c s) (cond ((or (eof-object? c) (char=? c #\newline)) (apply string (reverse s))) (else (collect-chars (read-char in) (cons c s)))))) (first-char (read-char in))) (cond ((eof-object? first-char) first-char) (else (collect-chars first-char '())))))) (eval-wish (lambda (cmd) (wish (string-append "evalCmdFromScm \"" (string-translate cmd '((#\\ . "\\\\") (#\" . "\\\""))) "\"")) (let again ((result (read-wish))) (cond ((not (pair? result)) (report-error (string-append "An error occurred inside Tcl/Tk" nl " --> " (form->string result) " " (read-line wish-output)))) ((eq? (car result) 'return) (cadr result)) ((eq? (car result) 'call) (apply call-by-key (cdr result)) (again (read-wish))) ((eq? (car result) 'error) (report-error (string-append "An error occurred inside Tcl/Tk" nl " " cmd nl " --> " (cadr result)))) (else (report-error result)))))) (id->widget (lambda (id) (get-property (string->symbol (form->string id)) tk-ids+widgets (lambda () (if (tcl-true? (tk/winfo 'exists id)) (make-widget-by-id (tk/winfo 'class id) (form->string id)) #f))))) (var (lambda (varname) (set-var! varname "") (string-append "::scmVar(" (form->string varname) ")"))) (get-var (lambda (varname) (eval-wish (string-append "set ::scmVar(" (form->string varname) ")")))) (set-var! (lambda (varname value) (eval-wish (string-append "set ::scmVar(" (form->string varname) ") {" (form->string value) "}")))) (start (lambda args ; optional argument allows user to input name of wish program (if (and (not (null? args)) (= 1 (length args))) (set! *wish-program* (car args))) (start-wish) (wish tk-init-string) (set! tk-ids+widgets '()) (set! tk-widgets '()) (set! in-callback #f) (set! tk (make-widget-by-id 'toplevel "." 'class: 'Wish)) (set! commands-invoked-by-tk '()) (set! inverse-commands-invoked-by-tk '()) (tk/wm 'protocol tk 'WM_DELETE_WINDOW end-tk))) (end-tk (lambda () (set! tk-is-running #f) (wish "after 200 exit"))) (dispatch-event (lambda () (let ((tk-statement (read-wish))) (if (and (list? tk-statement) (eq? (car tk-statement) 'call)) (apply call-by-key (cdr tk-statement)))))) (loop (lambda () (cond ((not tk-is-running) (if wish-output (tk/wm 'protocol tk 'WM_DELETE_WINDOW '()))) (else (dispatch-event) (loop))))) (event-loop (lambda () (set! tk-is-running #t) (loop))) (map-ttk-widgets (lambda (x) (cond ((eq? x 'all) (set! ttk-widget-map '("button" "checkbutton" "radiobutton" "menubutton" "label" "entry" "frame" "labelframe" "scrollbar" "notebook" "progressbar" "combobox" "separator" "scale" "sizegrip" "treeview"))) ((eq? x 'none) (set! ttk-widget-map '())) ((pair? x) (set! ttk-widget-map (map form->string x))) (else (report-error (string-append "Argument to TTK-MAP-WIDGETS must be " "ALL, NONE or a list of widget types.")))))) (string-split (lambda (c s) (letrec ((split (lambda (i k tmp res) (cond ((= i k) (if (null? tmp) res (cons tmp res))) ((char=? (string-ref s i) c) (split (+ i 1) k "" (cons tmp res))) (else (split (+ i 1) k (string-append tmp (string (string-ref s i))) res)))))) (reverse (split 0 (string-length s) "" '()))))) (ttk-available-themes (lambda () (string-split #\space (eval-wish "ttk::style theme names")))) (do-wait-for-window (lambda (w) (dispatch-event) (cond ((equal? (tk/winfo 'exists w) "0") '()) (else (do-wait-for-window w))))) (wait-for-window (lambda (w) (let ((outer-allow callback-mutex)) (set! callback-mutex #t) (do-wait-for-window w) (set! callback-mutex outer-allow)))) (wait-until-visible (lambda (w) (tk/wait 'visibility w))) (lock! (lambda () (set! callback-mutex (cons callback-mutex #t)))) (unlock! (lambda () (if (pair? callback-mutex) (set! callback-mutex (cdr callback-mutex))))) (with-lock (lambda (thunk) (lock!) (thunk) (unlock!)))) (set! tk-eval eval-wish) (set! tk-id->widget id->widget) (set! tk-var var) (set! tk-get-var get-var) (set! tk-set-var! set-var!) (set! tk-start start) (set! tk-end end-tk) (set! tk-dispatch-event dispatch-event) (set! tk-event-loop event-loop) (set! tk-wait-for-window wait-for-window) (set! tk-wait-until-visible wait-until-visible) (set! tk-with-lock with-lock) (set! tk/after (make-wish-func 'after)) (set! tk/bell (make-wish-func 'bell)) (set! tk/update (make-wish-func 'update)) (set! tk/clipboard (make-wish-func 'clipboard)) (set! tk/bgerror (make-wish-func 'bgerror)) (set! tk/bind (make-wish-func 'bind)) (set! tk/bindtags (make-wish-func 'bindtags)) (set! tk/destroy (make-wish-func 'destroy)) (set! tk/event (make-wish-func 'event)) (set! tk/focus (make-wish-func 'focus)) (set! tk/grab (make-wish-func 'grab)) (set! tk/grid (make-wish-func 'grid)) (set! tk/image (make-wish-func 'image)) (set! tk/lower (make-wish-func 'lower)) (set! tk/option (make-wish-func 'option)) (set! tk/pack (make-wish-func 'pack)) (set! tk/place (make-wish-func 'place)) (set! tk/raise (make-wish-func 'raise)) (set! tk/selection (make-wish-func 'selection)) (set! tk/winfo (make-wish-func 'winfo)) (set! tk/wm (make-wish-func 'wm)) (set! tk/choose-color (make-wish-func "tk_chooseColor")) (set! tk/choose-directory (make-wish-func "tk_chooseDirectory")) (set! tk/dialog (make-wish-func "tk_dialog")) (set! tk/get-open-file (make-wish-func "tk_getOpenFile")) (set! tk/get-save-file (make-wish-func "tk_getSaveFile")) (set! tk/message-box (make-wish-func "tk_messageBox")) (set! tk/focus-follows-mouse (make-wish-func "tk_focusFollowsMouse")) (set! tk/focus-next (make-wish-func "tk_focusNext")) (set! tk/focus-prev (make-wish-func "tk_focusPrev")) (set! tk/popup (make-wish-func "tk_popup")) (set! tk/wait (lambda args (make-wish-func 'tkwait))) (set! tk/appname (make-wish-func "tk appname")) (set! tk/caret (make-wish-func "tk caret")) (set! tk/scaling (make-wish-func "tk scaling")) (set! tk/useinputmethods (make-wish-func "tk useinputmethods")) (set! tk/windowingsystem (make-wish-func "tk windowingsystem")) (set! ttk/available-themes ttk-available-themes) (set! ttk/set-theme (make-wish-func "ttk::style theme use")) (set! ttk/style (make-wish-func "ttk::style")) (set! ttk-map-widgets map-ttk-widgets)) )