share/sym/chbase.lisp

   1 ; Fichier chbase.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 ;                     CHANGEMENTS DE BASES :
  21
  22 ;         PUI2COMP, PUI2ELE, ELE2PUI, ELE2COMP, COMP2PUI, COMP2ELE
  23 ;=============================================================================
  24
  25 (in-package :maxima)
  26 (macsyma-module chbase)
  27
  28 (mdefprop $ele2pui
  29     ((lambda ()) ((mlist) $max $listei)
  30      ((mprog) (($operation)) (($ele2pui0) $max $listei)))
  31     mexpr)
  32 (add2lnc '(($ele2pui) $max $listei) $functions)
  33 ;                   PASSAGE DES ELEMENTAIRES AUX COMPLETES
  34 (mdefprop $ele2comp
  35     ((lambda ()) ((mlist) $max $listei)
  36      ((mprog) (($operation)) (($ele2comp_init) $max $listei)))
  37     mexpr)
  38 (add2lnc '(($ele2comp) $max $listei) $functions)
  39 ;*******  recherche des puissances entre min et max connaissant
  40 ;                    les elementaires et les puissances
  41 ; Recherche des dependance des fonction puissance avec celle d'indice
  42 ; inferieur aux cardinal.
  43 (mdefprop $puireduc
  44     ((lambda ()) ((mlist) $max $listpi)
  45      ((mprog) (($operation)) (($puireduc_init) $max $listpi)))
  46     mexpr)
  47 (add2lnc '(($puireduc) $max $listpi) $functions)
  48 ;----------------------------------------------------------------------------
  49 ;                Passage des puissances aux elementaires
  50 (mdefprop $pui2ele
  51     ((lambda ()) ((mlist) $max $listpi)
  52      ((mprog) (($operation)) (($pui2ele0) $max $listpi)))
  53     mexpr)
  54 (add2lnc '(($pui2ele) $max $listpi) $functions)
  55 ;            PASSAGE DES PUISSANCES AUX COMPLETES
  56 (mdefprop $pui2comp
  57     ((lambda ()) ((mlist) $max $listpi)
  58      ((mprog) (($operation)) (($pui2comp_init) $max $listpi)))
  59     mexpr)
  60 (add2lnc '(($pui2comp) $max $listpi) $functions)
  61 ;*******  recherche des elementaires entre min et max connaissant
  62 ;                    les puissances et les elementaires
  63 (mdefprop $elereduc
  64     ((lambda ()) ((mlist) $min $max $listei $listpi)
  65      ((mprog) (($operation)) (($elereduc0) $min $max $listei $listpi)))
  66     mexpr)
  67 ;                 A PARTIR DES COMPLETES
  68 ;       LES PREMIERES FONCTIONS ELEMENTAIRES
  69 (mdefprop $comp2ele
  70     ((lambda ()) ((mlist) $max $listhi)
  71      ((mprog) (($operation)) (($comp2ele_init) $max $listhi)))
  72     mexpr)
  73 (add2lnc '(($comp2ele) $max $listhi) $functions)
  74 ;        OBTENIR LES PREMIERES FONCTIONS PUISSANCES
  75 (mdefprop $comp2pui
  76     ((lambda ()) ((mlist) $max $listhi)
  77      ((mprog) (($operation)) (($comp2pui_init) $max $listhi)))
  78     mexpr)
  79 (add2lnc '(($comp2pui) $max $listhi) $functions)
  80 ;==============================================================
  81 ;            RECAPITULATIF DES FONCTIONS
  82
  83
  84 ; ELEMENTAIRES AUX PUISSANCES
  85 ; $ele2pui0  ele2pui
  86 ; $puireduc_init puireduc_init
  87 ;  $puireduc0 puireduc
  88 ; ELEMENTAIRES AUX COMPLETES
  89 ; $ele2comp_init ele2comp
  90 ; PUISSANCES AUX ELEMENTAIRES
  91 ; $pui2ele0 pui2ele
  92 ; $elereduc0 elereduc
  93 ; PUISSANCES AUX COMPLETES
  94 ; $pui2comp_init pui2comp
  95 ; COMPLETES AUX ELEMENTAIRES
  96 ;$comp2ele_init comp2ele
  97 ; COMPLETES AUX PUISSANCES
  98 ;$comp2pui_init comp2pui
  99
 100 ;                      DECLARATION DES FONCTIONS LOCALES
 101
 102 ;** FTOC. WARNING:
 103 ;             Franz Lisp declaration 'localf' is currently untranslated
 104
 105 ;                            VARIABLES LOCALES
 106 (progn)
 107 (progn
 108   (defvar lpui)
 109   (defvar lelem)
 110   (defvar lcomp)
 111   (defvar card)
 112   (defvar en)
 113   (defvar $pui2ele))
 114 ;______________________________________________________________________
 115 ;                 CHANGEMENTS DE BASES
 116 ;card le cardinal de l'alphabet
 117 ;lpui=(card p1 ....)
 118 ;lelem=(card e1 ...)    et on a e1=p1=h1
 119 ;lcomp = (card h1 ...)
 120 ;-------------------------------------------------------------------------
 121 ;                        A PARTIR DES ELEMENTAIRES
 122 ;-------------------------------------------------------------------------
 123 ;                  OBTENIR LES PREMIERES FONCTIONS PUISSANCES
 124 ;        -------------- Les fonctions d'appel ----------------
 125 ;entree sortie macsyma
 126
 127
 128 (defun $ele2pui0 (max $lelem); on cherche de 0 a max
 129                              ;$lelem=((mlist) card e1 e2....)
 130   (cons '(mlist) (ele2pui_init max (cdr $lelem))))
 131
 132 ;l'evaluation
 133
 134 ; si il n'y a rien a changer avec card numerique
 135 (defun ele2pui (max lelem)
 136   ($e_calbasepui (car lelem) 2 max (list (cadr lelem) (car lelem))
 137       lelem))
 138
 139 (defun ele2pui_init (max lelem)
 140   (let* ((lelem ($debut '$e lelem max)) (l (list-length lelem))
 141          (card (car lelem)))
 142     ($e_calbasepui card 2 max (list (cadr lelem) card)
 143         (if (< l (1+ max))
 144             (nreverse
 145                 ($complbase '$e (reverse lelem) l
 146                     (1+ max)))
 147             lelem))))
 148
 149
 150 (defun $puireduc_init (max $lpui)
 151   (cons '(mlist) (puireduc_init max (cdr $lpui))))
 152
 153 ; lpui=(card p1 .... p(l-1))
 154
 155 (defun puireduc_init (max lpui)
 156   (let ((card (car lpui)) (l (list-length lpui)))
 157     (cond
 158       ((< max l)
 159        lpui)
 160       ((or (not (numberp card))
 161            (not (< card max)))
 162        (rangpi2 max lpui l))
 163       ((< card l)
 164        ($e_calbasepui card l max (reverse lpui)
 165            (pui2ele card lpui '$girard)))
 166       (t (let ((lpui (rangpi2 card lpui l)))
 167            ($e_calbasepui card
 168                (1+ card)
 169                max (reverse lpui) (pui2ele card lpui '$girard)))))))
 170
 171 ;listpi =(p0,...,pm) et lg = m+1
 172
 173 (defun rangpi2 (n listpi lg)
 174   (if (< n lg)
 175       listpi (append listpi (rangpi3 n lg nil))))
 176 (defun rangpi3 (n i flistpi)
 177   (if (< n i)
 178       (nreverse flistpi)
 179       (rangpi3 n
 180                (1+ i)
 181                (cons (flet ((franz.concat (&rest args)
 182                                 "equivalent to Franz Lisp 'concat'."
 183                                 (values (intern
 184                                          (format nil "~{~A~}" args)))))
 185                        (franz.concat '$p i))
 186                      flistpi))))
 187
 188 (defun $puireduc0 (min max $lpui $lelem)
 189   (cons '(mlist) (puireduc min max (cdr $lpui) (cdr $lelem))))
 190
 191 (defun puireduc (min max lpui lelem)
 192   ($pm_ei2 min max lpui ($debut '$e lelem max)))
 193
 194 (defun $pm_ei2 (min max lpui lelem)
 195   (let ((card (car lelem)))
 196     (let ((l1 (list-length lpui)))
 197       (if (or (eql 0 l1) (eql 1 l1))
 198           (flet ((franz.nthcdr (ind lis)
 199                      "equivalent to Franz Lisp 'nthcdr'."
 200                      (let ((evalind (eval ind)))
 201                        (if (minusp evalind) (cons nil lis)
 202                            (nthcdr evalind lis)))))
 203             (franz.nthcdr min
 204                 (apply '$e_calbasepui
 205                        (cons card
 206                              ($pe_rallonge 2 min max
 207                                  (list (car lelem) (cadr lelem)) lelem)))))
 208           (flet ((franz.nthcdr (ind lis)
 209                      "equivalent to Franz Lisp 'nthcdr'."
 210                      (let ((evalind (eval ind)))
 211                        (if (minusp evalind) (cons nil lis)
 212                            (nthcdr evalind lis)))))
 213             (franz.nthcdr min
 214                 (apply '$e_calbasepui
 215                        (cons card ($pe_rallonge l1 min max lpui lelem)))))))))
 216
 217 ;-------------------   Les calculs -----------------------------------
 218 ; pm = (-1)^{m+1}e_m + somme (-1)^{i+1} e_i p_{m-i} pour i=1 a m-1
 219 ; lelem = (e0 e1 ...) rlpui=(e1 e0)
 220 ;----------------------------------------------------------------------
 221 ;m>=2 les plus grands pm sont devant
 222
 223 (defun $e_calbasepui (card min max rlpui lelem)
 224   (let ((lelem (chsigne lelem)))
 225     (do ((rlpui rlpui)
 226          (m min
 227             (1+ m)))
 228         ((< max m))
 229       (flet ((franz.attach (newelt oldlist)
 230                  "equivalent to Franz Lisp 'attach'."
 231                  (progn
 232                    (rplacd oldlist (cons (car oldlist) (cdr oldlist)))
 233                    (rplaca oldlist newelt))))
 234         (franz.attach
 235             ($e_calpui card rlpui lelem
 236                 (if (< card m)
 237                     0 ($mult_sym m (nth m lelem))))
 238             rlpui)))
 239     (nreverse rlpui)))
 240
 241 ; Calcul de la m-ieme fonction puissance
 242
 243 (defun $e_calpui (card rlpui lelem pn)
 244   (do ((j 1
 245           (1+ j))
 246        (base (cdr lelem) (cdr base)) (rbase rlpui (cdr rbase)) (pn pn))
 247       ((or (< card j)
 248            (null (cdr rbase)))
 249        pn)
 250     (setq pn ($add_sym pn ($mult_sym (car base) (car rbase))))))
 251
 252 ;---------------   mise sous bonne forme d'initialisation --------------
 253
 254 ; il manque des ei de i=l2 a max
 255 (defun $pe_rallonge (l1 min max list1 list2)
 256   (let ((l2 (list-length list2)))
 257     (list (max min l1) max
 258           (if (< l1 min)
 259             ; il manque les pi de i=l1 a min-1
 260               ($complbase '$p (reverse list1) l1 min) (reverse list1))
 261           (if (or (< l2 max)
 262                   (eql l2 max))
 263                  ; il manque des ei de i=l2 a max
 264               (nreverse
 265                   ($complbase '$e (reverse list2) l2
 266                       (1+ max)))
 267               list2))))
 268 ;-------------------------------------------------------------------------------
 269 ;               OBTENIR LES PREMIERES FONCTIONS COMPLETES
 270 ; p.14 du Macdonald : h_0 = e_0 = 1
 271 ; somme des (-1)^r e_r * h_{n-r} = 0 pour tout n >= 1
 272 ; lelem = liste des elementaires
 273 ; lcomp = liste des completes
 274 ;-------------------------------------------------------------------------------
 275 (defun $ele2comp_init (max $lelem)
 276   (cons '(mlist) (ele2comp_init max (cdr $lelem))))
 277
 278 (defun ele2comp_init (max lelem)
 279   (let* ((lelem ($debut '$e lelem max)) (l (list-length lelem)))
 280     (ele2comp max
 281         (if (< l (1+ max))
 282             (nreverse
 283                 ($complbase '$e (reverse lelem) l
 284                             (1+ max)))
 285             lelem))))
 286
 287 ; si il n'y a rien a completer dans lelem
 288
 289 (defun ele2comp (max lelem)
 290   (e_calbasecomp (car lelem) 2 max (list (cadr lelem) (car lelem))
 291       lelem))
 292
 293 ; on utilise la meme fonction pour le passage des elementaires aux
 294 ; puissances : e_calpui.
 295
 296
 297 (defun e_calbasecomp (card min max rbarrivee badepart)
 298         ;m>=2 les plus grands pm sont devant
 299   (let ((badepart (chsigne badepart)))
 300     (do ((rbarrivee rbarrivee)
 301          (m min (1+ m)))
 302             ((< max m))
 303       (flet ((franz.attach (newelt oldlist)
 304                  "equivalent to Franz Lisp 'attach'."
 305                  (progn
 306                    (rplacd oldlist (cons (car oldlist) (cdr oldlist)))
 307                    (rplaca oldlist newelt))))
 308         (franz.attach
 309             ($e_calpui card rbarrivee badepart
 310                 (if (< card m)
 311                     0 (nth m badepart)))
 312             rbarrivee)))
 313     (nreverse rbarrivee)))
 314
 315 ;-------------------------------------------------------------------------
 316 ;                 A PARTIR DES FONCTIONS PUISSANCES
 317 ;--------------------------------------------------------------------------
 318 ;           OBTENIR LES PREMIERES FONCTIONS SYMETRIQUES ELEMENTAIRES
 319 ; Si on ne cherche qu'une seule fonction symetrique elementaire
 320 ; on utilise une formule close. Cela sera specifie par un drapeau
 321 ; pour pui2ele . Il sera avec Girard ou close.
 322 ; $lpui = ((mlist) p0 p1 ...)
 323 ;-------------------------------------------------------------------------
 324 ; on cherche de 0 a max
 325 (defun $pui2ele0 (max $lpui)
 326   (cond
 327     ((equal '$girard $pui2ele)
 328      (cons '(mlist) (pui2ele_init max (cdr $lpui))))
 329     (t (pui2ele_init max (cdr $lpui)))))
 330
 331 ; si il y a a rajouter
 332 (defun pui2ele_init (max lpui)
 333   (let* ((lpui ($debut '$p lpui max)) (l (list-length lpui)))
 334     (pui2ele max
 335              (if (< l (1+ max))
 336                  (nreverse
 337                      ($complbase '$p (reverse lpui) l
 338                          (1+ max)))
 339                  lpui)
 340              $pui2ele)))
 341
 342 ; si il n'y a rien a rajouter dans la liste des fonctions puissances.
 343 (defun pui2ele (max lpui $pui2ele)
 344   (cond
 345     ((equal '$girard $pui2ele) (girard_pui2ele max lpui))
 346     (t (cond
 347          ((< (car lpui) max)  0)
 348          (t (macdonald_pui2ele max (cdr lpui)))))))
 349
 350 ;.............. AVEC LA FORMULE CLOSE ..................................
 351
 352 (defun macdonald_pui2ele (n lpui)
 353   (let ((en 0))
 354     (macdonald2 n 0 (list (cons n (reverse lpui)) (expt -1 n)))
 355     en))
 356
 357 (defun macdonald2 (exposant ote poule)
 358   (cond
 359                       ;on a une partition de poids n
 360     ((eql 0 exposant) (setq en ($add_sym en (termine poule))))
 361     (t (macdonald2 ote
 362            (max 0
 363                 (- (* 2 ote) exposant))
 364            (chbase-met exposant ote poule))
 365        (let ((ote (1+ ote)))
 366          (and (< ote exposant)
 367               (macdonald2 exposant ote poule))))))
 368
 369 ; termine ramene epsilon_I*z_I*p_I avec |I|=n
 370 ; remarque : (nth i liste) ramene le i+1 ieme element de la liste.
 371
 372 (defun termine (poule)
 373   (let* ((aj+1 (cadddr poule)) (mj+1 (caddr poule)) (rlpui (car poule))
 374          (puiaj+1 (nth (- (car rlpui) aj+1)
 375                        (cdr rlpui))))
 376     ($divi_sym ($mult_sym ($exp_sym puiaj+1 mj+1) (car (last poule)))
 377         (* (cadr poule) (expt aj+1 mj+1) (factorielle mj+1)))))
 378
 379 ; chbase-met construit au fur et a mesure epsilon_I*z_I et p_I pour |I|
 380 ; strictement inferieure a n
 381
 382 ; au depart poule = ( (n  pn ... p1) (-1)^n)
 383 ; poule = (rlpui epsilon_I*z_I*(-1)^{mj+1} mj+1 aj+1 p_I)
 384 ; ou I = (a1 m1 ... aj mj) = [partition](2) avec n >= a1
 385 ; et rlpui = (aj paj pa(j-1) ... p2 p1)
 386
 387
 388
 389 (defun chbase-met (exposant ote poule)
 390   (cond
 391     ((null (cddr poule))
 392      (list (car poule)
 393            (* (cadr poule) -1)
 394            1
 395            (- exposant ote)
 396            1))
 397     (t (let ((ak (- exposant ote)); nouvelle part obtenue
 398              (aj+1 (nth 3 poule)); part courante, multiplicite en cours
 399                                  ; de calcul
 400              (rlpui (car poule))
 401              (coe (* -1 (cadr poule)))) ;on change la signature a chaque
 402                                              ; nouvelle part obtenue
 403      ;puisque la longueur augmente de 1.
 404          (cond
 405            ((eql ak aj+1)
 406             (cons rlpui
 407                   (cons coe ; cht de signature
 408                         (cons (1+ (caddr poule)) ; multiplicite + 1
 409                               (cdddr poule)))))
 410 ; on doit calculer epsilon_J et z_J ou J= aj+1^{mj+1} U I
 411 ; et p_J = paj+1^{mj+1}*p_I :
 412            (t (let ((nxrlpui (flet ((franz.nthcdr (ind lis)
 413                                      "equivalent to Franz Lisp 'nthcdr'."
 414                                      (let ((evalind (eval ind)))
 415                                        (if (minusp evalind)
 416                                         (cons nil lis)
 417                                         (nthcdr evalind lis)))))
 418                                (franz.nthcdr
 419                                    (- (car rlpui) aj+1)
 420                                    (cdr rlpui))))
 421                     (mj+1 (nth 2 poule)))
 422                 (list (cons aj+1 nxrlpui) ;avant derniere part
 423                       ; calcul du coefficient
 424                       (* coe (expt aj+1 mj+1) (factorielle mj+1))
 425                       1  ; ak aurra une multiplicite >=1
 426                       ak
 427                       ($mult_sym ($exp_sym (car nxrlpui) ;p(a(j+1))
 428                                            mj+1)
 429                           (car (last poule))))))))))) ;p_I
 430
 431 ;................... AVEC LA FORMULE DE GIRARD ....................
 432
 433
 434 (defun girard_pui2ele (max lpui)
 435   (let ((card (car lpui)) (rlelem (list (cadr lpui) (car lpui))))
 436     (if (< card max) ; forcement numerique (cf $debut)
 437         (nconc ($p_calbaselem 2 card rlelem lpui)
 438                (make-list
 439                    (- max card)
 440                    :initial-element 0))
 441         ($p_calbaselem 2 max rlelem lpui))))
 442
 443 (defun $elereduc0 (min max lelem lpui)
 444   (cons '(mlist) (elereduc min max (cdr lelem) (cdr lpui))))
 445
 446 (defun elereduc (min max lelem lpui)
 447   ($troncelem min max lelem ($debut '$p lpui max)))
 448
 449 ;bug!!!!!
 450 (defun $troncelem (min max lelem lpui)
 451   (let ((card (car lpui)))
 452     (if (< card max)
 453         (if (< card min)
 454             (nconc lelem
 455                    (make-list
 456                        (1+ (- max min))
 457                        :initial-element 0)) ;bug!!!!!
 458             (nconc ($p_baselem min card lelem lpui)
 459                    (make-list
 460                        (- max card)
 461                        :initial-element 0)))
 462         ($p_baselem min max (cons (car lpui) (cdr lelem)) lpui))))
 463
 464 (defun $p_baselem (min max lelem lpui)
 465   (let ((l1 (list-length lelem)))
 466     (if (or (eql 0 l1) (eql 1 l1))
 467         (flet ((franz.nthcdr (ind lis)
 468                    "equivalent to Franz Lisp 'nthcdr'."
 469                    (let ((evalind (eval ind)))
 470                      (if (minusp evalind) (cons nil lis)
 471                          (nthcdr evalind lis)))))
 472           (franz.nthcdr min
 473               (apply '$p_calbaselem
 474                      ($ep_rallonge 2 min max
 475                          (list (car lpui) (cadr lpui)) lpui))))
 476         (flet ((franz.nthcdr (ind lis)
 477                    "equivalent to Franz Lisp 'nthcdr'."
 478                    (let ((evalind (eval ind)))
 479                      (if (minusp evalind) (cons nil lis)
 480                          (nthcdr evalind lis)))))
 481           (franz.nthcdr min
 482               (apply '$p_calbaselem
 483                      ($ep_rallonge l1 min max lelem lpui)))))))
 484
 485 (defun $p_calbaselem (min max rlelem lpui) ;m>=2
 486   (let ((lpui (chsigne lpui)))
 487     (do ((rlelem rlelem)
 488          (m min
 489             (1+ m)))
 490         ((< max m))
 491       (flet ((franz.attach (newelt oldlist)
 492                  "equivalent to Franz Lisp 'attach'."
 493                  (progn
 494                    (rplacd oldlist (cons (car oldlist) (cdr oldlist)))
 495                    (rplaca oldlist newelt))))
 496         (franz.attach
 497             ($divi_sym ($p_calelem rlelem lpui (nth m lpui)) m) rlelem)))
 498     (nreverse rlelem)))
 499
 500 (defun $p_calelem (rlelem lpui en)
 501   (do ((j 1
 502           (1+ j))
 503        (base (cdr lpui) (cdr base)) (rbase rlelem (cdr rbase)) (en en))
 504       ((null (cdr rbase)) en)
 505     (setq en ($add_sym en ($mult_sym (car base) (car rbase))))))
 506
 507
 508 ; il manque des ei de i=l2 a max
 509 (defun $ep_rallonge (l1 min max list1 list2)
 510   (let ((l2 (list-length list2)))
 511     (list (max min l1) max
 512           (if (< l1 min)
 513                 ; il manque les pi de i=l1 a min-1
 514               ($complbase '$e (reverse list1) l1 min) (reverse list1))
 515           (if (or (< l2 max)
 516                   (eql l2 max))
 517                ; il manque des ei de i=l2 a max
 518               (nreverse
 519                   ($complbase '$p (reverse list2) l2
 520                       (1+ max)))
 521               list2))))
 522
 523 ;-------------------------------------------------------------------------
 524 ;            OBTENIR LES PREMIERES FONCTIONS COMPLETES
 525 ; p.16 du Macdonald : h_0 = e_0 = 1  ,
 526 ; n*h_n = somme des  p_r * h_{n-r} pour tout r = 1 a n
 527 ; lpui = liste des puissances
 528 ; lcomp = liste des completes
 529 ;-------------------------------------------------------------------------
 530
 531 (defun $pui2comp_init (max $lpui)
 532   (cons '(mlist) (pui2comp_init max (cdr $lpui))))
 533
 534 (defun pui2comp_init (max lpui)
 535   (let* ((lpui ($debut '$p lpui max)) (l (list-length lpui)))
 536     (pui2comp max
 537         (if (< l (1+ max))
 538             (nreverse
 539                 ($complbase '$p (reverse lpui) l
 540                     (1+ max)))
 541             lpui))))
 542 ; si il n'y a rien a completer dans lpui
 543
 544 (defun pui2comp (max lpui)
 545   (p_calbasecomp (car lpui) 2 max (list (cadr lpui) (car lpui)) lpui))
 546
 547 ; on utilise la meme fonction pour le passage des puissances aux
 548 ; elemantaires : p_calelem
 549
 550 (defun p_calbasecomp (card min max rlcomp lpui)
 551            ;m>=2 les plus grands pm sont devant
 552   (do ((rlcomp rlcomp)
 553        (m min
 554           (1+ m)))
 555       ((< max m))
 556     (flet ((franz.attach (newelt oldlist)
 557                "equivalent to Franz Lisp 'attach'."
 558                (progn
 559                  (rplacd oldlist (cons (car oldlist) (cdr oldlist)))
 560                  (rplaca oldlist newelt))))
 561       (franz.attach ($divi_sym ($p_calelem rlcomp lpui (nth m lpui)) m)
 562           rlcomp)))
 563   (nreverse rlcomp))
 564
 565 ;---------------------------------------------------------------------------
 566 ;                A PARTIR DES FONCTIONS SYMETRIQUES COMPLETES
 567 ;---------------------------------------------------------------------------
 568 ;           OBTENIR LES PREMIERES FONCTIONS SYMETRIQUES ELEMENTAIRES
 569 ; CF. ele2comp
 570
 571 (defun $comp2ele_init (max $lcomp)
 572   (cons '(mlist) (comp2ele_init max (cdr $lcomp))))
 573
 574 (defun comp2ele_init (max lcomp)
 575   (let* ((lcomp ($debut '$h lcomp max)) (l (list-length lcomp)))
 576     (comp2ele max
 577         (if (< l (1+ max))
 578             (nreverse
 579                 ($complbase '$h (reverse lcomp) l
 580                     (1+ max)))
 581             lcomp))))
 582
 583 (defun comp2ele (max lcomp)
 584   (let ((card (car lcomp)) (rlelem (list (cadr lcomp) (car lcomp))))
 585     (if (< card max); forcement numerique (cf $debut)
 586         (nconc (c_calbaselem 2 card rlelem lcomp)
 587                (make-list
 588                    (- max card)
 589                     :initial-element 0))
 590         (c_calbaselem 2 max rlelem lcomp))))
 591
 592 ; On utilise la fonction $p_calelem du passage des elementaires
 593 ; aux puissances.
 594
 595 (defun c_calbaselem (min max rlelem lcomp)
 596             ;m>=2
 597   (let ((lcomp (chsigne lcomp)))
 598     (do ((rlelem rlelem)
 599          (m min
 600             (1+ m)))
 601         ((< max m))
 602       (flet ((franz.attach (newelt oldlist)
 603                  "equivalent to Franz Lisp 'attach'."
 604                  (progn
 605                    (rplacd oldlist (cons (car oldlist) (cdr oldlist)))
 606                    (rplaca oldlist newelt))))
 607         (franz.attach ($p_calelem rlelem lcomp (nth m lcomp)) rlelem)))
 608     (nreverse rlelem)))
 609 ;______________________________________________________________________
 610 ;           OBTENIR LES PREMIERES FONCTIONS PUISSANCES
 611 ; CF. pui2comp
 612 ;______________________________________________________________________
 613
 614 (defun $comp2pui_init (max $lcomp)
 615   (cons '(mlist) (comp2pui_init max (cdr $lcomp))))
 616
 617 (defun comp2pui_init (max lcomp)
 618   (let* ((lcomp ($debut '$h lcomp max)) (l (list-length lcomp)))
 619     (comp2pui max
 620         (if (< l (1+ max))
 621             (nreverse
 622                 ($complbase '$h (reverse lcomp) l
 623                     (1+ max)))
 624             lcomp))))
 625
 626 (defun comp2pui (max lcomp)
 627   (let ((card (car lcomp)) (rlpui (list (cadr lcomp) (car lcomp))))
 628     (c_calbasepui 2 max rlpui lcomp)))
 629
 630 ; On utilise la fonction $p_calelem du passage des puissances
 631 ; aux elementaires.
 632
 633 (defun c_calbasepui (min max rlpui lcomp)
 634         ;m>=2
 635   (let ((-rlpui (mapcar '$moins_sym rlpui)))
 636     (do ((-rlpui -rlpui)
 637          (m min
 638             (1+ m)))
 639         ((< max m))
 640       (flet ((franz.attach (newelt oldlist)
 641                  "equivalent to Franz Lisp 'attach'."
 642                  (progn
 643                    (rplacd oldlist (cons (car oldlist) (cdr oldlist)))
 644                    (rplaca oldlist newelt))))
 645         (franz.attach
 646             ($moins_sym
 647                 ($p_calelem -rlpui lcomp ($mult_sym m (nth m lcomp))))
 648             -rlpui)))
 649     (nreverse (mapcar '$moins_sym -rlpui))))
 650
 651 ;----------------------------------------------------------------------------
 652 ;                       Fonctions en commun
 653 ; tenir compte du cardinal de l'alphabet lorsque l'on doit completer
 654 ; sur les elementaires on ne completera que jusqu'a ce
 655 ; cardinal .
 656
 657 (defun $complbase (base rlist i sup)
 658   (let ((card (car (last rlist))))
 659     (if (and (equal '$e base)
 660              (< card (1- sup))) ;forcement numerique
 661         ($complbase2 base rlist i
 662             (1+ card))
 663         ($complbase2 base rlist i sup))))
 664
 665 (defun $complbase2 (base rlist i sup)
 666   (if (eql i sup) rlist
 667       ($complbase base
 668           (cons (flet ((franz.concat (&rest args)
 669                            "equivalent to Franz Lisp 'concat'."
 670                            (values (intern (format nil "~{~A~}" args)))))
 671                   (franz.concat base i))
 672                 rlist)
 673           (1+ i)
 674           sup)))
 675
 676 (defun $debut (base list max)
 677   (let ((card (if (numberp (car list)) (car list) max)))
 678     (if (or (null list) (null (cdr list)))
 679         (list card
 680               (flet ((franz.concat (&rest args)
 681                          "equivalent to Franz Lisp 'concat'."
 682                          (values (intern (format nil "~{~A~}" args)))))
 683                 (franz.concat base 1)))
 684         (cons card (cdr list)))))
 685
 686 (defun chsigne (liste)
 687   (let ((test t))
 688     (mapcar #'(lambda (b)
 689                (if (setq test (not test)) b ($mult_sym -1 b)))
 690             liste)))