Publicité
+ Répondre à la discussion
Page 7 sur 8 PremièrePremière ... 345678 DernièreDernière
Affichage des résultats 121 à 140 sur 158
  1. #121
    Inactif
    Inscrit en
    juillet 2005
    Messages
    1 958
    Détails du profil
    Informations personnelles :
    Âge : 49

    Informations forums :
    Inscription : juillet 2005
    Messages : 1 958
    Points : 2 148
    Points
    2 148

    Par défaut

    Citation Envoyé par InOCamlWeTrust Voir le message
    [...]
    Autre conseil : ne suis pas les "conseils" de Knuth. Ses algorithmes sont inutilement compliqués. On peut faire tout aussi mieux sans pile ni impérativité.
    Knuth n'est effectivement pas un modèle à suivre. Il écrit du code illisible, sans conception, complètement incompréhensible, mais qui marche du premier coup ou presque -_- En tout cas, il est une exception

  2. #122
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    Je parlais plus des algorithmes en eux-mêmes que des codes. Knuth possède une façon de raisonner quasi-exclusivement tournée vers l'impérativité, et programme selon des dogmes qui aujourd'hui sont faux : gestion de pile à la main parce que c'est soi-disant plus rapide, tableaux dans tous les sens, méthode de la sentinelle qui n'est quasiment jamais applicable, etc...

    Pour ses codes, je suis d'accord, ils sont tout simplement affreux. Mais je ne suis pas sûr qu'ils aient marché du premier coup lorsqu'il les a écrits !

    Cependant, si il y a une chose a retenir des publications de Knuth sur le sujet, c'est la borne supérieure pour la hauteur d'un AVL : c'est très intéressant pour connaître la taille maximale, à l'octet près, de la pile. C'est nécessaire lorsque l'on doit programmer des fonctions que l'on ne peut faire sans gestion de pile explicite, même en style fonctionnel, comme la comparaison de deux AVL.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  3. #123
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 573
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 573
    Points : 2 448
    Points
    2 448

    Par défaut

    C'est pareil du côté de Niklaus Wirth (Algorithms and Data Structures), pas utilisable car le code est trop impératif pour du Caml.

    ce ne sont pas des AVL : la grande caractéristique des AVL est qu'il n'est pas nécessaire de stocker la hauteur, mais juste l'équilibrage (gauche, équilibré ou droit). En effet, la différence de hauteur entre les deux jambes étant d'au plus un, cette information suffit.
    La grande caractéristique d'un AVL c'est qu'il n'est jamais plus profond qu'un arbre de Fibonacci.
    On peut éventuellement coder l'équilibrage sur 2 bits (et même placer cette information dans les bits de poids faible du pointeur puisque tout pointeur 32bits est un multiple de 4). J'ai opté pour une solution différente, à savoir utiliser set_left et set_right de façon à ne pas calculer la hauteur des arbres vides. À mon avis ça rend le code plus lisible, c'est important pour une rubrique "code source".

    Pour ce qui est de la performance :
    • je ne vois pas l'intérêt à comparer une implantation impérative avec une implantation fonctionnelle
    • je n'ai pas d'autre implantation impérative pour faire une comparaison
    • quel échantilon suis-je sensé tester ? une insertion de clés randomisées ? dans ce cas un ABR est plus performant qu'un AVL. donc on teste un cas qu'en fait on éviterait en pratique. une insertion de clés croissantes ? dans ce cas un arbre de Braun est plus performant qu'un AVL. alors quel échantillon ?
    • je ne me sens en concurrence ni avec les implantations en C ou en Haskell, ni avec les implémentations en Caml qui n'existent pas (arbres de Braun) ou que personne n'a jamais vu (même sous forme compilée)

    gorgonite m'a déjà demandé de faire des tests de performance sur mon arbre de Braun. Ça ne sert à rien si on ne me dit ni contre quelle implantation impérative ni avec quel échantillon.
    Il faut arrêter l'exigence kafkaienne des benchs que je devrais faire contre du code qui n'a rien à voir ou contre le code que vous gardez pour vous.

    Il est, malheureusement, très rare de voir une librairie complète contenant une véritable implantation efficace de cette merveilleuse structure de données.
    Vu l'orientation 'pure' de la stdlib, OCaml-Reins et OCaml batteries la pénurie d'implantations impératives est là pour durer.

    Le gros avantage des AVL réside dans leur performance : il est donc inutile d'en implanter si on peut avoir mieux avec autre chose.
    On peut forcément avoir mieux avec autre chose quand l'ordre d'insertion n'est pas favorable aux AVL. L'optimisation ne peut que bouger la limite au delà de laquelle l'AVL n'est plus le meilleur choix même si c'est un très bon choix sur un très large spectre.

    les fonctions sur AVL ne sont d'aucune utilité si elles ne sont pas accompagnées d'une fonction de suppression d'élément (c'est en fait LA fonction difficile à implanter)
    Il me manque plus que la suppression. Je ne peux pas prendre en compte tes conseils d'implantation si je n'ai pas la garantie qu'ils ne rendront pas encore plus difficile l'équilibrage dans les opérations ensemblistes union / intersection / différence. L'opération d'union a une importance particulière, elle permet une insertion groupée bien plus rapide qu'élément par élément.
    Du même auteur: le cours OCaml, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  4. #124
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    A tes commentaires je vois que, malgré ta vraie volonté de bien faire et surtout de progresser, tu manques cruellement d'expérience.

    Je vais essayer de répondre en plusieurs points.


    1- J'ai rien compris quand tu parles de set_left ou set_right.

    Bien-sûr qu'il ne faut pas calculer la hauteur (qui est une opération en Thêta(log n) dans ce cas, par opposition aux arbres binaires normaux) ! Mais la SEULE information dont tu as besoin est l'équilibrage : mettre la hauteur, c'est tout simplement ajouter de la complexité à des algorithmes qui n'en ont pas besoin (car à chaque rééquilibrage il faudra faire attention à mettre à jour la donnée). Mettre à jour un équilibrage, c'est 1000 fois plus simple.

    De plus, n'oublie pas que les gens regardent le code avant de l'utiliser (c'est mon cas) : si tu tombes sur des gens qui s'y connaissent (et il y en a un paquet) et qui tombent sur des AVL stockant la hauteur à chaque noeud, je peux te garantir qu'ils ne chercheront pas à aller plus loin. Pourquoi ? Tout simplement parce que stocker une hauteur quand tu as besoin de stocker 3 valeurs au plus, c'est stocker des données inutiles, et ça ne jette pas beaucoup de crédit sur le développeur...


    2- Concernant la performance
    Ne fait surtout pas l'impasse sur les tests de performance. Si une librairie AVL (je précise bien AVL) n'est pas performante, ou si il existe un gros gap par rapport, par exemple, à une fonctionnalité équivalente de la librairie standard, tu peux être sûr que personne ne l'utilisera. Personne n'utilisera une librairie AVL tout simplement parce que c'est des AVL et que ça fait joli. On utilise des AVL parce qu'il s'agit de la structure de données entièrement dynamique (donc hors tables de hachage) la plus performante dans le cas général. C'est pas pour rien si on va l'utiliser jusques dans les OS comme Solaris !

    Pour procéder, je te conseille de commencer par tester ton implantation (impérative) contre l'implantation de la librairie standard (entièrement fonctionnelle, donc en principe beaucoup plus lente). Si tu ne gagnes rien en termes de performances (utilise des données TRES grandes, jusqu'à bourrer toute ta mémoire, mais sans arriver au swap), alors ton code est intrinsèquement lent et mauvais.

    Sinon, si ton code est plus rapide, je te conseille d'en implanter une version entièrement fonctionnelle. Si elle est plus rapide, c'est bon, sinon, il faudra que tu travailles jusqu'à être plus rapide que la librairie standard (il le faut, sinon ça sert à rien !). Tu pourras alors répercuter les modifications sur la version impérative : tu devrais alors beaucoup gagner en vitesse.

    Les tests doivent être de toutes natures : aléatoires, éléments répétés (pour voir si ils sont dupliqués ou non), en ordre croissant ou pas, ensembles vides... enfin tout, quoi ! Et pour insérer des éléments croissants (ou décroissants), je connais une structure imbattable : la liste ! Pour ce qui est des autres arbres cités, je pense que si on les coupait on ferait un joli feu de bois !

    Garde à l'esprit que personne n'utilisera une librairie AVL si elle n'est pas plus rapide que ce qui existe déjà.


    3- Il te manque ENCORE la suppression. Crois-moi, c'est beaucoup plus délicat que l'insertion. Une fonction de validation te sera d'un grand secours.

    D'autant plus que sans cette fonction, on ne peut rien faire.

    L'autre fonction difficile (très courte quand elle est bien écrite, mais délicate) est la comparaison de deux ensembles. L'union, l'intersection etc... devraient prendre moins de temps qu'ouvrir une canette de Coca.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  5. #125
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 573
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 573
    Points : 2 448
    Points
    2 448

    Par défaut

    Au point où j'en suis je vais me contenter d'une version correcte.
    On verra plus tard pour les perfs.

    Est-ce que ce code te paraît correct
    (moyennant les fonctions d'équilibrage appropriées)
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    module MakeBase (Ord: Ordered)
    =
    struct
    
      type key = Ord.ordered
      type 'a tree =
        'a node option
      and 'a node =
        {
        mutable left: 'a tree; mutable right: 'a tree; mutable height: int;
        key: key; mutable item: 'a;
        }
    
      (* mutable *)
        
      let balance n =
        n (* but balanced *)
    
      let insert k x t =
        let result = ref true in
        let rec loop t =
          match t with 
          | None ->
              {left = None; right = None; height = 1; key = k; item = x}
          | Some n -> 
              if Ord.compare k n.key < 0 then
                (n.left <- Some (loop n.left); balance n)
              else if Ord.compare k n.key > 0 then
                (n.right <- Some (loop n.right); balance n)
              else begin
                n.item <- x; result := false; n
              end
        in Some (loop t), !result    
    
      let rec remove_min t =
        match t.left with
        | None   -> t,t.right
        | Some n -> let m,l = remove_min n in t.left <- l; m,Some (balance t)
    
      let rec remove k = function
        | None ->
            None
        | Some n -> 
            if Ord.compare k n.key < 0 then
              (n.left <- remove k n.left; Some (balance n))
            else if Ord.compare k n.key > 0 then
              (n.right <- remove k n.right; Some (balance n))
            else
              match n.left,n.right with
              | None,t | t,None -> t
              | l,Some t ->
                  let m,r = remove_min t in
                  m.left <- l; m.right <- r;
                  Some (balance m)
    
      (* immutable *)
            
      let balanced l k x r =
        Some {left = l; right = r; height = 1; key = k; item = x}
        (* but balanced *)
    
      let rec add k x = function
        | None ->
            Some {left = None; right = None; height = 1; key = k; item = x}
        | Some n -> 
            if Ord.compare k n.key < 0 then
              balanced (add k x n.left) n.key n.item n.right
            else if Ord.compare k n.key > 0 then
              balanced n.left n.key n.item (add k x n.right)
            else
              Some {n with item = x}
              
      let rec delete_min t = 
        match t.left with
        | None   -> t.key,t.item,t.right
        | Some n -> let k,x,l = delete_min n in k,x,balanced l t.key t.item t.right
        
      let rec delete k = function
        | None ->
            None
        | Some n -> 
            if Ord.compare k n.key < 0 then
              balanced (delete k n.left) n.key n.item n.right
            else if Ord.compare k n.key > 0 then
              balanced n.left n.key n.item (delete k n.right)
            else
              match n.left,n.right with
              | None,t | t,None -> t
              | l,Some t ->
                  let k,x,r = delete_min t
                  in  balanced l k x r
    
    end
    L'union, l'intersection etc... devraient prendre moins de temps qu'ouvrir une canette de Coca.
    C'est tant mieux. Tu vas pouvoir m'expliquer pourquoi tout ce que je n'ai pas compris. Par exemple pourquoi le union de Set.Make ne fait qu'un seul split tandis que le union de Implementing Sets Efficiently in a Functional Language en fait deux ?
    Du même auteur: le cours OCaml, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  6. #126
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    Je suis réellement désolé SpiceGuid, mais ce que tu as fait n'a réellement rien à voir avec des AVL, même si je n'en conteste absolument pas la cohérence et le fait que le code soit juste. Je me demande même si on parle bien de la même chose.

    Les AVL sont caractérisés par le fait que sous-arbre droit et gauche sont de hauteur différant d'au plus un, de sorte que l'on conserve la donnée d'équilibrage au niveau des noeuds. Pas la hauteur, car ça sert à rien. L'insertion et suppression demandent de faire des rotations en cascade suivant les positions et équilibres des noeuds courants N et de ceux aux niveaux N-1 et N-2. Je ne reconnais pas vraiment ces opérations dans ton code.

    Pour ce qui est de l'algorithme de suppression, je confirme qu'il est beaucoup plus long et difficile que ce que tu as fait. Au passage, si je retourne sur la Linux de mon vieil ordinateur, je pourrais te faire suivre ce que j'avais fait à l'époque, tant en C qu'en OCaml.

    Enfin, concernant l'union et ses copains, une simple itération sur les éléments du premier AVL composée avec l'insertion dans le deuxième arbre suffit à avoir des résultats corrects. Il existe peut-être, pour les AVL, des algorithmes plus fins, mais j'aimerais bien savoir si en termes de complexité temporelle, donc asymptotique, on y gagne vraiment, du fait des nombreuses rotations que l'on doit opérer pour maintenir la structure équilibrée. Naïvement, on est en O(n log m), ce qui me laisse penser qu'il s'agit d'une complexité déjà optimale étant donné que la structure finale DOIT ETRE un arbre ed tri... donc qu'il s'agit, indirectement, d'un algorithme de pseudo-tri.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  7. #127
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 573
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 573
    Points : 2 448
    Points
    2 448

    Par défaut

    Les AVL sont caractérisés par le fait que sous-arbre droit et gauche sont de hauteur différant d'au plus un
    Nous parlons bien de la même chose.
    C'est juste que c'est mon style qui perturbe tes repères.
    Les algos sont exactement les mêmes que pour un arbre non-équilibré, il suffit simplement d'ajouter un appel à une fonction d'équilibrage.
    La suppression ne présente aucune difficulté particulière, c'est l'algo habituel pour un arbre binaire.
    C'est pareil dans OCaml-Reins, dans les tutoriels en Java et partout ailleurs où l'on cherche la lisibilité maximale.
    http://prevert.upmf-grenoble.fr/Prog...arbresAVL.html


    Les opérations ensemblistes rapides sont codées à l'aide de l'opération de fission (voir mon code merge/divide du post #79).
    Et elles sont vraiment plus rapides que la version naive.
    L'union rapide est particulièrement utile puisqu'elle permet d'accélérer l'insertion par lot.
    Quand tu dois fusionner deux ensembles triés cette opération n'est pas un tri (c'est le principe à la base du tri-fusion).
    Du même auteur: le cours OCaml, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  8. #128
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    Tu as raison pour l'union : ce n'est pas un algorithme de tri.

    Par contre, je ne comprends pas ton raisonnement en ce qui concerne les AVL. Où effectues-tu les opérations d'équilibrage et de rotation des sous-arbres ?

    Je continue à dire, parce que je l'ai vu de nombreuses fois, parce que je l'ai pratiqué et parce que j'ai vu beaucoup de biblitohèques sans cette fonction, que la suppression est de loin plus délicate que l'insertion. Même Knuth, dont le style de programmation est contestable mais dont le travail sur la question en termes de résultats et d'algorithmes est remarquable, la qualifie de complexe. Tu ne peux pas la coder en deux coups de cuillère à pot.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  9. #129
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 573
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 573
    Points : 2 448
    Points
    2 448

    Par défaut

    L'astuce c'est d'utiliser un constructeur "équilibré".

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
      let balance n =
        match n.left,n.right with
        | None,None -> 0
        | Some t,None -> t.height 
        | None,Some t -> - t.height
        | Some a,Some b -> a.height - b.height
        
      let node l k x r =    
        Some {
        left = l; right = r; key = k; item = x;
        height = match l,r with
               | None,None -> 1
               | Some t,None | None,Some t -> t.height + 1 
               | Some a,Some b -> max a.height b.height + 1 }
      
      let rotated l k x r =
        let rotated_left a =
          match a.right with
          | Some b when balance a < 0 ->
            (* double left rotation *)
            node (node a.left a.key a.item b.left) b.key b.item (node b.right k x r)
          | _ ->
            (* simple left rotation *)
            node a.left a.key a.item (node a.right k x r)
        and rotated_right c =
          match c.left with
          | Some b when balance c > 0 ->
            (* double right rotation *)
            node (node l k x b.left) b.key b.item (node b.right c.key c.item c.right)
          | _ ->
            (* simple right rotation *)
            node (node l k x c.left) c.key c.item c.right
        in
        match l,r with
        | Some a,None when a.height > 1 -> rotated_left a
        | None,Some c when c.height > 1 -> rotated_right c
        | Some a,Some c when a.height > c.height + 1 -> rotated_left a
        | Some a,Some c when c.height > a.height + 1 -> rotated_right c
        | _,_ -> node l k x r
    rotated l k x r crée un nouveau noeud avec les sous-arbres l,r la clé k et l'élément x.
    Les "1" désignent le différentiel maximal de hauteur entre les sous-arbres l et r.


    Après c'est exactement le même code que pour un arbre binaire quelconque.
    Sauf que tu remplace tous les constructeurs par rotated, ça suffit pour équilibrer ton arbre, du bas vers le haut.

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
      let rec add k x = function
        | None ->
            Some {left = None; height = 1; right = None; key = k; item = x}
        | Some n -> 
            if Ord.compare k n.key < 0 then
              rotated (add k x n.left) n.key n.item n.right
            else if Ord.compare k n.key > 0 then
              rotated n.left n.key n.item (add k x n.right)
            else
              Some {n with item = x}
              
      let rec delete_min t = 
        match t.left with
        | None   -> t.key,t.item,t.right
        | Some n -> let k,x,l = delete_min n in k,x,rotated l t.key t.item t.right
        
      let rec delete k = function
        | None ->
            None
        | Some n -> 
            if Ord.compare k n.key < 0 then
              rotated (delete k n.left) n.key n.item n.right
            else if Ord.compare k n.key > 0 then
              rotated n.left n.key n.item (delete k n.right)
            else
              match n.left,n.right with
              | None,t | t,None -> t
              | l,Some t ->
                  let k,x,r = delete_min t
                  in  rotated l k x r
    C'est exactement ce que fait la stdlib, sauf que Xavier Leroy a remplacé 1 par 2 pour le différentiel maximal de hauteur. Dans OCaml-Reins c'est un AVL 'généralisé' où le différentiel de hauteur a une valeur fixe quelconque.
    Du même auteur: le cours OCaml, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  10. #130
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    C'est un peu plus clair comme ça, même si je ne suis pas allé vérifier chaque ligne de code.

    Cependant, quel avantage à mettre 2 à la place de 1 ?
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  11. #131
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 573
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 573
    Points : 2 448
    Points
    2 448

    Par défaut



    http://caml.inria.fr/pub/ml-archives...e0a88c.en.html

    Une autre astuce (utilisée par OCaml-Reins) c'est d'ajouter un variant Leaf pour les feuilles, du coup il y a moins de Empty à tester, ça soulage le GC.
    Code :
    1
    2
    3
    4
      type ('k,'v) tree = 
          | Empty
          | Leaf of 'k * 'v
          | Node of ('k,'v) tree * 'k * 'v * ('k,'v) tree * int
    La dernière astuce utilisée par OCaml-Reins c'est la défonctorisation de la comparaison.
    Code :
      let add x t = add Ord.compare x t
    De cette façon Ord.compare n'est accédée qu'une seule fois (l'appel dans un 'foncteur' est légèrement plus coûteux que l'appel direct).

    Si tu n'as pas utilisé ces deux dernières astuces dans ton code alors il te reste encore un peu de marge de progression en performances.
    Du même auteur: le cours OCaml, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  12. #132
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    Moi je retiens de l'article cité plus haut...

    Light experimentation suggested that imbalance <= 2 is globally more
    efficient than imbalance <= 1


    J'essaye de retrouver mon code, alors, car je veux en être convaincu.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  13. #133
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    Citation Envoyé par SpiceGuid Voir le message


    http://caml.inria.fr/pub/ml-archives...e0a88c.en.html

    Une autre astuce (utilisée par OCaml-Reins) c'est d'ajouter un variant Leaf pour les feuilles, du coup il y a moins de Empty à tester, ça soulage le GC.
    Code :
    1
    2
    3
    4
      type ('k,'v) tree = 
          | Empty
          | Leaf of 'k * 'v
          | Node of ('k,'v) tree * 'k * 'v * ('k,'v) tree * int
    La dernière astuce utilisée par OCaml-Reins c'est la défonctorisation de la comparaison.
    Code :
      let add x t = add Ord.compare x t
    De cette façon Ord.compare n'est accédée qu'une seule fois (l'appel dans un 'foncteur' est légèrement plus coûteux que l'appel direct).

    Si tu n'as pas utilisé ces deux dernières astuces dans ton code alors il te reste encore un peu de marge de progression en performances.
    Je n'ai pas à les utiliser. Je t'avouerais que je n'avais même pas pensé à utiliser de 'a option pour les feuilles et les noeuds. J'ai l'impression que cela ajoute de la lourdeur plus qu'autre chose.

    Je donne ici l'implantation que j'avais faite à l'époque, il y a 3 ou 4 ans environ. Je l'ai conservée intacte. Entre autres, il y a tout plein de commentaires plus passionnants les uns que les autres, une licence de la mort-qui-tue, et un style mêlant encore Anglais et Français. Il y a même une fote de conjuguèson.

    Le code marche toujours.

    Je viens de le tester sur OCaml 3.09.02 en bytecode et ça marche. Le test consistait en l'insertion des entiers 1 à 5 000 000 dans un Set de int, en ordre croissant.

    Set standard OCaml : 1 minute 42 secondes
    Set AVL fonctionnel : 1 minute 10 secondes
    Set AVL impératif : 1 minute 1 seconde

    J'attire l'attention sur le fait que les résultats de la version impérative sont peut-être, comparativement aux versions fonctionnelles, en deçà de ce que l'on serait en mesure d'attendre. Le fait vient de l'état de la mémoire au moment des tests des versions fonctionnelles de la librairie standard et de la librairie AVL. La mémoire était, en effet, complètement vide, et le GC majeur n'a certainement pas dû se déclencher très souvent.

    @SpiceGuid : cette implantation peut déjà te servir de base pour des tests.

    Voilà.

    Toutes les remarques sont les bienvenues.
    Fichiers attachés Fichiers attachés
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  14. #134
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 573
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 573
    Points : 2 448
    Points
    2 448

    Par défaut

    Beaucoup de warnings dans ton code.


    J'ai testé mon code (uniquement l'insertion): les arbres générés sont corrects et équilibrés.
    Mais les benchs sont décevants.
    Pourtant avant de les faire j'avais ajouté une optimisation inspirée par ton code: l'équilibrage est court-circuité quand le sous-arbre modifié ne change pas de hauteur.
    Avec ça j'espérais dépasser la stdlib mais apparemment la performance dépend de bien d'autres facteurs que l'algorithmique pure.

    La 1ière colonne est le temps en secondes pour l'insertion de 5 millions d'entiers décroissants.
    La 2nd colonne est le temps en secondes pour l'insertion de 5 millions d'entiers Random.bits.
    Chaque test est précédé d'un Gc.full_major().

    En bytecode (linux x86, ocaml 3.10) :

    Code :
    1
    2
    3
    4
    5
    6
    Map.Make            51.135196  81.877118
    fAVLMap.Make        26.701668  61.451841
    impAVLMap.Make      27.893743  28.505782
    AvlTreeMap.Pure     58.855679  190.751921
    AvlTreeMap.Mutable  41.026564  49.199075
    En code natif (linux x86, ocaml 3.10) :

    Code :
    1
    2
    3
    4
    5
    6
    Map.Make            3.872241   35.946246
    fAVLMap.Make        3.808237   34.574161
    impAVLMap.Make      6.25239    6.276393
    AvlTreeMap.Pure     13.124819  111.454965
    AvlTreeMap.Mutable  13.032813  16.529033

    Conclusion:
    • les résultats sont très variables en fonction du profil d'échantillon
    • mon implémentation est mauvaise, et pourtant je n'ai "foiré" nulle part
    • celle de InOCamlWeTrust est la meilleure dans quasiment toutes les configurations


    D'une manière générale je trouve que la performance est difficilement prédictible.
    Par exemple, en randomisé, ma version fonctionnelle met 111.4 contre 16.5s en impératif, alors que les structures de données et l'algo sont exactement les mêmes. D'ailleurs en entiers décroissants le temps est le même dans les deux cas. Difficile à expliquer. Même chose avec impAVLMap.Make, plus lent que Map.Make sur les entiers décroissants mais plus rapide avec les randomisés, pourquoi ? Mystère.
    Ce bench ne me conforte pas dans l'idée de faire des implantations mixtes qui partageraient un maximum de code et d'optimisations. C'était pourtant une idee élégante. Dommage.


    Le code du test :

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    module IntMap = Map.Make(struct type t = int let compare = (-) end)
    
    let rec repeat n f init =
      if n = 0 then init
      else repeat (n-1) f (f n init);;
      
    let main size =
      Gc.full_major();  
      let start = Sys.time() in
      let map = IntMap.empty in
      ignore(repeat size (fun n m -> IntMap.add n () m) map);
      print_int size; print_string " decr inserted in ";
      print_float (Sys.time() -. start); print_newline ();
      Gc.full_major();  
      let start = Sys.time() in
      let map = IntMap.empty in
      ignore(repeat size (fun n m -> IntMap.add (Random.bits()) () m) map);
      print_int size; print_string " randoms inserted in ";
      print_float (Sys.time() -. start); print_newline ()
      ;;
    
    main 5000000;;

    Autres benchs :

    • les performances de mon arbre de Braun sont encore plus médiocres
    • j'ai essayé (sur mon implantation) ∆h = 2 au lieu de ∆h = 1, les temps sont sensiblement les mêmes (jamais dans le bon sens). j'ai également essayé avec 5000 éléments pour voir si c'est une bonne idée sur de plus petits échantillons, sans aucun succès, au mieux les performances ne se dégradent pas beaucoup mais je n'ai pas réussi à trouver un cas où elles s'améliorent.
    Du même auteur: le cours OCaml, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  15. #135
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    J'ai développé le code, à l'époque, avec OCaml 3.07. La compilation effectuée avec ma 3.09 dimanche montrait que l'ajout du nouveau warning E dans la distribution faisait apparaître de nombreux warning ne servant à rien. L'option -A est utilisée, donc il est possible que bon nombre de warning inutiles soient lancés à la compilation, surtout si ils ont été ajoutés aux dernières versions. En tous cas, sur la 3.09.02, ça compile sans warning.

    Pour ce qui est des tests, ma remarque allait dans le sens du commentaire de SpiceGuid.

    A mon avis, il serait intéressant d'étudier ce qui se passe dans le cas croissant ou décroissant. Par contre, pour le random, les résultats sont parfaitement prédictibles. Ce qui est intéressant également est la différence de performance délirante en natif de la version décroissant, entre fonctionnel pur et impératif. Peut-être est-ce un signe que le compilateur optimise mieux de tous petits codes fonctionnels que de gros tas d'instructions effectuées les unes après les autres... mais c'est juste une piste de réflexion.

    En ce qui concerne l'implantation, j'espère t'avoir convaincu qu'implanter une structure AVL réellement performante est une tâche pas si facile que ça.

    P.S. : j'ai la même en C, au cas où ça intéresserait quelqu'un.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  16. #136
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 573
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 573
    Points : 2 448
    Points
    2 448

    Par défaut

    Après avoir tatonné pendant plusieurs heures (bench puis recodage, en boucle) j'ai finalement réussi à dépasser Map.Make. Ça m'a pris pas mal de temps parce que j'ai suivi toutes les fausses pistes imaginables. Par exemple j'ai essayé de suivre le conseil de John Harrop (ajouter un variant Leaf pour les feuilles) mais ça n'a pas eu d'effet bénéfique en code natif, bien au contraire. J'ai été bien inspiré d'avoir deux benchs (je dirais même qu'il en faudrait encore plus) parce qu'un code qui améliore un bench le fait assez souvent au détriment de l'autre.

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
      type ('a,'b) tree =
        | Empty
        | Node of ('a,'b) tree * 'a * 'b * ('a,'b) tree * int
            
      let height = function
        | Empty  -> 0 
        | Node (_,_,_,_,h) -> h
    
      let node l k x r = 
        let lh = height l and rh = height r in
        Node(l,k,x,r,if lh > rh then lh + 1 else rh + 1)        
    
      let node3 ll lk lx lr k x rl rk rx rr =
        let lh = max (height ll) (height lr) + 1 in
        let rh = max (height rl) (height rr) + 1 in
        Node(Node(ll,lk,lx,lr,lh),k,x,Node(rl,rk,rx,rr,rh),max lh rh + 1) 
      
      let balanced l k x r =
        let lh = match l with Empty -> 0 | Node (_,_,_,_,h) -> h in
        let rh = match r with Empty -> 0 | Node (_,_,_,_,h) -> h in
        if lh > rh + 1 then
          let Node(ll,lk,lx,lr,lh) = l in
          if height ll >= height lr then node ll lk lx (node lr k x r)
          else
          let Node(cl,ck,cx,cr,_) = lr in
          node3 ll lk lx cl ck cx cr k x r
        else if rh > lh + 1 then
          let Node(rl,rk,rx,rr,rh) = r in
          if height rr >= height rl then node (node l k x rl) rk rx rr  
          else
          let Node(cl,ck,cx,cr,_) = rl in
          node3 l k x cl ck cx cr rk rx rr
        else
          Node(l,k,x,r,if lh > rh then lh + 1 else rh + 1) 
            
      let rec add cmp k x = function
        | Empty ->
            Node(Empty,k,x,Empty,1)
        | Node(l,a,b,r,h) -> 
            match cmp k a with 
            | c when c < 0 ->
                let left = add cmp k x l in
                if height left = height l then Node(left,a,b,r,h)
                else balanced left a b r
            | c when c > 0 ->
                let right = add cmp k x r in
                if height right = height r then Node(l,a,b,right,h)
                else balanced l a b right
            | _ -> Node(l,a,x,r,h)
    Le bench en bytecode :
    Code :
    1
    2
    3
    stdlib  51.135196  81.877118
    IOCWT   26.701668  61.451841
    Spice   37.702356  71.768484
    Le bench en code natif :
    Code :
    1
    2
    3
    stdlib  3.872241   35.946246
    IOCWT   3.808237   34.574161
    Spice   3.724232   32.386024

    Maintenant que j'ai un peu plus confiance dans mes perfs brutes je vais pouvoir retourner à des considérations un peu plus algorithmiques.

    Par exemple ni Reins ni la Extlib n'ont le filtrage rapide des structures arborescentes.
    L'idée de base ça serait le code ci-dessous (où j'ai omis delete_min vu que je l'ai déjà posté) et de l'adapter pour les arbres équilibrés.

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
      type ('a,'b) tree =
        ('a,'b) node option
      and ('a,'b) node =
        {
        left: ('a,'b) tree; right: ('a,'b) tree;
        key: 'a; item: 'b;
        }
    
      let concat ta tb =
        if ta = None then tb else 
        match tb with
        | None -> ta
        | Some n ->
    	let m,t = delete_min n in
            Some {left = ta; key = m.key; item = m.item; right = t}
           
      let rec filter f = function
        | None -> None
        | Some n ->
            if f n.key n.item then
              Some {
              left = filter f n.left;
              right = filter f n.right;
              key = n.key; item = n.item;
              }
            else        
              concat (filter f n.left) (filter f n.right)
    edit

    Voici comment procéder pour équilibrer.
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
      let rec filter f = function
        | None -> None
        | Some n ->
            if f n.key n.item then
              Some {
              left = filter f n.left;
              right = filter f n.right;
              key = n.key; item = n.item;
              }
            else        
              concat (filter f n.left) (filter f n.right)
    C'est le noeud coloré en rouge qui n'est pas équilibré parce qu'on ne connait rien de la hauteur du fils gauche et du fils droit.

    Ce qu'on fait c'est qu'on remplace par un appel à un constructeur join qui créera le même noeud mais cette fois de manière équilibrante :
    Code :
    1
    2
    3
    4
    5
    6
    7
      let rec filter f = function
        | None -> None
        | Some n ->
            if f n.key n.item then
              Some (join (filter f n.left) n (filter f n.right))
            else        
              concat (filter f n.left) (filter f n.right)
    Même chose pour concat, il nous en faut une version équilibrante.

    Ce genre de constructeurs équilibrés a été introduit par Stephen Adams dans Implementing Sets Efficiently in a Functional Language.

    Leur code ci-dessous est inspiré de la source de Set.Make et adapté pour un container associatif implanté à l'aide d'enregistrements.
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
      let rec join l n r =
        match l,r with
        | None,_ -> add n.key n.item r
        | _,None -> add n.key n.item l
        | Some nl,Some nr ->
            if nl.height > nr.height + 1 then
              balanced nl.left nl (Some (join nl.right n r))
            else if nr.height > nl.height + 1 then
              balanced (Some (join l n nr.left)) nr nr.right
            else
              node l n r
    
      let concat ta tb =
        match ta,tb with
        | None,t | t,None -> t
        | _,Some b ->
            let m,t = delete_min b in
            Some (join ta m t)
    Où :
    • add est l'insertion ordinaire dans un AVL
    • node et balanced sont des constructeurs pour les AVL (voir le code de l'AVL en début de message)
    Du même auteur: le cours OCaml, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  17. #137
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    Si j'en crois une remarque que tu avais faite précédemment, utiliser la fonction de comparaison par l'intermédiaire d'un foncteur est plus lent, même si je n'ai pas fait de test. Qu'en est-il de ton code avec cette façon de faire ? Je serais intéressé de voir la différence, car je n'ai aucune idée d'ordre de gandeur en tête.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  18. #138
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 573
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 573
    Points : 2 448
    Points
    2 448

    Par défaut

    Pour être clair, ce que j'appelle "défonctorisé" c'est à la façon OCaml-Reins (une implantation défonctorisée), pas à la façon ExtLib (une interface défonctorisée).

    Plus concrêtement, au lieu de faire ceci :

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    module MakePure (Ord: Ordered)
    =
    struct
    
      type key = Ord.ordered
    
      type 'a tree =
        | Empty
        | Node of 'a tree * key * 'a * 'a tree * int
    
      let rec add k x = function ...
    
    end
    Je fais cela (qui ne change pas l'interface) :

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    module MakeBase
    =
    struct
    
      type ('a,'b) tree =
        | Empty
        | Node of ('a,'b) tree * 'a * 'b * ('a,'b) tree * int
            
      let rec add cmp k x = function ...
    
    end
    
    module MakePure (Ord: Ordered)
    =
    struct
      
        include MakeBase
         
        type key = Ord.ordered
        type 'a map = (key,'a) tree
    
        let add k x t = add Ord.compare k x t 
       
    end
    Résultats en code natif :
    Code :
    1
    2
    sans MakeBase  3.728233  33.658103
    avec MakeBase  3.636226  33.474091
    J'ai fait plusieurs essais pour confirmer, la version défonctorisée est toujours un pouillème plus rapide mais ça ne peut pas faire la différence entre un bon et un mauvais AVL.

    Il n'y a qu'un seul moyen de faire un bon AVL, c'est de tout de suite tester l'équilibrage et de ne faire du pattern matching que s'il y a une rotation. Mon code initial, comme celui d'OCaml-Reins, mélangeait le pattern matching et la comparaison de hauteur. C'est dévastateur pour la performance. Il m'a fallu trop de tentatives pour comprendre que la déficience venait du réflexe conditionné qui consiste à filtrer avant toute autre chose.
    L'AVL d'OCaml-Reins aggrave son cas :
    • en ajoutant un variant Leaf pour les feuilles, le pattern matching inutile est encore plus lourd
    • en passant partout des paires clé/valeurs de façon à coder son AVLMap exactement comme son AVLSet, trop de création de paires inutiles ça se paye


    John Harrop dit avoir un AVL 30% plus rapide, je n'y crois pas fort :
    • soit il a benché en bytecode et alors ça ne veut rien dire pour le code natif
    • soit il n'a qu'un seul bench et il y a le piège qui consiste à tester/optimiser sur un échantillon particulier au détriment des autres


    Il est clair pour moi que stocker la hauteur est une source (mineure) d'inefficacité, je ne le fais que parce que :
    • c'est plus systématique et donc moins difficile à coder
    • c'est réutilisable sur d'autres opérations que l'insertion et la suppression
    • le bench montre qu'avec OCaml ça ne fait pas une différence énorme

    Ceci dit je ne conteste pas qu'en C la différence puisse être beaucoup plus sensible. Plus un code est optimisé plus les petites optimisations deviennent plus significatives.
    Du même auteur: le cours OCaml, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  19. #139
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 129
    Points
    1 129

    Par défaut

    Citation Envoyé par SpiceGuid Voir le message
    Il n'y a qu'un seul moyen de faire un bon AVL, c'est de tout de suite tester l'équilibrage et de ne faire du pattern matching que s'il y a une rotation.
    Cf. code IOCWT, qui suit l'algorithme originel au pied de la lettre.

    Je pense sincèrement qu'en termes d'AVL, on a tout inventé il y a très longtemps déjà. Tu ne fais là que confirmer ce que l'on sait déjà depuis longtemps : rien, mis à part la table de hachage, ne peut battre un vrai AVL.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

  20. #140
    Invité régulier
    Inscrit en
    novembre 2004
    Messages
    8
    Détails du profil
    Informations forums :
    Inscription : novembre 2004
    Messages : 8
    Points : 6
    Points
    6

    Par défaut Sudoku

    voici une utilisation du moteur d'inférence en DrScheme

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
    272
    273
    274
    275
    276
    277
    278
    279
    280
    281
    282
    283
    284
    285
    286
    287
    288
    289
    290
    291
    292
    293
    294
    295
    296
    297
    298
    299
    300
    301
    302
    303
    304
    305
    306
    307
    308
    309
    310
    311
    312
    313
    314
    315
    316
    317
    318
    319
    320
    321
    #lang scheme/base
    
    (require (planet williams/inference/inference))
    ;(require "../inference.ss")
    (require (lib "list.ss" "srfi" "1"))
    (require scheme/mpair)
    (provide (all-defined-out))
    
    (define-ruleset sudoku-rules)
    
    ;; If there is a board and no cells, initialize the system.
    (define-rule (initialize sudoku-rules)
      (board ?board)
      (no (cell . ?))
      ==>
      (printf "initialize:~n")
      (print-board ?board)
      (do ((row 0 (+ row 1)))
        ((= row 9) (void))
        (assert `(digit ,row))
        (do ((column 0 (+ column 1)))
          ((= column 9) (void))
          (let ((value (vector-ref (vector-ref ?board row) column))
                (box (+ (* (quotient row 3) 3)
                        (quotient column 3))))
            (if (eqv? value '_)
                (assert `(cell ,row ,column ,box (1 2 3 4 5 6 7 8 9)))
                (assert `(cell ,row ,column ,box ,value)))))))
    
    ;; If all of the cells are numbered, we've succeeded.
    (define-rule (rule-1 sudoku-rules)
      (all (cell ?row ?column ?box (?value (number? ?value))))
      (board ?board)
      ==>
      (stop-inference ?board))
    
    ;; If a cell has no possible values. we've failed.
    (define-rule (rule-2 sudoku-rules)
      (cell ?row ?column ?box (?value (eq? ?value '())))
      ==>
      (fail))
    
    ;; If we have a single possible value in a cell,
    ;;   use it to number the cell.
    (define-rule (rule-3 sudoku-rules)
      (?cell <- (cell ?row ?column ?box
                      (?value ;(and (list? ?value) (= (length ?value) 1))
                       (and (pair? ?value) (null? (cdr ?value)))
                       )))
      (board ?board)
      ==>
      (vector-set! (vector-ref ?board ?row) ?column (car ?value))
      (replace ?cell `(cell ,?row ,?column ,?box ,(car ?value))))
    
    ;; If a cell is numbered and it conflicts with another numbered cell,
    ;;   fail.
    ;(define-rule (rule-4 sudoku-rules)
    ;    (cell ?row ?column ?box (?value (number? ?value)))
    ;    (or (cell ?row (?column-1 (not (= ?column-1 ?column))) ?box-1
    ;              (?value-1 (and (number? ?value-1) (= ?value-1 ?value))))
    ;        (cell (?row-1 (not (= ?row-1 ?row))) ?column ?box-1
    ;              (?value-1 (and (number? ?value-1) (= ?value-1 ?value))))
    ;        (cell ?row-1 ?column-1 (?box (or (not (= ?row-1 ?row))
    ;                                         (not (= ?column-1 ?column))))
    ;              (?value-1 (and (number? ?value-1) (= ?value-1 ?value)))))
    ;  ==>
    ;    (fail))
    
    (define-rule (rule-4a sudoku-rules)
      (cell ?row ?column ?box (?value (number? ?value)))
      (cell ?row (?column-1 (not (= ?column-1 ?column))) ?box-1
            (?value-1 (and (number? ?value-1) (= ?value-1 ?value))))
      ==>
      (fail))
    
    (define-rule (rule-4b sudoku-rules)
      (cell ?row ?column ?box (?value (number? ?value)))
      (cell (?row-1 (not (= ?row-1 ?row))) ?column ?box-1
            (?value-1 (and (number? ?value-1) (= ?value-1 ?value))))
      ==>
      (fail))
    
    (define-rule (rule-4c sudoku-rules)
      (cell ?row ?column ?box  (?value (number? ?value)))
      (cell ?row-1 ?column-1 (?box (or (not (= ?row-1 ?row))
                                       (not (= ?column-1 ?column))))
            (?value-1 (and (number? ?value-1) (= ?value-1 ?value))))
      ==>
      (fail))
    
    ;; If a cell is numbered, remove that number from other cell in the
    ;; same row, column, or box.
    ;(define-rule (rule-5 sudoku-rules)
    ;  (cell ?row ?column ?box
    ;        (?value (number? ?value)))
    ;  (or (?cell-1 <- (cell (?row-1 (= ?row-1 ?row))
    ;                        (?column-1 (not (= ?column-1 ?column)))
    ;                        ?box-1
    ;                        (?value-1 (and (pair? ?value-1)
    ;                                       (memv ?value ?value-1)))))
    ;      (?cell-1 <- (cell (?row-1 (not (= ?row-1 ?row)))
    ;                        (?column-1 (= ?column-1 ?column))
    ;                        ?box-1
    ;                        (?value-1 (and (pair? ?value-1)
    ;                                       (memv ?value ?value-1)))))
    ;      (?cell-1 <- (cell ?row-1
    ;                        ?column-1
    ;                        (?box-1 (and (= ?box-1 ?box))
    ;                                     (or (not (= ?row-1 ?row))
    ;                                         (not (= ?column-1 ?column)))))
    ;                        (?value-1 (and (pair? ?value-1)
    ;                                       (memv ?value ?value-1))))))
    ;  ==>
    ;  (replace ?cell-1 `(cell ,?row-1 ,?column-1 ,?box-1
    ;                          ,(delete ?value ?value-1))))
      
    (define-rule (rule-5a sudoku-rules)
      (cell ?row ?column ?box
            (?value (number? ?value)))
      (?cell-1 <- (cell ?row
                        (?column-1 (not (= ?column-1 ?column)))
                        ?box-1
                        (?value-1 (and (pair? ?value-1)
                                       (memv ?value ?value-1)))))
      ==>
      (replace ?cell-1 `(cell ,?row ,?column-1 ,?box-1
                              ,(delete ?value ?value-1))))  
    
    (define-rule (rule-5b sudoku-rules)
      (cell ?row ?column ?box
            (?value (number? ?value)))
      (?cell-1 <- (cell (?row-1 (not (= ?row-1 ?row)))
                        ?column
                        ?box-1
                        (?value-1 (and (pair? ?value-1)
                                       (memv ?value ?value-1)))))
      ==>
      (replace ?cell-1 `(cell ,?row-1 ,?column ,?box-1
                              ,(delete ?value ?value-1))))
    
    (define-rule (rule-5c sudoku-rules)
      (cell ?row ?column ?box
            (?value (number? ?value)))
      (?cell-1 <- (cell ?row-1
                        ?column-1
                        (?box (or (not (= ?row-1 ?row))
                                  (not (= ?column-1 ?column))))
                        (?value-1 (and (pair? ?value-1)
                                       (memv ?value ?value-1)))))
      ==>
      (replace ?cell-1 `(cell ,?row-1 ,?column-1 ,?box
                              ,(delete ?value ?value-1))))
    
    ;; If there is a value that only occurs once as a possibility  in any
    ;; row, column, or box, then make it the only possible value.
    (define-rule (rule-6a sudoku-rules)
      (digit ?digit)
      (?cell <- (cell ?row ?column ?box (?value (and (pair? ?value)
                                                     (memv ?digit ?value)))))
      (no (cell ?row (?column-1 (not (= ?column-1 ?column))) ?
                (?value-1 (or (and (number? ?value-1)
                                   (= ?value-1 ?digit))
                              (and (pair? ?value-1)
                                   (memv ?digit ?value-1))))))
      ==>
      (replace ?cell `(cell ,?row ,?column ,?box ,(list ?digit))))
    
    (define-rule (rule-6b sudoku-rules)
      (digit ?digit)
      (?cell <- (cell ?row ?column ?box (?value (and (pair? ?value)
                                                     (memv ?digit ?value)))))
      (no (cell (?row-1 (not (= ?row-1 ?row))) ?column ?
                (?value-1 (or (and (number? ?value-1)
                                   (= ?value-1 ?digit))
                              (and (pair? ?value-1)
                                   (memv ?digit ?value-1))))))
      ==>
      (replace ?cell `(cell ,?row ,?column ,?box ,(list ?digit))))
    
    (define-rule (rule-6c sudoku-rules)
      (digit ?digit)
      (?cell <- (cell ?row ?column ?box (?value (and (pair? ?value)
                                                     (memv ?digit ?value)))))
      (no (cell ?row-1 ?column-1 (?box (or (not (= ?row-1 ?row))
                                           (not (= ?column-1 ?column))))
                (?value-1 (or (and (number? ?value-1)
                                   (= ?value-1 ?digit))
                              (and (pair? ?value-1)
                                   (memv ?digit ?value-1))))))
      ==>
      (replace ?cell `(cell ,?row ,?column ,?box ,(list ?digit))))
    
    ;; If the above rules don't find a solution (or fail), then create a
    ;; child inference to search using the shorted list of possibilities.
    (define-rule (search sudoku-rules #:priority -100)
      (board ?board)
      (cell ?row ?column ?box (?value (and (pair? ?value)
                                           (> (length ?value) 1)))
            )
      (no (cell ? ? ? (?value-1 (and (pair? ?value-1)
                                     (< (length ?value-1)
                                        (length ?value))))))
      ==>
      (printf "search: row = ~a, column = ~a, box = ~a, values = ~a~n"
              ?row ?column ?box ?value)
      (for-each
       (lambda (value)
         (let ((new-board (copy-board ?board)))
           (vector-set! (vector-ref new-board ?row) ?column value)
           (let ((result
                  (with-new-child-inference-environment
                   (activate sudoku-rules)
                   (assert `(board ,new-board))
                   (let ((result (start-inference)))
                     (printf "Rules fired = ~a~n" (current-inference-rules-fired))
                     result))))
             (when (vector? result)
               (stop-inference result)))))
       ?value)
      (fail))
    
    (define (copy-board board)
      (let ((new-board (make-vector 9)))
        (do ((row 0 (+ row 1)))
          ((= row 9) new-board)
          (let ((board-row (vector-ref board row))
                (new-row (make-vector 9)))
            (do ((column 0 (+ column 1)))
              ((= column 9) (void))
              (vector-set! new-row column
                           (vector-ref board-row column)))
            (vector-set! new-board row new-row)))))
    
    (define (print-board board)
      (do ((row 0 (+ row 1)))
        ((= row 9) (void))
        (do ((column 0 (+ column 1)))
          ((= column 9) (void))
          (let ((value (vector-ref (vector-ref board row) column)))
            (printf "~a " value)))
        (printf "~n")))
    
    (define (sudoku-solver board)
      (printf "Initial Board~n")
      (print-board board)
      (with-new-inference-environment
       (activate sudoku-rules)
       (graph-rule-network)
       ;(current-inference-strategy 'breadth)
       ;(current-inference-trace #t)
       (assert `(board ,board))
       (let ((result (start-inference)))
         (cond ((eq? result '#:fail)
                (printf "Problem cannot be solved!~n"))
               ((not result)
                (printf "No solution found!~n")
                (let* ((board (cdr (assq '?board (mcdr (mcar (query '(board ?board))))))))
                  (print-board board)))
               (else
                (printf "Solution found!~n")
                (print-board result))))
       (printf "Rules fired = ~a~n" (current-inference-rules-fired))
       ))
    
    (define _ '_)
    
    (printf "Trivial - Already Solved~n")
    (sudoku-solver (vector (vector 1 2 3 4 5 6 7 8 9)
                           (vector 4 5 6 7 8 9 1 2 3)
                           (vector 7 8 9 1 2 3 4 5 6)
                           (vector 2 3 4 5 6 7 8 9 1)
                           (vector 5 6 7 8 9 1 2 3 4)
                           (vector 8 9 1 2 3 4 5 6 7)
                           (vector 3 4 5 6 7 8 9 1 2)
                           (vector 6 7 8 9 1 2 3 4 5)
                           (vector 9 1 2 3 4 5 6 7 8)))
    
    (printf "~nTrivial - One open cell~n")
    (sudoku-solver (vector (vector _ 2 3 4 5 6 7 8 9)
                           (vector 4 5 6 7 8 9 1 2 3)
                           (vector 7 8 9 1 2 3 4 5 6)
                           (vector 2 3 4 5 6 7 8 9 1)
                           (vector 5 6 7 8 9 1 2 3 4)
                           (vector 8 9 1 2 3 4 5 6 7)
                           (vector 3 4 5 6 7 8 9 1 2)
                           (vector 6 7 8 9 1 2 3 4 5)
                           (vector 9 1 2 3 4 5 6 7 8)))
    
    (printf "~nEasy~n")
    (sudoku-solver (vector (vector 7 8 1 6 _ 2 9 _ 5)
                           (vector 9 _ 2 7 1 _ _ _ _)
                           (vector _ _ 6 8 _ _ _ 1 2)
                           (vector 2 _ _ 3 _ _ 8 5 1)
                           (vector _ 7 3 5 _ _ _ _ 4)
                           (vector _ _ 8 _ _ 9 3 6 _)
                           (vector 1 9 _ _ _ 7 _ 8 _)
                           (vector 8 6 7 _ _ 3 4 _ 9)
                           (vector _ _ 5 _ _ _ 1 _ _)))
    
    (printf "~nMedium~n")
    (sudoku-solver (vector (vector _ 8 _ _ _ _ _ _ _)
                           (vector _ 4 7 8 _ 9 _ _ 1)
                           (vector _ _ 1 4 5 _ _ 2 _)
                           (vector 8 1 6 7 _ _ 5 _ _)
                           (vector 9 _ _ _ _ 1 _ _ _)
                           (vector _ _ _ 5 6 _ _ _ _)
                           (vector _ _ _ _ _ 8 _ 5 3)
                           (vector _ _ _ _ _ _ _ 8 _)
                           (vector _ _ _ 3 1 _ _ 4 6)))
    
    (printf "~nHard~n")
    (sudoku-solver (vector (vector _ 1 9 _ _ _ _ _ _)
                           (vector _ _ 8 _ _ 3 _ 5 _)
                           (vector _ 7 _ 6 _ _ _ 8 _)
                           (vector _ _ 1 _ _ 6 8 _ 9)
                           (vector 8 _ _ _ 4 _ _ _ 7)
                           (vector 9 4 _ _ _ _ _ 1 _)
                           (vector _ _ _ _ _ 2 _ _ _)
                           (vector _ _ _ _ 8 _ 5 6 1)
                           (vector _ _ 3 7 _ _ _ 9 _)))

Liens sociaux

Règles de messages

  • Vous ne pouvez pas créer de nouvelles discussions
  • Vous ne pouvez pas envoyer des réponses
  • Vous ne pouvez pas envoyer des pièces jointes
  • Vous ne pouvez pas modifier vos messages
  •