blob: f454f682d2b23303a51d03aa682d5c6f2018701d (
plain) (
blame)
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
|
(define (match pattern sent)
(match-using-known-values pattern sent '()))
(define (match-using-known-values pattern sent known-values)
(cond ((empty? pattern)
(if (empty? sent) known-values 'failed))
((special? (first pattern))
(let ((placeholder (first pattern)))
(match-special (first placeholder)
(bf placeholder)
(bf pattern)
sent
known-values)))
((empty? sent) 'failed)
((equal? (first pattern) (first sent))
(match-using-known-values (bf pattern) (bf sent) known-values))
(else 'failed)))
(define (special? wd)
(member? (first wd) '(* & ? !)))
(define (match-special howmany name pattern-rest sent known-values)
(let ((old-value (lookup name known-values)))
(cond ((not (equal? old-value 'no-value))
(if (length-ok? old-value howmany)
(already-known-match
old-value pattern-rest sent known-values)
'failed))
((equal? howmany '?)
(longest-match name pattern-rest sent 0 #t known-values))
((equal? howmany '!)
(longest-match name pattern-rest sent 1 #t known-values))
((equal? howmany '*)
(longest-match name pattern-rest sent 0 #f known-values))
((equal? howmany '&)
(longest-match name pattern-rest sent 1 #f known-values)))))
(define (length-ok? value howmany)
(cond ((empty? value) (member? howmany '(? *)))
((not (empty? (bf value))) (member? howmany '(* &)))
(else #t)))
(define (already-known-match value pattern-rest sent known-values)
(let ((unmatched (chop-leading-substring value sent)))
(if (not (equal? unmatched 'failed))
(match-using-known-values pattern-rest unmatched known-values)
'failed)))
(define (chop-leading-substring value sent)
(cond ((empty? value) sent)
((empty? sent) 'failed)
((equal? (first value) (first sent))
(chop-leading-substring (bf value) (bf sent)))
(else 'failed)))
(define (longest-match name pattern-rest sent min max-one? known-values)
(cond ((empty? sent)
(if (= min 0)
(match-using-known-values pattern-rest
sent
(add name '() known-values))
'failed))
(max-one?
(lm-helper name pattern-rest (se (first sent))
(bf sent) min known-values))
(else (lm-helper name pattern-rest
sent '() min known-values))))
(define (lm-helper name pattern-rest
sent-matched sent-unmatched min known-values)
(if (< (length sent-matched) min)
'failed
(let ((tentative-result (match-using-known-values
pattern-rest
sent-unmatched
(add name sent-matched known-values))))
(cond ((not (equal? tentative-result 'failed)) tentative-result)
((empty? sent-matched) 'failed)
(else (lm-helper name
pattern-rest
(bl sent-matched)
(se (last sent-matched) sent-unmatched)
min
known-values))))))
;;; Known values database abstract data type
(define (lookup name known-values)
(cond ((empty? known-values) 'no-value)
((equal? (first known-values) name)
(get-value (bf known-values)))
(else (lookup name (skip-value known-values)))))
(define (get-value stuff)
(if (equal? (first stuff) '!)
'()
(se (first stuff) (get-value (bf stuff)))))
(define (skip-value stuff)
(if (equal? (first stuff) '!)
(bf stuff)
(skip-value (bf stuff))))
(define (add name value known-values)
(if (empty? name)
known-values
(se known-values name value '!)))
|