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


(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)))
   P  
;;; 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
;; BOGUS IMPLEMENTATION!!  But it works just fine for now.
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)
)
Ê(  –(cedarcode) style•NewlineDelimiter
™ ™JšœÐetœC™RJ™6J™/—J˜ ˜J˜ šœ˜Jšœ˜—J˜ J˜J˜ J˜—J˜ ˜J˜ šœ%˜%šœ˜Jšœ˜šœ7˜7Jšœ(˜(———J˜ šœ˜˜J˜˜
˜J˜J˜——˜J˜˜,J˜+——˜˜Jšœ˜——˜J˜————J˜ ˜J˜ ˜!J˜'˜˜J˜—˜J˜—˜˜;˜:J˜!—————J˜ ˜JšœÏbœ!™:J˜——J˜ ˜J˜ šœ˜J˜*Jšœ˜—J˜ šœ˜J˜šœ˜˜šœ˜Jšœ˜Jšœ˜————J˜ šœ˜˜˜'˜˜J˜—˜Jšœ,˜,Jšœ˜——————J˜ ˜J˜ ˜J˜X˜˜J˜%—˜J˜"—˜˜J˜˜˜J˜J˜—˜J˜"——————J˜ ˜J˜
—J˜ JšœÏc&Ðcu˜9J˜ ˜Jšœ%Ïuœ˜'J˜—J˜ J˜J˜ Jšœ˜—J˜ ˜J˜ ˜-˜)J˜J˜J˜—J˜ —˜.˜*J˜J˜J˜J˜ ——˜.˜)˜J˜!J˜J˜—šœ.˜.J˜J˜Jšœ˜—J˜ ——˜-˜*˜J˜"J˜ J˜—šœ.˜.J˜J˜Jšœ˜—J˜ ———J˜ ˜J˜ ˜J˜—J˜ šœ˜Jšœ˜šœ˜šœ˜šœ˜Jšœ˜—šœ˜Jšœ
˜
—˜šœ˜Jšœ˜Jšœ˜——————J˜ ˜J˜ J™A™&J™EJ™#J™"™™J™™J™	J™	™™J™5J™J™—™J™"™J™J™J™J™—J™—J™—J™—J™—J™—J™J™—J˜ ˜$J˜4J˜J˜˜˜J˜.J˜?J˜—J˜—˜J˜1J˜—˜J˜%˜	J˜J˜,J˜—J˜—J˜AJ˜HJ˜——J˜ ˜"J˜ J˜J˜ ˜<˜J˜=——J˜ Jšœ$˜$J˜ šœ˜Jšœ"˜"—J˜ Jšœ˜J˜ šœ6˜6˜J˜—JšœC˜C——J˜ ˜J˜ scheme˜˜7˜K˜˜˜K˜—˜K˜4—————J˜ J˜J˜ J˜J˜ ˜˜˜%J˜—˜J˜5———J˜ ˜˜˜%J˜—˜J˜5———J˜ ˜˜˜J˜—˜J˜:———J˜ ˜˜˜J˜—˜
J˜—˜J˜@————J˜ ˜J˜ ˜!˜˜%J˜————J˜ ˜J˜ ˜J˜H—J˜ ˜˜=J˜J˜———— …—    (     