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 | @
|
---|