;;; Code stored as:  {turing}<3-lisp.problem-sets>parsing-utilities.3-lisp
;;;                  {phylum}<3-lisp>course>problem-sets>parsing-utilities.3-lisp


;;; =================================================================
;;;                       SEQUENCE UTILITIES
;;; =================================================================

;;; (FILTER predicate sequence)   Designates the sequence consisting
;;; ===========================   of each element of sequence for which
;;;                               (predicate element) is true.

(define FILTER
   (lambda [predicate sequence]
      (collect (lambda [element]
                  (if (predicate element)
                      [element]
                      []))
               sequence)))

;;; (COLLECT fun args1 ... argsk)   Appends together the results of
;;; =============================   mapping fun (of arity k) to the
;;;                                 sequences of args args1 ... argsk.
;;; Useful, in combination with SINGLETON and NOTHING, for assembling
;;; some results from a sequence of args.

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

;;; (SINGLETON exp)   To be used by COLLECT and F-COLLECT
;;; (NOTHING)
;;; ===============

(define SINGLETON (lambda [element] [element]))
(define NOTHING (lambda [] []))

;;; (FILTERED-MAP fun predicate sequence)  Maps <fun> down a version of <sequence>
;;; =====================================  that has been filtered by <predicate>.
;;;                                             

(define FILTERED-MAP
   (lambda [fun predicate sequence]
      (map fun (filter predicate 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)))])))

;;; CONSTANT
;;; ========

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

;;; ===============================================================
;;;          STRANGE CONTROL STRUCTURES
;;; ===============================================================

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


;;; =================================================================
;;;          OBJECTS:
;;; =================================================================
;;; 
;;; General form:
;;; 
;;;  (object [init-var-1 ... init-var-k]
;;;          [[var-1 init-1] ... [var-n init-n]]
;;;     [<mess1> <fun1>]
;;;     [<mess2> <fun2>]
;;;        ...
;;;     [<messk> <funk>])
;;; =================================================================

(define OBJECT
  (let [[define-message
           (lambda [name]
              '(define ,name
                  (lambda args
                     (((first args) ,↑name) . (rest args)))))]]
    (mlambda [call]
      (letseq [[state-vars (arg 1 call)]
               [inited-vars (arg 2 call)]
               [pairs (tail 2 (pargs call))]
               [fun-names (map (lambda [pair] (acons)) pairs)]]
         '(begin
             ,(map (lambda [pair]
                      (define-message (first pair)))
                   pairs)
             (lambda ,state-vars
               (let ,inited-vars
                 (letrec ,(map (lambda [pair fun-name]
                                 '[,fun-name ,(second pair)])
                               pairs
                               fun-names)
                    (lambda [message]
                       (cond . ,(map (lambda [pair fun-name]
                                        '[(= message ,↑(first pair))
                                          ,fun-name])
                                     pairs
                                     fun-names)))))))))))