; 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 #<unspecific>
;            (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) "#<eof>")
               (else "#<other>"))))

     (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))
  )