[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/5MJXvtvo    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Mar 21:
; same five digits

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) <= >=)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(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 (digits n . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((n n) (d '()))
      (if (zero? n) d
          (loop (quotient n b)
                (cons (modulo n b) d))))))

(define (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs))
          (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(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 (mappend f . xss) (apply append (apply map f xss)))

(define (ok? s)
  (cond ((null? s) #t)
        ((= (caar s) (cdar s)) #f)
        (else (ok? (cdr s)))))

(for-each (lambda (x) (display x) (newline))
  (list-of (list a b c s a2 b2 c2)
    (a range 100 245) (a2 is (* a a)) (< (apply max (digits a2)) 6)
    (b range 100 245) (b2 is (* b b)) (< (apply max (digits b2)) 6)
    (c range 100 245) (c2 is (* c c)) (< (apply max (digits c2)) 6)
    (< a2 b2) (< b2 c2)
    (d is (sort < (mappend digits (list a2 b2 c2))))
    (s is (uniq-c = d))
    (= (length (unique = (sort < (map cdr s)))) 5)
    (equal? (unique = d) (unique = (sort < (map cdr s))))
    (ok? s)))


Output:
1
2
3
4
5
6
7
(111 112 235 ((1 . 3) (2 . 5) (3 . 1) (4 . 2) (5 . 4)) 12321 12544 55225)
(111 182 185 ((1 . 3) (2 . 5) (3 . 4) (4 . 2) (5 . 1)) 12321 33124 34225)
(111 211 235 ((1 . 3) (2 . 5) (3 . 1) (4 . 2) (5 . 4)) 12321 44521 55225)
(111 229 235 ((1 . 3) (2 . 5) (3 . 1) (4 . 2) (5 . 4)) 12321 52441 55225)
(112 185 211 ((1 . 2) (2 . 4) (3 . 1) (4 . 5) (5 . 3)) 12544 34225 44521)
(112 185 229 ((1 . 2) (2 . 4) (3 . 1) (4 . 5) (5 . 3)) 12544 34225 52441)
(185 211 229 ((1 . 2) (2 . 4) (3 . 1) (4 . 5) (5 . 3)) 34225 44521 52441)


Create a new paste based on this one


Comments: