1 files changed, 123 insertions, 0 deletions
diff --git a/ps06_rule_systems/rules.scm b/ps06_rule_systems/rules.scm
new file mode 100644
index 0000000..4ba2451
--- /dev/null
+++ b/ps06_rule_systems/rules.scm
@@ -0,0 +1,123 @@
+(define algebra-1
+  (rule-simplifier
+   (list
+
+    ;; Associative law of addition
+    (rule (+ (? a) (+ (? b) (? c)))
+	  none
+	  (+ (+ (? a) (? b)) (? c)))
+    
+    ;; Commutative law of multiplication
+    (rule (* (? b) (? a))
+	  (expr<? a b)
+	  (* (? a) (? b)))
+
+    ;; Distributive law of multiplication over addition
+    (rule (* (? a) (+ (? b) (? c)))
+	  none
+	  (+ (* (? a) (? b)) (* (? a) (? c))))
+
+    )))
+
+(define (expr<? x y)
+  (cond ((null? x)
+	 (if (null? y) #f #t))
+	((null? y) #f)
+	((number? x)
+	 (if (number? y) (< x y) #t))
+	((number? y) #f)
+	((symbol? x)
+	 (if (symbol? y) (symbol<? x y) #t))
+	((symbol? y) #f)
+	((list? x)
+	 (if (list? y)
+	     (let ((nx (length x)) (ny (length y)))
+	       (cond ((< nx ny) #t)
+		     ((> nx ny) #f)
+		     (else
+		      (let lp ((x x) (y y))
+			(cond ((null? x) #f) ; same
+			      ((expr<? (car x) (car y)) #t)
+			      ((expr<? (car y) (car x)) #f)
+			      (else (lp (cdr x) (cdr y))))))))))
+	((list? y) #f)
+	(else
+	 (error "Unknown expression type -- expr<?"
+		x y))))
+
+#|
+(algebra-1 '(* (+ y (+ z w)) x))
+;Value: (+ (+ (* x y) (* x z)) (* w x))
+|#
+
+(define algebra-2
+  (rule-simplifier
+   (list
+
+    ;; Sums
+
+    (rule (+ (? a)) none (? a))
+
+    (rule (+ (?? a) (+ (?? b)))
+	  none
+	  (+ (?? a) (?? b)))
+
+    (rule (+ (+ (?? a)) (?? b))
+	  none
+	  (+ (?? a) (?? b)))
+
+    (rule (+ (?? a) (? y) (? x) (?? b))
+	  (expr<? x y)
+	  (+ (?? a) (? x) (? y) (?? b)))
+    
+
+    ;; Products
+
+    (rule (* (? a)) none (? a))
+
+    (rule (* (?? a) (* (?? b)))
+	  none
+	  (* (?? a) (?? b)))
+
+    (rule (* (* (?? a)) (?? b))
+	  none
+	  (* (?? a) (?? b)))
+
+    (rule (* (?? a) (? y) (? x) (?? b))
+	  (expr<? x y)
+	  (* (?? a) (? x) (? y) (?? b)))
+
+
+    ;; Distributive law
+
+    (rule (* (? a) (+ (?? b)))
+	  none
+	  (+ (?? (map (lambda (x) `(* ,a ,x)) b))))
+
+
+    ;; Numerical simplifications below
+
+    (rule (+ 0 (?? x)) none (+ (?? x)))
+
+    (rule (+ (? x number?) (? y number?) (?? z))
+	  none
+	  (+ (? (+ x y)) (?? z)))
+
+
+    (rule (* 0 (?? x)) none 0)
+     
+    (rule (* 1 (?? x)) none (* (?? x)))
+
+    (rule (* (? x number?) (? y number?) (?? z))
+	  none
+	  (* (? (* x y)) (?? z)))
+
+    )))
+
+#|
+(algebra-2 '(* (+ y (+ z w)) x))
+;Value: (+ (* w x) (* x y) (* x z))
+
+(algebra-2 '(+ (* 3 (+ x 1)) -3))
+;Value: (* 3 x)
+|#