3.18 Solution: Binary Addition
| #lang racket |
| ;; a model of hardware addition of bit sequences |
| (require redex) |
| (define-language L |
| (e ::= |
| (or e e) |
| (and e e) |
| (not e) |
| (append e ...) |
| (add e e) |
| v) |
| (v ::= (b ...)) |
| (n ::= natural) |
| (b ::= 0 1)) |
| (define red |
| (compatible-closure |
| (reduction-relation |
| L |
| (--> (or (b) (1)) (1) "or-1b") |
| (--> (or (1) (b)) (1) "or-b1") |
| (--> (or (0) (0)) (0) "or-00") |
| (--> (or () ()) () "or-0") |
| (--> (or (b_1 b_2 b_3 ...) |
| (b_4 b_5 b_6 ...)) |
| (append (or (b_1) (b_4)) |
| (or (b_2) (b_5)) |
| (or (b_3) (b_6)) ...) |
| "or-n") |
| (--> (not (0)) (1) "not-1") |
| (--> (not (1)) (0) "not-0") |
| (--> (not (b_1 b_2 b_3 ...)) |
| (append (not (b_1)) |
| (not (b_2)) |
| (not (b_3)) ...) |
| "not-n") |
| (--> (not ()) () "not0") |
| (--> (append (b ...)) (b ...) "append1") |
| (--> (append (b_1 ...) (b_2 ...) (b_3 ...) ...) |
| (append (b_1 ... b_2 ...) (b_3 ...) ...) |
| "append2") |
| (--> (and (b_1 ...) (b_2 ...)) |
| (not (or (not (b_1 ...)) |
| (not (b_2 ...)))) |
| "and") |
| (--> (add () (b ...)) (b ...)) |
| (--> (add (b ...) ()) (b ...)) |
| (--> (add (b ... 0) (b_2 ... b_1)) |
| (append (add (b ...) (b_2 ...)) (b_1))) |
| (--> (add (b_2 ... b_1) (b ... 0)) |
| (append (add (b ...) (b_2 ...)) (b_1))) |
| (--> (add (b_1 ... 1) (b_2 ... 1)) |
| (append (add (add (b_1 ...) (b_2 ...)) (1)) (0)))) |
| L e)) |
| (module+ test |
| (test-->> red (term (or (1 1 0 0) (0 1 0 1))) (term (1 1 0 1))) |
| (test-->> red (term (not (0 1))) (term (1 0))) |
| (test-->> red (term (append (1 0) (0 1))) (term (1 0 0 1))) |
| (test-->> red (term (or (1 1 0 0) (0 1 0 1))) (term (1 1 0 1))) |
| (test-->> red (term (and (1 1) (0 1))) (term (0 1))) |
| (test-->> red (term (and (0 0) (0 1))) (term (0 0)))) |
| ;; rewrite-and-compare : (b ...) (b ...) -> boolean |
| (define (rewrite-and-compare b1s b2s) |
| (define rewrite-answer |
| (car |
| (apply-reduction-relation* |
| red |
| (term (add ,b1s ,b2s))))) |
| (if (redex-match? L (b ...) rewrite-answer) |
| (equal? (+ (to-nat b1s) (to-nat b2s)) |
| (to-nat rewrite-answer)) |
| #f)) |
| (define (to-nat bs) |
| (for/sum ([b (in-list (reverse bs))] |
| [i (in-naturals)]) |
| (* b (expt 2 i)))) |
| (module+ test |
| (test-equal (to-nat (term ())) 0) |
| (test-equal (to-nat (term (0))) 0) |
| (test-equal (to-nat (term (1))) 1) |
| (test-equal (to-nat (term (0 1))) 1) |
| (test-equal (to-nat (term (1 0))) 2) |
| (test-equal (to-nat (term (1 1))) 3) |
| (test-equal (to-nat (term (1 1 1))) 7) |
| (test-equal (to-nat (term (0 1 1 1))) 7) |
| (test-equal (to-nat (term (0 1 1 0))) 6)) |
| (module+ test |
| (test-equal (term (2nat ())) 0) |
| (test-equal (term (2nat (0))) 0) |
| (test-equal (term (2nat (1))) 1) |
| (test-equal (term (2nat (0 1))) 1) |
| (test-equal (term (2nat (1 0))) 2) |
| (test-equal (term (2nat (1 1))) 3) |
| (test-equal (term (2nat (1 1 1))) 7) |
| (test-equal (term (2nat (0 1 1 1))) 7) |
| (test-equal (term (2nat (0 1 1 0))) 6)) |
| (define-metafunction L |
| 2nat : (b ...) -> natural |
| [(2nat ()) 0] |
| [(2nat (b_0 b_1 ...)) |
| ,(+ (term n_0) (term n_1)) |
| (where n_1 (2nat (b_1 ...))) |
| (where n_0 ,(* (term b_0) (expt 2 (length (term (b_1 ...))))))]) |
| ;(traces red (term (and (1 1 0 0) (1 0 1 0)))) |
| (module+ test |
| (test-equal |
| (for*/and ([b1 (in-list '(0 1))] |
| [b2 (in-list '(0 1))] |
| [b3 (in-list '(0 1))] |
| [b4 (in-list '(0 1))] |
| [b5 (in-list '(0 1))] |
| [b6 (in-list '(0 1))]) |
| (rewrite-and-compare (list b1 b2 b3) |
| (list b4 b5 b6))) |
| #t)) |
| (module+ test (test-results)) |