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