;;; Copyright (c) 1998-2021
;;;   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

#|
(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 :signal t)
                          #-: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))))
                 (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

(defun generate-from-mrs-file (file ostream &aux
                               #+(and :sbcl :64-bit) (gc-bytes (sb-ext:bytes-consed-between-gcs)))
  ;; we don't call clear-expanded-lex here it since messes up generator index
  (clear-type-cache)
  (clear-temporary-data)

  (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)))
    (unwind-protect
      (loop
          initially
            #+(and :sbcl :64-bit)
            (progn
              (setf (sb-ext:bytes-consed-between-gcs)
                (* 8 (expt 2 30))) ; 8GB allocation before gc triggered automatically
              (sb-ext:gc :full t)) ; tenure everything so generation 0 starts empty
            ;; start timing here to omit initial GC which we shouldn't be accountable for
            (setq start-time (get-internal-run-time))

          for mrs in mrss
          when (and mrs (mrs::psoa-p mrs))
          do
            (incf nmrs)
  
            #+(and :sbcl :64-bit) ; >2GB allocated since last GC?
            (when (> (sb-ext:generation-bytes-allocated 0) (* 2 (expt 2 30)))
              (clear-temporary-data)
              (sb-ext:gc)
              (when (> (sb-ext:generation-bytes-allocated 0) (* 1/2 (expt 2 30))) ; in trouble?
                (sb-ext:gc :full t)))
  
            (let ((tgc nil) (tcpu nil) (treal nil) (errorp nil)
                  #+:pooling (*dag-recycling-p* t))
              #+:pooling (reset-pools #+:gdebug :forcep #+:gdebug t)
              (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))))

      (unexpand-leaf-types) ; also does clear-expanded-lex, clear-type-cache
      (clear-temporary-data)
      #+(and :sbcl :64-bit)
      (progn
        (setf (sb-ext:bytes-consed-between-gcs) gc-bytes)
        (sb-ext:gc :full t))) ; release unused memory, shrinking process size

    (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)
    (lkb-beep)
    nil))