ヤドカリ自習室(第二倉庫)

|

2009-06-19

CPSメモ 16:18

(define (flatten lst) 
  (define (flatten/cps lst cont)
    (cond ((null? lst) (cont '()))
          ((symbol? lst) (cont (list lst)))
          (else
           (flatten/cps
            (car lst)
            (lambda (f)
              (flatten/cps
               (cdr lst)
               (lambda (r) (cont (append f r)))))))))
  (flatten/cps lst values))

2008-09-25

[]問題4.44改 08:06

(define (queens)
  (define (increase-check level value points)
    (if (and (> level 0) (> 9 value))
        (begin
          (require (not (member (cons level value) points)))
          (increase-check (- level 1) (+ value 1) points))
        true))
  (define (decrease-check level value points)
    (if (and (> level 0) (> value 0))
        (begin
          (require (not (member (cons level value) points)))
          (decrease-check (- level 1) (- value 1) points))
        true))
  (define (cross-check level value points)
    (increase-check (- level 1) (+ value 1) points)
    (decrease-check (- level 1) (- value 1) points))
  (let ((q1 (amb 1 2 3 4 5 6 7 8))
        (q2 (amb 1 2 3 4 5 6 7 8)))
    (let ((points1 (list (cons 1 q1))))
      (require (not (= q2 q1)))
      (cross-check 2 q2 points1)
      (let ((q3 (amb 1 2 3 4 5 6 7 8)))
        (let ((points2 (cons (cons 2 q2) points1)))
          (require (not (member q3 (list q1 q2))))
          (cross-check 3 q3 points2)
          (let ((q4 (amb 1 2 3 4 5 6 7 8)))
            (let ((points3 (cons (cons 3 q3) points2)))
              (require (not (member q4 (list q1 q2 q3))))
              (cross-check 4 q4 points3)
              (let ((q5 (amb 1 2 3 4 5 6 7 8)))
                (let ((points4 (cons (cons 4 q4) points3)))
                  (require (not (member q5 (list q1 q2 q3 q4))))
                  (cross-check 5 q5 points4)
                  (let ((q6 (amb 1 2 3 4 5 6 7 8)))
                    (let ((points5 (cons (cons 5 q5) points4)))
                      (require (not (member q6 (list q1 q2 q3 q4 q5))))
                      (cross-check 6 q6 points5)
                      (let ((q7 (amb 1 2 3 4 5 6 7 8)))
                        (let ((points6 (cons (cons 6 q6) points5)))
                          (require (not (member q7 (list q1 q2 q3 q4 q5 q6))))
                          (cross-check 7 q7 points6)
                          (let ((q8 (amb 1 2 3 4 5 6 7 8)))
                            (let ((points7 (cons (cons 7 q7) points6)))
                              (require (not (member q8 (list q1 q2 q3 q4 q5 q6 q7))))
                              (cross-check 8 q8 points7)
                              (list (cons 1 q1) (cons 2 q2) (cons 3 q3) (cons 4 q4)
                                    (cons 5 q5) (cons 6 q6) (cons 7 q7) (cons 8 q8)))))))))))))))))

2008-09-24

[]問題4.44 02:25

(define (queens)
  (define (increase-check level value points)
    (if (and (> level 0) (> 9 value))
        (begin
          (require (not (member (cons level value) points)))
          (increase-check (- level 1) (+ value 1) points))
        true))
  (define (decrease-check level value points)
    (if (and (> level 0) (> value 0))
        (begin
          (require (not (member (cons level value) points)))
          (decrease-check (- level 1) (- value 1) points))
        true))
  (define (cross-check level value points)
    (increase-check level value points)
    (decrease-check level value points))
  (let ((q1 (amb 1 2 3 4 5 6 7 8))
        (q2 (amb 1 2 3 4 5 6 7 8)))
    (require (not (= q2 q1)))
    (cross-check 2 q2 (list (cons 1 q1)))
    (let ((q3 (amb 1 2 3 4 5 6 7 8)))
      (require (not (member q3 (list q1 q2))))
      (cross-check 3 q3 (list (cons 1 q1) (cons 2 q2)))
      (let ((q4 (amb 1 2 3 4 5 6 7 8)))
        (require (not (member q4 (list q1 q2 q3))))
        (cross-check 4 q4 (list (cons 1 q1) (cons 2 q2) (cons 3 q3)))
        (let ((q5 (amb 1 2 3 4 5 6 7 8)))
          (require (not (member q5 (list q1 q2 q3 q4))))
          (cross-check 5 q5 (list (cons 1 q1) (cons 2 q2) (cons 3 q3)
                                  (cons 4 q4)))
          (let ((q6 (amb 1 2 3 4 5 6 7 8)))
            (require (not (member q6 (list q1 q2 q3 q4 q5))))
            (cross-check 6 q6 (list (cons 1 q1) (cons 2 q2) (cons 3 q3)
                                    (cons 4 q4) (cons 5 q5)))
            (let ((q7 (amb 1 2 3 4 5 6 7 8)))
              (require (not (member q7 (list q1 q2 q3 q4 q5 q6))))
              (cross-check 7 q7 (list (cons 1 q1) (cons 2 q2) (cons 3 q3)
                                      (cons 4 q4) (cons 5 q5) (cons 6 q6)))
              (let ((q8 (amb 1 2 3 4 5 6 7 8)))
                (require (not (member q8 (list q1 q2 q3 q4 q5 q6 q7))))
                (cross-check 8 q8 (list (cons 1 q1) (cons 2 q2) (cons 3 q3)
                                        (cons 4 q4) (cons 5 q5) (cons 6 q6)
                                        (cons 7 q7)))
                (list (cons 1 q1) (cons 2 q2) (cons 3 q3) (cons 4 q4)
                      (cons 5 q5) (cons 6 q6) (cons 7 q7) (cons 8 q8))))))))))

2008-09-21

[]問題4.43の後半 17:31

(define (daughters)
  (let ((moore (amb 'mary-ann 'rosalind 'gabrielle))
        (barnacle 'melissa)
        (hall (amb 'gabrielle 'lorna 'mary-ann))
        (downing (amb 'gabrielle 'lorna 'rosalind 'mary-ann))
        (parker (amb 'lorna 'rosalind)))
    (require (distinct? (list moore hall downing parker)))
    (require (or (and (eq? hall 'gabrielle)
                      (eq? parker 'rosalind))
                 (and (eq? moore 'gabrielle)
                      (eq? parker 'lorna))))
    (list (list 'moore moore)
          (list 'barnacle barnacle)
          (list 'hall hall)
          (list 'downing downing)
          (list 'parker parker))))

2008-09-03

[]問題4.41をもっと素直に 19:19

(define (multiple-dwelling-scheme)
  (define result '())
  (define (proceed b c f m s)
    (if (= s 5)
        (if (= m 5) 
            (if (= f 5)
                (if (= c 5)
                    (if (= b 5)
                        result
                        (require-loop (+ b 1) 1 1 1 1))
                    (require-loop b (+ c 1) 1 1 1))
                (require-loop b c (+ f 1) 1 1))
            (require-loop b c f (+ m 1) 1))
        (require-loop b c f m (+ s 1))))
  (define (require-loop b c f m s)
    (cond ((not (distinct? (list b c f m s))) (proceed b c f m s))
          ((= b 5) (proceed b c f m s))
          ((= c 1) (proceed b c f m s))
          ((= f 5) (proceed b c f m s))
          ((= f 1) (proceed b c f m s))
          ((< m c) (proceed b c f m s))
          ((= (abs (- s f)) 1) (proceed b c f m s))
          ((= (abs (- f c)) 1) (proceed b c f m s))
          (else
           (set! result (cons (list (list 'baker b)
                                    (list 'cooper c)
                                    (list 'fletcher f)
                                    (list 'miller m)
                                    (list 'smith s))
                              result))
           (proceed b c f m s))))
  (require-loop 1 1 1 1 1))

[]問題4.42 xor00:36

(define (five-girls)
  (define (xor a b)
    (or (and a (not b))
        (and (not a) b)))
  (let ((betty (amb 1 2 3 4 5))
        (ethel (amb 1 2 3 4 5))
        (joan (amb 1 2 3 4 5))
        (kitty (amb 1 2 3 4 5))
        (mary (amb 1 2 3 4 5)))
    (require
     (distinct? (list betty ethel joan kitty mary)))
    (require (xor (= kitty 2) (= betty 3)))
    (require (xor (= ethel 1) (= joan 2)))
    (require (xor (= joan 3) (= ethel 5)))
    (require (xor (= kitty 2) (= mary 4)))
    (require (xor (= mary 4) (= betty 1)))
    (list (list 'betty betty)
          (list 'ethel ethel)
          (list 'joan joan)
          (list 'kitty kitty)
          (list 'mary mary))))

[]問題4.41ファイナルアンサー 01:04

(use srfi-1)
(use util.combinations)

(define (multiple-dwelling-scheme)
  (define (func lst)
    (and
     (not (eq? (fifth lst) 'baker))
     (not (eq? (first lst) 'cooper))
     (not (eq? (fifth lst) 'fletcher))
     (not (eq? (first lst) 'fletcher))
     (> (list-index (lambda (x) (eq? 'miller x)) lst)
        (list-index (lambda (x) (eq? 'cooper x)) lst))
     (not (= 1 (abs (- (list-index (lambda (x) (eq? 'smith x)) lst)
                       (list-index (lambda (x) (eq? 'fletcher x)) lst)))))
     (not (= 1 (abs (- (list-index (lambda (x) (eq? 'fletcher x)) lst)
                       (list-index (lambda (x) (eq? 'cooper x)) lst)))))))
  (map
   (lambda (lst) (map list lst '(1 2 3 4 5)))
   (filter func (permutations '(baker cooper fletcher miller smith)))))
|