TSS scramble

scrambleが「何をしているか」はわかった。でも目的がわからない。何これ。

;; scramble
; (1 1 1 3 4 2 1 1 9 2) -> (1 1 1 1 1 4 1 1 1 9)
; (1 2 3 4 5 6 7 8 9) -> (1 1 1 1 1 1 1 1 1)
; (1 2 3 1 2 3 4 1 8 2 10) -> (1 1 1 1 1 1 1 1 2 8 2)
(define one?
  (lambda (n)
    (= n 1)))
(define sub1
  (lambda (n)
    (- n 1)))
(define pick
  (lambda (n lat)
    (if (one? n)
        (car lat)
        (pick (sub1 n)(cdr lat)))))
(define pick
  (lambda (n lat)
    (list-ref lat (sub1 n))))
(pick 3 '(a b c d e f g))
; -> c
(define scramble-b
  (lambda (tup rev-pre)
    (if (null? tup)
        '()
        (cons (pick (car tup)
                    (cons (car tup) rev-pre))
              (scramble-b (cdr tup)
                          (cons (car tup) rev-pre))))))
(define scramble
  (lambda (tup)
    (scramble-b tup '())))
(define scramble-b
  (lambda (tup rev-pre)
    (if (null? tup)
        '()
        (let* ((n (car tup))
               (rev (cons n rev-pre)))
          (display (format "n = ~a, ret = ~a, tup = ~a, rev-pre = ~a\n"
                           n (pick n rev) tup rev-pre))
          (cons (pick n rev)
                (scramble-b (cdr tup) rev))))))
; (1 1 1 3 4 2 1 1 9 2) -> (1 1 1 1 1 4 1 1 1 9)
(scramble '(1 1 1 3 4 2 1 1 9 2))
;; n = 1, ret = 1, tup = (1 1 1 3 4 2 1 1 9 2), rev-pre = ()
;; n = 1, ret = 1, tup = (1 1 3 4 2 1 1 9 2), rev-pre = (1)
;; n = 1, ret = 1, tup = (1 3 4 2 1 1 9 2), rev-pre = (1 1)
;; n = 3, ret = 1, tup = (3 4 2 1 1 9 2), rev-pre = (1 1 1)
;; n = 4, ret = 1, tup = (4 2 1 1 9 2), rev-pre = (3 1 1 1)
;; n = 2, ret = 4, tup = (2 1 1 9 2), rev-pre = (4 3 1 1 1)
;; n = 1, ret = 1, tup = (1 1 9 2), rev-pre = (2 4 3 1 1 1)
;; n = 1, ret = 1, tup = (1 9 2), rev-pre = (1 2 4 3 1 1 1)
;; n = 9, ret = 1, tup = (9 2), rev-pre = (1 1 2 4 3 1 1 1)
;; n = 2, ret = 9, tup = (2), rev-pre = (9 1 1 2 4 3 1 1 1)
;; (1 1 1 1 1 4 1 1 1 9)
; (1 2 3 4 5 6 7 8 9) -> (1 1 1 1 1 1 1 1 1)
(scramble '(1 2 3 4 5 6 7 8 9))
;; n = 1, ret = 1, tup = (1 2 3 4 5 6 7 8 9), rev-pre = ()
;; n = 2, ret = 1, tup = (2 3 4 5 6 7 8 9), rev-pre = (1)
;; n = 3, ret = 1, tup = (3 4 5 6 7 8 9), rev-pre = (2 1)
;; n = 4, ret = 1, tup = (4 5 6 7 8 9), rev-pre = (3 2 1)
;; n = 5, ret = 1, tup = (5 6 7 8 9), rev-pre = (4 3 2 1)
;; n = 6, ret = 1, tup = (6 7 8 9), rev-pre = (5 4 3 2 1)
;; n = 7, ret = 1, tup = (7 8 9), rev-pre = (6 5 4 3 2 1)
;; n = 8, ret = 1, tup = (8 9), rev-pre = (7 6 5 4 3 2 1)
;; n = 9, ret = 1, tup = (9), rev-pre = (8 7 6 5 4 3 2 1)
;; (1 1 1 1 1 1 1 1 1)
; (1 2 3 1 2 3 4 1 8 2 10) -> (1 1 1 1 1 1 1 1 2 8 2)
(scramble '(1 2 3 1 2 3 4 1 8 2 10))
;; n = 1, ret = 1, tup = (1 2 3 1 2 3 4 1 8 2 10), rev-pre = ()
;; n = 2, ret = 1, tup = (2 3 1 2 3 4 1 8 2 10), rev-pre = (1)
;; n = 3, ret = 1, tup = (3 1 2 3 4 1 8 2 10), rev-pre = (2 1)
;; n = 1, ret = 1, tup = (1 2 3 4 1 8 2 10), rev-pre = (3 2 1)
;; n = 2, ret = 1, tup = (2 3 4 1 8 2 10), rev-pre = (1 3 2 1)
;; n = 3, ret = 1, tup = (3 4 1 8 2 10), rev-pre = (2 1 3 2 1)
;; n = 4, ret = 1, tup = (4 1 8 2 10), rev-pre = (3 2 1 3 2 1)
;; n = 1, ret = 1, tup = (1 8 2 10), rev-pre = (4 3 2 1 3 2 1)
;; n = 8, ret = 2, tup = (8 2 10), rev-pre = (1 4 3 2 1 3 2 1)
;; n = 2, ret = 8, tup = (2 10), rev-pre = (8 1 4 3 2 1 3 2 1)
;; n = 10, ret = 2, tup = (10), rev-pre = (2 8 1 4 3 2 1 3 2 1)
;; (1 1 1 1 1 1 1 1 2 8 2)
(define scramble
  (lambda (tup)
    (letrec ((iter (lambda (t rev-pre)
                     (if (null? t)
                         '()
                         (let* ((n (car t))
                                (rev (cons n rev-pre)))
                           (cons (pick n rev)
                                 (iter (cdr t) rev)))))))
      (iter tup '()))))

view raw TheSeasonedSchemer.scm This Gist brought to you by GitHub.

追記

• vallog: scramble (The Seasoned Schemer)