;;; Copyright (c) 1998-2001 John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen ;;; see LICENSE for conditions (in-package :lkb) ;;; test functions for generation ;;; evaluate the following for this stuff to be run ;;; as part of LKB batch testing ;;; currently only works in Allegro CL because of timing #| (defparameter *do-something-with-parse* 'check-generate) (defparameter *first-only-p* t) |# #| output results 0. input sentence 1. strings 2. error caused 3. total edges 4. gc time 5. cpu time 6. real time |# (defun read-gen-test-file (file-name) ;;; takes a file of output results from generation, and produces ;;; averages etc (let ((sentence-count 0) (total-sentence-length 0) (total-strings 0) (total-edges 0) (total-time 0)) (with-open-file (istream file-name :direction :input) (loop (let ((res (read istream nil nil))) (unless res (return)) ; (format t "~%~S" res) (let* ((input-sentence (elt res 0)) (input-sentence-text (apply #'concatenate 'string (add-spaces input-sentence))) (strings (elt res 1)) (strings-text (mapcar #'(lambda (str) (preprocess-sentence-string (apply #'concatenate 'string (add-spaces str)))) strings)) (errorp (elt res 2)) (edges (elt res 3)) (time (elt res 5))) (if errorp (format t "~%Error when generating from ~A - results ignored" input-sentence-text) (progn (if strings-text (unless (member input-sentence-text strings-text :test #'string-equal) (format t "~%String not matched when generating from ~A" input-sentence-text)) (format t "~%No strings generated from ~A" input-sentence-text)) (setf sentence-count (+ sentence-count 1)) (setf total-sentence-length (+ total-sentence-length (length input-sentence))) (setf total-strings (+ total-strings (length strings))) (setf total-edges (+ total-edges edges)) (setf total-time (+ total-time time))))))) (format t "~%Mean length ~,2F Mean strings ~,2F Mean edges ~,1F Mean time ~,1F secs" (/ total-sentence-length sentence-count) (/ total-strings sentence-count) (/ total-edges sentence-count) (/ (/ total-time sentence-count) 1000))))) (defun read-gen-test-file1 (file-name) ;;; takes a file of output results from generation, and produces ;;; averages etc (let ((sentence-count 0) (total-input-sentence-length 0) (total-success-sentence-length 0) (total-output-sentence-length 0) (total-strings 0) (total-edges 0) (total-time 0)) (with-open-file (istream file-name :direction :input) (loop (let ((res (read istream nil nil))) (unless res (return)) ; (format t "~%~S" res) (let* ((input-sentence (split-into-words (preprocess-sentence-string (elt res 0)))) (input-sentence-text (apply #'concatenate 'string (add-spaces input-sentence))) (strings (elt res 1)) (strings-text (mapcar #'(lambda (str) (preprocess-sentence-string (apply #'concatenate 'string (add-spaces str)))) strings)) (errorp (elt res 2)) (edges (if (numberp (elt res 3)) (+ (elt (elt res 3) 4) (elt (elt res 3) 5)) 0)) (time (elt res 4))) (if errorp (format t "~%Error when generating from ~A - results ignored" input-sentence-text) (progn (if strings-text (unless (member input-sentence-text strings-text :test #'string-equal) (format t "~%String not matched when generating from ~A" input-sentence-text)) (format t "~%No strings generated from ~A" input-sentence-text)) (setf sentence-count (+ sentence-count 1)) (setf total-input-sentence-length (+ total-input-sentence-length (length input-sentence))) (when strings (setf total-success-sentence-length (+ total-success-sentence-length (length input-sentence))) (setf total-output-sentence-length (+ total-output-sentence-length (/ (reduce #'+ (mapcar #'length strings)) (length strings))))) (print (/ total-output-sentence-length (float sentence-count))) (setf total-strings (+ total-strings (length strings))) (setf total-edges (+ total-edges edges)) (setf total-time (+ total-time time))))))) (format t "~%Mean input length ~,2F Mean input when output ~,2F Mean output length ~,2F Mean strings/sentence ~,2F Mean edges ~,1F Mean time ~,1F secs" (/ total-input-sentence-length sentence-count) (/ total-success-sentence-length sentence-count) (/ total-output-sentence-length sentence-count) (/ total-strings sentence-count) (/ total-edges sentence-count) (/ (/ total-time sentence-count) 1000))))) (defun pick-from-gen-test-file1 (file-name) ;;; takes a file of output results from generation, and produces ;;; averages etc (with-open-file (istream file-name :direction :input) (loop (let ((res (read istream nil nil))) (unless res (return)) ; (format t "~%~S" res) (let* ((input-sentence (elt res 0)) (input-sentence-text input-sentence ;; (apply #'concatenate 'string (add-spaces input-sentence)) ) ; (strings (elt res 1)) #| (strings-text (mapcar #'(lambda (str) (preprocess-sentence-string (apply #'concatenate 'string (add-spaces str)))) strings)) |# (errorp (elt res 2)) (edges (and (elt res 3) (+ (elt (elt res 3) 4) (elt (elt res 3) 5)))) (time (elt res 4))) (if (and (not errorp) (> time 10000)) (format t "~%~A time ~A edges ~A" input-sentence-text time edges))))))) (defun add-spaces (str-list) (cons (car str-list) (loop for str in (cdr str-list) append (list " " str)))) (defun compare-gen-test-files (file-name1 file-name2) ;;; compares two files of output results from generation (with-open-file (istream1 file-name1 :direction :input) (with-open-file (istream2 file-name2 :direction :input) (loop (let ((res1 (read istream1 nil nil)) (res2 (read istream2 nil nil))) (unless (and res1 res2) (return)) (let* ((input-sentence1 (elt res1 0)) (input-sentence2 (elt res2 0))) (unless (equalp input-sentence1 input-sentence2) (error "~%Unequal sentences")) (let ((input-sentence-text (apply #'concatenate 'string (add-spaces input-sentence1))) (strings1 (elt res1 1)) (strings2 (elt res2 1)) (errorp1 (elt res1 2)) (errorp2 (elt res2 2)) (edges1 (elt res1 3)) (edges2 (elt res2 3))) (unless (equal errorp1 errorp2) (format t "~%Differences in error in ~A" input-sentence-text) (format t "~%1 ~A" res1) (format t "~%2 ~A" res2)) (unless (string-set-equal strings1 strings2) (format t "~%Differences in strings in ~A" input-sentence-text) (format t "~%1 ~A" res1) (format t "~%2 ~A" res2)) (unless (eql edges1 edges2) (format t "~%Differences in edges in ~A" input-sentence-text) (format t "~%Edges ~A ~A" edges1 edges2)) ))))))) (defun compare-gen-test-files1 (file-name1 file-name2) ;;; compares two files of output results from generation (with-open-file (istream1 file-name1 :direction :input) (with-open-file (istream2 file-name2 :direction :input) (let ((total1 0) (total2 0) (count 0)) (loop (let ((res1 (read istream1 nil nil)) (res2 (read istream2 nil nil))) (unless (and res1 res2) (return)) (let* ((input-sentence1 (split-into-words (preprocess-sentence-string (elt res1 0)))) (input-sentence2 (split-into-words (preprocess-sentence-string (elt res2 0))))) (unless (equalp input-sentence1 input-sentence2) (error "~%Unequal sentences")) (let ((input-sentence-text (apply #'concatenate 'string (add-spaces input-sentence1))) (strings1 (elt res1 1)) (strings2 (elt res2 1)) (errorp1 (elt res1 2)) (errorp2 (elt res2 2)) (time1 (elt res1 4)) (time2 (elt res2 4))) (unless (equal errorp1 errorp2) (format t "~%Differences in error in ~A" input-sentence-text) (format t "~%1 ~A" res1) (format t "~%2 ~A" res2)) (unless (string-set-equal strings1 strings2) (format t "~%Differences in strings in ~A" input-sentence-text) (format t "~%1 ~A" res1) (format t "~%2 ~A" res2)) (when (equal errorp1 errorp2) (setf total1 (+ total1 time1)) (setf total2 (+ total2 time2)) (incf count)))))) (format t "~%mean time run 1: ~,1F seconds ~% mean time run 2: ~,1F seconds" (/ (/ total1 count) 1000) (/ (/ total2 count) 1000)))))) (defun string-set-equal (set1 set2) (and (eql (length set1) (length set2)) (every #'(lambda (x) (member x set2 :test #'equal)) set1))) (defun read-gen-test-file-stats1 (file-name) ;;; produces averages of internal stats and time/space (let ((items 0) (internal-totals (make-list 7 :initial-element 0)) (time-totals (make-list 4 :initial-element 0))) (with-open-file (istream file-name :direction :input) (loop (let ((res (read istream nil nil))) (unless res (setq items (float items)) (dolist (final-totals (list internal-totals time-totals)) (mapl #'(lambda (totals) (setf (car totals) (/ (car totals) items))) final-totals)) (format t "~&~:{~^ ~A=~,2F~}~%" (mapcar #'list (list "items" "filter" "etasks" "stasks" "unifs" "copies" "aedges" "pedges" "tcpu" "tgc" "treal" "space") (list* items (* 100 (/ (car internal-totals) (+ (cadr internal-totals) (car internal-totals)))) (append (cdr internal-totals) time-totals)))) (return)) (unless (elt res 2) ; error? (print (elt res 3)) (incf items) (mapl #'(lambda (stats totals) (incf (car totals) (car stats))) (elt res 3) internal-totals) (mapl #'(lambda (stats totals) (incf (car totals) (car stats))) (nthcdr 4 res) time-totals))))))) ;;; ************************************************************** (defun check-generate nil (let ((sentence *sentence*) (ostream (if (and *ostream* (streamp *ostream*) (output-stream-p *ostream*)) *ostream* t))) (unless *parse-record* (format ostream "~%#| Parse failure: ~A |#" sentence)) (loop for parse-res in *parse-record* do (let ((mrs (mrs::extract-mrs parse-res)) (tgc nil) (tcpu nil) (treal nil) (space nil) (errorp nil)) ;; ;; when generating from a parse, dag recycling caused a serious ;; problem. apparently, something in the generator makes reference ;; to a dag node allocated from the pool in the parser. when the ;; pool is reset prior to generation, this backward reference causes ;; desaster (though curiously not for all sentences; ``Abrams will ;; interview Browne as soon as Browne sleeps.'' seems a good test). ;; supposedly, the MRS structure extracted from the parser is fully ;; self-contained; so, if nothing else referenced parser results, ;; resetting the pool on entry to the generator would be the right ;; thing. room for debugging here ... (8-sep-99 - oe) ;; ;; following should fix the problem - aac (when mrs::*null-semantics-hack-p* (format ostream "~%#| Setting mrs::*null-semantics-hack-p* to nil |#") (setf mrs::*null-semantics-hack-p* nil)) #+:pooling (reset-pools #+:gdebug :forcep #+:gdebug t) ;; check for scoping, because incorrect MRS often ;; causes serious problems for generator (if (not (mrs::make-scoped-mrs mrs)) (format ostream "~%#| Scope failure: ~A |#~%" sentence) (multiple-value-bind (strings ftasks etasks stasks unifs copies aedges pedges) (time-a-funcall #'(lambda () (#-:gdebug handler-case #+:gdebug progn (generate-from-mrs mrs) #-:gdebug (storage-condition (condition) (format t "~%Memory allocation problem in generation: ~A caused by ~A~%" condition sentence) (setf errorp t)) #-:gdebug (error (condition) (format t "~%Error in generation: ~A caused by ~A~%" condition sentence) (setf errorp t)))) #'(lambda (tgcu tgcs tu ts tr scons ssym sother &rest ignore) (declare (ignore ignore)) (setq tgc (+ tgcu tgcs)) (setq tcpu (+ tu ts)) (setq treal tr) (setq space (+ (* scons 8) (* ssym 24) sother)))) (declare (ignore unifs-tried unifs-failed)) (clear-gen-chart) ; prevent any recycled dags from hanging around (unless (and (integerp aedges) (integerp pedges)) (setf errorp t) (format t "~%Problem in generation caused by missing relation?")) (let ((*print-escape* t) (*print-length* nil) (*print-level* nil)) (format ostream "~%(~S~%~:S ~S~{~^ ~:S~})~%" sentence (if (listp strings) strings nil) errorp (list (if errorp nil (list ftasks etasks stasks unifs copies aedges pedges)) (if errorp -1 tcpu) (if errorp -1 tgc) (if errorp -1 treal) (if errorp -1 space)))) (finish-output ostream))))))) ;;; Generate from a file of MRSs. Analogous to batch-parse-sentences. ;;; ;;; Fixes a few issues and omissions in the check-generate function above. JAC 5-Jul-2020 (defun generate-from-mrs-file (file ostream) (clear-type-cache) (setq ostream (if (null ostream) *standard-output* ostream)) (when mrs::*null-semantics-hack-p* (format ostream "~%#| Setting mrs::*null-semantics-hack-p* to nil |#") (setq mrs::*null-semantics-hack-p* nil)) (let* ((mrss (mrs::read-mrs-files-aux (list file))) (nmrs 0) (edge-total 0) (strings-total 0) (start-time (get-internal-run-time)) #+:sbcl (gc-bytes (sb-ext:bytes-consed-between-gcs))) #+:sbcl (setf (sb-ext:bytes-consed-between-gcs) (truncate (* #+:x86-64 1 #-:x86-64 0.5 (expt 2 30)))) ; double usual (unwind-protect (loop for mrs in mrss when (and mrs (mrs::psoa-p mrs)) do (incf nmrs) (let ((tgc nil) (tcpu nil) (treal nil) (errorp nil) #+:pooling (*dag-recycling-p* t)) ; !!! missing from check-generate #+:pooling (reset-pools #+:gdebug :forcep #+:gdebug t) ;; no check for scoping here, since input MRSes are assumed to be ;; well-formed (multiple-value-bind (strings unifs-tried unifs-failed active inactive) (time-a-funcall #'(lambda () (#-:gdebug handler-case #+:gdebug progn (generate-from-mrs mrs :signal t) #-:gdebug (storage-condition (condition) (format t "~&Memory allocation problem in generation: ~A~%" condition) (setq errorp t)) #+(and (not :gdebug) (or :allegro :sbcl :ccl)) (#+:allegro excl:interrupt-signal #+:sbcl sb-sys:interactive-interrupt #+:ccl ccl:interrupt-signal-condition () (error "Interrupt signalled")) #-:gdebug (error (condition) (format t "~&Error in generation: ~A~%" condition) (setq errorp t)))) #'(lambda (tgcu tgcs tu ts tr scons ssym sother &rest rest) (declare (ignore scons ssym sother rest)) (setq tgc (+ tgcu tgcs)) (setq tcpu (+ tu ts)) (setq treal tr))) (declare (ignore unifs-tried unifs-failed)) (unless (listp strings) (setq strings nil)) (incf strings-total (length strings)) (incf edge-total *edge-id*) (format ostream "~&(~A~%" nmrs) (format ostream "(~{~S~^~% ~}) ~A ~A ~A ~A ~A)~%~%" strings errorp (if errorp -1 (+ active inactive)) (if errorp -1 tgc) (if errorp -1 tcpu) (if errorp -1 treal)) (force-output ostream))) finally (format ostream "~&;;; Total CPU time: ~A msecs~%" (round (* (- (get-internal-run-time) start-time) 1000) internal-time-units-per-second)) (format ostream ";;; Mean edges: ~,2F~%" (/ edge-total nmrs)) (format ostream ";;; Mean realisations: ~,2F~%~%" (/ strings-total nmrs)) (finish-output ostream)) (flush-agenda *agenda*) ; clear out agenda in case of early exit from last generate #+:pooling (reset-pools #+:gdebug :forcep #+:gdebug t) (clear-gen-chart) ; prevent access to any dags in recycling pool #+:sbcl (setf (sb-ext:bytes-consed-between-gcs) gc-bytes) #+:sbcl (sb-ext:gc :full t) ; release unused memory, shrinking process size )))