1 | #|
|
---|
2 | $Id$
|
---|
3 | *--------------------------------------------------------------------------*
|
---|
4 | | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu) |
|
---|
5 | | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
|
---|
6 | | |
|
---|
7 | | Everyone is permitted to copy, distribute and modify the code in this |
|
---|
8 | | directory, as long as this copyright note is preserved verbatim. |
|
---|
9 | *--------------------------------------------------------------------------*
|
---|
10 | |#
|
---|
11 | ;;(use-package '("parse" "monom" "printer" "colored-poly" "grobner" "coefficient-ring"))
|
---|
12 |
|
---|
13 | ;; The value of this variable is a function that will do evaluation
|
---|
14 | ;; instead of eval; this one just prints what it is evaluating and calls eval
|
---|
15 |
|
---|
16 | (dribble "colored-poly-tests.output")
|
---|
17 |
|
---|
18 |
|
---|
19 | #|
|
---|
20 | (warn "Test 1")
|
---|
21 | (setf f (parse-string-to-sorted-alist "4*x^2-3*x*y" '(x y)))
|
---|
22 | (setf g (parse-string-to-sorted-alist "4*x+5*y" '(x y)))
|
---|
23 | (setf cf (make-colored-poly f 2))
|
---|
24 | (setf cg (make-colored-poly g 2))
|
---|
25 | (time (cond-system-print (grobner-system (list cf cg)) '(x y) '()))
|
---|
26 | (time (poly-print (cons '[ (grobner (list f g))) '(x y)))
|
---|
27 |
|
---|
28 | (warn" Test 2 - Enneper surface")
|
---|
29 | (setf fl
|
---|
30 | (cdr
|
---|
31 | (parse-string-to-sorted-alist
|
---|
32 | "[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]"
|
---|
33 | '(u v x y z))))
|
---|
34 | (setf cfl (make-colored-poly-list fl 5))
|
---|
35 | (time (cond-system-print (grobner-system cfl) '(u v x y z) '()))
|
---|
36 | (time (poly-print (cons '[ (reduced-grobner fl)) '(u v x y z)))
|
---|
37 |
|
---|
38 | (warn" Test 3 - staple")
|
---|
39 | (setf fl
|
---|
40 | (cdr (parse-string-to-sorted-alist
|
---|
41 | "[x+y,x+u*y]"
|
---|
42 | '(x y u))))
|
---|
43 | (setf cfl (make-colored-poly-list fl 2))
|
---|
44 | (time (cond-system-print (grobner-system cfl) '(x y) '(u)))
|
---|
45 |
|
---|
46 | (warn" Test 4 - staple")
|
---|
47 | (setf fl
|
---|
48 | (cdr
|
---|
49 | (parse-string-to-sorted-alist
|
---|
50 | "[x+y,u*x+y]"
|
---|
51 | '(x y u))))
|
---|
52 | (setf cfl (make-colored-poly-list fl 2))
|
---|
53 | (time (cond-system-print (grobner-system cfl) '(x y) '(u)))
|
---|
54 |
|
---|
55 | (warn "Test 5 - a small robot example")
|
---|
56 | (setf vars-params '(s1 c1 s2 c2 a b l1 l2 l3 ))
|
---|
57 | (setf vars (butlast vars-params 5))
|
---|
58 | (setf params (nthcdr 4 vars-params))
|
---|
59 | (setf cover2 (cdr (parse-string-to-sorted-alist "[l1,l2,l3]" params)))
|
---|
60 | (setf cover (list (list nil cover2)))
|
---|
61 | (setf fl (cdr
|
---|
62 | (parse-string-to-sorted-alist
|
---|
63 | "[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]"
|
---|
64 | vars-params)))
|
---|
65 | (setf cfl (make-colored-poly-list fl 4))
|
---|
66 |
|
---|
67 | (time (cond-system-print (grobner-system cfl :cover cover)
|
---|
68 | vars params))
|
---|
69 | |#
|
---|
70 |
|
---|
71 | (warn "Test 1")
|
---|
72 | (string-grobner-system "[4*x^2-3*x*y,4*x+5*y]" '(x y) '())
|
---|
73 |
|
---|
74 | (warn "Test 2 - Enneper")
|
---|
75 | (let* ((val1
|
---|
76 | (string-grobner-system
|
---|
77 | "[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]"
|
---|
78 | '(u v x y z) '() :suppress-value nil))
|
---|
79 | (val1 (grobner (mapcar #'colored-poly-to-poly (cadar val1))))
|
---|
80 | (val2
|
---|
81 | (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]"
|
---|
82 | '(u v x y z) :suppress-value nil)))
|
---|
83 | (grobner-equal val1 val2))
|
---|
84 |
|
---|
85 |
|
---|
86 | (warn" Test 3 - staple")
|
---|
87 | (string-grobner-system "[x+y,x+u*y]" '(x y) '(u))
|
---|
88 |
|
---|
89 | (warn" Test 4 - staple")
|
---|
90 | (string-grobner-system "[x+y,u*x+y]" '(x y) '(u))
|
---|
91 |
|
---|
92 |
|
---|
93 | (warn "Test 5 - a small robot example")
|
---|
94 | (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]")))
|
---|
95 |
|
---|
96 | (warn "Test 6 - Circle of Apollonius")
|
---|
97 | (string-grobner-system
|
---|
98 | "[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]"
|
---|
99 | '(s x1 x2 x3 x4 x5 x6 x7 x8) ;vars
|
---|
100 | '(u1 u2) ;parameters
|
---|
101 | )
|
---|
102 |
|
---|
103 | (warn "Test 7")
|
---|
104 | (setf fl (cdr (parse-string-to-sorted-alist
|
---|
105 | "[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]"
|
---|
106 | '(x y a b c))))
|
---|
107 | (setf cfl (make-colored-poly-list fl 2))
|
---|
108 | (cond-system-print (determine cfl) '(x y) '(a b c))
|
---|
109 |
|
---|
110 | (warn "Test 8")
|
---|
111 | (setf fl (cdr (parse-string-to-sorted-alist
|
---|
112 | "[a^2*x+5*a]"
|
---|
113 | '(x a))))
|
---|
114 | (setf cfl (make-colored-poly-list fl 1))
|
---|
115 | (cond-system-print (determine cfl) '(x) '(a))
|
---|
116 |
|
---|
117 | (warn "Test 9 - the discriminant of a quadratic polynomial")
|
---|
118 | (string-grobner-system
|
---|
119 | "[a*x^2+b*x+c,2*a*x+b]" '(x) '(a b c)
|
---|
120 | :cover (list (list "[]" "[a]")))
|
---|
121 |
|
---|
122 | (warn "Test 10 - the discriminant of a cubic polynomial")
|
---|
123 | (string-grobner-system
|
---|
124 | "[x^3+p*x+q,3*x^2+p]" '(x) '(p q)
|
---|
125 | :cover (list (list "[]" "[]")))
|
---|
126 |
|
---|
127 | (warn "Test 11 - the discriminant of a quartic polynomial")
|
---|
128 | (string-grobner-system
|
---|
129 | "[x^4+p*x^2+q*x+r,4*x^3+2*p*x+q]" '(x) '(p q r)
|
---|
130 | :cover (list (list "[]" "[]")))
|
---|
131 |
|
---|
132 |
|
---|
133 | (dribble)
|
---|
134 |
|
---|