[ create a new paste ] login | about

Link: http://codepad.org/vGy44zaT    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Jun 10:
; minimax pandigital factor

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define (undigits ds . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((ds ds) (n 0))
      (if (null? ds) n
          (loop (cdr ds) (+ (* n b) (car ds)))))))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (uniq-c eql? xs)
  (if (null? xs) xs
    (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
      (cond ((null? xs) (reverse (cons (cons prev k) result)))
            ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
            (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))

(define (permutations xs)
  (define (rev xs n ys)
    (if (zero? n) ys
      (rev (cdr xs) (- n 1) (cons (car xs) ys))))
  (let ((xs xs) (perms (list xs)))
    (define (perm n)
      (if (> n 1)
          (do ((j (- n 1) (- j 1)))
              ((zero? j) (perm (- n 1)))
            (perm (- n 1))
            (set! xs (rev xs n (list-tail xs n)))
            (set! perms (cons xs perms)))))
    (perm (length xs))
    perms))

(define (last-pair xs) (if (null? (cdr xs)) xs (last-pair (cdr xs))))
(define (cycle . xs) (set-cdr! (last-pair xs) xs) xs)

(define (smooth b n) ; factors if b-smooth, else #f
  (let loop ((n n) (f 2) (fs (list))
             (wheel (cons 1 (cons 2 (cons 2 (cycle 4 2 4 2 4 6 2 6))))))
    (if (< b f) #f
      (if (= n 1) fs
        (if (zero? (modulo n f))
            (loop (/ n f) f (cons f fs) wheel)
            (loop n (+ f (car wheel)) fs (cdr wheel)))))))

(define (lt? a b)
  (or (< (cadr a) (cadr b))
      (and (= (cadr a) (cadr b))
           (< (car a) (car b)))))

(define (darksteve limit)
  (sort lt?
    (map (lambda (xs) (cons (apply * xs) xs))
      (filter (lambda (x) x)
        (map (lambda (x) (smooth limit x))
          (map undigits
            (permutations
              (range 1 10))))))))

(for-each
  (lambda (xs)
    (display (car xs)) (display ":")
    (do ((ss (cons " " (cycle " * ")) (cdr ss))
         (fs (uniq-c = (reverse (cdr xs))) (cdr fs)))
        ((null? fs) (newline))
      (display (car ss)) (display (caar fs))
      (when (< 1 (cdar fs))
        (display "^") (display (cdar fs)))))
  (darksteve 20))


Output:
619573248: 2^12 * 3^2 * 7^5
948721536: 2^7 * 3^2 * 7^7
214396875: 3^4 * 5^5 * 7 * 11^2
372594816: 2^7 * 3^7 * 11^3
423579618: 2 * 3^6 * 7^4 * 11^2
536481792: 2^12 * 3^5 * 7^2 * 11
697321548: 2^2 * 3^5 * 7^2 * 11^4
745189632: 2^8 * 3^7 * 11^3
847159236: 2^2 * 3^6 * 7^4 * 11^2
129783654: 2 * 3^3 * 7^5 * 11 * 13
213497856: 2^11 * 3^6 * 11 * 13
256134879: 3^9 * 7 * 11 * 13^2
418693275: 3^2 * 5^2 * 7 * 11^2 * 13^3
139478625: 3^3 * 5^3 * 11 * 13 * 17^2
142957386: 2 * 3^5 * 11^3 * 13 * 17
156397824: 2^8 * 3^3 * 11^3 * 17
159274836: 2^2 * 3^9 * 7 * 17^2
185342976: 2^10 * 3^2 * 7 * 13^2 * 17
256937184: 2^5 * 3^4 * 7^3 * 17^2
312795648: 2^9 * 3^3 * 11^3 * 17
318549672: 2^3 * 3^9 * 7 * 17^2
319467825: 3^2 * 5^2 * 17^5
426391875: 3^2 * 5^4 * 7^3 * 13 * 17
462193875: 3^2 * 5^3 * 11 * 13^3 * 17
589324176: 2^4 * 3^2 * 7^2 * 17^4
124783659: 3^8 * 7 * 11 * 13 * 19
164923857: 3^11 * 7^2 * 19
165297834: 2 * 3^9 * 13 * 17 * 19
167845392: 2^4 * 3^3 * 11^2 * 13^2 * 19
183649725: 3^2 * 5^2 * 7 * 17 * 19^3
213465798: 2 * 3^2 * 7 * 13 * 19^4
231469875: 3^2 * 5^3 * 7^2 * 13 * 17 * 19
243918675: 3^3 * 5^2 * 7 * 11 * 13 * 19^2
249567318: 2 * 3^8 * 7 * 11 * 13 * 19
271964385: 3^7 * 5 * 7 * 11 * 17 * 19
283961574: 2 * 3^2 * 13^2 * 17^3 * 19
286493571: 3^3 * 7 * 13 * 17 * 19^3
389174625: 3^4 * 5^3 * 7 * 17^2 * 19
459317628: 2^2 * 3^5 * 7 * 11 * 17 * 19^2
461892375: 3^4 * 5^3 * 7^4 * 19
567923148: 2^2 * 3^2 * 13^2 * 17^3 * 19
598321647: 3^7 * 7 * 11^2 * 17 * 19
763251489: 3^2 * 7^4 * 11 * 13^2 * 19


Create a new paste based on this one


Comments: