(in-package "KPML")

;;; File: morph-realizations.lisp

;;;========================================================================
;;; And here are the very dubious realization statements for the morpheme rank:
;;; we will gradually need to evolve something a bit more theoretically 
;;; motivated here, with the inter-stratal link down to graphology and 
;;; phonology...

(defun morphose (Function-name morphose-fn)
  "Puts a new blackboard entry on the blackboard (replacing the old one for
   Function-name) which has the graphological form of the entry
   metamorphosized according to the function morphose-fn."
  (let ((Temp-List (find Function-Name Associations 
			 :key #'function-association-function))
	(lex-entry (first (find-association Function-name 'termset))))
    
;;; make sure that a function association is present...
    (cond ((Not Temp-List)
	   (Push (SETQ Temp-List (make-Function-Association
				   :Function  Function-Name))
		       Associations)
	   (push temp-list cumulative-associations)))

    (setf blackboard 
	  (mapcar 
	    #'(lambda (bb-entry)
		(if (listp bb-entry)
		    (let ((type (first bb-entry))
			  (function (second bb-entry))
			  (graphological-constraints (cddr bb-entry)))
		      (cond ((and (eq type 'substance)
				  (eq function Function-name))
			     (list type function lex-entry 'morphosed
				   (let ((spelling 
					   (get-graphological-form 
					     lex-entry graphological-constraints)))
				     (apply morphose-fn (list spelling)))))
			    (t
			     bb-entry)))
		    bb-entry))
	    blackboard))))


;;; a further dubious morphological realization operator...

(defun PRESELECT-SUBSTANCE-AS-STEM (&rest body)
  (let* ((micro-function (first body))
	 (linguistic-material (second body))
	 (Word  (if linguistic-material 
		    linguistic-material 
		    (find-association micro-function 'term))))
    (cond
      ((Not (In-Blackboard-P Micro-function))
       (Caution "In system " Message-Sender ", lexifying for a function " 
		Micro-function
		" which has never been inserted.")))
    (unless word 
      (setf word (lexical-term-resolution
			  (find-association micro-function 'concept)
			  micro-function)))
    (add-to-blackboard (Cons 'Substance (LIST Micro-function Word 'stem)))
    (cond
      ((Not (gethash word lexicon))
       (Warning "In system " message-sender ", the entry " Word 
		" has been requested as lexical material but is not known."))
      )
    Word))

(defun PRESELECT-SUBSTANCE-AS-PROPERTY (&rest body)
  (let* ((micro-function (first body))
	 (property (second body))
	 (word (find-association micro-function 'term))
	 property-value)
    (cond
      ((Not (In-Blackboard-P Micro-function))
       (Caution "In system " Message-Sender ", lexifying for a function " 
		Micro-function
		" which has never been inserted.")))
    (unless word 
      (setf word (lexical-term-resolution
			  (find-association micro-function 'concept)
			  micro-function)))
    (cond
      ((Not (gethash word lexicon))
       (Warning "In system " message-sender ", the entry " Word 
		" has been requested as lexical material but is not known.")
       (add-to-blackboard (Cons 'Substance 
				(LIST Micro-function WORD 'spelling))))
      (t
       (setf property-value 
	     (second (assoc property 
			    (fetch-lexicon-info word 'properties))))
       (add-to-blackboard (Cons 'Substance 
				(LIST Micro-function Word 'property property-value)))))
    Word))

(defun PRESELECT-SUBSTANCE (&rest body)
  (let* ((micro-function (first body))
	 (linguistic-material (second body))
	 (Word  (if linguistic-material 
		    linguistic-material 
		    (find-association micro-function 'term))))
    (cond
      ((Not (In-Blackboard-P Micro-function))
       (Caution "In system " Message-Sender ", lexifying for a function " 
		Micro-function
		" which has never been inserted.")))
    (unless word 
      (setf word (lexical-term-resolution
			  (find-association micro-function 'concept)
			  micro-function)))
    (add-to-blackboard (Cons 'Substance (LIST Micro-function Word 'spelling)))
    (cond
      ((Not (gethash word lexicon))
       (Warning "In system " message-sender ", the entry " Word 
		" has been requested as lexical material but is not known."))
      )
    Word))

(if (boundp 'operators)
    (setf operators (append operators 
			    '(preselect-substance-as-stem preselect-substance-as-property))))
(if (boundp 'legal-extension)
    (setf legal-extension (append legal-extension 
			      '(preselect-substance-as-stem
				 preselect-substance-as-property))))

(defun make-substance (arg)
  (let* ((lex-item (first (whiteboard-elt-featurelist arg)))
	 (lex-type (second  (whiteboard-elt-featurelist arg))))
    
    (case lex-type
      (spelling 
	(fetch-lexicon-info lex-item 'spelling))
      (stem
	(setf (whiteboard-elt-featurelist arg)
	      (fetch-lexicon-info lex-item 'stem)))
      (property 
	(setf (whiteboard-elt-featurelist arg)
	      (third (whiteboard-elt-featurelist arg))))
      (morphose
	(setf (whiteboard-elt-featurelist arg)
	      (third (whiteboard-elt-featurelist arg)))))))

  ;; ----------------------------------------------------------------------
  ;; The initial set of morphological transformations for a random
  ;; sample of languages as found useful over the years...
  ;; ----------------------------------------------------------------------

(defun weaken (Function-name)
  (morphose Function-name #'weaken-morph))

(defun weaken-morph (spelling)
  (concatenate 'string 
    (subseq spelling 0 (1- (length spelling)))
    "i"))

  ;;

(defun strengthen (Function-name)
  (morphose Function-name #'strengthen-morph))

(defun strengthen-morph (spelling)
  (concatenate 'string
    spelling
    (subseq spelling (1- (length spelling)) (length spelling))))

  ;;

(defun chop (Function-name)
  (morphose Function-name #'chop-morph))

(defun chop-morph (spelling)
  (subseq spelling 0 (1- (length spelling))))

  ;; ---------------------------------
  ;; Realizations for Dutch...
  ;; ---------------------------------

(define-realization-operators span shorten)

(defun SPAN (Function-name)
  (morphose Function-name #'span-morph))

(defun SPAN-MORPH (spelling)
  (let ((l (length spelling)))
    (concatenate 'string 
     (subseq spelling 0 (- l 2))
     (subseq spelling (- l 1) l))))

  ;; this is used in the Dutch resources, but I am not 
  ;; sure what it is... (John).

(defun SHORTEN (x)
  (morphose x #'chop-morph))

  ;; ---------------------------------
  ;; Realizations for French... 
  ;; (added Jan05)
  ;; ---------------------------------

(define-realization-operators 
  SOFTEN-G SOFTEN-C I-INTO-I-CIRC CLOSE-E)

(defun SOFTEN-G-MORPH (spelling)
  (concatenate 'string
    spelling
    "e"))

(defun SOFTEN-G (Function-name)
  (morphose Function-name #'soften-g-morph))

  ;; 

(defun SOFTEN-C-MORPH (spelling)
  (concatenate 'string
    (subseq spelling 0 (1- (length spelling)))
    "ç"))

(defun SOFTEN-C (Function-name)
  (morphose Function-name #'soften-c-morph))

  ;;

(defun I-INTO-I-CIRC-MORPH (spelling)
  (concatenate 'string
    (subseq spelling 0 (1- (length spelling)))
    "î"))

(defun I-INTO-I-CIRC (Function-name)
  (morphose Function-name #'i-into-i-circ-morph))

  ;;

(defun CLOSE-E-MORPH (spelling)
  "get the last e or e-acute and make it an e-grave"
  (let ((p1 (position #\e spelling :from-end T))
	(p2 (position #\é spelling :from-end T)))
    (if (and p1 p2 (> p1 p2))
	(setf (char spelling p1) #\è)
      (if (and p1 p2)
          (setf (char spelling p2) #\è)
        (if p1
            (setf (char spelling p1) #\è)
          (when p2
            (setf (char spelling p2) #\è)))))
    spelling))

(defun CLOSE-E (Function-name)
  (morphose Function-name #'close-e-morph))

