<<>>
<<;;; Miscellaneous.scheme>>
<<;;; Copyright Ó 1988, 1989, 1990, 1991 by Xerox Corporation.  All rights reserved.>>
<<;;; Last changed by Pavel on April 2, 1990 3:35 pm PDT>>
<<;;; Michael Plass, April 3, 1989 1:51:39 pm PDT>>

;;; Booleans

(define (not x)
(if x #f #t))

(define nil #f)

(define t #t)

;;; Equivalence predicates

(define (vector-equal? x y start end)
(if (= start end)
#t
(and (equal? (vector-ref x start) (vector-ref y start))
  (vector-equal? x y (+ start 1) end))))

(define (equal? x y)
(cond
((eqv? x y) #t)
((pair? x)
(and (pair? y)
  (equal? (car x) (car y))
  (equal? (cdr x) (cdr y))))
((vector? x)
(and (vector? y)
     (= (vector-length x) (vector-length y))
  (vector-equal? x y 0 (vector-length x))))
((string? x)
(and (string? y)
  (string=? x y)))
(else
#f)))

;;; Strings

(define (string-append . strings)
"Append an arbitrary number of strings"
(cond
((null? strings)
"")
((null? (cdr strings))
(car strings))
(else
(apply string-append (essential-string-append (car strings)
                                           (cadr strings))
               (cddr strings)))))

(define (number->string x)
<<;; BOGUS IMPLEMENTATION!!  But it works just fine for now.>>
(format #f "~S" x))

;;; Vectors

(define (vector . x)
"Create a vector containing the arguments"
(list->vector x))

(define (vector-fill! v obj) 
"Fill vector v with obj"
(let ((len (vector-length v)))
(let loop ((i 0))
(when (< i len)
(vector-set! v i obj)
(loop (+ i 1))))))

(define (vector->list v)
(let ((result '()))
(let loop ((i (- (vector-length v) 1)))
(cond
((< i 0)
result)
(else
(set! result (cons (vector-ref v i) result))
(loop (- i 1)))))))

;;; Control features

(define (apply proc . args)
"(proc arg1 ... argn) Apply PROC to ARG1 ... ARG(n-1) and the elements of the list ARGn"
(cond
((null? args)
(error "Too few arguments to APPLY"))
((null? (cdr args))
(essential-apply proc (car args)))
(else
(let loop ((tail args)
        (rest (cdr args)))
(cond
((null? (cdr rest))
(set-cdr! tail (car rest))
(essential-apply proc args))
(else
(loop (cdr tail) (cdr rest))))))))

(define (force promise)
(promise))

(define head car) ; for streams, as in Ableson & Sussman2

(define (tail foo)
"for streams, as in Ableson & Sussman2"
(force (cdr foo)))

(define empty-stream? null?)

(define the-empty-stream '())

;;; I/O

(define (call-with-input-file file-name proc)
(let* ((port (open-input-file file-name))
    (result (proc port)))
(close-input-port port)
result))

(define (call-with-output-file file-name proc)
(let* ((port (open-output-file file-name))
    (result (proc port)))
(close-output-port port)
result))

(define (with-input-from-file file-name thunk)
(let ((port (open-input-file file-name)))
(define (swap)
(define old (current-input-port))
(%set-current-input-port! port)
(set! port old))
(let ((result (dynamic-wind swap thunk swap)))
(close-input-port port)
result
)))

(define (with-output-to-file file-name thunk)
(let ((port (open-output-file file-name)))
(define (swap)
(define old (current-output-port))
(%set-current-output-port! port)
(set! port old))
(let ((result (dynamic-wind swap thunk swap)))
(close-output-port port)
result
)))


;;; Combinators

(define (identity x)
x)

(define (compose . functions)
"Function composition"
(let loop ((fns functions))
(cond
((null? fns)
(lambda (x) x))
((null? (cdr fns))
(car fns))
(else 
(let ((f (car fns))
   (g (loop (cdr fns))))
(lambda x (f (apply g x))))))))

;;; Apropos

<<string-match? is implemented in Cedar now, by calling Rope.Match.>>
<<(define (string-match? pattern target)>>
<<"Does the pattern string (which may contain *s) match target string?">>
<<(define pn (string-length pattern))>>
<<(define tn (string-length target))>>
<<(define (match-from pi ti)>>
<<(or>>
<<(and (= pi pn) (= ti tn))>>
<<(and>>
<<(< pi pn)>>
<<(< ti tn)>>
<<(or>>
<<(and>>
<<(eqv? (string-ref pattern pi) (string-ref target ti))>>
<<(match-from (+ 1 pi) (+ 1 ti))>>
<<)>>
<<(and>>
<<(eqv? (string-ref pattern pi) #\*)>>
<<(or>>
<<(= (+ 1 pi) pn)>>
<<(match-from (+ 1 pi) (+ 1 ti))>>
<<(match-from pi (+ 1 ti))>>
<<)>>
<<)>>
<<)>>
<<)>>
<<)>>
<<)>>
<<(match-from 0 0)>>
<<)>>

(define (apropos pattern . as-list?)
"find symbols in the environment that match pattern"
(define count 0)
(define result '())
(define collect
(if (equal? as-list? '(#t))
(lambda (sym) (set! result (cons sym result)))
(lambda (sym) (set! count (+ count 1)) (display sym) (newline))
)
)
(define (check sym val)
(if (string-ci-match? pattern sym) (collect sym))
)
(define (walk-env-chain fn env)
"apply fn to env and all its parents"
(when env
(fn env)
(walk-env-chain fn (environment-parent env))
)
)
(walk-env-chain (lambda (env) (walk-environment check env)) user)
(if (equal? as-list? '(#t)) (sort result string<? symbol->string) count)
)

;;; Read-Eval-Print and Load notes

(define *load-notes* '())

(define (*load-note-taker* file-description defined-symbols)
(set! *load-notes*
(cons (list file-description defined-symbols) *load-notes*)))

(define *read-eval-print-notes* '())

(define (read-eval-print-notes)
(reverse *read-eval-print-notes*))

(define & #f)

(define (*read-eval-print-note-taker* form exp . rest)
(when (pair? rest)
(set! & (car rest)))
(set! *read-eval-print-notes* (cons form *read-eval-print-notes*)))

;;; Viewers

(define (eval-selection)
(let ((p (open-input-string (get-selection-contents))))
(let loop ((form (read p))
        (results '()))
(cond
((eof-object? form)
(reverse! results))
(else
(loop (read p) (cons (eval form user) results)))))))

(define *default-context* #f)

(define event-kind car)

(define (event-x event)
(case (event-kind event)
((buttondown buttonup mouseto erased)
(cadr event))
(else
(error 'event-x event "Event has no x-coordinate"))))

(define (event-y event)
(case (event-kind event)
((buttondown buttonup mouseto erased)
(caddr event))
(else
(error 'event-y event "Event has no y-coordinate"))))

(define (event-button event)
(case (event-kind event)
((buttondown buttonup)
(cadddr event))
(else
(error 'event-button event "Event has no mouse button"))))

(define (event-shift event)
(case (event-kind event)
((buttondown buttonup)
(car (cddddr event)))
((mouseto)
(cadddr event))
(else
(error 'event-shift event "Event has no ctrlshift parameter"))))

;;; Environment manipulation

(define (walk-environment fn env)
(for-each (lambda (pair)
          (fn (car pair) (cdr pair)))
    (%environment->alist env)))

;;; Code-as-data tools

(define (eval expr env)
(apply (*system-compiler* (*system-syntax-expander* expr env) env) '()))

(define (kwote v)
(if (or (number? v)
  (string? v)
  (boolean? v)
  (char? v))
v
`(quote ,v)))