TSS deep

The Seasoned Schemer 16章。

(deep 3)

; -> (((pizza)))

というような手続きを書け、とのこと。無理やり（？）fold-rightなんかで書いてみたり。

	;; deep
	;; (deep 3)
	;; -> (((pizza)))
	;; (deep 7)
	;; -> (((((((pizza)))))))
	;; (deep 0)
	;; -> pizza
	(define (deep n)
	(if (zero? n)
	'pizza
	(cons (deep (- n 1))
	'())))
	(deep 3)
	; -> (((pizza)))
	;; again letrec
	(define (make-deep a)
	(lambda (n)
	(letrec
	((d (lambda (n)
	(if (zero? n)
	a
	(cons (d (- n 1)) '())))))
	(d n))))
	((make-deep 'pizza) 3)
	; -> (((pizza)))
	;; again named-let, accumulate
	(define (make-deep a)
	(lambda (n)
	(let loop ((n n)
	(acc a))
	(if (zero? n)
	acc
	(loop (- n 1)
	(cons acc '()))))))
	((make-deep 'pizza) 3)
	; -> (((pizza)))
	;; again fold-right
	(use srfi-1)
	(define (make-deep a)
	(lambda (n)
	(fold-right (lambda (e acc)
	(if (zero? e)
	acc
	(cons acc '())))
	a
	(iota (+ n 1)))))
	((make-deep 'pizza) 5)
	; -> (((((pizza)))))
	;; The Seasoned Schemer
	(define sub1
	(lambda (n)
	(- n 1)))
	(define deep
	(lambda (n)
	(cond
	((zero? n)(quote pizza))
	(else (cons (deep (sub1 n))
	(quote ()))))))
	(deep 3)
	; -> (((pizza)))

view raw deep.scm hosted with ❤ by GitHub

続きのdeepR, deepMなど。

	;; Ns, Rs
	(define Ns (quote ()))
	(define deepR
	(lambda (n)
	(set! Ns (cons n Ns))
	(deep n)))
	(deepR 3)
	; -> (((pizza)))
	Ns
	; -> (3)
	(define Rs (quote ()))
	(define Ns (quote ()))
	(define deepR
	(lambda (n)
	(set! Rs (cons (deep n) Rs))
	(set! Ns (cons n Ns))
	(deep n)))
	(deepR 3)
	; -> (((pizza)))
	Ns
	; -> (3)
	Rs
	; -> ((((pizza))))
	(deepR 5)
	; -> (((((pizza)))))
	Ns
	; -> (5 3)
	Rs
	; -> ((((((pizza))))) (((pizza))))
	(deepR 3)
	; -> (((pizza)))
	Ns
	; -> (3 5 3)
	Rs
	; -> ((((pizza))) (((((pizza))))) (((pizza))))
	;; ((((pizza)))
	;; (((((pizza)))))
	;; (((pizza))))
	;; find
	;; (find 3 Ns Rs)
	;; -> (((pizza)))
	;; (find 5 Ns Rs)
	;; -> (((((pizza)))))
	(define (find n ns rs)
	(cond
	((or (null? ns)
	(null? rs)) #f)
	((= n (car ns))(car rs))
	(else (find (- n 1)(cdr ns)(cdr rs)))))
	(find 3 Ns Rs)
	; -> (((pizza)))
	;; The Seasoned Schemer
	(define find
	(lambda (n Ns Rs)
	(letrec
	((A (lambda (ns rs)
	(cond
	((= (car ns) n)(car rs))
	(else (A (cdr ns)(cdr rs)))))))
	(A Ns Rs))))
	(find 5 Ns Rs)
	; -> (((((pizza)))))
	;; deepM
	(define (member? a lat)
	(let/cc skip
	(fold (lambda (e acc)
	(if (eq? e a)
	(skip #t)
	acc))
	#f lat)))
	(member? 1 '(a b c))
	; -> #f
	(member? 'c '(a b c d e))
	; -> #t
	(define deepM
	(lambda (n)
	(if (member? n Ns)
	(find n Ns Rs)
	(deepR n))))
	Ns
	; -> (3 5 3)
	Rs
	; -> ((((pizza))) (((((pizza))))) (((pizza))))
	(set! Ns (cdr Ns))
	(set! Rs (cdr Rs))
	Ns
	; -> (5 3)
	Rs
	; -> ((((((pizza))))) (((pizza))))
	(define deepM
	(lambda (n)
	(if (member? n Ns)
	(find n Ns Rs)
	(let ((result (deep n)))
	(set! Rs (cons result Rs))
	(set! Ns (cons n Ns))
	result))))
	; (deep 6) -> (cons (deep 5)(quote ()))
	(define deep
	(lambda (m)
	(cond
	((zero? m)(quote pizza))
	(else (cons (deepM (sub1 m))
	(quote ()))))))
	(deep 6)
	; -> ((((((pizza))))))
	Ns
	; -> (5 3)
	(deep 9)
	; -> (((((((((pizza)))))))))
	Ns
	; -> (8 7 6 5 3)
	(define deepM
	(let ((Rs (quote ()))
	(Ns (quote ())))
	(lambda (n)
	(if (member? n Ns)
	(find n Ns Rs)
	(let ((result (deep n)))
	(set! Rs (cons result Rs))
	(set! Ns (cons n Ns))
	result)))))
	(deepM 16)
	; -> ((((((((((((((((pizza))))))))))))))))
	(define find
	(lambda (n Ns Rs)
	(letrec
	((A (lambda (ns rs)
	(cond
	((null? ns) #f)
	((= (car ns) n)(car rs))
	(else (A (cdr ns)(cdr rs)))))))
	(A Ns Rs))))
	(define (atom? a)
	(and (not (pair? a))
	(not (null? a))))
	(define deepM
	(let ((Rs (quote ()))
	(Ns (quote ())))
	(lambda (n)
	(if (atom? (find n Ns Rs))
	(let ((result (deep n)))
	(set! Rs (cons result Rs))
	(set! Ns (cons n Ns))
	result)
	(find n Ns Rs)))))
	(define deepM
	(let ((Rs (quote ()))
	(Ns (quote ())))
	(lambda (n)
	(let ((exists (find n Ns Rs)))
	(if (atom? exists)
	(let ((result (deep n)))
	(set! Rs (cons result Rs))
	(set! Ns (cons n Ns))
	result)
	exists)))))

view raw deepR, deepM.scm hosted with ❤ by GitHub