(module tk *
  (import scheme chicken)
  (use posix ports data-structures)

(define tk #f)
(define tk-id->widget #f)
(define tk-var #f)
(define get-tk-var #f)
(define set-tk-var! #f)
(define *wish-program* #f)
(define *wish-input-filename* #f)
(define *wish-output-filename* #f)
(define *wish-debug-input* #f)
(define *wish-debug-output* #f)
(define eval-wish #f)
(define start-tk #f)
(define event-loop #f)
(define end-tk #f)
(define create-special-menu-in #f)
(define tk/after #f)
(define tk/update #f)
(define tk/clipboard #f)
(define tk/bgerror #f)
(define tk/bind #f)
(define tk/bindtags #f)
(define tk/destroy #f)
(define tk/event #f)
(define tk/focus #f)
(define tk/grab #f)
(define tk/grid #f)
(define tk/image #f)
(define tk/lower #f)
(define tk/option #f)
(define tk/pack #f)
(define tk/place #f)
(define tk/raise #f)
(define tk/selection #f)
(define tk/winfo #f)
(define tk/wm #f)
(define tk/choosecolor #f)
(define tk/choosedirectory #f)
(define tk/dialog #f)
(define tk/getopenfile #f)
(define tk/getsavefile #f)
(define tk/messagebox #f)
(define tk/focusfollowsmouse #f)
(define tk/focusnext #f)
(define tk/focusprev #f)
(define tk/popup #f)
(define tk/wait #f)
(define tk/console #f)
(define tk/appname #f)
(define tk/caret #f)
(define tk/scaling #f)
(define tk/useinputmethods #f)
(define tk/windowingsystem #f)

(define *wish-output* #f)
(define *wish-input* #f)

(letrec ((nl (string #\newline))
         (*tk-returns-proper-list* #f)
         (*tk-is-running* #f)
         (*tk-init-string*
           "
package require Tk

# --------------------------------

proc echo {args} {
    if {![winfo exists .debugoutput]} {
	toplevel .debugoutput
	pack [text .debugoutput.text]\\
	    -expand yes\\
	    -fill both
    }
    .debugoutput.text insert end $args\\n
    .debugoutput.text see end
}

# --------------------------------

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 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
}

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 setVscrollbarIn {toplevel a b} {
    # set vertical scrollbar in $toplevel (managed by grid)
    if {$toplevel eq \".\"} {
	set scrollbar .vscroll
    } else {
	set scrollbar $toplevel.vscroll
    }
    if {($a == 0.0) && ($b == 1.0)} {
	set code \"catch {grid forget $scrollbar}\"
	after cancel $code
	after 100 $code
    } else {
	grid configure $scrollbar -row 0 -column 1 -sticky news
	set code [list $scrollbar set $a $b]
	after cancel $code
	after idle $code
    }
}

proc setHscrollbarIn {toplevel a b} {
    # set horizontal scrollbar in $toplevel (managed by grid)
    if {$toplevel eq \".\"} {
	set scrollbar .hscroll
    } else {
	set scrollbar $toplevel.hscroll
    }
    if {($a == 0.0) && ($b == 1.0)} {
	set code \"catch {grid forget $scrollbar}\"
	after cancel $code
	after 100 $code
    } else {
	grid configure $scrollbar -row 1 -column 0 -sticky news
	set code [list $scrollbar set $a $b]
	after cancel $code
	after idle $code
    }
}

namespace eval dummy {}

proc scrolledtext {f args} {
    frame $f -class Scrolledtext
    grid [eval text $f.text $args]\\
	[scrollbar $f.vscroll\\
	     -command [list $f.text yview]]\\
	-sticky news
    grid [scrollbar $f.hscroll\\
	      -orient horizontal\\
	      -command [list $f.text xview]]\\
	-sticky news
    grid rowconfigure $f 0 -weight 1
    grid columnconfigure $f 0 -weight 1
    $f.text configure\\
	-xscrollcommand [list setHscrollbarIn $f]\\
	-yscrollcommand [list setVscrollbarIn $f]
    bindtags $f.text [concat $f [bindtags $f.text]]
    rename $f ::dummy::$f
    proc $f {args} [subst {
	eval $f.text \\$args
    }]
    set f
}
")
         (tcl-list->scheme-list
           (lambda (str)
             (with-input-from-string
               (eval-wish
                 (string-append "tclListToScmList {" str "}"))
               read)))
         (evaluated-list-from-tcl
           (lambda (l)
             (cond ((pair? l)
                    (cond ((equal? (car l) 'callToScm)
                           `(,(get-keyword
                                (string->keyword (->string (cadr l)))
                                commands-invoked-by-tk)
                             ,@(cddr l)))
                          (else (map evaluated-list-from-tcl l))))
                   ((tk-id->widget l))
                   (else l))))
         (tk-ids+widgets '())
         (tcl-true?
           (let ((false-values
                   `(0 "0" 'false "false" ,(string->symbol "0"))))
             (lambda (obj) (not (member obj false-values)))))
         (tk-widgets '())
         (widget?
           (lambda (x) (and (memq x tk-widgets) #t)))
         (commands-invoked-by-tk '())
         (inverse-commands-invoked-by-tk '())
         (call-by-key
           (lambda (key resultvar . args)
             (let* ((cmd (get-keyword key commands-invoked-by-tk))
                    (caught (catch (lambda () (apply cmd args))))
                    (success (eq? (car caught) 'success))
                    (failure (not success))
                    (result (if success (cadr caught) ""))
                    (str (cond (failure "")
                               ((equal? result "") "")
                               (else
                                (string-trimleft
                                  (scheme-arglist->tk-argstring
                                    (list result)))))))
               (if failure (print (cadr caught)))
               (set-tk-var! resultvar str)
               result)))
         (make-widget-by-id
           (lambda (type id . options)
             (let* ((self #f)
                    (result
                      (lambda (command . args)
                        (case command
                          ((get-id) id)
                          ((create-widget)
                           (let* ((widget-type (->string (car args)))
                                  (id-prefix (if (string=? id ".") "" id))
                                  (id-suffix
                                    (->string
                                      (get-keyword #:widget-name args gensym)))
                                  (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 " " (->string command))))
                                 ((null? (cdr args))
                                  (eval-wish
                                    (string-append
                                      id
                                      " "
                                      (->string command)
                                      (scheme-arglist->tk-argstring args))))
                                 (else
                                  (eval-wish
                                    (string-append
                                      id
                                      " "
                                      (->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-keyword
                               key
                               options
                               (lambda ()
                                 (eval-wish
                                   (string-append
                                     id
                                     " cget"
                                     (scheme-arglist->tk-argstring args)))))))
                          ((call exec)
                           (eval-wish
                             (string-trimleft
                               (scheme-arglist->tk-argstring args))))
                          (else
                           (eval-wish
                             (string-append
                               id
                               " "
                               (->string command)
                               (scheme-arglist->tk-argstring args))))))))
               (set! tk-widgets (cons result tk-widgets))
               (set! tk-ids+widgets
                 (cons (string->keyword id)
                       (cons result tk-ids+widgets)))
               (set! self result)
               result)))
         (scheme-arglist->tk-argstring
           (lambda (args)
             (apply string-append
                    (map (lambda (x)
                           (cond ((eq? x #f) " 0")
                                 ((eq? x #t) " 1")
                                 ((eq? x '()) " {}")
                                 ((keyword? x)
                                  (string-append " -" (->string x)))
                                 ((widget? x) (string-append " " (x 'get-id)))
                                 ((and (pair? x) (procedure? (car x)))
                                  (let* ((lambda-term (car x))
                                         (rest (cdr x))
                                         (l (member
                                              lambda-term
                                              inverse-commands-invoked-by-tk))
                                         (keystr
                                           (if l
                                             (->string (cadr l))
                                             (symbol->string (gensym)))))
                                    (if (not l)
                                      (let ((keywd (string->keyword keystr)))
                                        (set! inverse-commands-invoked-by-tk
                                          (cons lambda-term
                                                (cons keywd
                                                      inverse-commands-invoked-by-tk)))
                                        (set! commands-invoked-by-tk
                                          (cons keywd
                                                (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-trimleft
                                                   (scheme-arglist->tk-argstring
                                                     (cdr x)))))
                                           (cond ((string=? result "") " +")
                                                 ((string=?
                                                    (substring result 0 1)
                                                    "{")
                                                  (string-append
                                                    " {+ "
                                                    (substring result 1)))
                                                 (else
                                                  (string-append
                                                    " +"
                                                    result)))))
                                        ((and (= (length x) 3)
                                              (equal? (car x) '@)
                                              (number? (cadr x))
                                              (number? (caddr x)))
                                         (string-append
                                           "@"
                                           (number->string (cadr x))
                                           ","
                                           (number->string (caddr x))))
                                        (else
                                         (string-append
                                           " {"
                                           (string-trimleft
                                             (scheme-arglist->tk-argstring x))
                                           "}"))))
                                 ((pair? x)
                                  (string-append
                                    " "
                                    (->string (car x))
                                    "."
                                    (->string (cdr x))))
                                 ((string? x)
                                  (if (string->number x)
                                    (string-append " " x)
                                    (string-append
                                      " \""
                                      (string-translate*
                                        x
                                        '(("\\" . "\\\\") ("\"" . "\\\"")
					  ("[" . "\\u005b") ("]" . "\\]")
					  ("$" . "\\u0024")
					  ("{" . "\\{") ("}" . "\\}")
					  ) )
                                      "\"")))
                                 (else (string-append " " (->string x)))))
                         (tk-args-of args)))))
         (tk-args-of
           (lambda (arglist)
             (do ((arglist arglist (cddr arglist)))
                 ((or (null? arglist)
                      (not (memq (car arglist) '(#:widget-name))))
                  arglist))))
         (string-trimleft
           (lambda (str)
             (cond ((string=? str "") "")
                   ((string=? (substring str 0 1) " ")
                    (string-trimleft (substring str 1)))
                   (else str))))
         (make-wish-func
           (lambda (tkname)
             (let ((name (->string tkname)))
               (lambda args
                 (eval-wish
                   (string-append
                     name
                     (scheme-arglist->tk-argstring args)))))))
         (*wish-exit-message* "after 200 exit")
         (end-wish (lambda () (wish *wish-exit-message*)))
         (flush-wish
           (lambda () (flush-output *wish-input*)))
         (read-wish
           (lambda ()
             (let ((term (read *wish-output*)))
               (cond (*wish-debug-output*
                      (display "wish->scheme: ")
                      (write term)
                      (newline)))
               term)))
         (read-wish-chars
           (lambda ()
             (read-bytes-until *wish-output* '(#\newline))))
         (read-bytes-until
           (lambda (port stop-characters)
             (let ((char (read-char port)))
               (cond ((eof-object? char) '())
                     ((memq char stop-characters) '())
                     (else
                      (cons char
                            (read-bytes-until port stop-characters)))))))
         (wish (lambda arguments
                 (for-each
                   (lambda (argument)
                     (cond (*wish-debug-input*
                            (display "scheme->wish: ")
                            (display argument)
                            (newline)))
                     (display argument *wish-input*)
                     (newline *wish-input*))
                   arguments)
                 (flush-wish)))
         (delete-file-if-exists
           (lambda (name)
             (cond ((file-exists? name) (delete-file name)))))
         (run-program
           (lambda (program . args)
             (let-values
               (((in out pid)
                 (process (string-append program " 2>&1"))))
               (list out in))))
         (start-wish
           (lambda ()
             (let ((result (run-program *wish-program*)))
               (set! *wish-input* (car result))
               (set! *wish-output* (cadr result)))))
         (catch (lambda (thunk)
                  (condition-case
                    (list 'success (thunk))
                    (err ()
                         (list 'error
                               (with-output-to-string
                                 (lambda ()
                                   (print-error-message
                                     err
                                     (current-output-port)))))))))
         (eval-last-line-of
           (lambda (w)
             (string-append
               (with-output-to-string
                 (lambda ()
                   (write (eval (with-input-from-string
                                  (w 'get '(end - 1 lines) '(end - 1 chars))
                                  read)))))
               nl))))
  (set! eval-wish
    (lambda (cmd)
      (wish (string-append
              "evalCmdFromScm \""
              (string-translate*
                cmd
                '(("\\" . "\\\\") ("\"" . "\\\"")))
              "\""
              (if *tk-returns-proper-list* " 1" "")))
      (let again ((result (read-wish)))
        (case (car result)
          ((return)
           (if *tk-returns-proper-list*
             (evaluated-list-from-tcl (cadr result))
             (cadr result)))
          ((call)
           (apply call-by-key (cdr result))
           (again (read-wish)))
          ((error)
           (error (string-append
                    "occurred inside Tcl/Tk"
                    nl
                    " "
                    cmd
                    nl
                    " --> "
                    (cadr result))))
          (else (error result))))))
  (set! tk-id->widget
    (lambda (id)
      (get-keyword
        (string->keyword (->string id))
        tk-ids+widgets
        (lambda ()
          (if (tcl-true? (tk/winfo 'exists id))
            (make-widget-by-id
              (tk/winfo 'class id)
              (->string id))
            #f)))))
  (set! tk-var
    (lambda (varname)
      (set-tk-var! varname "")
      (string-append
        "::scmVar("
        (->string varname)
        ")")))
  (set! get-tk-var
    (lambda (varname)
      (eval-wish
        (string-append
          "set ::scmVar("
          (->string varname)
          ")"))))
  (set! set-tk-var!
    (lambda (varname value)
      (eval-wish
        (string-append
          "set ::scmVar("
          (->string varname)
          ") {"
          (->string value)
          "}"))))
  (set! tk #f)
  (set! start-tk
    (lambda ()
      (start-wish)
      (wish *tk-init-string*)
      (set! tk-ids+widgets '())
      (set! tk-widgets '())
      (set! tk
        (make-widget-by-id 'toplevel "." #:class 'Wish))
      (set! commands-invoked-by-tk '())))
  (set! end-tk
    (lambda () (set! *tk-is-running* #f) (end-wish)))
  (set! event-loop
    (lambda ()
      (tk/wm 'protocol tk 'WM_DELETE_WINDOW end-tk)
      (set! *tk-is-running* #t)
      (do ()
          ((not *tk-is-running*)
           (if *wish-output*
             (tk/wm 'protocol tk 'WM_DELETE_WINDOW '()))
           '())
        (let ((tk-statement (read-wish)))
          (if (and (list? tk-statement)
                   (eq? (car tk-statement) 'call))
            (apply call-by-key (cdr tk-statement)))))))
  (set! tk/after (make-wish-func 'after))
  (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/choosecolor
    (make-wish-func "tk_chooseColor"))
  (set! tk/choosedirectory
    (make-wish-func "tk_chooseDirectory"))
  (set! tk/dialog (make-wish-func "tk_dialog"))
  (set! tk/getopenfile
    (make-wish-func "tk_getOpenFile"))
  (set! tk/getsavefile
    (make-wish-func "tk_getSaveFile"))
  (set! tk/messagebox
    (make-wish-func "tk_messageBox"))
  (set! tk/focusfollowsmouse
    (make-wish-func "tk_focusFollowsMouse"))
  (set! tk/focusnext
    (make-wish-func "tk_focusNext"))
  (set! tk/focusprev
    (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! create-special-menu-in
    (lambda (menu name . options)
      (apply make-widget-by-id
             `("menu"
               ,(string-append
                  (menu 'get-id)
                  "."
                  (->string name))
               ,@options))))
  (set! *wish-debug-input* #f)
  (set! *wish-debug-output* #f)
  (set! *wish-input-filename* "/tmp/scheme_wish_i")
  (set! *wish-output-filename*
    "/tmp/scheme_wish_o")
  (set! *wish-program* "wish")
  (set! tk/console
    (lambda ()
      (let* ((toplevel (tk 'create-widget 'toplevel))
             (output (toplevel 'create-widget 'scrolledtext)))
        (tk/wm 'title toplevel 'Console)
        (tk/pack output #:expand 'yes #:fill 'both)
        (output
          'insert
          'end
          (string-append
            "Chicken/Tk is brought to you by Wolf-Dieter Busch."
            nl
            "This is a console for your 1st exercises (and for mine)."
            nl))
        (tk/bind
          output
          '<Return>
          (lambda ()
            (cond ((string=?
                     (output 'compare 'insert '< '(end - 1 lines))
                     "0")
                   (let ((result
                           (catch (lambda () (eval-last-line-of output)))))
                     (output 'insert 'end nl)
                     (output 'insert 'end (cadr result))
                     (output 'mark 'set 'insert 'end)
                     (output 'see 'insert)))
                  (else
                   (output
                     'delete
                     '(end - 1 lines)
                     '(end - 1 chars))
                   (output
                     'insert
                     'end
                     (output
                       'get
                       '(insert linestart)
                       '(insert lineend)))
                   (output 'mark 'set 'insert 'end)
                   (output 'see 'end)))))
        (tk/bind output '<Return> '+break)))))

)