Add pstk

.gitignore

@@ -18,4 +18,5 @@ test-r6rs
 test-r7rs.scm
 test-r7rs
 *.html
+*.rkt
 

retropikzel/pstk.scm

@@ -0,0 +1,692 @@
+(define-c-library libc
+                  '("stdlib.h" "stdio.h" "unistd.h")
+                  libc-name
+                  '((additional-versions ("0" "6"))))
+
+(define-c-procedure c-tempnam libc 'tempnam 'pointer '(pointer pointer))
+(define-c-procedure c-system libc 'system 'int '(pointer))
+(define wish-display pipe-write-string)
+(define wish-read (lambda (pipe)
+                    (let ((result (pipe-read pipe)))
+                      (if (eof-object? result)
+                        result
+                        (read (open-input-string result))))))
+(define wish-newline
+  (lambda (pipe)
+    (pipe-write-char #\newline pipe)))
+(define wish-flush (lambda () #t)) ; No need to do anything
+(define wish-read-line pipe-read-line)
+(define (run-program program)
+  (let* ((temp-prefix (string->c-utf8 "npcmd"))
+         (temp-name (lambda ()
+                      (c-utf8->string (c-tempnam (make-c-null)
+                                                 temp-prefix))))
+         (input-path (temp-name))
+         (output-path (temp-name))
+         (shell-command (string-append program
+                                       " < "
+                                       output-path
+                                       " 1> "
+                                       input-path
+                                       " 2> "
+                                       input-path
+                                       " & ")))
+    (create-pipe input-path 0777)
+    (create-pipe output-path 0777)
+    (c-system (string->c-utf8 shell-command))
+    (list (open-input-pipe input-path)
+          (open-output-pipe output-path))))
+
+(define *wish-program* "tclsh")
+(define *wish-debug-input* #f)
+(define *wish-debug-output* #f)
+
+(define *use-keywords?*
+  (cond-expand (chicken #t)
+               (else (or (not (symbol? 'text:))
+                         (not (symbol? ':text))
+                         (string=? "text" (symbol->string 'text:))
+                         (string=? "text" (symbol->string ':text))))))
+
+(define (keyword? x) #f)        ;; TODO: handle keywords?
+(define (keyword->string x) x)
+
+(define nl (string #\newline))
+
+(define wish-input #f)
+
+(define wish-output #f)
+
+(define tk-is-running #f)
+
+(define tk-ids+widgets '())
+
+(define tk-widgets '())
+
+(define commands-invoked-by-tk '())
+
+(define inverse-commands-invoked-by-tk '())
+
+(define in-callback #f)
+
+(define callback-mutex #t)
+
+(define ttk-widget-map '())
+
+(define tk-init-string
+  (let ((start-str '("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"
+                     "}")))
+    (do ((str start-str (cdr str)) ; turn into one string with \n between each line
+         (res "" (string-append res (car str) nl)))
+      ((null? str) res))))
+
+(define report-error
+  (lambda (x)
+    (newline)
+    (display x)
+    (newline)
+    ; (bottom x)
+    ))
+
+
+
+(define 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))))))))
+
+(define 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)))))))
+
+(define 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)))))))
+
+(define 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>"))))
+
+(define 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) '())))))
+
+(define string-trim-left
+  (lambda (str)
+    (cond ((string=? str "") "")
+          ((string=? (substring str 0 1) " ")
+           (string-trim-left (substring str 1
+                                        (string-length str))))
+          (else str))))
+
+(define 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)))))
+
+(define tcl-true?
+  (let ((false-values
+          `(0 "0" 'false "false" ,(string->symbol "0"))))
+    (lambda (obj) (not (memv obj false-values)))))
+
+(define widget?
+  (lambda (x)
+    (and (memq x tk-widgets) #t)))
+
+(define 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)))))
+                  (tk-set-var! resultvar str)
+                  (set! in-callback (cdr in-callback))
+                  result)))))
+
+(define gen-symbol
+  (let ((counter 0))
+    (lambda ()
+      (let ((sym (string-append "g" (number->string counter))))
+        (set! counter (+ counter 1))
+        (string->symbol sym)))))
+
+(define widget-name
+  (lambda (x)
+    (let ((name (form->string x)))
+      (cond ((member name ttk-widget-map)
+             (string-append "ttk::" name))
+            (else name)))))
+
+(define 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)))
+                (tk-eval
+                  (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)
+                     (tk-eval
+                       (string-append id " " (form->string command))))
+                    ((null? (cdr args))
+                     (tk-eval
+                       (string-append
+                         id
+                         " "
+                         (form->string command)
+                         (scheme-arglist->tk-argstring args))))
+                    (else
+                      (tk-eval
+                        (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 ()
+                    (tk-eval
+                      (string-append
+                        id
+                        " cget"
+                        (scheme-arglist->tk-argstring args)))))))
+             ((call exec)
+              (tk-eval
+                (string-trim-left
+                  (scheme-arglist->tk-argstring args))))
+             (else
+               (tk-eval
+                 (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)))
+
+(define 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))))))
+
+(define scheme-arglist->tk-argstring
+  (lambda (args)
+    (apply string-append
+           (map scheme-arg->tk-arg
+                args))))
+
+(define make-wish-func
+  (lambda (tkname)
+    (let ((name (form->string tkname)))
+      (lambda args
+        (tk-eval
+          (string-append
+            name
+            (scheme-arglist->tk-argstring args)))))))
+
+(define read-wish
+  (lambda ()
+    (let ((term (wish-read wish-output)))
+      (cond ((and *wish-debug-output*
+                  (not (eof-object? term)))
+             (display "wish->scheme: ")
+             (write term)
+             (newline)))
+      term)))
+
+(define wish
+  (lambda arguments
+    (for-each
+      (lambda (argument)
+        (cond (*wish-debug-input*
+                (display "scheme->wish: ")
+                (display argument)
+                (newline)))
+        (wish-display argument wish-input)
+        (wish-newline wish-input)
+        (wish-flush))
+      arguments)))
+
+(define start-wish
+  (lambda ()
+    (let ((result (run-program *wish-program*)))
+      (set! wish-input (cadr result))
+      (set! wish-output (car result)))))
+
+
+(define tk-eval
+  (lambda (cmd)
+    (wish (string-append
+            "evalCmdFromScm \""
+            (string-translate cmd
+                              '((#\\ . "\\\\") (#\" . "\\\"")))
+            "\""))
+    (let again ((result (read-wish)))
+      (cond ((eof-object? result) #t)
+            ((not (pair? result))
+             (report-error (string-append
+                             "An error occurred inside Tcl/Tk" nl
+                             " --> " (form->string result)
+                             " " (wish-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))))))
+
+(define tk-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)))))
+
+(define tk-var
+  (lambda (varname)
+    (tk-set-var! varname "")
+    (string-append
+      "::scmVar("
+      (form->string varname)
+      ")")))
+
+(define tk-get-var
+  (lambda (varname)
+    (tk-eval
+      (string-append
+        "set ::scmVar("
+        (form->string varname)
+        ")"))))
+
+(define tk-set-var!
+  (lambda (varname value)
+    (tk-eval
+      (string-append
+        "set ::scmVar("
+        (form->string varname)
+        ") {"
+        (form->string value)
+        "}"))))
+
+; start: void -> tk
+(define tk-start
+  (lambda args ; optional argument for name of wish program
+    (when (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)
+    (let ((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 tk-end)
+      tk)))
+
+(define tk-end
+  (lambda ()
+    (set! tk-is-running #f)
+    (wish "after 200 exit")))
+
+(define tk-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))))))
+
+(define loop
+  (lambda (tk)
+    (cond ((not tk-is-running)
+           (if wish-output
+             (tk/wm 'protocol tk 'WM_DELETE_WINDOW '())))
+          (else (tk-dispatch-event)
+                (loop tk)))))
+
+(define tk-event-loop
+  (lambda (tk)
+    (set! tk-is-running #t)
+    (loop tk)))
+
+(define ttk-map-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."))))))
+
+(define 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) "" '())))))
+
+(define ttk-available-themes
+  (lambda ()
+    (string-split #\space (tk-eval "ttk::style theme names"))))
+
+(define do-wait-for-window
+  (lambda (w)
+    (tk-dispatch-event)
+    (cond ((equal? (tk/winfo 'exists w) "0") '())
+          (else (do-wait-for-window w)))))
+
+(define tk-wait-for-window
+  (lambda (w)
+    (let ((outer-allow callback-mutex))
+      (set! callback-mutex #t)
+      (do-wait-for-window w)
+      (set! callback-mutex outer-allow))))
+
+(define tk-wait-until-visible
+  (lambda (w)
+    (tk/wait 'visibility w)))
+
+(define lock!
+  (lambda ()
+    (set! callback-mutex
+      (cons callback-mutex #t))))
+
+(define unlock!
+  (lambda ()
+    (if (pair? callback-mutex)
+      (set! callback-mutex
+        (cdr callback-mutex)))))
+
+(define tk-with-lock
+  (lambda (thunk)
+    (lock!)
+    (thunk)
+    (unlock!)))
+
+(define tk/after (make-wish-func 'after))
+(define tk/bell (make-wish-func 'bell))
+(define tk/update (make-wish-func 'update))
+(define tk/clipboard (make-wish-func 'clipboard))
+(define tk/bgerror (make-wish-func 'bgerror))
+(define tk/bind (make-wish-func 'bind))
+(define tk/bindtags (make-wish-func 'bindtags))
+(define tk/destroy (make-wish-func 'destroy))
+(define tk/event (make-wish-func 'event))
+(define tk/focus (make-wish-func 'focus))
+(define tk/grab (make-wish-func 'grab))
+(define tk/grid (make-wish-func 'grid))
+(define tk/image (make-wish-func 'image))
+(define tk/lower (make-wish-func 'lower))
+(define tk/option (make-wish-func 'option))
+(define tk/pack (make-wish-func 'pack))
+(define tk/place (make-wish-func 'place))
+(define tk/raise (make-wish-func 'raise))
+(define tk/selection (make-wish-func 'selection))
+(define tk/winfo (make-wish-func 'winfo))
+(define tk/wm (make-wish-func 'wm))
+(define tk/choose-color (make-wish-func "tk_chooseColor"))
+(define tk/choose-directory (make-wish-func "tk_chooseDirectory"))
+(define tk/dialog (make-wish-func "tk_dialog"))
+(define tk/get-open-file (make-wish-func "tk_getOpenFile"))
+(define tk/get-save-file (make-wish-func "tk_getSaveFile"))
+(define tk/message-box (make-wish-func "tk_messageBox"))
+(define tk/focus-follows-mouse (make-wish-func "tk_focusFollowsMouse"))
+(define tk/focus-next (make-wish-func "tk_focusNext"))
+(define tk/focus-prev (make-wish-func "tk_focusPrev"))
+(define tk/popup (make-wish-func "tk_popup"))
+(define tk/wait (lambda args (make-wish-func 'tkwait)))
+(define tk/appname (make-wish-func "tk appname"))
+(define tk/caret (make-wish-func "tk caret"))
+(define tk/scaling (make-wish-func "tk scaling"))
+(define tk/useinputmethods (make-wish-func "tk useinputmethods"))
+(define tk/windowingsystem (make-wish-func "tk windowingsystem"))
+(define ttk/available-themes ttk-available-themes)
+(define ttk/set-theme (make-wish-func "ttk::style theme use"))
+(define ttk/style (make-wish-func "ttk::style"))

retropikzel/pstk.sld

@@ -0,0 +1,163 @@
+; 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
+; Copyright (C) 2025 Retropikzel
+; 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
+; - Peter Lane: R7RS support
+; Thank you!
+;
+; Change Log:
+; 2025-06-08 MAde to work with named pipes and foreign-c library
+; 2017-05-11 Optional argument to 'start' for input of wish/tclsh program name.
+; 2017-05-11 Converted into an R7RS library with Chibi, Gauche and Sagittarius support.
+; 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.
+
+(define-library
+  (retropikzel pstk)
+  (export tk-eval
+          tk-id->widget
+          tk-var
+          tk-get-var
+          tk-start
+          tk-end
+          tk-dispatch-event
+          tk-event-loop
+          tk-wait-for-window
+          tk-wait-until-visible
+          tk-with-lock
+          ttk-map-widgets
+          tk/after
+          tk/bell
+          tk/update
+          tk/clipboard
+          tk/bgerror
+          tk/bind
+          tk/bindtags
+          tk/destroy
+          tk/event
+          tk/focus
+          tk/grab
+          tk/grid
+          tk/image
+          tk/lower
+          tk/option
+          tk/pack
+          tk/place
+          tk/raise
+          tk/selection
+          tk/winfo
+          tk/wm
+          tk/choose-color
+          tk/choose-directory
+          tk/dialog
+          tk/get-open-file
+          tk/get-save-file
+          tk/message-box
+          tk/focus-follows-mouse
+          tk/focus-next
+          tk/focus-prev
+          tk/popup
+          tk/wait
+          tk/appname
+          tk/caret
+          tk/scaling
+          tk/useinputmethods
+          tk/windowingsystem
+          ttk/available-themes
+          ttk/set-theme
+          ttk/style)
+  (import (scheme base)
+          (scheme cxr)
+          (scheme read)
+          (scheme file)
+          (scheme write)
+          (foreign c)
+          (retropikzel named-pipes))
+  (include "pstk.scm"))
+

retropikzel/pstk/LICENSE

@@ -0,0 +1,28 @@
+Copyright (C) 2008 Kenneth A Dickey
+Copyright (C) 2006-2008 Nils M Holm
+Copyright (C) 2004 Wolf-Dieter Busch
+Copyright (C) 2017 Peter Lane
+Copyright (C) 2025 Retropikzel
+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.

retropikzel/pstk/VERSION

@@ -0,0 +1 @@
+1.0.1

retropikzel/pstk/test.scm

@@ -0,0 +1,10 @@
+(import (scheme base)
+        (scheme write)
+        (retropikzel pstk))
+
+(let ((tk (tk-start)))
+  (tk/pack (tk 'create-widget
+               'button 'text: "Hello"
+               'command: (lambda () (display "Hello world") (newline)))
+           'padx: 20 'pady: 20)
+  (tk-event-loop tk))