;;;   -*- Mode: LISP; Package: CGP; BASE: 10; Syntax: ANSI-Common-Lisp; Readtable: augmented-readtable-*-
;;
;; Copyright (C) Paul Meurer 2000 - 2007. All rights reserved.
;; paul.meurer@aksis.uib.no
;; Aksis, UNIFOB, University of Bergen
;;

(in-package :cgp)

(defclass feature-filter ()
  ((filter-bv :initform nil :initarg :filter-bv :accessor filter-bitvector)
   (pos-list :initform nil :initarg :pos-list)
   (substitutions :initform nil :initarg :substitutions :accessor string-substitutions)))

(defmethod map-filter-features ((filter feature-filter)) nil)

(defmethod map-syntactic-functions ((filter feature-filter)) nil)

(defclass feature-map-filter (feature-filter)
  ((tagger :initform nil :initarg :tagger :reader multi-tagger)
   (map-filter-features :initform nil :initarg :map-filter-features :reader map-filter-features) ;; rename!
   (map-syntactic-functions :initform () :initarg :syntactic-functions :reader map-syntactic-functions)
   (feature-mapping-fn :initform nil :initarg :feature-mapping-fn :reader feature-mapping-fn)))

(defmethod initialize-instance :after ((filter feature-map-filter) &key syntactic-functions &allow-other-keys)
  (with-slots (map-syntactic-functions map-filter-features) filter
    (setf map-syntactic-functions
	  (loop for sf in syntactic-functions
		collect (position sf map-filter-features)))))

(defun %filter-features (feature-bv filter-bv &optional union-bv)
  (let ((filtered-feature-bv
	 (or union-bv (make-array (length feature-bv) :element-type 'bit :initial-element 0))))
    (loop for i from 0 to (1- (length feature-bv))
	when (and (= 1 (bit filter-bv i)) (= 0 (bit filtered-feature-bv i)))
	do (setf (bit filtered-feature-bv i) (bit feature-bv i)))
    filtered-feature-bv))

(defmethod %filter-map-features ((filter feature-map-filter) feature-bv &optional union-bv)
  (with-slots (map-filter-features feature-mapping-fn) filter
    (let ((filtered-feature-bv
	   (or union-bv (make-array (length map-filter-features) :element-type 'bit :initial-element 0)))
	  (features (code-features feature-bv)))
      (when feature-mapping-fn (setf features (funcall #'feature-mapping-fn features)))
      (loop for i from 0 to (1- (length map-filter-features))
	    for f across map-filter-features
	    when (find f features :test #'string-equal)
	    do (setf (bit filtered-feature-bv i) 1))
      filtered-feature-bv)))

(defun part-of-speech (feature-bv pos-list)
  (dolist (pos pos-list)
    (when (bit feature-bv pos)
      (return pos))))

(defmethod filter-features ((filter t) readings)
  readings)

(defmethod filter-features ((filter feature-map-filter) readings)
  (with-slots (pos-list tagger) filter
    (let ((*tagger* tagger)
	  (filtered ()))
      (dolist (reading readings)
	(when (car reading)
	  (destructuring-bind (lemma . bv) reading
	    (let ((found-p nil))
	      (loop for filtered-reading in filtered
		  until found-p
		  ;; do (print (list lemma (car filtered-reading)))
		  do (cond ((string/= lemma (car filtered-reading))
			    nil)
			   #+test
			   ((= (part-of-speech bv pos-list)
			       (part-of-speech (cdr filtered-reading) pos-list))
			    (%filter-map-features filter bv (cdr filtered-reading))
			    (setf found-p t))
			   (t
			    nil)))
	      (unless found-p
		(push (cons lemma (%filter-map-features filter bv)) filtered))))))
      filtered)))

(defmethod filter-features ((filter feature-filter) readings)
  (with-slots (filter-bv pos-list) filter
    (let ((filtered ()))
      (dolist (reading readings)
	(when (car reading)
	  (destructuring-bind (lemma . bv) reading
	    (let ((found-p nil))
	      (loop for filtered-reading in filtered
		  until found-p
		  do (cond ((string/= lemma (car filtered-reading))
			    nil)
			   ((= (part-of-speech bv pos-list)
			       (part-of-speech (cdr filtered-reading) pos-list))
			    (%filter-features bv filter-bv (cdr filtered-reading))
			    (setf found-p t))
			   (t
			    nil)))
	      (unless found-p
		(push (cons lemma (%filter-features bv filter-bv)) filtered))))))
      filtered)))

(defmethod stringify-readings ((filter t) readings &key feature-vector (downcase-p t))
  (collecting
   (dolist (reading readings)
     (when reading
       (collect (cons (car reading)
		      (when (cdr reading)
			(if downcase-p
			    (mapcar (lambda (f)
				      (string-downcase f))
				    (code-features (cdr reading) feature-vector))
			    (code-features (cdr reading) feature-vector)))))))))
  
(defmethod stringify-readings ((filter feature-filter) readings &key feature-vector)
  (with-slots (substitutions) filter
    (mapcar (lambda (reading)
	      (cons (car reading)
		    (mapcar (lambda (f)
			      (subst-substrings (string-downcase f) substitutions))
			    (code-features (cdr reading) feature-vector))))
	    readings)))

#+test
(let ((*tagger* *nbo-tagger*))
  (print (stringify-readings
	  *nbo-feature-filter*
	  (print (filter-features
		  *nbo-feature-filter*
		  (list (cons "fifi" (encode-features 'subst 'noeyt))
			(cons "fifi" (encode-features 'subst 'mask))))))))

;; This gives the filtered features in correct order, to be put into .csp file.
#+test
(let ((*tagger* *nbo-tagger*))
  (princ (cdar (stringify-readings
		*nbo-feature-filter*
		(filter-features
		 *nbo-feature-filter*
		 (list (cons "" (filter-bitvector *nbo-feature-filter*))))))))

(defparameter *nbo-feature-filter*
  (make-instance 'feature-filter
    :filter-bv
    (let ((*tagger* *nbo-tagger*))
      (apply
       #'encode-features
       '(subst appell ent ub be fl mask noeyt adj verb fem pos <perf-part> m/f pres inf
	 sup perf-part pret imp <pres-part> pass komp prop
	 n unorm adv fork uboey prep @adv <s-verb> pref interj det <tittel>
	 prep+subst <ordenstall> kvant prob <aux1/perf_part> @tittel
	 symb sbu dem pron poss <aux1/inf> <adj> @s-pred @interj pers @<subst @o-pred
	 adj+subst hum <aux1/infinitiv> konj+adj \3 <adv> forst prep+adj
	 @loes-np @<p-utfyll @obj @subj det+subst prep+subst+prep konj
	 prep+adj+subst nom akk subst+kon+subst hoeflig suff prep+subst+kon+subst @fv sp prep+prop
	 subst+verb @iv <romertall>
	 prep+subst+subst subst+subst det+adj prep+det+subst res clb prep+prep @adv> interj+adv
	 verb+det konj+adv+adj \2 subst+prep+subst pron+verb+verb \1 adj+verb konj+adv+prep @i-obj
	 gen @det> prep+konj+prep + subst+prep adj+det prep+adv nynorsk adv+prep verb+verb sbu+adj
	 adv+adj prep+adj+adj interj+adj subst+konj+subst konj+det+adj adv+subst verb+det+subst
	 prep+perf-part+subst prep+adv+subst v+v @kon @adj> prep+det+subst+kon+det+subst
	 adj+prep+subst verb+subst subst+kvant prep+subst+prep+sbu adv+adv+prep mask/fem/noeyt
	 prep+det+sbu ub/be inf-merke det+adj+det <spoerreartikkel> 
	 subst+prep+adj+subst pron+prep+adj
	 det+subst+prep+subst mask/fem adj+kon+adj part+prep adv+prep+subst refl adj+adj inf/pres
	 prep+subst+konj+subst adv+adj+prep fl/be subst+adj subst+v+subst subst+perf-part ent/fl
	 ;; refl4 a1 t ;; those are fishy
	 ;; added after calculation below
	 ukjent <semi> <kolon> samset inter bu <overskrift> <anf> <strek> <dato> <komma> @sbu
	 <parentes-slutt> <parentes-beg> <ellipse> @infmerke
	 ;; fra multi-tagger.lisp
	 <PUNKT> <UTROP> <SPM>
	 <klokke> <beloep>
	 @<sbu @app @subst> @s-gr @<adv @<det @<sbu-rel
	 ;; named entity features
	 &person &institusjon &sted &verk &ting
	 foreign)))
    :pos-list
    (let ((*tagger* *nbo-tagger*))
      (mapcar #'feature-code
	      '(subst konj adv pron adj suff prob verb prep pref fork
		det symb interj sbu prep+det+subst inf-merke)))
    :substitutions '()))

#+nny-parser
(defparameter *nny-feature-filter*
    (make-instance 'feature-filter
      :filter-bv
      (let ((*tagger* *nny-tagger*))
	(apply
	 #'encode-features
	 '(subst appell eint ub bu fl adj noeyt fem mask pos verb tr1 sup <perf-part> inf m/f pres
	   komp imp perf-part pret <pres-part> st-form prop
	   <st-verb> unorm adv fork prep @adv pref det interj <tittel> <ordenstal> <aux1/infinitiv>  
	   prep+subst tr kvant sideform dem symb poss sbu i pron adj+subst 
	   <adv> uttr pers <adj> @interj prob prep+adj @<subst @s-pred
	   \3 pr4/til pa @o-pred konj+adj konj @tittel hum @<p-utfyll det+subst @loes-np @obj akk
	   <att> prep+subst+prep nom subst+kon+subst @subj forst prep+adj+subst
	   prep+subst+subst @fv prep+subst+kon+subst be konj+adv+prep prep+prop \1 @iv sp subst+verb
	   interj+adv suff <romartal> prep+konj+prep res subst+subst clb hoeflig bokmaal \2 adj+verb
	   prep+adv
	   adv+adj subst+prep+subst det+adj prep+det+subst verb+det subst+prep @adv> konj+adv+adj
	   prep+adv+subst pron+verb+verb @det> verb+verb adj+det adv+adv gen @i-obj adv+verb @adj>
	   prep+perf-part+subst adv+adv+prep adv+subst prep+prep prep+adj+adj konj+det+adj adj+kon+adj
	   @kon verb+det+subst prep+det+sbu subst+perf-part subst+kvant subst+verb+subst ikke-hum 
	   prep+kon+subst @sbu interj+adj subst+prep+adj+subst adj+adj sbu+prep inf-merke
	   prep+det+subst+kon+subst part+prep prep+subst+konj+adv verb+subst refl1 det+subst+prep+subst
	   prep+subst+prep+sbu prep+det+subst+kon+det+subst prep+subst+konj+subst 
	   ;; added after calculation below
	   <overskrift> ukjent samset @infmerke test <anf> uboey >>> <dato> <<< <strek> <semi>
	   <parentes-slutt> <parentes-beg> <kolon> <komma> <ellipse>
	   ;; fra multi-tagger.lisp
	   <PUNKT> <UTROP> <SPM>
	   <klokke> <beloep>
	   ;; fra norsk-map.lisp; evaluate form below
	   @<sbu-rel @<det @<adv @s-gr @subst> @app @<sbu
	   @f-subj @fv-ho @iv-ho @fv-hj @iv-hj 
	   foreign)))
      :pos-list
      (let ((*tagger* *nny-tagger*))
	(mapcar #'feature-code
		'(inf-merke prep+det+subst inf sbu uttr nil interj symb det
		  prob fork pref prep verb suff adv adj pron konj subst PREP+DET+SUBST UTTR)))
      :substitutions '("oe" "ø")))


#+test
(string-net::print-strings (titles *nbo-tagger*))

;; calculates list of all pos features (first feature in feature list)
#+test
(let ((*tagger* *nbo-tagger*)
      (pos-list ()))
  (string-net::nmap-strings
   (lexicon *tagger*)
   ;;(abbreviations *tagger*)
   ;;(expressions *tagger*)
   (lambda (string)
     (destructuring-bind (word compressed-lemma feature-vector)
	 (split string #\: 3) ;; OBS: feature vector might contain split char!
       (declare (ignore word compressed-lemma))
       (setf feature-vector (map 'string #'string-net::restore-char feature-vector))
       (let ((features (code-features (string-to-bit-vector feature-vector))))
	 (pushnew (car features) pos-list)))))
  (print pos-list))

#+test
(let ((*tagger* *nny-tagger*)
      (pos-list ()))
  (string-net::nmap-strings
   ;;(lexicon *tagger*)
   ;;(abbreviations *tagger*)
   (expressions *tagger*)
   (lambda (string)
     (destructuring-bind (word compressed-lemma feature-vector)
	 (split string #\: 3) ;; OBS: feature vector might contain split char!
       (declare (ignore word compressed-lemma))
       (setf feature-vector (map 'string #'string-net::restore-char feature-vector))
       (let ((features (code-features (string-to-bit-vector feature-vector))))
	 (pushnew (car features) pos-list)))))
  (print pos-list))

;; pos-features
#+test
'(inf-merke prep+det+subst sbu interj symb det fork pref prep verb prob suff adj pron adv konj subst)


;;; EOF