share/sym/resolv1.lisp

   1 ;; Fichier resolvante.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 ;                   CALCUL DE RESOLVANTES
  21 ; ON TRANSFORME UN POLYNOME $pol DE LA VARIABLE $var
  22 ; AVEC UNE FONCTION RESOLVANTE $fonction_resolvante DONT
  23 ; LES VARIABLES $list_var.
  24 ; ON NE DOIT PAS METTRE DANS $list_var LES VARIABLES DONT NE DEPEND
  25 ; PAS LA FONCTION RESOLVANTE.
  26 ;=========================================================================
  27 ; REMARQUES D'AMELIORATIONS :
  28 ;     1) SI LA TRANSFORMATION EST d'ARITE LE DEGRE DU POLYNOME,
  29 ;          ON BALAYE TOUTES LES PARTITIONS POUR RIEN
  30 ;     2) IL FAUT AUSSI DISTINGUER LE CAS DE LA TRANSFORMATION A COEFFICIENTS
  31 ;        NUMERIQUES ET CELLE A COEFFICIENTS FORMELS
  32 ;========================================================================
  33 ;                        INTERFACE
  34 (in-package :maxima)
  35 (macsyma-module resolvante)
  36
  37 (mdefprop $linear_resolvante
  38     ((lambda ()) ((mlist) $pol $var $coeff)
  39      ((mprog) (($operation)) ((linear_resolvante_init) $pol $var $coeff)))
  40     mexpr)
  41 (add2lnc '(($linear_resolvante) $pol $var $coeff) $functions)
  42
  43 (mdefprop $resolvante
  44     ((lambda ()) ((mlist) $pol $var $fonction_resolvante $lvar)
  45      ((mprog) (($operation)) ((resolvante) $pol $var
  46                                                 $fonction_resolvante $lvar)))
  47     mexpr)
  48 (add2lnc '(($resolvante) $pol $var $fonction_resolvante $lvar) $functions)
  49
  50 (mdefprop $somme_orbitale
  51     ((lambda ()) ((mlist) $coeff poids)
  52      ((mprog) (($operation)) ((somme_orbitale_init) $coeff poids )))
  53     mexpr)
  54 (add2lnc '(($somme_orbitale) $coeff poids) $functions)
  55
  56 ;=========================================================================
  57
  58 (defun resolvante ($pol $var $fonction_resolvante $list_var)
  59      (cond  ((equal '$cayley $resolvante)
  60                  (print " resolvante de Cayley ")
  61                  ;; (load "resolcayley.lisp")
  62                  (meval (list '($SUBSTITUTE)
  63                            (cons '(mlist)
  64                                  (mapcar #'(lambda (val $ei)
  65                                                    (list '(mequal) $ei val))
  66                                           (cdr (polynome2ele  $pol
  67                                                               $var))
  68                                            '($E1 $E2 $E3 $E4 $E5)))
  69                                  $RESOLCAYLEY)))
  70             ((or (equal '$unitaire $resolvante)
  71                  (= 2 (list-length $List_var)))
  72                  (print " resolvante unitaire ")
  73                  (meval (list
  74                               '($RESOLVANTE_UNITAIRE)
  75                               $pol
  76                               (meval (list '($EV)
  77                                              $fonction_resolvante
  78                                              (meval (list '(MEQUAL)
  79                                                            (cadr
  80                                                             $list_var)
  81                                                             $var))))
  82                               $var)))
  83            ((equal '$produit $resolvante) ; a`optimiser svp
  84                  (print " resolvante produit ")
  85             (meval (list '($prodrac)
  86                           (cons '(mlist) (cdr (polynome2ele $pol $var)))
  87                           (1- (list-length $list_var)))))
  88            ((equal '$somme $resolvante)
  89                  (print " resolvante somme ")
  90             (meval (list '($somrac)
  91                           (cons '(mlist) (cdr (polynome2ele $pol $var)))
  92                           (1- (list-length $list_var)))))
  93            ((equal '$lineaire $resolvante)
  94                  (print " resolvante lineaire ")
  95             (linear_resolvante (mapcar #'(lambda ($var)
  96                                             ($coeff $fonction_resolvante
  97                                                            $var 1))
  98                                         (cdr $list_var))
  99                                (polynome2ele $pol $var)))
 100            ((equal '$alternee $resolvante)
 101                  (print " resolvante alternee ")
 102             (linear_resolvante (mapcar #'(lambda ($var)
 103                                             ($coeff $fonction_resolvante
 104                                                            $var 1))
 105                                         (cdr $list_var))
 106                                (polynome2ele $pol $var)
 107                                :alternee t))
 108            ((equal '$symetrique $resolvante)
 109                  (print " resolvante symetrique ")
 110          ; ce n'est pas a resolvante de tester la symetrie
 111             (symetrique_resolvante $fonction_resolvante
 112                                    $list_var
 113                                    (polynome2ele $pol $var)))
 114            ((equal '$groupe $resolvante)
 115                  (print " resolvante groupe ")
 116                   (print '|non implante|)
 117                   (groupe_resolvante $fonction_resolvante
 118                                       $list_var
 119                                       (polynome2ele  $pol $var)))
 120
 121
 122            (t ; ici on peut eventuellement rajouter des tests :
 123                  ; symetrique ou lineaire
 124                  (print " resolvante generale ")
 125             (if (not (consp (cadr $list_var)))
 126                 (meval (list '($direct)
 127                               (list '(mlist)  $pol)
 128                                $var
 129                               $fonction_resolvante
 130                               (list '(mlist) $list_var)))
 131                 (meval (list '($direct)
 132                               $pol
 133                               $var
 134                               $fonction_resolvante
 135                               $list_var))))))
 136
 137 ; cette fonction semble inutile
 138 (defun cree_subs (val $ei)  (list '(mequal) $ei val))
 139
 140
 141 ;=========================================================================
 142 ;                  RESOLVANTES SYMETRIQUES
 143
 144 ; i.e. LA FONCTION RESOLVANTE EST SYMETRIQUE EN p VARIABLES
 145 ; COMME L'ORBITE DE LA FONCTION RESOLVANTE SOUS S_p EST LA FONCTION RESOLVANTE,
 146 ; LES FONCTIONS PUISSANCES DE CETTE ORBITE SE CALCULENT EN CALCULANT
 147 ; LES PUISSANCES DE LA FONCTION RESOLVANTE.
 148 ; ENSUITE ON PASSE A S_n (n LE DEGRE DU POLYNOME INITIAL) EN RAJOUTANT
 149 ; A CHAQUE PARTITION I LE COEFFICIENT BINOMIAL BIN(n-lg(I),p-lg(I)).
 150
 151 (defun symetrique_resolvante ($fct_resolvante $list_var elementaires)
 152     (meval (list '($bidon2))) ; charger les fichiers pui.lisp et multmon.lisp
 153     (meval (list '($multsym) (list '(mlist)) (list '(mlist)) 0))
 154     (let* (($pui 3)
 155            (degre (car elementaires))
 156            (longueur (list-length (cdr $list_var)) )
 157              ; recherche de la fonction resolvante sous la forme
 158               ; d'un polynome partitionne
 159            (fct_resolvante  (cont2part_rep1
 160                                    ($expand (meval (list '($contract)
 161                                                    $fct_resolvante
 162                                                    $list_var)))
 163                                    $list_var))
 164            (degre_resol (binomial degre longueur)))
 165           (pui2polynome '$y
 166                       (cons degre_resol
 167                             (puissances_symetrique_resolvante
 168                                    degre_resol
 169                                    longueur
 170                                    fct_resolvante
 171                                    fct_resolvante
 172                                    (meval (list '($ele2pui)
 173                                                 degre_resol
 174                                                 (cons '(mlist) elementaires)))
 175                                )))))
 176
 177
 178 ; la fonction multsym realise le produit de deux polynomes symetriques.
 179 ; il faut mettre le polynome f plus creux que puif en deuxieme argument
 180 ; on pourrait etre tente' de garder un seul polynome puif en memoire
 181 ; mais de toute maniere le fait de passer de Rep[1] a Rep[2]
 182 ; necessaire a la decomposition en les fonctions puissances imposera
 183 ; d'avoir deux polynomes en memoire. Domage! Sinon on gardait les
 184 ; anciens coefficients en memoire.
 185 ; je n'ai pas cherche' a faire de la recursivite' terminale.
 186
 187 ; ici difference avec macsyma dont le commonlisp compile' ne supporte pas
 188 ; les print emboite's dans une fonction.
 189
 190 (defun puissances_symetrique_resolvante (ind arite_f f puif $puissances)
 191      (and (< 0 ind)
 192          (print (- (- (list-length $puissances) 1) ind))
 193          (cons  (p_red1 $puissances
 194                        (complete_pui (cadr $puissances)
 195                                       arite_f
 196                                       puif ))
 197                (puissances_symetrique_resolvante
 198                             (1- ind)
 199                              arite_f
 200                              f
 201                              (and (< 1 ind)
 202                                   (multsym puif f arite_f))
 203                              $puissances))))
 204
 205
 206 ; Pour le cas qui nous interesse, il est indispensable de ne pas faire
 207 ; de remplacement physique sur la liste . Alors on redefinie
 208 ; pui_complete
 209 ; il serait astucieux d'utiliser les rplaca. Pour cela il faut
 210 ; garder en memoire bin(n-lg,p-lg), et le retirer de $puif apres
 211 ; avoir evalue' en les fonction puissance. Ainsi on perdrait en temps
 212 ; mais on gagnerai toute la longueur de $puif en espace.
 213
 214 (defun complete_pui (n p puissance_resolvante)
 215      (mapcar #'(lambda (part) ; part=(part)(1) comme representation
 216                        (let ((lg (longueur (cdr part))))
 217                             (list* lg
 218                                    ($mult_sym (car part)
 219                                               (binomial (- n lg)
 220                                                         (- p lg)))
 221                                    (ch2rep (cdr part)))))
 222                 puissance_resolvante))
 223 ;=========================================================================
 224 ;          ALGORITHMES POUR CALCULER DES RESOLVANTES LINEAIRES
 225
 226 ; I.E LA FONCTION RESOLVANTE EST UNE FORME LINEAIRE DANS $K[x_1,...,x_n]$
 227 ; SES COEFFICIENTS SONT DANS $coeff :
 228 ; ON TRANSFORME UN POLYNOME $pol DE LA VARIABLE $var (DE DEGRE n).
 229 ; ATTENTION !!!!
 230 ;               ON SUPPOSE DANS UN PREMIER TEMPS QUE
 231 ;     $coeff NE COMPORTE QUE DES VALEURS NON NULLES
 232
 233 ; SINON LE DEGRE DE LA RESOLVANTE, CELUI DE L'ORBITE DE $coeff SOUS $S_n$,
 234 ; N'EST PLUS n!/(n-p)! OU p EST LE NOMBRE DE COEFFICIENTS NON NULS DANS $var
 235 ; DE PLUS L'ORBITE DE LA FONCTION RESOLVANTE SOUS L'ACTION DE S_n EST PLUS PETITE.
 236 ; IL RESTE DONC A TRAITER CE TRAVAIL SUR LES RESOLVANTES LINEAIRES.
 237 ;============================================================================
 238
 239
 240 (defun linear_resolvante_init ($pol $var $coeff &key alternee)
 241     (linear_resolvante (cdr $coeff)
 242                        (polynome2ele $pol $var)
 243                        :alternee alternee))
 244
 245 ; $bidon2 SERT A CHARGER LE FICHIER PUI.LISP SI CE N'EST DEJA FAIT
 246
 247 (defun linear_resolvante (coeff elementaires &key alternee)
 248     (meval (list '($bidon2)))
 249     (let* ((degre (car elementaires))
 250                      ; on enleve les coefficients nuls
 251            (coeff (retirezero coeff))
 252                      ;il faut que les coefficients soient non nuls:
 253            (longueur (list-length coeff))
 254            (permut_coeff ((lambda (p)
 255                                   (if alternee  (permut_alterne p)
 256                                                  p))
 257                              (permut coeff)))
 258            (degre_resol (* (binomial degre longueur)
 259                           ((lambda (d) (if alternee (* 2 d) d))
 260                            (list-length permut_coeff)))))
 261           (pui2polynome '$y
 262                         (cons degre_resol
 263                                (puissances_linear_resolvante
 264                                       degre_resol
 265                                       longueur
 266                                       permut_coeff
 267                                       (meval (list '($ele2pui)
 268                                                  degre_resol
 269                                                  (cons '(mlist)
 270                                                        elementaires)))
 271                                       alternee)))))
 272
 273
 274 ; on utilise directement, p_red1, une fonction interne au fichier
 275 ;  pui.lisp evitant ainsi un interfacage inutile et couteux.
 276 ; Cette fonction realise le meme travail que la fonction pui
 277 ; en imposant que les partitions aient leur longueur en tete
 278 ; et quelles soient sous la  representation:
 279 ;     [partition](2) (i.e. (... a_i m_i ...) si I=...a_i^m_i...)
 280
 281 ; il faut calculer les fonctions puissances generiques en imaginant
 282 ; que le degre du polyn\^ome est longueur (l'arite de la fonction
 283 ; de transformation). Puis ensuite on rajoute le
 284 ; coefficient binomial bin(degre-lg(I),longueur-lg(I)) a chaque partition.
 285 ; On peux meme imaginer que ces coefficients apparaissent souvent
 286 ; donc on va les stocker.
 287
 288 (defun puissances_linear_resolvante
 289            (poids longueur permut_coeff $puissances alternee)
 290        (do ((i poids (1- i))
 291             (sol nil))
 292            ((= 0 i) sol)
 293            (setq sol
 294                  (cons (if (and alternee (oddp i)) 0
 295                            ((lambda (pui)
 296                                  (if alternee ($mult_sym 2 pui) pui))
 297                              (p_red1 $puissances
 298                                      (pui_linear_resolvante
 299                                             permut_coeff
 300                                             i
 301                                             longueur
 302                                             (cadr $puissances)))))
 303                          sol))))
 304
 305
 306 ;-----------------------------------------------------------------------
 307 ;       recherche de la r-ieme fonction puissance generique
 308 ;    sur la base des formes monomiales en n variables (n=degre(pol))
 309 ;  ON CHERCHE DONC LES PARTITIONS DE POIDS FIXE ET DE LONGUEUR BORNEE
 310 ; AVEC EN PLUS COMME COEFFICIENTS :
 311
 312 ; BIN(n-lg(I),p-lg(I))*MULTINOMIAL(POIDS(I),I)
 313 ;                     *SUM(c^I,c \in ORBIT(coeff,S_p))
 314
 315 ; DONC REPRISE AVEC CETTE MODIFICATION DE LA FONCTION ltreillis de SYM
 316
 317 ; son poids est r, sa longueur ne doit pas depasser le nombre de
 318 ; coefficients non nuls (i.e. l'arite de la fonction de transformation)
 319 ; les permutations distinctes de coeff sont dans : permut_coeff
 320
 321 (defun pui_linear_resolvante (permut_coeff poids longueur n)
 322
 323   (let ((lpart (cons nil nil)))
 324     (somme_orbitale poids
 325                (- longueur 1)
 326                0
 327                (maxote poids longueur)
 328                nil
 329                lpart permut_coeff poids n longueur)
 330                (print poids)(cdr lpart)))
 331
 332 ; -------------------------------------------------------------------------------
 333 ; on doit mettre cela dans $mm car on doit le quoter pour $save qui ne
 334 ; peut comprendre (cdr lpart)))
 335
 336    ;   (set (concat '$ppp poids) (cdr lpart)))) je n'arrive pas a recuperer les pppi
 337 ; a la sortie car ce sont des variables speciales (ce que je crois) que je ne
 338 ;peux declarer comme telles et de plus cela surcharge la memoire.
 339
 340 ; -------------------------------------------------------------------------------
 341 ; Remarque : on s'arrangera plus tard pour eviter les parts nulles, mais alors
 342 ; attention a $multinomial, que l'on devra diviser par (p-lg(I))!.
 343
 344 (defun somme_orbitale (poids rlongueur ote maxote partition lpart
 345                        permut_coeff poids_init n p)
 346   (cond ((minusp rlongueur)
 347                      ; les partitions obtenues ne sont pas sous la
 348                      ; forme [partition](2) avec la longueur en tete
 349                      ; de plus on passe d'une fonction p-aire a une
 350                      ; n-aire => (bin (- n lg) (- p lg))
 351                      ; sans oublier le coefficient multinomial de la partition
 352          (let* ((partition (sanszero partition))
 353                 (lg (list-length partition))
 354                 (orbit_mon (ev_forme_monomiale permut_coeff
 355                                                partition)))
 356                (if (not (equal 0 orbit_mon))
 357                 (rplacd lpart
 358                         (list (list* lg ; passer de $S_p$ a $S_n$
 359 ; Pour des coefficients de la transformation numeriques :   ($mult_sym
 360                                       (m*
 361                                          (* (binomial (- n lg) (- p lg))
 362                                             ($multinomial poids_init
 363                                                    (cons '(mlist)
 364                                                  (reverse partition))))
 365                                           orbit_mon)
 366                                      (ch2rep (reverse partition))))))))
 367         (t (somme_orbitale   ote
 368                          (- rlongueur 1)
 369                          (max 0 (- (* 2 ote) poids))
 370                          (maxote ote rlongueur)
 371                          (cons (- poids ote) partition)
 372                          lpart
 373                          permut_coeff poids_init n p)
 374             (and (< ote maxote)
 375                    (somme_orbitale poids
 376                          rlongueur
 377                          (1+ ote)
 378                          maxote
 379                          partition
 380                          (last lpart)
 381                          permut_coeff poids_init n p)))))
 382
 383 ; la fonction maxote est commune a : treillis.lsp , resolvante.lsp, kak.lsp
 384 ; voir dans util.lsp
 385
 386 ;  A PARTIR DES PERMUTATIONS D'UN p-UPLET
 387 ;  CONSTRUIRE L'ALPHABET DES MONOMES CONSTITUE' AVEC LES PERMUTATIONS
 388 ; COMME VARIABLES ET LA PARTITION part COMME EXPOSANT. ON CALCULE ICI
 389 ; LA SOMME DES ELEMENT DE CET ALPHABET.
 390 ; C'est meme beaucoup mieux ! Cela s'inscrit dans la formule generale
 391 ; des resolvantes lineaires.
 392 ; J'IMPOSE QUE LES COEFFICIENTS NULS NE SOIENT PAS DONNE'S.
 393
 394 (defun ev_forme_monomiale (permut_coeff part)
 395      ($fadd_sym
 396             (mapcar #'(lambda (coeff)
 397                               ($fmult_sym
 398                                      (mapcar #'(lambda (var expo)
 399                                                     ($exp_sym var expo))
 400                                              coeff part)))
 401                     permut_coeff)))
 402 ;; CECI EST LA VERSION POUR UNE FONCTION DE TRANSFORMATION A COEFFICIENTS
 403 ;; NUMERIQUES
 404 (defun ev_forme_monomiale (permut_coeff part)
 405      (eval (cons 'add
 406                 (mapcar #'(lambda (coeff)
 407                               (eval (cons 'm*
 408                                        (mapcar #'(lambda (var expo)
 409                                                     (expt var expo))
 410                                              coeff part))))
 411                         permut_coeff))))
 412 (defun sanszero (rpartition)
 413       (if (= 0 (car rpartition))
 414           (sanszero (cdr rpartition))
 415           rpartition))
 416
 417 ; liste de coefficients formels ou numerique a laquelle
 418 ; on desire retirer les zeros.
 419 (defun retirezero (coeff)
 420     (and coeff
 421          (if (equal 0 (car coeff)) (retirezero (cdr coeff))
 422              (cons (car coeff) (retirezero (cdr coeff))))))
 423 ;=========================================================================
 424 ;      ALGORITHMES POUR CALCULER DES RESOLVANTES LINEAIRES-ALTERNEE
 425
 426 ;
 427 ; NOUS POUVONS OPTIMISER AU CAS OU LA FONCTION RESOLVANTE EST ALTERNEE
 428 ; LE PB EST DE CHANGER (PERMUT COEFF ) (LES PERMUTATIONS SOUS LE GROUPE
 429 ; SYMETRIQUE ) PAR (PERMUT-ALTERNEE COEFF) OU L'ON QUOTIENTE PAR
 430 ; <(1 2)(3 4)...(P-1 P)>
 431 ; POUR CELA CA NE COUTE PAS EXTREMEMENT CHER DE CALCULER TOUTES LES
 432 ; PERMUTATIONS ET DE SE DEBARASSER DES INDESIRABLES (ENGENDRANT AINSI QUE
 433 ; L'UNE DES FONCTIONS PERMUTEES DE LA FONCTION RESOLVANTE : f_i OU -f_i)
 434
 435 ; CETTE METHODE PERMET DE CALCULER UN POLYNOME DE DEGRE MOITIE MOINS QUE CELUI
 436 ; DE LA RESOLVANTE LINEAIRE CHERCHEE. MAIS LE POIDS MAXIMUM DES
 437 ; PARTITIONS INTERVENANT DANS LE CALCUL (LE DEGRE DE LA RESOLVANTE)
 438 ; RESTE LE MEME
 439 ;=========================================================================
 440
 441
 442 (defun permut_alterne (permut_coeff)
 443     (do ((sol (list (car permut_coeff)))
 444          (p (cdr permut_coeff) (cdr p))
 445          (c (cadr permut_coeff) (cadr p))) ; erreur ici corige'e en juin 92!!!
 446         ((null p)  sol)
 447         (and (pas-dans (mapcar #'- c) sol) (setq sol (cons c sol))))); Mars 93
 448
 449 ;ENCORE UNE FOIS LES COEFFICIENTS DE LA FONCTIONS DE TRANSFORMATION
 450 ; SONT SUREMENT NUMERIQUES : DE PLUS CELA NE MARCHE PAS AVEC RAT :
 451 ;        (and (pas-dans (mapcar #'$moins_sym c) sol) (setq sol (cons c sol)))))
 452
 453 ;; ATTENTION ICI TOUT DOIT-ETRE NUMERIQUE:
 454 (defun pas-dans (u list)
 455   (or  (null list)
 456        (and (not (equal u (car list)))
 457             (pas-dans u (cdr list)))))
 458
 459
 460 (defun resol_carre (degre puissances)
 461    (un-sur-deux (cdr (puireduc_init degre (cons (/ degre 2) puissances)))))
 462
 463 (defun un-sur-deux (liste); liste =(p1,p2,p3,....)
 464    (and liste (cons (cadr liste) (un-sur-deux (cddr liste)))))