Page code source, mettez vos sources ici !

Version imprimable

Voir 40 message(s) de cette discussion en une page

02/11/2008, 23h36
Garulfo

Citation:

Envoyé par So.Ta

[...]
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.
03/11/2008, 23h22
So.Ta

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.

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:

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:

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

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:

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:

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

transformation des listes

transformer la liste (asd123ddd34 ff23gg66 gg6h7) vers

(12334_asdddd 2366_ffgg 67_ggh)

vloila le code

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

09/11/2008, 10h31
Garulfo
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:

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.

La source du chapitre IX

Partie IX. Application aux tableaux extensibles

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

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.

J'ai l'impression que le code actuel de l'opération set est faux :
Code:

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:

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

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:

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:

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:

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:

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:

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:

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:

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.

15/11/2008, 00h58
SpiceGuid

Citation:

Envoyé par bluestorm

J'ai l'impression que le code actuel de l'opération set est faux

Saloperies de valeurs mutables!

Citation:

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 :(

Citation:

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

Citation:

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)

Citation:

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.

Citation:

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}.
15/11/2008, 09h55
gasche
Disclaimer : aucun des codes de ce post n'a été testé (ni même compilé).

Citation:

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

Citation:

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:

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:

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.

Citation:

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:

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:

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:

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.

Citation:

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:

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.

30/11/2008, 18h44
SpiceGuid

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

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:

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

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:

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

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:

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
)

module PocketCube

Un plateau de jeu pour le Rubik's Cube Pocket (La version 2 x 2 x 2 du cube classique).

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

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:

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:

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:

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.

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:

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:

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 :king:

Insertion dans un AVL

J'ai volontairement effacé toutes les autres fonctions pour améliorer la lisibilité.

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

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:

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:

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:

type 'a fold = (item -> 'a -> 'a) -> 'a -> t -> 'a

Où 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:

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.

12/04/2009, 14h17
InOCamlWeTrust

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

Voir 40 message(s) de cette discussion en une page