mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added Emacs mode line.

Browse Source
This commit is contained in:
Gerd Heber 2016-01-10 18:32:20 -05:00
parent 04ec4331a4
commit 05a386f8ae
6 changed files with 594 additions and 582 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/chain-complexes.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
@ -513,7 +515,7 @@ MAKE-INSTANCE.
(error "In the combination located by *WRONG-CMBN*, the generators:~@
~A and ~A are in a wrong order." (cdar mark2)
(cdar mark1))))))
cmbn)
cmbn)
#|
(DEFVAR *PROFILER-STACK*)

378
src/chcm-elementary-op.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
@ -14,41 +16,41 @@ Build the unit chain complex.
------------------------------------------------------------------------------"
(the chain-complex
(build-chcm
:cmpr #'(lambda (gnrt1 gnrt2)
(declare (ignore gnrt1 gnrt2))
(the cmpr :equal))
:basis #'(lambda (n)
(declare (type fixnum n))
(the list
:cmpr #'(lambda (gnrt1 gnrt2)
(declare (ignore gnrt1 gnrt2))
(the cmpr :equal))
:basis #'(lambda (n)
(declare (type fixnum n))
(the list
(if (zerop n)
(list :Z-gnrt)
+empty-list+)))
:bsgn :Z-gnrt
:intr-dffr #'zero-intr-dffr
:strt :cmbn
:orgn '(Z-chcm))))
(list :Z-gnrt)
+empty-list+)))
:bsgn :Z-gnrt
:intr-dffr #'zero-intr-dffr
:strt :cmbn
:orgn '(Z-chcm))))
(DEFUN ZERO-MRPH (chcm1 &optional (chcm2 chcm1) (degr 0))
(declare (type chain-complex chcm1 chcm2)
(type fixnum degr))
(type fixnum degr))
(the morphism
(build-mrph
:sorc chcm1 :trgt chcm2 :degr degr
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(zero-cmbn (+ (cmbn-degr cmbn) degr)))
:strt :cmbn
:orgn `(zero-mrph ,chcm1 ,chcm2 ,degr))))
:sorc chcm1 :trgt chcm2 :degr degr
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(zero-cmbn (+ (cmbn-degr cmbn) degr)))
:strt :cmbn
:orgn `(zero-mrph ,chcm1 ,chcm2 ,degr))))
(DEFUN IDNT-MRPH (chcm)
(declare (type chain-complex chcm))
(the morphism
(build-mrph
:sorc chcm :trgt chcm :degr 0
:intr #'identity
:strt :cmbn
:orgn `(idnt-mrph ,chcm))))
:sorc chcm :trgt chcm :degr 0
:intr #'identity
:strt :cmbn
:orgn `(idnt-mrph ,chcm))))
(DEFUN OPPS (mrph)
@ -56,17 +58,17 @@ Build the unit chain complex.
(the morphism
(with-slots (sorc trgt degr) mrph
(build-mrph
:sorc sorc :trgt trgt :degr degr
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(cmbn-opps (cmbn-? mrph cmbn)))
:strt :cmbn
:orgn `(opps ,mrph)))))
:sorc sorc :trgt trgt :degr degr
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(cmbn-opps (cmbn-? mrph cmbn)))
:strt :cmbn
:orgn `(opps ,mrph)))))
(DEFGENERIC CMPS (chcm-or-mrph1 chcm-or-mrph2 &optional strt)
(:documentation
"---------------------------------------------------------------[generic-doc]
"---------------------------------------------------------------[generic-doc]
CMPS
Args: (arg1 arg2 &optional opt)
A generic function whose specializations implement the composition
@ -94,47 +96,47 @@ composition of two morphisms, where the optional argument is a strategy.
(the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2)
(fixnum degr2)
(type strt strt2))
(unless (eq (grmd sorc1) (grmd trgt2))
(error "In 2MRPH-CMPS, the morphisms ~A and ~A may not be composed (cf source and target)."
mrph1 mrph2))
(unless strt
(setf strt (if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'zero-mrph)
(eq (first (orgn mrph2)) 'zero-mrph))
(return-from cmps
(unless (eq (grmd sorc1) (grmd trgt2))
(error "In 2MRPH-CMPS, the morphisms ~A and ~A may not be composed (cf source and target)."
mrph1 mrph2))
(unless strt
(setf strt (if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'zero-mrph)
(eq (first (orgn mrph2)) 'zero-mrph))
(return-from cmps
(zero-mrph sorc2 trgt1 (+ degr1 degr2))))
(when (eq (first (orgn mrph1)) 'idnt-mrph)
(return-from cmps mrph2))
(when (eq (first (orgn mrph2)) 'idnt-mrph)
(return-from cmps mrph1))
(ecase strt
(:cmbn (build-mrph
:sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(the cmbn
(when (eq (first (orgn mrph1)) 'idnt-mrph)
(return-from cmps mrph2))
(when (eq (first (orgn mrph2)) 'idnt-mrph)
(return-from cmps mrph1))
(ecase strt
(:cmbn (build-mrph
:sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(the cmbn
(cmbn-? mrph1 (cmbn-? mrph2 cmbn))))
:strt :cmbn :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt)))
(:gnrt (build-mrph
:sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
:intr #'(lambda (degr gnrt)
(declare
(type fixnum degr)
(type gnrt gnrt))
(the cmbn
:strt :cmbn :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt)))
(:gnrt (build-mrph
:sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
:intr #'(lambda (degr gnrt)
(declare
(type fixnum degr)
(type gnrt gnrt))
(the cmbn
(cmbn-? mrph1 (gnrt-? mrph2 degr gnrt))))
:strt :gnrt :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt))))))))
:strt :gnrt :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt))))))))
(DEFUN N-MRPH-INTR (n mrph)
@ -142,8 +144,8 @@ composition of two morphisms, where the optional argument is a strategy.
(fixnum n)
(type morphism mrph))
(flet ((rslt (cmbn)
(declare (type cmbn cmbn))
(n-cmbn n (cmbn-? mrph cmbn))))
(declare (type cmbn cmbn))
(n-cmbn n (cmbn-? mrph cmbn))))
(the intr-mrph #'rslt)))
(DEFUN N-MRPH (n mrph)
@ -152,13 +154,13 @@ composition of two morphisms, where the optional argument is a strategy.
(type morphism mrph))
(the morphism
(with-slots (sorc trgt degr) mrph
(declare
(type chain-complex sorc trgt)
(fixnum degr))
(build-mrph
:sorc sorc :trgt trgt :degr degr
:intr (n-mrph-intr n mrph) :strt :cmbn
:orgn `(n-mrph ,n ,mrph)))))
(declare
(type chain-complex sorc trgt)
(fixnum degr))
(build-mrph
:sorc sorc :trgt trgt :degr degr
:intr (n-mrph-intr n mrph) :strt :cmbn
:orgn `(n-mrph ,n ,mrph)))))
(DEFGENERIC ADD (chcm-or-mrph morphism &optional strt))
@ -167,52 +169,52 @@ composition of two morphisms, where the optional argument is a strategy.
(the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2)
(fixnum degr2)
(type strt strt2))
(unless (and (eq (grmd sorc1) (grmd sorc2))
(eq (grmd trgt1) (grmd trgt2))
(= degr1 degr2))
(error "In 2MRPH-ADD, ~A and ~A may not be added." mrph1 mrph2))
(when (eq (first (orgn mrph1)) 'zero-mrph)
(return-from add mrph2))
(when (eq (first (orgn mrph2)) 'zero-mrph)
(return-from add mrph1))
(unless strt
(setf strt
(if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'idnt-mrph)
(eq (first (orgn mrph2)) 'idnt-mrph))
(setf strt :cmbn))
(let ((cmpr (cmpr trgt1)))
(declare (type cmprf cmpr))
(ecase strt
(unless (and (eq (grmd sorc1) (grmd sorc2))
(eq (grmd trgt1) (grmd trgt2))
(= degr1 degr2))
(error "In 2MRPH-ADD, ~A and ~A may not be added." mrph1 mrph2))
(when (eq (first (orgn mrph1)) 'zero-mrph)
(return-from add mrph2))
(when (eq (first (orgn mrph2)) 'zero-mrph)
(return-from add mrph1))
(unless strt
(setf strt
(if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'idnt-mrph)
(eq (first (orgn mrph2)) 'idnt-mrph))
(setf strt :cmbn))
(let ((cmpr (cmpr trgt1)))
(declare (type cmprf cmpr))
(ecase strt
(:gnrt (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt))
(2cmbn-add cmpr
(gnrt-? mrph1 degr gnrt)
(gnrt-? mrph2 degr gnrt)))
:strt :gnrt
:orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt))
(2cmbn-add cmpr
(gnrt-? mrph1 degr gnrt)
(gnrt-? mrph2 degr gnrt)))
:strt :gnrt
:orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))
(:cmbn (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(2cmbn-add cmpr
(cmbn-? mrph1 cmbn)
(cmbn-? mrph2 cmbn)))
:strt :cmbn
:orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))))))))
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(2cmbn-add cmpr
(cmbn-? mrph1 cmbn)
(cmbn-? mrph2 cmbn)))
:strt :cmbn
:orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))))))))
(DEFGENERIC SBTR (chcm-or-mrph morphism &optional strt))
@ -221,53 +223,53 @@ composition of two morphisms, where the optional argument is a strategy.
(the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2)
(fixnum degr2)
(type strt strt2))
(unless (and (eq (grmd sorc1) (grmd sorc2))
(eq (grmd trgt1) (grmd trgt2))
(= degr1 degr2))
(error "In 2MRPH-SBTR, ~A and ~A may not be subtracteded."
mrph1 mrph2))
(when (eq (first (orgn mrph1)) 'zero-mrph)
(return-from sbtr mrph2))
(when (eq (first (orgn mrph2)) 'zero-mrph)
(return-from sbtr mrph1))
(unless strt
(setf strt
(if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'idnt-mrph)
(eq (first (orgn mrph2)) 'idnt-mrph))
(setf strt :cmbn))
(let ((cmpr (cmpr trgt1)))
(declare (type cmprf cmpr))
(ecase strt
(unless (and (eq (grmd sorc1) (grmd sorc2))
(eq (grmd trgt1) (grmd trgt2))
(= degr1 degr2))
(error "In 2MRPH-SBTR, ~A and ~A may not be subtracteded."
mrph1 mrph2))
(when (eq (first (orgn mrph1)) 'zero-mrph)
(return-from sbtr mrph2))
(when (eq (first (orgn mrph2)) 'zero-mrph)
(return-from sbtr mrph1))
(unless strt
(setf strt
(if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'idnt-mrph)
(eq (first (orgn mrph2)) 'idnt-mrph))
(setf strt :cmbn))
(let ((cmpr (cmpr trgt1)))
(declare (type cmprf cmpr))
(ecase strt
(:gnrt (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt))
(2cmbn-sbtr cmpr
(gnrt-? mrph1 degr gnrt)
(gnrt-? mrph2 degr gnrt)))
:strt :gnrt
:orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt))
(2cmbn-sbtr cmpr
(gnrt-? mrph1 degr gnrt)
(gnrt-? mrph2 degr gnrt)))
:strt :gnrt
:orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))
(:cmbn (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(2cmbn-sbtr cmpr
(cmbn-? mrph1 cmbn)
(cmbn-? mrph2 cmbn)))
:strt :cmbn
:orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))))))))
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(2cmbn-sbtr cmpr
(cmbn-? mrph1 cmbn)
(cmbn-? mrph2 cmbn)))
:strt :cmbn
:orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))))))))
(DEFUN CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
(declare
@ -276,12 +278,12 @@ composition of two morphisms, where the optional argument is a strategy.
(the morphism
(with-slots (sorc trgt degr intr strt) mrph
(build-mrph
:sorc (or new-sorc sorc)
:trgt (or new-trgt trgt)
:degr degr
:intr intr
:strt strt
:orgn `(change-sorc-trgt ,mrph ,new-sorc ,new-trgt)))))
:sorc (or new-sorc sorc)
:trgt (or new-trgt trgt)
:degr degr
:intr intr
:strt strt
:orgn `(change-sorc-trgt ,mrph ,new-sorc ,new-trgt)))))
(DEFUN DSTR-CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
(declare
@ -290,9 +292,9 @@ composition of two morphisms, where the optional argument is a strategy.
(the morphism
(with-slots (sorc trgt) mrph
(when new-sorc
(setf sorc new-sorc))
(setf sorc new-sorc))
(when new-trgt
(setf trgt new-trgt))
(setf trgt new-trgt))
mrph)))
(DEFMETHOD ADD ((chcm chain-complex) (perturbation morphism) &optional strt)
@ -300,28 +302,28 @@ composition of two morphisms, where the optional argument is a strategy.
(the chain-complex
(with-slots (cmpr basis bsgn dffr) chcm
(declare
(type cmprf cmpr)
(type basis basis)
(type morphism dffr))
(with-slots (sorc trgt degr) perturbation
(declare
(type cmprf cmpr)
(type basis basis)
(type morphism dffr))
(with-slots (sorc trgt degr) perturbation
(declare
(type chain-complex sorc trgt)
(fixnum degr))
(unless (and (eq (grmd sorc) (grmd chcm))
(eq (grmd trgt) (grmd chcm))
(= degr -1))
(error "In (METHOD ADD CHAIN-COMPLEX MORPHISM), the data are not coherent."))
(let ((new-dffr (add dffr perturbation strt)))
(declare (type morphism new-dffr))
(let ((new-chcm (build-chcm
:cmpr cmpr
:basis basis
:intr-dffr (intr new-dffr)
:strt (strt new-dffr)
:orgn `(add ,chcm ,perturbation))))
(declare (type chain-complex new-chcm))
(if (slot-boundp chcm 'bsgn)
(setf (slot-value new-chcm 'bsgn) bsgn)
(slot-makunbound new-chcm 'bsgn))
(setf (slot-value new-chcm 'grmd) (grmd chcm))
new-chcm))))))
(unless (and (eq (grmd sorc) (grmd chcm))
(eq (grmd trgt) (grmd chcm))
(= degr -1))
(error "In (METHOD ADD CHAIN-COMPLEX MORPHISM), the data are not coherent."))
(let ((new-dffr (add dffr perturbation strt)))
(declare (type morphism new-dffr))
(let ((new-chcm (build-chcm
:cmpr cmpr
:basis basis
:intr-dffr (intr new-dffr)
:strt (strt new-dffr)
:orgn `(add ,chcm ,perturbation))))
(declare (type chain-complex new-chcm))
(if (slot-boundp chcm 'bsgn)
(setf (slot-value new-chcm 'bsgn) bsgn)
(slot-makunbound new-chcm 'bsgn))
(setf (slot-value new-chcm 'grmd) (grmd chcm))
new-chcm))))))

4
src/classes.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES
@ -202,7 +204,7 @@ Intances of this class represent chain complexes. The class has 8 slots:
;; STRT = STRaTegy
(DEFTYPE STRT ()
"-----------------------------------------------------------------[type-doc]
"-----------------------------------------------------------------[type-doc]
STRT
A derived type, which represents the mapping strategy of morphisms.
------------------------------------------------------------------------------"

690
src/combinations.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS
@ -22,19 +24,19 @@ is ignored.
------------------------------------------------------------------------------"
(the cmbn
(with-cmbn (degr list) cmbn
(format stream "~%~70@{-~}{CMBN ~D}" degr)
(do ((mark list (cdr mark))
(nth 0 (1+ nth)))
((endp mark))
(declare
(list mark)
(fixnum nth))
(when (and *print-length* (= nth *print-length*))
(format stream "~%... ...")
(return))
(format stream "~%<~D * ~A>" (-cffc mark) (-gnrt mark)))
(format stream "~%~78@{-~}~%" t)
cmbn)))
(format stream "~%~70@{-~}{CMBN ~D}" degr)
(do ((mark list (cdr mark))
(nth 0 (1+ nth)))
((endp mark))
(declare
(list mark)
(fixnum nth))
(when (and *print-length* (= nth *print-length*))
(format stream "~%... ...")
(return))
(format stream "~%<~D * ~A>" (-cffc mark) (-gnrt mark)))
(format stream "~%~78@{-~}~%" t)
cmbn)))
(DEFUN MAPLEXICO (cmpr list1 list2)
@ -43,17 +45,17 @@ is ignored.
(list list1 list2))
(the boolean
(do ((mark1 list1 (cdr mark1))
(mark2 list2 (cdr mark2)))
(nil)
(mark2 list2 (cdr mark2)))
(nil)
(declare (list mark1 mark2))
(unless mark1
(return-from maplexico
(if mark2 :less :equal)))
(return-from maplexico
(if mark2 :less :equal)))
(unless mark2
(return-from maplexico :greater))
(return-from maplexico :greater))
(case (funcall cmpr (car mark1) (car mark2))
(:less (return-from maplexico :less))
(:greater (return-from maplexico :greater))))))
(:less (return-from maplexico :less))
(:greater (return-from maplexico :greater))))))
(DEFUN S-CMPR (symbol1 symbol2)
@ -67,12 +69,12 @@ comparison function of the strings (SYMBOL-NAME SYMBOL1) and
------------------------------------------------------------------------------"
(the cmpr
(if (#+aclpc acl:whole-string<
#-aclpc string< symbol1 symbol2)
:less
(if (#+aclpc acl:whole-string=
#-aclpc string= symbol1 symbol2)
:equal
:greater))))
#-aclpc string< symbol1 symbol2)
:less
(if (#+aclpc acl:whole-string=
#-aclpc string= symbol1 symbol2)
:equal
:greater))))
(DEFUN F-CMPR (n1 n2)
@ -85,10 +87,10 @@ comparison of the integers N1 and N2.
------------------------------------------------------------------------------"
(the cmpr
(if (< n1 n2)
:less
(if (= n1 n2)
:equal
:greater))))
:less
(if (= n1 n2)
:equal
:greater))))
(DEFUN L-CMPR (list1 list2)
@ -108,12 +110,12 @@ of the generator lists LIST1 and LIST2.
(lexico
(s-cmpr (first list1) (first list2))
(l-cmpr (rest list1) (rest list2)))
:greater)
:greater)
(if (symbolp (first list2))
:less
(lexico
(f-cmpr (first list1) (first list2))
(l-cmpr (rest list1) (rest list2))))))
:less
(lexico
(f-cmpr (first list1) (first list2))
(l-cmpr (rest list1) (rest list2))))))
;;;;
;;;; COMBINATIONS
@ -124,10 +126,10 @@ of the generator lists LIST1 and LIST2.
(declare (fixnum degr))
(the cmbn
(let ((rslt (list degr :cmbn)))
(do ((mark rest (cddr mark)))
((endp mark) (nreverse rslt))
(declare (list mark))
(push (term (car mark) (cadr mark)) rslt)))))
(do ((mark rest (cddr mark)))
((endp mark) (nreverse rslt))
(declare (list mark))
(push (term (car mark) (cadr mark)) rslt)))))
|#
(DEFUN CMBN (degr &rest rest)
@ -142,12 +144,12 @@ is an instance of the null combination of degree DEGR.
------------------------------------------------------------------------------"
(the cmbn
(make-cmbn :degr degr
:list (do ((rslt +empty-list+
(cons (term (car mark) (cadr mark))
rslt))
(mark rest (cddr mark)))
((endp mark) (nreverse rslt))
(declare (list rslt mark))))))
:list (do ((rslt +empty-list+
(cons (term (car mark) (cadr mark))
rslt))
(mark rest (cddr mark)))
((endp mark) (nreverse rslt))
(declare (list rslt mark))))))
(setf *print-pretty* nil)
@ -165,18 +167,18 @@ CHECK-CMBN raises an error if the generators of CMBN are out-of-order.
------------------------------------------------------------------------------"
(the boolean
(do ((cmpr (cmpr chcm))
(mark2 (cmbn-list cmbn) mark1)
(mark1 (rest (cmbn-list cmbn)) (cdr mark1)))
((endp mark1) t)
(declare
(type cmprf cmpr)
(list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(error "In CHECK-CMBN, bad order; the generator:~@
(mark2 (cmbn-list cmbn) mark1)
(mark1 (rest (cmbn-list cmbn)) (cdr mark1)))
((endp mark1) t)
(declare
(type cmprf cmpr)
(list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(error "In CHECK-CMBN, bad order; the generator:~@
~A~@
is not less than the generator:~@
~A."
(-gnrt mark2) (-gnrt mark1))))))
(-gnrt mark2) (-gnrt mark1))))))
(DEFUN ZERO-CMBN (degr)
@ -188,8 +190,8 @@ Returns an instance of the null combination of degree DEGR.
------------------------------------------------------------------------------"
(the cmbn
(make-cmbn
:degr degr
:list +empty-list+)))
:degr degr
:list +empty-list+)))
(DEFINE-CONSTANT +ZERO-NEGATIVE-CMBN+
@ -220,14 +222,14 @@ Returns the combination opposite combination of CMBN.
------------------------------------------------------------------------------"
(the cmbn
(with-cmbn (degr list) cmbn
(make-cmbn
:degr degr
:list (mapcar #'(lambda (term)
(declare (type term term))
(with-term
(cffc gnrt) term
(term (- cffc) gnrt)))
list)))))
(make-cmbn
:degr degr
:list (mapcar #'(lambda (term)
(declare (type term term))
(with-term
(cffc gnrt) term
(term (- cffc) gnrt)))
list)))))
(DEFUN N-CMBN (n cmbn)
@ -242,16 +244,16 @@ Returns N times the combination CMBN. N must be non-zero.
------------------------------------------------------------------------------"
(the cmbn
(if (= n 1)
cmbn
(with-cmbn (degr list) cmbn
(make-cmbn
:degr degr
:list (mapcar #'(lambda (term)
(declare (type term term))
(with-term
(cffc gnrt) term
(term (* n cffc) gnrt)))
list))))))
cmbn
(with-cmbn (degr list) cmbn
(make-cmbn
:degr degr
:list (mapcar #'(lambda (term)
(declare (type term term))
(with-term
(cffc gnrt) term
(term (* n cffc) gnrt)))
list))))))
(DEFUN 2CMBN-ADD (cmpr cmbn1 cmbn2)
@ -268,62 +270,62 @@ combination.
------------------------------------------------------------------------------"
(the cmbn
(with-cmbn
(degr1 list1) cmbn1
(with-cmbn
(degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In ADD, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2cmbn-add cmbn2))
(unless list2
(return-from 2cmbn-add cmbn1))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term
(cffc1 gnrt1) mark1
(with--term
(cffc2 gnrt2) mark2
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (+ cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1)
cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (-term mark1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (-term mark2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt (nreconc pre-rslt mark2))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt (nreconc pre-rslt mark1))
:exit))
(make-cmbn :degr degr1 :list pre-rslt)))))))
(degr1 list1) cmbn1
(with-cmbn
(degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In ADD, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2cmbn-add cmbn2))
(unless list2
(return-from 2cmbn-add cmbn1))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term
(cffc1 gnrt1) mark1
(with--term
(cffc2 gnrt2) mark2
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (+ cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1)
cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (-term mark1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (-term mark2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt (nreconc pre-rslt mark2))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt (nreconc pre-rslt mark1))
:exit))
(make-cmbn :degr degr1 :list pre-rslt)))))))
(DEFUN 2CMBN-SBTR (cmpr cmbn1 cmbn2)
@ -340,73 +342,73 @@ combination.
------------------------------------------------------------------------------"
(the cmbn
(with-cmbn
(degr1 list1) cmbn1
(with-cmbn
(degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In SBTR, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2cmbn-sbtr (cmbn-opps cmbn2)))
(unless list2
(return-from 2cmbn-sbtr cmbn1))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term
(cffc1 gnrt1) mark1
(with--term
(cffc2 gnrt2) mark2
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (- cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(unless mark1 (go :cmbn1-is-finished))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1)
cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (-term mark1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (term (- cffc2) gnrt2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt
(nreconc pre-rslt
(mapcar #'(lambda (term)
(declare (cons term))
(with-term
(cffc gnrt) term
(term (- cffc)
gnrt)))
mark2)))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt (nreconc pre-rslt mark1))
:exit))
(make-cmbn
:degr degr1
:list pre-rslt)))))))
(degr1 list1) cmbn1
(with-cmbn
(degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In SBTR, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2cmbn-sbtr (cmbn-opps cmbn2)))
(unless list2
(return-from 2cmbn-sbtr cmbn1))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term
(cffc1 gnrt1) mark1
(with--term
(cffc2 gnrt2) mark2
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (- cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(unless mark1 (go :cmbn1-is-finished))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1)
cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (-term mark1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (term (- cffc2) gnrt2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt
(nreconc pre-rslt
(mapcar #'(lambda (term)
(declare (cons term))
(with-term
(cffc gnrt) term
(term (- cffc)
gnrt)))
mark2)))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt (nreconc pre-rslt mark1))
:exit))
(make-cmbn
:degr degr1
:list pre-rslt)))))))
(DEFUN 2N-2CMBN (cmpr n1 cmbn1 n2 cmbn2)
@ -426,86 +428,86 @@ the result combination.
------------------------------------------------------------------------------"
(the cmbn
(with-cmbn
(degr1 list1) cmbn1
(with-cmbn
(degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In 2N-2CMBN, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2n-2cmbn (n-cmbn n2 cmbn2)))
(unless list2
(return-from 2n-2cmbn (n-cmbn n1 cmbn1)))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term
(cffc1 gnrt1) mark1
(with--term
(cffc2 gnrt2) mark2
(setf cffc1 (* n1 cffc1)
cffc2 (* n2 cffc2))
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (+ cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (* n1 (-cffc mark1))
gnrt1 (-gnrt mark1)
cffc2 (* n2 (-cffc mark2))
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (term cffc1 gnrt1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (* n1 (-cffc mark1))
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (term cffc2 gnrt2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (* n2 (-cffc mark2))
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt
(nreconc pre-rslt
(if (= 1 n2)
mark2
(mapcar #'(lambda (term)
(declare (cons term))
(with-term
(cffc gnrt) term
(term (* n2 cffc)
gnrt)))
mark2))))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt
(nreconc pre-rslt
(if (= 1 n1)
mark1
(mapcar #'(lambda (term)
(declare (cons term))
(with-term
(cffc gnrt) term
(term (* n1 cffc)
gnrt)))
mark1))))
:exit))
(make-cmbn
:degr degr1
:list pre-rslt)))))))
(degr1 list1) cmbn1
(with-cmbn
(degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In 2N-2CMBN, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2n-2cmbn (n-cmbn n2 cmbn2)))
(unless list2
(return-from 2n-2cmbn (n-cmbn n1 cmbn1)))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term
(cffc1 gnrt1) mark1
(with--term
(cffc2 gnrt2) mark2
(setf cffc1 (* n1 cffc1)
cffc2 (* n2 cffc2))
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (+ cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (* n1 (-cffc mark1))
gnrt1 (-gnrt mark1)
cffc2 (* n2 (-cffc mark2))
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (term cffc1 gnrt1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (* n1 (-cffc mark1))
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (term cffc2 gnrt2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (* n2 (-cffc mark2))
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt
(nreconc pre-rslt
(if (= 1 n2)
mark2
(mapcar #'(lambda (term)
(declare (cons term))
(with-term
(cffc gnrt) term
(term (* n2 cffc)
gnrt)))
mark2))))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt
(nreconc pre-rslt
(if (= 1 n1)
mark1
(mapcar #'(lambda (term)
(declare (cons term))
(with-term
(cffc gnrt) term
(term (* n1 cffc)
gnrt)))
mark1))))
:exit))
(make-cmbn
:degr degr1
:list pre-rslt)))))))
(DEFUN CMBN-CMBN (cmpr n-cmbn-list)
@ -531,38 +533,38 @@ combination.
(unless (cddr n-cmbn-list)
(return-from cmbn-cmbn
(2n-2cmbn cmpr
(caar n-cmbn-list) (cdar n-cmbn-list)
(caadr n-cmbn-list) (cdadr n-cmbn-list))))
(caar n-cmbn-list) (cdar n-cmbn-list)
(caadr n-cmbn-list) (cdadr n-cmbn-list))))
(the cmbn
(let ((new-rslt +empty-list+))
(declare (list new-rslt))
(do ((mark1 (rest n-cmbn-list) (cddr mark1))
(mark2 n-cmbn-list (cdr mark1)))
((endp mark2))
(declare (list mark1 mark2))
(when (endp mark1)
(push (n-cmbn (caar mark2) (cdar mark2)) new-rslt)
(return))
(push (2n-2cmbn cmpr
(caar mark2) (cdar mark2)
(caar mark1) (cdar mark1))
new-rslt))
(let ((old-rslt +empty-list+))
(declare (list old-rslt))
(loop
(unless (rest new-rslt)
(return-from cmbn-cmbn (first new-rslt)))
(setf old-rslt new-rslt
new-rslt +empty-list+)
(do ((mark1 (rest old-rslt) (cddr mark1))
(mark2 old-rslt (cdr mark1)))
((endp mark2))
(declare (list mark1 mark2))
(when (endp mark1)
(push (car mark2) new-rslt)
(return))
(push (2cmbn-add cmpr (car mark2) (car mark1))
new-rslt)))))))
(declare (list new-rslt))
(do ((mark1 (rest n-cmbn-list) (cddr mark1))
(mark2 n-cmbn-list (cdr mark1)))
((endp mark2))
(declare (list mark1 mark2))
(when (endp mark1)
(push (n-cmbn (caar mark2) (cdar mark2)) new-rslt)
(return))
(push (2n-2cmbn cmpr
(caar mark2) (cdar mark2)
(caar mark1) (cdar mark1))
new-rslt))
(let ((old-rslt +empty-list+))
(declare (list old-rslt))
(loop
(unless (rest new-rslt)
(return-from cmbn-cmbn (first new-rslt)))
(setf old-rslt new-rslt
new-rslt +empty-list+)
(do ((mark1 (rest old-rslt) (cddr mark1))
(mark2 old-rslt (cdr mark1)))
((endp mark2))
(declare (list mark1 mark2))
(when (endp mark1)
(push (car mark2) new-rslt)
(return))
(push (2cmbn-add cmpr (car mark2) (car mark1))
new-rslt)))))))
(DEFUN NTERM-ADD (cmpr degr &rest rest)
@ -586,24 +588,24 @@ is returned.
(let ((rslt (list (first rest))))
(declare (list rslt))
(dolist (term (rest rest))
(declare (type term term))
(with-term (cffc gnrt) term
(do ((mark1 rslt (cdr mark1))
(mark2 nil mark1))
((endp mark1) (setf (cdr mark2) (list term)))
(ecase (funcall cmpr gnrt (-gnrt mark1))
(:less
(if mark2
(push term (cdr mark2))
(push term rslt))
(return))
(:equal
(incf (-cffc mark1) cffc)
(return))
(:greater )))))
(declare (type term term))
(with-term (cffc gnrt) term
(do ((mark1 rslt (cdr mark1))
(mark2 nil mark1))
((endp mark1) (setf (cdr mark2) (list term)))
(ecase (funcall cmpr gnrt (-gnrt mark1))
(:less
(if mark2
(push term (cdr mark2))
(push term rslt))
(return))
(:equal
(incf (-cffc mark1) cffc)
(return))
(:greater )))))
(make-cmbn
:degr degr
:list (delete 0 rslt :key #'car)))))
:degr degr
:list (delete 0 rslt :key #'car)))))
(DEFUN NCMBN-ADD (cmpr cmbn &rest rest)
@ -621,7 +623,7 @@ the input combinations and to order the terms of the result combination.
(cmbn-cmbn cmpr (mapcar #'(lambda (cmbn)
(declare (type cmbn cmbn))
(cons 1 cmbn))
(cons cmbn rest)))))
(cons cmbn rest)))))
(DEFUN DSTR-ADD-TERM-TO-CMBN (cmpr cffc gnrt cmbn)
@ -642,26 +644,26 @@ result combination.
(let ((list (cmbn-list cmbn)))
(declare (list list))
(unless list
(push (term cffc gnrt) (cmbn-list cmbn))
(return-from dstr-add-term-to-cmbn cmbn))
(push (term cffc gnrt) (cmbn-list cmbn))
(return-from dstr-add-term-to-cmbn cmbn))
(do ((mark2 nil mark1)
(mark1 list (cdr mark1)))
((endp mark1) (setf (cdr mark2) (list (term cffc gnrt))))
(declare (list mark1 mark2))
(ecase (funcall cmpr gnrt (-gnrt mark1))
(:less
(if mark2
(push (term cffc gnrt) (cdr mark2))
(push (term cffc gnrt) (cmbn-list cmbn)))
(return))
(:equal
(let ((new-cffc (+ cffc (-cffc mark1))))
(declare (fixnum new-cffc))
(if (zerop new-cffc)
(if mark2
(pop (cdr mark2))
(pop (cmbn-list cmbn)))
(setf (-cffc mark1) new-cffc))
(return)))
(:greater)))
(declare (list mark1 mark2))
(ecase (funcall cmpr gnrt (-gnrt mark1))
(:less
(if mark2
(push (term cffc gnrt) (cdr mark2))
(push (term cffc gnrt) (cmbn-list cmbn)))
(return))
(:equal
(let ((new-cffc (+ cffc (-cffc mark1))))
(declare (fixnum new-cffc))
(if (zerop new-cffc)
(if mark2
(pop (cdr mark2))
(pop (cmbn-list cmbn)))
(setf (-cffc mark1) new-cffc))
(return)))
(:greater)))
cmbn)))

48
src/macros.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS
@ -63,8 +65,8 @@ and returns VALUE.
`(let ((,vrslt ,(first rest)))
(declare (type cmpr ,vrslt))
(if (eq ,vrslt :equal)
(lexico ,@(rest rest))
,vrslt))))
(lexico ,@(rest rest))
,vrslt))))
(DEFMACRO TERM (cffc gnrt)
@ -103,7 +105,7 @@ Returns the the generator of a term.
(DEFMACRO WITH-TERM ((cffc gnrt) term . body)
`(let (,@(if cffc `((,cffc (cffc ,term))) nil)
,@(if gnrt `((,gnrt (gnrt ,term))) nil))
,@(if gnrt `((,gnrt (gnrt ,term))) nil))
(declare
(fixnum ,@(if cffc `(,cffc) nil))
(type gnrt ,@(if gnrt `(,gnrt) nil)))
@ -112,7 +114,7 @@ Returns the the generator of a term.
(DEFMACRO WITH--TERM ((cffc gnrt) mark . body)
`(let ((,cffc (-cffc ,mark))
(,gnrt (-gnrt ,mark)))
(,gnrt (-gnrt ,mark)))
(declare
(fixnum ,cffc)
(type gnrt ,gnrt))
@ -121,7 +123,7 @@ Returns the the generator of a term.
(DEFMACRO WITH-CMBN ((degr list) cmbn . body)
`(let ((,degr (cmbn-degr ,cmbn))
(,list (cmbn-list ,cmbn)))
(,list (cmbn-list ,cmbn)))
(declare
(fixnum ,degr)
(list ,list))
@ -459,7 +461,7 @@ the chain complex D."
(DEFMACRO WITH-BICN ((bcnx ibicn) bicn . body)
`(let ((,bcnx (bcnx ,bicn))
(,ibicn (ibicn ,bicn)))
(,ibicn (ibicn ,bicn)))
(declare
(type (member :bcnb :bcnc :bcnd) ,bcnx)
(type gnrt ,ibicn))
@ -492,9 +494,9 @@ the chain complex D."
(DEFMACRO WITH-TNPR ((degr1 gnrt1 degr2 gnrt2) tnpr . body)
`(let (,@(if degr1 `((,degr1 (degr1 ,tnpr))) nil)
,@(if gnrt1 `((,gnrt1 (gnrt1 ,tnpr))) nil)
,@(if degr2 `((,degr2 (degr2 ,tnpr))) nil)
,@(if gnrt2 `((,gnrt2 (gnrt2 ,tnpr))) nil))
,@(if gnrt1 `((,gnrt1 (gnrt1 ,tnpr))) nil)
,@(if degr2 `((,degr2 (degr2 ,tnpr))) nil)
,@(if gnrt2 `((,gnrt2 (gnrt2 ,tnpr))) nil))
(declare
(fixnum ,@(if degr1 `(,degr1) nil) ,@(if degr2 `(,degr2) nil))
(type gnrt ,@(if gnrt1 `(,gnrt1) nil) ,@(if gnrt2 `(,gnrt2) nil)))
@ -535,7 +537,7 @@ the chain complex D."
(DEFMACRO WITH-CBGN ((cdegr cgnrt) cbgn . body)
`(let ((,cdegr (cdegr ,cbgn))
(,cgnrt (cgnrt ,cbgn)))
(,cgnrt (cgnrt ,cbgn)))
(declare
(fixnum ,cdegr)
(type gnrt ,cgnrt))
@ -544,7 +546,7 @@ the chain complex D."
(DEFMACRO WITH--CBGN ((cdegr cgnrt) cbgn . body)
`(let ((,cdegr (-cdegr ,cbgn))
(,cgnrt (-cgnrt ,cbgn)))
(,cgnrt (-cgnrt ,cbgn)))
(declare
(fixnum ,cdegr)
(type gnrt ,cgnrt))
@ -596,7 +598,7 @@ the chain complex D."
(DEFMACRO WITH-BRGN ((bdegr bgnrt) brgn . body)
`(let ((,bdegr (bdegr ,brgn))
(,bgnrt (bgnrt ,brgn)))
(,bgnrt (bgnrt ,brgn)))
(declare
(fixnum ,bdegr)
(type gnrt ,bgnrt))
@ -605,7 +607,7 @@ the chain complex D."
(DEFMACRO WITH--BRGN ((bdegr bgnrt) brgn . body)
`(let ((,bdegr (-bdegr ,brgn))
(,bgnrt (-bgnrt ,brgn)))
(,bgnrt (-bgnrt ,brgn)))
(declare
(fixnum ,bdegr)
(type gnrt ,bgnrt))
@ -681,7 +683,7 @@ the chain complex D."
(declare
(fixnum ,dgop-var)
(type gmsm ,gmsm-var))
,@body))))
,@body))))
(DEFMACRO DEGENERATE-P (absm)
@ -751,8 +753,8 @@ the chain complex D."
(ecase (length rest)
(2 `(cons :crpr (cons (cdr ,(first rest)) (cdr ,(second rest)))))
(4 `(cons :crpr (cons
(cons ,(first rest) ,(second rest))
(cons ,(third rest) ,(fourth rest)))))))
(cons ,(first rest) ,(second rest))
(cons ,(third rest) ,(fourth rest)))))))
|#
(DEFMACRO CRPR (&rest rest)
(ecase (length rest)
@ -805,7 +807,7 @@ the chain complex D."
#|
(DEFMACRO WITH-CRPR-2 ((absm1 absm2) crpr . body)
`(let ((,absm1 (cons :absm (cadr ,crpr)))
(,absm2 (cons :absm (cddr ,crpr))))
(,absm2 (cons :absm (cddr ,crpr))))
(declare (type absm ,absm1 ,absm2))
,@body))
|#
@ -819,9 +821,9 @@ the chain complex D."
(DEFMACRO WITH-CRPR-4 ((dgop1 gmsm1 dgop2 gmsm2) crpr . body)
`(let ((,dgop1 (dgop1 ,crpr))
(,gmsm1 (gmsm1 ,crpr))
(,dgop2 (dgop2 ,crpr))
(,gmsm2 (gmsm2 ,crpr)))
(,gmsm1 (gmsm1 ,crpr))
(,dgop2 (dgop2 ,crpr))
(,gmsm2 (gmsm2 ,crpr)))
(declare
(fixnum ,dgop1 ,dgop2)
(type gmsm ,gmsm1 ,gmsm2))
@ -884,7 +886,7 @@ the chain complex D."
(DEFMACRO WITH-POWR ((gmsm expn) powr . body)
`(let ((,gmsm (car ,powr))
(,expn (cdr ,powr)))
(,expn (cdr ,powr)))
(declare
(type gmsm ,gmsm)
(fixnum expn))
@ -893,8 +895,8 @@ the chain complex D."
(DEFMACRO WITH-APOWR ((dgop gmsm expn) apowr . body)
`(let ((,dgop (apdgop ,apowr))
(,gmsm (cadr ,apowr))
(,expn (cddr ,apowr)))
(,gmsm (cadr ,apowr))
(,expn (cddr ,apowr)))
(declare
(fixnum ,dgop ,expn)
(type gmsm ,gmsm))

52
src/various.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS
@ -13,10 +15,10 @@
(setf p (- n p)))
(the fixnum
(do ((nn n (1- nn))
(pp 1 (1+ pp))
(rslt 1 (/ (* rslt nn) pp)))
((> pp p) rslt)
(declare (fixnum nn pp rslt)))))
(pp 1 (1+ pp))
(rslt 1 (/ (* rslt nn) pp)))
((> pp p) rslt)
(declare (fixnum nn pp rslt)))))
(SETF *PRINT-LEVEL* 5
@ -26,46 +28,46 @@
(declare (fixnum a b))
(the list
(do ((i (1- b) (1- i))
(rslt +empty-list+ (cons i rslt)))
((< i a) rslt)
(rslt +empty-list+ (cons i rslt)))
((< i a) rslt)
(declare (fixnum i) (list rslt)))))
(DEFUN <A-B> (a b)
(declare (fixnum a b))
(the list
(do ((i b (1- i))
(rslt +empty-list+ (cons i rslt)))
((< i a) rslt)
(declare (fixnum i) (list rslt)))))
(rslt +empty-list+ (cons i rslt)))
((< i a) rslt)
(declare (fixnum i) (list rslt)))))
(DEFUN >A-B< (a b)
(declare (fixnum a b))
(the list
(do ((i (1- b) (1- i))
(rslt +empty-list+ (cons i rslt)))
((= i a) rslt)
(declare (fixnum i) (list rslt)))))
(rslt +empty-list+ (cons i rslt)))
((= i a) rslt)
(declare (fixnum i) (list rslt)))))
(DEFUN >A-B> (a b)
(declare (fixnum a b))
(the list
(do ((i b (1- i))
(rslt +empty-list+ (cons i rslt)))
((= i a) rslt)
(declare (fixnum i) (list rslt)))))
(rslt +empty-list+ (cons i rslt)))
((= i a) rslt)
(declare (fixnum i) (list rslt)))))
(DEFUN V<A-B> (a b)
(declare (fixnum a b))
(the (vector fixnum)
(let ((rslt (make-array (1+ (- b a)) :element-type 'fixnum)))
(declare (type (vector fixnum) rslt))
(do ((i a (1+ i))
(mark 0 (1+ mark)))
((> i b))
(declare (fixnum i mark))
(setf (aref rslt mark) i))
rslt)))
(declare (type (vector fixnum) rslt))
(do ((i a (1+ i))
(mark 0 (1+ mark)))
((> i b))
(declare (fixnum i mark))
(setf (aref rslt mark) i))
rslt)))
(DEFUN SRANDOM (max)
@ -74,15 +76,15 @@
(let ((rslt (- (random (+ max max)) max)))
(declare (fixnum rslt))
(if (zerop rslt)
max
rslt))))
max
rslt))))
(DEFUN CLOCK ()
(multiple-value-bind (sec min hour day month year)
(get-decoded-time)
(format t "~%;; Clock -> ~4D-~2,'0D-~2,'0D, ~Dh ~Dm ~Ds.~%"
year month day hour min sec))
year month day hour min sec))
(values))
#|