1 files changed, 107 insertions, 0 deletions
diff --git a/js/games/nluqo.github.io/~bh/downloads/simply/match.scm b/js/games/nluqo.github.io/~bh/downloads/simply/match.scm
new file mode 100644
index 0000000..f454f68
--- /dev/null
+++ b/js/games/nluqo.github.io/~bh/downloads/simply/match.scm
@@ -0,0 +1,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 '!)))