[ create a new paste ] login | about

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

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

; http://www.reddit.com/r/math/comments/2749y4/
; a_problem_i_came_up_with_and_havent_been_able_to/

(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 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 (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 (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 (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 (smooth limit n)
  (define (last-pair xs) (if (null? (cdr xs)) xs (last-pair (cdr xs))))
  (define (cycle . xs) (set-cdr! (last-pair xs) xs) xs)
  (let ((wheel (cons 1 (cons 2 (cons 2 (cycle 4 2 4 2 4 6 2 6))))))
    (let loop ((n n) (f 2) (fs (list)) (wheel wheel))
      (if (< limit 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 (x) (display x) (newline))
  (darksteve 20))


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


Create a new paste based on this one


Comments: