;******************************************************************************
;
; File name     : widgetinit.stk
; Creation date : Aug-3-1993
; Last update   : Aug-16-1993
;
;******************************************************************************
;
; General definitions and macros extending STk.
;
;******************************************************************************


;---- Predicates

(define-macro (not-equal? x y)
  `(not (equal? ,x ,y)))


;---- Operators

(define-macro (<> x y)
  `(not (= ,x ,y)))

;---- Display

(define (write\n . l)
  (until (null? l)
	 (write (car l))
	 (set! l (cdr l)))
  (newline))

(define (display\n . l)
  (until (null? l)
	 (display (car l))
	 (set! l (cdr l)))
  (newline))



;---- Control structures

;(define-macro (while test . body)
;  (if (null? body)
;      (error "malfomed while, there is no body")
;      (let ((while-name (gensym)))
;	`(let while-name ()
;	   (if ,test
;	       (begin
;		 ,@body
;		 (while-name ())))))))


;(define-macro (until test . body)
;  (if (null? body)
;      (error "malformed until, there is no body")
;      (let ((until-name (gensym)))
;	`(let until-name ()
;	   (if (not ,test)
;	       (begin
;		 ,@body
;		 (until-name ())))))))


(define-macro (while test . body)
  `(do ()
       ((not ,test))
       ,@body))

(define-macro (until test . body)
  `(do ()
       (,test)
       ,@body))

(define-macro (for var test . body)
  `(do ,var
       ((not ,test))
       ,@body))

(define-macro (when test . expr)
  `(if ,test
       (begin
	 ,@expr)))

(define-macro (unless test . expr)
  `(if (not ,test)
       (begin
	 ,@expr)))


;---- Strings

(define (->string obj)
  (cond ((string? obj) 	   obj)
	((number? obj)     (number->string obj))
	((symbol? obj)     (symbol->string obj))
	((tk-command? obj) (widget->string obj))
	(else 	           (error "Cannot convert ~S to a string" obj))))
  

(define (list->str l)
  (if (null? l)
      ""
      (let loop ((l l) (s ""))
	(if (null? (cdr l))
	    (string-append s (->string (car l)))
	    (loop (cdr l) (string-append s (->string (car l)) " "))))))

;---- Vectors

(define (vector-index v value)
  (let ((length (vector-length v))
	(index #f))
    (for ((i (- length 1) (- i 1)))
	 (>= i 0)
	 (if (equal? (vector-ref v i) value) (set! index i)))
    index))
	 

;---- Files

(define (eof? port)
  (eof-object? (peek-char port)))


(define (read-string port)
  (let ((c ()))
    (define (_read-string s)
      (set! c (read-char port))
      (if (or (eof-object? c) (char=? c #\newline))
	  s
	  (_read-string (string-append s (string c)))))
    (if (eof? port) (peek-char port) (_read-string ""))))


(define (read-block port count)
  (let ((c ()))
    (define (_read-block s)
      (if (equal? count 0)
	  s
	  (begin
	    (set! count (- count 1))
	    (set! c (read-char port))
	    (if (eof-object? c)
		s
		(_read-block (string-append s (string c)))))))
    (if (eof? port) (peek-char port) (_read-block ""))))


;---- Tk goodies

(define (& . l)
  (let loop ((l l) (s ""))
    (if (null? l)
        s
	(loop (cdr l) (string-append s (->string (car l)))))))


(define (&& . l)
  (if (null? l)
      ""
      (let loop ((l l) (s ""))
	(if (null? (cdr l))
	    (string-append s (->string (car l)))
	    (loop (cdr l) (string-append s (->string (car l)) " "))))))


(define-macro (tki-get canvas item option)
  `(list-ref (,canvas 'itemconfigure ,item ,option) 2))


(define-macro (tki-set canvas item option value)
  `(,canvas 'itemconfigure ,item ,option ,value))


(define-macro (@ x y)
  `(& "@" ,x "," ,y))


;******************************************************************************
;
; STk adaptation of the Tk widget demo.
;
; showVars:
; Create a top-level window that displays a bunch of global variable values
; and keeps the display up-to-date even when the variables change value.
;
;******************************************************************************
(define (showVars w . args)
  (catch (destroy w))
  (toplevel w)
  (wm 'title w "Variable values")
  (pack [label (& w ".title")
	       :text "Variable values:" :width 20 :anchor "center"
	       :font "-Adobe-helvetica-medium-r-normal--*-180*"]
	:side "top" :fill "x")

  (for-each (lambda (i)
	     (let ((f (& w "." i)))
	       (pack [frame f] :side "top" :anchor "w")
	       (pack [label (& f ".name") :text (& i ": ")]
		     [label (& f ".value") :textvar i]
		     :side "left")))
	    args)

  (pack [button (& w ".ok") :text "OK" :command `(destroy ,w)]
	:side "bottom" :pady 2))