;;; 
;;; General Utilities (not included in standard library)
;;; 

;;; Pretty printer for functions:

(define PP
  (rlambda [call env esc cont]
    (normalize (arg 1 call) env esc
      (lambda [proc]
        (let [[name 'lambda]
              [proc \proc]]
           (begin (cond [(closure proc) "ok"]
                        [(function proc)
                         (letseq [[string (externalize call)]
                                  [index (string-search " " string)]]
                            (begin (print ps "We'll assume you meant to type "
                                             (substring 1 index string)
                                             #^
                                             (substring (1+ index)
                                                        (string-length string)
                                                        string)
                                             cr)
                                   (set proc ^proc)))]
                        [$true (error "Unknown structure type")])
                  (cond [(reflective-closure proc)
                         (set name 'rlambda)
                         (set proc (extract-simple-closure proc))]
                        [(macro-closure proc) 
                         (set name 'mlambda)
                         (set proc (extract-simple-closure proc))]
                        [$true "ok"])
                  (if (primitive-closure proc)
                      (print ps "Primitive:" cr)
                      "ok")
;                 (pp-printer proc name)
                  (print ps
                         '(,name ,(pattern proc) ,(body proc))
                         cr)
                  (cont '"ok")))))))

;;; (define PP-PRINTER
;;;    (lambda [proc name]
;;;      (if (not (= ^(closure-environment proc) ^global))
;;;          (let [[vars (contour-variables (closure-environment proc))]]
;;; 
;;; ... this will not be trivial to write ...
;;; 


;;; Pretty printer for functions.  Pretty trivial: prints out a pseudo-redex
;;; with the procedure name cons'ed onto the pattern.  So (help +) returns
;;; '(+ number-1 number-2) 

(define HELP
   (rlambda [call env esc cont]
      (normalize (arg 1 call) env esc
         (lambda [proc]
            (cont ^(pcons (arg 1 call) (pattern proc)))))))
 
(let
   [[helper
      (lambda [comparator]
         (letrec
            [[loop (lambda [current remaining]
                      (if (null remaining)
                          current
                          (loop (if (comparator current (first remaining))
                                    current
                                    (first remaining))
                                (rest remaining))))]]
            (lambda args
                (if (null args)
                    (error "Too few arguments" 'MIN/MAX)
                    (loop (first args) (rest args))))))]]
   [(define MIN (helper <))
    (define MAX (helper >))])

(define 1st first)
(define 2nd second)
(define 3rd third)
(define 4th fourth)
(define 5th fifth)

(define carriage-return cr)

(define MAPPEND
   (lambda args
      (append . (map . args))))

;;; (COLLECT predicate selector sequence) designates the sequence
;;; of (selector element) for each element of sequence for which
;;; (predicate element) is true.

(define COLLECT
   (lambda [predicate selector sequence]
      (mappend (lambda [element]
                  (if (predicate element)
                      [(selector element)]
                      []))
               sequence)))
 
(define FILTER
   (lambda [predicate sequence]
      (mappend (lambda [element]
                  (if (predicate element)
                      [element]
                      []))
               sequence)))

;;; General purposes COMPOSE:
;;;
;;; ((compose f1 f2 ... fk) a1 a2 ... an)     ; 1 =< k
;;; 
;;;   =>  (f1 (f2 ... (fk a1 a2 ... an)...))  ; 0 =< n

(define COMPOSE
   (lambda funs
      (cond [(null funs) (lambda args args)]
            [(null (rest funs)) (first funs)]
            [$true
             (lambda args
                ((first funs)
                 ((compose . (rest funs)) . args)))])))

(define CONSTANT
   (lambda [constant]
      (lambda args constant)))

(define ERROR-PROTECT
   (mlambda [call]
      '(,^cps-error-protect ,(arg 1 call)
                            ,^id
                            ,(arg 2 call))))

(define EVERY-CHARACTER
   (lambda [predicate string]
      (cond [(string-null string) $true]
            [(predicate (string-first string))
             (every-character predicate (string-rest string))]
            [$true $false])))

;;; DYNAMIC-CATCH
;;; DYNAMIC-THROW
;;; =============

(define DYNAMIC-CATCH
   (rlambda [call env esc cont]
      (cont (normalize (arg 1 call) env esc id))))

(define DYNAMIC-THROW
   (rlambda [call env esc cont]
      (normalize (arg 1 call) env esc id)))