Changeset 3483
- Timestamp:
- 2015-09-05T10:21:17-07:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/f4grobner/monom.lisp
r3482 r3483 340 340 order, otherwise NIL. The second returned value is T if P=Q, 341 341 otherwise it is NIL.") 342 (:method ((p monom) (q monom) &optional (start 0) (end ( r-dimension p)))342 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p))) 343 343 (declare (type fixnum start end)) 344 344 (do ((i start (1+ i))) 345 345 ((>= i end) (values nil t)) 346 346 (cond 347 ((> ( r-elt p i) (r-elt q i))347 ((> (monom-elt p i) (monom-elt q i)) 348 348 (return-from lex> (values t nil))) 349 ((< ( r-elt p i) (r-elt q i))349 ((< (monom-elt p i) (monom-elt q i)) 350 350 (return-from lex> (values nil nil))))))) 351 351 … … 355 355 lexicographic order, otherwise NIL. The second returned value is T if 356 356 P=Q, otherwise it is NIL.") 357 (:method ((p monom) (q monom) &optional (start 0) (end ( r-dimension p)))357 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p))) 358 358 (declare (type monom p q) (type fixnum start end)) 359 (let ((d1 ( r-total-degree p start end))360 (d2 ( r-total-degree q start end)))359 (let ((d1 (monom-total-degree p start end)) 360 (d2 (monom-total-degree q start end))) 361 361 (declare (type fixnum d1 d2)) 362 362 (cond … … 373 373 because some sets do not have a minimal element. This order is useful 374 374 in constructing other orders.") 375 (:method ((p monom) (q monom) &optional (start 0) (end ( r-dimension p)))375 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p))) 376 376 (declare (type fixnum start end)) 377 377 (do ((i (1- end) (1- i))) … … 379 379 (declare (type fixnum i)) 380 380 (cond 381 ((< ( r-elt p i) (r-elt q i))381 ((< (monom-elt p i) (monom-elt q i)) 382 382 (return-from revlex> (values t nil))) 383 ((> ( r-elt p i) (r-elt q i))383 ((> (monom-elt p i) (monom-elt q i)) 384 384 (return-from revlex> (values nil nil))))))) 385 385 … … 390 390 lexicographic order, NIL otherwise. The second returned value is T if 391 391 P=Q, otherwise it is NIL.") 392 (:method ((p monom) (q monom) &optional (start 0) (end ( r-dimension p)))392 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p))) 393 393 (declare (type fixnum start end)) 394 (let ((d1 ( r-total-degree p start end))395 (d2 ( r-total-degree q start end)))394 (let ((d1 (monom-total-degree p start end)) 395 (d2 (monom-total-degree q start end))) 396 396 (declare (type fixnum d1 d2)) 397 397 (cond … … 405 405 lexicographic order, NIL otherwise The second returned value is T if 406 406 P=Q, otherwise it is NIL.") 407 (:method ((p monom) (q monom) &optional (start 0) (end ( r-dimension p)))407 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p))) 408 408 (declare (type fixnum start end)) 409 409 (do ((i (1- end) (1- i))) … … 411 411 (declare (type fixnum i)) 412 412 (cond 413 ((> ( r-elt p i) (r-elt q i))413 ((> (monom-elt p i) (monom-elt q i)) 414 414 (return-from invlex> (values t nil))) 415 ((< ( r-elt p i) (r-elt q i))415 ((< (monom-elt p i) (monom-elt q i)) 416 416 (return-from invlex> (values nil nil))))))) 417 417 418 418 (defun reverse-monomial-order (order) 419 419 "Create the inverse monomial order to the given monomial order ORDER." 420 #'(lambda (p q &optional (start 0) (end ( r-dimension q)))420 #'(lambda (p q &optional (start 0) (end (monom-dimension q))) 421 421 (declare (type monom p q) (type fixnum start end)) 422 422 (funcall order q p start end))) … … 430 430 ;; This returns a closure with the same signature 431 431 ;; as all orders such as #'LEX>. 432 (defun make-elimination-orde r-factory-1 (&optional (secondary-elimination-order #'lex>))432 (defun make-elimination-ordemonom-factory-1 (&optional (secondary-elimination-order #'lex>)) 433 433 "It constructs an elimination order used for the 1-st elimination ideal, 434 434 i.e. for eliminating the first variable. Thus, the order compares the degrees of the 435 435 first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER." 436 #'(lambda (p q &optional (start 0) (end ( r-dimension p)))436 #'(lambda (p q &optional (start 0) (end (monom-dimension p))) 437 437 (declare (type monom p q) (type fixnum start end)) 438 438 (cond 439 ((> ( r-elt p start) (r-elt q start))439 ((> (monom-elt p start) (monom-elt q start)) 440 440 (values t nil)) 441 ((< ( r-elt p start) (r-elt q start))441 ((< (monom-elt p start) (monom-elt q start)) 442 442 (values nil nil)) 443 443 (t … … 447 447 ;; The result is *another closure* with the same signature as all 448 448 ;; orders such as #'LEX>. 449 (defun make-elimination-orde r-factory (&optional449 (defun make-elimination-ordemonom-factory (&optional 450 450 (primary-elimination-order #'lex>) 451 451 (secondary-elimination-order #'lex>)) … … 467 467 (error "K must be at least 1")) 468 468 ((= k 1) 469 (make-elimination-orde r-factory-1 secondary-elimination-order))469 (make-elimination-ordemonom-factory-1 secondary-elimination-order)) 470 470 (t 471 #'(lambda (p q &optional (start 0) (end ( r-dimension p)))471 #'(lambda (p q &optional (start 0) (end (monom-dimension p))) 472 472 (declare (type monom p q) (type fixnum start end)) 473 473 (multiple-value-bind (primary equal)
Note:
See TracChangeset
for help on using the changeset viewer.