fixed test14

jpbarrette · Sep 15, 2007 · b167323 · b167323
1 parent 38c1ea5
commit b167323
Show file tree

Hide file tree

Showing 4 changed files with 104 additions and 78 deletions.
diff --git a/finenight/lisp/iadfa-run.lisp b/finenight/lisp/iadfa-run.lisp
@@ -10,6 +10,7 @@
       (dolist (word (extract-words fsa))
 	(format str "~A~%" word)))))
 
+;(detect-problems-from-file "../../data/com.zone.sorted.small")
 (iadfa-run)
 
 

diff --git a/finenight/lisp/iadfa-test.lisp b/finenight/lisp/iadfa-test.lisp
@@ -17,79 +17,6 @@
 					    "cappend" "cappendice"
 					    "mormont")))
 
-(defmacro test-equivalence (words)
-  (with-syms (w iadfa output)
-    `(let* ((,w ,words)
-            (,iadfa (debug-gen-iadfa ,w))
-	    (,output nil))
-       (setf ,output (extract-words (iadfa-fsa ,iadfa)))
-       (format t "input:~%~S~%output:~%~S~%" ,w ,output)
-       (equal ,w ,output))))
-
-(defun detect-problems (words)
-  (let ((iadfa (build-iadfa))
-	(words-to-be-checked nil))
-    (dolist (word words)
-      (setf words-to-be-checked (nconc words-to-be-checked (list word)))
-      (handle-word iadfa (concatenate 'list word))
-      (when (not (equal words-to-be-checked 
-			(extract-words (iadfa-fsa iadfa))))
-	(return)))
-    ;; We got the first entry that trigger the problem.
-    ;; we need now to see which entry is needed to start
-    ;; the problem
-    words-to-be-checked))
-
-
-(defun detect-first-starting-problematic-word (words-to-be-checked)
-  (let ((wtbc (cdr words-to-be-checked))
-	(last-word (car words-to-be-checked)))
-    (do ((iadfa (gen-iadfa wtbc) (gen-iadfa wtbc)))
-	((null wtbc))
-      (if (equal wtbc
-		 (extract-words (iadfa-fsa iadfa)))
-	  (return (cons last-word wtbc)))
-      (setf last-word (car wtbc))
-      (setf wtbc (cdr wtbc)))))
-
-(defun filter-non-problematic-words (words-to-be-checked)
-  (let ((problematics-words (list (car words-to-be-checked)))
-	(last-word (cadr words-to-be-checked))
-	(words-to-be-checked (cddr words-to-be-checked)))
-    (do ((iadfa (gen-iadfa (append problematics-words words-to-be-checked))
-		(gen-iadfa (append problematics-words words-to-be-checked))))
-	((null words-to-be-checked))
-      (if (equal (append problematics-words words-to-be-checked)
-		 (extract-words (iadfa-fsa iadfa)))
-	  (setf problematics-words (nconc problematics-words (list last-word))))
-      (setf last-word (car words-to-be-checked))
-      (setf words-to-be-checked (cdr words-to-be-checked)))
-    (setf problematics-words (nconc problematics-words (list last-word)))
-    problematics-words))
-
-
-(defun detect-problems-from-file (filename)
-  (let ((words-to-be-checked nil))
-    (let ((iadfa (build-iadfa)))
-      (for-each-line-in-file (word filename)
-	(setf words-to-be-checked (nconc words-to-be-checked (list word)))
-	(handle-word iadfa (concatenate 'list word))
-	(when (not (equal words-to-be-checked 
-			  (extract-words (iadfa-fsa iadfa))))
-	  (return))
-	nil))
-    ;; We got the first entry that trigger the problem.
-    ;; we need now to see which entry is needed to start
-    ;; the problem
-    (setf words-to-be-checked 
-	  (detect-first-starting-problematic-word words-to-be-checked))
-    (setf words-to-be-checked
-	  (filter-non-problematic-words words-to-be-checked))
-    words-to-be-checked))
-
-
-
-(detect-problems-from-file "../../data/com.zone.sorted.small")
 
 (defun iadfa-non-branch-suffix ()
   "This tests that the output of the iadfa isn't screwed up 
@@ -211,7 +138,7 @@ produce a stem shorter than the previous stem.
 		      "0-7-2")))
 
 (org.ancar.CLUnit::deftest "IADFA Test 12"
-    :category "Subsumed previs stems." 
+    :category "Subsumed previouss stems." 
     :test-fn #'iadfa-test12)
 
 (defun iadfa-test13 ()
@@ -227,6 +154,22 @@ stem"
 		      "0-500"
 		      "0-500MPH")))
 
+(org.ancar.CLUnit::deftest "IADFA Test 13"
+    :category "Subsumed previous stems." 
+    :test-fn #'iadfa-test13)
+
+(defun iadfa-test14 ()
+  "The common suffix was wrongly programmed for previous stem.
+The right behavior is not to consume it, and stop when current-suffix
+is equal to previous-stem."
+  (test-equivalence '("0-APR-CREDITS-CARD" 
+		      "0-APRCREDIT-CARD" 
+		      "0-APRCREDITCARD")))
+
+(org.ancar.CLUnit::deftest "IADFA Test 14"
+    :category "Subsumed previous stems." 
+    :test-fn #'iadfa-test14)
+
 (org.ancar.CLUnit::deftest "IADFA Test 1"
     :category "Destinations" 
     :test-fn #'iadfa-test1)

diff --git a/finenight/lisp/iadfa.lisp b/finenight/lisp/iadfa.lisp
@@ -181,20 +181,22 @@
 (defun c-suffix (iadfa current-suffix node prefix-node profile sub-stem)
   (if (or (= 1 (length current-suffix)) 
 	  (= 1 (length profile)) 
-	  (= 1 (length sub-stem))
+	  ;(= 1 (length sub-stem))
 	  (= (length sub-stem) (length current-suffix)))
       (values node (reverse current-suffix) (reverse profile))
       (let ((next-node (ancestror-transition iadfa node (car current-suffix) (car profile))))
 ;; 	(if (equal '(#\0 #\- #\7) current-suffix)
 ;; 	    (break))
-	(if (or (not next-node) (eq next-node prefix-node) (eq next-node (fsa-start-node (iadfa-fsa iadfa))))
+	(if (or (not next-node) 
+		(eq next-node prefix-node) 
+		(eq next-node (fsa-start-node (iadfa-fsa iadfa))))
 	    (values node (reverse current-suffix) (reverse profile))
 	    (c-suffix iadfa
 		      (cdr current-suffix)
 		      next-node
 		      prefix-node
 		      (cdr profile)
-		      (cdr sub-stem))))))
+		      sub-stem)))))
 
 
 (defun common-suffix  (iadfa current-suffix node prefix-node profile sub-stem)
@@ -307,6 +309,84 @@
       iadfa)
   iadfa))
 
+
+(defmacro test-equivalence (words)
+  (with-syms (w iadfa output)
+    `(let* ((,w ,words)
+            (,iadfa (debug-gen-iadfa ,w))
+	    (,output nil))
+       (setf ,output (extract-words (iadfa-fsa ,iadfa)))
+       (format t "input:~%~S~%output:~%~S~%" ,w ,output)
+       (equal ,w ,output))))
+
+
+(defun detect-problems (words)
+  (let ((iadfa (build-iadfa))
+	(words-to-be-checked nil))
+    (dolist (word words)
+      (setf words-to-be-checked (nconc words-to-be-checked (list word)))
+      (handle-word iadfa (concatenate 'list word))
+      (when (not (equal words-to-be-checked 
+			(extract-words (iadfa-fsa iadfa))))
+	(return)))
+    ;; We got the first entry that trigger the problem.
+    ;; we need now to see which entry is needed to start
+    ;; the problem
+    words-to-be-checked))
+
+
+(defun detect-first-starting-problematic-word (words-to-be-checked)
+  (let ((wtbc (cdr words-to-be-checked))
+	(last-word (car words-to-be-checked)))
+    (do ((iadfa (gen-iadfa wtbc) (gen-iadfa wtbc)))
+	((null wtbc))
+      (if (equal wtbc
+		 (extract-words (iadfa-fsa iadfa)))
+	  (return (cons last-word wtbc)))
+      (setf last-word (car wtbc))
+      (setf wtbc (cdr wtbc)))))
+
+(defun filter-non-problematic-words (words-to-be-checked)
+  (let ((problematics-words (list (car words-to-be-checked)))
+	(last-word (cadr words-to-be-checked))
+	(words-to-be-checked (cddr words-to-be-checked)))
+    (do ((iadfa (gen-iadfa (append problematics-words words-to-be-checked))
+		(gen-iadfa (append problematics-words words-to-be-checked))))
+	((null words-to-be-checked))
+      (if (equal (append problematics-words words-to-be-checked)
+		 (extract-words (iadfa-fsa iadfa)))
+	  (setf problematics-words (nconc problematics-words (list last-word))))
+      (setf last-word (car words-to-be-checked))
+      (setf words-to-be-checked (cdr words-to-be-checked)))
+    (setf problematics-words (nconc problematics-words (list last-word)))
+    problematics-words))
+
+
+(defun detect-problems-from-file (filename)
+  (let ((words-to-be-checked nil))
+    (let ((iadfa (build-iadfa)))
+      (for-each-line-in-file (word filename)
+	(setf words-to-be-checked (nconc words-to-be-checked (list word)))
+	(format t "Processing word [~A].~%" word)
+	(handle-word iadfa (concatenate 'list word))
+	(when (not (equal words-to-be-checked 
+			  (extract-words (iadfa-fsa iadfa))))
+	  (format t "Word [~A] triggered a problem.~%" word)
+	  (return))
+	nil))
+    ;; We got the first entry that trigger the problem.
+    ;; we need now to see which entry is needed to start
+    ;; the problem
+    (setf words-to-be-checked 
+	  (detect-first-starting-problematic-word words-to-be-checked))
+    (setf words-to-be-checked
+	  (filter-non-problematic-words words-to-be-checked))
+    words-to-be-checked))
+
+
+
+
+
 ;; (defun dump-words (iadfa)
 ;;   (let ((fsa (iadfa-fsa))
 ;; 	(states (list (cons "" (fsa-start-node start)))))

diff --git a/finenight/lisp/package.lisp b/finenight/lisp/package.lisp
@@ -83,4 +83,6 @@
 	   :iadfa-state-ancestrors
 	   :make-fsa-builder-from-fsa
 	   :nadd-edge
-	   :transition))
+	   :transition
+	   :detect-problems-from-file
+	   :test-equivalence))