[1] | 1 | head 1.1;
|
---|
| 2 | access;
|
---|
| 3 | symbols;
|
---|
| 4 | locks
|
---|
| 5 | marek:1.1; strict;
|
---|
| 6 | comment @;;; @;
|
---|
| 7 |
|
---|
| 8 |
|
---|
| 9 | 1.1
|
---|
| 10 | date 2009.01.19.18.19.32; author marek; state Exp;
|
---|
| 11 | branches;
|
---|
| 12 | next ;
|
---|
| 13 |
|
---|
| 14 |
|
---|
| 15 | desc
|
---|
| 16 | @@
|
---|
| 17 |
|
---|
| 18 |
|
---|
| 19 | 1.1
|
---|
| 20 | log
|
---|
| 21 | @Initial revision
|
---|
| 22 | @
|
---|
| 23 | text
|
---|
| 24 | @#|
|
---|
| 25 | $Id: colored-poly-tests.lisp,v 1.4 1997/11/28 18:12:43 marek Exp $
|
---|
| 26 | *--------------------------------------------------------------------------*
|
---|
| 27 | | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@@math.arizona.edu) |
|
---|
| 28 | | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
|
---|
| 29 | | |
|
---|
| 30 | | Everyone is permitted to copy, distribute and modify the code in this |
|
---|
| 31 | | directory, as long as this copyright note is preserved verbatim. |
|
---|
| 32 | *--------------------------------------------------------------------------*
|
---|
| 33 | |#
|
---|
| 34 | ;;(use-package '("parse" "monom" "printer" "colored-poly" "grobner" "coefficient-ring"))
|
---|
| 35 |
|
---|
| 36 | ;; The value of this variable is a function that will do evaluation
|
---|
| 37 | ;; instead of eval; this one just prints what it is evaluating and calls eval
|
---|
| 38 |
|
---|
| 39 | #+kcl
|
---|
| 40 | (setf *evalhook*
|
---|
| 41 | #'(lambda (form env)
|
---|
| 42 | (format t "~&EVAL> ~s~%" form)
|
---|
| 43 | (let (val)
|
---|
| 44 | (time (setf val (multiple-value-list (eval form))))
|
---|
| 45 | (format t "~&VALUES--> ~s~2%" val)
|
---|
| 46 | val)))
|
---|
| 47 |
|
---|
| 48 |
|
---|
| 49 | (dribble "colored-poly-tests.output")
|
---|
| 50 |
|
---|
| 51 |
|
---|
| 52 | #|
|
---|
| 53 | (warn "Test 1")
|
---|
| 54 | (setf f (parse-string-to-sorted-alist "4*x^2-3*x*y" '(x y)))
|
---|
| 55 | (setf g (parse-string-to-sorted-alist "4*x+5*y" '(x y)))
|
---|
| 56 | (setf cf (make-colored-poly f 2))
|
---|
| 57 | (setf cg (make-colored-poly g 2))
|
---|
| 58 | (time (cond-system-print (grobner-system (list cf cg)) '(x y) '()))
|
---|
| 59 | (time (poly-print (cons '[ (grobner (list f g))) '(x y)))
|
---|
| 60 |
|
---|
| 61 | (warn" Test 2 - Enneper surface")
|
---|
| 62 | (setf fl
|
---|
| 63 | (cdr
|
---|
| 64 | (parse-string-to-sorted-alist
|
---|
| 65 | "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
|
---|
| 66 | '(u v x y z))))
|
---|
| 67 | (setf cfl (make-colored-poly-list fl 5))
|
---|
| 68 | (time (cond-system-print (grobner-system cfl) '(u v x y z) '()))
|
---|
| 69 | (time (poly-print (cons '[ (reduced-grobner fl)) '(u v x y z)))
|
---|
| 70 |
|
---|
| 71 | (warn" Test 3 - staple")
|
---|
| 72 | (setf fl
|
---|
| 73 | (cdr (parse-string-to-sorted-alist
|
---|
| 74 | "[x+y,x+u*y]"
|
---|
| 75 | '(x y u))))
|
---|
| 76 | (setf cfl (make-colored-poly-list fl 2))
|
---|
| 77 | (time (cond-system-print (grobner-system cfl) '(x y) '(u)))
|
---|
| 78 |
|
---|
| 79 | (warn" Test 4 - staple")
|
---|
| 80 | (setf fl
|
---|
| 81 | (cdr
|
---|
| 82 | (parse-string-to-sorted-alist
|
---|
| 83 | "[x+y,u*x+y]"
|
---|
| 84 | '(x y u))))
|
---|
| 85 | (setf cfl (make-colored-poly-list fl 2))
|
---|
| 86 | (time (cond-system-print (grobner-system cfl) '(x y) '(u)))
|
---|
| 87 |
|
---|
| 88 | (warn "Test 5 - a small robot example")
|
---|
| 89 | (setf vars-params '(s1 c1 s2 c2 a b l1 l2 l3 ))
|
---|
| 90 | (setf vars (butlast vars-params 5))
|
---|
| 91 | (setf params (nthcdr 4 vars-params))
|
---|
| 92 | (setf cover2 (cdr (parse-string-to-sorted-alist "[l1,l2,l3]" params)))
|
---|
| 93 | (setf cover (list (list nil cover2)))
|
---|
| 94 | (setf fl (cdr
|
---|
| 95 | (parse-string-to-sorted-alist
|
---|
| 96 | "[a-l3*c1*c2+l3*s1*s2, b-l3*c1*s2-l3*c2*s1+l2*s1, c1^2+s1^2-1, c2^2+s2^2-1]"
|
---|
| 97 | vars-params)))
|
---|
| 98 | (setf cfl (make-colored-poly-list fl 4))
|
---|
| 99 |
|
---|
| 100 | (time (cond-system-print (grobner-system cfl :cover cover)
|
---|
| 101 | vars params))
|
---|
| 102 | |#
|
---|
| 103 |
|
---|
| 104 | (warn "Test 1")
|
---|
| 105 | (string-grobner-system "[4*x^2-3*x*y,4*x+5*y]" '(x y) '())
|
---|
| 106 |
|
---|
| 107 | (warn "Test 2 - Enneper")
|
---|
| 108 | (let* ((val1
|
---|
| 109 | (string-grobner-system
|
---|
| 110 | "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
|
---|
| 111 | '(u v x y z) '() :suppress-value nil))
|
---|
| 112 | (val1 (grobner (mapcar #'colored-poly-to-poly (cadar val1))))
|
---|
| 113 | (val2
|
---|
| 114 | (string-grobner "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
|
---|
| 115 | '(u v x y z) :suppress-value nil)))
|
---|
| 116 | (grobner-equal val1 val2))
|
---|
| 117 |
|
---|
| 118 |
|
---|
| 119 | (warn" Test 3 - staple")
|
---|
| 120 | (string-grobner-system "[x+y,x+u*y]" '(x y) '(u))
|
---|
| 121 |
|
---|
| 122 | (warn" Test 4 - staple")
|
---|
| 123 | (string-grobner-system "[x+y,u*x+y]" '(x y) '(u))
|
---|
| 124 |
|
---|
| 125 |
|
---|
| 126 | (warn "Test 5 - a small robot example")
|
---|
| 127 | (string-grobner-system "[a-l3*c1*c2+l3*s1*s2-l2*c1, b-l3*c1*s2-l3*c2*s1-l2*s1, c1^2+s1^2-1, c2^2+s2^2-1]" '(c2 s2 c1 s1) '(a b l2 l3) :cover '(("[]" "[l2,l3]")))
|
---|
| 128 |
|
---|
| 129 | (warn "Test 6 - Circle of Apollonius")
|
---|
| 130 | (string-grobner-system
|
---|
| 131 | "[2*x1-u1,2*x2-u2,2*x3-u1,2*x4-u2,x5*u1-x6*u2,x5*u2+x6*u1-u1*u2,x1^2-2*x1*x7+x7^2+x8^2-x7^2-x8^2+2*x8*x2-x2^2,x1^2-2*x1*x7+x7^2+x6^2-2*x6*x8+x8^2-x3^2+2*x3*x7-x7^2-x4^2+2*x4*x8-x8^2,1-s*x5^2+2*s*x5*x7-s*x7^2-s*x6^2+2*s*x6*x8-s*x8^2+s*x1^2-2*s*x1*x7+s*x7^2+s*x8^2]"
|
---|
| 132 | '(s x1 x2 x3 x4 x5 x6 x7 x8) ;vars
|
---|
| 133 | '(u1 u2) ;parameters
|
---|
| 134 | )
|
---|
| 135 |
|
---|
| 136 | (warn "Test 7")
|
---|
| 137 | (setf fl (cdr (parse-string-to-sorted-alist
|
---|
| 138 | "[a^2*x^2*y+b*x^2*y+a^3*b*x*y+a^3*c*x*y,c^2*a*x^2+c^2*b*x^2+b*y+4]"
|
---|
| 139 | '(x y a b c))))
|
---|
| 140 | (setf cfl (make-colored-poly-list fl 2))
|
---|
| 141 | (cond-system-print (determine cfl) '(x y) '(a b c))
|
---|
| 142 |
|
---|
| 143 | (warn "Test 8")
|
---|
| 144 | (setf fl (cdr (parse-string-to-sorted-alist
|
---|
| 145 | "[a^2*x+5*a]"
|
---|
| 146 | '(x a))))
|
---|
| 147 | (setf cfl (make-colored-poly-list fl 1))
|
---|
| 148 | (cond-system-print (determine cfl) '(x) '(a))
|
---|
| 149 |
|
---|
| 150 | (warn "Test 9 - the discriminant of a quadratic polynomial")
|
---|
| 151 | (string-grobner-system
|
---|
| 152 | "[a*x^2+b*x+c,2*a*x+b]" '(x) '(a b c)
|
---|
| 153 | :cover (list (list "[]" "[a]")))
|
---|
| 154 |
|
---|
| 155 | (warn "Test 10 - the discriminant of a cubic polynomial")
|
---|
| 156 | (string-grobner-system
|
---|
| 157 | "[x^3+p*x+q,3*x^2+p]" '(x) '(p q)
|
---|
| 158 | :cover (list (list "[]" "[]")))
|
---|
| 159 |
|
---|
| 160 | (warn "Test 11 - the discriminant of a quartic polynomial")
|
---|
| 161 | (string-grobner-system
|
---|
| 162 | "[x^4+p*x^2+q*x+r,4*x^3+2*p*x+q]" '(x) '(p q r)
|
---|
| 163 | :cover (list (list "[]" "[]")))
|
---|
| 164 |
|
---|
| 165 |
|
---|
| 166 | (dribble)
|
---|
| 167 | (setf *evalhook* nil)
|
---|
| 168 | @
|
---|