1; Fichier kak.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;;;              SUR UN PROBLEME DE PIERRE CARTIER
21;       Produit k a k ou sommes k a k des racines d'un polynome
22; Nous traitons ici le cas des resolvantes symetriques lorsque la fonction
23; resolvante est une somme ou un produit.
24;========================================================================
25;                      INTERFACE
26
27(in-package :maxima)
28(macsyma-module kak)
29
30(mdefprop $somrac
31    ((lambda ()) ((mlist) $listei $k)
32     ((mprog) (($operation)) (($somrac_init) $listei $k)))
33    mexpr)
34(add2lnc '(($somrac) $listei $k) $functions)
35
36(mdefprop $prodrac
37    ((lambda ()) ((mlist) $listei $k)
38     ((mprog) (($operation)) (($prodkak) $listei $k)))
39    mexpr)
40(add2lnc '(($prodrac) $listei $k) $functions)
41
42
43; ON RAMENE LES FORME MONOMIALES DE MEME LONGUEUR AVEC LE VRAI
44; ORDRE DES LONGUEURS DECROISSANT
45;**************************************************************************
46;               DECLARATIONS AU COMPILATEUR
47(progn
48  (defvar listpi)
49  (defvar listei)
50  (defvar k)
51  (defvar coe)
52  (defvar $somrac))
53;$somrac_init
54;   SOMME KAK EN PASSANT PAR LES FONCTIONS PUISSANCES
55;    $p_rac
56;Tail merging being done: ($som_Pipj (|1-| i) ..........)
57; Tail merging being done: ($Pi2mon pui (|1-| var) ....)
58;  SOMME KAK EN PASSANT PAR LES ELEMENTAIRES
59;     $e_rac
60; CREATION DES PARTION DE LONGEUR ET DE POIDS DONNES
61; PRODUIT KAK
62;    $prodkak
63; CALCUL D'UN COEFFICIENT BINOMIAL
64; ECRIVAIN
65;** FTOC. WARNING:
66;             Franz Lisp declaration 'localf' is currently untranslated
67(progn)
68;**********************************************************************
69;                 SOMME K A K DES RACINES D'UN POLYNOME P
70
71(defun $somrac_init (listei k)
72  (cond
73    ((equal '$puissances $somrac) ($p_rac listei k))
74    (t ($e_rac listei k))))
75
76;           DECOMPOSITION DES FORMES MONOMIALES CONSTITUANT
77; CHAQUE FONCTION PUISSANCE DU NOUVEL ALPHABET EN FONCTION DES FONCTIONS
78;                  PUISSANCE DES RACINES DE P
79;compatible avec (macsyma) et p_sym23 21 et 22.
80;consideration des constantes
81;de l=1 a bin(n,k) :
82;    sl(anciennes racines)=fct(sigmai(anciennes racines); i=1 a n)
83;    avec changement de base
84;    Sl(nouvelles racines)=Fct(si(anciennes racines))
85;    SIGMAl(nouvelles racines)=FCT( Sl(nouvelles racines))
86;  plus rapide que som en temps mais pas en espace
87; listei=((mlist) e1 ... en)
88
89(defun $p_rac (listei k)
90  (setq listei (cdr listei))
91  (let ((n (list-length listei)))
92    (cond
93      ((< n k)
94       " impossible ")
95      (t
96       (meval (list '($bidon2) ))
97       (let* ((binnk (binomial n k))
98	      (listpi (cdr (meval (list '($ele2pui) binnk
99					(cons '(mlist)(cons n listei))))))
100	      (listpi (cons binnk ($som_pipj n binnk nil))))
101	 ;; je n'ai pas besoin de faire meval ici puisque le fichier
102	 ;; est forcement charge'
103	 (pui2polynome '$y listpi))))))
104;               (listei  (cdr (pui2ele binnk listpi '$girard))))
105 ;         ($fin (1- binnk)
106  ;              -1 (list '(mexpt) '$y binnk) listei)))))
107;__________________________________________________________________________
108;        recherche des Fonctions puissances Pi en fonction des pj
109(defun $som_pipj (n i nxlistpi)
110  (if (eql 0 i)  nxlistpi
111      ($som_pipj n
112          (1- i)
113          (cons ($p_reduit ($init_pi2mon n i (min k i)))
114                nxlistpi))))
115;__________________________________________________________________________
116;Recherche de l'expressiond'un Pi dans la base des formes monomiales sur S[A]
117;*** depart
118(defun $init_pi2mon (n i infki)
119  (if (eql i infki)
120      ($pi2mon n i infki nil
121               (binomial (- n i)
122                     (- k i)))
123      ($pi2mon n i infki nil 1)))
124;*** recherche des fonctions monomiales en fonction de leur longueur, var,
125;On les range au fur et a mesure dans sym
126(defun $pi2mon (n pui var sym coe)
127  (if (eql 0 var) sym
128      ($pi2mon n pui
129               (1- var)
130               (nconc sym ($init_monlgfix pui var (cons nil nil)))
131               (div (* coe (- n (1- var))) (- k (1- var))))))
132
133;*** recherche des formes monomiales de S[A], representant Pi (i=pui)
134;           et ayant leur longueur egale a var.
135(defun $init_monlgfix (pui var slvarh)
136  ($monlgfix pui
137      (1- var)
138      (1- var)
139      slvarh (cons 1 nil) (maxote pui var))
140  (mapl #'(lambda (ppart)
141           (rplaca ppart
142                   (cons var
143                         (cons ($mult_sym coe (caar ppart))
144                               (cdar ppart)))))
145        (cdr slvarh)))
146;*************************************************************************
147;           PAR LES FONCTIONS SYMETRIQUES ELEMENTAIRES ei
148;                  DU POLYNOME DE DEPART
149;compatible avec e_sym26.l (macsyma)
150; consideration des constantes
151;de l=1 a bin(n,k) :
152;    sl(anciennes racines)=fct(sigmai(anciennes racines); i=1 a n)
153;    avec changement de base
154;    Sl(nouvelles racines)=Fct(si(anciennes racines))
155;    SIGMAl(nouvelles racines)=FCT( Sl(nouvelles racines))
156;  plus rapide que som en temps mais pas en espace
157(progn)
158;listei=(e1,...,en)=((mlist) e1 ... en)
159(defun $e_rac (listei k)
160  (let ((n (1- (list-length listei))))
161    (if (< n k)
162        " impossible "
163        (if (meval (list '($bidon))); permet de charger le fichier elem ou pas.
164        (let* ((binnk (binomial n k))
165               (listei (cons n (cdr listei))))
166              (pui2polynome '$y (cons binnk ($rac2 binnk nil n))))))))
167
168;__________________________________________________________________________
169;             Recherche des Pi (i=1 a binnk) en fonction ds ej (j=1 a n)
170(defun $rac2 (l nxlistpi n)
171  (if (eql 0 l) nxlistpi
172      ($rac2 (1- l)
173             (cons ($init_piej l (min k l) n) nxlistpi )
174             n)))
175;__________________________________________________________________________
176;      recherche d'un Pi dans la base des ej de S[A]
177;*** depart
178(defun $init_piej (l infkl n)
179  (if (eql l infkl)
180      ($piej l infkl 0 (binomial (- n l) (- k l)) n )
181      ($piej l infkl 0 1 n)))
182;*** recherche par les monomiales de S[A], rentrant dans la decomposition
183; de Pi et ayant meme longueur. Que l'on decompose en fonction des ej et que
184; l'on range longueur apres longueur (longueur = var) dans Pi.
185; i=pui
186(defun $piej (pui var $pi coe n)
187  (if (eql 0 var)  $pi
188      ($piej pui
189             (1- var)
190             ($add_sym $pi
191                 ($mult_sym coe ($piej_lgfix pui var (cons nil nil) n)))
192              (div (* coe (- n (1- var))) (- k (1- var)))
193              n  )))
194
195;*** recherche des formes monomiales a longueur fixe var
196
197(defun $piej_lgfix (pui var slvarh n)
198  ($monlgfix pui
199      (1- var)
200      (1- var)
201      slvarh (cons 1 nil) (maxote pui var))
202  ($reduit (min pui n) ; varm
203           (mapl #'(lambda (ppart)
204                    (rplaca ppart (cons var (car ppart))))
205                 (cdr slvarh))))
206;*********************************************************************
207; Calcul des formes monomiales et de leur coefficient intervenant dans Pi
208; a longueur fixe et donc aussi a poids i fixe.
209
210; la fonction maxote est commune a : treillis.lsp , resolvante.lsp, kak.lsp
211; voir dans util.lsp. Elle donne ici
212; le maximun que l'on peut retirer pour avoir p dans E(l,var)(croissance)
213
214
215
216;recherche proprement dite (non recursive terminale)
217(defun $monlgfix (pui rvar ote slvar poule maxote)
218  (cond
219    ((> 0 rvar)
220     (rplacd slvar (list (cons (car poule) (reverse (cdr poule))))))
221    (t
222     ($monlgfix ote
223		(1- rvar)
224		(max (1- rvar)
225		     (- (* 2 ote)
226			pui))
227		slvar ($met pui ote poule) (maxote ote rvar))
228     (and (< ote maxote)
229	  ($monlgfix pui rvar
230		     (1+ ote)
231		     (last slvar) poule maxote)))))
232
233(defun $met (pui ote poule)
234  (let ((nxcoe ($mult_sym (car poule) (binomial pui ote)))
235        (nxpui (- pui ote)))
236    (if (eq (caddr poule) nxpui)
237        (list* nxcoe
238                (1+ (cadr poule))
239                (cddr poule))
240        (list* nxcoe 1 nxpui (cdr poule)))))
241;-----------------------------------------------------------------------
242;-----------------------------------------------------------------------
243;                    PRODUIT K A K
244; listei = ((mlist) e1 .en)
245; sans p0
246(defun $prodkak (listei k)
247  (setq listei (cdr listei))
248  (let ((n (list-length listei)))
249    (cond
250      ((< n k)
251       " impossible ")
252      (t
253       (meval (list '($bidon2)))
254       (let* ((binnk (binomial n k))
255	      (listpi
256	       (cdr (meval (list '($ele2pui) (mult binnk k)
257                                 (cons '(mlist) (cons n listei)))))))
258	 (pui2polynome '$y
259		       (cons binnk ($listpui binnk nil k))))))))
260
261; liste des fonctions puissances dans l'alphabet des racines du polynome
262; cherche.
263(defun $listpui (i listpui k)
264  (if (eql 0 i) listpui
265      ($listpui
266          (1- i)
267          (cons ($p_reduit (list (list k 1 i k))) listpui)
268           k)))
269