From 05a386f8ae447f807fce60dc10056bde10b05fa8 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Sun, 10 Jan 2016 18:32:20 -0500 Subject: [PATCH] Added Emacs mode line. --- src/chain-complexes.lisp | 4 +- src/chcm-elementary-op.lisp | 378 ++++++++++---------- src/classes.lisp | 4 +- src/combinations.lisp | 690 ++++++++++++++++++------------------ src/macros.lisp | 48 +-- src/various.lisp | 52 +-- 6 files changed, 594 insertions(+), 582 deletions(-) diff --git a/src/chain-complexes.lisp b/src/chain-complexes.lisp index c6efb70..cbb4317 100644 --- a/src/chain-complexes.lisp +++ b/src/chain-complexes.lisp @@ -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*) diff --git a/src/chcm-elementary-op.lisp b/src/chcm-elementary-op.lisp index 6b4aeb8..83bb8d1 100644 --- a/src/chcm-elementary-op.lisp +++ b/src/chcm-elementary-op.lisp @@ -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)))))) diff --git a/src/classes.lisp b/src/classes.lisp index 41b2cbe..45d7390 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -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. ------------------------------------------------------------------------------" diff --git a/src/combinations.lisp b/src/combinations.lisp index 5665d20..d3b09f2 100644 --- a/src/combinations.lisp +++ b/src/combinations.lisp @@ -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))) diff --git a/src/macros.lisp b/src/macros.lisp index 0fefbb2..c9af69a 100644 --- a/src/macros.lisp +++ b/src/macros.lisp @@ -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)) diff --git a/src/various.lisp b/src/various.lisp index 2df1452..81a67b8 100644 --- a/src/various.lisp +++ b/src/various.lisp @@ -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) (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) (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)) #|