share/sym/kak.lisp

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