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))) 196