► |  | Redex: Practical Semantics Engineering

1 | Amb: A Redex Tutorial
2 | Long Tutorial
3 | Extended Exercises
4 | The Redex Reference
5 | Automated Testing Benchmark
| Bibliography
| Index

▼ | 3 | Extended Exercises

3.1 | Objects: Problem
3.2 | Objects: Solution
3.3 | Problem: Types
3.4 | Solution: Types
3.5 | Problem: Missionaries and Cannibals
3.6 | Solution: Missionaries and Cannibals
3.7 | Problem: Towers of Hanoi
3.8 | Solution: Towers of Hanoi
3.9 | Problem: GC
3.10 | Solution: GC
3.11 | Problem: Finite State Machines
3.12 | Solution: Finite State Machines
3.13 | Problem: Threads
3.14 | Solution: Threads
3.15 | Problem: Contracts
3.16 | Solution: Contracts
3.17 | Problem: Binary Addition
3.18 | Solution: Binary Addition

top ← prev up next →

#### 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))

top ← prev up next →