[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Nov 15:
; grade school multiplication

(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 (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 (repeat n c)
  (make-string n c))

(define (display-right n len)
  (let ((s (number->string n)))
    (display (repeat (- len (string-length s)) #\space))
    (display s) (newline)))

(define (ilog10 n)
  (inexact->exact (floor (/ (log n) (log 10)))))

(define (mult x y)
  (let* ((ys (digits y))
         (len (length (digits (* x y))))
         (lines (length (filter positive? ys))))
    (display-right x len)
    (display-right y len)
    (display (repeat len #\-)) (newline)
    (when (< 1 lines)
      (let loop ((ys (reverse ys)) (i 0) (z 1))
        (when (pair? ys)
          (if (zero? (car ys))
              (loop (cdr ys) i (* z 10))
              (begin (display-right (* x (car ys) z) (- len i))
                     (loop (cdr ys) (+ i (ilog10 z) 1) 1)))))
      (display (repeat len #\-)) (newline))
    (display-right (* x y) len)))

(define (problem-a filename)
  (with-input-from-file filename
    (lambda ()
      (let loop ((x (read)) (y (read)) (i 1))
        (when (and (positive? x) (positive? y))
          (display "Problem ") (display i) (newline)
          (mult x y)
          (loop (read) (read) (+ i 1)))))))

(mult 432 5678)
(newline)
(mult 200001 90040)
(newline)
(mult 246 70)


Output:
    432
   5678
-------
   3456
  3024
 2592
2160
-------
2452896

     200001
      90040
-----------
    8000040
180000900
-----------
18008090040

  246
   70
-----
17220


Create a new paste based on this one


Comments: