fannkuch-redux.scm

   1 (define (rotate ls)
   2   (if (null? ls)
   3       ls
   4       (append (cdr ls) (list (car ls)))))
   5
   6 (define (permutations ls)
   7   (let ((len (length ls)))
   8     (if (= 1 len)
   9         (list ls)
  10         (let r ((result '()) (ls1 ls) (rotate-times len))
  11           (if (= 0 rotate-times)
  12               result
  13               (r (append result
  14                          (map (lambda (x) (cons (car ls1) x))
  15                                       (permutations (cdr ls1))))
  16                  (rotate ls1) (- rotate-times 1)))))))
  17
  18 (define (permutation2 ls) ;generator style
  19   (let ((len (length ls)))
  20     (if (= 1 len)
  21         (list ls)
  22         (let r ((result '()) (ls1 ls) (rotate-times len))
  23           (if (= 0 rotate-times)
  24               result
  25               (r (append result
  26                          (map (lambda (x) (cons (car ls1) x))
  27                                       (permutations (cdr ls1))))
  28                  (rotate ls1) (- rotate-times 1)))))))
  29
  30 (define (m1 v k)
  31   (lambda (x) (k (cons v x))))
  32
  33
  34 (define (reverse-by-first-elem ls)
  35   (let ((n (car ls)))
  36     (append (reverse (list-head ls n))
  37             (list-tail ls n))))
  38
  39 (define (max-flips ls)
  40   (let r ((times 0) (nls ls))
  41     (let ((e1 (car nls)))
  42       (if (= 1 e1)
  43           times
  44           (r (+ 1 times) (reverse-by-first-elem nls))))))
  45
  46 ;; (define q '(1 2 3 4 5 6 7 8 9 10 11 12))
  47
  48 ;; (display (apply max (map max-flips (permutations ))))
  49 ;; (newline)
  50
  51
  52 ;; (max-flips '(7 6 5 4 3 2 1))
  53
  54 (define (process p)
  55   (set! pile (cons (max-flips p) pile)))
  56
  57 (define (incred-permutation proc cur rest)
  58   (if (null? rest)
  59       (proc (max-flips cur))
  60        (for-each
  61         (lambda (x) (incred-permutation
  62                      proc
  63                      (cons x cur)
  64                      (remove (lambda (y) (= x y)) rest)))
  65         rest)))
  66
  67 (define (incred-permutation2 proc cur rest)
  68   (if (null? rest)
  69       (proc (max-flips cur))
  70        (for-each2
  71         (lambda (M R) (incred-permutation2
  72                        proc
  73                        (cons M cur)
  74                        R))
  75         rest)))
  76
  77 (define (for-each2 P L)
  78   (let R ((mid (car L))
  79           (left '())
  80           (right (cdr L)))
  81     (P mid (append (reverse left) right))
  82     (if (not (null? right))
  83         (R (car right)
  84            (cons mid left)
  85            (cdr right)))))
  86
  87 (define (for-each3 P L)
  88   q
  89
  90 ;; (for-each2 (lambda (M R)
  91 ;;         (format #t "middle is: ~a\n" M)
  92 ;;         (format #t "rest is: ~a\n" R))
  93 ;;       '(1 2 3 4))
  94
  95 ;; (use-modules (statprof))
  96
  97 ;; (statprof-reset 0 50000 #t)
  98 ;; (statprof-start)
  99 (begin
 100   (let* ((max 0)
 101          (f (lambda (x) (if (> x max)
 102                          (set! max x)))))
 103     ;; (use-modules (srfi srfi-1))
 104     ;; (incred-permutation f '() '(1 2 3 4 5 6 7 8))
 105     ;; (incred-permutation2 f '() '(1 2 3 4 5 6 7 8 9 10 11 12))
 106     (incred-permutation2 f '() '(1 2 3 4 5 6 7 8 9 10 11 12))
 107     (display max)
 108     (newline)))
 109 ;; (statprof-stop)
 110 ;; (statprof-display)
 111
 112 ;; (define q (make-bytevector 7))
 113
 114 (define (test . x)
 115   (format #t "~a" x))
 116
 117 (test 1 2 3 4)