Permalink
Browse files

symbolic algebra

  • Loading branch information...
1 parent 5762299 commit 94d6cd2ae031ac0c69ab1f791931d0a3af366f8f @sarabander committed Oct 14, 2011
Showing with 293 additions and 0 deletions.
  1. +52 −0 2.5/2.87.scm
  2. +30 −0 2.5/2.88.scm
  3. +4 −0 2.5/2.89.scm
  4. +4 −0 2.5/2.90.scm
  5. +203 −0 2.5/2.91.scm
View
@@ -0,0 +1,52 @@
+
+;; Let our polynomial be structured as:
+;;
+;; '(polynomial <variable> <term_1> <term_2> .. <term_n>)
+;;
+;; where <variable> is the indeterminate, like 'x or 'y,
+;; <term_1> <term_2> .. <term_n> are terms:
+;; coeff[n] coeff[n-1] .. coeff[0] when dense,
+;; (order coeff) (order coeff) .. when sparse.
+
+;; Example polynomials:
+(define poly1 '(polynomial x 5 -2 0 4 2))
+(define poly2 '(polynomial y (4 5) (3 -2) (1 4) (0 2)))
+(define poly3 '(polynomial y))
+(define poly4 '(polynomial x 0 0 0))
+
+(define (list-of-zeros? lst)
+ (eval (cons 'and
+ (map (λ (elem)
+ (and (number? elem)
+ (zero? elem)))
+ lst))))
+
+;; '=zero?' is installed to polynomial package in the file
+;; generic-arithmetic/polynomials.scm:
+(put '=zero? '(polynomial)
+ (λ (p) (list-of-zeros? (contents p))))
+
+;; Tests
+(list-of-zeros? '()) ; true
+(list-of-zeros? '(3 -3 0)) ; false
+(list-of-zeros? '(a b c)) ; false
+(list-of-zeros? '(0 0 0)) ; true
+
+(=zero? poly1) ; false
+(=zero? poly2) ; false
+(=zero? poly3) ; true
+(=zero? poly4) ; true
+
+;; Addition and multiplication tests
+
+(add poly3 poly3) ; '(polynomial y)
+(add poly2 poly2) ; '(polynomial y (4 10) (3 -4) (1 8) (0 4))
+(add poly4 poly4) ; '(polynomial x 0 0 0)
+(add poly1 poly4) ; '(polynomial x 5 -2 0 4 2)
+(add poly1 poly1) ; '(polynomial x 10 -4 0 8 4)
+
+(mul poly1 poly4) ; '(polynomial x)
+(mul poly1 poly1)
+; '(polynomial x (8 25) (7 -20) (6 4) (5 40) (4 4) (3 -8) (2 16) (1 16) (0 4))
+(mul poly2 poly2)
+; '(polynomial y (8 25) (7 -20) (6 4) (5 40) (4 4) (3 -8) (2 16) (1 16) (0 4))
View
@@ -0,0 +1,30 @@
+
+;; Negation and subtraction are added to generic-arithmetic/polynomials.scm:
+
+;; Negates all terms
+(define (negate-termlist termlist)
+ (if (empty? termlist)
+ empty
+ (let ((negator (if (list? (car termlist))
+ (λ (elem) (list (car elem) (- (cadr elem))))
+ -)))
+ (map negator termlist))))
+
+(put 'neg '(polynomial)
+ (lambda (p)
+ (tag (cons (variable p)
+ (negate-termlist (contents p))))))
+
+(put 'sub '(polynomial polynomial)
+ (lambda (p1 p2) (tag (add-poly p1 (contents (neg (tag p2)))))))
+
+;; Tests
+(neg poly1) ; '(polynomial x -5 2 0 -4 -2)
+(neg poly2) ; '(polynomial y (4 -5) (3 2) (1 -4) (0 -2))
+(neg poly3) ; remains the same
+(neg poly4) ; remains the same
+
+(sub poly1 poly1) ; '(polynomial x 0 0 0 0 0)
+(sub poly2 poly2) ; '(polynomial y)
+(sub poly3 poly2) ; '(polynomial y (4 -5) (3 2) (1 -4) (0 -2))
+(sub poly4 poly1) ; '(polynomial x -5 2 0 -4 -2)
View
@@ -0,0 +1,4 @@
+
+;; The definitions in polynomial package are modified to recognize dense
+;; polynomials. The termlist handling procedures are aware of dense
+;; and sparse format. See generic-arithmetic/polynomials.scm.
View
@@ -0,0 +1,4 @@
+
+;; The definitions in polynomial package are modified to recognize dense
+;; polynomials. The termlist handling procedures are aware of dense
+;; and sparse format. See generic-arithmetic/polynomials.scm.
View
@@ -0,0 +1,203 @@
+
+;; Definitions of div-poly, div-terms and division dispatcher for polynomials
+;; are added to the file generic-arithmetic/polynomials.scm.
+
+;; Tests
+(mul '(polynomial z (3 1)) '(polynomial z (2 1) (0 -1)))
+; '(polynomial z (5 1) (3 -1))
+
+(div '(polynomial z (5 1) (0 -1))
+ '(polynomial z (2 1) (0 -1)))
+; '((polynomial z (3 1) (1 1)) (polynomial z (1 1) (0 -1)))
+
+(div '(polynomial z)
+ '(polynomial z (2 1) (0 -1)))
+; '((polynomial z) (polynomial z))
+
+(div '(polynomial z (2 1) (0 -1))
+ '(polynomial z (5 1) (3 -1)))
+; '((polynomial z) (polynomial z (2 1) (0 -1)))
+
+(sub '(polynomial z (5 1) (0 -1))
+ (mul '(polynomial z (3 1))
+ '(polynomial z (2 1) (0 -1))))
+; '(polynomial z (3 1) (0 -1))
+
+(sort '((2 1) (5 -1) (3 4) (4 -5)) #:key car >) ; '((5 -1) (4 -5) (3 4) (2 1))
+(sort '() #:key car >) ; '()
+
+(div '(polynomial x (3 1) (2 -12) (0 -42))
+ '(polynomial x (1 1) (0 -3)))
+; '((polynomial x (2 1) (1 -9) (0 -27)) (polynomial x (0 -123)))
+
+(div '(polynomial x (3 3) (2 -2) (1 4) (0 -3))
+ '(polynomial x (2 1) (1 3) (0 3)))
+; '((polynomial x (1 3) (0 -11)) (polynomial x (1 28) (0 30)))
+
+;; ---------------------------------------------------------------------------
+
+;; We should make the polynomials more readable. Let's write some
+;; format conversion procedures.
+
+;; Converts polynomial string looking like this: "4x^3 + x^2 - 5"
+;; to internal representation: '(polynomial x (3 4) (2 1) (0 -5))
+(define (mathpoly->listpoly variable polynomial)
+ (define (tag p) (attach-tag 'polynomial p))
+ (define (sort-termlist L) (sort L #:key car >))
+ (define (mathpoly->termlist)
+ (let ((poly-pattern (string-append "[\\+\\-]?\\s*\\d*/?\\d*"
+ (symbol->string variable)
+ "(\\^\\d+)*|[\\+\\-]?\\s*\\d+/?\\d*"))
+ (term-pattern (string-append "([\\+\\-]?)\\s*(\\d*/?\\d*)("
+ (symbol->string variable)
+ "?)\\^?(\\d+)*")))
+ (map (λ (termparts)
+ (let ((coeff (if (equal? (third termparts) "")
+ (cond ((equal? (second termparts) "-") -1)
+ (else 1))
+ (string->number (string-append
+ (second termparts)
+ (third termparts)))))
+ (order (cond ((equal? (fourth termparts) "") 0)
+ ((false? (fifth termparts)) 1)
+ (else (string->number (fifth termparts))))))
+ (list order coeff)))
+ (map (λ (term) (regexp-match (pregexp term-pattern) term))
+ (regexp-match* (pregexp poly-pattern) polynomial)))))
+ (tag (cons variable (sort-termlist (mathpoly->termlist)))))
+
+;; Examples:
+(mathpoly->listpoly 'x "12x^3 + x^2 - 5")
+; '(polynomial x (3 12) (2 1) (0 -5))
+
+(mathpoly->listpoly 's "s^5 - 16s^2 + 9s - 33")
+; '(polynomial s (5 1) (2 -16) (1 9) (0 -33))
+
+
+;; Converts polynomial looking like this: '(polynomial x (3 4) (2 1) (0 -5))
+;; to conventional algebraic form: "4x³ + x² - 5"
+(define (listpoly->mathpoly p)
+ (define (sort-termlist L) (sort L #:key car >))
+ (define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (if (number? datum)
+ datum
+ (error "Bad tagged datum - CONTENTS" datum))))
+ (define (variable p) (car p))
+ (define (term-list p) (cdr p))
+ (define (order term) (car term))
+ (define (coeff term) (cadr term))
+ (let* ((content (contents p))
+ (var (symbol->string (variable content)))
+ (termlist (sort-termlist (term-list content))))
+ (let ((stringlist
+ (map (λ (term)
+ (let ((coeff-string (if (eq? (abs (coeff term)) 1)
+ (if (zero? (order term)) "1" "")
+ (number->string
+ (abs (coeff term)))))
+ (sign-string (if (negative? (coeff term))
+ " - "
+ " + "))
+ (var-string (if (zero? (order term)) "" var))
+ (power-string (if (or (eq? (order term) 0)
+ (eq? (order term) 1))
+ ""
+ (number->superscript
+ (order term)))))
+ (list sign-string coeff-string var-string power-string)))
+ termlist)))
+ (if (empty? stringlist)
+ "0"
+ (let ((without-leading-plus
+ (cons (if (equal? (caar stringlist) " + ")
+ (cdar stringlist)
+ (cons "-" (cdar stringlist)))
+ (cdr stringlist))))
+ (apply string-append (apply append without-leading-plus)))))))
+
+;; Makes a superscript string out of the given number
+(define (number->superscript number)
+ (define uninums #hash((#\1 . "¹")
+ (#\2 . "²")
+ (#\3 . "³")
+ (#\4 . "")
+ (#\5 . "")
+ (#\6 . "")
+ (#\7 . "")
+ (#\8 . "")
+ (#\9 . "")
+ (#\0 . "")))
+ (apply string-append
+ (map (λ (digit) (hash-ref uninums digit))
+ (string->list (number->string number)))))
+
+;; Examples:
+(number->superscript 450) ; "⁴⁵⁰"
+
+(listpoly->mathpoly '(polynomial x (3 -2) (2 -6) (1 4) (0 5)))
+; "-2x³ - 6x² + 4x + 5"
+
+(listpoly->mathpoly poly2)
+; "5y⁴ - 2y³ + 4y + 2"
+
+(listpoly->mathpoly '(polynomial z (6 4) (4 -8) (2 -24)))
+; "4z⁶ - 8z⁴ - 24z²"
+
+
+;; Divides polynomial p1 by p2. Both should be lists consisting of variable
+;; as a symbol and algebraic notation as a string, like '(x "2x^4 + 5x^3 - 1").
+;; Returns a list containing quotient and remainder in algebraic notation.
+(define (divide p1 p2)
+ (let ((p1-internal (apply mathpoly->listpoly p1))
+ (p2-internal (apply mathpoly->listpoly p2)))
+ (let ((result (div p1-internal p2-internal)))
+ (list (listpoly->mathpoly (car result))
+ (listpoly->mathpoly (cadr result))))))
+
+;; Tests
+(divide '(x "x^3") '(x "x")) ; '("x²" "0")
+(divide '(n "4n^5 - 2n^3 + 1") '(n "2n^2 + 2")) ; '("2n³ - 3n" "6n + 1")
+
+(divide '(w "w^3 - 12w^2 -42") '(w "w - 3")) ; '("w² - 9w - 27" "-123")
+(divide '(y "3y^3 - 2y^2 + 4y -3") '(y "y^2 + 3y + 3"))
+; '("3y - 11" "28y + 30")
+(divide '(s "s^3 - 1") '(s "s + 2")) ; '("s² - 2s + 4" "-9")
+(divide '(x "x^4 + 4") '(x "x^2 - 5")) ; '("x² + 5" "29")
+(divide '(z "z^3 - 3z^2 + 5z - 3") '(z "z - 1")) ; '("z² - 2z + 3" "0")
+(divide '(p "p^3 - 4") '(p "2p + 5")) ; '("1/2p² - 5/4p + 25/8" "-157/8")
+(divide '(k "2k^3 - 9k^2 + 15") '(k "2k - 5")) ; '("k² - 2k - 5" "-10")
+(divide '(r "4r^4 + 3r^3 +2r +1") '(r "r^2 + r +2"))
+; '("4r² - r - 7" "11r + 15")
+
+;; And the book example:
+(divide '(x "x^5 - 1") '(x "x^2 - 1")) ; '("x³ + x" "x - 1")
+
+;; We define similar procedures for adding, subtracting and multiplying
+;; by first factoring out a shared skeleton:
+(define (algebraic-op op p1 p2)
+ (let ((p1-internal (apply mathpoly->listpoly p1))
+ (p2-internal (apply mathpoly->listpoly p2)))
+ (listpoly->mathpoly (op p1-internal p2-internal))))
+
+;; and then making particular operations:
+(define (addit p1 p2)
+ (algebraic-op add p1 p2))
+
+(define (subit p1 p2)
+ (algebraic-op sub p1 p2))
+
+(define (multiply p1 p2)
+ (algebraic-op mul p1 p2))
+
+;; Tests
+(multiply '(x "x + 1") '(x "x - 1")) ; "x² - 1"
+(multiply '(x "x + 1") '(x "x + 1")) ; "x² + 2x + 1"
+(multiply '(x "2x + 3") '(x "x^3 - 2x")) ; "2x⁴ + 3x³ - 4x² - 6x"
+
+(addit '(x "2x + 3") '(x "x^3 - 2x")) ; "x³ + 3"
+(addit '(x "x^4 -5x^3 +7") '(x "2x^3 + 4x -6")) ; "x⁴ - 3x³ + 4x + 1"
+
+(subit '(x "x^5 -5x^3 +7") '(x "-x^5 - 9x^3 -5")) ; "2x⁵ + 4x³ + 12"
+(subit '(x "6x + 2") '(x "6x + 3")) ; "-1"

0 comments on commit 94d6cd2

Please sign in to comment.