;;;;;; General car & cdr composition                     -*- Scheme -*-

;;; Taylor Campbell wrote this code; he places it in the public domain.

;;; C...R* is pretty simple: (c...r* "cadaddar") returns (lambda (pair)
;;; (car (cdr (car (cdr (cdr (car pair))))))).  C...R* will also accept
;;; a symbol instead of a string -- thus (c...r* 'cadaddar) would work
;;; in the previous example as well.  C...R doesn't return a function
;;; to do the work; it does the work itself: (c...r 'caddadr PAIR) is
;;; equivalent to (car (cdr (cdr (car (cdr PAIR))))).

(define (maybe-symbol->string s)
  (cond ((symbol? s) (symbol->string s))
        ((string? s) s)
        (else (error "Not a symbol or string" s))))

(define (ca/dr char)
  (case char
    ((#\a #\A) car)
    ((#\d #\D) cdr)
    (else (error "Bad CAR/CDR char" char))))

(define (c...r* s)
  (let ((s* (maybe-symbol->string s)))
    (string-fold-right (lambda (char f)
                         (compose (ca/dr char) f))
                       (lambda (x) x)
                       s*
                       1
                       (- (string-length s*) 1))))

(define (c...r s p)
  (let ((s* (maybe-symbol->string s)))
    (string-fold-right (lambda (char p*)
                         ((ca/dr char) p*))
                       p
                       s*
                       1
                       (- (string-length s*) 1))))

(define (compose f g)
  (lambda (x) (f (g x))))

(define (string-fold-right kons knil str start end)
  (do ((i (- end 1) (- i 1))
       (knil knil (kons (string-ref str i) knil)))
      ((< i start) knil)))