;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: USER -*-

;;;
;;; A program that learns phoneme-sequence <-> sememe-set mappings given
;;; a sequence of phonetic utterances paired with sememes (semantic symbols).
;;;

(in-package "USER")

(export '(
	  )
	(find-package "USER"))

(defparameter *debug* nil)

;;;
;;; Parsing parameters.
;;;

(defparameter +iteration-cutoff+ 100
  "Maximum number of iterations parsing algorithm will execute.")
(defparameter +parse-change-rate+ .03
  "Change rate for activations in parsing algorithm.")

(defparameter +phonetic-match-coefficient+ .5
  "Proportion of error due to phonetic matches.")
(defparameter +phonetic-mismatch-coefficient+ .5
  "Proportion of error due to phonetic mismatches.")
(defparameter +semantic-match-coefficient+ 1.5
  "Proportion of error due to semantic matches.")
(defparameter +semantic-mismatch-coefficient+ .5
  "Proportion of error due to semantic mismatches.")

(defconstant +phonetic-error-fn-epsilon+ .2)
(defconstant +semantic-error-fn-epsilon+ .2)

(proclaim '(type short-float
	    +improvement-cutoff-ratio+
	    +improvement-cutoff-absolute+
	    +parse-change-rate+
	    +phonetic-match-coefficient+
	    +phonetic-mismatch-coefficient+
	    +semantic-match-coefficient+
	    +semantic-mismatch-coefficient+
	    ))

;;;
;;; New word parameters.
;;;

(defparameter +unparsed-phoneme-cutoff+ .2
  "Phonetic error level at which we create new words to cover error.")
(defparameter +unparsed-sememe-cutoff+ .2
  "Semantic error level at which we create new words to cover error.")
(defparameter +initial-temperature+ .8
  "Temperature of new words.")
(defparameter +phonetic-mismatch-fix-cutoff+ .2
  "Fix phonetic mismatches greater than this level.")
(defparameter +phonetic-extension-error-cutoff+ .4
  "Extend phonetic word into areas with error greater than this level.")
(defparameter +maximum-phonetic-extension+ 3
  "Longest one-sided extension to make.")
(defparameter +maximum-number-of-unparsed-phoneme-sequences+ 2
  "Max number of unparsed sequences in sentence if totally new words are to be created.")
(defparameter +maximum-length-of-new-word+ 10
  "Max length of totally new word.")
(defparameter +error-cutoff-coefficient+ .2
  "Coefficient used in determination of how good a parse is.")
(defparameter +minimal-temperature-change+ .9
  "Minimum factor of temperature decrease word must have to be added to dictionary.")
(defparameter +maximum-good-parse-error+ .1
  "Maximum error of parse before new words are created.")
(defparameter +overparsed-phoneme-cutoff+ .2
  "Level of overparsing before phonemes are removed from words.")
(defparameter +overparsed-sememe-cutoff+ .2
  "Level of overparsing before sememes are removed from words.")

(proclaim '(type short-float
	    +unparsed-phoneme-cutoff+
	    +unparsed-sememe-cutoff+
	    +initial-temperature+
	    +phonetic-mismatch-fix-cutoff+
	    +phonetic-extension-error-cutoff+
	    +overparsed-phoneme-cutoff+
	    +overparsed-sememe-cutoff+
	    +error-cutoff-coefficient+
	    +minimal-temperature-change+
	    +maximum-good-parse-error+))
(proclaim '(type fixnum
	    +maximum-number-of-unparsed-phoneme-sequences+
	    +maximum-phonetic-extension+))

;;;
;;; GC Parameters.
;;;

(defparameter +word-evaluation-period+ 250
  "Evaluation time during which a word will not be deleted from the dictionary.")

(proclaim '(type fixnum
	    +word-evaluation-period+))

;;;
;;; Other parameters.
;;;

(defparameter +parse-print-activation-cutoff+ .25
  "Minimum activation of word that will be printed in parse.")
(defconstant +padding+ 2
  "Padding used on either side of utterance during parsing process.")

(proclaim '(type short-float
	    +parse-print-activation-cutoff+))


;;;
;;; Function type proclamations.
;;;

(proclaim '(ftype (function (short-float short-float) short-float)
	    probability-of-participating-in-phonetic-fix
	    probability-of-participating-in-semantic-fix
	    recompute-temperature))
(proclaim '(ftype (function (short-float) short-float)
	    probability-of-gc))

;;;
;;; Macros
;;;

(defmacro debug-info (&rest d)
  `(when *debug* (format t ,@d)))

(defmacro debug (&rest body) `(when *debug* ,@body))

(defmacro make-float-array (n)
  `(make-array ,n :element-type 'short-float :initial-element 0.0))

;;;
;;; DICTIONARYs
;;;

(defstruct dictionary
  (words nil :type list) 
  )

;;;
;;; WORDs
;;;

(defstruct (word (:print-function print-word))
  (phoneme-sequence "" :type simple-string)
  (sememe-set nil :type list)
  (temperature +initial-temperature+ :type short-float)
  (created-at 0 :type fixnum)
  (count 0 :type fixnum)
  (from nil))

(defun word-equal (w1 w2)
  (and (set-equal (word-sememe-set w1) (word-sememe-set w2))
       (string= (word-phoneme-sequence w1) (word-phoneme-sequence w2))))

(defun print-word (w stream depth)
  (declare (ignore depth))
  (format stream "<~S ~S ~3F ~D>"
	  (word-phoneme-sequence w)
	  (word-sememe-set w)
	  (word-temperature w)
	  (word-count w)))

;;;
;;; WORD-MATCHs
;;;

(defstruct (word-match (:print-function print-word-match))
  (phoneme-sequence "" :type simple-string)
  (sememe-set nil :type list)
  (phoneme-offset 0 :type fixnum) ;; Offset of word in target phonetic sequence.
  (phonetic-match-vector (make-float-array 0) :type (simple-array single-float (*)))
  (phonetic-mismatch-scalar 0.0 :type short-float)
  (phonetic-match-scalar 0.0 :type short-float)
  (semantic-match-vector (make-float-array 0) :type (simple-array single-float (*)))
  (semantic-match-scalar 0.0 :type short-float)
  (semantic-mismatch-scalar 0.0 :type short-float)
  (activation 0.0 :type short-float)
  word
  )

(defun print-word-match (wm stream depth)
  (declare (ignore depth))
  (format stream "<~S ~D {~{~S ~}} A~3F T~3F (P: ~3F ~3F S: ~3F ~3F)>"
	  (word-match-phoneme-sequence wm)
	  (word-match-phoneme-offset wm)
	  (word-match-sememe-set wm)
	  (word-match-activation wm)
	  (word-temperature (word-match-word wm))
	  (word-match-phonetic-match-scalar wm)
	  (word-match-phonetic-mismatch-scalar wm)
	  (word-match-semantic-match-scalar wm)
	  (word-match-semantic-mismatch-scalar wm)))

;;;
;;; UTTERANCEs
;;;

(defstruct (utterance (:print-function print-utterance))
  (phonetic-target "" :type simple-string)
  (phonetic-target-vector (make-float-array 0) :type (simple-array single-float (*)))
  (semantic-target nil :type list)
  (semantic-target-vector (make-float-array 0) :type (simple-array single-float (*)))
  (semantic-target-sememe-order nil :type list))

(defun create-utterance (phoneme-sequence sememe-set)
  (make-utterance :phonetic-target phoneme-sequence
		  :semantic-target sememe-set
		  :semantic-target-sememe-order (remove-duplicates sememe-set)))

(defun print-utterance (utterance stream depth)
  (declare (ignore depth))
  (format stream "<~S {~{ ~S~}}>"
	  (utterance-phonetic-target utterance)
	  (utterance-semantic-target utterance)))

;;;
;;; LINKs
;;;

(defstruct link
  (weight 0.0 :type short-float)
  value)

;;;
;;;
;;;

(defun parse-utterance (utterance dictionary)
  (let ((word-match-list (screen-words utterance (dictionary-words dictionary))))
    (format t "~%~D matches." (length word-match-list))
    (multiple-value-bind (error
			  phonetic-deviance-vector
			  semantic-deviance-vector)
	(search-for-optimal-parse word-match-list utterance)
      (display-errors utterance phonetic-deviance-vector semantic-deviance-vector)
      (print-parse word-match-list utterance)
      (values word-match-list error))))

(defun process-utterance (utterance dictionary print? &optional utterance-number)
  (when print? (format t "~%~%Utterance: ~S" utterance))
  ;;
  ;; Get words that come close to matching parts of the utterance- that aren't
  ;; wildly off.
  ;;
  (let ((word-match-list (screen-words utterance (dictionary-words dictionary)))
	(reparsed? nil)
	(new-words nil)
	(new-word-match-list nil))
    (when print? (format t "~%~D matches." (length word-match-list)))
    ;;
    ;; Use these words to parse the sentence.
    ;;
    (multiple-value-bind (error
			  phonetic-deviance-vector
			  semantic-deviance-vector)
	(search-for-optimal-parse word-match-list utterance)
      (declare (ignore error))
      (when (eq print? :all)
	(print-parse word-match-list utterance)
	(display-errors utterance phonetic-deviance-vector semantic-deviance-vector)
	(format t "~&Error: ~4F" error))
      ;;
      ;; If the error is too high, create new words to improve the parse.
      ;;
      (when (>= error +maximum-good-parse-error+)
	(let ((all-new-words (create-new-words utterance
					       word-match-list
					       phonetic-deviance-vector
					       semantic-deviance-vector)))
	  (setf new-words (remove-if #'(lambda (w) (find w word-match-list
							 :test #'word-equal
							 :key #'word-match-word))
				     all-new-words)
		new-word-match-list (screen-words utterance new-words))
	  (when new-word-match-list
	    (setf word-match-list (append new-word-match-list word-match-list))
	    (when print?
	      (format t "~&Hyp words: ~{~12T~S~%~}" new-words)
	      (when (eq print? :all)
		(format t "~&~D matches." (length word-match-list))))
	    ;;
	    ;; Reparse with new words.
	    ;;
	    (multiple-value-bind (new-error
				  new-phonetic-deviance-vector
				  new-semantic-deviance-vector)
		(search-for-optimal-parse word-match-list utterance)
	      (setf error new-error
		    phonetic-deviance-vector new-phonetic-deviance-vector
		    semantic-deviance-vector new-semantic-deviance-vector
		    reparsed? t)
	      (when print? (print-parse word-match-list utterance))))))
      ;;
      ;; Reinforce words that were used effectively and reliably.
      ;;
      (cool-words word-match-list utterance error phonetic-deviance-vector)
      ;;
      ;; Add new words that were effectively used to the dictionary.
      ;;
      (when reparsed?
	(let ((inserted-words (add-cooled-words new-word-match-list dictionary
						utterance-number)))
	  (when (eq print? :all)
	    (display-errors utterance phonetic-deviance-vector semantic-deviance-vector)
	    (format t "~&Error: ~4F" error))
	  (when print? (format t "~&New words: ~{~12T~S~%~}" inserted-words))))
      ;;
      ;; Remove some words from the dictionary.
      ;;
      (when (and utterance-number (zerop (mod utterance-number 200)))
	(gc-words dictionary utterance-number))
      (when (and utterance-number (zerop (mod utterance-number 2000)))
	(reduce-dictionary dictionary)))))

(defmacro phonetic-match-level (p1 p2)
  ;;
  ;; Return a float between 0 and 1 reflecting how close the two phonemes are.
  ;; A value of 1 should be an exact match, 0 a distinctly unlikely match.
  ;;
  `(the short-float (if (char= ,p1 ,p2) 1.0 0.0)))

(defmacro phonetic-mismatch-level (p1 p2)
  ;;
  ;; Return a float between 0 and 1 reflecting how distant the two phonemes are.
  ;; A value of 0 should be an exact match, 1 a distinctly unlikely match.
  ;;
  `(the short-float (if (char= ,p1 ,p2) 0.0 1.0)))

(defmacro semantic-match-level (s1 s2)
  ;;
  ;; Return a float between 0 and 1 reflecting how close the two sememes are.
  ;; A value of 1 should be an exact match, 0 a distinctly unlikely match.
  ;;
  `(the short-float (if (eql ,s1 ,s2) 1.0 0.0)))

(defmacro semantic-mismatch-level (s sememe-set)
  ;;
  ;; Return a float between 0 and 1 reflecting how mismatched s is in the environment
  ;; sememe-set.  A value of 0 should be an exact match, 1 a distinctly unlikely match.
  ;;
  `(the short-float (if (find ,s ,sememe-set) 0.0 1.0)))

(defun phonetic-error-fn (deviance)
  ;;
  ;; This function should have the characteristics that
  ;;   1.  deviance = 0 -> error = 0.
  ;;   2.  deviance = 1 or -1 -> error = 1.
  ;;   3.  deviance > 1 -> error grows greater than linearly.
  ;;   4.  deviance is better concentrated than spread, i.e., e(d1)+e(d2), d1+d2=c is
  ;;          maximized by e(c)+e(0).
  ;;
  (declare (short-float deviance))
  (let ((dev (abs deviance)))
    (declare (short-float dev))
    (if (> dev 1.0)
	(* dev dev)
	(let ((d (- dev 0.5)))
	  (declare (short-float d))
	  (+ dev (* +phonetic-error-fn-epsilon+ (- 1.0 (* 4.0 (* d d)))))))))

(defun phonetic-error-fn-derivative (deviance)
  (declare (short-float deviance))
  (let* ((dev (abs deviance))
	 (result (cond ((zerop dev) 0.0)
		       ((> dev 1.0) (+ dev dev))
		       (t (- 1.0 (* 8.0 +phonetic-error-fn-epsilon+ (- deviance 0.5)))))))
    (declare (short-float dev result))
    (if (minusp deviance) (- result) result)))

(defun semantic-error-fn (deviance)
  (declare (short-float deviance))
  (let ((dev (abs deviance)))
    (declare (short-float dev))
    (if (> dev 1.0)
	(* dev dev)
	(let ((d (- dev 0.5)))
	  (declare (short-float d))
	  (+ dev (* +phonetic-error-fn-epsilon+ (- 1.0 (* 4.0 (* d d)))))))))

(defun semantic-error-fn-derivative (deviance)
  (declare (short-float deviance))
  (let* ((dev (abs deviance))
	 (result (cond ((zerop dev) 0.0)
		       ((> dev 1.0) (+ dev dev))
		       (t (- 1.0 (* 8.0 +phonetic-error-fn-epsilon+ (- deviance 0.5)))))))
    (declare (short-float dev result))
    (if (minusp deviance) (- result) result)))

(defun search-for-optimal-parse (word-match-list utterance)
  ;;
  ;; A parse is a vector of activation coefficients on word-matches, each coefficient
  ;; between 0 and 1.  This algorithm uses a hill-climbing approach to find a
  ;; good vector.  The starting point of the search is with a uniform zero activation vector
  ;; (no words in the parse).
  ;;
  (declare (list word-match-list))
  ;;
  ;; Create the phonetic and semantic target vectors, essentially all 1s.
  ;;
  (create-phonetic-target-vector utterance)
  (create-semantic-target-vector utterance)
  ;;
  (let* ((number-of-words (length word-match-list))
	 (word-match-vector (make-array number-of-words :element-type 'word-match
					:initial-contents word-match-list))
	 (word-activation-derivative-vector (make-float-array number-of-words))

	 (phonetic-target-vector (utterance-phonetic-target-vector utterance))
	 (semantic-target-vector (utterance-semantic-target-vector utterance))
	 (n (length phonetic-target-vector))
	 (m (length semantic-target-vector))
	 (phonetic-hypothesis-vector (make-float-array n))
	 (semantic-hypothesis-vector (make-float-array m))
	 (phonetic-deviance-vector (make-float-array n))
	 (semantic-deviance-vector (make-float-array m))
	 (phonetic-error-fn-derivative-vector (make-float-array n))
	 (semantic-error-fn-derivative-vector (make-float-array m)))
    (declare (fixnum n m number-of-words)
	     (type (simple-array short-float (*))
		   phonetic-target-vector
		   phonetic-hypothesis-vector
		   phonetic-deviance-vector
		   semantic-target-vector
		   semantic-hypothesis-vector
		   semantic-deviance-vector
		   phonetic-error-fn-derivative-vector
		   semantic-error-fn-derivative-vector))
    ;;
    ;; Set initial word activations to random values, so as to break any symmetries.
    ;;
    (dotimes (w number-of-words)
      (setf (word-match-activation (aref word-match-vector w)) (random 1.0)))
    ;;
    ;; Now, we start iteratively improving our word-activation-vector until our global
    ;; measure of error stops improving by any significant amount.
    ;;
    (let ((last-error most-positive-short-float))
      (declare (short-float last-error))
      (dotimes (count +iteration-cutoff+)
	(declare (fixnum count))
	;;
	;; The first step of every iteration is to calculate how well the current 
	;; activation-vector does.  We sum the contribution of every word to the phonetic
	;; and semantic match and mismatch quantities.
	;;
	(calculate-hypothesis-vectors word-match-list
				      phonetic-hypothesis-vector
				      semantic-hypothesis-vector)
	;;
	;; Now that we have the phonetic and semantic matches computed, we
	;; calculate their deviances (how much they differ from ideal targets),
	;; the resulting contribution to the global error function, and the
	;; derivative of this error contribution with respect to the change
	;; in deviance.
	;;
	(let ((total-phonetic-match-error 0.0)
	      (total-phonetic-mismatch-error 0.0)
	      (total-semantic-match-error 0.0)
	      (total-semantic-mismatch-error 0.0))
	  (declare (short-float total-phonetic-match-error
				total-phonetic-mismatch-error
				total-semantic-match-error
				total-semantic-mismatch-error))
	  (dotimes (i n)
	    (declare (fixnum i))
	    (let ((deviance (- (aref phonetic-target-vector i)
			       (aref phonetic-hypothesis-vector i))))
	      (declare (short-float deviance))
	      (setf (aref phonetic-deviance-vector i) deviance)
	      (setf (aref phonetic-error-fn-derivative-vector i)
		    (phonetic-error-fn-derivative deviance))
	      (incf total-phonetic-match-error (phonetic-error-fn deviance))))
	  (dotimes (i m)
	    (declare (fixnum i))
	    (let ((deviance (- (aref semantic-target-vector i)
			       (aref semantic-hypothesis-vector i))))
	      (declare (short-float deviance))
	      (setf (aref semantic-deviance-vector i) deviance)
	      (setf (aref semantic-error-fn-derivative-vector i)
		    (semantic-error-fn-derivative deviance))
	      (incf total-semantic-match-error (semantic-error-fn deviance))))
	  ;;
	  ;; The phonetic and semantic match and mismatch errors are weighted to
	  ;; produce a single global error scalar.  It is this error scalar
	  ;; that must be reduced towards zero, and to do that, we compute its
	  ;; derivative with respect to the word activations.
	  ;;
	  ;; E = c1 * [sum i=1..n  phonetic-error-fn(PTi-PHi)] +
	  ;;     c2 * [sum i=1..m  semantic-error-f(STi-SHi)] +
	  ;;     c3 * [sum i=1..w  Aw * phonetic-mismatch(w) ] +
	  ;;     c4 * [sum i=1..w  Aw * semantic-mismatch(w) ]
	  ;; dE/dAw = c1 * [ sum i=1..n (phonetic-error-fn-deriv(PTi-PHi)
	  ;;                              * -(dPHi/dAw)) ] +
	  ;;          c2 * [ sum i=1..m (semantic-error-fn-deriv(STi-SHi)
	  ;;                              * -(dSHi/dAw)) ] +
	  ;;          c3 * phonetic-mismatch(w)
	  ;;          c4 * phonetic-mismatch(w)
	  ;;
	  (dotimes (w number-of-words)
	    (let* ((word-match (aref word-match-vector w))
		   (activation (word-match-activation word-match))
		   (phonetic-mismatch (word-match-phonetic-mismatch-scalar word-match))
		   (semantic-mismatch (word-match-semantic-mismatch-scalar word-match))
		   (phonetic-match-error-derivative-contribution 0.0)
		   (semantic-match-error-derivative-contribution 0.0)
		   (phonetic-mismatch-error-derivative-contribution phonetic-mismatch)
		   (semantic-mismatch-error-derivative-contribution semantic-mismatch))
	      (declare (short-float activation
				    phonetic-mismatch
				    semantic-mismatch
				    phonetic-match-error-derivative-contribution
				    semantic-match-error-derivative-contribution
				    phonetic-mismatch-error-derivative-contribution
				    semantic-mismatch-error-derivative-contribution))
	      (incf total-phonetic-mismatch-error (* activation phonetic-mismatch))
	      (incf total-semantic-mismatch-error (* activation semantic-mismatch))
	      ;;
	      ;; Calculate contribution of phonetic matches to activation derivative.
	      ;;
	      (let* ((phonetic-match-vector (word-match-phonetic-match-vector word-match))
		     (phoneme-offset (word-match-phoneme-offset word-match))
		     (word-start (max 0 (the fixnum (- phoneme-offset))))
		     (word-end (min (length (word-match-phoneme-sequence word-match))
				    (- n phoneme-offset))))
		(declare (fixnum word-start word-end phoneme-offset))
		(do ((i word-start (1+ i)))
		    ((>= i word-end))
		  (declare (fixnum i))
		  (decf phonetic-match-error-derivative-contribution
			(* (the short-float
				(aref phonetic-error-fn-derivative-vector
				      (the fixnum (+ (the fixnum (+ i phoneme-offset))
						     +padding+))))
			   (the short-float (aref phonetic-match-vector i))))))
	      ;;
	      ;; Calculate contribution of semantic matches to activation derivative.
	      ;;
	      (let ((semantic-match-vector (word-match-semantic-match-vector word-match)))
		(dotimes (i m)
		  (declare (fixnum i))
		  (decf semantic-match-error-derivative-contribution
			(* (the short-float (aref semantic-error-fn-derivative-vector i))
			   (the short-float (aref semantic-match-vector i))))))
	      ;;
	      ;; Now we can compute the total derivative of the error with respect
	      ;; to this word's activation.
	      ;;
	      (let ((error-derivative-wrt-activation
		     (+ (the short-float (* +phonetic-match-coefficient+
					    phonetic-match-error-derivative-contribution))
			(the short-float (* +semantic-match-coefficient+
					    semantic-match-error-derivative-contribution))
			(the short-float (* +phonetic-mismatch-coefficient+
					    phonetic-mismatch-error-derivative-contribution))
			(the short-float (* +semantic-mismatch-coefficient+
					    semantic-mismatch-error-derivative-contribution)))))
		(declare (short-float error-derivative-wrt-activation))
		(cond ((and (< error-derivative-wrt-activation 0.0) (>= activation 1.0))
		       (setf error-derivative-wrt-activation 0.0))
		      ((and (> error-derivative-wrt-activation 0.0) (<= activation 0.0))
		       (setf error-derivative-wrt-activation 0.0)))
		(debug-info "    ~&dE/dA: ~4F ~S" error-derivative-wrt-activation word-match)
		(setf (aref word-activation-derivative-vector w)
		      error-derivative-wrt-activation))))
	  (let ((error (+ (* +phonetic-match-coefficient+ total-phonetic-match-error)
			  (* +semantic-match-coefficient+ total-semantic-match-error)
			  (* +phonetic-mismatch-coefficient+ total-phonetic-mismatch-error)
			  (* +semantic-mismatch-coefficient+ total-semantic-mismatch-error))))
	    (debug-info "~&~D. Error = ~5F" count error)
	    (debug (display-errors utterance
				   phonetic-deviance-vector
				   semantic-deviance-vector))
	    (setf last-error error)
	    ;;
	    ;; We can now update the activation vector, based on the error and its derivative.
	    ;;
	    (dotimes (w number-of-words)
	      (let* ((word-match (aref word-match-vector w))
		     (new-activation (- (word-match-activation word-match)
					(the short-float
					     (* +parse-change-rate+
						(aref word-activation-derivative-vector w))))))
		(declare (short-float new-activation))
		(cond ((< new-activation 0.0001) (setq new-activation 0.0))
		      ((> new-activation .9999) (setq new-activation 1.0)))
		(setf (word-match-activation word-match) new-activation))))))
      (values last-error phonetic-deviance-vector semantic-deviance-vector))))

(defun gc-words (dictionary utterance-number)
  ;;
  ;; With some probability eliminate high-temperature words to reduce the
  ;; total temperature of the dictionary (we don't care how many frozen
  ;; words we have, but we don't want too many unfrozen ones).
  ;;
  (format t "~%~%GCing dictionary: ~D" (length (dictionary-words dictionary)))
  (setf (dictionary-words dictionary)
	(delete-if #'(lambda (word)
		       (and (> (- utterance-number (word-created-at word))
			       +word-evaluation-period+)
			    (< (random 1.0) (probability-of-gc (word-temperature word)))))
		   (dictionary-words dictionary)))
  (format t " -> ~D." (length (dictionary-words dictionary))))

(defun add-cooled-words (word-match-list dictionary utterance-number)
  ;;
  ;; If these new words have been significantly frozen, add them to the dictionary.
  ;;
  (let ((new-words nil))
    (dolist (word-match word-match-list)
      (let* ((word (word-match-word word-match))
	     (temperature (word-temperature word)))
	(when (and (< temperature (* +initial-temperature+ +minimal-temperature-change+))
		   (not (find word (dictionary-words dictionary) :test #'word-equal)))
	  (setf (word-created-at word) utterance-number)
	  (push word (dictionary-words dictionary))
	  (push word new-words))))
    new-words))

(defun cool-words (word-match-list utterance error phonetic-deviance-vector)
  ;;
  ;; Cool words in proportion to their activation levels and the "goodness"
  ;; of the parse.
  ;;
  (let ((parse-goodness (parse-goodness error utterance)))
    (dolist (word-match word-match-list)
      (let* ((word-start (+ (word-match-phoneme-offset word-match) +padding+))
	     (word-end (+ word-start (length (word-match-phoneme-sequence word-match)))))
	;;
	;; Don't cool words if:
	;;   1.  Neighboring phonemes are unparsed.
	;;   2.  The word has semantic or phonetic errors.
	;;
	(when (and (zerop (word-match-phonetic-mismatch-scalar word-match))
		   (zerop (word-match-semantic-mismatch-scalar word-match))
		   (or (< word-start 0)
		       (< (aref phonetic-deviance-vector (1- word-start)) .3))
		   (or (>= word-end (length phonetic-deviance-vector))
		       (< (aref phonetic-deviance-vector word-end) .3)))
	  (let* ((word (word-match-word word-match))
		 (activation (word-match-activation word-match))
		 (temperature (word-temperature word)))
	    (when (> activation .7)
	      (let ((delta (/ (* parse-goodness activation) 2.0)))
		(if (> delta .4) (incf (word-count word)))
		(setf (word-temperature word) (recompute-temperature temperature delta))))))))))

(defun create-new-words (utterance word-match-list
				   phonetic-deviance-vector
				   semantic-deviance-vector)
  ;;
  ;; Fix semantics:
  ;;
  ;; 1. Remove sememes that do not occur in the utterance sememe set
  ;;    from activated (and warm) words.
  ;; 2. Add unaccounted-for sememes to activated (and warm) words,
  ;;    assuming there are not unaccounted phonetic areas
  ;;    in the parse.
  ;;
  ;; Fix phonetics:
  ;;
  ;; 3. Phonetically alter activated (and warm) words to eliminate
  ;;    mismatches.
  ;; 4. Phonetically alter activated (and warm) words by extending
  ;;    them into unparsed areas of the utterance.
  ;;
  ;; Create wholly new words:
  ;;
  ;; 5. Create new words out of unparsed semantic and phonetic parts of
  ;;    the utterance, so long as the unparsed parts are pretty small.
  ;;
  (let* ((new-words nil)
	 (sememe-order (utterance-semantic-target-sememe-order utterance))
	 (utterance-phonetic-target (utterance-phonetic-target utterance))
	 (utterance-phonetic-target-vector (utterance-phonetic-target-vector utterance))
	 (n (length utterance-phonetic-target))
	 (unparsed-sememes
	  (loop for sememe in sememe-order
		for i from 0
		when (> (the short-float (aref semantic-deviance-vector i))
			+unparsed-sememe-cutoff+)
		collecting sememe))
	 (overparsed-sememes
	  (loop for sememe in sememe-order
		for i from 0
		when (< (the short-float (aref semantic-deviance-vector i))
			(- +overparsed-sememe-cutoff+))
		collecting sememe))
	 (unparsed-phoneme-sequences nil))
    ;;
    ;; Calculate unparsed areas of the phonetic-sequence.
    ;;
    (let ((first-unparsed-phoneme-index nil))
      (dotimes (i (length phonetic-deviance-vector))
	(declare (fixnum i))
	(if (and (not (> 0.5 (aref utterance-phonetic-target-vector i)));; check for pause.
		 (> (aref phonetic-deviance-vector i) +unparsed-phoneme-cutoff+))
	    ;; We are on an unparsed phoneme.
	    (unless first-unparsed-phoneme-index
	      (setf first-unparsed-phoneme-index i))
	    ;; We are on a parsed phoneme.
	    (when first-unparsed-phoneme-index
	      (push (subseq utterance-phonetic-target
			    (- first-unparsed-phoneme-index +padding+)
			    (- i +padding+))
		    unparsed-phoneme-sequences)
	      (setf first-unparsed-phoneme-index nil)))))
    ;;
    ;; 1. Remove sememes that do not occur in the utterance sememe set
    ;;    from activated (and warm) words.
    ;; 2. Add unaccounted-for sememes to activated (and warm) words,
    ;;    assuming there are not unaccounted phonetic areas in the
    ;;    parse.
    ;;
    (dolist (word-match word-match-list)
      (let ((word (word-match-word word-match)))
	(when (< (random 1.0) (probability-of-participating-in-semantic-fix
			       (word-match-activation word-match)
			       (word-temperature word)))
	  (let* ((excessive-sememes (union (set-difference (word-sememe-set word) sememe-order)
					   overparsed-sememes))
		 (improved-sememe-set (set-difference (word-sememe-set word) excessive-sememes)))
	    (unless (set-equal improved-sememe-set (word-sememe-set word))
	      (push (make-word :phoneme-sequence (word-phoneme-sequence word)
			       :sememe-set improved-sememe-set
			       :from word)
		    new-words))
	    ;; If parse is pretty good, add unaccounted-for sememes to word.
	    (when (null unparsed-phoneme-sequences)
	      (setf improved-sememe-set (union improved-sememe-set unparsed-sememes))
	      (unless (or (null unparsed-sememes)
			  (set-equal improved-sememe-set (word-sememe-set word)))
		(push (make-word :phoneme-sequence (word-phoneme-sequence word)
				 :sememe-set improved-sememe-set
				 :from word)
		      new-words)))))))
    ;;
    ;; 3. Phonetically alter activated (and warm) words to eliminate
    ;;    mismatches and over-parses.
    ;; 4. Phonetically alter activated (and warm) words by extending
    ;;    them into unparsed areas of the utterance.
    ;;
    (dolist (word-match word-match-list)
      (let ((word (word-match-word word-match)))
	(when (< (random 1.0) (probability-of-participating-in-phonetic-fix
			       (word-match-activation word-match)
			       (word-temperature word)))
	  (let* ((phoneme-sequence (word-phoneme-sequence word))
		 (phoneme-offset (word-match-phoneme-offset word-match))
		 (word-start (max 0 (the fixnum (- phoneme-offset))))
		 (word-end (min (length phoneme-sequence) (- n phoneme-offset)))
		 (first-good word-end)
		 (last-good (1- word-start)))
	    (declare (fixnum word-start word-end first-good last-good))
	    ;;
	    ;; Improve mismatched words.
	    ;;
	    (do ((i word-start (1+ i)))
		((= i word-end))
	      (declare (fixnum i))
	      (if (and (< (phonetic-mismatch-level
			   (schar phoneme-sequence i)
			   (aref utterance-phonetic-target (+ phoneme-offset i)))
			  +phonetic-mismatch-fix-cutoff+)
		       ;; Check for overparsing.
		       (> (aref phonetic-deviance-vector (+ phoneme-offset i +padding+))
			  (- +overparsed-phoneme-cutoff+)))
		  (setf first-good (min first-good i)
			last-good (max last-good i))))
	    (incf last-good);; To make it one past the end.
	    (when (< first-good last-good)
	      (let ((improved-phoneme-sequence (subseq utterance-phonetic-target
						       (+ phoneme-offset first-good)
						       (+ phoneme-offset last-good))))
		;;
		;; We really want to pull the old defn out.  Or at least
		;; significantly lower its confidence.
		;; 
		(unless (string-equal improved-phoneme-sequence phoneme-sequence)
		  (push (make-word :phoneme-sequence improved-phoneme-sequence
				   :sememe-set (word-sememe-set word)
				   :from word)
			new-words))))
	    ;;
	    ;; Extend phonetic words into unparsed regions.
	    ;;
	    (when (zerop (word-match-phonetic-mismatch-scalar word-match))
	      (let (new-word-start
		    new-word-end
		    (max-left-extension (min phoneme-offset +maximum-phonetic-extension+))
		    (max-right-extension (min (- n phoneme-offset word-end)
					      +maximum-phonetic-extension+)))
		(declare (fixnum new-word-end new-word-start))
		(do* ((left-extension 1 (1+ left-extension))
		      (index (+ (- word-start left-extension) phoneme-offset +padding+)
			     (+ (- word-start left-extension) phoneme-offset +padding+)))
		     ((or (> left-extension max-left-extension)
			  (< 0.5 (aref utterance-phonetic-target-vector index));; check for pause
			  (< (aref phonetic-deviance-vector index)
			     +phonetic-extension-error-cutoff+))
		      (decf left-extension)
		      (setf new-word-start (- word-start left-extension)))
		  (declare (fixnum left-extension index)))
		(do* ((right-extension 1 (1+ right-extension))
		      (index (+ (+ word-end right-extension -1) phoneme-offset +padding+)
			     (+ (+ word-end right-extension -1) phoneme-offset +padding+)))
		     ((or (> right-extension max-right-extension)
			  (< 0.5 (aref utterance-phonetic-target-vector index));; check for pause
			  (< (aref phonetic-deviance-vector index)
			     +phonetic-extension-error-cutoff+))
		      (decf right-extension)
		      (setf new-word-end (+ word-end right-extension)))
		  (declare (fixnum right-extension index)))
		(let ((improved-phoneme-sequence
		       (subseq utterance-phonetic-target
			       (+ new-word-start phoneme-offset)
			       (+ new-word-end phoneme-offset))))
		  (unless (string-equal improved-phoneme-sequence phoneme-sequence)
		    (push (make-word :phoneme-sequence improved-phoneme-sequence
				     :sememe-set (word-sememe-set word)
				     :from word)
			  new-words)))))))))
    ;;
    ;; 5. Create new words out of unparsed semantic and phonetic parts of
    ;;    the utterance, so long as the unparsed parts are pretty small.
    ;;
    (when (and (<= (length unparsed-phoneme-sequences)
		   +maximum-number-of-unparsed-phoneme-sequences+)
	       (not (find-if #'(lambda (phoneme-sequence)
				 (> (length phoneme-sequence) +maximum-length-of-new-word+))
			     unparsed-phoneme-sequences)))
      (dolist (phoneme-sequence unparsed-phoneme-sequences)
	(push (make-word :phoneme-sequence phoneme-sequence
			 :sememe-set unparsed-sememes)
	      new-words)))
    new-words))

(defun compute-phonetic-match (utterance word phoneme-offset)
  ;;
  ;; Return the phonetic-match-vector, the phonetic-mismatch-scalar, and
  ;; the phonetic-match-scalar.
  ;;
  (declare (fixnum phoneme-offset))
  (let* ((target-phonetic-sequence (utterance-phonetic-target utterance))
	 (n (length target-phonetic-sequence))
	 (word-phoneme-sequence (word-phoneme-sequence word))
	 (k (length word-phoneme-sequence))
	 (phonetic-match-vector (make-float-array k))
	 (phonetic-mismatch-scalar 0.0)
	 (phonetic-match-scalar 0.0)
	 (temperature (word-temperature word))
	 (word-start (max 0 (the fixnum (- phoneme-offset))))
	 (word-end (min k (the fixnum (- n phoneme-offset)))))
    (declare (fixnum word-start word-end k n)
	     (type (simple-array short-float) phonetic-match-vector)
	     (short-float phonetic-mismatch-scalar phonetic-match-scalar))
    (dotimes (i k)
      (declare (fixnum i))
      (let ((word-phoneme (schar word-phoneme-sequence i))
	    (target-phoneme (if (or (< i word-start) (>= i word-end))
				#\Space
				(schar target-phonetic-sequence (the fixnum
								     (+ i phoneme-offset))))))
	(let* ((match-level (phonetic-match-level word-phoneme target-phoneme))
	       (factor (if (< temperature .001) 1000.0 (/ 1.0 temperature)))
	       (mismatch-level (* factor (phonetic-mismatch-level word-phoneme target-phoneme))))
	  (declare (short-float match-level factor mismatch-level))
	  (setf (aref phonetic-match-vector i) match-level)
	  (incf phonetic-match-scalar match-level)
	  (incf phonetic-mismatch-scalar mismatch-level))))
    (values phonetic-match-vector phonetic-mismatch-scalar phonetic-match-scalar)))

(defun compute-semantic-match (utterance word)
  ;;
  ;; Return the semantic-match-vector, the semantic-mismatch-scalar, and
  ;; the semantic-match-scalar.
  ;;
  (let* ((sememe-ordering (utterance-semantic-target-sememe-order utterance))
	 (m (length sememe-ordering))
	 (word-sememe-set (word-sememe-set word))
	 (semantic-match-vector (make-float-array m))
	 (semantic-mismatch-scalar (if (null word-sememe-set)
				       ;;
				       ;; Penalize use of empty words, preventing
				       ;; their storage in the dictionary.
				       ;;
				       -0.01 
				       0.0))
	 (semantic-match-scalar 0.0)
	 (temperature (word-temperature word)))
    (declare (fixnum m)
	     (short-float semantic-mismatch-scalar semantic-match-scalar))
    (dolist (word-sememe word-sememe-set)
      (loop for utterance-sememe in sememe-ordering
	    for i from 0
	    do (let ((match-level (semantic-match-level word-sememe utterance-sememe)))
		 (incf semantic-match-scalar match-level)
		 (incf (aref semantic-match-vector i) match-level)))
      (let ((sememe-mismatch-level (semantic-mismatch-level word-sememe sememe-ordering))
	    (factor (if (< temperature .001) 1000.0 (/ 1.0 temperature))))
	(declare (short-float sememe-mismatch-level factor))
	(incf semantic-mismatch-scalar (* sememe-mismatch-level factor))))
    (values semantic-match-vector semantic-mismatch-scalar semantic-match-scalar)))

(defun create-phonetic-target-vector (utterance)
  ;;
  ;; The phonetic target vector is a uniform 1.0 (except for the pads and spaces), because
  ;; we need to account for exactly one phoneme.
  ;;
  (let* ((target-phonetic-sequence (utterance-phonetic-target utterance))
	 (n (+ (length target-phonetic-sequence) (* 2 +padding+)))
	 (target-phonetic-vector (make-float-array n)))
    (setf (utterance-phonetic-target-vector utterance) target-phonetic-vector)
    (dotimes (i n)
      (declare (fixnum i))
      (setf (aref target-phonetic-vector i)
	    (if (or (< i +padding+) (>= i (the fixnum (- n +padding+)))
		    (char= #\Space (schar target-phonetic-sequence (- i +padding+))))
		0.0
		1.0)))))

(defun create-semantic-target-vector (utterance)
  (let* ((sememe-ordering (utterance-semantic-target-sememe-order utterance))
	 (semantic-vector (make-float-array (length sememe-ordering))))
    (declare (type (simple-array short-float (*)) semantic-vector))
    (setf (utterance-semantic-target-vector utterance) semantic-vector)
    (dolist (sememe (utterance-semantic-target utterance))
      (incf (aref semantic-vector (position sememe sememe-ordering)) 1.0))))

(defun screen-words (utterance words)
  ;;
  ;; Return a reasonably small list of word-matches.
  ;;
  (let* ((all-matches nil))
    (dolist (word words)
      (multiple-value-bind (semantic-match-vector semantic-mismatch-scalar
						  semantic-match-scalar)
	  (compute-semantic-match utterance word)
	;;
	;; First we filter out poor semantic matches.
	;;
	(when (>= semantic-match-scalar semantic-mismatch-scalar)
	  ;;
	  ;; Then we filter out poorly phonetic matches.
	  ;;
	  (let ((offset-start (- 1 (length (word-phoneme-sequence word))))
		(offset-end (length (utterance-phonetic-target utterance))))
	    (declare (fixnum offset-start offset-end))
	    (do ((offset offset-start (1+ offset)))
		((= offset offset-end))
	      (declare (fixnum offset))
	      (multiple-value-bind (phonetic-match-vector phonetic-mismatch-scalar
							  phonetic-match-scalar)
		  (compute-phonetic-match utterance word offset)
		(if (>= phonetic-match-scalar phonetic-mismatch-scalar)
		    (push (make-word-match
			   :phoneme-sequence (word-phoneme-sequence word)
			   :sememe-set (word-sememe-set word)
			   :phoneme-offset offset
			   :word word
			   :phonetic-match-vector phonetic-match-vector
			   :phonetic-match-scalar phonetic-match-scalar
			   :phonetic-mismatch-scalar phonetic-mismatch-scalar
			   :semantic-match-vector semantic-match-vector
			   :semantic-match-scalar semantic-match-scalar
			   :semantic-mismatch-scalar semantic-mismatch-scalar)
			  all-matches))))))))
    all-matches))

(defun probability-of-participating-in-phonetic-fix (activation temperature)
  ;;
  ;; This function should be approximately proportional to the activation,
  ;; and zero if the word is frozen, highest if the word is very warm.
  ;; The following function meets this criterion.
  ;;
  (declare (short-float activation)
	   (ignore temperature))
  activation)

(defun probability-of-participating-in-semantic-fix (activation temperature)
  ;;
  ;; This function should be approximately proportional to the activation,
  ;; and zero if the word is frozen, highest if the word is very warm.
  ;; The following function meets this criterion.
  ;;
  (declare (short-float activation temperature))
  (* activation (sqrt (the short-float (* temperature (the short-float (- 2.0 temperature)))))))

(defun probability-of-gc (temperature)
  ;;
  ;; This function should be 0 if the word is frozen, 1 if the word is very warm.
  ;; The following function meets this criterion.
  ;;
  (declare (short-float temperature))
  (- 1.0 (sqrt (the short-float (- 1.0 (the short-float (* temperature temperature)))))))

(defun recompute-temperature (temperature delta)
  ;;
  ;; This function should have the characteristic that as the temperature
  ;; approches 0, deltas have a smaller and smaller effect on the temperature.
  ;; It is based on [ T = exp(-c) ] where c is the sum of the deltas.
  ;;
  (declare (short-float temperature delta))
  (* temperature (exp (- delta))))

(defun parse-goodness (error utterance)
  ;;
  ;; This function should be 1.0 if the parse is perfect (error is zero),
  ;; and tend towards zero as the parse gets worse, equalling zero if
  ;; the parse is sufficiently bad.
  ;;
  (declare (short-float error))
  (let* ((n (length (utterance-phonetic-target utterance)))
	 (error-cutoff (* n +error-cutoff-coefficient+)))
    (if (> error error-cutoff)
	0.0
	(- 1.0 (/ error error-cutoff)))))

(defun calculate-hypothesis-vectors (word-match-list
				     phonetic-hypothesis-vector
				     semantic-hypothesis-vector)
  ;;
  ;; Take the current word-match-list (with activations) and calculate how
  ;; well this accounts for the utterance by producing the weighted sum
  ;; hypothesis vectors, and also the weighted sum mismatch errors.
  ;;
  (declare (type (simple-array short-float (*))
		 phonetic-hypothesis-vector
		 semantic-hypothesis-vector))
  (let ((n (length phonetic-hypothesis-vector))
	(m (length semantic-hypothesis-vector))
	(phonetic-mismatch-scalar 0.0)
	(semantic-mismatch-scalar 0.0))
    (declare (fixnum n m))
    (dotimes (i n) (declare (fixnum i)) (setf (aref phonetic-hypothesis-vector i) 0.0))
    (dotimes (i m) (declare (fixnum i)) (setf (aref semantic-hypothesis-vector i) 0.0))
    (dolist (word-match word-match-list)
      (let ((activation (word-match-activation word-match)))
	(when (> activation .0001) ;; Eliminates some underflow errors.
	  ;;
	  ;; Sum phonetic match.
	  ;;
	  (let* ((phonetic-match-vector (word-match-phonetic-match-vector word-match))
		 (phoneme-offset (word-match-phoneme-offset word-match))
		 (word-start (max 0 (the fixnum (- phoneme-offset))))
		 (word-end (min (length (word-match-phoneme-sequence word-match))
				(- n phoneme-offset))))
	    (declare (fixnum word-start word-end phoneme-offset)
		     (type (simple-array short-float (*)) phonetic-match-vector))
	    (do ((i word-start (1+ i)))
		((= i word-end))
	      (declare (fixnum i))
	      (let* ((index (+ (the fixnum (+ i phoneme-offset)) +padding+))
		     (old-value (aref phonetic-hypothesis-vector index))
		     (increment (* activation (aref phonetic-match-vector i))))
		(declare (fixnum index) (short-float old-value increment))
		(unless (and (< old-value .0001) (< increment .0001))
		  (setf (aref phonetic-hypothesis-vector index)
			(+ old-value increment))))))
	  (incf phonetic-mismatch-scalar
		(the short-float
		     (* activation (word-match-phonetic-mismatch-scalar word-match))))
	  ;;
	  ;; Sum semantic match and mismatches.
	  ;;
	  (let ((semantic-match-vector (word-match-semantic-match-vector word-match)))
	    (dotimes (i m)
	      (declare (fixnum i))
	      (incf (aref semantic-hypothesis-vector i)
		    (* activation (the float (aref semantic-match-vector i))))))
	  (incf semantic-mismatch-scalar
		(* activation (word-match-semantic-mismatch-scalar word-match)))
	  )))
    (values phonetic-mismatch-scalar
	    semantic-mismatch-scalar)))

(defun reduce-dictionary (dictionary)
  ;;
  ;; Take each word from the dictionary, temporarily remove it, and
  ;; try to parse the word.  If the word can be parsed perfectly into
  ;; some smaller object, eliminate the word from the dictionary.
  ;;
  (let* ((original-words (dictionary-words dictionary))
	 (remaining-words original-words))
    (dolist (word original-words)
      (let* ((utterance (create-utterance (word-phoneme-sequence word)
					  (word-sememe-set word)))
	     (word-match-list (remove word (screen-words utterance remaining-words)
				      :key #'word-match-word)))
	(let ((error (search-for-optimal-parse word-match-list utterance)))
	  (when (< error +maximum-good-parse-error+)
	    (format t "~%Deleting ~S" word)
	    (setf remaining-words (remove word remaining-words))))))
    (setf (dictionary-words dictionary) remaining-words))
  (values))

(defun display-errors (utterance phonetic-deviance-vector
				 semantic-deviance-vector)
  ;;
  ;; Print a visual representation of an utterance and errors.
  ;;
  (let ((n (length phonetic-deviance-vector))
	(m (length semantic-deviance-vector)))
    (format t "~&Utterance: \"~2@T~A~2@T\"  ~S~&~11@T\""
	    (utterance-phonetic-target utterance)
	    (utterance-semantic-target-sememe-order utterance))
    (dotimes (i n)
      (let ((error (aref phonetic-deviance-vector i)))
	(let ((s (second (assoc error '((-.95 ")") (-.85 "(")
					(-.75 "*") (-.65 "&") (-.55 "^") (-.45 "%")
					(-.35 "$") (-.25 "#") (-.15 "@") (-.05 "!")
					(.05 " ") (.15 "1") (.25 "2") (.35 "3") (.45 "4")
					(.55 "5") (.65 "6") (.75 "7") (.85 "8") (.95 "9")
					(100.0 "x"))
				:test #'<))))
	  (format t "~A" s))))
    (format t "\"~2@T\"")
    (dotimes (i m)
      (let ((error (aref semantic-deviance-vector i)))
	(let ((s (second (assoc error '((-.95 ")") (-.85 "(")
					(-.75 "*") (-.65 "&") (-.55 "^") (-.45 "%")
					(-.35 "$") (-.25 "#") (-.15 "@") (-.05 "!")
					(.05 " ") (.15 "1") (.25 "2") (.35 "3") (.45 "4")
					(.55 "5") (.65 "6") (.75 "7") (.85 "8") (.95 "9")
					(100.0 "x"))
				:test #'<))))
	  (format t "~A" s))))
    (format t "\"")
    ))

(defun print-parse (word-match-list utterance)
  (declare (ignore utterance))
  (let ((wml (sort (remove-if-not #'(lambda (wm)
				      (>= (word-match-activation wm)
					 +parse-print-activation-cutoff+))
				  word-match-list)
		   #'< :key #'word-match-phoneme-offset)))
    (format t "~%Parse:~{~7T~S~%~}" wml)))

(defun count-intersection (s1 s2)
  (declare (list s1 s2))
  (let ((count 0))
    (declare (fixnum count))
    (dolist (s s1)
      (do ((ss s2 (cdr ss)))
	  ((null ss))
	(when (eql (car ss) s)
	  (incf count 1)
	  (return))))
    count))

(defun set-equal (sw1 sw2)
  (declare (list sw1 sw2))
  (and (= (length sw1) (length sw2)) (null (set-difference sw1 sw2))))