[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Jul 13:
; international mathematical olympiad

(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 (sum xs) (apply + xs))

(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 (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 (ilog b n)
  (if (zero? n) -1
    (+ (ilog b (quotient n b)) 1)))

(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 (square x) (* x x))

(display
  (list-of n
    (n range 100 1000)
    (zero? (modulo n 11))
    (= (/ n 11)
       (sum (map square (digits n))))))

(newline)

(display
  (let loop ((n 6))
    (let ((m (+ (* 6 (expt 10 (ilog 10 n))) (quotient n 10))))
      (if (= (* 4 n) m) n
        (loop (+ n 10))))))

(newline)

(define (in-position actual predicted)
  (let loop ((a actual) (p predicted) (n 0))
    (cond ((null? a) n)
          ((equal? (car a) (car p))
            (loop (cdr a) (cdr p) (+ n 1)))
          (else (loop (cdr a) (cdr p) n)))))

(define (two-consecutive actual predicted)
  (let loop ((a actual) (p predicted) (n 0))
    (cond ((or (null? a) (null? p)) n)
          ((null? (cdr p)) n)
          ((null? (cdr a))
            (loop actual (cdr p) n))
          ((and (equal? (car a) (car p))
                (equal? (cadr a) (cadr p)))
            (loop (cddr a) p (+ n 1)))
          (else (loop (cdr a) p n)))))

(display
  (list-of p
    (p in (permutations '(a b c d e)))
    (= (in-position p '(a b c d e)) 0)
    (= (two-consecutive p '(a b c d e)) 0)
    (= (in-position p '(d a e c b)) 2)
    (= (two-consecutive p '(d a e c b)) 2)))


Output:
1
2
3
(550 803)
153846
((e d a c b))


Create a new paste based on this one


Comments: