;;; -*- Mode: LISP; Package: CGP; BASE: 10; Syntax: ANSI-Common-Lisp; -*-

(in-package :cgp)

;; NB. Strings match lemma forms, not word forms. A token is matched if any of its readings matches.

;; cp. transduce-boolean-list-regexp()

#+test
(filter "En stor fisk." :regexp *test-extractor* :transduce-p t)

#+test
(defparameter *test-extractor*
  (make-instance 'feature-regexp
    :name "Regulære uttrykk for termekstraksjon"
    :source-regexp
    `(:seq
      (:and * (:not subst) "*tor" (:not "1") (:add :epsilon)) ;; not yet implemented
      (:or ((:name "adj-frase")
	    (:seq
	     (:or
	      (:* (:or (:and adj (:not poss) (:not komp) (:not sup) (:not gen) (:not <ordenstall>))
		       ukjent))
	      (:seq (:or (:and adj (:not poss) pos (:not gen)) ukjent)
		    (:or "og" "eller")
		    (:or (:and adj (:not poss) pos (:not gen)) ukjent)))
	     (:or (:and subst
			(:add head)
			(:not gen))
		  (:and ukjent
			(:add head)))))))))

(progn ;; eval-when (load-toplevel compile-toplevel execute)
  (defparameter *adj-stoplist*
    '(:or "svær" "viss" "adskille" "atskille"
      "adskilt" "atskilt" "atskillig" "aggressiv" "ajourføre" "akselerere" "akseptabel" "akseptere" "aktuell" "alarmere" "alarmerende" "alminnelig" "alternativ" "alvorlig" "anbefale" "angi" "ansatt" "ansette" "antakelig" "antagelig" "anta" "automatisk" "avdempe" "avgjøre" "avgjørende" "avsluttet" "avtalt" "bedret" "begynnende" "behersket" "berøre" "beskjeden" "beslutte" "bestemme" "bestemt" "betryggend" "betydelig" "bevismessig" "billig" "blande" "bra" "bratt" "bred" "bruke" "brukt" "detaljert" "diverse" "dokumentere" "dominere" "dominerende" "drøy" "dyr" "dårlig" "egenkomponert" "egentlig" "eksistere" "eksklusiv" "eksportdrevet" "ekstra" "ekstrem" "endret" "enhetlig" "enkel" "enkelt" "enkeltstående" "etterfølge" "eventuell" "falle" "feil" "felles" "fengslig" "flere" "forbedre" "foregå" "foregående" "forestå" "forekomme" "forestående" "forhåndsbestemt" "fornuftig" "fortsatt" "fortsette" "forsiktig" "forskjellig" "forurolige" "foruroligende" "forutsigbar" "framherskende" "fremherskende" "framvoksende" "fremvoksende" "frykte" "fullstendig" "full" "fundamental" "følge" "følgje" "følgende" "før" "få" "gammel" "gammal" "generell" "geografisk" "gi" "gift" "gjennomført" "gjennomgå" "gjennomgående" "gjennomsnittlig" "gjenta" "gradvis" "grundig" "grunne" "gunstig" "hederlig" "hektisk" "hel" "helhetlig" "hensiktsmessig" "historisk" "hjemlig" "hovedsakelig" "høyre" "hurtig" "hyppig" "høre" "høy" "identisk" "inkludere" "innbyrdes" "innkomme" "innsende" "integrere" "intens" "interessant" "involvere" "isolert" "kalle" "kjenne" "kjent" "kjøpe" "klar" "komfortabel" "komme" "kompleks" "komplisere" "konkret" "konsistent" "kontinuerlig" "koordinere" "korrekt" "kortvarig" "kraftig" "langvarig" "lav" "lede" "lenge" "lett" "lik" "ligne" "lignende" "likne" "liknende" "likeartet" "lite" "liten" "mange" "mangelfull" "markant" "massiv" "mild" "moderat" "mulig" "mørk" "mye" "nedre" "nevne" "nordlig" "normal" "ny" "nyttig" "nær" "nøle" "nøyaktig" "nøytral" "nåværende" "ofte" "omfatte" "omfattende" "omtrentlig" "oppdatere" "oppsatt" "oppsette" "ordentlig" "ovenstående" "overordne" "overordnet" "overraske" "oversende" "oversiktlig" "permanent" "planlegge" "plutselig" "politisk" "potensiell" "praktisk" "presentere" "primær" "prosentvis" "påfallende" "påfølgende" "pågå" "pågående" "påpeke" "rasjonell" "rask" "regelmessig" "regional" "regningssvarende" "rekordhøy" "relativ" "relevant" "ren" "respektiv" "rett" "rikelig" "riktig" "rimelig" "risikabel" "robust" "sammenfalle" "sammenfallende" "sammenfatte" "sammenfattet" "sammenlignbar" "samtidig" "sannsynlig" "selvsagt" "sentral" "separat" "sesongmessig" "sist" "sistnevnt" "sjelden" "slak" "snarlig" "snar" "solid" "spesiell" "spesifikk" "spesifisere" "stadig" "starte" "sterk" "stige" "stor" "straffbar" "streng" "strukturere" "styrke" "svak" "svekke" "symmetrisk" "systematisk" "særlig" "særnorsk" "særskilt" "sørlig" "såkalt" "således" "tape" "teknologisk" "tenkelig" "teoretisk" "teste" "tidlig" "tidsriktig" "tilhøre" "tilsikte" "tilsvare" "tilsynelatende" "tiltagende" "tilta" "tiltakende" "tiltrengt" "tradisjonell" "trolig" "typisk" "uansvarlig" "ubetydelig" "uendret" "uforklarlig" "uforsvarlig" "uheldig" "uholdbar" "ukentlig" "ukjent" "ulik" "ulike" "ulovlig" "umiddelbar" "unnta" "unntatt" "unødvendig" "usedvanlig" "utarbeide" "utelate" "utføre" "utilfredsstillende" "utvalgt" "utvelge" "uvanlig" "uønsket" "velge" "vanlig" "vanskelig" "variere" "vedkomme" "vedkommende" "vedrøre" "vente" "venstre" "verdifull" "vid" "viktig" "vise" "vokse" "voldsom" "ytterligere" "øke" "økt" "ønske" "øvrig" "amerikansk" "britisk" "dansk" "engelsk" "europeisk" "finsk" "japansk" "kinesisk" "nederlandsk" "norsk" "nordisk" "polsk" "sentraleuropeisk" "sveitsisk" "svensk" "tsjekkisk" "tysk" "vesteuropeisk" "slovensk" "ungarsk" "georgisk" "kroatisk" "rumensk" "italiensk" "fransk")))

#+test
(filter "En stor fisk (FIS) sannelig." :regexp *term-extractor* :transduce-p nil)

(setf *term-extractor*
  (make-instance 'feature-regexp
    :name "Regulære uttrykk for termekstraksjon"
    :source-regexp
    `(:or ((:name "adj-frase")
	   (:seq
	    (:or
	     (:* (:or (:and adj
			    (:not poss) (:not komp) (:not sup) (:not gen) (:not <ordenstall>)
			    (:not ,*adj-stoplist*))
		      ukjent))
	     (:seq (:or (:and adj (:not poss) pos (:not gen) (:not ,*adj-stoplist*)) ukjent)
		   (:or "og" "eller")
		   (:or (:and adj (:not poss) pos (:not gen) (:not ,*adj-stoplist*)) ukjent)))
	    (:or (:and subst
		       (:add head)
		       #+ignore
		       (:not gen))
		 (:and ukjent
		       (:add head)))
	    (:* (:seq (:or "$(" <parentes-beg>)
		      (:or (:and subst prop) ukjent)
		      (:or "$)" <parentes-slutt>)
		      ))
	    ;;(:? (:seq "og" (:and subst (:not gen))))
	    #+test
	    (:? (:seq prep
		      (:* (:and adj (:not poss)))
		      (:and subst))))))))

#+orig
(setf *term-extractor*
  (make-instance 'feature-regexp
    :name "Regulære uttrykk for termekstraksjon"
    :source-regexp
    `(:OR
      #+test
      ((:name "compounds")
       (:seq (:and samset (:not gen))))
      ((:name "adj-frase")
       (:seq
	(:or
	 (:* (:or (:and adj
			(:not poss) (:not komp) (:not sup) (:not gen) (:not <ordenstall>)
			(:not ,*adj-stoplist*))
		  ukjent))
	 (:seq (:or (:and adj (:not poss) pos (:not gen) (:not ,*adj-stoplist*)) ukjent)
	       (:or "og" "eller")
	       (:or (:and adj (:not poss) pos (:not gen) (:not ,*adj-stoplist*)) ukjent)))
	(:or (:and subst
		   (:add head)
		   (:not gen))
	     (:and ukjent
		   (:add head)))
	;;(:? (:seq "og" (:and subst (:not gen))))
	#+test
	(:? (:seq prep
		  (:* (:and adj (:not poss)))
		  (:and subst))))))))

(setf *name-term-extractor*
  (make-instance 'feature-regexp
    :name "Regulære uttrykk for navnegjenkjenning"
    :source-regexp ;; '(:or ((:name "tull") (:seq det)))
    '(:OR
      ((:name "X i Y")
       (:SEQ (:AND subst (:ADD head) ;; (not :<sted>)
	      prop be ent) "i" (:AND subst prop)))
      ((:name "Den (norske)* X")
       (:OR
	(:SEQ (:AND det dem prop)
	 (:+ (:AND adj (:OR be fl)))
	 (:AND subst (:ADD head)))
	(:SEQ (:AND pron pers fl nom høflig)
	 (:+ (:AND adj (:OR be fl)))
	 (:AND subst (:ADD head)))))
      #+prelim
      ((:name "?")
       (:SEQ (:+ (:AND adj prop))
	(:AND subst (:ADD head))))
      ((:name "Bergen rådhus")
       (:SEQ (:+ (:AND subst prop (:NOT gen)))
	(:* adj)
	(:? (:seq (:and subst) "og"))
	(:or (:AND subst (:ADD head) ent ub 
		   (:OR "as" "a/s"
			"*kontor" "*hjem" "kirke" "*klubb"
			"*skole" "*barnehage" "*korps"
			"borettslag" "lufthavn" "flyplass" "*anlegg" "børs" "*gymnas"
			"*hjem" "kapell" "fylke" "*kommune" "*rett" "sentrum" "*råd"
			"*fengsel" "*senter" "*hus" "politikammer" "*bane" "gård"
			"stadion" "menighet" "rådhus" "stadion" "museum" "kino" "teater"
			"Børs" "*børs"))
	 "Børs")))
      ((:name "Institutt for filosofi")
       (:SEQ
	(:AND subst (:ADD head) prop (:NOT gen) (:OR "*institutt" "*avdeling"))
	"for"
	(:+ adj) (:? (:SEQ "og" adj))
	(:AND subst appell (:NOT gen))
	))
      ((:name "Norges Bank")
       (:SEQ
	(:AND subst prop gen)
	(:+ adj)
	(:AND subst (:ADD head) (:NOT gen) (:or "Bank"))
	))
      #+test
      ((:name "Navn")
       (:SEQ (:AND subst prop (:NOT gen)) (:+ (:AND subst prop)) (:? (:AND det <romertall>))))
      ((:name "Sammensatt navn")
       (:OR 
	(:SEQ 
	 (:* (:AND subst prop @subst> (:NOT gen)))
	 (:AND subst (:ADD head) prop #+test(:NOT gen))
	 #+ignore(:AND subst (:ADD head) prop @subj (:NOT gen))
	 #+ignore(:AND subst (:ADD head) prop @obj (:NOT gen))
	 #+ignore(:AND subst (:ADD head) prop @i-obj (:NOT gen))
	 (:? (:AND det <romertall>)))
	#+test
	(:SEQ
	 (:+ (:AND subst prop @subst> #+test (:NOT gen)))
	 (:AND subst (:ADD head) prop #+test (:NOT gen))
	 #+ignore(:AND subst (:ADD head) prop @subj (:NOT gen))
	 #+ignore(:AND subst (:ADD head) prop @obj (:NOT gen))
	 #+ignore(:AND subst (:ADD head) prop @i-obj (:NOT gen)))))
      #+test
      ((:name "test")
       (:SEQ (:AND subst prop gen) (:+ (:AND subst ub (:NOT prop)))))
      ((:name "X og Y (AS)")
       (:SEQ (:+ (:AND subst prop)) 
	(:OR (:SEQ "&" (:+ (:AND subst prop)))
	 #+test
	 (:SEQ (:AND subst prop) "og"
	       (:+ (:AND subst appell prop (:not samset)))))
	(:? (:or "AS" "A/S"))))
      ((:name "X of Y (eng)")
       (:SEQ
	(:+ (:AND subst (:ADD head) prop))
	(:OR "of" "di" "on")
	(:+ (:AND subst prop))))
      #+test
      ((:name "X for Y (eng)")
       (:SEQ
	(:+ (:AND subst (:ADD head) prop (:NOT lc)))
	"for"
	(:+ (:AND subst prop))))
      ((:name "Odontologisk fakultet")
       (:SEQ
	(:AND adj prop)
	(:AND subst (:ADD head) appell))))
    ))


(defun extract (string)
  (filter string :regexp *np-recognizer* ;; *term-extractor*
	  :transduce-p t))

#+test
(extract "Dette er vår lille Petters mye benyttete metode som han oppfant selv.")

#+test
(filter "Dette betyr vesentlige helendringer på Universitetet i Bonn.")

(setf *np-recognizer*
  (make-instance 'feature-regexp
    :name "Nominalfraser for Bredt"
    :source-regexp
    '(:OR
      ((:name "pron-frase")
       (:and pron #+test(:not refl)))
	
      ((:name "adj-frase")
       (:seq
	(:? 
	 ;; genitiv-attributt
	 (:seq
	  (:? (:and det))
	  (:or
	   (:* (:and adj))
	   (:seq (:and adj (:not poss) pos)
		 "og"
		 (:and adj (:not poss) pos)))
	  (:and subst gen)))
	(:? (:and det))
	(:or
	 (:* (:and adj))
	 (:seq (:and adj (:not poss) pos)
	       "og"
	       (:and adj (:not poss) pos)))
	(:or
	 (:and subst (:add head) (:not gen))
	 (:seq (:and subst (:add head) (:not gen))
	       (:and det poss))))))))


:eof