[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Jul 29:
; send + more = money

(define (mappend f . xss) (apply append (apply map f xss)))

(define (make-list n x)
  (let loop ((n n) (xs '()))
    (if (zero? n) xs
      (loop (- n 1) (cons x xs)))))

(define rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  (define (flip-cycle)
    (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (set! fptr 54) (vector-ref a 55))
  (define (init-rand seed)
    (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
      (vector-set! a 55 prev)
      (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
        (vector-set! a i next) (set! next (mod-diff prev next))
        (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
        (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
      (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  (define (next-rand)
    (if (negative? (vector-ref a fptr)) (flip-cycle)
      (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  (define (unif-rand m)
    (let ((t (- two31 (modulo two31 m))))
      (let loop ((r (next-rand)))
        (if (<= t r) (loop (next-rand)) (modulo r m)))))
  (init-rand 19380110) ; happy birthday donald e knuth
  (set! rand (lambda seed
    (cond ((null? seed) (/ (next-rand) two31))
          ((eq? (car seed) 'get) (cons fptr (vector->list a)))
          ((eq? (car seed) 'set) (set! fptr (caadr seed))
                                 (set! a (list->vector (cdadr seed))))
          (else (/ (init-rand (modulo (numerator
                  (inexact->exact (car seed))) two31)) two31)))))
  (set! randint (lambda args
    (cond ((null? (cdr args))
            (if (< (car args) two31) (unif-rand (car args))
              (floor (* (next-rand) (car args)))))
          ((< (car args) (cadr args))
            (let ((span (- (cadr args) (car args))))
              (+ (car args)
                 (if (< span two31) (unif-rand span)
                   (floor (* (next-rand) span))))))
          (else (let ((span (- (car args) (cadr args))))
                  (- (car args)
                     (if (< span two31) (unif-rand span)
                       (floor (* (next-rand) span))))))))))

(define (make-key . words)
  (let loop ((cs (mappend string->list words)) (ks (list)))
    (cond ((null? cs)
            (append (make-list (- 10 (length ks)) #\_) ks))
          ((member (car cs) ks) (loop (cdr cs) ks))
          (else (loop (cdr cs) (cons (car cs) ks))))))

(define (lookup k ks)
  (let loop ((i 0) (ks ks))
    (if (char=? (car ks) k) i
      (loop (+ i 1) (cdr ks)))))

(define (swap ks a b firsts) ; fix this
  (let* ((vs (list->vector ks))
         (t (vector-ref vs a)))
    (vector-set! vs a (vector-ref vs b))
    (vector-set! vs b t)
    (if (member (vector-ref vs 0) firsts)
        ks (vector->list vs))))

(define (number cs ks)
  (let loop ((s 0) (cs cs))
    (if (null? cs) s
      (loop (+ (* 10 s) (lookup (car cs) ks)) (cdr cs)))))

(define (score xs ys zs key)
  (abs (- (number zs key) (number ys key) (number xs key))))

(define (output xs ks)
  (let loop ((xs xs) (zs (list)))
    (if (null? xs) (reverse zs)
      (loop (cdr xs) (cons (lookup (car xs) ks) zs)))))

(define (solve x y z)
  (let* ((xs (string->list x))
         (ys (string->list y))
         (zs (string->list z))
         (firsts (map car (list xs ys zs)))
         (ks (make-key x y z))
         (s (score xs ys zs ks)))
    (let loop ((ks ks) (s s))
      (if (zero? s)
          (list (output xs ks) (output ys ks) (output zs ks))
          (let* ((new-ks (swap ks (randint 10) (randint 10) firsts))
                 (new-s (score xs ys zs new-ks)))
            (if (< new-s s) (loop new-ks new-s) (loop ks s)))))))

; (display (solve "send" "more" "money")) (newline)

(define (solve x y z)
  (let* ((xs (string->list x))
         (ys (string->list y))
         (zs (string->list z))
         (firsts (map car (list xs ys zs)))
         (ks (make-key x y z))
         (s (score xs ys zs ks)))
    (let loop ((ks ks) (s s))
      (if (zero? s)
          (list (output xs ks) (output ys ks) (output zs ks))
          (let* ((new-ks (swap ks (randint 10) (randint 10) firsts))
                 (new-s (score xs ys zs new-ks)))
            (if (or (< new-s s) (zero? (randint 100)))
                (loop new-ks new-s)
                (loop ks s)))))))

(display (solve "send" "more" "money")) (newline)


Output:
1
((9 5 6 7) (1 0 8 5) (1 0 6 5 2))


Create a new paste based on this one


Comments: