| blob | 0df361bd4b71999473e5ab7f423b35f96952f372 |
1 ;;; -*- mode: lisp; package: cl-maxima; syntax: common-lisp; -*-
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; ;;;;;
4 ;;; Copyright (c) 1984 by William Schelter,University of Texas ;;;;;
5 ;;; All rights reserved ;;;;;
6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 ;;returns the I'th open of the blowup of the FIRSTK coord of ZOPEN
21 answ)
36 for ld-number from 0
50 (defun blowup-pls-using-high-dimensional-components (pls n &key (one-open t) already-blown-up &aux (current-pls pls) op codim)
53 with new-pls = current-pls
54 with red-pls = current-pls
55 with first-time = t
57 do
61 ;;if keeping more than one open the current-pls will be simplified inside blowup
62 ;;since that way we only simplify opens blownup.
76 and
77 collecting (list (format nil "Before the ~A blowup the homogeneous equations on one of the nontrivial opens looked like :" i)
78 current-pls) into blew-up
79 and
80 collecting (list (format nil "~%The ~A blowup was by the ~A ldata of the following open:" i (second op)) (open-sub-scheme red-pls (car op)))
81 into blew-up
82 do
86 do
91 do
100 ;(defun blowup-pls-using-choices (pls n &key (query-user t) (one-open t) already-blown-up
101 ; (number-to-reduce 3) &aux (current-pls pls) choice
102 ; )
103 ; (loop named sue for i from n while (pls-data current-pls)
104 ; with new-pls = current-pls
105 ;; with red-pls = current-pls
106 ; with first-time = t
107 ; when (null first-time)
108 ; do
109 ; (cond ((null query-user)
110 ; (vformat t "Going to blowup wrt to reduced pls:")
111 ; ;(vdes red-pls)))
112 ; (vformat t "homogeneous simplified pls:")))
113 ;
114 ; ;;if keeping more than one open the current-pls will be simplified inside blowup
115 ; ;;since that way we only simplify opens blownup.
116 ; (cond (one-open (setq current-pls (simplify-svar-homogeneous current-pls))))
117 ; (vdes current-pls)
118 ;; (cond ((null (pls-data red-pls))
119 ;; (return (list blew-up i))))
120 ;; (multiple-value ( op codim)
121 ;; (high-dimensional-component red-pls))
122 ;; (show op codim)
123 ; (cond ((null query-user)
124 ; (format t "~%The ~A blowup: The coordinates and the equations" i)
125 ; (des (second choice)) (des (third choice))))
126 ; (setq new-pls (blowup-pls current-pls (second choice)
127 ; (ldata-eqns (third choice))
128 ; :simplify-homogeneous t))
129 ; and
130 ; collecting (list (format nil "Before the ~A blowup the homogeneous equations ~
131 ; on one of the nontrivial opens looked like :" i)current-pls)
132 ; into blew-up
133 ; and
134 ; collecting (list
135 ; (format nil "~%The ~A blowup was by :"
136 ; i ) (second choice) (third choice))
137 ;
138 ; into blew-up
139 ;
140 ; do
141 ; (setq first-time nil)
142 ; (setq choice
143 ; (provide-some-choices-to-blowup new-pls :query-user query-user :number-to-reduce number-to-reduce))
144 ; (cond ((null (third choice))(return-from sue (append already-blown-up blew-up))))
145 ; (cond (one-open
146 ; (loop for op in (pls-opens new-pls)
147 ; for op-num from 0
148 ; do (setq current-op-number op-num)
149 ; when (zopen-equal op (second choice))
150 ; do (setq current-pls (open-sub-scheme new-pls op-num))
151 ; (return 'done)
152 ; (finally (merror "could not find the open"))))
153 ; (t (setq current-pls new-pls)))
154 ; finally (return-from sue (append already-blown-up blew-up))))
163 when lis-dat
165 finally
166 ; (setq paired-dat (eliminate-smaller paired-dat :key 'car
167 ; :test 'zopen-special-subset))
174 current-op-number
175 choices )
178 with new-pls = current-pls
179 with first-time = t
181 do
184 ;(vdes red-pls)))
187 ;;if keeping more than one open the current-pls will be simplified inside blowup
188 ;;since that way we only simplify opens blownup.
189 ; (cond (one-open (setq current-pls (simplify-svar-homogeneous current-pls))))
205 and
209 into blew-up
210 and
213 into blew-up
216 ; (user:write-object "Alonzo:wfs>blew-up.tem" (nthcdr (- (length *blew-up*) 2) *blew-up*))
220 :query-user query-user
225 for op-num from 0
231 current-op-number)))
234 (defun restart-blowup ( &key part use-blewup one-open query-user (after 0) (number-to-reduce 3) &aux pls)
238 number-to-reduce))
247 :number-to-reduce number-to-reduce
251 ;(defun restart-blowup (&key one-open query-user after &aux pls)
252 ; (let ((las (nth (1- (length *blew-up*)) *blew-up*))
253 ; (blas (nth (- (length *blew-up*) 2) *blew-up*))
254 ; (n (quotient (length *blew-up*) 2)))
255 ; (cond ((search "after" (car las) :test #'char-equal) (setq pls (second las)))
256 ; (t (setq pls (second blas)) (setq *blew-up* (butlast *blew-up*))))
257 ; (blowup-pls-using-choices pls n :query-user query-user :one-open one-open
258 ; :already-blown-up *blew-up*)))
266 ;
267 ;(defmacro user-supply (var)
268 ; `(let ((*print-level* 3) ( prinlength 3) .new.)
269 ; (loop
270 ; do
271 ; (format t "~%The value of ~A is ~A ." ',var ,var)
272 ; (format t "~%Supply a form to evaluate to use for ~A or 'keep to keep same :" ',var)
273 ; (setq .new. (eval (read)))
274 ; (cond ((eq .new. 'keep)(return ,var))
275 ; (t
276 ; (format t "~%Use ~A?" .new.)
277 ; (cond ((y-or-n-p )(return (setq ,var .new.)))))))))
278 ;
282 ;;returns an ordered list of choices..
284 &aux component-number an-open-number a-red-pls
285 n len red-pls choices red-choices pcomp min-pcomp some-red-pls the-min comp-eqns min-comp number-eqns opens-not-to-try the-max
291 when lis-ld
293 and
296 into tem1
297 else collecting 0 into tem
298 and collecting 0 into tem1
299 when lis-ld
300 minimize len into the-min1
301 and
302 maximize len into the-max1
303 and
304 minimize pcomp into min-pcomp1
305 and
306 maximize pcomp into max-pcomp1
308 comp-eqns tem1 the-max the-max1)
311 number-eqns comp-eqns)
314 for w in comp-eqns
317 for i from 0
332 when
342 and
346 else collecting red-pls into some-red
347 finally
356 appending
359 appending
371 for i from 0
375 finally
387 ))
403 a-red-pls)))))))
414 appending
417 appending
431 ;;;the following works to blow up following one open thru
432 ;(defun blowup-pls-using-high-dimensional-components (pls n &aux (current-pls pls)
433 ; op codim )
434 ; (loop named sue for i from n while (pls-data current-pls)
435 ; with new-pls = current-pls
436 ; with red-pls = current-pls
437 ; with first-time = t
438 ; when (null first-time)
439 ; do
440 ; (format t "reduced pls:")
441 ; (des red-pls)
442 ; (format t "homogeneous simplified pls:")
443 ; (setq current-pls (simplify-svar-homogeneous current-pls))
444 ; (des current-pls)
445 ; (cond ((null (pls-data red-pls))
446 ; (return (list blew-up i))))
447 ; (multiple-value ( op codim)
448 ; (high-dimensional-component red-pls))
449 ; (show op codim)
450 ; (format t "~%The ~A blowup: the ~A component of the ~A open of codimension ~A."
451 ; i (second op) (car op) codim)
452 ;
453 ; (setq new-pls (blowup-pls current-pls (nth (car op) (pls-opens red-pls))
454 ; (nth (second op) (nth (car op) (pls-data red-pls)))))
455 ;
456 ; and
457 ; collecting (list (format nil "Before the ~A blowup the homogeneous equations on one of the nontrivial opens looked like :" i)current-pls) into blew-up
458 ; and
459 ; collecting (list
460 ; (format nil "~%The ~A blowup was by the ~A ldata of the following open:" i (second op)) (open-sub-scheme red-pls (car op)))
461 ; into blew-up
462 ; do
463 ; (setq first-time nil)
464 ; (loop for ii from 0
465 ; for ope in (pls-opens new-pls)
466 ; do
467 ; (setq red-pls (simplify-svar-ldata
468 ; (open-sub-scheme new-pls ii)))
469 ; (show ii (length (pls-data red-pls)))
470 ; (format t "Open history" (zopen-history (car (pls-opens current-pls))))
471 ; when (pls-data red-pls)
472 ; do (setq current-pls (open-sub-scheme new-pls ii))
473 ; (format t "~%Taking the ~A open with history " ii)
474 ; (return 'done)
475 ; else do (format t "~%The ~A open is empty")
476 ; finally (return-from sue blew-up))
477 ; finally (return (list blew-up i))))
478 ;
479 ;(defun blowup-pls-using-high-dimensional-components (pls n &aux (current-pls pls)
480 ; op codim)
481 ; (loop for i from n while (pls-data current-pls)
482 ; do (multiple-value ( op codim)
483 ; (high-dimensional-component pls))
484 ; (format t "~%The ~A blowup: the ~A component of the ~A open of codimension ~A."
485 ; i (second op) (car op) codim)
486 ; (setq current-pls (copy-tree (s-blow current-pls (car op) (second op))))))
489 ;;performs the transform of a list of equations into new equations on the
490 ;;ITH blowup of the FIRSTK coordinates AMBIENT-DIM space
491 ;(defun proper-transform (list-eqns ith firstk ambient-dim &aux
492 ; ichart fns subs trans answ gg)
493 ; (cond ((eq (car list-eqns) 'ldata)
494 ; (setq gg (ldata-inequality list-eqns))
495 ; (setq list-eqns (ldata-eqns list-eqns))))
496 ; (setq ichart (ichart ith firstk ambient-dim))
497 ; (setq fns (rmap-fns (zopen-inv ichart)))
498 ; (setq subs (my-pairlis *xxx* fns))
499 ; (setq trans (loop for v in list-eqns collecting (psublis subs 1 v)))
500 ; (cond (gg (setq gg (psublis subs 1 gg))))
501 ; (setq answ($cancel_factors_and_denominators (cons '(mlist)
502 ; trans) (list (xxx ith)) t))
503 ; (cond (gg (make-ldata :eqns answ :inequality gg))
504 ; (t answ)))
507 ichart trans answ )
516 ;(setq answ($cancel_factors_and_denominators (cons '(mlist)(ldata-eqns trans))
517 ; (list (xxx ith))
518 ;;homogeneous cancellation
519 ; t))
521 trans)
525 ;
526 ;(defun blowup-sheaf (pls firstk &key opens-not-to-blowup opens-to-blowup
527 ; simplify-homogeneous
528 ; throw-out-components-in-exceptional-divisor
529 ; (keep-history t)&aux answ tem pt)
530 ;
531 ; (setq pls (copy-list-structure pls))
532 ; (let* ((svar (pls-s-var pls))
533 ; (data (pls-data pls))
534 ; (opens (sv-zopens svar))
535 ; dim)
536 ; (setq dim (zopen-dim (first (pls-opens pls))))
537 ; (loop for op in opens
538 ; for dl in data
539 ; for ii from 0
540 ; when (or (and (null opens-to-blowup) (not (member ii opens-not-to-blowup :test #'eq)))
541 ; (mem ii opens-to-blowup :test #'eq))
542 ; do (format t "~%Blowing up open number ~A " ii)
543 ; and
544 ; appending
545 ; (loop for i from 1 to firstk
546 ; do (setq tem (iblowup op i firstk))
547 ; (setq pt (loop for ldat in dl
548 ; collecting
549 ; (proper-transform ldat
550 ; i firstk dim)))
551 ; (iassert (eq (car tem) 'zopen))
552 ; (push (xxx i) (zopen-history tem))
553 ; when throw-out-components-in-exceptional-divisor
554 ; do (setq pt (loop for v in pt collecting
555 ; (copy-structure
556 ; v ldata-
557 ; eqns
558 ; (loop for f in (ldata-eqns v)
559 ; with mon = (pexpt (xxx i) 10)
560 ; collecting
561 ; (car (eliminate-common-factors
562 ; (list f mon)))))))
563 ;
564 ; when simplify-homogeneous
565 ; do (setq pt (loop for v in pt appending (ldata-simplify-homogeneous v
566 ; (zopen-inequality tem))))
567 ; collecting (cons tem pt))
568 ; into paired-data
569 ; else
570 ; collecting (cons op dl) into paired-data
571 ; finally (return(setq answ (make-pre-ldata-sheaves
572 ; s-var (make-s-var zopens (mapcar 'car paired-data))
573 ; data (mapcar 'cdr paired-data)))))
574 ; (fsignal "hi")
575 ; (cond (keep-history (add-pls-zopen-history answ)))
576 ; answ))
579 simplify-homogeneous add-exceptional-divisor-ldata
586 dim)
589 for dl in data
591 for ii from 0
597 and
598 appending
603 collecting
605 i firstk dim)))
608 when simplify-homogeneous
611 when add-exceptional-divisor-ldata
614 into paired-data
615 else
624 answ))
636 ;(defun apply-rmap (rmap fns &key (coords-for-fn *xxx*) subs
637 ; &aux (the-denom (rmap-denom rmap)))
638 ; "Argument may be list of polys, or rat'l fns, result is always rat'l"
639 ; (cond(subs nil)
640 ; (t (setq subs(my-pairlis coords-for-fn (rmap-fns rmap)))))
641 ; (cond ((affine-polynomialp fns)
642 ; (rsublis subs the-denom fns :reduce t))
643 ; ((rational-functionp fns)
644 ; (ratquotient (rsublis subs the-denom (num fns) )
645 ; (rsublis subs the-denom (denom fns))))
646 ; ((eq (car fns) 'ldata)
647 ; (make-ldata eqns (loop for v in (ldata-eqns fns)
648 ; collecting (function-numerator (apply-rmap rmap v
649 ; :coords-for-fn
650 ; coords-for-fn
651 ; :subs subs)))
652 ; inequality (function-numerator(apply-rmap rmap (ldata-inequality fns)
653 ; :coords-for-fn
654 ; coords-for-fn
655 ; :subs subs))))
656 ; ((or (affine-polynomialp (car fns))
657 ; (rational-functionp (car fns))
658 ; (ldatap (car fns)))
659 ; (loop for v in fns
660 ; collecting (apply-rmap rmap v :coords-for-fn coords-for-fn
661 ; :subs subs)))
662 ; (t (merror "fns should be a polynomial, rat'l fn,ldata or list of such"))))
663 ;
664 ;(defun apply-rmap (rmap fns &key (coords-for-fn *xxx*) subs
665 ; &aux )
666 ; "Argument may be list of polys, or rat'l fns, result is always rat'l"
667 ; (cond(subs nil)
668 ; (t (setq subs (subs-for-simple-rat-sublis
669 ; coords-for-fn
670 ; (loop for f in (rmap-fns rmap)
671 ; collecting (ratreduce
672 ; f
673 ; (rmap-denom rmap)))))))
674 ; (cond ((or (affine-polynomialp fns)(rational-functionp fns))
675 ; (simple-rat-sublis subs fns))
676 ; ((eq (car fns) 'ldata)
677 ; (make-ldata eqns (loop for v in (ldata-eqns fns)
678 ; collecting (function-numerator (apply-rmap rmap v
679 ; :coords-for-fn
680 ; coords-for-fn
681 ; :subs subs)))
682 ; inequality (function-numerator(apply-rmap rmap (ldata-inequality fns)
683 ; :coords-for-fn
684 ; coords-for-fn
685 ; :subs subs))))
686 ; ((or (affine-polynomialp (car fns))
687 ; (rational-functionp (car fns))
688 ; (ldatap (car fns)))
689 ; (loop for v in fns
690 ; collecting (apply-rmap rmap v :coords-for-fn coords-for-fn
691 ; :subs subs)))
692 ; (t (merror "fns should be a polynomial, rat'l fn,ldata or list of such"))))
695 "Argument may be list of polys, or rat'l fns, result is always rat'l"
698 nil)
704 answ)
709 :coords-for-fn
710 coords-for-fn
713 :coords-for-fn
714 coords-for-fn
727 ;;;;idea is to take the eqns in ldata and
728 ;;;;construct an rmap to a coordinate system where the
729 ;;;;elements of ldata are transformed to the first n
730 ;;;;eqns where n is the number of eqns in ldata
731 ;;;;we need the ldata since the gg is necessary to figure out which
732 ;;;;variables were linear and should be solved for.
733 ;;(defun normalize-zopen (ldata dim &aux (gg (ldata-inequality ldata))
734 ;; (eqns (ldata-eqns ldata))
735 ;; vari all-eqns all-vari lis map fns
736 ;; other newvars new-eqns denom
737 ;; n tem)
738 ;; (setq vari (loop for v in eqns
739 ;; when (setq tem (any-linearp v gg ))
740 ;; do (show tem) and
741 ;; collecting tem
742 ;; else do (merror "Hey this is not linear ~A" v)))
743 ;; (setq other (loop for w in *xxx*
744 ;; for i below dim
745 ;; when (not (member w vari :test #'eq))
746 ;; collecting w))
747 ;; (setq all-vari (append vari other))
748 ;; (setq newvars (unused-variables dim))
749 ;; (cond ((not (eql (length all-vari) dim)) (merror "Some variables are wrong in vari")))
750 ;; (setq new-eqns
751 ;; (loop for v in eqns
752 ;; for u in newvars
753 ;; for va in vari
754 ;; collecting (linear-poly-solve (pdifference v (list u 1 1)) va)))
755 ;; (setq fns (append eqns other))
756 ;; (setq all-eqns (append new-eqns (loop for u in (nthcdr (length eqns) newvars)
757 ;; collecting (list u 1 1))))
758 ;; (setq all-eqns (gen-psublis (append vari other) newvars all-eqns))
759 ;;; (setq all-eqns
760 ;;; (gen-psublis other (nthcdr (length eqns) newvars)
761 ;;; all-eqns))
762 ;; (setq all-eqns
763 ;; (sublis (pairlis newvars *xxx*)
764 ;; all-eqns))
765 ;; (setq lis (make-list dim))
766 ;; (loop for v in all-vari
767 ;; for u in all-eqns
768 ;; do (setq n (find-position-in-list v *xxx*))
769 ;; (setf (nth n lis) u))
770 ;; (setq map (construct-rmap lis))
771 ;; (setq gg (num (apply-rmap map gg)))
772 ;; (setq fns (construct-rmap fns))
773 ;; (make-zopen coord fns inv (construct-rmap lis) inequality gg))
774 ;
775 ;;;idea is to take the eqns in ldata and
776 ;;;construct an rmap to a coordinate system where the
777 ;;;elements of ldata are transformed to the first n
778 ;;;eqns where n is the number of eqns in ldata
779 ;;;we need the ldata since the gg is necessary to figure out which
780 ;;;variables were linear and should be solved for.
781 ;
782 ;(defun normalize-zopen
783 ; (ldata dim &aux (gg (ldata-inequality ldata))
784 ; (eqns (ldata-eqns ldata))
785 ; vari fns all-new
786 ; other newvars new-eqns subs rest-new map denom
787 ; n tem)
788 ; (setq vari (loop for v in eqns
789 ; when (setq tem (any-linearp v gg ))
790 ; do (show tem) and
791 ; collecting tem
792 ; else do (merror "Hey this is not linear ~A" v)))
793 ; (setq other (loop for w in *xxx*
794 ; for i below dim
795 ; when (not (member w vari :test #'eq))
796 ; collecting w))
797 ; (setq vari (append vari other))
798 ; (setq newvars (unused-variables dim))
799 ; (cond ((not (eql (length vari) dim)) (merror "Some variables are wrong in vari")))
800 ; (setq new-eqns
801 ; (loop for v in eqns
802 ; for u in newvars
803 ; for va in vari
804 ; collecting (linear-poly-solve (pdifference v (list u 1 1)) va)))
805 ; (setq rest-new (loop for i from (length eqns) below dim
806 ; collecting (nth i newvars)))
807 ; (setq all-new (append new-eqns rest-new))
808 ; (setq subs (subs-for-psublis other rest-new ))
809 ; (setq new-eqns
810 ; (loop for w in new-eqns
811 ; collecting (cons (psublis subs 1 (car w))
812 ; (psublis subs 1 (cdr w)))))
813 ;; (setq all-subs (append subs (my-pairlis vari new-eqns)))
814 ; (setq new-eqns (append new-eqns rest-new))
815 ;; (make-zopen coord vari inv (append new-eqns rest-new)
816 ; (setq map (construct-rmap new-eqns))
817 ; ;;assumes denom in x1,x2,.. coords
818 ;; (setq denom (apply-rmap map gg))
819 ; (setq fns (rmap-fns map))
820 ; (setq new-eqns
821 ; (loop for v in vari
822 ; do (setq n (find-position-in-list v vari))
823 ; collecting (nth n fns)))
824 ; (show newvars)
825 ; (show (subs-for-psublis newvars *xxx*))
826 ; (setq new-eqns (gen-psublis newvars *xxx* new-eqns))
827 ; (setf (rmap-fns map) new-eqns)
828 ; (setf (rmap-denom map) (gen-psublis newvars *xxx* (rmap-denom map)))
829 ; map)
833 ; "takes as arguments a list of polys or rat'l fns and tries to make
834 ; these into the first coordinates. It tries to find the inverse.
835 ; It will check whether it has found the inverse, and error if not
836 ;
837 ; some variable. It collects these linear variables and then completes
838 ; them to get a list up to the dimension of the space. (f1,f2, ..
839 ; fm,xi1,xi2,..) is then the set of coordinates, and it calculates the
840 ; inverse of this set. It returns the open with inequality gg and coord
841 ; (f1,...) and inverse These are to become the first nwhich are to be the
842 ; first in the list of coordinates of some open. It then completes the
843 ; list of "
846 variables fns tem all-variables answ
847 coords newvar coord-eqns solu dif-eqns other-monoms other-variables)
850 for u in newvar
851 collecting
861 for i below dim
863 collecting v))
870 for u in newvar
874 ; (setq solu (loop for v in all-variables
875 ; for eqn in coord-eqns
876 ; collecting (linear-poly-solve eqn v)))
877 ; (setq solu (gen-psublis other-variables (nthcdr (length eqns) newvar) solu))
881 for f in solu
884 for f in solu
889 answ)
890 ;
891 ;(defun make-normal-zopen (eqns dim gg &aux (check-inverse t)
892 ; variables fns tem all-variables answ
893 ; coords
894 ; newvar coord-eqns solu other-monoms other-variables)
895 ;
896 ; "takes as arguments a list of polys f1,f2,..each of which is linear in
897 ; some variable. It collects these linear variables and then completes
898 ; them to get a list up to the dimension of the space. (f1,f2, ..
899 ; fm,xi1,xi2,..) is then the set of coordinates, and it calculates the
900 ; inverse of this set. It returns the open with inequality gg and coord
901 ; (f1,...) and inverse These are to become the first nwhich are to be the
902 ; first in the list of coordinates of some open. It then completes the
903 ; list of "
904 ; (setq variables
905 ; (loop for v in eqns
906 ; collecting (setq tem (any-linearp v gg))
907 ; when (null tem) do
908 ; (merror "this equation contains no linear " (sh v))))
909 ; (setq other-variables (loop for v in *xxx*
910 ; for i below dim
911 ; when (not (member v variables :test #'eq))
912 ; collecting v))
913 ; (setq all-variables (append variables other-variables))
914 ; (setq other-monoms
915 ; (loop for v in other-variables
916 ; collecting (list v 1 1)))
917 ; (setq newvar (unused-variables dim))
918 ; (setq coord-eqns (loop for v in (setq coords (append eqns other-monoms))
919 ; for u in newvar
920 ; collecting (pdifference v (list u 1 1))))
921 ; (setq solu (solve-simple-system (mapcar 'function-numerator coord-eqns) all-variables
922 ; :invertible gg))
923 ;; (setq solu (loop for v in all-variables
924 ;; for eqn in coord-eqns
925 ;; collecting (linear-poly-solve eqn v)))
926 ;; (setq solu (gen-psublis other-variables (nthcdr (length eqns) newvar) solu))
927 ; (setq solu (gen-psublis newvar *xxx* solu))
928 ; (setq fns (make-list dim))
929 ; (setq fns (loop for v in all-variables
930 ; for f in solu
931 ; collecting (nth (find-position-in-list v *xxx*) solu)))
932 ; (loop for v in all-variables
933 ; for f in solu
934 ; do (setf (nth (find-position-in-list v *xxx*) fns) f))
935 ; (setq answ (make-zopen coord
936 ; (construct-rmap coords) inv (construct-rmap fns) inequality gg))
937 ; (cond (check-inverse (check-zopen-inv answ)))
938 ; answ)
961 collecting
964 ;;(poly-linearp w v invertible) the variables get replaced
968 ; (declare (values norm-open data))
992 pls)
999 ;
1000 ;(defun open-all-refinement ( list-eqns open-g )
1001 ; (loop for v in list-eqns
1002 ; when (setq tem (all-linearp v open-g))
1003 ; collecting v into lin-eqns
1004 ; collecting lin-vars into lin-vars
1005 ; else
1006 ; collecting v into fns
1007 ; collecting (setq tem (gm-all-prepared v :inequal open-g)) into prep-vars
1008 ; finally
1009 ; (loop for v in prep-vars
1010 ; for w in fns when (null v)do (fsignal "Not gm-prepared ~A" w))
1011 ;
1012 ;;(setq vtree (gm-all-prepared (st-rat #$x*y+x^2*w+s*t+1$)))
1013 ;((#:S #:W #:Y . OK) (#:S #:Y #:W . OK)
1014 ; (#:T #:W #:Y . OK)
1015 ; (#:T #:Y #:W . OK)
1016 ; (#:W #:S #:Y . OK)
1017 ; (#:W #:T #:Y . OK)
1018 ; (#:W #:Y #:S . OK)
1019 ; (#:W #:Y #:T . OK)
1020 ; (#:Y #:S #:W . OK)
1021 ; (#:Y #:T #:W . OK)
1022 ; (#:Y #:W #:S . OK)
1023 ; (#:Y #:W #:T . OK))
1024 ;;now check refinements wrt to different ones for lower complexity
1025 ;;will get for each f a list of lists of cofs that need inverting to make
1026 ;;covering. We can factor them and use eliminate-larger to find the best
1027 ;;cove;
1030 ;;should return an open cover such that the functions are all linear
1031 ;;they should start out well prepared. You shortest such covering
1032 ;;Note some functions depend on the fact that the first
1033 ;;element returned by best-open-cover is the function itself and
1039 collecting v ))
1043 do
1048 appending
1053 collecting inv-list into possible
1057 finally
1066 when square-free
1070 ;;this works for a list of one function..
1071 (defun best-open-cover1 (list-fns open-g &aux tem compl-tem the-prep-fns answ possible-refs lis-prep-cofs lis-prep-var)
1074 collecting f into lins
1075 else collecting f into prep-fns
1083 for lis in lis-prep-var
1084 collecting
1086 collecting
1088 collecting
1096 finally
1098 for i from 0
1104 ;;return the factors for refinement
1112 appending
1114 collecting
1118 "Will return m+1 opens covering the zopen. It is gm-prepared wrt the
1119 inequality g of zopen."
1128 for cof in cofs
1129 collecting
1137 gmprep-poly)))
1140 ;(defun ldata-refinement (ldata gmprep-poly m &key (inequality 1)
1141 ; &aux all-ldata cofs)
1142 ; "Will return m ldata covering the zopen. It is gm-prepared wrt the
1143 ; inequality g of zopen."
1144 ; (let* ((gg (nplcm inequality (ldata-inequality ldata)))
1145 ;; (m (length (any-gm-prepared gmprep-poly gg)))
1146 ; (vari (gm-prepared gmprep-poly :m m :inequal gg)))
1147 ; (check-arg gmprep-poly affine-polynomialp "poly")
1148 ; (setq cofs (loop for v in vari
1149 ; collecting (pcoeff gmprep-poly (list v 1 1))))
1150 ; (setq all-ldata
1151 ; (loop
1152 ; for cof in cofs
1153 ; collecting
1154 ; (copy-structure ldata
1155 ; ldata- inequality (nplcm cof gg))))
1156 ; all-ldata))
1160 "Will return m ldata covering the ldata. The open-gs can
1161 be used as the open number for the simplification."
1162 ; (declare (values all-data open-gs))
1164 ; (m (length (any-gm-prepared gmprep-poly gg)))
1173 for cof in cofs
1174 collecting
1179 ;(defun ldata-refinement (ldata gmprep-poly m &key (inequality 1)
1180 ; &aux all-ldata cofs)
1181 ; "Will return m ldata covering the ldata. The open-gs can
1182 ; be used as the open number for the simplification."
1183 ; (declare (values all-data open-gs))
1184 ; (check-arg gmprep-poly affine-polynomialp "poly")
1185 ; (setq cofs (best-open-cover gmprep-poly inequality))
1186 ; (iassert (may-invertp gmprep-poly (car cofs)))
1187 ; (setq cofs (cdr cofs))
1188 ; (setq all-ldata
1189 ; (loop
1190 ; for cof in cofs
1191 ; collecting
1192 ; (copy-structure ldata
1193 ; ldata- inequality (sftimes cof (ldata-inequality ldata)))))
1194 ; (values all-ldata cofs))
1195 ;;; the following would have been empty:
1196 ; (setq next-ld
1197 ; (copy-structure ldata ldata- inequality (nplcm gg
1198 ; gmprep-poly)))
1199 ; (cons next-ld all-ldata)))
1201 ;;want s-var-ldata-simplifications to take
1202 ;;a pre-ldata-sheaves and simplify it.
1203 ;; this may involve adding more opens if we meet m-prepared's in
1204 ;;the ldata, it will return a pre-ldata-sheaves
1206 ;;notes add an argument to (ldata-simplifications ldata gg)
1207 ;;to allow passing the gg from the current open. The
1208 ;;computation of the mpreprared should be wrt that gg.
1209 ;;still have to modify the ldata-simplifications to return
1210 ;; in *stop-simplify* the mprepared fn and m. (and to stop work )
1217 ;;to make the gm-prepared
1219 some-ld gg a-list answ)
1228 for dl in data
1231 for ii from 0
1232 do
1238 do
1241 ; (des (car w))
1242 appending some-ld into tem
1244 do
1247 ;;set v so that (cdr v) will be the rest of
1248 ;;the pairs (zopen . (list ldata1 ldata2..))
1272 keep-opens-with-empty-ldata simped-ld))
1273 do
1280 simped-ld
1284 and
1285 collecting
1287 and
1288 collecting simped-ld into ldata-list
1289 finally
1296 answ)
1302 ;
1303 ;(defun set-inequalities-to-one (lis)
1304 ; (cond ((atom lis) lis)
1305 ; ((eq (car lis) 'ldata) (setf (ldata-inequality lis) 1))
1306 ; (t
1307 ; (loop for v on lis while (not (atom v))
1308 ;
1309 ; do (set-inequalities-to-one v)))))
1310 ;
1311 ;(defun set-inequalities-to-one (lis)
1312 ; (cond ((listp lis)
1313 ; (cond ((and (listp lis)(eq (car lis) 'ldata))
1314 ; (setf (ldata-inequality lis) 1))
1315 ; (t
1316 ; (loop for v in lis
1317 ; do
1318 ; (set-inequalities-to-one v)))))))
1324 form)
1328 form)))
1332 (defun check-component-containment (orig-ldata-list list-ldat &optional (open-g 1) &aux bad-components
1337 for i from 0
1338 do
1340 when use-ldata-inverse
1343 do
1348 do
1353 (format t "**The component ~/maxima::tilde-q-fsh/ ~%does not contain the original data***** " v)
1355 bad-components)
1359 for i from 0
1360 do
1367 (format t "**The ideal: ~/maxima::tilde-q-fsh/ ~%does not contain the original one *** : ~/maxima::tilde-q-fsh/"
1368 v ldata)
1373 (cond (bad-components (format t "~%All but components ~A contained the originals." bad-components)))
1374 bad-components)
1382 ;(defun simplify-svar-ldata (pls &aux simped-dat-list some-ld gg ref the-partial-ldat answ)
1383 ; (let ((svar (pls-s-var pls))
1384 ; (data (pls-data pls))
1385 ; ( *inside-simplify-svar-ldata* t))
1386 ; (loop for op on (sv-zopens svar)
1387 ; for dat-list on data
1388 ; do
1389 ; (show op)
1390 ; (show dat-list)
1391 ; (setq gg (zopen-inequality (car op)))
1392 ; (show gg)
1393 ; (setq *stop-simplify* nil)
1394 ; (loop for ld in (car dat-list)
1395 ; do (setq some-ld (ldata-simplifications ld gg ))
1396 ; when (null *stop-simplify*)
1397 ; appending some-ld into tem
1398 ; else
1399 ; do
1400 ; (setq ref (apply 'refinement
1401 ; (cons (car op) *stop-simplify*)))
1402 ; (setq op (cons nil (append ref (cdr op))))
1403 ; (setq the-partial-ldat (append tem some-ld (cdr ld)))
1404 ; (setq dat-list (cons nil (append
1405 ; (make-list (length ref)
1406 ; :initial-value
1407 ; the-partial-ldat)
1408 ; (cdr dat-list))))
1409 ; (show dat-list)
1410 ; (return 'stopped)
1411 ; finally (setq simped-dat-list tem)(show simped-dat-list))
1412 ; ;;otherwise the open will be picked up next trip through the loop
1413 ; when (null *stop-simplify*)
1414 ; collecting (car op) into ops
1415 ; and
1416 ; collecting simped-dat-list into dats
1417 ; finally (return (setq answ (make-pre-ldata-sheaves :s-var
1418 ; (make-s-var zopens ops)
1419 ; data dats)))))
1420 ; answ)
1422 ;;the following is for converting back things which have been dumped to file.
1423 ;;or after we have reset the genvar
1444 ;(setq pl
1445 ;(construct-pre-ldata-sheaves :s-var
1446 ; (make-s-var :zopens (list (affine-open (firstn 2 *xxx*) )))
1447 ; :data (list (list
1448 ; (make-ldata :eqns
1449 ; (loop for v in '(1 2)
1450 ; collecting (nth v (grobner-monomials #$[x1,x2]$ 3)))
1451 ;
1452 ; inequality 1)))))
1453 ;
1454 ;
1455 ;(setq test
1456 ; (construct-pre-ldata-sheaves
1457 ; :s-var
1458 ; (make-s-var zopens (list (affine-open (firstn 8 *xxx*) #$1$)))
1459 ; :data (list (list
1460 ; (make-ldata eqns (st-rat
1461 ; #$[x1*x2+1+x3*x4,x3^2+x1^2]$)
1462 ; inequality 1)))))
1468 :s-var
1474 :s-var
1484 $display2d)
1506 $display2d)
1510 ;(defmacro des-editor (expr &optional slash &aux me)
1511 ; (setq me `(setq ,expr (rerat (quote ,(eval expr)))))
1512 ; (time:print-current-time)
1513 ; (for-editor (des (symbol-value expr)))
1514 ; (cond (slash
1515 ; (format t "~%~s" me))
1516 ; (t (format t "~%~a" me)))
1517 ; (values ))
1523 ;(defun des-editor (expr)
1524 ; (for-editor (format t "~A" expr)))
1525 ;(defun find-map (open1 open2 &aux answ)
1526 ; "produces a map so that g so that g(coord open1) = (coord open2)"
1527 ; (let ((subs (subs-for-psublis *xxx* (rmap-fns (zopen-inv open1))))
1528 ; (coord2 (zopen-coord open2)))
1529 ; (setq answ (loop for v in (rmap-fns coord2)
1530 ; collecting (psublis subs 1 v) into tem
1531 ; finally (return (make-rmap fns tem denom
1532 ; (psublis subs 1 (rmap-denom coord2))))))
1533 ; (setq answ (reduce-rational-map answ))))
1552 ;(defun translate-component-and-reduce (from-open to-open ldata
1553 ; &aux *refine-opens* hh gg red-transl transl map )
1554 ; (setq map (find-ring-map from-open to-open))
1555 ; (setq transl (apply-rmap map ldata))
1556 ; (setq red-transl (ldata-simplifications transl
1557 ; (setq gg (zopen-inequality to-open))))
1558 ; (show red-transl)
1559 ; (setq hh (nplcm (rmap-denom map) gg))
1560 ; (setq hh (nplcm (function-numerator (apply-rmap map (zopen-inequality from-open)))
1561 ; hh))
1562 ;
1563 ; (loop for v in red-transl
1564 ; when (not (unit-idealp (ldata-eqns v) hh))
1565 ; collecting v into tem
1566 ; finally (return (cond ((> (length tem) 1)
1567 ; (format t
1568 ; "~%The image had two components meet the intersection.")
1569 ; (des tem) (break 'two))
1570 ; ((= (length tem) 1) (car tem))
1571 ; (t nil)))))
1577 ;;;works
1583 for v in facts by #'cddr
1584 collecting v into tem
1591 ;;;did not need to compute the translated ldata except on the intersection
1594 inv inv-denom transl MAPL )
1595 ; (declare (values ldata intersection-inequality-on-to-open))
1610 hh))
1611 ;;calculate on open intersection (possibly using the inv-denom !!)
1617 collecting v into tem
1626 ;(defun translate-reduced-component-and-reduce (from-open to-open ldata &aux leng)
1627 ; (multiple-value-bind ( answ hh)
1628 ; (translate-component-and-reduce from-open to-open ldata
1629 ; :use-inverse-inequal nil)
1630 ; (show answ)
1631 ; (cond ((null answ) (values answ hh))
1632 ; ((equal leng (length (ldata-eqns ldata)))
1633 ; (cond ((null use-inverse-inequal)
1634 ;
1635 ; (translate-component-and-reduce from-open to-open ldata
1636 ; :use-inverse-inequal t
1637 ; ))))
1638 ; (t (values answ hh)))))
1642 ;;to hell with the expense: use translate the correct intersection inequality.
1644 &key homogeneous-ldata-on-to-open
1645 &aux answer int-transl
1646 contract simp-contract)
1653 answer
1657 answ)
1660 hh))
1663 :open-g
1671 collecting v into some-ld
1690 ))))
1699 ;(defun translate-reduced-component (from-open to-open ldata pls
1700 ; &key( break-bad-component t)
1701 ; &aux map gg hh answer
1702 ; image answ cont unit *stop-simplify*)
1703 ; "Takes eqns (which one might want to turn into coordinates) and translates them
1704 ; around to the other opens. For example if one had an ldata of some one open
1705 ; and wanted to blow it up one would need the translates of this, before blowing up."
1706 ;
1707 ;
1708 ; (cond ((eq from-open to-open) ldata)
1709 ; (t
1710 ; (setq to-open (nth to-open (pls-opens pls)))
1711 ; (setq from-open (nth from-open (pls-opens pls)))
1712 ; (setq hh (zopen-inequality to-open ))
1713 ; (setq gg (zopen-inequality from-open ))
1714 ; (cond ((ldatap ldata) nil)
1715 ; (t (setq ldata (make-ldata :eqns ldata :inequality
1716 ; 1 ))))
1717 ; (setq map (find-ring-map from-open to-open))
1718 ; (setq image (apply-rmap map ldata))
1719 ; (setq gg (function-numerator (apply-rmap map gg)))
1720 ; (setq hh (nplcm hh gg))
1721 ; (setq hh (nplcm (rmap-denom map) hh))
1722 ; (setq answ (ldata-simplifications image))
1723 ; (loop for v in answ
1724 ; do (multiple-value
1725 ; (cont unit)
1726 ; (grobner-subset (ldata-eqns v)
1727 ; (ldata-eqns image)
1728 ; hh))
1729 ; (cond (unit (format t "%intersection is empty") (return 'empty))
1730 ; (cont (return (setq answer v))))
1731 ; finally (cond (answ (return
1732 ; (cond (break-bad-component
1733 ; (merror "bad-comp")
1734 ; (break 'bad-component))
1735 ; (t (format t "****Bad component: not trivial****")))))))
1736 ; answer)))
1743 ;(defun test (pl n m l &aux opens im (ldata (nth n (nth m (pls-data pl)))))
1744 ; (setq opens (pls-opens pl))
1745 ; (setq im (translate-component (nth m opens) (nth l opens) ldata))
1746 ;; (setq denom (apply-rmap ma (rmap-denom (coord
1747 ; (loop for ld in (nth l (pls-data pl))
1748 ; when (grobner-subset ld im)
1749 ; do (format t "image is:") (shl im)
1750 ; (format t" containing")(des ld)
1751 ; (des (nth l (pls-data pl)))))
1755 "Gets the list of ldata corresponding to OPEN"
1765 ;(defun function-numerator (f)
1766 ; (cond ((affine-polynomialp f) f)
1767 ; ((rational-functionp f) (num f))
1768 ; (t (num (new-rat f)))))
1769 ;
1770 ;(defun match-components (pls nth-open &aux map opens open gg image cont unit answ)
1771 ; (setq opens (pls-opens pls))
1772 ; (setq open (nth nth-open opens))
1773 ; (setq answ
1774 ; (loop for ld in (pls-ldata pls open)
1775 ; for ii from 0
1776 ; collecting
1777 ; (loop for op in opens
1778 ; for i from 0
1779 ; for lis-ld in (pls-data pls)
1780 ; when (not (eql i nth-open))
1781 ; collecting
1782 ; (progn
1783 ; (setq map (find-ring-map open op))
1784 ; (setq image (apply-rmap map ld))
1785 ; (setq gg (function-numerator (apply-rmap map (zopen-inequality open))))
1786 ; (setq gg (plcm (rmap-denom map) gg))
1787 ; (loop for ldd in lis-ld
1788 ; for j from 0
1789 ; do
1790 ; (multiple-value (cont unit)
1791 ; (grobner-subset (ldata-eqns ldd)
1792 ; (ldata-eqns image)
1793 ; (plcm (zopen-inequality op) gg)))
1794 ;
1795 ; (cond (unit
1796 ; (format
1797 ; t
1798 ; "~%The intersection with the ~D open is empty."
1799 ; i)))
1800 ; (cond ((and (null unit) cont)
1801 ; (cond ((null (grobner-subset
1802 ; (ldata-eqns image)
1803 ; (ldata-eqns ldd)
1804 ; (plcm (zopen-inequality op) gg)))
1805 ;
1806 ; (merror "containment only one way!!")))))
1807 ; when unit do (return nil)
1808 ; when (and (null unit)cont)
1809 ; collecting (cons i j) into tem
1810 ; finally
1811 ; (cond ((and lis-ld (null tem))
1812 ; (merror "this component not trivial")))
1813 ; (return tem))))))
1814 ; (loop for u in answ
1815 ; do (des (car u))
1816 ; (loop for vv in (cdr u)
1817 ; do
1818 ; (loop for v in vv
1819 ; do
1820 ; (format t
1821 ; "~%on open ~A the ~D component is contained in its image"
1822 ; (car v)(cdr v)))))
1823 ; answ)
1836 collecting v)
1846 ;;;doesn 't work!! eg if str1 is nil
1847 ;(defun build-equivalence-relation1 (str1 str2 &aux str3)
1848 ; (setq str3
1849 ; (loop for v in str1
1850 ; collecting
1851 ; (loop for w in str2
1852 ; when (intersectp v w :test 'equal)
1853 ; appending (union-equal v w) into tem))))
1860 do
1881 ;
1882 ;(defun new-match-components (pls open-number)
1883 ; (declare (special str))
1884 ; (loop for ld in (pls-ldata open-number)
1885 ; for ii from 0
1886 ; do
1887 ; (new-match-component pls open-number ii)))
1888 ;
1889 ;(defun new-match-component (pls open ld-number &aux (opens (pls-opens pls)) hh nth-open
1890 ; ok map image gg simped images cont unit *bad-components* ld)
1891 ; (setq nth-open (find-position-in-list opens))
1892 ; (setq ld (pls-ldata 0 :ldata-number ld-number))
1893 ; (loop for op in (pls-opens pls)
1894 ; for i from 0
1895 ; for lis-ld in (pls-data pls)
1896 ; when (equal op open)
1897 ; do (push (cons nth-open ld-number ) str)
1898 ; else
1899 ; do (setq map (find-ring-map op open))
1900 ; (setq image (apply-rmap map ld))
1901 ; (setq gg (function-numerator (apply-rmap map (zopen-inequality open))))
1902 ; (setq gg (plcm (rmap-denom map) gg))
1903 ; (setq images (list image))
1904 ; (setq ok nil)
1905 ; (setq simped nil)
1906 ; (loop while images
1907 ; do (setq image (car images))
1908 ; (setq images (cdr images))
1909 ; (loop for an-ld in lis-ld
1910 ; for j from 0
1911 ; do
1912 ; (multiple-value (cont unit)
1913 ; (grobner-subset (ldata-eqns an-ld)
1914 ; (ldata-eqns image)
1915 ; (setq hh (plcm (zopen-inequality op) gg))))
1916 ; when cont
1917 ; do (setq ok t) (push (cons nth-open j) str)
1918 ; when unit
1919 ; do (push (cons nth-open nil) str)
1920 ; (setq ok t) (return 'empty))
1921 ; finally (cond ((and lis-ld (null ok))
1922 ; (cond ((null simped)
1923 ; (setq images (ldata-simplifications image))
1924 ; (setq simped t)
1925 ; (cond ((equal (ldata-eqns (car images))
1926 ; (ldata-eqns image))
1927 ; (setq images nil))))
1928 ; (t
1929 ;
1930 ; (push (list nth-open i ld-number) *bad-components*)
1931 ; (format t "~%Bad component ~A" (car *bad-components*)))))))))
1934 current-ld-number nth-open
1938 do
1940 for i from 0
1941 do
1944 when unit
1946 when
1956 ;
1957 ;(defun match-components (pls nth-open &key check-equal break-on-bad ignore-empty-opens
1958 ; ldata-number &aux map opens open gg hh image cont unit answ found-one str lis-dat rev-cont)
1959 ; (setq opens (pls-opens pls))
1960 ; (setq open (nth nth-open opens))
1961 ; (setq lis-dat (pls-ldata pls open) )
1962 ; (cond (ldata-number (setq lis-dat (list (nth ldata-number lis-dat)))))
1963 ; (setq answ
1964 ; (loop for ld in lis-dat
1965 ; for ii from 0
1966 ; ;;str will be ( (open number . ld number) ...)
1967 ; when ldata-number
1968 ; do (setq str (list (cons nth-open ldata-number)))
1969 ; else
1970 ; do
1971 ; (setq str (list (cons nth-open ii)))
1972 ; do
1973 ; (loop for op in opens
1974 ; for i from 0
1975 ; for lis-ld in (pls-data pls)
1976 ; when (and (not (eql i nth-open)) (or lis-ld (null ignore-empty-opens)))
1977 ; do (setq found-one nil)
1978 ; (progn
1979 ; (setq map (find-ring-map open op))
1980 ; (setq image (apply-rmap map ld))
1981 ; (setq gg (function-numerator (apply-rmap map (zopen-inequality open))))
1982 ; (setq gg (nplcm (rmap-denom map) gg))
1983 ; (loop for ldd in lis-ld
1984 ; for j from 0
1985 ; do
1986 ; (multiple-value (cont unit)
1987 ; (grobner-subset (ldata-eqns ldd)
1988 ; (ldata-eqns image)
1989 ; (setq hh (nplcm (zopen-inequality op) gg))))
1990 ; (cond ((and cont check-equal (null unit))
1991 ; (setq rev-cont (grobner-subset (ldata-eqns ldd)
1992 ; (ldata-eqns image)
1993 ; hh))
1994 ; (cond ((null rev-cont)
1995 ; (cond (break-on-bad (break 'not-equal)))))))
1996 ;
1997 ; (cond (unit
1998 ; (format
1999 ; t
2000 ; "~%The intersection with the ~D open is empty."
2001 ; i)))
2002 ;; (cond ((and (null unit) cont)
2003 ;; (cond ((null (grobner-subset
2004 ;; (ldata-eqns image)
2005 ;; (ldata-eqns ldd)
2006 ;; (nplcm (zopen-inequality op) gg)))
2007 ;;
2008 ;; (merror "containment only one way!!")))))
2009 ; when unit do (push (cons i nil) str)(setq found-one t)
2010 ; when (and (null unit)cont)
2011 ; do (push (cons i j) str) (setq found-one t)
2012 ; finally
2013 ; (cond ((and lis-ld (null found-one))
2014 ; (push (list nth-open ii i open ld) *bad-components*)
2015 ; (format t "~%*****Bad component..****")
2016 ; (format t " original open and component are:")
2017 ; (des open) (des ld)
2018 ; (format t "%On the image open the components are:")
2019 ; (loop for l in lis-ld do (des l))
2020 ; (format t "while image is :")
2021 ; (des image)
2022 ; (cond (break-on-bad (break t))))
2023 ; ))))
2024 ;; (merror
2025 ; ; "this component not trivial but doesn't seem to be here"))))))
2026 ; collecting str))
2027 ; answ)
2032 ldata-number &aux MAPL opens open gg hh tem
2033 image cont unit answ found-one str lis-dat rev-cont)
2040 for ii from 0
2041 ;;str will be ( (open number . ld number) ...)
2042 when ldata-number
2044 else
2045 do
2047 do
2049 for i from 0
2059 for j from 0
2060 do
2068 hh))
2074 t
2075 "~%The intersection with the ~D open is empty."
2076 i)))
2077 ; (cond ((and (null unit) cont)
2078 ; (cond ((null (grobner-subset
2079 ; (ldata-eqns image)
2080 ; (ldata-eqns ldd)
2081 ; (nplcm (zopen-inequality op) gg)))
2082 ;
2083 ; (merror "containment only one way!!")))))
2087 finally
2090 lis-ld image hh i j nth-open))
2092 ; (push (list nth-open ii i open ld) *bad-components*)
2093 ; (format t "~%*****Bad component..****")
2094 ; (format t " original open and component are:")
2095 ; (des open) (des ld)
2096 ; (format t "%On the image open the components are:")
2097 ; (loop for l in lis-ld do (des l))
2098 ; (format t "while image is :")
2099 ; (des image)
2100 ; (cond (break-on-bad (break t))))
2101 ))))
2102 ; (merror
2103 ; "this component not trivial but doesn't seem to be here"))))))
2104 collecting str))
2105 answ)
2123 do
2127 collecting com into tem
2137 components all-codims ops bad-one)
2138 "we assume that the pls has been reduced"
2140 for op-num from 0
2142 do
2145 for i from 0
2150 else
2151 do
2153 for comp in components
2160 with accounted-for
2164 for lld-num from 0
2166 do
2169 op to-open lld))
2170 when transl
2171 do
2173 for ld-num from 0
2174 when
2178 do
2181 transl ld :open-g hh
2188 for lld-num from 0
2191 and
2193 and
2208 for i from 0
2210 collecting i))
2221 ; (cond ((check-equivalence-relation equiv) equiv)
2222 ; (t (merror "some components don't match up ~A" equiv)))
2229 for i from 0
2231 do
2234 for j from 0
2237 ;; should really look at inequal when (equal open op2)
2241 ; (check-components-contain-original (car lis-dat) lis-dat2))
2245 ;;the following system of equations does not admit a nice solution using the above.
2246 ;;maybe we have to add another divide-dichotomy machine:
2247 ;;If have two polynomials with leading term x6 could do a dichotomy:
2248 ;;f=y^i*a+.. g=y^j*b+.. then do
2249 ;; while y is the main variable you make dichotomy
2250 ;;between (third (vdivide f g))=0 and (third (vdivide f g)) invertible.
2251 ;;in the latter system you have the additional ldata of remainder.
2253 ;;(LDATA ((X7 1 1) (X8 1 1) (X5 2 1 1 (X4 2 -2 0 (X3 1 (X2 1 1))) 0 (X4 4 1 2 (X3 1 (X2 1 1)) 1 (X3 1 (X1 1 2)))) (X6 1 (X5 1 (X2 1 1) 0 (X4 2 (X2 1 1) 1 (X1 1 2))) 0 (X5 1 (X4 1 (X2 1 3) 0 (X1 1 2)) 0 (X4 3 (X2 1 -1)))) (X6 1 (X5 1 1 0 (X4 2 -1)) 0 (X5 1 (X4 1 -1) 0 (X4 3 1 1 (X3 1 (X2 1 -1)) 0 (X3 1 (X1 1 -1))))) (X5 1 (X2 2 1) 0 (X1 2 -1))) 1 2)
2255 ; (declare (values where-its-miniminum))
2259 with .where.
2267 "operation may be :minimize, maximize, general-summing, or general-product;
2268 and the the quantity will ususually involve the variable v. The result of the
2269 minimize is where the minimum is"
2281 with .prev-min. = ,init
2282 with .where.
2283 ,@ when-clause
2284 do
2297 with .answer. = ,init
2298 ,@ when-clause
2301 (t (fsignal "The operation was not one of minimize, maximize, general-summing, or general-product"))))
2305 ;;(for v in '(-1 -3 -.5 2 3) when (< v 0) minimize (abs v ))
2307 ;;(for v in '(-1 $x -3 -.5 2 3) general-product v )
2308 ;;(for v in '(-1 $x -3 -.5 2 3) when (> v 0) general-product v )
2310 ;
2311 ;(defun good-order-variables (eqns &aux variable-occurs (varl (list-variables eqns)))
2312 ; (declare (special mult))
2313 ; (declare (values . (list ordered-list variable-occurs-in)))
2314 ; (setq variable-occurs (mapcar 'list-variables eqns))
2315 ; (setq mult
2316 ; (loop for v in
2317 ; varl
2318 ; collecting
2319 ; (cons v
2320 ; (loop for w in variable-occurs
2321 ; for f in eqns
2322 ; when (member v w :test #'eq)
2323 ; count 1 ))))
2324 ; (setq mult (sort mult #'(lambda (u v)
2325 ; (< (cdr u) (cdr v)))))
2326 ; (list (mapcar 'car mult) variable-occurs))
2329 ;;this allowed me to do the troublesome ldata
2330 ;;it tries to order the variables so that the variables belonging to
2331 ;;simpler and less equations come first.
2332 ;(defun good-order-variables (eqns &aux variable-occurs (varl (list-variables eqns))
2333 ; compl)
2334 ; (declare (special mult))
2335 ; (declare (values . (list ordered-list variable-occurs-in)))
2336 ; (setq variable-occurs (mapcar 'list-variables eqns))
2337 ; (setq compl (loop for v in eqns collecting (gen-pcomplexity v)))
2338 ; (setq mult
2339 ; (loop for v in
2340 ; varl
2341 ; collecting
2342 ; (cons v
2343 ; (loop for w in variable-occurs
2344 ; for f in eqns
2345 ; when (member v w :test #'eq)
2346 ; count 1 into the-mult
2347 ; finally (return (* the-mult (loop for com in compl
2348 ; for ww in variable-occurs
2349 ; when (member v ww :test #'eq)
2350 ; minimize com)))))))
2351 ; (setq mult (sort mult #'(lambda (u v)
2352 ; (< (cdr u) (cdr v)))))
2353 ; (list (mapcar 'car mult) variable-occurs))
2356 compl)
2358 ; (declare (values . (list ordered-list variable-occurs-in)))
2364 order)))
2371 collecting
2374 for f in eqns
2376 count 1 into the-mult
2378 for ww in variable-occurs
2380 minimize com)))))))
2402 ;(defun order-equations (eqns variables &optional occurs &aux all-eqns)
2403 ; (cond ((null occurs) (setq occurs (mapcar 'list-variables eqns))))
2404 ; (loop for va in variables
2405 ; appending
2406 ; (loop for eqn in eqns
2407 ; for oc in occurs
2408 ; when (member va oc :test #'eq)
2409 ; do (push-new eqn all-eqns)))
2410 ; (nreverse all-eqns))
2413 ; (declare (values eqns ch-set))
2431 collecting v))
2436 collecting
2446 error-check-containments))
2450 collecting ld
2451 else
2457 appending result))
2459 answ))
2461 ;;this is hoky. It should try much harder!!
2469 ;;should be wrt open-g
2496 for f in eqns
2500 for ff in eqns
2502 do
2515 answ)
2523 ))
2555 for v in variables
2561 ;(defun divide-dichotomy (ldata &key (open-g 1) &aux (eqns (ldata-eqns ldata)) f new-eqns
2562 ; occurs vars highest-vars orig-rep repeat eqns-rep gg ld1 ld2)
2563 ;
2564 ; "endeavors to turn ldata into an triangular list of eqns
2565 ; so that each equation has possibly one more variable occurring than the
2566 ; previous. It takes a good order for the variables and then takes the first variable
2567 ; to be highest in two succeeding eqns, and does a division to try to correct this. If
2568 ; the leading variable is not invertible it does a dichotomy. This dichotomy must be
2569 ; at the level of open sets, since otherwise we will not get component containment."
2570 ; ;;ordering should take into account open-g
2571 ; (setq vars (good-order-variables eqns))
2572 ; (setq occurs (second vars))
2573 ; (setq vars (first vars))
2574 ; (setq highest-vars
2575 ; (loop for v in occurs
2576 ; collecting (loop for u in vars
2577 ; when (member u v :test #'eq)
2578 ; do (return u))))
2579 ; (show vars highest-vars)
2580 ; (setq repeat
2581 ; (loop named rep for v in vars
2582 ; do
2583 ; (loop for w on highest-vars
2584 ; when (and (eq (car w) v)
2585 ; (member v (cdr w) :test #'eq))
2586 ; do (return-from rep v))))
2587 ; (cond
2588 ; (repeat
2589 ; (setq eqns-rep (loop for v in eqns
2590 ; for u in highest-vars
2591 ; when (eq u repeat)
2592 ; collecting v))
2593 ; (setq orig-rep (copy-list eqns-rep))
2594 ; (show (length eqns-rep))
2595 ; (setq eqns-rep (sort-key eqns-rep '< 'pdegree repeat))
2596 ;; (progn (declare (special repeat))
2597 ;; (setq eqns-rep (sort eqns-rep
2598 ;; #'(lambda (u v) (< (pdegree u repeat) (pdegree v repeat))))
2599 ; (show (length eqns-rep))
2600 ;
2601 ; (cond ((eq ( pdegree (first eqns-rep) repeat)
2602 ; (pdegree (second eqns-rep) repeat))
2603 ; ;;choose the least complex leading coefficient to divide by
2604 ; (setq eqns-rep
2605 ; (sort-key (firstn 2 eqns-rep) '<
2606 ; #'(lambda (u var) (pcomplexity
2607 ; (leading-coefficient u var)))
2608 ; repeat))))
2609 ; (setq f (second eqns-rep))
2610 ;
2611 ; (show repeat)
2612 ;
2613 ; (multiple-value-bind (rem c-reqd)
2614 ; (gen-prem f (first eqns-rep) repeat)
2615 ;
2616 ; (shl (list f (first eqns-rep)))
2617 ; (setq new-eqns (delete f
2618 ; (copy-list eqns)))
2619 ; (cond (($zerop rem) nil)
2620 ; (t (setq new-eqns ;;these have f replaced by rem
2621 ; (append new-eqns (list rem)))))
2622 ;; (setq gg (nplcm open-g (ldata-inequality ldata)))
2623 ;; (cond ((may-invertp c-reqd gg)
2624 ;; (setq ld2 (make-ldata eqns new-eqns
2625 ;; inequality gg )))
2626 ;; ;;make two ldata one where c-reqd is invertible and f replaced by rem
2627 ;; ;; and other where its zero and f is still there.
2628 ;; (t (setq ld2 (make-ldata eqns new-eqns
2629 ;; inequality (nplcm gg c-reqd)))
2630 ;; (setq ld1 (make-ldata eqns
2631 ;; (cons c-reqd eqns)
2632 ;; inequality gg))))
2633 ;; (cond (ld1
2634 ;; (format t "~%Breaking into dichotomy on:")
2635 ;; (sh c-reqd)
2636 ;; (format t "%original ldata followed by consequents:" )
2637 ;; (des ldata)(des ld1) (des ld2 )
2638 ;;
2639 ;; (append (ldata-simplifications ld1)
2640 ;; (ldata-simplifications ld2)))
2641 ;; (t
2642 ;; (format t "~%The c-reqd was invertible: ")
2643 ;; (sh c-reqd)
2644 ;; (ldata-simplifications ld2)))))
2645 ;; (t (list ldata))))
2646 ;
2647 ;
2648 ;;;I hope this was the one to keep
2649 ;(defun divide-dichotomy (ldata &key (open-g 1) &aux answ (eqns (ldata-eqns ldata)) f new-eqns
2650 ; occurs vars highest-vars orig-rep repeat eqns-rep gg ld1 ld2)
2651 ;
2652 ; "endeavors to turn ldata into an triangular list of eqns
2653 ; so that each equation has possibly one more variable occurring than the
2654 ; previous. It takes a good order for the variables and then takes the first variable
2655 ; to be highest in two succeeding eqns, and does a division to try to correct this. If
2656 ; the leading variable is not invertible it does a dichotomy. This dichotomy must be
2657 ; at the level of open sets, since otherwise we will not get component containment."
2658 ; ;;ordering should take into account open-g
2659 ; (setq vars (good-order-variables eqns))
2660 ; (setq occurs (second vars))
2661 ; (setq vars (first vars))
2662 ; (setq highest-vars
2663 ; (loop for v in occurs
2664 ; collecting (loop for u in vars
2665 ; when (member u v :test #'eq)
2666 ; do (return u))))
2667 ; (show vars highest-vars)
2668 ; (setq repeat
2669 ; (loop named rep for v in vars
2670 ; do
2671 ; (loop for w on highest-vars
2672 ; when (and (eq (car w) v)
2673 ; (member v (cdr w) :test #'eq))
2674 ; do (return-from rep v))))
2675 ; (cond
2676 ; (repeat
2677 ; (setq eqns-rep (loop for v in eqns
2678 ; for u in highest-vars
2679 ; when (eq u repeat)
2680 ; collecting v))
2681 ; (setq orig-rep (copy-list eqns-rep))
2682 ; (show (length eqns-rep))
2683 ; (setq eqns-rep (sort-key eqns-rep '< 'pdegree repeat))
2684 ;; (progn (declare (special repeat))
2685 ;; (setq eqns-rep (sort eqns-rep
2686 ;; #'(lambda (u v) (< (pdegree u repeat) (pdegree v repeat))))
2687 ; (show (length eqns-rep))
2688 ;
2689 ; (cond ((eq ( pdegree (first eqns-rep) repeat)
2690 ; (pdegree (second eqns-rep) repeat))
2691 ; ;;choose the least complex leading coefficient to divide by
2692 ; (setq eqns-rep
2693 ; (sort-key (firstn 2 eqns-rep) '<
2694 ; #'(lambda (u var) (pcomplexity
2695 ; (leading-coefficient u var)))
2696 ; repeat))))
2697 ; (setq f (second eqns-rep))
2698 ; (cond ((not (equal (ml-sort (copy-list eqns-rep))
2699 ; (ml-sort (copy-list orig-rep))))
2700 ; (merror "not sorted but destroyed!!")))
2701 ; (show repeat)
2702 ;
2703 ; (multiple-value-bind (rem c-reqd)
2704 ; (gen-prem f (first eqns-rep) repeat)
2705 ; (shl (list f (first eqns-rep)))
2706 ; (setq new-eqns (delete f
2707 ; (copy-list eqns)))
2708 ; (cond (($zerop rem) nil)
2709 ; (t (setq new-eqns ;;these have f replaced by rem
2710 ; (append new-eqns (list rem)))))
2711 ; (setq gg (nplcm open-g (ldata-inequality ldata)))
2712 ; (mshow open-g)
2713 ; (cond ((may-invertp c-reqd gg)
2714 ; (list (ldata-simplifications (make-ldata eqns new-eqns
2715 ; inequality gg ) open-g)))
2716 ; (t
2717 ; (setq ld1 (make-ldata eqns (cons f new-eqns) inequality (plcm c-reqd gg)))
2718 ; (setq ld2 (make-ldata eqns (cons c-reqd (ldata-eqns ldata)) inequality gg))
2719 ; (check-component-containment ldata (list ld1 ld2) open-g)
2720 ; (setq answ(append
2721 ; (ldata-simplifications ld1 open-g)
2722 ; (ldata-simplifications ld2 open-g)))
2723 ; (check-component-containment ldata answ open-g)
2724 ; answ))))
2725 ; (t (list ldata))))
2728 ;;from version 7 ;;this worked on orig so be careful about modifying it!!!.
2729 ;;watch out for the use-inverse in delete redundant switch.
2736 for eqnss on eqns
2740 for va in v
2743 collecting v)))
2748 ;
2749 ;(defun new-divide-dichotomy (ldata &key (open-g 1) &aux var-and-occurs variables eqns occurs highest-variables
2750 ; divisor ld1 ld2
2751 ; repeated-eqns high-var)
2752 ; (setq var-and-occurs (good-order-variables ldata))
2753 ; (setq variables (car var-and-occurs) occurs (second var-and-occurs))
2754 ; (setq eqns (order-equations (ldata-eqns ldata) variables occurs))
2755 ; (setq occurs (mapcar 'list-variables eqns))
2756 ; (setq highest-variables (highest-variables variables occurs))
2757 ; (multiple-value-setq (repeated-eqns high-var)
2758 ; (find-repeats highest-variables eqns))
2759 ; (cond
2760 ; (repeated-eqns
2761 ; (setq repeated-eqns (sort-key repeated-eqns '< 'pdegree high-var))
2762 ;
2763 ; (setq divisor
2764 ; (loop for v in repeated-eqns
2765 ; find v minimizing (+ (* 1000 (pdegree v high-var))
2766 ; (pcomplexity v))))
2767 ; (multiple-value-bind (rem c-reqd)
2768 ; (gen-prem (second repeated-eqns) divisor high-var)
2769 ; (setq ld1 (copy-list-structure ldata))
2770 ; (setf (ldata-eqns ld1)
2771 ; (cons rem (delete (second repeated-eqns) (copy-list eqns))))
2772 ; (iassert (not (member (second repeated-eqns) (ldata-eqns ld1))))
2773 ; (mshow divisor (second repeated-eqns) rem c-reqd)
2774 ; (cond ((may-invertp c-reqd open-g)
2775 ; (format t " which was invertible")
2776 ; (ldata-simplifications
2777 ; ld1 :open-g open-g))
2778 ; (t
2779 ; (setq ld2 (copy-list-structure ldata))
2780 ; (setf (ldata-eqns ld2) (cons c-reqd (ldata-eqns ldata)))
2781 ; (setf (ldata-inequality ld1) (nplcm (ldata-inequality ldata)
2782 ; c-reqd))
2783 ; (des ld1)(des ld2)
2784 ; (append
2785 ; (ldata-simplifications
2786 ; ld1 :open-g open-g)
2787 ; (ldata-simplifications
2788 ; ld2 :open-g open-g))))))
2789 ; (t (list ldata))))
2799 occurs vars highest-vars orig-rep repeat eqns-rep gg ld1 ld2)
2801 "endeavors to turn ldata into an triangular list of eqns
2802 so that each equation has possibly one more variable occurring than the
2803 previous. It takes a good order for the variables and then takes the first variable
2804 to be highest in two succeeding eqns, and does a division to try to correct this. If
2805 the leading variable is not invertible it does a dichotomy "
2807 ;;ordering should take into account open-g
2830 ; (push repeat *used-divisors*)
2834 ;;choose the least complex leading coefficient to divide by
2839 repeat))))
2854 ;;make two ldata one where c-reqd is invertible and f replaced by rem
2855 ;; and other where its zero and f is still there.
2861 :inequality gg
2871 ; (loop for v in (list ld1 ld2)
2872 ; when (not (unit-idealp (ldata-eqns v) (ldata-inequality v)))
2873 ; appending (ldata-simplifications v )))
2889 answer)
2892 ;
2893 ;;;;;the following was the divide-dichotomy in force at XMAS 84
2894 ;(defun divide-dichotomy (ldata &key (open-g 1) &aux answer used
2895 ; (eqns (ldata-eqns ldata)) f new-eqns
2896 ; occurs vars highest-vars orig-rep repeat eqns-rep gg ld1 ld2)
2897 ;
2898 ; "endeavors to turn ldata into an triangular list of eqns
2899 ; so that each equation has possibly one more variable occurring than the
2900 ; previous. It takes a good order for the variables and then takes the first variable
2901 ; to be highest in two succeeding eqns, and does a division to try to correct this. If
2902 ; the leading variable is not invertible it does a dichotomy "
2903 ;
2904 ; ;;ordering should take into account open-g
2905 ;
2906 ; (setq ldata (copy-list-structure ldata))
2907 ; (setq vars (copy-tree (good-order-variables eqns)))
2908 ; (setq occurs (second vars))
2909 ; (setq vars (first vars))
2910 ; (setq highest-vars
2911 ; (loop for v in occurs
2912 ; collecting (loop for u in vars
2913 ; when (member u v :test #'eq)
2914 ; do (return u))))
2915 ; (show vars highest-vars)
2916 ; (setq repeat
2917 ; (loop named rep for v in vars
2918 ; do
2919 ; (loop for w on highest-vars
2920 ; when (and (eq (car w) v)
2921 ; (member v (cdr w) :test #'eq))
2922 ; do (return-from rep v))))
2923 ;
2924 ; (unwind-protect
2925 ; (progn
2926 ; (cond
2927 ; (repeat
2928 ; (setq eqns-rep (loop for v in eqns
2929 ; for u in highest-vars
2930 ; when (eq u repeat)
2931 ; collecting v))
2932 ; (setq orig-rep (copy-list eqns-rep))
2933 ; (show (length eqns-rep))
2934 ; (setq eqns-rep (sort-key eqns-rep '< 'pdegree repeat))
2935 ; (setq used (cons repeat (pdegree (first eqns-rep) repeat)))
2936 ;; (push repeat *used-divisors*)
2937 ; (show (length eqns-rep))
2938 ; (cond ((eq ( pdegree (first eqns-rep) repeat)
2939 ; (pdegree (second eqns-rep) repeat))
2940 ; ;;choose the least complex leading coefficient to divide by
2941 ; (setq eqns-rep
2942 ; (sort-key (firstn 2 eqns-rep) '<
2943 ; #'(lambda (u var) (pcomplexity
2944 ; (leading-coefficient u var)))
2945 ; repeat))))
2946 ; (setq f (second eqns-rep))
2947 ; (show repeat)
2948 ; (multiple-value-bind (rem c-reqd)
2949 ; (gen-prem f (first eqns-rep) repeat)
2950 ; (push f *used-divisors*)
2951 ; (mshow f (first eqns-rep))
2952 ; (setq new-eqns (delete f
2953 ; (copy-list eqns)))
2954 ; (cond (($zerop rem) nil)
2955 ; (t (setq new-eqns ;;these have f replaced by rem
2956 ; (append new-eqns (list rem)))))
2957 ; (setq gg (nplcm open-g (ldata-inequality ldata)))
2958 ; (cond ((may-invertp c-reqd gg)
2959 ; (setq ld2 (make-ldata eqns new-eqns
2960 ; inequality gg variables vars )))
2961 ; ;;make two ldata one where c-reqd is invertible and f replaced by rem
2962 ; ;; and other where its zero and f is still there.
2963 ; (t (setq ld2 (make-ldata eqns new-eqns
2964 ; inequality (nplcm gg c-reqd)
2965 ; variables vars))
2966 ; (setq ld1 (make-ldata eqns
2967 ; (cons c-reqd eqns)
2968 ; inequality gg
2969 ; variables vars))))
2970 ; (setq answer
2971 ;
2972 ; (cond
2973 ; (ld1
2974 ; (format t "~%Breaking into dichotomy on:")
2975 ; (sh c-reqd)
2976 ; (format t "%original ldata followed by consequents:" )
2977 ; (des ldata)(des ld1) (des ld2 )
2978 ;; (loop for v in (list ld1 ld2)
2979 ;; when (not (unit-idealp (ldata-eqns v) (ldata-inequality v)))
2980 ;; appending (ldata-simplifications v )))
2981 ;
2982 ; (append (ldata-simplifications ld1
2983 ; :open-g open-g :recursive-p t)
2984 ; (ldata-simplifications
2985 ; ld2 :open-g open-g :recursive-p t)))
2986 ; (t
2987 ; (format t "~%The c-reqd was invertible: ")
2988 ; (sh c-reqd)
2989 ; (iassert (not (member f (ldata-eqns ld2))))
2990 ; (des ld2)
2991 ; (ldata-simplifications
2992 ; ld2 :open-g open-g :recursive-p t))))))
2993 ; (t (setq answer (list ldata)))))
2994 ; (setq *used-divisors* nil))
2995 ;
2996 ; answer)
2997 ;;attempt to repeat use of the variable order
2998 ;(defun divide-dichotomy (ldata &key (open-g 1) &aux answer used
2999 ; (eqns (ldata-eqns ldata)) f new-eqns
3000 ; occurs vars highest-vars orig-rep repeat eqns-rep gg ld1 ld2)
3001 ;
3002 ; "endeavors to turn ldata into an triangular list of eqns
3003 ; so that each equation has possibly one more variable occurring than the
3004 ; previous. It takes a good order for the variables and then takes the first variable
3005 ; to be highest in two succeeding eqns, and does a division to try to correct this. If
3006 ; the leading variable is not invertible it does a dichotomy "
3007 ;
3008 ; ;;ordering should take into account open-g
3009 ;
3010 ; (setq ldata (copy-list-structure ldata))
3011 ; (setq vars (good-order-variables eqns))
3012 ; (setq occurs (second vars))
3013 ; (setq vars (first vars))
3014 ; (loop for v in *used-divisors*
3015 ; do (setq vars (delete v vars)))
3016 ; (setq highest-vars
3017 ; (loop for v in occurs
3018 ; collecting (loop for u in vars
3019 ; when (member u v :test #'eq)
3020 ; do (return u))))
3021 ; (show vars highest-vars)
3022 ; (setq repeat
3023 ; (loop named rep for v in vars
3024 ; do
3025 ; (loop for w on highest-vars
3026 ; when (and (eq (car w) v)
3027 ; (member v (cdr w) :test #'eq))
3028 ; do (return-from rep v))))
3029 ;
3030 ; (unwind-protect
3031 ; (progn
3032 ; (cond
3033 ; (repeat
3034 ; (setq eqns-rep (loop for v in eqns
3035 ; for u in highest-vars
3036 ; when (eq u repeat)
3037 ; collecting v))
3038 ; (setq orig-rep (copy-list eqns-rep))
3039 ; (show (length eqns-rep))
3040 ; (setq eqns-rep (sort-key eqns-rep '< 'pdegree repeat))
3041 ; (setq used (cons repeat (pdegree (first eqns-rep) repeat)))
3042 ;; (push repeat *used-divisors*)
3043 ; (show (length eqns-rep))
3044 ; (cond ((eq ( pdegree (first eqns-rep) repeat)
3045 ; (pdegree (second eqns-rep) repeat))
3046 ; ;;choose the least complex leading coefficient to divide by
3047 ; (setq eqns-rep
3048 ; (sort-key (firstn 2 eqns-rep) '<
3049 ; #'(lambda (u var) (pcomplexity
3050 ; (leading-coefficient u var)))
3051 ; repeat))))
3052 ; (setq f (second eqns-rep))
3053 ; (show repeat)
3054 ; (multiple-value-bind (rem c-reqd)
3055 ; (gen-prem f (first eqns-rep) repeat)
3056 ; (push f *used-divisors*)
3057 ; (mshow f (first eqns-rep))
3058 ; (setq new-eqns (delete f
3059 ; (copy-list eqns)))
3060 ; (cond (($zerop rem) nil)
3061 ; (t (setq new-eqns ;;these have f replaced by rem
3062 ; (append new-eqns (list rem)))))
3063 ; (setq gg (nplcm open-g (ldata-inequality ldata)))
3064 ; (cond ((may-invertp c-reqd gg)
3065 ; (setq ld2 (make-ldata eqns new-eqns
3066 ; inequality gg variables vars )))
3067 ; ;;make two ldata one where c-reqd is invertible and f replaced by rem
3068 ; ;; and other where its zero and f is still there.
3069 ; (t (setq ld2 (make-ldata eqns new-eqns
3070 ; inequality (nplcm gg c-reqd)
3071 ; variables vars))
3072 ; (setq ld1 (make-ldata eqns
3073 ; (cons c-reqd eqns)
3074 ; inequality gg
3075 ; variables vars))))
3076 ; (setq answer
3077 ; (cond (ld1
3078 ; (format t "~%Breaking into dichotomy on:")
3079 ; (sh c-reqd)
3080 ; (format t "%original ldata followed by consequents:" )
3081 ; (des ldata)(des ld1) (des ld2 )
3082 ;; (loop for v in (list ld1 ld2)
3083 ;; when (not (unit-idealp (ldata-eqns v) (ldata-inequality v)))
3084 ;; appending (ldata-simplifications v )))
3085 ;
3086 ; (append (ldata-simplifications ld1
3087 ; :open-g open-g :recursive-p t)
3088 ; (ldata-simplifications
3089 ; ld2 :open-g open-g :recursive-p t)))
3090 ; (t
3091 ; (format t "~%The c-reqd was invertible: ")
3092 ; (sh c-reqd)
3093 ; (iassert (not (member f (ldata-eqns ld2))))
3094 ; (des ld2)
3095 ; (ldata-simplifications
3096 ; ld2 :open-g open-g :recursive-p t))))))
3097 ; (t (setq answer (list ldata)))))
3098 ; (setq *used-divisors* nil))
3099 ;
3100 ; answer)
3103 ;;evaluates the key function only once for each term
3104 ;;orders by (pred (key u) (key v)) true ==> u earlier than v in sorted list
3120 do
3133 clist)
3135 ;;one should do divide dichot on the simplest functions and
3136 ;;the lowest degree variables..
3138 ;(defun second-divide-dichotomy (ldata &key (open-g 1) &aux tem
3139 ; variables-to-exclude non-lin-eqns)
3140 ; (unwind-protect
3141 ; (progn
3142 ; (loop for eqn in (ldata-eqns ldata)
3143 ; when (setq tem (any-linearp eqn open-g :variables-to-exclude
3144 ; variables-to-exclude))
3145 ; do (push tem variables-to-exclude)
3146 ; and
3147 ; collecting eqn into lin-eqn
3148 ; else
3149 ; collecting eqn into non-lin
3150 ; finally (setq non-lin-eqns non-lin))
3151 ; (setq non-lin-eqns (sort-expensive-key
3152 ; non-lin-eqns #'< #'gen-pcomplexity))
3153 ; (loop for eqn in non-lin-eqns
3154 ; collecting (degree-one-variables eqn) into deg-1
3155 ; collecting (list-variables eqn) into all-vars
3156 ; finally
3157 ; (setq deg1-divisions
3158 ; (loop for d1 in deg-1
3159 ; for f in non-lin-eqns
3160 ; for i from 0
3161 ; appending
3162 ; (loop for al in all-vars
3163 ; for j from 0
3164 ; for g in non-lin-eqns
3165 ; when (and (not (eql i j))
3166 ; (setq tem(intersect d1 al)))
3167 ; collecting (list tem g f ) into possible-1)))
3168 ; (setq higher-divisions
3169 ; (loop for d1 in all-vars
3170 ; for f in non-lin-eqns
3171 ; for i from 0
3172 ; appending
3173 ; (loop for al in all-vars
3174 ; for j from 0
3175 ; for g in non-lin-eqns
3176 ; when (and (not (eql i j))
3177 ; (setq tem(intersect d1 al)))
3178 ; collecting (list tem g f ) into possible-1)))
3179 ; (setq
3180 ; some-quotients
3181 ; (loop for try in deg1-divisions
3182 ; appending
3183 ; (loop for va in (third try)
3184 ; when (not (member (cons va (cdr try))
3185 ; *used-divisors*))
3186 ; collecting (append
3187 ; (multiple-value-list (gen-prem (first try)
3188 ; (second try)
3189 ; va)) try))))
3190 ; (loop for f in non-lin-eqns
3191 ; when (may-invertp (second v) open-g))))
3192 ;
3193 ;
3194 ; (setq *used-divisors* nil)))
3203 for f in fns
3206 finally
3217 ldata)))
3222 ldata))
3226 collecting
3233 )))))))
3245 (defun simplify-affine-ldata-write (ldata &key (open-g 1) (pathname "haskell:>wfs>answer.lisp") &aux answ)