-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathtp2.scm
393 lines (341 loc) · 18.9 KB
/
tp2.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
;;; Fichier : tp2.scm
;;; Ce programme est une version incomplete du TP2. Vous devez uniquement
;;; changer et ajouter du code dans la première section.
;;;----------------------------------------------------------------------------
;;;----------------------------------------------------------------------------
;;; Vous devez modifier cette section. La fonction "traiter" doit
;;; être définie, et vous pouvez ajouter des définitions de fonction
;;; afin de bien décomposer le traitement à faire en petites
;;; fonctions. Il faut vous limiter au sous-ensemble *fonctionnel* de
;;; Scheme dans votre codage (donc n'utilisez pas set!, set-car!,
;;; begin, etc).
;;; La fonction traiter reçoit en paramètre une liste de caractères
;;; contenant la requête lue et le dictionnaire. La fonction retourne
;;; une paire contenant la liste de caractères qui sera imprimée comme
;;; résultat de l'expression entrée et le nouveau dictionnaire. Vos
;;; fonctions ne doivent pas faire d'affichage car c'est la fonction
;;; "go" qui se charge de cela.
;;;----------------------------------------------------------------------------
; retourne #f si x est '() ou #f
(define (exist x) (not (or (null? x) (not x))))
;fonction d'assertion gentillement prêtée par Guillaume P. Morency
(define assert (lambda (expr . message)
(let ((color (if expr "\x1b[32m" "\x1b[31m")) (reset "\x1b[0m"))
(display color)
(display (if expr "pass" "fail"))
(display (if (not (null? message)) (string-append " " (car message)) ""))
(display "\n")
(display reset))))
(define foldl
(lambda (f base lst)
(if (null? lst)
base
(foldl f (f base (car lst)) (cdr lst)))))
(define foldr
(lambda (f base lst)
(if (null? lst)
base
(f (car lst)
(foldr f base (cdr lst))))))
#|
(assert (equal? (foldl + 1 '(1 2 3)) 7) "fold-left an addition")
(assert (equal? (foldl string-append "" '("a" "b" "c")) "abc") "fold-left a string")
(assert (equal? (foldl string-append "" '()) "") "fold-left an empty list")
(assert (equal? (foldr + 1 '(1 2 3)) 7) "foldr testing" )
(assert (equal? (foldr string-append "" '("a" "b" "c")) "cba") "foldr testing wierd")
(assert (equal? (foldr string-append "" '()) "") "foldr testing")
;Calcule à partir de la root la profondeur jusqu'au noeud avec la clée cherchée
(define (node-depth root key)
(if (null? root)
0
(let ((cmp (compare key (node-key root))))
(cond
((equal? cmp 'youfoundme) 1)
((equal? cmp 'right) (+ 1 (node-depth (node-rchild root) key)))
((equal? cmp 'left) (+ 1 (node-depth (node-lchild root) key)))
(else #f)))))
|#
; Pour utilisation consquente dans le programme, appeler avec str1=clé recherchée et str2 noeud actuel
(define (compare str1 str2)
(let ((string1 (list->string str1)) (string2 (list->string str2)))
(cond
((string<? string1 string2) 'left)
((string>? string1 string2) 'right)
((string=? string1 string2) 'youfoundme)
(else -1))
)
)
(define node-key cadr)
(define node-definition caddr)
(define node-lchild car)
(define node-rchild cadddr)
(define (node-create key definition lchild rchild) (list lchild key definition rchild))
(define (node-reconstruct x lchild rchild) (list lchild (node-key x) (node-definition x) rchild))
#|
(assert (equal? '() (node-lchild '(() "term" ("def1" "def2") ()))) "get the left child of a node")
(assert (equal? "term" (node-key '(() "term" ("def1" "def2") ()))) "get the term of a node")
(assert (equal? '("def1" "def2") (node-definition '(() "term" ("def1" "def2") ()))) "get the definitions of a node")
(assert (equal? '() (node-rchild '(() "term" ("def1" "def2") ()))) "get the right child of a node")
|#
;
;Opération zig. p etait root -> c est root
; quand x est le left child de p et p est root
; (((A) X (B)) P (C)) -> ((A) X ((B) P (C)))
(define zig
(lambda (p x)
(node-reconstruct x (node-lchild x) (node-reconstruct p (node-rchild x) (node-rchild p)))))
;Opération zig. p etait root -> c est root
; quand x est le right child de p et p est root
; ((C) P ((B) X (A))) -> (((C) P (B)) X (A))
(define zag
(lambda (p x)
(node-reconstruct x (node-reconstruct p (node-lchild p) (node-lchild x))(node-rchild x) )))
; x is right child of p is right child of g
(define zag-zag
(lambda (g p x)
(node-reconstruct x (node-reconstruct p (node-reconstruct g (node-lchild g)
(node-lchild p))
(node-lchild x))
(node-rchild x))))
; x is leftchild of p is leftchild of g
(define zig-zig
(lambda (g p x)
(node-reconstruct x (node-lchild x)
(node-reconstruct p (node-rchild x)
(node-reconstruct g (node-rchild p)
(node-rchild g))))))
(define zig-zag
(lambda (g p x)
(node-reconstruct x (node-reconstruct p (node-lchild p) (node-lchild x)) (node-reconstruct g (node-rchild x)(node-rchild g) ))))
(define zag-zig
(lambda (g p x)
(node-reconstruct x (node-reconstruct g (node-lchild g) (node-lchild x)) (node-reconstruct p (node-rchild x)(node-rchild p) ))))
(define get-next-node
(lambda (actual key)
(let ((cmp (if (not (exist actual)) #f (compare key (node-key actual)))))
(cond
((equal? cmp 'right) (if (exist (node-rchild actual))
(cons (node-rchild actual) 'right)
#f))
((equal? cmp 'left) (if (exist (node-lchild actual))
(cons (node-lchild actual) 'left)
#f))
((equal? cmp 'youfoundme) (cons actual 'youfoundme))
(else #f)))))
; key est la clée recherchée du noeud a splayer
; g est la racine de l'arbre à splayer
(define node-splay
(lambda (g key)
;assign
(let ((p (get-next-node g key))) ; p est soit
(cond
((not (exist p)) g) ; dans le cas où le noeud cherché n'est pas dans l'arbre
((equal? (cdr p) 'youfoundme) g)
(else (let ((x (get-next-node (car p) key)))
(cond
((not (exist x)) g);dans le cas où le noeud cherché n'est pas dans l'arbre
((and (equal? (cdr x) 'youfoundme) (equal? (cdr p) 'right))
(zag g (car p)))
((and (equal? (cdr x) 'youfoundme) (equal? (cdr p) 'left))
(zig g (car p)))
((and (equal? (cdr x) 'right) (equal? (cdr p) 'right))
(zag-zag g (car p) (node-splay (car x) key)))
((and (equal? (cdr x) 'left) (equal? (cdr p) 'right))
(zag-zig g (car p) (node-splay (car x) key)))
((and (equal? (cdr x) 'right) (equal? (cdr p) 'left))
(zig-zag g (car p) (node-splay (car x) key)))
((and (equal? (cdr x) 'left) (equal? (cdr p) 'left))
(zig-zig g (car p) (node-splay (car x) key)))
(else (display 'wtfomgerreur)))))))))
#|
(display (node-splay '(((() (#\a) (#\a #\a) ()) (#\b) (#\b #\b) (() (#\c) (#\c #\c) ())) (#\d) (#\d #\d) ((() (#\e) (#\e #\e) ()) (#\f) (#\f #\f) (() (#\g) (#\g #\g) ())))
'(#\a)))
(newline)
(display (node-splay '(((() (#\a) (#\a #\a) ()) (#\b) (#\b #\b) (() (#\c) (#\c #\c) ())) (#\d) (#\d #\d) ((() (#\e) (#\e #\e) ()) (#\f) (#\f #\f) (() (#\g) (#\g #\g) ())))
'(#\b)))
(newline)
(display (node-splay '(((() (#\a) (#\a #\a) ()) (#\b) (#\b #\b) (() (#\c) (#\c #\c) ())) (#\d) (#\d #\d) ((() (#\e) (#\e #\e) ()) (#\f) (#\f #\f) (() (#\g) (#\g #\g) ())))
'(#\c)))
(newline)
(display (node-splay '(((() (#\a) (#\a #\a) ()) (#\b) (#\b #\b) (() (#\c) (#\c #\c) ())) (#\d) (#\d #\d) ((() (#\e) (#\e #\e) ()) (#\f) (#\f #\f) (() (#\g) (#\g #\g) ())))
'(#\d)))
(newline)
(display (node-splay '(((() (#\a) (#\a #\a) ()) (#\b) (#\b #\b) (() (#\c) (#\c #\c) ())) (#\d) (#\d #\d) ((() (#\e) (#\e #\e) ()) (#\f) (#\f #\f) (() (#\g) (#\g #\g) ())))
'(#\e)))
(newline)
(display (node-splay '(((() (#\a) (#\a #\a) ()) (#\b) (#\b #\b) (() (#\c) (#\c #\c) ())) (#\d) (#\d #\d) ((() (#\e) (#\e #\e) ()) (#\f) (#\f #\f) (() (#\g) (#\g #\g) ())))
'(#\f)))
(newline)
(display (node-splay '(((() (#\a) (#\a #\a) ()) (#\b) (#\b #\b) (() (#\c) (#\c #\c) ())) (#\d) (#\d #\d) ((() (#\e) (#\e #\e) ()) (#\f) (#\f #\f) (() (#\g) (#\g #\g) ())))
'(#\g)))
|#
(define node-insert
(lambda (root node)
(node-splay (_node-insert root node) (node-key node))))
(define _node-insert
(lambda (root node)
(let ((cmp (if (null? root) #f (compare (node-key node) (node-key root)))))
(cond
((equal? cmp 'youfoundme) (node-reconstruct node (node-lchild root) (node-rchild root)))
((equal? cmp 'right) (if (null? (node-rchild root))
(node-reconstruct root (node-lchild root) node)
(node-reconstruct root (node-lchild root) (_node-insert (node-rchild root) node))))
((equal? cmp 'left) (if (null? (node-lchild root))
(node-reconstruct root node (node-rchild root))
(node-reconstruct root (_node-insert (node-lchild root) node) (node-rchild root))))
(else node))))) ; ce cas arrive quand la root est nulle
;;;(display (node-insert '() '(() (a b) (d e f i n i t i o n) ())))
(define node-remove
(lambda (root key)
(let ((cmp (if (null? root) #f (compare key (node-key root)))))
(cond
((equal? cmp 'youfoundme) (if (null? (node-lchild root))
(node-rchild root)
(if (null? (node-rchild root))
(node-lchild root)
(node-insert (node-lchild root) (node-rchild root)))))
((equal? cmp 'right) (if (null? (node-rchild root))
root
(node-reconstruct root (node-lchild root) (node-remove (node-rchild root) key)))
)
((equal? cmp 'left) (if (null? (node-lchild root))
root
(node-reconstruct root (node-remove (node-lchild root) key) (node-rchild root))))
(else '())))
)
)
;;Retourne l'arbre splayé en fonction du noeud recherché. Retourne faux si l'élément n'est pas dans l'arbre
(define (node-find root key)
(let ((x (_node-find root key)))
(if x
(node-splay root (node-key x))
#f)))
;cherche et retourne le noeud avec une clé correspondante. retourne #f si le aucun noeud n'a une clé correspondante.
(define (_node-find root key)
(let ((cmp (if (null? root) #f (compare key (node-key root)))))
(cond
((equal? cmp 'youfoundme) root )
((equal? cmp 'right) (_node-find (node-rchild root) key))
((equal? cmp 'left) (_node-find (node-lchild root) key ))
(else #f)
)
)
)
;;;(assert (equal? (_node-find '((() (a) (b r a v o) () ) (b) (b) ()) '(a)) '(() (a) (b r a v o) ())))
;;;(assert (equal? (_node-find '(() (#\a) (#\d #\e #\f #\i #\n #\i #\t #\i #\o #\n) ()) '(#\a)) '(() (#\a) (#\d #\e #\f #\i #\n #\i #\t #\i #\o #\n) ())))
;;; Prend en input une liste de caractère, retourne une liste de liste de caractère séparé au niveau du char demandé
;;; ex. (string-split '(a p p l e + p i e + a r e + f u c k i n g + d e l i c i o u s)) => ((a p p l e) (p i e) (a r e) (f u c k i n g) ( d e l i c i o u s))
;;; (string-split '(a p p l e p i e)) => (a p p l e p i e)
(define string-split
(lambda (str chr)
(foldr
(lambda (x y)
(if (equal? x chr)
(cons '() y)
(cons (cons x (car y)) (cdr y))))
'(()) str)))
#|
(assert (equal? (string-split (caddr (eval-expr '(a b c #\= d e + f g + h i))) '+) '((d e) (f g) (h i))))
(assert (equal? (string-split '(a p p l e + p i e + a r e + f u c k i n g + d e l i c i o u s) '+) '((a p p l e) (p i e) (a r e) (f u c k i n g) ( d e l i c i o u s))) "string-split")
(assert (equal? (string-split '(a p p l e p i e) +) '((a p p l e p i e))) "split without token in list");;;si dans la liste à splitter il n'y a aucune occurence du séparateur,
;;;on retourne la liste de la liste initiale (1 niveau d'encapsulation)
(assert (equal? (string-split '(1 2 3) 2) '((1) (3))) "regular split")
(assert (equal? (string-split '() 2) '()) "splitting an empty list")
|#
;;;prend une liste de chaines et retourne la concatenation de ces chaines en une seule liste
;;;ex: ((a b c) (d e) (f g h i)) => (a b c d e f g h i)
(define (construire-def lst)
(foldr
(lambda(x y)
(append x y)
)
'()
lst
)
)
;; prends en input une liste de terme a concatener
;; retourne une liste de definition concatener
(define (make-concatdefinition dict lst)
(foldr
(lambda (x y)
(if (not (equal? y #f))
(let ((d (_node-find dict x)))
(if (and d y)
(cons (node-definition d) y)
#f))
#f))
'() lst))
#|
(assert (equal? (make-concatdefinition '(()(#\a #\b #\c)(#\p #\a #\t #\a #\t #\e)(() (#\d #\e #\f) (#\p #\o #\i #\l) ())) '((#\a #\b #\c) (#\d #\e #\f)) ) '((#\p #\a #\t #\a #\t #\e) (#\p #\o #\i #\l))) "test de concatenation de definition")
(assert(equal? (make-concatdefinition '(() (#\a #\b) (#\z #\z #\z) ()) '((#\a #\b))) '((#\z #\z #\z))) "test de make-concatdefinition")
(assert (equal? (make-concatdefinition '(() (#\b) (#\b #\b #\b) (() (#\c) (#\c #\c #\c) ())) '((#\b) (#\c))) '((#\b #\b #\b) (#\c #\c #\c))) "test de make-concatdefinition")
|#
(define (eval-expr expr)
(if (member #\= expr)
(let ((expr2 (string-split expr #\=)))
(if (null? (cadr expr2))
(cons '- (list (car expr2)));;;retrait du mot expr
(append (list '= (car expr2))
(cdr expr2));;;ajouter le mot. REMARQUE: S'il y a plusieurs '= dans expr, c'est bizarre
)
)
(cons '% expr);;;recherche du mot expr
)
)
#|
(assert (equal? (eval-expr '(a b c #\= d e + f g + h i)) '(= (a b c) (d e + f g + h i))))
(assert (equal? (eval-expr '(q w e 1 2 3 )) '(q w e 1 2 3)))
(assert (equal? (eval-expr '(a b c = d e f)) '(= (a b c) (d e f))))
(assert (equal? (eval-expr '(q w e 1 2 3 )) '(q w e 1 2 3)))
;; TESTÉ
;;;(eval-expr '(a b c =)) => (- (a b c))
;;;(eval-expr '(a b c)) => (a b c)
;;;(eval-expr '(a b c = d e f)) => (= (a b c) (d e f))
(define (affichage-dict dictio)
(begin
(newline)
(display 'dict:)
(display dictio)
(newline)
dictio
)
)
|#
;;;----------------------------------------------------------------------------
(define traiter
(lambda (expr dict)
;;;evaluer l'expression
(if (null? expr) (cons (string->list "entree vide\n") dict) ;;;l'utilisateur a taper enter et rien d'autre.
(let ((result (eval-expr expr)))
(if (exist (cdr result))
(cond ((equal? (car result) '-);;;result est de la forme ('- key) et il faut remove le mot key
(cons (string->list "") (node-remove dict (cadr result))));;;appel à node-remove avec (cdr result)?
((equal? (car result) '=);;;result est de la forme ('= key definition) et il faut ajouter le mot key
(if (member #\+ (caddr result))
(let ((d (make-concatdefinition dict (string-split (caddr result) #\+))))
(if d
(cons (string->list "") (node-insert dict (node-create (cadr result) (construire-def d) '() '())))
(cons (string->list "terme inconnu\n") dict)))
(cons (string->list "") (node-insert dict (node-create (cadr result) (caddr result) '() '())))));;;ajout normal
((equal? (car result) '%) ;;;result est de la forme ('% key) et il faut rechercher le mot key
(let ((n (node-find dict (cdr result))))
(if n
(cons (append (node-definition n) (list #\newline)) n)
(cons (string->list "terme inconnu\n") dict))))
(else (cons (string->list "???\n") dict)))
(cons (string->list "entree non-valide\n") dict))))))
;;;----------------------------------------------------------------------------
;;; Ne pas modifier cette section.
(define go
(lambda (dict)
(print "? ")
(let ((ligne (read-line)))
(if (string? ligne)
(let ((r (traiter-ligne ligne dict)))
(for-each write-char (car r))
(go (cdr r)))))))
(define traiter-ligne
(lambda (ligne dict)
(traiter (string->list ligne) dict)))
(go '()) ;; dictionnaire initial est vide
;;;----------------------------------------------------------------------------