http://t3x.org/lisp64k/nmath.html

LISPy things you can do in 64K bytes of core

NMATH Package

This package implements arithmetics on natural numbers. It is discussed here.

; Kilo LISP natural number package
; Nils M Holm, 2007-2019
; In the public domain

(setq value
  (lambda (x)
    (cond ((eq x '0) nil)
          ((eq x '1) #i)
          ((eq x '2) #ii)
          ((eq x '3) #iii)
          ((eq x '4) #iiii)
          ((eq x '5) #iiiii)
          ((eq x '6) #iiiiii)
          ((eq x '7) #iiiiiii)
          ((eq x '8) #iiiiiiii)
          ((eq x '9) #iiiiiiiii)
          (else (error 'not/ a/ digit x)))))

(setq dzerop null)

(setq pred cdr)
(setq succ (lambda (x) (cons 'i x)))

(setq sums
  '(((0.0) (1.0) (2.0) (3.0) (4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1))
    ((1.0) (2.0) (3.0) (4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1))
    ((2.0) (3.0) (4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1))
    ((3.0) (4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1))
    ((4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1))
    ((5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1))
    ((6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1) (6.1))
    ((7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1) (6.1) (7.1))
    ((8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1) (6.1) (7.1) (8.1))
    ((9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1) (6.1) (7.1) (8.1) (9.1))))

(setq diffs
  '(((0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1) (3.1) (2.1) (1.1) (0.1))
    ((1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1) (3.1) (2.1) (1.1))
    ((2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1) (3.1) (2.1))
    ((3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1) (3.1))
    ((4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1))
    ((5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1))
    ((6.0) (5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1))
    ((7.0) (6.0) (5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1))
    ((8.0) (7.0) (6.0) (5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1))
    ((9.0) (8.0) (7.0) (6.0) (5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1))))

(setq dth
  (lambda (d lst)
    (if (dzerop d)
        (car lst)
        (dth (pred d) (cdr lst)))))

(setq dplus
  (lambda (a b c)
    (let ((row (dth (value b) sums)))
      (if (eq c '1)
          (dth (value a) (cdr row))
          (dth (value a) row)))))

(setq dminus
  (lambda (a b c)
    (let ((row (dth (value a) diffs)))
      (if (eq c '1)
          (dth (value b) (cdr row))
          (dth (value b) row)))))

(setq plus
  (lambda (a b)
    (labels
      ((add
         (lambda (a b c r)
           (cond ((null a)
                   (if (null b)
                       (if (eq c '0)
                           r  ; no carry
                           (cons '1 r))
                       (let ((sum (dplus '0 (car b) c)))
                         (add nil
                              (cdr b)
                              (cdr sum)
                              (cons (car sum) r)))))
                 ((null b)
                   (let ((sum (dplus (car a) '0 c)))
                     (add (cdr a)
                          nil
                          (cdr sum)
                          (cons (car sum) r))))
                 (else (let ((sum (dplus (car a) (car b) c)))
                         (add (cdr a)
                              (cdr b)
                              (cdr sum)
                              (cons (car sum) r))))))))
      (add (rever a) (rever b) '0 nil))))

(setq normalize
  (lambda (x)
    (cond ((null (cdr x)) x)
          ((eq (car x) '0)
            (normalize (cdr x)))
          (else x))))

(setq diff
  (lambda (a b)
    (labels
      ((diff
         (lambda (a b c r)
           (cond ((null a)
                   (if (null b)
                       (if (eq c '0)
                           r
                           'negative)
                       'negative))
                 ((null b)
                   (if (eq c '0)
                       (conc (rever a) r)
                       (diff a #1 '0 r)))
                 (else (let ((d (dminus (car a) (car b) c)))
                         (diff (cdr a)
                               (cdr b)
                               (cdr d)
                               (cons (car d) r))))))))
      (let ((d (diff (rever a) (rever b) '0 nil)))
        (if (atom d)
            d
            (normalize d))))))

(setq less
  (lambda (a b)
    (eq 'negative (diff a b))))

(setq grtr (lambda (a b) (less b a)))

(setq lteq (lambda (a b) (not (less b a))))

(setq gteq (lambda (a b) (not (less a b))))

; equal = equal

(setq zerop
  (lambda (x)
    (and (eq (car x) '0)
         (null (cdr x)))))
 
(setq times
  (lambda (a b)
    (labels
      ((x10
         (lambda (x)
           (conc x #0)))
       (dtimes
         (lambda (a b r)
           (if (dzerop b)
               r
               (dtimes a (pred b) (plus a r)))))
       (times
         (lambda (a b r)
           (if (null b)
               r
               (times (x10 a)
                      (cdr b)
                      (dtimes a (value (car b)) r))))))
      (if (zerop a)
          #0
          (times a (rever b) #0)))))

(setq divide
  (lambda (a b)
    (labels
      ; Equalize the divisor B by shifting it to the left
      ; (multiplying it by 10) until it has the same number
      ; of digits as the dividend A.
      ; Return: (new divisor . base 1 shift count)
      ((eql
         (lambda (a b r s)
           (cond ((null a)
                   (cons (rever r) s))
                 ((null b)
                   (eql (cdr a)
                        nil
                        (cons '0 r)
                        (succ s)))
                 (else
                   (eql (cdr a)
                        (cdr b)
                        (cons (car b) r)
                        s)))))
       ; Divide with quotient < 10
       ; Return (A/B*B . A/B)
       (div10
         (lambda (a b r)
           (cond ((less (car r) a)
                   (div10 a b (cons (plus (car r) b)
                                    (plus (cdr r) #1))))
                 ((equal (car r) a) r)
                 (else (cons (diff (car r) b)
                             (diff (cdr r) #1))))))
       ; X / 10
       (d10
         (lambda (x)
           (nrever (cdr (rever x)))))
       (div
         (lambda (a b r)
           (if (null (cdr b))
               (cons (normalize r) a)
               (let ((quot (div10 a (car b) (cons #0 #0))))
                   (div (diff a (car quot))
                        (cons (d10 (car b)) (pred (cdr b)))
                        (conc r (cdr quot))))))))
      (cond ((zerop b) (error 'divide/ by/ zero))
            ((less a b) (cons #0 a))
            (else (div a (eql a b nil #1) #0))))))

(setq div (lambda (a b) (car (divide a b))))

(setq rem (lambda (a b) (cdr (divide a b))))

contact  |  privacy