share/sym/permut.lisp

   1 ; permut.lsp
   2
   3 ;       ***************************************************************
   4 ;       *                    MODULE SYM                               *
   5 ;       *       MANIPULATIONS DE FONCTIONS SYMETRIQUES                *
   6 ;       *        (version01: Commonlisp pour Maxima)                 *
   7 ;       *                                                             *
   8 ;       *                ----------------------                       *
   9 ;       *          Philippe ESPERET 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 ;           OBTENIR TOUTES LES PERMUTATIONS D'UN NUPLET D'ENTIER
  21 ;---------------------------------------------------------------------------
  22 ; appel : $permut
  23 ;========================================================================
  24 ;                        DECLARATIONS AU COMPILATEUR
  25 ;-------------------------------------------------------------------------
  26
  27 (in-package :maxima)
  28 (macsyma-module permut)
  29
  30 (progn (defvar lvar) (defvar permut))
  31 ; LES PERMUTATIONS
  32 ; $permut
  33 ;** FTOC. WARNING:
  34 ;             Franz Lisp declaration 'localf' is currently untranslated
  35 (progn)
  36 (defun $permut (nuplet)
  37   (cons '(mlist)
  38         (mapcar #'(lambda (permu) (cons '(mlist) permu))
  39                 (permut (cdr nuplet)))))
  40 ;cas particulier de permut avec les elem. de L 2 a 2 <>(pour voir)
  41 ;On place le car
  42 ; dans toutes les positions possibles
  43 ;(de permut0(L)
  44 ; (let (    (i 0) (reponse ()) (relais ())   )
  45 ;  (if (<= (length L) 1)
  46 ;      (list L)
  47 ;     (setq relais (permut0 (cdr L))
  48 ;             a        (car L))
  49 ;     (while (< i (length L))
  50 ;      (setq reponse
  51 ;            (append reponse
  52 ;                   (append (mapcar
  53 ;                           '(lambda(z)
  54 ;                                (insert0 a z i))
  55 ;                          relais)))
  56 ;              i (+ 1 i)))
  57 ;     reponse)))
  58 ; pour le cas ge'ne'ral c'est pareil sauf que j'augmente i assez
  59 ; a' chaque etape
  60 ; pour etre sur qu'il  y a moins de re'pe'tition : j'en obtiens encore trop
  61 ; ne'anmoins, ce surplus est du a' :
  62 ; des () qui viennent la'-dedans a' cause de insert : je les ote avec vire_nil
  63 ; des re'pe'titions malgre_tout:  je vais les e'liminer par un_de_chaque()
  64 (defun insertion (a l i)
  65   (if (null l) (list a)
  66       (if (equal (nth i l) a) nil
  67           (append (schur-firstn i l) (list a)
  68                   (flet ((franz.nthcdr (ind lis)
  69                              "equivalent to Franz Lisp 'nthcdr'."
  70                              (let ((evalind (eval ind)))
  71                                (if (minusp evalind) (cons nil lis)
  72                                    (nthcdr evalind lis)))))
  73                     (franz.nthcdr i l))))))
  74 ; dans la liste L il y a peut - etre des () au top niveau : je les vire
  75 ; chlorure de vire_nil
  76 (defun vire_nil (l)
  77   (and l
  78        (if (null (car l)) (vire_nil (cdr l))
  79            (cons (car l) (vire_nil (cdr l))))))
  80 ;ne garde que les e'le'ments de L 2 a' 2 distincts au top niveau
  81 (defun un_de_chaque (l)
  82   (and l
  83        (if (member (car l) (cdr l) :test #'equal)
  84            (un_de_chaque (cdr l))
  85            (cons (car l) (un_de_chaque (cdr l))))))
  86 ;retourne la liste de toutes les permutations de L (voir ex plus bas )
  87 (defun permut (l)
  88   (let ((i 0) (reponse nil) (relais nil) (a nil))
  89     (cond
  90       ((<= (list-length l) 1)
  91        (list l))
  92       (t
  93        (setq relais (permut (cdr l)) a (car l))
  94        (do ((i i
  95                (1+ i)))
  96            ((eql i (list-length l)) (un_de_chaque (vire_nil reponse)))
  97          (setq reponse
  98                (append reponse
  99                        (append (mapcar #'(lambda (z)
 100                                            (insertion a z i))
 101                                        relais)))))))))
 102 ; ex : ( permut '(1 1 2 2 3 3)) donne la liste des 90 positions concerne'es
 103
 104
 105
 106
 107
 108