source: CGBLisp/tests/RCS/colored-poly-tests.lisp,v@ 1

head    1.1;
access;
symbols;
locks
        marek:1.1; strict;
comment @;;; @;


1.1
date    2009.01.19.18.19.32;    author marek;   state Exp;
branches;
next    ;


desc
@@


1.1
log
@Initial revision
@
text
@#|
        $Id: colored-poly-tests.lisp,v 1.4 1997/11/28 18:12:43 marek Exp $      
  *--------------------------------------------------------------------------*
  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@@math.arizona.edu)    |
  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
  |                                                                          |
  | Everyone is permitted to copy, distribute and modify the code in this    |
  | directory, as long as this copyright note is preserved verbatim.         |
  *--------------------------------------------------------------------------*
|#
;;(use-package '("parse" "monom" "printer" "colored-poly" "grobner" "coefficient-ring"))

;; The value of this variable is a function that will do evaluation
;; instead of eval; this one just prints what it is evaluating and calls eval

#+kcl
(setf *evalhook* 
  #'(lambda (form env)
      (format t "~&EVAL> ~s~%" form)
      (let (val)
        (time (setf val (multiple-value-list (eval form))))
        (format t "~&VALUES--> ~s~2%" val)
        val)))


(dribble "colored-poly-tests.output")


#|
(warn "Test 1")
(setf f (parse-string-to-sorted-alist "4*x^2-3*x*y" '(x y)))
(setf g (parse-string-to-sorted-alist "4*x+5*y" '(x y)))
(setf cf (make-colored-poly f 2))
(setf cg (make-colored-poly g 2))
(time (cond-system-print (grobner-system (list cf cg)) '(x y) '()))
(time (poly-print (cons '[ (grobner (list f g))) '(x y)))

(warn" Test 2 - Enneper surface")
(setf fl 
      (cdr
       (parse-string-to-sorted-alist
        "[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]"
        '(u v x y z))))
(setf cfl (make-colored-poly-list fl 5))
(time (cond-system-print (grobner-system cfl) '(u v x y z) '()))
(time (poly-print (cons '[ (reduced-grobner fl)) '(u v x y z)))

(warn" Test 3 - staple")
(setf fl 
      (cdr (parse-string-to-sorted-alist
            "[x+y,x+u*y]"
            '(x y u))))
(setf cfl (make-colored-poly-list fl 2))
(time (cond-system-print (grobner-system cfl) '(x y) '(u)))

(warn" Test 4 - staple")
(setf fl 
      (cdr
       (parse-string-to-sorted-alist
        "[x+y,u*x+y]"
        '(x y u))))
(setf cfl (make-colored-poly-list fl 2))
(time (cond-system-print (grobner-system cfl) '(x y) '(u)))

(warn "Test 5 - a small robot example")
(setf vars-params '(s1 c1 s2 c2 a b l1 l2 l3 ))
(setf vars (butlast vars-params 5))
(setf params (nthcdr 4 vars-params))
(setf cover2 (cdr (parse-string-to-sorted-alist "[l1,l2,l3]" params)))
(setf cover (list (list nil cover2)))
(setf fl (cdr 
          (parse-string-to-sorted-alist
           "[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]"
           vars-params)))
(setf  cfl (make-colored-poly-list fl 4))

(time (cond-system-print (grobner-system cfl :cover cover)
                         vars params))
|#

(warn "Test 1")
(string-grobner-system "[4*x^2-3*x*y,4*x+5*y]" '(x y) '())

(warn "Test 2 - Enneper")
(let* ((val1
       (string-grobner-system 
        "[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]"
        '(u v x y z) '() :suppress-value nil))
       (val1 (grobner (mapcar #'colored-poly-to-poly (cadar val1))))
       (val2 
        (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]"
                        '(u v x y z) :suppress-value nil)))
  (grobner-equal val1 val2))


(warn" Test 3 - staple")
(string-grobner-system "[x+y,x+u*y]" '(x y) '(u))

(warn" Test 4 - staple")
(string-grobner-system "[x+y,u*x+y]" '(x y) '(u))


(warn "Test 5 - a small robot example")
(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]")))

(warn "Test 6 - Circle of Apollonius")
(string-grobner-system 
 "[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]"
 '(s x1 x2 x3 x4 x5 x6 x7 x8)           ;vars
 '(u1 u2)                               ;parameters
 )

(warn "Test 7")
(setf fl (cdr (parse-string-to-sorted-alist 
               "[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]"
               '(x y a b c))))
(setf cfl (make-colored-poly-list fl 2))
(cond-system-print (determine cfl) '(x y) '(a b c))

(warn "Test 8")
(setf fl (cdr (parse-string-to-sorted-alist 
               "[a^2*x+5*a]"
               '(x a))))
(setf cfl (make-colored-poly-list fl 1))
(cond-system-print (determine cfl) '(x) '(a))

(warn "Test 9 - the discriminant of a quadratic polynomial")
(string-grobner-system 
 "[a*x^2+b*x+c,2*a*x+b]" '(x) '(a b c)
 :cover (list (list "[]" "[a]")))

(warn "Test 10 - the discriminant of a cubic polynomial")
(string-grobner-system 
 "[x^3+p*x+q,3*x^2+p]" '(x) '(p q)
 :cover (list (list "[]" "[]")))

(warn "Test 11 - the discriminant of a quartic polynomial")
(string-grobner-system 
 "[x^4+p*x^2+q*x+r,4*x^3+2*p*x+q]" '(x) '(p q r)
 :cover (list (list "[]" "[]")))


(dribble)
(setf *evalhook* nil)
@