;;; Solution courtesy of Jason Hartline.

(define (foldr op id lst)
   (if (null? lst)
       id
       (op (car lst) (foldr op id (cdr lst)))
   )
)

;; curry function
(define (curry f . first-args)
   (lambda second-args (apply f (append first-args second-args)))
)


;;;
;;; A constraint is implemented as function that is
;;; passed the entire argument list and if first arguments match the 
;;; constraint, then it returns the remaining arguments.  Otherwise, it 
;;; returns false.
;;;

(define (arguments-ok? arg-list c)
   (null? (c arg-list))
)     

(define (overload orig new c)
   (lambda args 
     (if (arguments-ok? args c)
         (apply new args)
         (apply orig args)
     )
   )
)

(define (overload-list orig fc-list)
  (foldr (lambda (fc-new orig) (overload orig (car fc-new) (cadr fc-new)))
	 orig
	 fc-list   
  )
)

(define (make-constraint pred)
   (lambda (args) 
     (cond 
       ((null? args)       #f)
       ((pred (car args))  (cdr args))
       (else               #f) 
     )
   )
)

(define (empty-constraint) id)

(define (anything-constraint)
   (make-constraint (lambda (x) #t))
)

(define (append-two-constraints c1 c2)
  (lambda (args)
    (let ((result (c1 args)))
         (if (eq? result #f)
             #f
	     (c1 result)
         )
    )
  )
)

(define (append-constraints . consts)
   (foldr append-two-constraints (empty-constraint) consts)
)
	
(define (combine-constraints c1 c2)
   (lambda (args)
     (let ((result (c1 args)))
       (if (eq? result #f)
	   (c2 args)
	   result
       )
     )
   )
)

;;;
;;; this uses repeated squaring to get c^k.  E.g.
;;;
;;; (repeat-constraint c 4)
;;;
;;; is the same as:
;;;
;;; (let ((repeated (repeat-constraint c 2)))
;;;      (append-constraints repeated repeated)
;;; )
;;;
;;; See Chapter 1 of SCIP for a great discussion of repeated squaring.
;;;
(define (repeat-constraint c k)
   (cond ((= k 0) (empty-constraint))
         ((= k 1) c)
         (else (let ((repeated-half-k (repeat-constraint c (quotient k 2)))
		     (extra (if (= (remainder k 2) 1) 
                                c
				(empty-constraint)
                            )
		     )
                    )
		    (append-constraints extra repeated repeated)
                )
         )
   )
)
            
(define (infinite-repeat-constraint c)
   (define (infinite-constraint args)
       (if (null? args) 
	   '()
	   (let ((result (c args)))
	        (if (eq? #f result)
		    #f
		    (infinite-constraint result)
		)
           )
       )
   )
   infinite-constraint
)