share/sym/pui.lisp

   1 ; Fichier pui.lsp
   2
   3 ;       ***************************************************************
   4 ;       *                    MODULE SYM                               *
   5 ;       *       MANIPULATIONS DE FONCTIONS SYMETRIQUES                *
   6 ;       *        (version01: Commonlisp pour Maxima)                 *
   7 ;       *                                                             *
   8 ;       *                ----------------------                       *
   9 ;       *                  Annick VALIBOUZE                           *
  10 ;       *                    GDR MEDICIS                              *
  11 ;       *  (Mathe'matiques Effectives, De'veloppements Informatiques, *
  12 ;       *           Calculs et Ingenierie, Syste`mes)                 *
  13 ;       *             LITP (Equipe Calcul Formel)                     *
  14 ;       *                 Universite' Paris 6,                        *
  15 ;       *        4 place Jussieu, 75252 Paris cedex 05.               *
  16 ;       *              e-mail : avb@sysal.ibp.fr                      *
  17 ;       ***************************************************************
  18
  19 ;==========================================================================
  20 ;                      PASSAGE DES FONCTIONS PUISSANCES
  21 ;                           AUX FORMES MONOMIALES
  22 ; appel avec pui([card,p1,...,pn],sym(x,y,..,z),[x,y,...,z])
  23 ;==========================================================================
  24 ;                     INTERFACE
  25
  26 (in-package :maxima)
  27 (macsyma-module pui macros)
  28
  29 (mdefprop $pui
  30     ((lambda ()) ((mlist) $valpi $sym $lvar)
  31      ((mprog) (($operation)) (($pui_init) $valpi $sym $lvar)))
  32     mexpr)
  33 ;; IT APPEARS ARGS WAS A MACRO. THERE IS NO ARGS MACRO AT PRESENT.
  34 ;; DUNNO IF THE ABSENCE OF ARGS CAUSES ANY INCORRECT BEHAVIOR IN SYM
  35 ;; (args $pui '(3 . 3))
  36 (add2lnc '(($pui) $valpi $sym $lvar) $functions)
  37 (mdefprop $multi_pui
  38     ((lambda ()) ((mlist) $lvalpi $pc $llvar)
  39      ((mprog) (($operation)) (($multi_pui_init) $lvalpi $pc $llvar)))
  40     mexpr)
  41 (add2lnc '(($multi_pui) $lvalpi $pc $llvar) $functions)
  42
  43 ; fonction bidon de chargement pour eviter de construire pour detruire
  44 ; lorsque l'on appelle une fonction de npui a partir d'un autre
  45 ; fichier du module sym
  46 (defun $bidon2 ())
  47 ;==========================================================================
  48 ;               DECLARATIONS AU COMPILATEUR
  49 (progn (defvar listpi) (defvar $pui) (defvar $testpartpol))
  50
  51
  52 ;--------------------------------------------------------------------------
  53 ;                      MULTIDECOMPOSITION
  54 ;--------------------------------------------------------------------------
  55
  56 (defun $multi_pui_init ($multi_lpui $multi_pc $llvar)
  57   (multi_pui  (cdr $multi_lpui) $multi_pc
  58                       (cdr $llvar)))
  59 ;cf. p_red1
  60 (defun multi_pui (multi_lpui $multi_pc l$lvar)
  61   (cond
  62     ((meval (list '($is) (list '(mequal) $multi_pc 0))) 0)
  63     ((null l$lvar) $multi_pc)
  64     (t (multi_pui (cdr multi_lpui)
  65               (if (meval (list '($is) (list '(mequal) $multi_pc 0))) 0
  66                  (p_red1 (car multi_lpui)
  67 ; on a le polynome multisymetrique sous forme contracte'
  68 ; on considere qu'il est symetrique en un bloc de variables, les
  69 ; autres intervenant dans les coefficients
  70 ; on ramene sa forme partitionnee avec les longueurs devant
  71                            (lgparts (ch2repol
  72                                  (mac2lisp (meval
  73                                                (list '($cont2part) $multi_pc
  74                                                       (car l$lvar))))))))
  75
  76            (cdr l$lvar)))))
  77 ;***************************************************************************
  78 ;          MISE SOUS FORME INTERNE DU POLYNOME SYMETRIQUE
  79 ;                SUIVANT LES FORMES EXTERNES DONNEES
  80 ; Donnees :
  81 ; valpi = ((mlist) card p1 ....)  ou card est le cardinal
  82 ; sym est un polynome symetrique pouvant etre represente
  83 ; de plusieurs manieres en entree .
  84 ; lvar = ((mlist) x1 x2 ...) les variables de sym.
  85 ; Representation interne : REP([pol]) = [lppart](2)
  86 ;                          listpi=(card p1 ...)
  87 ;----------------------------------------------------------------------------
  88 ; sym = polynome contracte
  89 ;le polynome symetrique en entier ou en partie
  90 ; sym=REP([pol])(1)
  91 ; sym est le polynome symetrique
  92 ; on test egalement sa symetrie
  93 ; sym = (REP([pol])(2) + longueurs) retirer les "mlist"
  94 ; sym = REP([pol])(2)
  95 (defun $pui_init (valpi sym $lvar)
  96   (let ((sauvlistpi
  97             (cdr (flet ((franz.boundp (name)
  98                             "equivalent to Franz Lisp 'boundp'."
  99                             (and (boundp name)
 100                                  (cons nil (symbol-value name)))))
 101                    (franz.boundp 'listpi)))))
 102     (prog1 (case $pui
 103              (1
 104               (if (meval (list '($is) (list '(mequal) sym 0))) 0
 105                   (p_red1  valpi
 106                       (lgparts (ch2repol
 107                                   (mac2lisp (meval
 108                         (list '($cont2part) sym $lvar))))))))
 109              (2
 110               (if (meval (list '($is) (list '(mequal) sym 0))) 0
 111               (p_red1 valpi
 112                       (lgparts (ch2repol
 113                                  (mac2lisp (meval
 114                            (list '($partpol) sym $lvar))))))))
 115              (3
 116               (p_red1 valpi
 117                       (lgparts (ch2repol
 118                                    (mapcar 'cdr (cdr sym))))))
 119              (4
 120               (let ((pol (lgparts (ch2repol
 121                                     (mac2lisp (meval
 122                       (list '($tpartpol) sym $lvar)))))))
 123                 (p_red2 ($degrep pol) pol  valpi)))
 124              (5 (p_red1  valpi (mapcar 'cdr (cdr sym))))
 125              (6 (p_red1 valpi (lgparts (mapcar 'cdr (cdr sym)))))
 126              (t "erreur $pui n'a pas de valeur"))
 127       (setq listpi sauvlistpi))))
 128 ;**************************************************************************
 129
 130 (defun p_red1 ($l ppart)
 131    (p_red2 ($degrep ppart)
 132             (sort ppart 'orlongsup) $l))
 133
 134 ; on n'a qu'une constante
 135 ; dans fichier chbase
 136 (defun p_red2 (degpol ppart $l)
 137   (cond
 138     ((eql 0 (lgi ppart)) (coei ppart))
 139     (t (setq listpi (cdr (meval (list '($puireduc) degpol $l)) ))
 140        ($p_reduit ppart))))
 141 ;--------------------------------------------------------------------------
 142 ;                 LA BOUCLE PRINCIPALE
 143 ;--------------------------------------------------------------------------
 144 ;On rajoute la fonction puifor2 a l'interieur
 145 (defun $p_reduit (sym)
 146   (cond
 147     ((or (null sym) (eql 1 (lgi sym))) (p_ecrit sym))
 148     ((eql 2 (lgi sym)) (longde2 sym 0))
 149     (t ($p_reduit
 150            (somme (termrest sym)
 151                   (p_reducpart (moni sym) (coei sym) (lgi sym))
 152                   'orlongsup)))))
 153 ; Pour le fichier kak uniquement :
 154 (defun $p_reduit_init ($sym)
 155      ($p_reduit (mapcar 'cdr (cdr $sym))))
 156 ;-------------------------------------------------------------------------
 157 ; Calcul des fonctions puissances pour des partitions de longueur 2
 158 ;m(i)! * \sum x^i y^j = \sum x^i \sum x^j - \sum x^{i+j}
 159 ;              = p_i*p_j - p_{i+j}
 160 ; ici la multiplicite m(i) de i dans \sum x^i y^j est de 1 ou 2
 161 ;-------------------------------------------------------------------------
 162 ; m(i)=1=m(j)
 163 (defun longde2 (sym lg2)
 164   (cond
 165     ((or (null sym) (eql 1 (lgi sym))) ($add_sym lg2 (p_ecrit sym)))
 166     (t (let ((partin (moni sym)))
 167          (longde2 (cdr sym)
 168                   ($add_sym lg2
 169                       ($mult_sym (coei sym)
 170                           (if (eql 4 (list-length partin))
 171                               (let ((i (car partin))
 172                                     (j (caddr partin)))
 173                                 ($add_sym
 174                                     ($moins_sym
 175                                      (nth
 176                                       (+ i j)
 177                                       listpi))
 178                                     ($mult_sym (nth j listpi)
 179                                      (nth i listpi))))
 180                               ($divi_sym
 181                                   ($add_sym
 182                                       ($moins_sym
 183                                        (nth
 184                                         (* 2 (car partin))
 185                                         listpi))
 186                                       ($exp_sym
 187                                        (nth (car partin) listpi) 2))
 188                                   2)))))))))
 189 ;-------------------------------------------------------------------------
 190 ;              REECRITURE D'UNE FORME MONOMIALE
 191 ;          EN FONCTION DE FORMES MONOMIALES INFERIEURES
 192 ;                 POUR L'ORDRE DES LONGUEURS
 193 ; CAS r=1 (cf. article)
 194 ;-------------------------------------------------------------------------
 195 ; mapc agit sur tout les car successifs de ses listes arguments et rends la
 196 ; premiere liste (la seule ici et que l'on modifie physiquement).
 197 ; Comme on n'a plus besoin de part on peut la modifier physiquement
 198 ;--------------------------------------------------------------------------
 199 (defun p_reducpart (part coe lg)
 200   (let* ((puim (car part)) (m (cadr part))
 201          (-m (* -1 m))
 202          (coef (nth puim listpi)) (partf (p_fact part m)))
 203     (mapc #'(lambda (tpart)
 204              (flet ((franz.attach (newelt oldlist)
 205                         "equivalent to Franz Lisp 'attach'."
 206                         (progn
 207                           (rplacd oldlist
 208                                   (cons (car oldlist) (cdr oldlist)))
 209                           (rplaca oldlist newelt))))
 210                (franz.attach (1- lg)
 211                              tpart)))
 212           (constsol coef m coe partf
 213               (mapc #'(lambda (part)
 214                        (flet ((franz.attach (newelt oldlist)
 215                                   "equivalent to Franz Lisp 'attach'."
 216                                   (progn
 217                                     (rplacd oldlist
 218                                      (cons (car oldlist) (cdr oldlist)))
 219                                     (rplaca oldlist newelt))))
 220                          (franz.attach ($divi_sym coe -m) part)))
 221                     (multpui partf puim))))))
 222 ; si la puim-ieme fonction puissance est non nulle on rajoute partf
 223 ; aux nouvelles partitions a decomposer.
 224 (defun constsol (coef m coe partf prsol)
 225   (if (and (numberp coef)(zerop coef)) prsol
 226       (nconc prsol
 227              (list (cons ($divi_sym ($mult_sym coef coe) m) partf)))))
 228 ; On va eventuellement modifier physiquement part
 229 (defun p_fact (part m)
 230   (cond
 231     ((eql 1 m)
 232      (cddr part))
 233     (t
 234      (rplaca (cdr part) (1- m))
 235      part)))
 236 ;---------------------------------------------------------------------------
 237 ;             PRODUIT D'UNE FORME MONOMIALE parf PAR
 238 ;              LA FONCTION PUISSANCE DE POIDS puim.
 239 ; partf a pour representation [partition](2)
 240 ; LE CAS r=1 PERMET DE N'AVOIR QUE DES COEFFICIENTS EGAUX A 1.
 241 ;-----------------------------------------------------------------------
 242 (defun multpui (partf puim)
 243   (let ((k (cons nil nil))) (multpui2 partf puim nil k) (cdr k)))
 244 ; les partitions sont rangees dans l'ordre lexicographique decroissant
 245 ; dans k. Etant de meme longueur on les obtiend donc dans l'ordre
 246 ; des longueurs decroissant.
 247 ; nconc impossible ici
 248 (defun multpui2 (part puim s k)
 249   (or (null part)
 250       (let ((pui (car part)) (nb (cadr part)) (rpart (cddr part)))
 251         (multpui2 rpart puim (append s (list pui nb))
 252             (cdr (rplacd k
 253                          (list (list* (+ pui puim)
 254                                       1
 255                                       (nconc s
 256                                        (restpart pui
 257                                         (1- nb)
 258                                         rpart))))))))))
 259 (defun restpart (pui nb part)
 260   (if (eql 0 nb) part (cons pui (cons nb part))))
 261 ;----------------------------------------------------------------------------
 262 ;                      L'ECRIVAIN
 263 ;----------------------------------------------------------------------------
 264 ; une constante
 265 (defun p_ecrit (solu)
 266   (let ((solu (nreverse solu)))
 267     (cond
 268       ((null solu) 0)
 269       ((eql 0 (lgi solu))
 270        (p_ecrit2 (cdr solu) (cdr listpi) (coei solu) 1))
 271       (t (p_ecrit2 solu (cdr listpi) 0 1)))))
 272 (defun p_ecrit2 (solu listpi mpol i_init)
 273   (let ((i (car (moni solu))))
 274     (cond
 275       ((null solu) mpol)
 276       ((eql i i_init)
 277        (p_ecrit2 (cdr solu) listpi
 278            ($add_sym mpol ($mult_sym (coei solu) (car listpi))) i_init))
 279       (t (setq listpi
 280                (flet ((franz.nthcdr (ind lis)
 281                           "equivalent to Franz Lisp 'nthcdr'."
 282                           (let ((evalind (eval ind)))
 283                             (if (minusp evalind) (cons nil lis)
 284                                 (nthcdr evalind lis)))))
 285                  (franz.nthcdr
 286                      (- i i_init)
 287                      listpi)))
 288          (p_ecrit2 (cdr solu) listpi
 289              ($add_sym mpol ($mult_sym (coei solu) (car listpi))) i)))))