share/sym/multmon.lisp

   1 ; Fichier multmon.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 ;=========================================================================
  21 ;               PRODUIT DE DEUX FORMES MONOMIALES
  22
  23 ; multsym(ppart1,ppart2,card)
  24
  25 ; LE CALCUL N'EST ABSOLUMENT PAS SYMETRIQUE, IL FAUT QUE ppart2 soit
  26 ; plus creux que ppart1 si l'on desire etre efficace.
  27 ;============================================================================
  28
  29 (in-package :maxima)
  30 (macsyma-module multmon)
  31
  32 (progn (defvar terparts))
  33
  34 (progn)
  35 ;----------------------------------------------------------------------------
  36
  37 ;*********************************************************************
  38 ;                   BOUCLE PRINCIPALE
  39 ;*********************************************************************
  40 ; faire 2 option
  41 ; 1- contractee
  42 ; 2- partitionnee de type 1
  43
  44 ;-------------------------------------------------------------------------
  45 ;                         INTERFACE
  46
  47 (mdefprop $multmon
  48     ((lambda ()) ((mlist) $mi $mj $card)
  49      ((mprog) (($operation)) (($multmon_init) $mi $mj $card)))
  50     mexpr)
  51 (add2lnc '(($multmon) $mi $mj $card) $functions)
  52
  53 (mdefprop $multsym
  54     ((lambda ()) ((mlist) $2ppart $1ppart $card)
  55      ((mprog) (($operation)) (($multsym_init) $1ppart $2ppart $card)))
  56     mexpr)
  57 (add2lnc '(($multsym) $1ppart $2ppart $card) $functions)
  58
  59 ;-------------------------------------------------------------------------
  60
  61 (defun $multsym_init ($1ppart $2ppart card)
  62       (macsy_list (multsym (mapcar 'cdr (cdr $1ppart))
  63                                   (mapcar 'cdr (cdr $2ppart)) card)))
  64
  65 ; Remarque : multmon restitue des ppart ordones
  66 ; dans l'ordre lexicographique decroissant.
  67
  68 (defun multsym (1ppart 2ppart card)
  69   (do ((1ppart 1ppart (cdr 1ppart))
  70        (solution nil))
  71       ((null 1ppart) solution)
  72       (do ((2ppart 2ppart (cdr 2ppart))
  73            (term1 (car 1ppart)))
  74           ((null 2ppart))
  75           (setq solution (somme_coef (merge 'list
  76                                              solution
  77                                              (mult_term term1
  78                                                         (car 2ppart)
  79                                                         card)
  80                                              #'lex_term))))))
  81 (defun mult_term (term1 term2 card)
  82      (mapcar #'(lambda (term)
  83                        (rplaca term
  84                               ($mult_sym  (car term)
  85                                           ($mult_sym  (car term1)
  86                                                       (car term2)))))
  87              (multmon (cdr term1) (cdr term2) card)))
  88
  89
  90 ; Produit de deux formes monomiales sous formes contractees
  91
  92 (defun $multmon_init ($mi $mj card)
  93   (cond
  94     ((or (equal 0 $mi) (equal 0 $mj)) 0)
  95     (t (let ((i (fmon2part $mi)) (j (fmon2part $mj)))
  96          (ecrit_pol (multmon i j card) (lvar card nil))))))
  97
  98
  99 ; PASSAGE D'UNE FORME MONOMIALE A SA REPRESENTATION PARTITIONNELLE
 100          ; [forme monomiale] ---> [partition](1)
 101
 102 (defun fmon2part (m)
 103   (let ((rat (cadr ($rat m))))
 104       (sort (chexpo (caddr rat) (list (cadr rat))) '>)))
 105
 106 (defun chexpo (liste lexpo)
 107   (cond
 108     ((numberp liste) lexpo)
 109     (t (chexpo (caddr liste) (cons (cadr liste) lexpo)))))
 110
 111 ;---------------------------------------------------------------------
 112 ; Produit de deux formes monomiales sous forme de partition , type 1.
 113 ; Rend la plus grande partition en premier.
 114 ; Les partitions ont des zeros a la fin
 115
 116 ; exemple :
 117 ;<1>: (multmon '(2 1 1) '(3 1 1) 5)
 118 ;((1 5 2 2 0 0) (2 5 2 1 1 0) (6 5 1 1 1 1) (2 4 2 2 1 0)
 119 ; (3 4 2 1 1 1) (1 4 3 2 0 0) (2 4 3 1 1 0) (6 3 3 1 1 1)
 120 ; (4 3 2 2 1 1) (2 3 3 2 1 0) (3 3 2 2 2 0))
 121 ;---------------------------------------------------------------------
 122 ; on complete I avec de zeros
 123
 124 (defun multmon (i j card)
 125   (let ((i (fini0 i card)) (j (epur0 j)))
 126     (let ((lperm (permut j)) (terparts (cons nil nil)))
 127       (mapc #'(lambda (j) (parti_som_init i j terparts)) lperm)
 128       (cdr (nreverse terparts)))))
 129
 130 ; on rajoute les zeros
 131
 132 (defun fini0 (i card)
 133   (nconc i
 134          (make-list (- card (list-length i))
 135                 :initial-element 0)))
 136 ; on enleve les zeros
 137
 138 (defun epur0 (j)
 139   (mapcan #'(lambda (part)
 140              (and (< 0 part)
 141                   (list part)))
 142           j))
 143
 144 ;******************************************************************
 145 ; OBTENTION DE CERTAINES DES PARTITIONS SOLUTION A PARTIR D'UNE
 146 ; PERMUTATION DE J
 147 ;******************************************************************
 148
 149 ; I=(i1 i2 ... in) avec i1>i2>...>in>=0 n=card
 150 ; J est une permutation de Jo (sans les parts nulles)
 151 ; on desire faire la somme de I avec toutes les partitions K,
 152 ; construites a partir de J par insertion de zeros, et telles
 153 ; que IK=((i1,k1),(i2,k2), ... , (in , kn)) soit dans l'ordre
 154 ; lexicographique decroissant.
 155 ; On associe alors a K+I le quotient des 2 valeurs c1 et c2.
 156 ; Ou c1 est le nombre de permutations laissant I+K invariante
 157 ; et c2 le nombre de permutations laissant IK invariante.
 158
 159 (defun parti_som_init (i j terparts) (parti_som i j nil nil))
 160
 161 ; I se met au fur et a mesure dans RI, et K dans RK.
 162 ; les solutions IK se rangent dans terparts.
 163 ;conservation de l'ordre lex
 164 ; sur les couples solutions
 165 ; si le cardinal le permet, on va pouvoir rajouter des zeros
 166
 167 (defun parti_som (i j ri rk)
 168   (cond
 169     ((null j)
 170      (flet ((franz.attach (newelt oldlist)
 171               "equivalent to Franz Lisp 'attach'."
 172               (progn
 173                 (rplacd oldlist (cons (car oldlist) (cdr oldlist)))
 174                 (rplaca oldlist newelt))))
 175        (franz.attach
 176         (somme_coe (nconc (reverse i) ri)
 177                    (append (make-list (list-length i) :initial-element 0) rk))
 178         terparts)))
 179     (t
 180      (and (or (not ri)
 181               (< (car i) (car ri))
 182               (not (< (car rk) (car j))))
 183           (parti_som (cdr i) (cdr j) (cons (car i) ri)
 184                      (cons (car j) rk)))
 185      (and (not (< (list-length (cdr i)) (list-length j)))
 186           (parti_som (cdr i) j (cons (car i) ri) (cons 0 rk))))))
 187
 188
 189 (defun somme_coe (i k)
 190   (let ((i+k (sort (mapcar '+ i k) '>))
 191         (cik (mapcar 'cons i k)))
 192     (cons (coei+k i+k cik) i+k)))
 193
 194 (defun coei+k (i+k cik)
 195   (/ (card_stab i+k 'eql) (card_stab cik 'equal)))