IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Langages fonctionnels Discussion :

Page code source, mettez vos sources ici !


Sujet :

Langages fonctionnels

  1. #101
    Inactif  
    Profil pro
    Inscrit en
    Juillet 2005
    Messages
    1 958
    Détails du profil
    Informations personnelles :
    Âge : 58
    Localisation : France

    Informations forums :
    Inscription : Juillet 2005
    Messages : 1 958
    Points : 2 467
    Points
    2 467
    Par défaut
    Citation Envoyé par So.Ta Voir le message
    [...]
    Garulfo> En parlant de "véritable" opérateur (bien que ici, la formulation est loin du sens que je voulais lui donner), je voulais dire un opérateur permettant de donner une valeur par défaut de manière plus simple qu'à coups de let.
    Ah oui rien à voir avec l'idée que ce soit optionnel donc. Tu parles de valeurs par défaut (bien que cela sous-entende que les paramètres puissent être optionnels). Ton exemple ne donne pas de valeur par défaut mais effectue la tâche classique (prendre l'argument s'il existe). Difficile donc de s'y retrouver ^_^.

    Je pense que tu dois passer par un let. Mais je vérifierais.

  2. #102
    Nouveau membre du Club
    Profil pro
    Inscrit en
    Avril 2008
    Messages
    18
    Détails du profil
    Informations personnelles :
    Localisation : Belgique

    Informations forums :
    Inscription : Avril 2008
    Messages : 18
    Points : 26
    Points
    26
    Par défaut
    Mes recherches n'ont abouti à rien pour le Scheme standard, tandis que comme cité plus haut, il existe #!optional en MIT/GNU Scheme.

    > http://www.gnu.org/software/mit-sche...pressions.html

    Hum, après relecture, le #!optional ne permet pas de donner une valeur par défaut de manière plus concise qu'avec un let.

  3. #103
    Membre à l'essai
    Profil pro
    Inscrit en
    Novembre 2004
    Messages
    8
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Novembre 2004
    Messages : 8
    Points : 10
    Points
    10
    Par défaut petit jeu de ping pong en DrScheme
    bonjour,

    voici un petit jeu de ping pong contre l'ordi
    touche flèches haut bas pour déplacer la raquette...

    je débute en scheme et mon but est de tester les approches impératives et fonctionnelles. je me demande comment programmer en style fonctionnel. j'ai fait un essai, mais le programme est plus "lourd" à mon gout.

    voici la version non fonctionnelle (classes + style impératif)

    les classes :
    figure% : image 2D pouvant monter ou descendre
    mobile% : figure% pouvant se déplacer dans toutes les directions
    mobile-rebondissant% : mobile% rebondissant contre les parois ou les raquettes
    joueur% : mobile% avec déplacement automatique

    les objets :
    la balle de type mobile-rebondissant%
    la raquette gauche de type joueur% (l'ordinateur)
    la raquette droite de type mobile% (vous)

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    #lang scheme
    
    (require (lib "world.ss" "htdp"))
    
    ;                                               
    ;                                               
    ;                                               
    ;          ;                                    
    ;          ;                                    
    ;          ;                                    
    ;    ;;;   ;   ;;;    ;;;    ;;;    ;;;    ;;;  
    ;   ;   ;  ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ; 
    ;   ;      ;      ;  ;      ;      ;   ;  ;     
    ;   ;      ;   ;;;;   ;;;    ;;;   ;;;;;   ;;;  
    ;   ;      ;  ;   ;      ;      ;  ;          ; 
    ;   ;   ;  ;  ;  ;;  ;   ;  ;   ;  ;   ;  ;   ; 
    ;    ;;;   ;   ;; ;   ;;;    ;;;    ;;;    ;;;  
    ;                                               
    ;                                               
    ;                                               
    
    (define figure%
      (class object%
        (init-field (image empty) (x 0) (y 0))
        
        (define/public (touche? autre-figure)
          (and (< (abs (- x (send autre-figure getX))) (send this getLargeur))
               (< (abs (- y (send autre-figure getY))) (send this getHauteur))))   
        
        (define/public (monte)
          (cond [(> y (+ (/ (send this getHauteur) 2) 10)) 
                 (set! y (- y 10))]))
        
        (define/public (descend)
          (cond [(< y (- HAUTEUR (+ (/ (send this getHauteur) 2) 10)))
                 (set! y (+ y 10))]))
        
        (define/public (getX) x)
        (define/public (getY) y)
        (define/public (setX new-x)
          (set! x new-x))
        (define/public (setY new-y)
          (set! y new-y))
        (define/public (getImage) image)
        (define/public (setImage new-image)
          (set! image new-image))
        (define/public (getLargeur) (image-width image))
        (define/public (getHauteur) (image-height image))
        (super-new)))
    
    (define mobile%
      (class figure%
        (init-field (dx 0) (dy 0))
        
        (define/public (deplace dans-jeu)
          (begin
            (send this setX (+ (send this getX) dx))
            (send this setY (+ (send this getY) dy))))
        
        (define/public (getdX) dx)
        (define/public (getdY) dy)
        (define/public (setdX new-dx)
          (set! dx new-dx))
        (define/public (setdY new-dy)
          (set! dy new-dy))
        (super-new)))
    
    (define mobile-rebondissant%
      (class mobile%
        (inherit 'deplace)
        (rename-super [super-deplace deplace])    
        
        (define/override (deplace dans-jeu)
          (let ([x (send this getX)]
                [y (send this getY)]
                [dx (send this getdX)]
                [dy (send this getdY)]
                [h (send this getHauteur)]
                [l (send this getLargeur)]
                [rg (jeu-mobile-gauche dans-jeu)]
                [rd (jeu-mobile-droit dans-jeu)]) 
            (begin
              (cond 
                [(or (and (> y (- HAUTEUR (+ (/ h 2) 5))) (> dy 0)) 
                     (and (< y (+ (/ h 2) 5)) (< dy 0)))
                 (send this setdY (- dy))]
                [(or (and
                      (and (> x (- LARGEUR (+ (/ l 2) 10))) (> dx 0)) 
                      (send this touche? rd))
                     (and 
                      (and (< x (+ (/ h 2) 10)) (< dx 0))
                      (send this touche? rg)))
                 (send this setdX (- dx))])
              (super-deplace dans-jeu)
              )))
        
        (super-new)))
    
    (define joueur%
      (class mobile%
        (init-field (temps-reaction 2) (inertie 1))
        
        (define/public (joue avec-balle)
          (cond [(visible? avec-balle)
                 (strategie avec-balle)]))
        
        (define/private (visible? figure)
          (< (distance figure) (/ (random LARGEUR) 1.2)))
        
        (define/private (strategie avec-balle)
          (let ([d (distance avec-balle)])
            (if (= compteur-temps-inertie 0)        
                (if (< compteur-temps-reaction temps-reaction)
                    (set! compteur-temps-reaction (+ compteur-temps-reaction 1))
                    (begin
                      (set! compteur-temps-reaction 0)
                      (set! compteur-temps-inertie inertie)
                      (send this monte)
                      (cond [(> (distance avec-balle) d)
                             (begin
                               (send this descend)
                               (send this descend))]
                            [(= (distance avec-balle) d)
                             (send this descend)])))
                (set! compteur-temps-inertie (- compteur-temps-inertie 1))
                )))
        
        (define compteur-temps-reaction 0)
        (define compteur-temps-inertie 0)
        (define/private (distance figure)
          (let ([x1 (send this getX)]
                [y1 (send this getY)]
                [x2 (send figure getX)]
                [y2 (send figure getY)])
            (sqrt (+ (sqr (- x2 x1)) (sqr (- y2 y1))))))
        (super-new)))    
    
    ;                                                                        
    ;                                                                        
    ;                                                                        
    ;     ;          ;                                                       
    ;    ;            ;                                                      
    ;   ;              ;                                           ;         
    ;                                                              ;         
    ;   ;;;  ;;; ;;; ;;;  ;; ;;    ;;;  ;; ;;  ;;    ;;;  ;; ;;   ;;;;  ;;;; 
    ;  ;   ;  ;   ; ;   ;  ;;  ;  ;   ;  ;;  ;;  ;  ;   ;  ;;  ;   ;   ;   ; 
    ;  ;;;;;   ; ;  ;;;;;  ;   ;  ;;;;;  ;   ;   ;  ;;;;;  ;   ;   ;    ;;   
    ;  ;       ; ;  ;      ;   ;  ;      ;   ;   ;  ;      ;   ;   ;      ;; 
    ;  ;   ;   ; ;  ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;  ;   ;   ; ; ;   ; 
    ;   ;;;     ;    ;;;  ;;; ;;;  ;;;  ;;; ;;; ;;;  ;;;  ;;; ;;;  ;;; ;;;;  
    ;                                                                        
    ;                                                                        
    ;                                                                        
    
    (define (jeu-suivant j)
      (let ([balle (jeu-mobile-balle j)]
            [raquette-gauche (jeu-mobile-gauche j)])
        (begin
          (send balle deplace j)
          (send raquette-gauche joue balle)
          j)))
    
    (define (affiche-jeu j)
      (let* ([image1
              (place-image (send (jeu-mobile-gauche j) getImage)
                           (send (jeu-mobile-gauche j) getX)
                           (send (jeu-mobile-gauche j) getY)
                           (empty-scene LARGEUR HAUTEUR))]
             [image2 
              (place-image (send (jeu-mobile-droit j) getImage)
                           (send (jeu-mobile-droit j) getX)
                           (send (jeu-mobile-droit j) getY)
                           image1)] 
             [image3
              (place-image (send (jeu-mobile-balle j) getImage)
                           (send (jeu-mobile-balle j) getX)
                           (send (jeu-mobile-balle j) getY)
                           image2)]) 
        image3)) 
    
    (define (gestion-clavier j a-key-event)
      (begin
        (cond 
          [(key=? a-key-event #\a)
           (send (jeu-mobile-gauche j) monte)]
          [(key=? a-key-event #\q) 
           (send (jeu-mobile-gauche j) descend)]
          [(key=? a-key-event 'up) 
           (send (jeu-mobile-droit j) monte)]
          [(key=? a-key-event 'down) 
           (send (jeu-mobile-droit j) descend)]
          ))
      j)
    
    ;                    
    ;                    
    ;                    
    ;                    
    ;                    
    ;                    
    ;   ; ; ;   ;  ; ;;  
    ;   ;;  ;   ;  ;;  ; 
    ;   ;   ;   ;  ;   ; 
    ;   ;   ;   ;  ;   ; 
    ;   ;   ;   ;  ;   ; 
    ;   ;   ;   ;  ;   ; 
    ;   ;    ;;;;  ;   ; 
    ;                    
    ;                    
    ;                    
    
    (define-struct jeu (mobile-gauche mobile-droit mobile-balle))
    
    (define LARGEUR 500)
    (define HAUTEUR 300)
    
    (big-bang LARGEUR HAUTEUR 0.01 (make-jeu
                                    (new joueur% (image (rectangle 10 40 'solid 'red)) (x 10) (y (/ HAUTEUR 2)))
                                    (new mobile% (image (rectangle 10 40 'solid 'green)) (x (- LARGEUR 10)) (y (/ HAUTEUR 2))) 
                                    (new mobile-rebondissant% (image (circle 5 'solid 'black)) (x 100) (y 100) (dx 2.5) (dy 2))))
    
    (on-tick-event jeu-suivant)
    (on-redraw affiche-jeu)
    (on-key-event gestion-clavier)
    et l'essai en "fonctionnel"

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    #lang scheme
    
    (require (lib "world.ss" "htdp"))
    
    ;                                               
    ;                                               
    ;                                               
    ;          ;                                    
    ;          ;                                    
    ;          ;                                    
    ;    ;;;   ;   ;;;    ;;;    ;;;    ;;;    ;;;  
    ;   ;   ;  ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ; 
    ;   ;      ;      ;  ;      ;      ;   ;  ;     
    ;   ;      ;   ;;;;   ;;;    ;;;   ;;;;;   ;;;  
    ;   ;      ;  ;   ;      ;      ;  ;          ; 
    ;   ;   ;  ;  ;  ;;  ;   ;  ;   ;  ;   ;  ;   ; 
    ;    ;;;   ;   ;; ;   ;;;    ;;;    ;;;    ;;;  
    ;                                               
    ;                                               
    ;                                               
    
    (define figure%
      (class object%
        (init-field [image empty] [x 0] [y 0] [classe figure%])
        
        (define/public (touche? autre-figure)
          (and (< (abs (- x (send autre-figure getX))) (send this getLargeur))
               (< (abs (- y (send autre-figure getY))) (send this getHauteur))))   
        
        (define/public (getX) x)
        (define/public (getY) y)
        (define/public (getImage) image)
        (define/public (getLargeur) (image-width image))
        (define/public (getHauteur) (image-height image))
        (define/public (getClasse) classe)
        (super-new)))
    
    (define mobile%
      (class figure%
        (init-field [dx 0] [dy 0])
        
        (define/public (monte)
          (let* ([y (send this getY)]
                 [nouveau-y 
                  (if (> y (+ (/ (send this getHauteur) 2) 10)) 
                      (- y 10)
                      y)])
            
            (new (send this getClasse) 
                 [image (send this getImage)] 
                 [x (send this getX)] 
                 [y nouveau-y]
                 [classe (send this getClasse)])))
        
        (define/public (descend)
          (let* ([y (send this getY)]
                 [nouveau-y 
                  (if (< y (- HAUTEUR (+ (/ (send this getHauteur) 2) 10)))
                      (+ y 10)
                      y)])
            
            (new (send this getClasse) 
                 [image (send this getImage)] 
                 [x (send this getX)]
                 [y nouveau-y]
                 [classe (send this getClasse)])))
        
        (define/public (deplace dans-jeu)
          (new (send this getClasse) 
               [image (send this getImage)] 
               [x (+ (send this getX) dx)] 
               [y (+ (send this getY) dy)] 
               [dx (send this getdX)]
               [dy (send this getdY)]
               [classe (send this getClasse)]))
        
        (define/public (getdX) dx)
        (define/public (getdY) dy)
        (super-new)))
    
    (define mobile-rebondissant%
      (class mobile%
        
        (define/override (deplace dans-jeu)
          (let* ([x (send this getX)]
                 [y (send this getY)]
                 [dx (send this getdX)]
                 [dy (send this getdY)]
                 [h (send this getHauteur)]
                 [l (send this getLargeur)]
                 [rg (jeu-raquette-gauche dans-jeu)]
                 [rd (jeu-raquette-droite dans-jeu)]
                 [delta-y
                  (if (or (and (> y (- HAUTEUR (+ (/ h 2) 5))) (> dy 0)) 
                          (and (< y (+ (/ h 2) 5)) (< dy 0)))
                      (- dy)
                      dy)]
                 [delta-x
                  (if (or (and
                           (and (> x (- LARGEUR (+ (/ l 2) 10))) (> dx 0)) 
                           (send this touche? rd))
                          (and 
                           (and (< x (+ (/ h 2) 10)) (< dx 0))
                           (send this touche? rg)))
                      (- dx)
                      dx)])
            
            (new (send this getClasse) 
                 [image (send this getImage)] 
                 [x (+ (send this getX) dx)]
                 (y (+ (send this getY) dy)) 
                 [dx delta-x]
                 [dy delta-y]
                 [classe (send this getClasse)])))
        
        (super-new)))
    
    (define joueur%
      (class mobile%
        (init-field [inertie 2] [compteur-inertie inertie])
        
        (define/private (visible? figure)
          (< (distance figure) (/ (random LARGEUR) 1.2)))
        
        (define/override (deplace dans-jeu)
          (let* ([balle (jeu-balle dans-jeu)]
                 [d (distance balle)]
                 [monte-un-cran (send this monte)]
                 [nouveau-compteur-inertie
                  (if (= compteur-inertie 0)
                      inertie
                      (- compteur-inertie 1))]                 
                 [nouveau-joueur           
                  (if (and (= compteur-inertie 0)
                           (visible? balle))
                      (cond [(>= (send monte-un-cran distance balle) d)                                        
                             (send this descend)]
                            [(= (send monte-un-cran distance balle) d)
                             this]
                            [else
                             monte-un-cran])
                      this)])    
            
            (new (send nouveau-joueur getClasse) 
                 [image (send nouveau-joueur getImage)]
                 [x (send nouveau-joueur getX)]
                 [y (send nouveau-joueur getY)] 
                 [dx (send nouveau-joueur getdX)]
                 [dy (send nouveau-joueur getdY)]
                 [compteur-inertie nouveau-compteur-inertie]
                 [classe (send nouveau-joueur getClasse)])))
        
        (define/public (distance figure)
          (let ([x1 (send this getX)]
                [y1 (send this getY)]
                [x2 (send figure getX)]
                [y2 (send figure getY)])
            (sqrt (+ (sqr (- x2 x1)) (sqr (- y2 y1))))))
        
        (super-new)))    
    
    ;                                                                        
    ;                                                                        
    ;                                                                        
    ;     ;          ;                                                       
    ;    ;            ;                                                      
    ;   ;              ;                                           ;         
    ;                                                              ;         
    ;   ;;;  ;;; ;;; ;;;  ;; ;;    ;;;  ;; ;;  ;;    ;;;  ;; ;;   ;;;;  ;;;; 
    ;  ;   ;  ;   ; ;   ;  ;;  ;  ;   ;  ;;  ;;  ;  ;   ;  ;;  ;   ;   ;   ; 
    ;  ;;;;;   ; ;  ;;;;;  ;   ;  ;;;;;  ;   ;   ;  ;;;;;  ;   ;   ;    ;;   
    ;  ;       ; ;  ;      ;   ;  ;      ;   ;   ;  ;      ;   ;   ;      ;; 
    ;  ;   ;   ; ;  ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;  ;   ;   ; ; ;   ; 
    ;   ;;;     ;    ;;;  ;;; ;;;  ;;;  ;;; ;;; ;;;  ;;;  ;;; ;;;  ;;; ;;;;  
    ;                                                                        
    ;                                                                        
    ;                                                                        
    
    (define (jeu-suivant j)
      (map (lambda (mobile) (send mobile deplace j)) j)) 
    
    (define (affiche-jeu j)
      (if (empty? (cdr j))
          (place-image (send (car j) getImage)
                       (send (car j) getX)
                       (send (car j) getY)
                       (empty-scene LARGEUR HAUTEUR))
          (place-image (send (car j) getImage)
                       (send (car j) getX)
                       (send (car j) getY)
                       (affiche-jeu (cdr j)))))
    
    (define (gestion-clavier j a-key-event)
      (cond 
        [(key=? a-key-event #\a)
         (cons (send (jeu-raquette-gauche j) monte) (cdr j))]
        [(key=? a-key-event #\q) 
         (cons (send (jeu-raquette-gauche j) descend) (cdr j))]
        [(key=? a-key-event 'up) 
         (let ([raquettes (list (jeu-raquette-gauche j) (send (jeu-raquette-droite j) monte))])
           (append raquettes (cdr (cdr j))))]
        [(key=? a-key-event 'down) 
         (let ([raquettes (list (jeu-raquette-gauche j) (send (jeu-raquette-droite j) descend))])
           (append raquettes (cdr (cdr j))))]
        [else
         j]))
    
    ;                    
    ;                    
    ;                    
    ;                    
    ;                    
    ;                    
    ;   ; ; ;   ;  ; ;;  
    ;   ;;  ;   ;  ;;  ; 
    ;   ;   ;   ;  ;   ; 
    ;   ;   ;   ;  ;   ; 
    ;   ;   ;   ;  ;   ; 
    ;   ;   ;   ;  ;   ; 
    ;   ;    ;;;;  ;   ; 
    ;                    
    ;                    
    ;                    
    
    (define LARGEUR 500)
    (define HAUTEUR 300)
    
    (define (jeu-raquette-gauche jeu)
      (car jeu))
    
    (define (jeu-raquette-droite jeu)
      (car (cdr jeu)))
    
    (define (jeu-balle jeu)
      (car (cdr (cdr jeu))))
    
    (define make-raquette-ordinateur 
      (new joueur% 
           [image (rectangle 10 40 'solid 'red)] 
           [x 10] [y (/ HAUTEUR 2)]
           [classe joueur%]))
    
    (define make-raquette-joueur 
      (new mobile% 
           [image (rectangle 10 40 'solid 'green)] 
           [x (- LARGEUR 10)] [y (/ HAUTEUR 2)] 
           [classe mobile%]))
    
    (define make-balle-noire 
      (new mobile-rebondissant% 
           [image (circle 5 'solid 'black)]
           [x 100] [y 100]
           [dx 2.5] [dy 2]
           [classe mobile-rebondissant%]))
    
    (big-bang LARGEUR HAUTEUR 0.01 (list make-raquette-ordinateur 
                                         make-raquette-joueur 
                                         make-balle-noire))
    
    (on-tick-event jeu-suivant)
    (on-redraw affiche-jeu)
    (on-key-event gestion-clavier)
    si vous avez des suggestions, n'hésitez pas...

  4. #104
    Nouveau membre du Club
    Étudiant
    Inscrit en
    Novembre 2008
    Messages
    26
    Détails du profil
    Informations personnelles :
    Âge : 40

    Informations professionnelles :
    Activité : Étudiant

    Informations forums :
    Inscription : Novembre 2008
    Messages : 26
    Points : 27
    Points
    27
    Par défaut Le traitement des listes dans la langue LISP
    Écrire la lambda-expression pour la transformation de la liste (a b c d e), comprenant de cinq éléments, vers l'aspect correspondant à la variante
    ((d . a) b (e c))


    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    (defun transformer(x)
    ( (LAMBDA (x)
         (cons(cons(cadddr x)(car x ))(cons(cadr x)
         (cons(cons(caddr x)(cddddr x))()))
    ) )x))

    ou


    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    (defun transformer(x)
    ( (LAMBDA (x)
         (append(cons(cons(cadddr x)(car x)) 
                           (cons(cadr x)()))(list(cons(caddr x)(cddddr x)))
    ) )x))

  5. #105
    Nouveau membre du Club
    Étudiant
    Inscrit en
    Novembre 2008
    Messages
    26
    Détails du profil
    Informations personnelles :
    Âge : 40

    Informations professionnelles :
    Activité : Étudiant

    Informations forums :
    Inscription : Novembre 2008
    Messages : 26
    Points : 27
    Points
    27
    Par défaut transformation des listes
    transformer la liste (asd123ddd34 ff23gg66 gg6h7) vers

    (12334_asdddd 2366_ffgg 67_ggh)

    vloila le code

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    (defun isNumber (a)
        
    (<= 48 (char-code a) 57)
    )
    (defun getChars(l)
           (cond ((null l) l)
    	         ((not (isNumber (car l))) (cons (car l) (getChars (cdr l))))
    			 (t (getChars(cdr l)))
     ))
    
    (defun getNumbers(l)
    (cond ((null l) l)
           ((isNumber(car l )) (cons (car l) (getNumbers(cdr l))))
    	   (t (getNumbers (cdr l)))
    	   
    	   )
    )   
    
    (defun convert(l)
    (append (getNumbers l)'(#\_)(getChars l))
    
    )
    (defun convertList(l)
            (cond ((null l)l)
                      (t ( cons 
    		  (intern (coerce ( convert (coerce 
                                (string (car l)) 'list))'string ))(convertList (cdr l))
    ))))

  6. #106
    Inactif  
    Profil pro
    Inscrit en
    Juillet 2005
    Messages
    1 958
    Détails du profil
    Informations personnelles :
    Âge : 58
    Localisation : France

    Informations forums :
    Inscription : Juillet 2005
    Messages : 1 958
    Points : 2 467
    Points
    2 467
    Par défaut
    Alors là je suis perplexe… à quoi ceci peut-il servir ?

    Le but n'est pas de mettre du code pour du code, mais des éléments pertinents comme des fonctions classiques par exemple.

    De surcroit, e n'est pas très bien présenté et certains morceaux sont douteux.
    Quel est l'intérêt de mettre un lambda ici ?
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    (defun transformer(x)
    ( (LAMBDA (x)
         (cons(cons(cadddr x)(car x ))(cons(cadr x)
         (cons(cons(caddr x)(cddddr x))()))
    ) )x))
    Et c'est tellement particulier comme cas, que s'en est inutile.

  7. #107
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut La source du chapitre IX
    Partie IX. Application aux tableaux extensibles

    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    
    module Vector =
    
      struct
    
        type 'a vector =
          | Leaf
          | Node of 'a node
        and 'a node =
          {mutable left: 'a vector; mutable item: 'a; mutable right: 'a vector}
        type 'a t =
          {mutable plus: 'a vector; mutable minus: 'a vector; default: 'a}
    
        let make x =
          {plus=Leaf; minus=Leaf; default=x}
    
        let get v i =
          let rec loop i node =
            match node with
            | Leaf ->
                v.default
            | Node n ->
                if i = 1 then n.item else
                loop (i asr 1) (if i land 1 = 0 then n.left else n.right)
          in if i >= 0 then loop (succ i) v.plus else loop (-i) v.minus
    
        let set v i x =
          let rec grow i =
            Node
            (
            if i = 1 then
              {left = Leaf; item = x; right = Leaf}
            else if i land 1 = 0 then
              {left = grow (i asr 1); item = v.default; right = Leaf}
            else
              {left = Leaf; item = v.default; right = grow (i asr 1)}
            )
          and tree i node =
            match node with
            | Leaf ->
                grow i
            | Node n ->
                if i = 1 then
                  n.item <- x
                else if i land 1 = 0 then
                  n.left <- tree (i asr 1) n.left
                else
                  n.right <- tree (i asr 1) n.right;
                if x = v.default && n.left = Leaf && n.right = Leaf then Leaf
                else node       
          in 
          if i >= 0 then
            v.plus <- tree (succ i) v.plus
          else
            v.minus <- tree (-i) v.minus
    
        let add v i x =
          let rec grow i =
            Node
            (
            if i = 1 then
              {left = Leaf; item = x; right = Leaf}
            else if i land 1 = 0 then
              {left = grow (i asr 1); item = v.default; right = Leaf}
            else
              {left = Leaf; item = v.default; right = grow (i asr 1)}
            )
          and tree i node =
            match node with
            | Leaf ->
                grow i
            | Node n ->
                Node
                (
                if i = 1 then
                  {n with item = x}
                else if i land 1 = 0 then
                  {n with left = tree (i asr 1) n.left}
                else
                  {n with right = tree (i asr 1) n.right}
                )    
          in
          if i >= 0 then
            {v with plus = tree (succ i) v.plus}
          else
            {v with minus = tree (-i) v.minus; plus = v.plus}
    
        let fold f init v =
          let rec loop node acc =
            match node with
            | Leaf ->
                acc
            | Node n -> 
                if n.item = v.default then loop n.right (loop n.left acc)
                else loop n.right (f n.item (loop n.left acc))
          in loop v.plus (loop v.minus init)
    
        let iter f v = 
          fold (fun h t -> f h) () v
    
        let exists p v = 
          fold (fun h t -> p h or t) false v
    
        let for_all p v = 
          fold (fun h t -> p h && t) true v
    
        let filter p v =
          fold (fun h t -> if p v then h::t else t) [] v
    
        let to_list v =
          fold (fun h t -> h::t) [] v
    
        let foldi f init v =
          let rec plus node acc i d =
            match node with
            | Leaf ->
                acc
            | Node n -> 
                let left = plus n.left acc (i+d) (d+d) in
                if n.item = v.default then plus n.right left (i+d+d) (d+d)
                else plus n.right (f (i-1) n.item left) (i+d+d) (d+d)
          and minus node acc i d =
            match node with
            | Leaf ->
                acc
            | Node n -> 
                let right = minus n.right acc (i+d+d) (d+d) in
                if n.item = v.default then minus n.left right (i+d) (d+d) 
                else minus n.left (f (-i) n.item right) (i+d) (d+d)
          in plus v.plus (minus v.minus init 1 1) 1 1
    
        let iteri f v = 
          foldi (fun i h t -> f i h) () v
    
        let to_alist v =
          foldi (fun i h t -> (i,h)::t) [] v
    
      end

    merci à bluestorm pour ses corrections et ses propositions d'amélioration.
    Du même auteur: mon projet, 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. #108
    Membre éprouvé
    Profil pro
    Inscrit en
    Avril 2007
    Messages
    832
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Avril 2007
    Messages : 832
    Points : 1 104
    Points
    1 104
    Par défaut
    J'ai l'impression que le code actuel de l'opération set est faux :

    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    let set v i x =
          let rec grow i = Node (*[...]*)
          and tree i node =
            match node with
            | Leaf ->
                grow i
            | Node n -> (*[...]*)
          in ignore  
          (if i >= 0 then tree (succ i) v.plus else tree (-i) v.minus)

    Dans le cas Leaf, "grow" renvoie un arbre, qui n'est jamais utilisé puisque tu ignore. Pour avoir une version correcte il faut rendre les champs "plus" et "minus" mutable et faire :
    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    if i >= 0
      then v.plus <- tree (succ i) v.plus
      else v.minus <- tree (-i) v.minus

    Au passage, toutes ces bidouilles de plus/minus sont assez laides et n'apportent pas grand chose. On pourrait pas s'en débarrasser ? Tu perdrais rien en pédagogie et gagnerait beaucoup en clarté.

  9. #109
    Membre éprouvé
    Profil pro
    Inscrit en
    Avril 2007
    Messages
    832
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Avril 2007
    Messages : 832
    Points : 1 104
    Points
    1 104
    Par défaut
    Bon, c'est mort. On regarde un code, on voit un truc à améliorer, on essaie. Puis un autre. Puis un autre. Puis après ça ressemble plus du tout, et on a perdu la trace de l'ordre des modifications. Donc, pavé en vrac avec tout d'un coup.

    D'abord, on vire les "plus/minus". Comment ? Il suffit de considérer le type "t" comme équivalent au type "node" : on crée un noeud supplémentaire, en mettant les indices négatifs à gauche, et les indices positifs à droite.

    Ensuite, il suffit de faire une traduction "indice réel" (donné par l'utilisateur) vers "indice non signé" (servant à naviguer dans le noeud spécial de signe) :
    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    let to_unsigned si =
      if si >= 0 then 1 lor ((succ si) lsl 1) else (-si) lsl 1
    let to_signed i =
      if i land 1 = 1 then pred (i asr 1) else -(i asr 1)

    À quoi ressemblent nos types maintenant ?

    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    type 'a tree =
      | Leaf
      | Node of 'a node
    and 'a node =
        {left: 'a tree ref; mutable item: 'a option; right: 'a tree ref}
     
    type 'a vector = 'a node

    Pourquoi ('a option) dans l'item ? Parce qu'au lieu d'avoir des "defaults" laid, on met "None" quand aucune valeur n'a été choisie, et "Some ..." quand une valeur a été choisie. Ok, c'est légèrement couteux, mais le code est plus joli et la structure plus correcte à utiliser (en particulier to_alist arrête de se chier dessus quand on a créé plein de noeuds intermédiaires "vides" en ajoutant une valeur).

    Pourquoi ('a tree ref) au lieu du bon vieux mutable ? Parce que ça permet d'utiliser le même "objet", à la fois pour accéder à une branche de l'arbre, et pour la modifier. On peut donc factoriser les fonctions de navigation en fonction de l'indice (les opérations de bit shifting laides, là) :
    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    let head i node = 
      if i land 1 = 0 then node.left else node.right
     
    let tail i = i asr 1
    let is_nil i = i = 1

    Vous avez remarqué l'analogie très classe avec les listes ? Moi aussi.

    Après ces petites modifications cosmétiques, voici la fonction get :
    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    let get v si =
      let rec loop i = function
        | Leaf -> None
        | Node n ->
            if is_nil i then n.item else loop (tail i) !(head i n)
      in loop (to_unsigned si) (Node v)

    Et la fonction set :
    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    let set v si x =
      let rec tree i node =
        let node = match node with
        | Leaf -> empty ()
        | Node n -> n in
        if is_nil i then node.item <- Some x
        else head i node := tree (tail i) !(head i node);
        if node = empty () then Leaf else Node node
      in ignore (tree (to_unsigned si) (Node v))

    On peut noter que l'"optimisation" est formulée en une seule ligne, mais actuellement complètement inutile, puisque l'utilisateur peut ajouter seulement des valeurs du type "Some ..", et pas de None. Il faudrait étendre l'interface de set pour prendre un type option, ou alors :
    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    let change v si x =
      let rec tree i node =
        let node = match node with
        | Leaf -> empty ()
        | Node n -> n in
        if is_nil i then node.item <- x
        else head i node := tree (tail i) !(head i node);
        if node = empty () then Leaf else Node node
      in ignore (tree (to_unsigned si) (Node v))
     
    let set v si x = change v si (Some x)
    let delete v si = change v si None

    La fonction foldi, et sans la duplication plus/minus, quand même.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    let foldi f init {left=minus; right=plus} =
      let rec loop node acc i lvl =
        match node with
        | Leaf -> acc
        | Node n -> 
            let left_val = loop !(n.left) acc (i + 1 lsl lvl) (lvl + 1) in
            let mid_val = match n.item with
            | None -> left_val
            | Some x -> f (to_signed i) x left_val in
            loop !(n.right) mid_val (i + 1 lsl (lvl + 1)) (lvl + 1)
      in loop !plus
           (loop !minus init (to_unsigned (-1)) 1)
           (to_unsigned 0) 1
    Par contre, j'ai pas trop compris comment utiliser "i+d+d" (il est tard et ça a l'air subtil), donc j'ai re codé un petit truc avec du bit shifting selon le schéma.

    Au passage, on peut noter que le "fold" présenté ici n'est pas un vrai fold sur les arbres, c'est un fold sur les listes d'éléments de l'arbre (dans un sens arbitraire). C'est pour cela que l'on n'arrive pas à en construire map; il faudrait utiliser un fold qui respecte la structure de l'arbre. Cependant, ce serait sans doute aussi lourd à faire que le fold+map actuel, et surtout l'utilisateur a envie de voir seulement le fold linéaire actuel, et pas un "vrai" fold sur les arbres, qui révèle l'implémentation de la structure sous-jacente.

  10. #110
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut
    Citation Envoyé par bluestorm
    J'ai l'impression que le code actuel de l'opération set est faux
    Saloperies de valeurs mutables!

    Au passage, toutes ces bidouilles de plus/minus sont assez laides et n'apportent pas grand chose. On pourrait pas s'en débarrasser ? Tu perdrais rien en pédagogie et gagnerait beaucoup en clarté.
    Au contraire, j'y perdrais la pertinence de mes beaux schémas bien pédagogiques

    Parce qu'au lieu d'avoir des "defaults" laid, on met "None" quand aucune valeur n'a été choisie, et "Some ..." quand une valeur a été choisie. Ok, c'est légèrement couteux, mais le code est plus joli et la structure plus correcte à utiliser
    Coûteux, je ne sais pas , ça dépend comment le Some est implanté, en tout cas le fold devient nettement plus propre! Il ne traverse plus les valeurs 'inutiles'.

    Par contre, j'ai pas trop compris comment utiliser "i+d+d" (il est tard et ça a l'air subtil)
    C'est mieux visible sur les figures (voir le texte).
    (mais c'est pas testé non plus)

    Au passage, on peut noter que le "fold" présenté ici n'est pas un vrai fold sur les arbres, c'est un fold sur les listes d'éléments de l'arbre (dans un sens arbitraire). C'est pour cela que l'on n'arrive pas à en construire map; il faudrait utiliser un fold qui respecte la structure de l'arbre.
    C'est pas dit assez clairement, dans le texte, que ça n'est pas un catamorphisme mais juste un itérateur ? (mais tu n'as peut être regardé que le code)
    La partie précédente Partie VIII. Les types algébriques contenait déjà le fold sur les arbres binaires et le map construit avec.

    Pourquoi ('a tree ref) au lieu du bon vieux mutable ? Parce que ça permet d'utiliser le même "objet", à la fois pour accéder à une branche de l'arbre, et pour la modifier. On peut donc factoriser les fonctions de navigation en fonction de l'indice
    C'est sans doute moi, mais je trouve que c'est une question de goût, un code plus court n'est pas forcément un code plus facile à lire.
    Avec tes ref tu perds totalement la similitude que j'avais entretenue entre la version mutable et la version immutable, similitude dont je me sers (dans le texte) pour introduire le {r with a = b}.
    Du même auteur: mon projet, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  11. #111
    Membre éprouvé
    Profil pro
    Inscrit en
    Avril 2007
    Messages
    832
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Avril 2007
    Messages : 832
    Points : 1 104
    Points
    1 104
    Par défaut
    Disclaimer : aucun des codes de ce post n'a été testé (ni même compilé).

    La partie précédente Partie VIII. Les types algébriques contenait déjà le fold sur les arbres binaires et le map construit avec.
    Au passage, je suis allé voir et j'ai le sentiment que ton fold sur les arbres n-aires n'est pas "le fold canonique". Tu as l'air de mieux savoir ce qu'est un "catamorphisme canonique" que moi, mais j'aurais plutôt vu une fonction au type isomorphe à : ('a * 'b list -> b) -> 'a tree -> 'b
    Ainsi, "map" s'écrit : let map f = fold (fun (a, li) -> Node (f a, li))


    C'est sans doute moi, mais je trouve que c'est une question de goût, un code plus court n'est pas forcément un code plus facile à lire.
    Certes, mais il y a quand même une différence objective, qui est que ton code est plus redondant :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
                else if i land 1 = 0 then
                  n.left <- tree (i asr 1) n.left
                else
                  n.right <- tree (i asr 1) n.right;
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
        else head i node := tree (tail i) !(head i node);
    Mon code utilise une fonction de plus, donc est placé à un niveau d'abstraction supérieur. Il y a donc certainement un "coût" qui peut rendre la compréhension plus difficile au premier abord (quand on n'a jamais rencontré cette abstraction), mais je pense que ce coût est suffisamment faible, et que l'élimination de la redondance est avantageuse. Peut-être que je n'ai pas encore trouvé les bons noms de fonctions pour rendre cette ligne compréhensible en soit.

    Avec tes ref tu perds totalement la similitude que j'avais entretenue entre la version mutable et la version immutable, similitude dont je me sers (dans le texte) pour introduire le {r with a = b}.
    J'ai essayé de simplifier le code impératif tel qu'il est, sans regarder en effet la synchronisation avec la partie persistante. Cependant, je pense qu'on peut encore faire une factorisation similaire pour le code persistant :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    let get_head i node = if i land 1 = 0 then n.left else n.right
    let change_head i node v =
      if i land 1 = 0
      then { n with left = v }
      else { n with right = v }
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
                if i = 1 then
                  {n with item = x}
                else change_head i n (tree (tail i) (get_head i n))
    À cause d'une limitation de caml à ce niveau (on ne peut pas manipuler les record commodément), le code est un peu plus lourd que la version impérative qui sait résumer en une seul fonction "objet de lecture" et "objet de changement", en particulier la "logique de navigation" (i land 1 ..) est dupliquée.

    Cependant, cette version du code peut être adaptée en retour vers le code impératif :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    let get_head i n = !(head i n)
    let change_head i n v = head i n := v
    À ce moment là, tu n'as plus une analogie mais la même ligne de code dans les deux cas. Pour ma part, j'apprécie l'utilisation de := et ! qui sont standard en OCaml, et font bien comprendre le changement et l'accès, donc je garderais l'ancienne version impérative, mais celle-ci devrait combler tes envies de similarités, et pas qu'un peu.

  12. #112
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut
    Au passage, je suis allé voir et j'ai le sentiment que ton fold sur les arbres n-aires n'est pas "le fold canonique".
    Tu as bien vu, le fold "canonique" applique exactement un morphisme par constructeur, ici il n'y aurait donc qu'un seul morphisme de type 'a * 'b list → 'b.
    (je vais révoir ce passage)

    Sinon, il est vrai qu'il y a certains raccourcis, ce sont des arbitrages que j'ai fait, souvent volontairement.

    Par exemple, le prédicat ordered utilise une inégalité large:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    let ordered t =
      let a,b =
        cata_rec
        (fun a -> a,a)
        (fun a b -> a,b)
        (fun (l1,l2) a (r1,r2) ->
           if l1>l2 then l1,l2
           else if l2>a then l2,a
           else if a>r1 then a,r1
           else if r1>r2 then r1,r2
           else l1,r2
        )
        t
      in a<=b
    C'est clairement abusif, puisquez tous les éléments de l'arbre devraient être distincts. C'est dû au fait que je n'introduit pas de nouveau type somme (ce que, rigoureusement parlant, je devrais faire). C'était ou bien ce petit arrangement avec la vérité ou bien risquer de distraire le lecteur avec un nouveau type somme tombé du ciel. Ça n'est encore qu'un simple tutoriel, c'est plein d'arbitrages.
    Du même auteur: mon projet, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  13. #113
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut
    J'ai mis à jour la source du module Vect pour que ni le fold ni le foldi ne traversent les noeuds contenant la valeur par défaut (que cette valeur soit None ou autre).

    Quant au module Shared, pour ne pas avoir à dupliquer la source (c'est pénible quand je dois faire des modifications en plusieurs endroits, souvent avec coloration syntaxique dans deux langages de balise différents), je vous renvoie à la lecture de mon billet blog :
    http://blog.developpez.com/damien-gu...noeud#more6857
    Du même auteur: mon projet, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  14. #114
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut module Set
    Un Mutable.Set higher-order module.
    J'ai trop besoin de la fonction zip_intersect, c'est essentiellement ça qui m'empêche d'utiliser le module standard Set.Make.
    (voir mon billet blog pour plus de détails)

    Ce module ne contient que le minimum nécessaire pour implémenter les modules qui suivent, de ce fait il lui manque plein d'opérations qu'on serait en droit d'attendre d'un module Set. Je vous laisse compléter en cas de besoin.

    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    module Ordered = struct
      module type Type = 
      sig
        type t
        val  compare: t -> t -> int 
      end
    end
    
    
    module Mutable = struct
    
      module type Set =
      sig
        type t
        type item
        val empty: unit -> t
        val singleton: item -> t 
        val add: item -> t -> unit
        val zip_intersect: (item -> item -> 'a) -> t -> t -> 'a list
        val iter: (item -> unit) -> t -> unit
        val filter: (item -> bool) -> t -> item list 
      end
      
      module MakeSet (Ord: Ordered.Type) =
      struct
        type item =
          Ord.t
        type node =
          {mutable left: node option; item: item; mutable right: node option}
        type t =
          node option ref
        let empty () =
          ref None
        let singleton x =
          ref (Some {left = None; item = x; right = None})
        let add x t =
          let rec helper t =
            match t with 
            | None ->
                Some {left = None; item = x; right = None}
            | Some a -> 
                if Ord.compare x a.item < 0 then a.left <- helper a.left
                else if Ord.compare x a.item > 0 then a.right <- helper a.right;
                t
          in t := helper !t
        let iter f t =
          let rec helper = function
            | None -> ()
            | Some n -> helper n.left; f n.item; helper n.right
          in helper !t 
        let zip_intersect zip ta tb =
          let rec one x = function
            | None -> []
            | Some t -> 
                if Ord.compare x t.item < 0 then one x t.left
                else if Ord.compare x t.item > 0 then one x t.right
                else [zip x t.item]
          in let rec many ta tb =
            match ta,tb with
            | None,_ | _,None ->
                []
            | Some a,Some b ->
                many a.left  b.left @
                many a.right b.right @
                if Ord.compare a.item b.item < 0 then
                  many a.right b.left @ one a.item b.left @ one b.item a.right
                else if Ord.compare a.item b.item > 0 then 
                  many a.left b.right @ one a.item b.right @ one b.item a.left
                else
                  [zip a.item b.item]
          in many !ta !tb
        let filter prop t =
          let rec helper = function
            | None -> []
            | Some n ->
                let t = helper n.left @ helper n.right in
                if prop n.item then n.item::t else t   
          in helper !t 
      end
    
    end
    Du même auteur: mon projet, 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. #115
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut module Board
    Un module-type pour les plateaux de jeu.
    Typiquement la fonction compare servira à placer les positions de jeu dans une table de transposition (à l'aide du module Set).

    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    module type Board = 
    sig
      type board
      type moves
      type game = {board: board; played: moves}
      type strategy = (game -> unit) -> game -> unit
      type t = game
      val  compare: t -> t -> int 
    end
    Du même auteur: mon projet, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  16. #116
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut module Solver
    Un higher-order module pour solutionner des problèmes sur les plateaux de jeu.
    • Set est un module pour les tables de transposition
    • find permet de rechercher un plateau satifaisant une certaine propriété
    • solve permet de rechercher un chemin vers une certaine position
    • solve utilise une recherche bi-directionnelle


    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    module Solver (B: Board) (Set: Mutable.Set with type item = B.game) =
    (
    struct
      let play p sa =
        let sb = Set.empty () in
        Set.iter (fun g -> p (fun x -> Set.add x sb) g) sa; sb
      let find p prop g =
        let rec helper s =
          match Set.filter (fun g -> prop g.B.board) s with
          | [] -> helper (play p s)
          | l -> l
        in
        if prop g.B.board then [g]
        else helper (Set.singleton g) 
      let solve p zip ga gb =
        let rec even sa sb =
          match Set.zip_intersect zip sa sb with
          | [] -> odd (play p sa) sb
          | l  -> l
        and odd sa sb =
          match Set.zip_intersect zip sa sb with
          | [] -> even sa (play p sb)
          | l  -> l
        in
        even (Set.singleton ga) (Set.singleton gb) 
    end
    :
    sig
      val find: B.strategy -> (B.board -> bool) -> B.game -> B.game list 
      val solve: B.strategy -> (B.game -> B.game -> 'a) -> B.game -> B.game -> 'a list 
    end
    )
    Du même auteur: mon projet, 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. #117
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut module PocketCube
    Un plateau de jeu pour le Rubik's Cube Pocket (La version 2 x 2 x 2 du cube classique).

    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    module PocketCube =
    struct
    
      type cubie =
        | C1  | C2  | C3  | C4  | C5  | C6  | C7 
      type orient =
        | O1 | O2 | O3
      type 'a septuple =
        'a * 'a * 'a * 'a * 'a * 'a * 'a
      type board =
        cubie septuple * orient septuple  
    
      type move =
        | Front  | Back  | Left  | Right  | Up  | Down
      type moves =
        move list
      type game =
        {board: board; played: moves}
    
      let ror = function
        | O1 -> O2 | O2 -> O3 | O3 -> O1 
      let rol = function
        | O1 -> O3 | O2 -> O1 | O3 -> O2 
    
      let initial = {
        board  = (C1,C2,C3,C4,C5,C6,C7),(O1,O1,O1,O1,O1,O1,O1);
        played = [] }
    
      let right g =
        let (c1,c2,c3,c4,c5,c6,c7),(o1,o2,o3,o4,o5,o6,o7) = g.board in {
        board  = (c2,c5,c3,c1,c4,c6,c7),(ror o2,rol o5,o3,rol o1,ror o4,o6,o7);
        played = Right::g.played }
    
      let back g =
        let (c1,c2,c3,c4,c5,c6,c7),(o1,o2,o3,o4,o5,o6,o7) = g.board in {
        board  = (c1,c2,c3,c5,c6,c7,c4),(o1,o2,o3,ror o5,rol o6,ror o7,rol o4);
        played = Back::g.played }
    
      let down g =
        let (c1,c2,c3,c4,c5,c6,c7),(o1,o2,o3,o4,o5,o6,o7) = g.board in {
        board  = (c1,c3,c6,c4,c2,c5,c7),(o1,o3,o6,o4,o2,o5,o7);
        played = Down::g.played }
    
      let left g =
        let (c1,c2,c3,c4,c5,c6,c7),(o1,o2,o3,o4,o5,o6,o7) = g.board in {
        board  = (c4,c1,c3,c5,c2,c6,c7),(ror o4,rol o1,o3,rol o5,ror o2,o6,o7);
        played = Left::g.played }
    
      let front g =
        let (c1,c2,c3,c4,c5,c6,c7),(o1,o2,o3,o4,o5,o6,o7) = g.board in {
        board  = (c1,c2,c3,c7,c4,c5,c6),(o1,o2,o3,ror o7,rol o4,ror o5,rol o6);
        played = Front::g.played }
    
      let up g =
        let (c1,c2,c3,c4,c5,c6,c7),(o1,o2,o3,o4,o5,o6,o7) = g.board in {
        board  = (c1,c5,c2,c4,c6,c3,c7),(o1,o5,o2,o4,o6,o3,o7);
        played = Up::g.played }
    
      let rec scramble g n = 
        if n = 0 then g
        else
          scramble
          ( match Random.int 6 with 
          | 1 -> front g | 2 -> back  g
          | 3 -> left  g | 4 -> right g
          | 5 -> up    g | n -> down  g )
          (n-1)
    
      let inverse = function
        | Front -> Back  | Back  -> Front
        | Left  -> Right | Right -> Left
        | Up    -> Down  | Down  -> Up
    
      let zip ga gb =
        List.rev_append (List.map inverse gb.played) ga.played
    
      type strategy =
        (game -> unit) -> game -> unit
      let player : strategy = fun f g ->
        f (front g); f (back  g);
        f (left  g); f (right g);
        f (up    g); f (down  g) 
    
      type t =
        game
      let compare : t -> t -> int =
        fun ga gb -> Pervasives.compare ga.board gb.board 
    
    end

    Création du module solveur de pocket-cube :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    Random.self_init ();;
    module Cube = PocketCube;;
    module CubeSolver = Solver(Cube)(Mutable.MakeSet(Cube));;
    Création d'un pocket-cube mélangé avec 60 rotations aléatoires :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    # let scrambled = Cube.scramble Cube.initial 60;;
    val scrambled : Cube.game =
      {Cube.board =
        ((Cube.C3, Cube.C4, Cube.C2, Cube.C7, Cube.C1, Cube.C5, Cube.C6),
         (Cube.O2, Cube.O1, Cube.O3, Cube.O1, Cube.O1, Cube.O3, Cube.O2));
       Cube.played =
        [Cube.Left; Cube.Left; Cube.Left; Cube.Up; Cube.Front; Cube.Front;
         Cube.Up; Cube.Down; Cube.Right; Cube.Right; Cube.Left; Cube.Right;
         Cube.Left; Cube.Right; Cube.Right; Cube.Up; Cube.Down; Cube.Up;
         Cube.Front; Cube.Front; Cube.Left; Cube.Back; Cube.Left; Cube.Right;
         Cube.Up; Cube.Up; Cube.Up; Cube.Back; Cube.Front; Cube.Up; Cube.Back;
         Cube.Front; Cube.Up; Cube.Down; Cube.Up; Cube.Front; Cube.Left;
         Cube.Left; Cube.Down; Cube.Front; Cube.Front; Cube.Left; Cube.Left;
         Cube.Front; Cube.Up; Cube.Left; Cube.Down; Cube.Right; Cube.Back;
         Cube.Front; Cube.Left; Cube.Up; Cube.Front; Cube.Right; Cube.Front;
         Cube.Down; Cube.Back; Cube.Left; Cube.Right; Cube.Right]}
    
    Remarque: le champ Cube.played contient la liste des coups à jouer pour reconstituer le cube initial.

    Oubli forcé du cheminement vers la position initiale :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    # let scrambled_blanked = {scrambled with Cube.played = []};;
    val scrambled_blanked : Cube.game =
      {Cube.board =
        ((Cube.C3, Cube.C4, Cube.C2, Cube.C7, Cube.C1, Cube.C5, Cube.C6),
         (Cube.O2, Cube.O1, Cube.O3, Cube.O1, Cube.O1, Cube.O3, Cube.O2));
       Cube.played = []}
    
    Reconstitution d'une solution par recherche bi-directionnelle :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    # CubeSolver.solve Cube.player Cube.zip scrambled_blanked Cube.initial;;
    - : Cube.move list list =
    [[Cube.Front; Cube.Up; Cube.Back; Cube.Left; Cube.Left; Cube.Down; Cube.Down;
      Cube.Right; Cube.Up; Cube.Up];
     [Cube.Up; Cube.Right; Cube.Down; Cube.Down; Cube.Back; Cube.Right;
      Cube.Front; Cube.Right; Cube.Up; Cube.Back];
     [Cube.Down; Cube.Down; Cube.Right; Cube.Back; Cube.Down; Cube.Down;
      Cube.Left; Cube.Left; Cube.Up; Cube.Back];
     [Cube.Front; Cube.Down; Cube.Right; Cube.Right; Cube.Down; Cube.Down;
      Cube.Front; Cube.Left; Cube.Up; Cube.Up]]
    
    Les 4 solutions trouvées sont les plus courtes possibles.
    Du même auteur: mon projet, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  18. #118
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut nouvel algo pour zip_intersect
    Petite analyse de complexité de la fonction Mutable.MakeSet.zip_intersect.
    Vu que cette fonction est utilisée pour de la recherche bidirectionnelle les deux arbres à intersecter croisent dans les mêmes proportions, on va considérer qu'ils ont le même nombre d'éléments.
    Je note N ce nombre d'éléments.

    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
        let zip_intersect zip ta tb =
          let rec one x = function
            | None -> []
            | Some t -> 
                if Ord.compare x t.item < 0 then one x t.left
                else if Ord.compare x t.item > 0 then one x t.right
                else [zip x t.item]
          in let rec many ta tb =
            match ta,tb with
            | None,_ | _,None ->
                []
            | Some a,Some b ->
                many a.left  b.left @
                many a.right b.right @
                if Ord.compare a.item b.item < 0 then
                  many a.right b.left @ one a.item b.left @ one b.item a.right
                else if Ord.compare a.item b.item > 0 then 
                  many a.left b.right @ one a.item b.right @ one b.item a.left
                else
                  [zip a.item b.item]
          in many !ta !tb

    Chaque niveau dans l'arbre de recherche (soit 2 fois plus d'éléments) donne lieu à 3 appels récursifs à la fonction many.
    La complexité est donc de type Karatsuba c'est-à-dire N^(ln 3 / ln 2).

    Une alternative consisterait à traverser l'arbre ta pour en rechercher les éléments présents dans tb.
    La nouvelle complexité est N × ln N.

    Code OCaml : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
        let fold f init t =
          let rec loop acc = function
            | None -> acc
            | Some a -> loop (f a.item (loop acc a.left)) a.right
          in loop init !t
    
        let zip_intersect zip ta tb =
          let rec loop x = function
            | None -> None
            | Some t -> 
                if Ord.compare x t.item < 0 then loop x t.left
                else if Ord.compare x t.item > 0 then loop x t.right
                else Some (zip x t.item)
          in
          fold
          (fun a b -> match loop a !tb with None -> b | Some x -> x::b)
          [] ta

    Un test rapide montre que cette nouvelle version accélère d'au moins 20% la résolution du Pocket Cube. Même dans l'interpréteur de bytecode la très grande majorité des cubes sont résolus en moins d'une seconde
    Du même auteur: mon projet, 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. #119
    Membre émérite
    Avatar de SpiceGuid
    Homme Profil pro
    Inscrit en
    Juin 2007
    Messages
    1 704
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : Juin 2007
    Messages : 1 704
    Points : 2 990
    Points
    2 990
    Par défaut Insertion dans un AVL
    J'ai volontairement effacé toutes les autres fonctions pour améliorer la lisibilité.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    module AvlTreeMap (Ord: Ordered)
    =
    struct
    
      type key = Ord.t
    
      type 'a node =
        {
        mutable left: 'a node option; mutable right: 'a node option;
        mutable height: int;
        key: key; mutable item: 'a;
        }
    
      type 'a t =
        'a node option ref
    
      let set_height n =
        n.height <- max
        (match n.left  with None -> 2 | Some b -> b.height + 1)
        (match n.right with None -> 2 | Some b -> b.height + 1)
     
      let set_left n b =
        n.left <- Some b; n.height <- succ
        (match n.right with None -> b.height | Some c -> max b.height c.height)
    
      let set_right n b =
        n.right <- Some b; n.height <- succ
        (match n.left with None -> b.height | Some c -> max b.height c.height)
    
      let single_left n b =
        n.left <- b.right; set_height n; 
        set_right b n; b
    
      let double_left n b =
        match b.right with
        | None   -> b (* can't happen *)
        | Some c -> 
        b.right <- c.left;  set_height b;
        n.left  <- c.right; set_height n;
        c.left <- Some b; c.right <- Some n;
        set_height c; c
    
      let single_right n b =
        n.right <- b.left; set_height n; 
        set_left b n; b
    
      let double_right n b =
        match b.left with
        | None   -> b (* can't happen *)
        | Some c -> 
        b.left  <- c.right; set_height b;
        n.right <- c.left;  set_height n;
        c.left <- Some n; c.right <- Some b;
        set_height c; c
    
      let insert k x t =
        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
                let b = loop n.left in
                if ( match n.right with
                   | None   -> b.height = 2
                   | Some c -> b.height - c.height = 2 ) then
                   if Ord.compare k b.key < 0 then single_left n b
                   else double_left n b
                else
                  (set_left n b; n)
              else if Ord.compare k n.key > 0 then
                let b = loop n.right in
                if ( match n.left with
                   | None   -> b.height = 2
                   | Some c -> b.height - c.height = 2 ) then
                   if Ord.compare k b.key > 0 then single_right n b
                   else double_right n b
                else
                  (set_right n b; n)
              else begin
                n.item <- x; n
              end
        in t := Some (loop !t)
       
    end
    Remarque: les fonctions set_left et set_right ne sont pas indispensables, ceux qui préfèrent un code plus simple (mais moins optimisé) peuvent les remplacer par une affectation suivie d'un appel à set_height.


    Les autres routines qui suivent sont applicables sur des arbres binaires ordonnés, dans un style 'mutable'.
    Evidemment ces routines ne sont pas applicables ni sur les arbres binaires qui implémentent des tas/files/queues ni sur les arbres de Braun.
    Dans le cas du style 'mutable' il faudra ajouter la référence, c'est-à-dire qu'il faudra changer loop t en loop !t ou bien en t := loop !t s'il y a modification de l'arbre.

    Le code peut facilement est modifié pour être fonctionnellement pur. Dans la plupart des cas il suffira par exemple d'écrire {n with left = r} au lieu de n.left <- r; n.


    Les trois routines suivantes permettent d'itérer sur un intervalle de clés dans un arbre binaire ordonné ('pur' ou bien 'mutable').

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
      let less k f init t = 
        let rec loop acc = function
        | None   ->
            acc
        | Some n ->
            if Ord.compare n.key k < 0 then
              loop (f n.key n.item (fold f acc n.left)) n.right
            else
              loop acc n.left
        in loop init t
    
      let more k f init t = 
        let rec loop acc = function
        | None   ->
            acc
        | Some n ->
            if Ord.compare n.key k > 0 then
              fold f (f n.key n.item (loop acc n.left)) n.right
            else
              loop acc n.right
        in loop init t
    
      let interval ka kb f init t = 
        let rec loop acc = function
        | None   ->
            acc
        | Some n ->
            if Ord.compare n.key ka < 0 then
              loop acc n.right
            else if Ord.compare n.key kb > 0 then
              loop acc n.left
            else
              loop (f n.key n.item (loop acc n.left)) n.right
        in loop init t
    La fission/fusion d'arbres binaires, sans rééquilibrage (donc à ne pas utiliser sur des AVL ou des arbres rouges-noirs) :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
      let rec divide k t =
        match t with  
        | None ->
            None,None,None
        | Some n ->
            if Ord.compare k n.key < 0 then
              let l,a,r = divide k n.left in n.left <- r;
              l,a,t
            else if Ord.compare k n.key > 0 then
              let l,a,r = divide k n.right in n.right <- l;
              t,a,r
            else 
              n.left,(Some n.item),n.right
    
      let rec merge f ta tb =
        match tb with
        | None -> ta
        | Some n ->
            let l,a,r = divide n.key ta in
            n.left  <- merge f l n.left;
            n.right <- merge f r n.right;
            match a with
            | None -> tb
            | Some x -> n.item <- f n.key x n.item; tb

    Une table de transposition est esentiellement une mémoisation pour la recherche.
    Pour les tables de transposition, j'ai utilisé cette fusion particulière qui itère sur les éléments insérés mais pas sur ceux qui étaient déjà présents dans la table.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
      let rec fold f init = function
        | None   -> init
        | Some n -> fold f (f n.item (fold f init n.left)) n.right 
    
      let merge_fold f init ta tb =
        let rec loop ta tb a =
          if ta = None then tb,a else 
          match tb with
          | None -> ta,fold f a ta
          | Some n ->
              let l,r = divide n.item  ta in
              let nl,b = loop l n.left  a in
              let nr,c = loop r n.right b in
              n.left <- nl; n.right <- nr;
              tb,c
        in
        let t,acc = loop !ta !tb init
        in  tb := t; acc
    La fonction fold est l'itérateur ordinaire sur un ensemble, c'est-à-dire la fonction de type :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
      type 'a fold = (item -> 'a -> 'a) -> 'a -> t -> 'a
    t est le type-ensemble et item le type-élément.
    La fonction merge_fold est un bi-itérateur, c'est-à-dire une fonction de type :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
      type 'a fold2 = (item -> 'a -> 'a) -> 'a -> t -> t -> 'a
    Un test sur un exemple réaliste de plus de 300000 éléments m'amène à penser que la pénalité en performance due à l'utilisation de ce genre d'itérateurs est négligable (mais pas inexistante).


    Remarque: toutes les sources de ce message ont été testées.
    Du même auteur: mon projet, le dernier article publié, le blog dvp et le jeu vidéo.
    Avant de poser une question je lis les règles du forum.

  20. #120
    Membre éprouvé
    Avatar de InOCamlWeTrust
    Profil pro
    Inscrit en
    Septembre 2006
    Messages
    1 036
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Septembre 2006
    Messages : 1 036
    Points : 1 284
    Points
    1 284
    Par défaut
    Trois critiques, un peu dures, concernant tes AVL :

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

    - je te conseille de commencer par les implanter dans un module entièrement fonctionnel, avec ds structures de données non modifiables. C'est 1000 fois plus facile à débugger.

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

    Je connais très bien les AVL, pour en avoir fait plusieurs implantations tant en C, qu'en Haskell ou qu'en OCaml. Il est, malheureursement, très rare de voir une librairie complète contenant une véritable implantation efficace de cette merveilleurse structure de données. La seule, à mes yeux, réellement intéressante est la libAVLmap de GNU. 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.

    Je te conseille de comparer ton module, au niveau performances, avec Set et Map de la librairie standard. Si il est plus lent, alors c'es que tu as foiré. Essaye avec des arbres d'au moins 4 millions d'éléments : en-dessous, c'est un peu pipeau comme test (en fait, jusqu'à bourrer toute la mémoire de ton ordi : c'est ce que je faisais à l'époque).

    De mémoire, mon implantation fonctionnelle des AVL était environ entre 20% et 30% plus rapide que Set et Map à données égales. Celle impérative, était environ 10 fois plus rapide. C'est normal : le temps GC est borné (O(1)), contrairement à l'implantation fonctionnelle.

    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é.
    When Colt produced the first practical repeating handgun, it gave rise to the saying God created men, but Colt made them equal.

Discussions similaires

  1. Page Sources Java libres - participez ici
    Par Mickael Baron dans le forum Format d'échange (XML, JSON...)
    Réponses: 109
    Dernier message: 26/06/2011, 18h34
  2. Page code source, mettez vos sources ici !
    Par gorgonite dans le forum Caml
    Réponses: 98
    Dernier message: 02/05/2009, 18h05
  3. Page Code Source, mettez vos codes ici
    Par Bovino dans le forum Contribuez
    Réponses: 8
    Dernier message: 05/12/2008, 13h11
  4. Page Code Source, mettez vos codes ici
    Par Kerod dans le forum Balisage (X)HTML et validation W3C
    Réponses: 8
    Dernier message: 05/12/2008, 13h11

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo