/var/log/messages

2011-08-30

[] letcc

フライングして書いてみようかな。以下。

(define-syntax letcc
  (syntax-rules ()
    ((letcc hop body1 body2 ...)
     (call-with-current-continuation (lambda (hop) body1 body2 ...)))))

(define member?
  (lambda (a lat)
    (cond ((null? lat) #f)
	  ((eq? (car lat) a) #t)
	  (else
	   (member? a (cdr lat))))))

(define intersect
  (lambda (set1 set2)
    (cond ((null? set1) '())
	  ((member? (car set1) set2)
	   (cons (car set1)
		 (intersect (cdr set1) set2)))
	  (else
	   (intersect (cdr set1) set2)))))

(define intersectall
  (lambda (lset)
    (letcc hop
	   (letrec
	       ((A (lambda (lset)
		     (cond ((null? (car lset)) (hop '()))
			   ((null? (cdr lset)) (car lset))
			   (else
			    (intersect (car lset)
				       (A (cdr lset))))))))
	     (cond ((null? lset) '())
		   (else
		    (A lset)))))))

で、上記を gosh に吸わせた出力が以下。

gosh> (intersectall '((3 mangoes and) () (3 diet hamburgers)))
()
gosh> (intersectall '((3 steaks and) (no food and) (three baked potatoes) (3 diet hamburgers)))
()
gosh> (intersectall '((3 mangos and) (3 kiwis and) (3 hamburgers)))
(3)
gosh> 

大丈夫なのかどうか。

トラックバック - http://d.hatena.ne.jp/yamanetoshi/20110830/1314706816