(load "~/classes/symbolic/psets/02/ghelper.scm")

;;;;    Generic sequence operator definitions

;;; First we declare the operators we want to be generic.
;;;  Each declaration specifies the arity (number of arguments)
;;;  and the default operation, if necessary.

(define sequence:null
  (make-generic-operator 1 #f))

(define sequence:ref
  (make-generic-operator 2 #f))

(define sequence:size 
  (make-generic-operator 1 #f))

(define sequence:type
  (make-generic-operator 1 #f))

(define sequence:null?
  (make-generic-operator 1 #f))

(define sequence:equal?
  (make-generic-operator 2 #f))

(define sequence:set!
  (make-generic-operator 3 #f))

(define sequence:subsequence
  (make-generic-operator 3 #f))


;;; sequence:append takes multiple arguments.  It is defined in terms
;;; of a binary generic append that takes a sequence and a list of sequences.

(define (sequence:append . sequences)
  (if (null? sequences)
      (error "Need at least one sequence for append"))
  (let ((type? (sequence:type (car sequences))))
    (if (not (for-all? (cdr sequences) type?))
        (error "All sequences for append must be of the same type"
               sequences))
    (fold-right generic:binary-append
                (sequence:null (sequence:type (car sequences)))
                sequences)))

(define generic:binary-append (make-generic-operator 2 #f))

;;; Implementations of the generic operators.

(define (any? x) #t)
(define (constant val) (lambda (x) val))
(define (is-exactly val) (lambda (x) (eq? x val)))

(assign-operation sequence:null (constant "")    (is-exactly string?))
(assign-operation sequence:null (constant '())   (is-exactly list?))
(assign-operation sequence:null (constant #())   (is-exactly vector?))

(assign-operation sequence:ref string-ref         string? exact-integer?)
(assign-operation sequence:ref list-ref           list?   exact-integer?)
(assign-operation sequence:ref vector-ref         vector? exact-integer?)

(assign-operation sequence:size string-length     string?)
(assign-operation sequence:size length            list?)
(assign-operation sequence:size vector-length     vector?)

(assign-operation sequence:type (constant string?)     string?)
(assign-operation sequence:type (constant list?)       list?)
(assign-operation sequence:type (constant vector?)     vector?)


(define (vector-null? v) (= (vector-length v) 0))

(assign-operation sequence:null? string-null?     string?)
(assign-operation sequence:null? null?            list?)
(assign-operation sequence:null? vector-null?     vector?)


;;; To assign to the ith element of a list:

(define (list-set! list i val)
  (cond ((null? list)
         (error "List does not have enough elements" i))
        ((= i 0) (set-car! list val))
        (else (list-set! (cdr list) (- i 1) val))))

(assign-operation sequence:set! string-set!   string? exact-integer? any?)
(assign-operation sequence:set! list-set!     list?   exact-integer? any?)
(assign-operation sequence:set! vector-set!   vector? exact-integer? any?)


(assign-operation sequence:subsequence
                  substring
                  string?  exact-integer?  exact-integer?)
(assign-operation sequence:subsequence 
                  sublist
                  list?  exact-integer?  exact-integer?)
(assign-operation sequence:subsequence
                  subvector
                  vector?  exact-integer?  exact-integer?)


(define (vector-append v1 v2)
  (let ((n1 (vector-length v1))
        (n2 (vector-length v2)))
    (make-initialized-vector (+ n1 n2)
                             (lambda (i)
                               (if (< i n1)
                                   (vector-ref v1 i)
                                   (vector-ref v2 (- i n1)))))))

(assign-operation generic:binary-append string-append  string? string?)
(assign-operation generic:binary-append append         list?   list?)
(assign-operation generic:binary-append vector-append  vector? vector?)

;;;
;;;; Begin new code
;;;

;;  misc. functions


(define (all? pred)
  (lambda (x)
    (for-all? x pred)))

(define (applier fn)
  (lambda (x)
    (apply fn x)))

(define (select-from-pair fn)
  (lambda (x y)
    (if (fn x y)
        x
        y)))

(define (of-arity? n)
  (lambda (fn)
    (procedure-of-arity? fn n)))

(define (there-exists? lis pred?)
  (let loop ((lis lis))
    (cond ((null? lis)
           #f)
          ((pred? (car lis))
           #t)
          (else
           (loop (cdr lis))))))

(define (reverse-arguments f)
  (lambda args
    (apply f (reverse args))))


;;;;            Generic sequence operations

;;; There are many kinds of data that can be used to represent sequences: 
;;;     examples include strings, lists, and vectors.

;;; There are operations that can be defined for all sequence types.

;;;                    Constructing
;;;
;;; (sequence:construct <sequence-type> <item-1> ... <item-n>)
;;;    Constructs a new sequence of the given type and of size n with
;;;    the given elements: item-1 ... item-n

(define sequence:from-list
  (make-generic-operator 2 #f))

(assign-operation sequence:from-list ((discard-argument 0) list->string)  (is-exactly string?)  (all? char?))
(assign-operation sequence:from-list ((discard-argument 0) identity)      (is-exactly list?)    any?)
(assign-operation sequence:from-list ((discard-argument 0) list->vector)  (is-exactly vector?)  any?)

(define sequence:to-list
  (make-generic-operator 1 #f))

(assign-operation sequence:to-list identity     list?)
(assign-operation sequence:to-list vector->list vector?)
(assign-operation sequence:to-list string->list string?)


(define (sequence:internal-do-coerce type? sequence)
  (sequence:from-list type?
                      (sequence:to-list sequence)))

(define sequence:coerce
  (make-generic-operator 2 #f))

(assign-operation sequence:coerce ((discard-argument 0) identity) (is-exactly list?) list?)
(assign-operation sequence:coerce ((discard-argument 0) vector->list) (is-exactly list?) vector?)
(assign-operation sequence:coerce ((discard-argument 0) string->list) (is-exactly list?) string?)

(assign-operation sequence:coerce ((discard-argument 0) list->vector)   (is-exactly vector?) list?)
(assign-operation sequence:coerce ((discard-argument 0) identity)       (is-exactly vector?) vector?)
(assign-operation sequence:coerce sequence:internal-do-coerce (is-exactly vector?) string?)

(assign-operation sequence:coerce ((discard-argument 0) list->string)   (is-exactly string?) list?)
(assign-operation sequence:coerce sequence:internal-do-coerce (is-exactly string?) vector?)
(assign-operation sequence:coerce ((discard-argument 0) identity) (is-exactly string?) string?)

(define (sequence:coercer type?)
  (lambda (sequence)
    (sequence:coerce type? sequence)))


(sequence:to-list '(1 2 3))
;Value: (1 2 3)

(sequence:to-list '#(1 2 3))
;Value: (1 2 3)

(sequence:to-list "foo")
;Value: (#\f #\o #\o)


(sequence:from-list list? (sequence:to-list '(1 2 3)))
;Value: (1 2 3)

(sequence:from-list vector? (sequence:to-list '#(1 2 3)))
;Value: #(1 2 3)

(sequence:from-list string? (sequence:to-list "foo"))
;Value: "foo"


(sequence:coerce list? '(1 2 3))
;Value: (1 2 3)

(sequence:coerce list? '#(1 2 3))
;Value: (1 2 3)

(sequence:coerce list? "foo")
;Value: (#\f #\o #\o)

(sequence:coerce vector? '(1 2 3))
;Value: #(1 2 3)

(sequence:coerce vector? '#(1 2 3))
;Value: #(1 2 3)

(sequence:coerce vector? "abc")
;Value: #(#\a #\b #\c)

(sequence:coerce string? '(#\a #\b #\c))
;Value: "abc"

(sequence:coerce string? '#(#\a #\b #\c))
;Value: "abc"

(sequence:coerce string? "abc")
;Value: "abc"


((sequence:coercer list?) '#(1 2 3))
;Value: (1 2 3)

((sequence:coercer vector?) "abc")
;Value: #(#\a #\b #\c)

((sequence:coercer string?) '(#\a #\b #\c))
;Value: "abc"



(define (sequence:construct type? . elements)
  (sequence:from-list type? elements))

#||
(sequence:construct vector? 1 2 3)
;Value: #(1 2 3)

(sequence:construct list? 1 2 3)
;Value: (1 2 3)

(sequence:construct string? #\f #\o #\o)
;Value: "foo"
||#

;;; (sequence:null <sequence-type>)
;;;    Produces the null sequence of the given type

;;; defined above

#|
(sequence:null string?)
;Value: ""

(sequence:null list?)
;Value: ()

(sequence:null vector?)
;Value: #()

|#


;;;                     Selecting
;;;
;;; (sequence:ref <sequence> <i>)
;;;    Returns the ith element of the sequence.  We use zero-based
;;;    indexing, so for a sequence of length n the ith item is
;;;    referenced by (sequence:ref <sequence> <i-1>).

;;; defined above

#||
(sequence:ref '(1 2 3) 1)
;Value: 2

(sequence:ref '#(1 2 3) 1)
;Value: 2

(sequence:ref "foo" 1)
;Value: #\o
||#

;;; (sequence:size <sequence>)
;;;    Returns the number of elements in the sequence.

#||
(sequence:size '(1 2 3))
;Value: 3

(sequence:size '#(1 2 3))
;Value: 3

(sequence:size "foo")
;Value: 3
||#

;;; (sequence:type <sequence>)
;;;    Returns the predicate defining the type of the sequence given.


#||
((sequence:type '(1 2 3)) '(1 2 3))
;Value: #t

((sequence:type '(1 2 3)) "foo")
;Value: #f

((sequence:type '#(1 2 3)) '#(1 2 3))
;Value: #t

((sequence:type '#(1 2 3)) '(1 2 3))
;Value: #f

((sequence:type "foo") "foo")
;Value: #t

((sequence:type "foo") '#(1 2 3))
;Value: #f
||#


;;;                     Testing
;;;
;;; (sequence:null? <sequence>)
;;;    Returns #t if the sequence is null, otherwise returns #f.

#||

(sequence:null? '(1 2 3))
;Value: #f

(sequence:null? '())
;Value: #t

(sequence:null? '#(1 2 3))
;Value: #f

(sequence:null? '#())
;Value: #t

(sequence:null? "foo")
;Value: #f

(sequence:null? "")
;Value: #t

||#

;;; (sequence:equal? <sequence-1> <sequence-2>)
;;;    Returns #t if the sequences are of the same type and have equal
;;;    elements in the same order, otherwise returns #f.

(assign-operation sequence:equal? equal? list? list?)
(assign-operation sequence:equal? equal? vector? vector?)
(assign-operation sequence:equal? equal? string? string?)



(sequence:equal? '(1 2 3) '(1 2 3))
;Value: #t

(sequence:equal? '(1 2 3) '(1 2))
;Value: #f

(sequence:equal? '#(1 2 3) '#(1 2 3))
;Value: #t

(sequence:equal? '#(1 2 3) '#(1 2))
;Value: #f

(sequence:equal? "123" "123")
;Value: #t

(sequence:equal? "123" "12")
;Value: #f




;;;                     Mutation
;;;
;;; Some sequences are immutable, while others can be changed.  
;;;
;;; For those that can be modified we can change an element:
;;;
;;; (sequence:set! <sequence> <i> <v>) 
;;;    Sets the ith element of the sequence to v.

(assign-operation sequence:set! list-set!    list?   exact-integer? any?)
(assign-operation sequence:set! vector-set!  vector? exact-integer? any?)
(assign-operation sequence:set! string-set!  string? exact-integer? char?)


(define foo '(1 2 3))
;Value: foo

(sequence:set! foo 1 'a)
;Unspecified return value

foo
;Value: (1 a 3)

(define bar '#(1 2 3))
;Value: bar

(sequence:set! bar 1 'a)
;Unspecified return value

bar
;Value: #(1 a 3)

(define baz "123")
;Value: baz

(sequence:set! baz 1 #\a)
;Unspecified return value

baz
;Value: "1a3"




;;;                  Cutting and Pasting
;;;
;;;  (sequence:subsequence <sequence> <start> <end>)
;;;    The arguments start and end must be exact integers such that 
;;;       0 <= start <= end <= (sequence:size <sequence>).
;;;    Returns a new sequence of the same type as the given sequence,
;;;    of size end-start with elements selected from the given sequence.
;;;    The new sequence starts with the element of the given sequence
;;;    referenced by start.  It ends with the element of the given
;;;    sequence referenced by end-1.



(sequence:subsequence (iota 10) 3 7)
;Value: (3 4 5 6)

(sequence:subsequence (list->vector (iota 10)) 3 7)
;Value: #(3 4 5 6)

(sequence:subsequence (list->string 
                       (map digit->char 
                            (iota 10)))
                      3 7)
;Value: "3456"


;;; (sequence:append <sequence-1> ... <sequence-n>)
;;;    Requires that the sequences are all of the same type.  Returns
;;;    a new sequence of the type, formed by concatenating the
;;;    elements of the given sequences.  The size of the new sequence
;;;    is the sum of the sizes of the given sequences.


(sequence:append (iota 3 0)
                 (iota 7 4)
                 (iota 10 8))
;Value: (0 1 2 4 5 6 8 9)

(sequence:append "foo " "bar " "baz ")
;Value: "foo bar baz "

(apply 
 sequence:append (map list->vector
                      (list (iota 3 0)
                            (iota 7 4)
                            (iota 10 8))))
;Value: #(0 1 2 4 5 6 8 9)



;;;                      Iterators
;;;
;;; (sequence:generate <sequence-type> <n> <function>)
;;;    Makes a new sequence of the given sequence type, of size n.
;;;    The ith element of the new sequence is the value of the 
;;;    function at the index i.


(define (sequence:internal-do-generate type? n fn)
  (sequence:from-list type? (map fn (iota n))))

(define sequence:generate
  (make-generic-operator 3 #f))

(assign-operation sequence:generate
                  sequence:internal-do-generate
                  (is-exactly list?)
                  exact-integer?
                  (of-arity? 1))

(assign-operation sequence:generate
                  sequence:internal-do-generate
                  (is-exactly vector?)
                  exact-integer?
                  (of-arity? 1))

(assign-operation sequence:generate
                  sequence:internal-do-generate
                  (is-exactly string?)
                  exact-integer?
                  (of-arity? 1))


(sequence:generate list? 5 square)
;Value: (0 1 4 9 16)

(sequence:generate vector? 5 square)
;Value: #(0 1 4 9 16)

(sequence:generate string? 5 digit->char)
;Value: "01234"


;;; (sequence:map <function> <seq-1> ... <seq-n>)
;;;    Requires that the sequences given are of the same size and
;;;    type, and that the arity of the function is n.  The ith element
;;;    of the new sequence is the value of the function applied to the
;;;    n ith elements of the given sequences.


(define (sequence:map fn . sequences)
  (cond ((null? sequences)
         (error "sequence:map : Need at least one sequence for map"))
        ((not (procedure? fn))
         (error "sequence:map : Cannot map a non-procedure"))
        ((not (procedure-of-arity? fn (length sequences)))
         (error "sequence:map : Cannot map procedure -- not of arity" (length sequences)))
        ((not (apply = (map sequence:size sequences)))
         (error "sequence:map : Cannot map onto sequences of different length"))
        (else
         (let ((type? (sequence:type (car sequences))))
           (if (not (for-all? (cdr sequences) type?))
               (error "sequence:map : All sequences for map must be of the same type"
                      sequences))
           (sequence:from-list type?
                               (apply map fn
                                      (map sequence:to-list
                                           sequences)))))))


(sequence:map + '(1 2 3) '(5 5 5))
;Value: (6 7 8)

(sequence:map + '#(1 2 3) '#(5 5 5))
;Value: #(6 7 8)

(sequence:map (select-from-pair char<=?) "abcde" "ccccc")
;Value: "abccc"

(sequence:map + '(1 2 3) '(5 5))
;sequence:map : Cannot map onto sequences of different length

(sequence:map +)
;sequence:map : Need at least one sequence for map

(sequence:map 3 '(1 2 3) '(5 5 5))
;sequence:map : Cannot map a non-procedure

(sequence:map sqrt '(1 2 3) '(5 5 5))
;sequence:map : Cannot map procedure -- not of arity 2



;;; (sequence:for-each <procedure> <seq-1> ... <seq-n>)
;;;    Requires that the sequences given are of the same size and
;;;    type, and that the arity of the procedure is n.  Applies the
;;;    procedure to the n ith elements of the given sequences;
;;;    discards the value.  This is done for effect.


(define (apply-display fn)
  (lambda args
    (display (apply fn args))))

(define (sequence:for-each fn . sequences)
  (cond ((null? sequences)
          (error "sequence:for-each : Need at least one sequence for for-each"))
        ((not (procedure? fn))
         (error "sequence:for-each : Cannot for-each a non-procedure"))
        ((not (procedure-of-arity? fn (length sequences)))
         (error "sequence:for-each : Cannot for-each procedure -- not of arity" (length sequences)))
        ((not (apply = (map sequence:size sequences)))
         (error "sequence:for-each : Cannot for-each onto sequences of different length"))
        (else
         (let ((type? (sequence:type (car sequences))))
           (if (not (for-all? (cdr sequences) type?))
               (error "sequence:for-each : All sequences for for-each must be of the same type"
                      sequences))
           (apply for-each fn
                  (map sequence:to-list
                       sequences))))))

(sequence:for-each (apply-display +) '(1 2 3) '(5 5 5))
678
;Unspecified return value

(sequence:for-each (apply-display +) '#(1 2 3) '#(5 5 5))
678
;Unspecified return value

(sequence:for-each (apply-display (select-from-pair char<?))
                   "abcde"
                   "ccccc")
abccc
;Unspecified return value


;;;                 Filtration and Search
;;;
;;; (sequence:filter <sequence> <predicate>)
;;;    Returns a new sequence with exactly those elements of the given
;;;    sequence for which the predicate is true (does not return #f).

(define (sequence:internal-do-filter sequence predicate)
  (sequence:from-list (sequence:type sequence)
             (filter predicate
                     (sequence:to-list sequence))))

(define sequence:filter
  (make-generic-operator 2 #f))

(assign-operation sequence:filter sequence:internal-do-filter list?   (of-arity? 1))
(assign-operation sequence:filter sequence:internal-do-filter vector? (of-arity? 1))
(assign-operation sequence:filter sequence:internal-do-filter string? (of-arity? 1))


(sequence:filter '(1 2 3 4 5) even?)
;Value: (2 4)

(sequence:filter '#(1 2 3 4 5) even?)
;Value: #(2 4)

(sequence:filter "abcde" (lambda (x) (char>? x #\c)))
;Value: "de"

;;; (sequence:get-index <sequence> <predicate>)
;;;    Returns the index of the first element of the sequence that
;;;    satisfies the predicate.  Returns #f if no element of the
;;;    sequence satisfies the predicate.

(define (list-index lis pred)           ;adapted from SRFI 1
  (let loop ((lis lis)                  ;by Olin Shivers
             (i 0))
    (and (not (null? lis))
         (if (pred (car lis))
             i
             (loop (cdr lis)
                   (+ 1 i))))))

(define (sequence:internal-do-get-index sequence predicate)
  (list-index
   (sequence:to-list sequence)
   predicate))

(define sequence:get-index
  (make-generic-operator 2 #f))

(assign-operation sequence:get-index sequence:internal-do-get-index list?   (of-arity? 1))
(assign-operation sequence:get-index sequence:internal-do-get-index vector? (of-arity? 1))
(assign-operation sequence:get-index sequence:internal-do-get-index string? (of-arity? 1))



(sequence:get-index '(1 2 3 4 5) even?)
;Value: 1

(sequence:get-index '#(1 2 3 4 5) even?)
;Value: 1

(sequence:get-index "abcde" (lambda (x) (char>? x #\c)))
;Value: 3





;;; (sequence:get-element <sequence> <predicate>)
;;;    Returns the first element of the sequence that satisfies the
;;;    predicate.  Returns #f if no element of the sequence satisfies
;;;    the predicate.


(define (get-element lis pred)          ;adapted from SRFI 1
  (let loop ((lis lis)                  ;by Olin Shivers
             (i 0))
    (and (not (null? lis))
         (if (pred (car lis))
             (car lis)
             (loop (cdr lis)
                   (+ 1 i))))))


(define (sequence:internal-do-get-element sequence predicate)
  (get-element
   (sequence:to-list sequence)
   predicate))

(define sequence:get-element
  (make-generic-operator 2 #f))

(assign-operation sequence:get-element sequence:internal-do-get-element list?   (of-arity? 1))
(assign-operation sequence:get-element sequence:internal-do-get-element vector? (of-arity? 1))
(assign-operation sequence:get-element sequence:internal-do-get-element string? (of-arity? 1))



(sequence:get-element '(1 2 3 4 5) even?)
;Value: 2

(sequence:get-element '#(1 2 3 4 5) even?)
;Value: 2

(sequence:get-element "abcde" (lambda (x) (char>? x #\c)))
;Value: #\d




;;;                    Accumulation
;;;
;;; (sequence:fold-right <function> <initial> <sequence>)
;;;    Returns the result of applying the given binary function,
;;;    from the right, starting with the initial value.
;;;    For example, 
;;;      (sequence:fold-right list 'end '(a b c))
;;;           => (a (b (c end)))




(define (sequence:internal-do-fold-right kons seed sequence)
  (fold-right
   kons
   seed
   (sequence:to-list sequence)))

(define sequence:fold-right
  (make-generic-operator 3 #f))

(assign-operation sequence:fold-right
                  sequence:internal-do-fold-right
                  (of-arity? 2)
                  any?
                  list?)
(assign-operation sequence:fold-right
                  sequence:internal-do-fold-right
                  (of-arity? 2)
                  any?
                  vector?)
(assign-operation sequence:fold-right
                  sequence:internal-do-fold-right
                  (of-arity? 2)
                  any?
                  string?)

(sequence:fold-right * 1 '(1 2 3 4 5))
;Value: 120

(sequence:fold-right / 1 '(1 2 3 4 5))
;Value: 15/8


(sequence:fold-right cons '() '#(1 2 3 4 5))
;Value: (1 2 3 4 5)

(sequence:fold-right cons '() "abcde")
;Value: (#\a #\b #\c #\d #\e)



;;;
;;; (sequence:fold-left <function> <initial> <sequence>)
;;;    Returns the result of applying the given binary function,
;;;    starting with the initial value, from the left.
;;;    For example, 
;;;      (sequence:fold-left list 'start '(a b c))
;;;           => (((start a) b) c)





(define (sequence:internal-do-fold-left kons seed sequence)
  (fold-left
   kons
   seed
   (sequence:to-list sequence)))

(define sequence:fold-left
  (make-generic-operator 3 #f))

(assign-operation sequence:fold-left
                  sequence:internal-do-fold-left
                  (of-arity? 2)
                  any?
                  list?)
(assign-operation sequence:fold-left
                  sequence:internal-do-fold-left
                  (of-arity? 2)
                  any?
                  vector?)
(assign-operation sequence:fold-left
                  sequence:internal-do-fold-left
                  (of-arity? 2)
                  any?
                  string?)

(sequence:fold-left * 1 '(1 2 3 4 5))
;Value: 120

(sequence:fold-left / 1 '(1 2 3 4 5))
;Value: 1/120

(sequence:fold-left cons '() '#(1 2 3 4 5))
;Value: (((((() . 1) . 2) . 3) . 4) . 5)

(sequence:fold-left cons '() "abcde")
;Value: (((((() . #\a) . #\b) . #\c) . #\d) . #\e)



;;;; Problem 2.2


(define (sequence:mixed-append type? . sequences)
  (if (null? sequences)
      (error "Need at least one sequence for append"))
  (fold-right generic:binary-append
              (sequence:null type?)
              (map (sequence:coercer type?)
                   sequences)))

(sequence:mixed-append 
 list?
 '(1 2 3)
 '#(4 5 6)
 "abc")
;Value: (1 2 3 4 5 6 #\a #\b #\c)

(sequence:mixed-append 
 vector?
 '#(4 5 6)
 "abc"
 '(1 2 3))
;Value: #(4 5 6 #\a #\b #\c 1 2 3)

(sequence:mixed-append 
 string?
 "abc"
 '(#\1 #\2 #\3)
 '#(#\4 #\5 #\6))
;Value: "abc123456"



(define (sequence:mixed-map type? fn . sequences)
  (cond ((null? sequences)
         (error "sequence:map : Need at least one sequence for map"))
        ((not (procedure? fn))
         (error "sequence:map : Cannot map a non-procedure"))
        ((not (procedure-of-arity? fn (length sequences)))
         (error "sequence:map : Cannot map procedure -- not of arity" (length sequences)))
        ((not (apply = (map sequence:size sequences)))
         (error "sequence:map : Cannot map onto sequences of different length"))
        (else
         (sequence:from-list type?
                             (apply map fn
                                    (map sequence:to-list
                                         sequences))))))

(sequence:mixed-map vector? + '(1 2 3)
                              '#(5 5 5))
;Value: (6 7 8)


(define (fold-right kons seed lis-1 . lists)
  (if (not (pair? lists))
      (let loop ((lis lis-1))
        (if (null? lis)
            seed
            (kons (car lis)
                  (loop (cdr lis)))))
      (let ((lists (cons lis-1 lists)))
        (cond ((not (procedure-of-arity? kons (+ 1 (length lists))))
               (error "fold:right: procedure not of arity" (length lists)))
              (else
               (let loop ((lists lists))
                 (if (there-exists? lists null?)
                     seed
                     (let ((cars (map car lists))
                           (cdrs (map cdr lists)))
                       (apply kons
                              (reverse (cons (loop cdrs)
                                             (reverse cars))))))))))))

(define (fold-left kons seed lis-1 . lists)
  (if (not (pair? lists))
      (let loop ((lis lis-1))
        (if (null? lis)
            seed
            (kons (car lis)
                  (loop (cdr lis)))))
      (let ((lists (cons lis-1 lists)))
        (cond ((not (procedure-of-arity? kons (+ 1 (length lists))))
               (error "fold:right: procedure not of arity" (length lists)))
              (else
               (let loop ((lists lists)
                          (value seed))
                 (if (there-exists? lists null?)
                     value
                     (let ((cars (map car lists))
                           (cdrs (map cdr lists)))
                       (loop cdrs
                             (apply kons (reverse (cons value
                                                        (reverse cars)))))))))))))



(fold-right cons* '(z) '(a b c d) '(e e e e e e e e e))
;Value: (a e b e c e d e z)

(fold-right + 0 '(1 2 3) '(5 5 5 5))
;Value: 21


(fold-left cons* '(z) '(a b c d) '(e e e e e e e e e))
;Value: (d e c e b e a e z)

(fold-left + 0 '(1 2 3) '(5 5 5))
;Value: 21

(define (sequence:mixed-fold-right kons seed sequence-1 . sequences)
  (if (null? sequences)
      (sequence:fold-right kons seed sequence-1)
      (apply fold-right
             kons
             seed
             (sequence:coerce list? sequence-1)
             (map (sequence:coercer list?)
                  sequences))))


(define (sequence:mixed-fold-left kons seed sequence-1 . sequences)
  (if (null? sequences)
      (sequence:fold-left kons seed sequence-1)
      (apply fold-left
             kons
             seed
             (sequence:coerce list? sequence-1)
             (map (sequence:coercer list?)
                  sequences))))

(sequence:mixed-fold-right + 0 '(1 2 3) '#(5 5 5 5))
;Value: 21

(sequence:mixed-fold-right
 (lambda (x y z)
   (generic:binary-append
    (apply sequence:construct string? (make-list x y))
    z))
 (sequence:null string?)
 '(1 2 3)
 "abc")
;Value: "abbccc"


(sequence:mixed-fold-left
 (lambda (x y z)
   (generic:binary-append
    (apply sequence:construct string? (make-list x y))
    z))
 (sequence:null string?)
 '(1 2 3)
 "abc")
;Value: "cccbba"


;;;; Problem 2.3

; The changes that would need to be made to handle multiple finite
; arities include:

;  - using a cons cell for the arity in make-generic-operator

;  -creating a function that would perform an arity check given the
; arity (not a procedure) as input, and calling it appropriately in
; make-generic-operator

;  - changing assign-operation to check that the arity of the handler,
; the number of argument predicates, and the arity of the generic
; operator are all mutually compatible.


; This seems like an entirely reasonable thing to do -- it doesn't
; seem like it would cost much at all either in code-writing time or
; run-time, since it would only have to check the dispatch lookup
; table in the usual way, and it would improve flexibility.

; Handling arbitrary arities would require a much larger change.
; There would need to be some syntax for "list-of-pred?" and the
; matcher that locates the correct handler would need to check for two
; different patterns -- the explicit list given, and the one using a
; trailing sequence.  For instance, the dispatch on:

; (string? vector? vector? vector?)

; would need to check for that, and for:

; (string? . (all? vector))

; This would (slightly more than) double the time needed to determine
; that there was no correct dispatch for a predicate list, but that
; seems okay, since presumably once people reach the point of doing a
; large run in which runtime is important they will have removed
; sources of errors like that.  As long as it was set up to check for
; the original type of dispatch first, it wouldn't slow things down.
; This type of system isn't really tuned for speed anyway -- it seems
; like the sort of thing that would be more useful for spinning out a
; fast prototype than making a really speedy package.


;;; Problem 2.4


;;;
;;; Helper functions
;;;


(define (string-chop string n)
  (if (negative? n)
      (string-tail string (- n))
      (string-head string
                   (- (string-length string)
                      n))))

(string-chop "foo bar baz" 3)
;Value: "foo bar "

(string-chop "foo bar baz" -3)
;Value: " bar baz"

(define (reverse-arguments f)
  (lambda args
    (apply f (reverse args))))

((reverse-arguments -) 1 5)
;Value: 4

(define (remove-all x lis)
  (let loop ((lis lis))
    (cond ((null? lis)
           '())
          ((eqv? x (car lis))
           (loop (cdr lis)))
          (else
           (cons (car lis)
                 (loop (cdr lis)))))))



;;;
;;; generic binary arithmetic-like operators
;;;

(define +bin (make-generic-operator 2 +))
(define -bin (make-generic-operator 2 -))
(define *bin (make-generic-operator 2 *))
(define /bin (make-generic-operator 2 /))

;;;
;;; handler assignments
;;;

;;; addition

(assign-operation +bin
                  (reverse-arguments cons)
                  list?
                  any?)

(assign-operation +bin
                  (lambda (x y)
                    (vector-map + x y))
                  vector?
                  vector?)

(assign-operation +bin
                  (lambda (x y)
                    (vector-map (lambda (z) (+ y z))
                                x))
                  vector?
                  number?)

(assign-operation +bin
                  (lambda (y x)
                    (vector-map (lambda (z) (+ y z))
                                x))
                  number?
                  vector?)

(assign-operation +bin string-append string? string?)



;;; subtraction


(assign-operation -bin
                  (reverse-arguments remove-all)
                  list?
                  any?)

(assign-operation -bin
                  (lambda (x y)
                    (vector-map - x y))
                  vector?
                  vector?)

(assign-operation -bin
                  (lambda (x y)
                    (vector-map (lambda (z) (- y z))
                                x))
                  vector?
                  number?)


(assign-operation -bin
                  (lambda (y x)
                    (vector-map (lambda (z) (- z y))
                                x))
                  number?
                  vector?) 

(assign-operation -bin string-chop string? exact-integer?)


;;; multiplication

(assign-operation *bin
                  (reverse-arguments make-list)
                  list?
                  exact-integer?)

(assign-operation *bin
                  dot-product
                  vector?
                  vector?)

(assign-operation *bin
                  (lambda (x y)
                    (vector-map (lambda (z) (* y z))
                                x))
                  vector?
                  number?)

(assign-operation *bin
                  (lambda (y x)
                    (vector-map (lambda (z) (* y z))
                                x))
                  number?
                  vector?)

(assign-operation *bin
                  (lambda (string n)
                    (apply string-append
                           (make-list n string)))
                  string?
                  exact-integer?)

;;; division


(assign-operation /bin
                  (lambda (x y)
                    (vector-map (lambda (z) (/ z y))
                                x))
                  vector?
                  number?)

(assign-operation /bin
                  (lambda (y x)
                    (vector-map (lambda (z) (/ y z))
                                x))
                  number?
                  vector?)


(define generic-arithmetic-environment
  (extend-top-level-environment user-initial-environment))

(define ref-env (the-environment))

(environment-define generic-arithmetic-environment '+ +bin)
(environment-define generic-arithmetic-environment '- -bin)
(environment-define generic-arithmetic-environment '* *bin)
(environment-define generic-arithmetic-environment '/ /bin)
(environment-define generic-arithmetic-environment 'old-env ref-env)
(ge generic-arithmetic-environment)

; (ge old-env)

;;;
;;; examples
;;;

;;  addition

(+ '(a b c)
   'z)
;Value: (z a b c)

(+ '#(1 2 3)
   '#(5 5 5))
;Value: #(6 7 8)

(+ '#(1 2 3)
   5)
;Value: #(6 7 8)

(+ 5
   '#(1 2 3))
;Value: #(6 7 8)

(+ "foo "
   "bar")
;Value: "foo bar"


;;  subtraction

(- '(a x b x c)
   'x)
;Value: (a b c)

(- '#(5 5 5)
   '#(1 2 3))
;Value: #(4 3 2)

(- '#(1 2 3)
   5)
;Value: #(4 3 2)

(- 5
   '#(1 2 3))
;Value: #(4 3 2)

(- "foo bar baz"
   4)
;Value: "foo bar"

(- "foo bar baz"
   -4)
;Value: "bar baz"


;;  multiplication

(* '(a b c)
   3)
;Value: ((a b c) (a b c) (a b c))

(* '#(5 5 5)
   '#(1 2 3))
;Value: 30

(* 5
   '#(1 2 3))
;Value: #(5 10 15)

(* '#(1 2 3)
   5)
;Value: #(5 10 15)


;;  division

(/ '#(5 10 15)
   5)
;Value: #(1 2 3)

(/ 6
   '#(1 2 3))
;Value: #(6 3 2)


;;;;
;;;; Problem 2.5
;;;;


; Doing dispatch with predicates rather than tags costs efficiency
; because for each object you need to check whether each predicate
; applies to it.  Intermediate results can be cached, so you're not
; going to need to check whether it's a number more than once if
; you're careful, but you're still likely to often have to check an
; argument with more than one predicate while doing the dispatch.

; This could be improved some with a method-ordering system that would
; let you sort the dispatch lookup by likelihood.  That would also
; allow a priority system for dispatch such that you could make sure
; that (exact-integer? string?) would be checked before (number?
; string?) and could have a different handler.

; This capability would also add functionality that would be really
; hard to implement in a tagging system.  For instance you might have
; employee records, and want to be able to use different handlers
; based on predicates like temporary? or vested?, and only default to
; employee? if those weren't satisfied.  Implementing that with a
; tagging system wouldn't gain you much in efficiency, since you'd
; still have to check the record for multiple tags and figure out
; which set of tags is the first one that should cue a dispatch.  At
; that point you're pretty much rolling your own predicate system, and
; losing the efficiency advantage.

; If you're building a system that you're sure isn't going to need to
; be expanded and which needs to run fast, then tagging might be a
; reasonable option.  But at that point you might do better to use the
; more flexible system to get a prototype up and running and then
; profile it to figure out where you might advantageously replace the
; generic operators with more specific functions.