diff options
| author | dos-reis <gdr@axiomatics.org> | 2008-08-16 06:00:35 +0000 |
|---|---|---|
| committer | dos-reis <gdr@axiomatics.org> | 2008-08-16 06:00:35 +0000 |
| commit | 84db9d8c5349cb8b3e7e2d102867e53e610d7ef2 (patch) | |
| tree | 0a2689194fd9e75ce8925550a4e177f3e5520684 /src/algebra/strap/UFD-.lsp | |
| parent | 3372c377eded97a0094f63cddd2e039af7066431 (diff) | |
| download | open-axiom-84db9d8c5349cb8b3e7e2d102867e53e610d7ef2.tar.gz | |
* algebra/strap: New. Sequester cached Lisp translation of
algebra bootstrap domains here.
Diffstat (limited to 'src/algebra/strap/UFD-.lsp')
| -rw-r--r-- | src/algebra/strap/UFD-.lsp | 83 |
1 files changed, 83 insertions, 0 deletions
diff --git a/src/algebra/strap/UFD-.lsp b/src/algebra/strap/UFD-.lsp new file mode 100644 index 00000000..eb1afd12 --- /dev/null +++ b/src/algebra/strap/UFD-.lsp @@ -0,0 +1,83 @@ + +(/VERSIONCHECK 2) + +(DEFUN |UFD-;squareFreePart;2S;1| (|x| $) + (PROG (|s| |f| #0=#:G1403 #1=#:G1401 #2=#:G1399 #3=#:G1400) + (RETURN + (SEQ (SPADCALL + (SPADCALL + (LETT |s| (SPADCALL |x| (|getShellEntry| $ 8)) + |UFD-;squareFreePart;2S;1|) + (|getShellEntry| $ 10)) + (PROGN + (LETT #3# NIL |UFD-;squareFreePart;2S;1|) + (SEQ (LETT |f| NIL |UFD-;squareFreePart;2S;1|) + (LETT #0# (SPADCALL |s| (|getShellEntry| $ 14)) + |UFD-;squareFreePart;2S;1|) + G190 + (COND + ((OR (ATOM #0#) + (PROGN + (LETT |f| (CAR #0#) + |UFD-;squareFreePart;2S;1|) + NIL)) + (GO G191))) + (SEQ (EXIT (PROGN + (LETT #1# (QCAR |f|) + |UFD-;squareFreePart;2S;1|) + (COND + (#3# + (LETT #2# + (SPADCALL #2# #1# + (|getShellEntry| $ 15)) + |UFD-;squareFreePart;2S;1|)) + ('T + (PROGN + (LETT #2# #1# + |UFD-;squareFreePart;2S;1|) + (LETT #3# 'T + |UFD-;squareFreePart;2S;1|))))))) + (LETT #0# (CDR #0#) |UFD-;squareFreePart;2S;1|) + (GO G190) G191 (EXIT NIL)) + (COND (#3# #2#) ('T (|spadConstant| $ 16)))) + (|getShellEntry| $ 15)))))) + +(DEFUN |UFD-;prime?;SB;2| (|x| $) + (EQL (LENGTH (SPADCALL (SPADCALL |x| (|getShellEntry| $ 18)) + (|getShellEntry| $ 22))) + 1)) + +(DEFUN |UniqueFactorizationDomain&| (|#1|) + (PROG (|dv$1| |dv$| $ |pv$|) + (RETURN + (PROGN + (LETT |dv$1| (|devaluate| |#1|) + . #0=(|UniqueFactorizationDomain&|)) + (LETT |dv$| (LIST '|UniqueFactorizationDomain&| |dv$1|) . #0#) + (LETT $ (|newShell| 25) . #0#) + (|setShellEntry| $ 0 |dv$|) + (|setShellEntry| $ 3 + (LETT |pv$| (|buildPredVector| 0 0 NIL) . #0#)) + (|stuffDomainSlots| $) + (|setShellEntry| $ 6 |#1|) + $)))) + +(MAKEPROP '|UniqueFactorizationDomain&| '|infovec| + (LIST '#(NIL NIL NIL NIL NIL NIL (|local| |#1|) (|Factored| $) + (0 . |squareFree|) (|Factored| 6) (5 . |unit|) (|Integer|) + (|Record| (|:| |factor| 6) (|:| |exponent| 11)) + (|List| 12) (10 . |factors|) (15 . *) (21 . |One|) + |UFD-;squareFreePart;2S;1| (25 . |factor|) + (|Union| '"nil" '"sqfr" '"irred" '"prime") + (|Record| (|:| |flg| 19) (|:| |fctr| 6) (|:| |xpnt| 11)) + (|List| 20) (30 . |factorList|) (|Boolean|) + |UFD-;prime?;SB;2|) + '#(|squareFreePart| 35 |prime?| 40) 'NIL + (CONS (|makeByteWordVec2| 1 'NIL) + (CONS '#() + (CONS '#() + (|makeByteWordVec2| 24 + '(1 6 7 0 8 1 9 6 0 10 1 9 13 0 14 2 6 + 0 0 0 15 0 6 0 16 1 6 7 0 18 1 9 21 0 + 22 1 0 0 0 17 1 0 23 0 24))))) + '|lookupComplete|)) |