[12.30] [tls] 算术表达式

[ruandao]

(define add1
  (lambda(n)
    (+ n 1)))

(define sub1
  (lambda(n)
    (- n 1)))

(define o+
  (lambda(n m)
    (cond
     ((zero? m) n)
     (else (add1 (o+ n (sub1 m)))))))

(define o-
  (lambda(n m)
    (cond
     ((zero? m) n)
     (else (sub1 (o- n (sub1 m)))))))

(define addtup
  (lambda(tup)
    ((null? tup) 0)
    (else (o+ (car tup)
          (addtup (cdr tup))))))

(define o*
  (lambda(n m)
    (cond
     ((zero? m) 0)
     (else (o+ n
           (o* n (sub1 m)))))))

(define tup+
  (lambda(tup1 tup2)
    (cond
     ((and (null? tup1)
       (null? tup2))'())
     ((null? tup1) tup2)
     ((null? tup2) tup1)
     (else (cons (o+ (car tup1)
             (car tup2))
         (tup+ (cdr tup1)
               (cdr tup2)))))))

(define o>
  (lambda(n m)
    (cond
     ((zero? n) false)
     ((zero? m) true)
     (else (o> (sub1 n)
           (sub1 m))))))

(define o<
  (lambda(n m)
    (cond
     ((zero? m) false)
     ((zero? n) true)
     (else (o< (sub1 n)
           (sub1 m))))))

(define o=1
  (lambda(n m)
    (cond
     ((zero? n) (zero? m))
     ((zero? m) false)
     (else (o=1 (sub1 n)
        (sub1 m))))))
(define o=
  (lambda(n m)
    (cond
     ((o> n m) false)
     ((o< n m) false)
     (else true))))

(define ^
  (lambda(n m)
    (cond
     ((zero? m) 1)
     (else (o* n
           (^ n (sub1 m)))))))
(define o/
  (lambda(n m)
    (cond
     ((o< n m) 0)
     (else (add1 (o/ (o- n m)
             m))))))

(define length
  (lambda(lat)
    ((null? lat) 0)
    (else (add1 (length (cdr lat))))))

(define pick
  (lambda(n lat)
    (cond
     ((zero? (sub1 n)) (car lat))
     (else (pick (sub1 n) (cdr lat))))))

(define rempick
  (lambda(n lat)
    (cond
     ((zero? (sub1 n)) (cdr lat))
     (else (cons (car lat)
         (rempick (sub1 n)
              (cdr lat)))))))
(define no-nums
  (lambda(lat)
    (cond
     ((null? lat) '())
     (else
      (cond
       ((number? (car lat)) (no-nums (cdr lat)))
       (else (cons (car lat)
           (no-nums (cdr lat)))))))))

(define all-nums
  (lambda(lat)
    (cond
     ((null? lat) '())
     (else
      (cond
       ((number? (car lat))
    (cons (car lat) (all-nums (cdr lat))))
       (else (all-nums (cdr lat))))))))

(define eqan?
  (lambda(a1 a2)
    (cond
     ((and (number? a1) (number? a2))
      (o= a1 a2))
     ((or (number? a1) (number a2))
      false)
     (else (eq? a1 a2)))))

(define occur
  (lambda(a lat)
    (cond
     ((null? lat) 0)
     (else
      (cond
       ((eq? a (car lat))
    (add1 (occur (cdr lat))))
       (else (occur (cdr lat))))))))

(define one?
  (lambda(n)
    (o= n 1)))

(define rempick1
  (lambda(n lat)
    (cond
     ((one? n) (cdr lat))
     (else (cons (car lat)
         (rempick1 (sub1 n) (cdr lat)))))))

(define rember
  (lambda(s l)
    (cond
     ((null? l) '())
     ((equal? s (car l)) (cdr l))
     (else (cons (car l)
         (rember s (cdr l)))))))
(define rember*
  (lambda(a l)
    (cond
     ((null? l) '())
     (else
      (cond
       ((atom? (car l))
    (cond
     ((eq? (car l) a) (rember* a (cdr l)))
     (else (cons (car l)
             (rember* a (cdr l))))))
       (else (cons (rember* a (car l))
           (rember* a (cdr l)))))))))

(define insertR*
  (lambda(new old lat)
    (cond
     ((null? lat) '())
     ((atom? (car lat))
      (cond
       ((eq? old (car lat))
    (cons (car lat)
          (cons new (insertR* new old (cdr lat)))))
       (else (cons (car lat)
           (insertR* new old (cdr lat))))))
     (else (cons (insertR* new old (car lat))
         (insertR* new old (cdr lat)))))))

(define occur*
  (lambda(a l)
    (cond
     ((null? l) 0)
     ((atom? (car l))
      (cond
       ((eq? a (car l))
    (add1 (occur* (cdr l))))
       (else (occur* (cdr l)))))
     (else (o+ (occur* (car l))
           (occur* (cdr l)))))))

(define subst*
  (lambda(new old l)
    (cond
     ((null? l) '())
     ((atom? (car l))
      (cond
       ((eq? old (car l))
    (cons new (subst* new old (cdr l))))
       (else (cons (car l)
           (subst* new old (cdr l))))))
     (else (cons (subst* new old (car l))
         (subst* new old (cdr l)))))))

(define insertL*
  (lambda(new old l)
    (cond
     ((null? l) '())
     ((atom? (car l))
      (cond
       ((eq? old (car l))
    (cons new
          (cons old (insertL* new old (cdr l)))))
       (else (cons old (insertL* new old (cdr l))))))
     (else (cons (insertL* new old (car l))
         (insertL* new old (cdr l)))))))

(define member*
  (lambda(a l)
    (cond
     ((null? l) false)
     ((atom? (car l))
      (or (eq? (car l) a)
      (member* a (cdr l))))
     (else (or (member* a (car l))
           (member* a (cdr l)))))))

(define leftmost
  (lambda(l)
    ((null? l) '())
    ((atom? (car l)) (car l))
    (else (leftmost (car l)))))

(define eqlist?
  (lambda(l1 l2)
    (cond
     ((and (null? l1) (null? l2)) true)
     ((or (null? l1) (null? l2)) false)
     (else (and (equal? (car l1) (car l2))
        (eqlist? (cdr l1) (cdr l2)))))))

(define equal?
  (lambda(s1 s2)
    (cond
     ((and (atom? s1) (atom? s2))
      (eqan? s1 s2))
     ((or (atom? s1) (atom? s2))
      false)
     (else (eqlist? s1 s2)))))

(define numbered?
  (lambda(aexp)
    (cond
     ((atom? aexp) (number? aexp))
     ((or (eq? (car (cdr aexp)) '*)
      (eq? (car (cdr aexp)) '+)
      (eq? (car (cdr aexp)) '^))
      (and (numbered? (car aexp))
       (numbered? (car (cdr (cdr aexp)))))))))

(define numbered?-1
  (lambda(aexp)
    (cond
     ((atom? aexp) (number? aexp))
     (else
      (and (numbered?-1 (car aexp))
       (numbered?-1 (car (cdr (cdr aexp)))))))))

(define value
  (lambda(nexp)
    (cond
     ((atom? nexp)
      (cond
       ((number? nexp) nexp)))
     ((eq? '+ (car (cdr nexp)))
      (o+ (value (car nexp))
      (value (car (cdr (cdr nexp))))))
     ((eq? '* (car (cdr nexp)))
      (o* (value (car nexp))
      (value (car (cdr (cdr nexp))))))
     (else (^ (value (car nexp))
          (value (car (cdr (cdr nexp)))))))))
#|

(value '1)
(value '(1 + 3))
(value '(1 + (3 ^ 4)))
(car (cdr (cdr '(1 + (3 ^ 4)))))

|#

[ruandao]

恩, 括号, 自动对算式进行了分组(譬如 '(1 + (3 ^ 4)) 与 '(1 + 3 ^ 4))的不同