; vampire numbers

(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 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 (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))))))

(do ((x 10 (+ x 1))) ((= x 100))
  (do ((y x (+ y 1))) ((= y 100))
    (when (equal? (sort < (digits (* x y)))
                  (sort < (append (digits x) (digits y))))
      (display x) (display " ") (display y)
      (display " ") (display (* x y)) (newline))))

(define (vampire? x y)
  (let ((z (* x y)))
    (if (not (= (modulo (* x y) 9) (modulo (+ x y) 9))) #f
      (if (and (zero? (modulo x 10)) (zero? (modulo y 10))) #f
        (equal? (sort < (digits z))
                (sort < (append (digits x) (digits y))))))))

(define (vampires n)
  (define (next-mod n r)
    (let ((x (+ n r -1)))
      (if (< x n) (+ x 9) x)))
  (let ((lo (expt 10 (- (/ n 2) 1)))
        (hi (expt 10 (/ n 2)))
        (vs (list)))
    (do ((i (next-mod lo 0) (+ i 9))) ((<= hi i))
      (do ((j i (+ j 9))) ((<= hi j))
        (if (vampire? i j) (set! vs (cons (* i j) vs)))))
    (do ((i (next-mod lo 2) (+ i 9))) ((<= hi i))
      (do ((j i (+ j 9))) ((<= hi j))
        (if (vampire? i j) (set! vs (cons (* i j) vs)))))
    (do ((i (next-mod lo 3) (+ i 9))) ((<= hi i))
      (do ((j (+ i 3) (+ j 9))) ((<= hi j))
        (if (vampire? i j) (set! vs (cons (* i j) vs)))))
    (do ((i (next-mod lo 5) (+ i 9))) ((<= hi i))
      (do ((j (+ i 3) (+ j 9))) ((<= hi j))
        (if (vampire? i j) (set! vs (cons (* i j) vs)))))
    (do ((i (next-mod lo 6) (+ i 9))) ((<= hi i))
      (do ((j (+ i 6) (+ j 9))) ((<= hi j))
        (if (vampire? i j) (set! vs (cons (* i j) vs)))))
    (do ((i (next-mod lo 8) (+ i 9))) ((<= hi i))
      (do ((j (+ i 6) (+ j 9))) ((<= hi j))
        (if (vampire? i j) (set! vs (cons (* i j) vs)))))
    (unique = (sort < vs))))

(display (vampires 4)) (newline)
(display (vampires 6)) (newline)

15 93 1395
21 60 1260
21 87 1827
27 81 2187
30 51 1530
35 41 1435
80 86 6880
(1260 1395 1435 1530 1827 2187 6880)
(102510 104260 105210 105264 105750 108135 110758 115672 116725 117067 118440 120600 123354 124483 125248 125433 125460 125500 126027 126846 129640 129775 131242 132430 133245 134725 135828 135837 136525 136948 140350 145314 146137 146952 150300 152608 152685 153436 156240 156289 156915 162976 163944 172822 173250 174370 175329 180225 180297 182250 182650 186624 190260 192150 193257 193945 197725 201852 205785 211896 213466 215860 216733 217638 218488 226498 226872 229648 233896 241564 245182 251896 253750 254740 260338 262984 263074 284598 284760 286416 296320 304717 312475 312975 315594 315900 319059 319536 326452 329346 329656 336550 336960 338296 341653 346968 361989 362992 365638 368550 369189 371893 378400 378418 378450 384912 386415 392566 404968 414895 416650 416988 428980 429664 447916 456840 457600 458640 475380 486720 489159 489955 498550 516879 529672 536539 538650 559188 567648 568750 629680 638950 673920 679500 729688 736695 738468 769792 789250 789525 792585 794088 809919 809964 815958 829696 841995 939658)