[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Jan 3:
; thirteen anagram

(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 (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 (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 (num->words n)
  (letrec ((ones '("" "one" "two" "three" "four" "five" "six"
             "seven" "eight" "nine" "ten" "eleven" "twelve"
             "thirteen" "fourteen" "fifteen" "sixteen"
             "seventeen" "eighteen" "nineteen"))
           (tens '("" "" "twenty" "thirty" "forty" "fifty"
             "sixty" "seventy" "eighty" "ninety"))
           (groups '("" "thousand" "million" "billion" "trillion"
             "quadrillion" "quintillion" "sextillion"
             "septillion" "octillion" "nonillion" "decillion"
             "undecillion" "duodecillion" "tredecillion"
             "quattuordecillion" "quindecillion" "sexdecillion"
             "septendecillion" "octodecillion" "novemdecillion"
             "vigintillion"))
           (nnn->words (lambda (n) ; three-digit numbers
             (cond ((<= 100 n)
                     (string-append
                       (list-ref ones (quotient n 100))
                       " hundred"
                       (if (positive? (modulo n 100)) " " "")
                       (nnn->words (modulo n 100))))
                   ((<= 20 n)
                     (string-append
                       (list-ref tens (quotient n 10))
                       (if (zero? (modulo n 10)) ""
                         (string-append "-" (list-ref ones (modulo n 10))))))
                   (else (list-ref ones n))))))
    (cond ((negative? n) (string-append "negative " (num->words (- n))))
          ((<= #e1e66 n) (error 'num->words "out of range"))
          ((zero? n) "zero")
          ((< n 1000) (nnn->words n))
          (else (let loop ((n n) (groups groups))
                  (let ((prev (quotient n 1000))
                        (group (modulo n 1000)))
                    (string-append
                      (if (zero? prev) ""
                        (loop prev (cdr groups)))
                      (if (zero? group) ""
                        (string-append
                          (if (positive? prev) " " "")
                          (nnn->words group)
                          (if (string=? "" (car groups)) ""
                            (string-append " " (car groups))))))))))))

(define (symbols op x y)
  (sort char<?
    (append
      (list (case op ((+) #\+) ((-) #\-) ((*) #\*) ((/) #\/)))
      (map (lambda (n) (integer->char (+ n 48))) (digits x))
      (map (lambda (n) (integer->char (+ n 48))) (digits y)))))

(define (words op x y)
  (define (w n)
    (filter char-alphabetic?
      (string->list (num->words n))))
  (sort char<? (append (w x) (w y)
    (string->list (case op ((+) "plus")
      ((-) "minus") ((*) "times") ((/) "divide"))))))

(define (list< xs ys)
  (let loop ((xs xs) (ys ys))
    (cond ((null? xs) (pair? ys))
          ((null? ys) (pair? xs))
          ((char<? (car xs) (car ys)) #t)
          ((char<? (car ys) (car xs)) #f)
          (else (loop (cdr xs) (cdr ys))))))

(define (make-xs n)
  (sort (lambda (a b)
          (cond ((< (car a) (car b)) #t)
                ((< (car b) (car a)) #f)
                ((list< (caddr a) (caddr b)) #t)
                ((list< (caddr b) (caddr a)) #f)
                ((list< (cadddr a) (cadddr b)) #t)
                ((list< (cadddr b) (cadddr a)) #f)
                (else #f)))
    (list-of (list (eval (list op x y)) (list op x y)
                   (symbols op x y) (words op x y))
      (op in '(+ - * /)) (x range 1 (+ n 1)) (y range 1 (+ n 1)))))

(define (alt xs)
  (let loop ((xs xs) (zs (list)))
    (if (null? xs) zs
      (loop (cddr xs) (cons (car xs) zs)))))

(define (format-anagram xs)
  (string-append
    (number->string (list-ref (cadar xs) 1))
    (symbol->string (list-ref (cadar xs) 0))
    (number->string (list-ref (cadar xs) 2))
    "="
    (number->string (list-ref (cadadr xs) 1))
    (symbol->string (list-ref (cadadr xs) 0))
    (number->string (list-ref (cadadr xs) 2))))

(define (thirteen-anagram n)
  (let loop ((xs (make-xs n)) (zs (list)))
    (if (null? (cdr xs))
        (map format-anagram (alt zs))
        (let ((x0 (car xs)) (x1 (cadr xs)))
          (cond ((not (= (car x0) (car x1)))
                  (loop (cdr xs) zs)) ; different result
                ((not (equal? (caddr x0) (caddr x1)))
                  (loop (cdr xs) zs)) ; different symbols
                ((not (equal? (cadddr x0) (cadddr x1)))
                  (loop (cdr xs) zs)) ; different words
                ((and (= (list-ref (cadr x0) 1) (list-ref (cadr x1) 2))
                      (= (list-ref (cadr x0) 2) (list-ref (cadr x1) 1)))
                  (loop (cdr xs) zs)) ; same operands different order
                (else (loop (cdr xs) (cons (list x0 x1) zs))))))))

(display (thirteen-anagram 20)) (newline)

(display (length (thirteen-anagram 50))) (newline)


Output:
1
2
(11+2=12+1 14+6=16+4 14+7=17+4 14+9=19+4 16+7=17+6 16+9=19+6 17+9=19+7)
271


Create a new paste based on this one


Comments: