naga:順序付Listの合成

順序付Listの合成

順序付リストの合成を行う手続きを作ってみた。3.4.2にある (a, b, c) と (x, y, z) から (a, b, c, x, y, z) ... (x, y, z, a, b, c)
の20のリストを得る手続きである。

 ;;gosh> (get-mlists '((a b c) (x y z))) のようにして使う。

;;; 複数の順序listをマージしてできる順序listのリストを得たい。
;;; ((a1 a2) (b1 b2))
;;; ->((a1 a2 b1 b2) (a1 b1 a2 b2) (a1 b1 b2 a2) ...
;;;                  (b1 a1 a2 b2) (b1 a1 b2 a2) (b1 b2 a1 a2))

;; データ構造 seq
;;   List の List
;;   ・最初のlist は マージしてできつつある順序リスト(=マージリストと呼ぶ。逆順になっている)
;;     最初は'()
;;   ・以降のリストは元となる順序リスト。但し、各リストのマージリストに移動した項は
;;     含まれない。
;;   ((merged-list 最初は null) (olist A 順序付List) (olist B) ... (olist N))
;;  olist の先頭の項を mlist に移動させた新しい seq を作る操作を全ての olist に
;;  ついて行い、得られた seq をlistにする。その各seqに対し同様な操作を繰り返し、
;;  すべての項が mlist に移れば、seq の先頭が求める list の要素となっている。 
(define (mlist-s seq) (car seq))
(define (olists-s seq) (cdr seq))

(define (get-mlists olists)
  ;; olist の list から seq を作る。
  (define (make-seq olists)
    (cons '() olists))
  ;; すべての olist の要素数を加えて総要素数を得る。
  (define (get-num-allitems olists nitem)
    (cond ((null? olists) nitem)
          (else (get-num-allitems
                 (cdr olists)
                 (+ nitem (length (car olists)))))))
  ;; 各 seq の mlist を更新した新しい seq リストを作る。
  (define (update-seqs seqs)
    (define (iter iseqs rseqs)
      (cond ((null? iseqs) rseqs)
            (else (iter (cdr iseqs)
                        (if (null? rseqs)
                            (make-new-seqlist (car iseqs))
                            (append rseqs (make-new-seqlist (car iseqs))))))))
    (iter seqs '()))
  ;; 各 olist の最初の要素を mlist に移動した新しい seq のリストを得る。
  (define (make-new-seqlist seq)
    (define (iter olists seqs)
      (cond ((null? olists) (reverse seqs))
            ((null? (car olists)) (iter (cdr olists) seqs))
            (else (iter (cdr olists) (cons (make-newseq seq (car olists)) seqs)))))
    (iter (olists-s seq) '()))
  ;; 指定された olist の最初の要素 mlist に移動した新しい seq を作る。
  ;; mlist の要素の順は逆になっている。
  (define (make-newseq seq tlist)
    (define (iter iolists rolists)
      (cond ((null? iolists) (reverse rolists))
            (else (iter (cdr iolists)
                        (cons
                         (if (eq? (car iolists) tlist)
                             (cdr (car iolists))
                             (car iolists))
                         rolists)))))
    (cons (cons (car tlist) (mlist-s seq))
          (iter (olists-s seq) '())))

  (let ((nitem (get-num-allitems olists 0))
        (seq (make-seq olists)))
    (define (rec iseqs)
      (if (eq? (length (mlist-s (car iseqs))) nitem)
          iseqs
          (rec (update-seqs iseqs))))
    (map (lambda (x) (reverse (car x))) (rec (list seq))))
  )


#|
(define a '(a1 a2))
(define b '(b1 b2))
(define c '(c1))
(define k (list a b c))
(define l (list '() a b c))(define (disp-mlists l)
  (define (iter iseqs)
    (if (null? iseqs)
        'done
        (begin (print (car iseqs)) (iter (cdr iseqs)))))
  (iter (get-mlists l))) |#

これを使うと、例えば問題3.39は

(define p1-v 0)
(define p1 (list '(set! p1-v (* x x)) '(set! x p1-v)))
(define p2-v 0)
(define p2 (list '(set! x  (+ x 1))))

(define (cps l)
  (define (iter iseqs)
    (if (null? iseqs)
        'done
        (begin (set! x 10)
               (eval (cons 'begin (car iseqs)) '())
               (print x) (print (car iseqs))
               (iter (cdr iseqs)))))
  (iter (get-mlists l)))

(define x 0)
(define cp (list p1 p2))
gosh> (cps cp)
101
((set! p1-v (* x x)) (set! x p1-v) (set! x (+ x 1)))
100
((set! p1-v (* x x)) (set! x (+ x 1)) (set! x p1-v))
121
((set! x (+ x 1)) (set! p1-v (* x x)) (set! x p1-v))
done

のように解くことができる。もちろん、手で解いたほうが早いのですが。