;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Copyright   : (c)1997-2002 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : vision-module.lisp
;;; Version     : 2.1b7
;;; 
;;; Description : Source code for the ACT-R/PM Vision Module.  
;;;
;;; Bugs        : [] Need to split object identification and chunk 
;;;             :    construction in GET-OBJECT-AT because of EMMA.
;;; 
;;; Todo        : [] Ordering of screen-x and screen-y tests.
;;;             : [] General feature synthesis.
;;;             : [] Finst marking.
;;;             : [] Tracking setting visual-location buffer.
;;;
;;; 
;;; ----- History ----- [look also at function comments]
;;;
;;; 01.07.27 mdb
;;;             : Started the 2.1/ACT5 recoding.
;;;             : [x] Split up FL into pieces to be callable.
;;;             : [x] Remove OBJECTS slot from visual-locations.
;;;             : [x] VALUE slot should not be available for text features.
;;; 01.09.17 mdb
;;;             : Fixed bug in REMAP-SPEC-TO-CURRENT.
;;; 01.09.21 mdb [b2]
;;;             : * Made a bunch of changes to reduce the number of gentemps
;;;             : created by the system.  It probably rebuilds the icon
;;;             : faster, also.
;;;             : * Corrected another stupidity in UPDATE-ATTENDED-LOC.
;;; 01.10.31 mdb [b3]
;;;             : Added COPY-INSTANCE method for non-MCL Lisps.
;;; 01.11.05 mdb
;;;             : Added CURRENT-LOF slot to ease certain problems related to
;;;             : where attention is focussed vs. the chunk describing where
;;;             : its focussed.
;;; 01.11.11 mdb 
;;;             : Added ATTN-TRACE and TRACE-ATTN-P slots to support replay as
;;;             : well as SET-CLOF function.  This changed the tracking code
;;;             : a teensy bit as well.
;;; 02.01.17 mdb [b4]
;;;             : Adopted Dan's fix on ENTER-INTO-VISICON.
;;; 02.01.21 mdb 
;;;             : Fixed GREATER-THAN-CURRENT and LESS-THAN-CURRENT.
;;;             : Fixed NEAREST broken, only relative to current.
;;; 02.03.08 mdb [b5]
;;;             : Some regression happened somewhere--I had changed FOCUS-ON
;;;             : to ENCODING-COMPLETE, but that got clobbered somewhere.  
;;;             : I changed it back.
;;;             : -> Added "distance" to make the VM 3d.
;;; 02.03.18 mdb
;;;             : Last fix broke the initializer.  Fixed.
;;; 2002.04.09 mdb
;;;             : * FEAT-TO-DMO should propagate height and width information, 
;;;             : and it wasn't.  Fixed.
;;;             : * Also, the VALUE slot for visual locations was being
;;;             : propagated, which is bad for text [means it can be read 
;;;             : without an attention shift].  Bad, and fixed.
;;;             : * Size now propagates to visual locations, and by default is
;;;             : rounded to two decimal places.
;;; 2002.04.16 mdb [b6]
;;;             : Changed PRINT-ICON-FEATURE function to be more tabular.
;;; 2002.05.08 mdb
;;;             : Made a few changes to object tracking so that it's sensitive
;;;             : to the feature generated by the screen object, not the 
;;;             : screen object itself.
;;; 2002.06.12 mdb [b7]
;;;             : Included distance slot in COPY-INSTANCE method.
;;; 02.06.21 Dan
;;;             : Fixed the #-:mcl because it was missing the :.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(proclaim '(optimize (speed 3) (space 0)))

;;;; ---------------------------------------------------------------------- ;;;;
;;;; Class declarations
;;;; ---------------------------------------------------------------------- ;;;;

(defclass vision-module (attn-module)
  ((visicon :accessor visicon :initarg :visicon :initform nil)
   (optimize-visual :accessor optimize-p :initarg :optimize-p :initform t)
   (print-viewed :accessor print-view-p :initarg :print-view-p :initform nil)
   (conservative-update :accessor conservative-p :initarg :conservative-p 
                        :initform nil)
   (move-attention-latency :accessor move-attn-latency 
                           :initarg :move-attn-latency :initform 0.085)
   (tracked-object :accessor tracked-obj :initarg :tracked-obj :initform nil)
   (tracked-object-last-location :accessor tracked-obj-lastloc 
                                 :initarg :tracked-obj-lastloc :initform nil)
   (last-scale :accessor last-scale :initarg :last-scale :initform nil)
   (moving-attention :accessor moving-attention :initarg :moving-attention 
                     :initform nil)
   (move-allowance :accessor move-allowance :initarg :move-allowance
                   :initform 0)
   (synthd-objs :accessor synthd-objs :initarg :synthd-objs
                :initform (make-hash-table)) 
   (found-locs :accessor found-locs :initarg :found-locs
               :initform (make-hash-table))
   (feature-sets :accessor feature-sets :initarg :feature-sets 
                 :initform (all-feature-sets))
   (active-cfs :accessor active-cfs :initarg :active-cfs 
               :initform nil)
   (num-finst :accessor num-finst :initarg :num-finst :initform 4)
   (finst-lst :accessor finst-lst :initarg :finst-lst :initform nil)
   (finst-span :accessor finst-span :initarg :finst-span :initform 3.0)
   (new-span :accessor new-span :initarg :new-span :initform 0.5)
   (default-spec :accessor default-spec :initarg :default-spec 
     :initform nil)
   (current-lof :accessor current-lof :initarg :current-lof :initform #(0 0))
   (trace-attn-p :accessor trace-attn-p :initarg :trace-attn-p :initform nil)
   (attn-trace :accessor attn-trace :initarg :attn-trace :initform nil)
   )
  (:default-initargs
    :name :VISION))

(defclass found-spec ()
  ((spec :accessor spec :initarg :spec :initform nil)
   (feat :accessor feat :initarg :feat :initform nil)))


(defclass finst ()
  ((id :accessor id :initarg :id :initform nil)
   (tstamp :accessor tstamp :initarg :tstamp :initform 0.0)
   (synthed-from :accessor synthed-from :initarg :synthed-from :initform nil)))


;;; ICON-FEATURE      [Class]
;;; Description : Coordinates (x, y, width, height) should be in pixels to
;;;             : relate directly to the screen.  However, the SIZE attribute
;;;             : should be in degrees of visual angle (squared, of course)
;;;             : for FIND-LOCATION calls.
;;;             : Beta6 added WIDTH, HEIGHT, and SIZE attributes.

(defclass icon-feature ()
  ((screen-x :accessor screen-x :initarg :x :initform nil)
   (screen-y :accessor screen-y :initarg :y :initform nil)
   ;; need initiform for distance?
   (distance :accessor distance :initarg :distance 
             :initform (when *mp* (viewing-distance (device-interface *mp*))))
   (attended-p :accessor attended-p :initarg :attended-p :initform 'NEW)
   (kind :accessor kind :initarg :kind :initform 'visual-object)
   (val :accessor val :initarg :value :initform nil)
   (color :accessor color :initarg :color :initform 'black)
   (dmo-id :accessor dmo-id :initarg :dmo-id :initform nil)     	
   (screen-obj :accessor screen-obj :initarg :screen-obj :initform nil) 
   (height :accessor height :initarg :height :initform nil)
   (width :accessor width :initarg :width :initform nil)
   (size :accessor size :initarg :size :initform nil)
   (tstamp :accessor tstamp :initarg :tstamp :initform nil) 
   (obj-freq :accessor obj-freq :initarg :obj-freq :initform 0.01)
   ))


(defclass oval-feature (icon-feature)
  ()
  (:default-initargs
    :kind 'oval
    :value 'oval
    ))


(defclass led-line-feature (icon-feature)
  ((line-pos :accessor line-pos :initarg :line-pos :initform nil)
   (left-edge :accessor left-edge :initarg :left :initform nil)
   (right-edge :accessor right-edge :initarg :right :initform nil))
  (:default-initargs
    :kind 'text))


(defclass cursor-feature (icon-feature)
  ()
  (:default-initargs
    :kind 'cursor
    :value 'pointer))


(defclass rect-feature (icon-feature)
  ()
  (:default-initargs
    :kind 'visual-object
    :value 'box))


(defclass line-feature (icon-feature)
  ((end1-x :accessor end1-x :initarg :end1-x :initform nil)
   (end1-y :accessor end1-y :initarg :end1-y :initform nil)
   (end2-x :accessor end2-x :initarg :end2-x :initform nil)
   (end2-y :accessor end2-y :initarg :end2-y :initform nil)
   )
  (:default-initargs
    :kind 'line
    :value 'line))


(defclass text-feature (icon-feature)
  ()
  (:default-initargs
    :kind 'text))


(defclass empty-feature (icon-feature)
  ()
  (:default-initargs
    :kind 'EMPTY-SPACE
    :value nil
    :color nil))


(defclass feature-spec (icon-feature spec)
  ((nearest :accessor nearest :initarg :nearest :initform nil))
  (:default-initargs 
    :check-slots #(attended-p screen-x screen-y distance kind val color size)
    :x :IGNORE
    :y :IGNORE
    :attended-p :IGNORE
    :value :IGNORE
    :color :IGNORE
    :kind :IGNORE
    :size :IGNORE
    ))

(defmethod initialize-instance :after ((feat feature-spec) &key)
  (setf (dmo-id feat) (gensym "SPEC")))


(defclass char-primitive-feature (icon-feature)
  ((true-feat :accessor true-feat :initarg :true-feat :initform nil)
   (left-edge :accessor left-edge :initarg :left :initform nil)
   (right-edge :accessor right-edge :initarg :right :initform nil))
  (:default-initargs
    :kind 'text))



;;; SYNTHD-FEAT      [Class]
;;; Date        : 99.04.02
;;; Description : When an object (word or phrase) is synthesized out of 
;;;             : primitive features, some record of that has to be kept
;;;             : around for things like mouse targeting.  Synthetic
;;;             : features are hashed by ID, and store the IDs of the
;;;             : features from which they were constructed.

(defclass synthd-feat (icon-feature)
  ((built-from :accessor built-from :initform nil :initarg :built-from)))


(defclass dummy-feature ()
  ((xy-loc :accessor xy-loc :initarg :xy-loc :initarg nil)))


(defgeneric approach-width (feat theta)
  (:documentation "Returns the width of a feature in degrees given an approach angle."))

(defmethod approach-width ((feat dummy-feature) (theta float))
  (default-target-width (motor-m *mp*)))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Module-level stuff stuff

(defmethod initialize-instance :after ((vis-mod vision-module) &key)
  "Initializes a vision module"
  (setf (state-dmo vis-mod)
        (make-dme 'vision-state 'module-state
                  '(module :vision modality free processor free preparation free
                    execution free)
                  :where :external))
  (setf (default-spec vis-mod)
        (make-instance 'feature-spec :attended-p 'NEW :x 'LOWEST :tstamp 0))
  (set-cfs-mth vis-mod :RM-ORIG))


;;; RESET-MODULE      [Method]
;;; Date        : 97.03.31
;;; Description : Besides the basics, clear the icon and reset the 
;;;             : current location to be nil.

(defmethod reset-module :after ((vis-mod vision-module))
  "Resets the state of a Vision Module"
  (setf (visicon vis-mod) nil)
  (remove-tracking vis-mod)
  (setf (last-scale vis-mod) nil)
  (set-cfs-mth vis-mod :RM-ORIG)
  (setf (synthd-objs vis-mod) (clrhash (synthd-objs vis-mod)))
  (setf (found-locs vis-mod) (clrhash (found-locs vis-mod)))
  (setf (finst-lst vis-mod) nil)
  (setf (default-spec vis-mod)
        (make-instance 'feature-spec :attended-p 'NEW :x 'LOWEST :tstamp 0))
  (setf (attn-trace vis-mod) nil)
  (set-clof vis-mod #(0 0))
  )


(defmethod clear :after ((vis-mod vision-module))
  (remove-tracking vis-mod))


(defmethod update-module :after ((vis-mod vision-module))
  (when (tracked-obj vis-mod)
    (update-tracking-mth vis-mod))
  (check-finsts vis-mod)
  (mapc #'(lambda (f) (checknew f vis-mod)) (visicon vis-mod)))


(defmethod silent-events ((vis-mod vision-module))
  (tracked-obj vis-mod))


(defgeneric set-cfs-mth (vis-mod kwrd)
  (:documentation "Set the current character feature set."))

(defmethod set-cfs-mth ((vis-mod vision-module) kwrd)
  (setf (active-cfs vis-mod) (get-cfs-mth vis-mod kwrd)))


(defgeneric get-cfs-mth (vis-mod kwrd)
  (:documentation "Given a keyword, find a character feature set."))

(defmethod get-cfs-mth ((vis-mod vision-module) kwrd)
  (aif (member kwrd (feature-sets vis-mod) :key #'name)
    (first it)
    (pm-warning "Feature set ~S is unknown" kwrd)))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Moving attention and its immediate support functions, such
;;;;     as FOCUS-ON and the various GET- functions.
;;;; ---------------------------------------------------------------------- ;;;;

;;; MOVE-ATTENTION      [Method]
;;; Date        : 97.02.09
;;; Description : This is a toplevel command for the Vision Module, causing
;;;             : attention to move.  Latencey is 185 ms, so nothing actually
;;;             : happens right away other than setting state variables.
;;;             : A method is dispatched based on the scale that's passed.

(defgeneric move-attention (vis-mod &key location scale)
  (:documentation "Shift attention to a particular location at a particular scale."))

(defmethod move-attention ((vis-mod vision-module) &key location scale)
  (declare (symbol scale))
  (if (eq (exec-s vis-mod) 'BUSY)
    (pm-warning "Attention shift requested at ~S while one was already in progress."
                (mp-time *mp*))
    (progn
      (when (tracked-obj vis-mod) (remove-tracking vis-mod))
      (setf (input-q vis-mod) nil)
      (setf (moving-attention vis-mod) t)
      (clear-attended vis-mod)
      (setf (last-scale vis-mod) scale)
      (setf location (psdme-to-dmo location))
      (queue-command
       :time (move-attn-latency vis-mod) :where :VISION :command 'encoding-complete
       :randomize t :params `(,location ,scale))
      (setf (current-marker vis-mod) location)
      (set-clof vis-mod (dmo-to-xy location))
      (change-state vis-mod :exec 'busy))))



;;; FOCUS-ON      [Method]
;;; Date        : 97.06.01
;;; Description : Several things to do when focusing attention on a location.
;;;             : [1] Make the location attended, set state to FREE.
;;;             : [2] Make it an external source (and null the old source).
;;;             : [3] If there was nothing there, or we were non-conserving
;;;             :     get the thing at that location.
;;;             : [4] If there is something, synch it up with the location
;;;             :     chunk.
;;;             : [5] If requested, print it.


(defgeneric encoding-complete (vis-mod loc-dmo scale)
  (:documentation "When MOVE-ATTENTION completes, focus on a place with this."))

(defmethod encoding-complete ((vis-mod vision-module) (loc-dmo dmo) scale)
  (declare (symbol scale))
  (set-attributes loc-dmo '(attended t))
  (setf (moving-attention vis-mod) nil)
  (change-state vis-mod :exec 'free)
  ;(setf (current-marker vis-mod) loc-dmo)
  (let ((return-obj (get-obj-at-location vis-mod loc-dmo scale)))
    (unless return-obj
      ;(clear-loc loc-dmo)
      (clear-attended vis-mod)
      (return-from encoding-complete nil))
    (set-attended vis-mod return-obj)
    (when (print-view-p vis-mod)
      (format t "~% <> MOVE-ATTENTION generated DMO ~S~%" (id return-obj)))
    return-obj))


(defgeneric get-obj-at-location (vis-mod loc-dmo scale)
  (:documentation  "Given a location and a scale, return a DMO representing what's there."))

(defmethod get-obj-at-location ((vis-mod vision-module) (loc-dmo dmo) 
                               scale)
  (declare (symbol scale))
  (let ((return-obj nil)
        (xy-loc (dmo-to-xy loc-dmo)))
    (if (conservative-p vis-mod)
      (setf return-obj (conservative-get-object vis-mod loc-dmo))
      (progn
        (setf return-obj 
              (cond ((eq scale 'PHRASE)
                     (get-phrase-at vis-mod xy-loc))
                    ((and (eq scale 'WORD) (not (optimize-p vis-mod)))
                     (get-word-at-noopt vis-mod loc-dmo))
                    (t
                     (let ((feat-lis (within-move vis-mod xy-loc)))
                       (when (eq scale 'WORD)
                         (setf feat-lis (text-feats feat-lis)))
                       (when feat-lis
                         (featlis-to-focus vis-mod loc-dmo feat-lis))))))))
    return-obj)) 



;;; CONSERVATIVE-GET-OBJECT      [Method]
;;; Date        : 99.03.29
;;; Description : When CONSERVATIVE is on, try to grab an object that's 
;;;             : present in the current location chunk.  

(defgeneric conservative-get-object (vis-mod loc-dmo)
  (:documentation "Create a DMO for the object at the given location, when :CONSERVATIVE-UPDATE-VISUAL is true."))

(defmethod conservative-get-object ((vis-mod vision-module) 
                                        (loc-dmo dmo))
  (let ((present-objects
         (remove-if-not #'(lambda (o) (object-present-p vis-mod o))
                        (get-attribute loc-dmo 'objects)))
        (best-object nil)
        (base-feat (feat (gethash (id loc-dmo) (found-locs vis-mod)))))
    (when present-objects
      (if (null base-feat)
        (setf best-object (random-item present-objects))
        (progn
          (setf best-object 
                (determine-focus-dmo vis-mod present-objects base-feat))
          (setf (attended-p base-feat) t)))
      (setf (currently-attended vis-mod) best-object)
      best-object)))


;;; SYNCH-LOCS      [Method]
;;; Date        : 98.07.26, last delta 99.06.24
;;; Description : When an object is focused on, some objects might need to
;;;             : be updated.  This should keep the location chunk in
;;;             : synch with the world and with the object chunk.

(defgeneric synch-locs (vis-mod object location)
  (:documentation "Given an object and location DM rep, synchronizes the appropriate slots."))

(defmethod synch-locs ((vis-mod vision-module) (object dmo) (location dmo))
  (let ((still-around nil))
    (dolist (obj (mklist (get-attribute location 'objects)))
      (when (object-present-p vis-mod obj)
        (push obj still-around)))
    (set-attributes object `(screen-pos ,(id location)))
    (if (null still-around)
      (setf still-around (id object))
      (push (id object) still-around))
    (set-attributes location `(objects ,still-around))))


;;; WITHIN-MOVE      [Method]
;;; Date        : 99.03.29
;;; Description : Simply walk the icon and accumulate features that are within
;;;             : the movement tolerance.

(defgeneric within-move (vis-mod loc)
  (:documentation "Return a list of icon feature within the move allowance of loc."))

(defmethod within-move ((vis-mod vision-module) (loc vector))
  (if (= (move-allowance vis-mod) 0)
    (feat-match-xy (visicon vis-mod) loc)
    (let ((max (pm-angle-to-pixels (move-allowance vis-mod)))
          (accum nil))
      (dolist (feat (visicon vis-mod) accum)
        (when (>= max (dist (xy-loc feat) loc))
          (push feat accum))))))


;;; FEATLIS-TO-FOCUS      [Method]
;;; Date        : 99.03.29
;;; Description : First, determine which feature in the icon is the "best"
;;;             : feature, given the location that is the focus.  That
;;;             : location will have associate with it the feature and the
;;;             : spec used to generate it (in FIND-LOCATION).  Find the best
;;;             : feature, generate the list of DMOs at that location,
;;;             : determinine the focus, and make sure the location chunks and
;;;             : visual object chunks are synched up.

(defgeneric featlis-to-focus (vis-mod loc-dmo feat-lst)
  (:documentation  "Given the source location and a list of features, return the DMO that should be the focus."))

(defmethod featlis-to-focus ((vis-mod vision-module) (loc-dmo dmo) (feat-lis list))
  (let* ((best-feature 
          (find-best-feature feat-lis 
                             (gethash (id loc-dmo) (found-locs vis-mod))))
         (dmo-lis (featlis-to-dmos vis-mod (xy-loc best-feature)
                                     (feat-match-xy feat-lis 
                                                    (xy-loc best-feature))))
         (return-dmo (determine-focus-dmo vis-mod dmo-lis best-feature)))
    (dolist (obj dmo-lis)
      (set-attributes obj `(screen-pos ,(id loc-dmo))))
    return-dmo))


;;; FEATLIS-TO-DMOS      [Method]
;;; Date        : 99.03.29
;;; Description : Actually, some of the features could be CHAR-PRIMITIVE 
;;;             : features, in which case they're part of characters.  Save 
;;;             : those out and make a character out of 'em.

(defgeneric featlis-to-dmos (vis-mod loc feat-lis)
  (:documentation  "Given a list of features, make a DMO for each."))

(defmethod featlis-to-dmos ((vis-mod vision-module) (loc vector) (feat-lis list))
  (let ((primitive-feats nil)
        (dmo-lis nil))
    (dolist (feat (feat-match-xy feat-lis loc))
      (setf (attended-p feat) t)
      ;; If it's a char primitive, push the feature, else push the feature chunk.
      (if (typep feat 'char-primitive-feature) 
        (push  feat primitive-feats)
        (push (feat-to-dmo feat) dmo-lis)))
    (when primitive-feats
      (push (synthesize-letter vis-mod primitive-feats) dmo-lis))
    dmo-lis))


;;; DETERMINE-FOCUS-DMO      [Method]
;;; Date        : 99.03.29
;;; Description : Basically, look for a DMO with the same ID as the feature.
;;;             : If none, see if the DMO was synthesized from that feature.
;;;             : If none of those, return a random one.

(defgeneric determine-focus-dmo (vis-mod dmo-lst feat)
  (:documentation  "Determine which DMO corresponds to <feat>, which should be the 'best' feature."))

(defmethod determine-focus-dmo ((vis-mod vision-module) (dmo-lis list) (feat icon-feature))
  (when (= 1 (length dmo-lis))
    (return-from determine-focus-dmo (first dmo-lis)))
  (aif (member (dmo-id feat) dmo-lis :key #'id)
    (first it)
    (dolist (dmo dmo-lis (random-item dmo-lis))
      (when (member (dmo-id feat) 
                    (synthed-to-features vis-mod (id dmo) nil))
        (return-from determine-focus-dmo dmo)))))


;;; GET-WORD-AT-NOOPT      [Method]
;;; Date        : 99.04.02
;;; Description : Getting a word when optimizing is off involves calling
;;;             : SYNTHESIZE-WORD method, but we need to collect the 
;;;             : locations first, and also check the return if what was
;;;             : sent in was a DMO.

(defgeneric get-word-at-noopt (vis-mod loc-dmo)
  (:documentation  "Synthesize a word at the given location and synch it with the location."))

(defmethod get-word-at-noopt ((vis-mod vision-module) (loc-dmo dmo))
  (multiple-value-bind (locs xmin xmax) 
                       (adjoining-led-locs vis-mod (dmo-to-xy loc-dmo))
    (when locs
      (let ((rtn-dmo (synthesize-word vis-mod locs 
                                        (- xmax xmin) (dmo-to-xy loc-dmo))))
        (when rtn-dmo
          (set-attributes rtn-dmo `(screen-pos ,(id loc-dmo)))
          (values rtn-dmo xmin xmax))))))


(defgeneric get-word-at-noopt (vis-mod loc)
  (:documentation  "Synthesize a word at the given location."))

(defmethod get-word-at-noopt ((vis-mod vision-module) (loc vector))
  (multiple-value-bind (locs xmin xmax)  (adjoining-led-locs vis-mod loc)
    (when locs
      (let ((rtn-dmo (synthesize-word vis-mod locs 
                                        (- xmax xmin) loc)))
        (when rtn-dmo
          (values rtn-dmo xmin xmax))))))


;;; GET-WORD-DMOS-NOOPT      [Method]
;;; Date        : 99.04.02
;;; Description : OK, when optimizing is off and a phrase needs to be built,
;;;             : the tricky bit is figuring out which locations you need
;;;             : to grab words from, since if you hit every x location, 
;;;             : you'll generate multiple copies of each word.

(defgeneric get-word-dmos-noopt (vis-mod x-lst y)
  (:documentation  "Return a list of DMOs representing words at the given xlocs, with optimizing off."))

(defmethod get-word-dmos-noopt ((vis-mod vision-module) (x-ls list) y)
  (let ((rtn-dmos nil)
        (curr-x -1))
    (dolist (x x-ls (remove nil (nreverse rtn-dmos)))
      (when (> x curr-x)
        (multiple-value-bind (word min max)
                             (get-word-at-noopt vis-mod (vector x y))
          (declare (ignore min))
          (push word rtn-dmos)
          (setf curr-x max))))))


;;; GET-WORD-DMOS-OPT      [Method]
;;; Date        : 99.04.02
;;; Description : This is simpler when optimizing--just walk the xlist
;;;             : and accumulate words.
;;;             : Might be vestigial as of beta 6.

(defgeneric get-word-dmos-opt (vis-mod x-lst y)
  (:documentation  "Return a list of DMOs representing words at the given xlocs, with optimizing on."))

(defmethod get-word-dmos-opt ((vis-mod vision-module) (x-ls list) y)
  (let (accum)
    (dolist (x x-ls (nreverse accum))
      (dolist (feat (text-feats (feat-match-xy (visicon vis-mod) (vector x y))))
        (push (feat-to-dmo feat) accum)))))


;;; GET-ICON-OBJECT-AT      [Method]
;;; Date        : 97.06.01
;;; Description : Returns the DMO representing the feature(s) at a
;;;             : location.  If there are a whole bunch of the little line
;;;             : features that comprise letters, then do the categorization
;;;             : bit on the letters.

(defgeneric get-icon-object-at (vis-mod loc)
  (:documentation  "Return the chunk representing the icon feature(s) at the given <loc>"))

(defmethod get-icon-object-at ((vis-mod vision-module) (loc vector))
  (let ((led-feats nil)
        (dmo-lis nil)
        (return-dmo nil))
    (dolist (feat (within-move vis-mod loc))
      (setf (attended-p feat) t)
      ;; If it's an LED line, push the feature, else push the feature chunk.
      (if (eq (kind feat) 'led-line) 
        (push  feat led-feats)
        (push (feat-to-dmo feat) dmo-lis)))
    (when led-feats
      (push (synthesize-letter vis-mod led-feats) dmo-lis))
    (setf return-dmo (random-item dmo-lis))
    return-dmo))


#|
;;; GET-WORD-AT      [Method]
;;; Date        : 97.06.01
;;; Description : Getting a word can be either hard or easy, depending on 
;;;             : whether we're optimizing.  If we're optimizing, then the
;;;             : features are already words, so life is easy--just return
;;;             : the chunk for one of the features. If optimizing
;;;             : is off, then we have to synthesize a word from the letters.
;;;             : Vestigial in beta 6?  Not sure.

(defmethod get-word-at ((vis-mod vision-module) (loc list))
  "Return a chunk for the word at the given <loc>"
  (let ((dmo-lis nil))
    (if (optimize-p vis-mod)
      (let ((loc-feats (text-feats (within-move vis-mod loc)))
            (new-dmo nil))
        (unless (null loc-feats)
          (dolist (feat loc-feats (random-item dmo-lis))
            (setf new-dmo (feat-to-dmo feat))
            (push new-dmo dmo-lis))))
      ;; not optimizing
      (awhen (contiguous-locs loc (feat-match-y (visicon vis-mod) (second loc)))
        (synthesize-word vis-mod it)))))
|#


(defun text-feats (feat-lst)
  "Given a list, return only those features which are TEXT features."
  (remove-if #'(lambda (f) (not (eq (kind f) 'text))) feat-lst))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Finst support


(defmethod print-object ((fnst finst) strm)
  (print-unreadable-object (fnst strm :type t)
    (format strm "~S ~4,2F" (id fnst) (tstamp fnst))))


(defgeneric elapsed (object)
  (:documentation  "Return the time since this object was time-stamped."))

(defmethod elapsed ((fnst finst))
  (- (mp-time *mp*) (tstamp fnst)))


(defmethod in-finst ((name symbol) (fnst finst))
  (or (eq name (id fnst))
      (member name (synthed-from fnst))))


(defgeneric feat-attended (feat vis-mod)
  (:documentation  "Return the attended status of a visicon feature object."))

(defmethod feat-attended ((feat icon-feature) (vis-mod vision-module))
  (if (eq (attended-p feat) 'NEW)
    'NEW
    (consp (member (dmo-id feat) (finst-lst vis-mod) 
                   :test #'in-finst))))


(defgeneric test-attended (spec feat)
  (:documentation  "Test a visicon feature against a spec, return T if they match on ATTENDED."))

(defmethod test-attended ((spec icon-feature) (feat icon-feature))
  (cond ((eq (attended-p spec) :IGNORE) t)
        ((and (null (attended-p spec)) (eq (attended-p feat) 'NEW)) t)
        (t (eq (attended-p spec)
               (feat-attended feat (vis-m *mp*))))))


(defmethod set-attended :after ((vis-mod vision-module) obj)
  (aif (member (id obj) (finst-lst vis-mod) :key #'id)
    (setf (tstamp (first it)) (mp-time *mp*))
    (push
     (make-instance 'finst :id (id obj) :tstamp (mp-time *mp*)
                    :synthed-from (synthed-to-features vis-mod (id obj) nil))
     (finst-lst vis-mod)))
  (sort-finsts vis-mod)
  (when (> (length (finst-lst vis-mod)) (num-finst vis-mod))
    (pop (finst-lst vis-mod))))


(defgeneric sort-finsts (vis-mod)
  (:documentation  "Sort finsts according to time stamp."))

(defmethod sort-finsts ((vis-mod vision-module))
  (setf (finst-lst vis-mod) (sort (finst-lst vis-mod) #'< :key #'tstamp)))


(defgeneric check-finsts (vis-mod)
  (:documentation  "Update finsts against what's on the display and sort."))

(defmethod check-finsts ((vis-mod vision-module))
  (setf (finst-lst vis-mod)
        (delete-if #'(lambda (f) 
                       (or (not (object-present-p vis-mod (id f)))
                           (> (elapsed f)
                              (finst-span vis-mod))))
                   (finst-lst vis-mod)))
  (sort-finsts vis-mod))


;;;; ---------------------------------------------------------------------- ;;;;
;;;;  Supporting NEW tags


(defmethod elapsed ((feat icon-feature))
  (- (mp-time *mp*) (tstamp feat)))


(defgeneric checknew (feat vis-mod)
  (:documentation  "Check to see if a visicon feature is still NEW."))

(defmethod checknew ((feat icon-feature) (vis-mod vision-module))
  (when (and (eq (attended-p feat) 'NEW)
             (> (elapsed feat) (new-span vis-mod)))
    (setf (attended-p feat) nil))
  feat)





;;;; ---------------------------------------------------------------------- ;;;;
;;;; Synthetic features (letters, words, and phrases).
;;;; ---------------------------------------------------------------------- ;;;;

(defgeneric record-synth (vis-mod the-dmo &key x y width height built-from)
  (:documentation  "Record the id of a synthesized object and its properties."))

(defmethod record-synth ((vis-mod vision-module) (the-dmo dmo) 
                           &key x y width height built-from)
  (declare (fixnum x y width height))
  (when (not (and x y width height built-from))
    (error "NIL passed to RECORD-SYNTH."))
  (setf (gethash (id the-dmo) (synthd-objs vis-mod))
        (make-instance 'synthd-feat :dmo-id (id the-dmo)
                       :built-from (mklist built-from)
                       :width width :height height
                       :x x :y y)))


;;; SYNTHED-TO-FEATURES      [Method]
;;; Description : If the ID is in the hash table of synthed IDs, then 
;;;             : recurse on those.

(defgeneric synthed-to-features (vis-mod objid accum)
  (:documentation  "Given a synthetic object, return a list of icon features comprising it."))

(defmethod synthed-to-features ((vis-mod vision-module) objid accum)
  (aif (gethash objid (synthd-objs vis-mod))
    (flatten (mapcar #'(lambda (f) (synthed-to-features vis-mod f nil)) 
                     (built-from it)))
    (cons objid accum)))


;;; FEAT-OR-SYNTH      [Method]
;;; Date        : 99.04.02
;;; Description : VISUAL-OBJECTs should correspond to either real features
;;;             : or synthetic ones.  Look in both places.

(defgeneric feat-or-synth (vis-mod id)
  (:documentation  "Return the icon feature or synthetic object associated with <id>."))

(defmethod feat-or-synth ((vis-mod vision-module) id)
  (aif (member id (visicon vis-mod) :key #'dmo-id)
    (first it)
    (awhen (gethash id (synthd-objs vis-mod))
      it)))


;;; GET-PHRASE-AT      [Method]
;;; Date        : 98.07.27
;;; Description : The only way to get a phrase is to synthesize one, there is
;;;             : no "phrase" primitive in RPM.

(defgeneric get-phrase-at (vis-mod loc)
  (:documentation  "Mostly a stub for SYNTHESIZE-PHRASE."))

(defmethod get-phrase-at ((vis-mod vision-module) (loc vector))
  (awhen (feat-match-y (visicon vis-mod) (py loc))
    (synthesize-phrase vis-mod it (py loc))))


;;; SYNTHESIZE-LETTER      [Method]
;;; Date        : 98.07.27
;;; Description : From a list of LED-style icon features, synthesize a letter
;;;             : feature and note the synthesis.  The real worker here is
;;;             : Mike Matessa's FIND-BEST-OBJECT function, which is based on
;;;             : "rational categorization" of the features into a letter.

(defgeneric synthesize-letter (vis-mod feats)
  (:documentation  "Build a DMO representing a letter from a list of LED features."))

(defmethod synthesize-letter ((vis-mod vision-module) (feats list))
  (let ((base-feat (first feats))
        (letter (prob-best-character (active-cfs vis-mod) 
                                      (mapcar #'true-feat feats)))
        (return-dmo nil)
        )
    (dolist (feat feats)
      (setf (attended-p feat) t))
    (setf return-dmo
          (make-dme (new-name-fct "LETTER") 'visual-object
                    `(screen-pos ,(id (current-marker vis-mod))
                                 value ,letter
                                 color black)
                    :obj (screen-obj base-feat)
                    ))
    (record-synth vis-mod return-dmo :x (screen-x base-feat) 
                  :y (screen-y base-feat) :width (width base-feat) 
                  :height (height base-feat)
                  :built-from (mapcar #'dmo-id feats))
    return-dmo))


;;; SYNTHESIZE-WORD      [Method]
;;; Date        : 98.07.27
;;; Description : Given the list of contiguous locations, get the letter 
;;;             : at each location, and then build the word from the list
;;;             : of letters.

(defgeneric synthesize-word (vis-mod loc-lis width center)
  (:documentation  "Build a DMO representing a word from a location."))

(defmethod synthesize-word ((vis-mod vision-module) (loc-lis list) 
                               (width number) (center vector))
  (let ((return-dmo nil)
        (letter-dmos nil))
    (dolist (xloc loc-lis)
      (push (synthesize-letter vis-mod (feat-match-xy (visicon vis-mod) xloc)) 
            letter-dmos)
      (when (not (stringp (get-attribute (first letter-dmos) 'value)))
        (pop letter-dmos)))
    (when letter-dmos
      (setf letter-dmos (nreverse letter-dmos))
      (setf return-dmo
            (make-dme (new-name-fct "WORD") 'TEXT
                      `(screen-pos ,(id (current-marker vis-mod))
                                   value ,(word-accum
                                           (mapcar #'(lambda (x) (get-attribute x 'value))
                                                   letter-dmos)))))
      (record-synth vis-mod return-dmo :x (px center) :y (py center)
                    :width width 
                    :height 
                    (height (feat-or-synth vis-mod (id (first letter-dmos))))
                    :built-from (mapcar #'id letter-dmos))
      return-dmo)))


;;; GET-PHRASE-AT      [Method]
;;; Date        : 98.07.27
;;; Description : The only way to get a phrase is to synthesize one, there is
;;;             : no "phrase" primitive in RPM.

(defgeneric get-phrase-at (vis-mod loc)
  (:documentation  "Mostly a stub for SYNTHESIZE-PHRASE."))

(defmethod get-phrase-at ((vis-mod vision-module) (loc vector))
  (awhen (feat-match-y (visicon vis-mod) (py loc))
    (synthesize-phrase vis-mod it loc)))


(defgeneric synthesize-phrase (vis-mod feature-locs loc)
  (:documentation  "Build a DMO representing a phrase."))

(defmethod synthesize-phrase ((vis-mod vision-module) (feature-locs list) 
                                 (loc vector))
  (let ((x-locs (mapcar #'screen-x feature-locs))
        (word-dmos nil) 
        (words nil)
        (return-dmo nil))
    (setf x-locs (sort (remove-duplicates x-locs) #'<))
    (if (optimize-p vis-mod)
      (setf word-dmos (get-word-dmos-opt vis-mod x-locs (py loc)))
      (setf word-dmos (get-word-dmos-noopt vis-mod x-locs (py loc))))
    ;(setf word-lis (nreverse word-lis))
    (when word-dmos
      (setf words (mapcar #'(lambda (x)
                              (get-attribute x 'value)) word-dmos))
      (setf word-dmos (mapcar #'id word-dmos))
      (setf return-dmo
            (make-dme (new-name-fct "PHRASE") 'phrase!
                      `(screen-pos 
                        ,(id (current-marker vis-mod))
                        objects ,word-dmos
                        words ,words
                        color black
                        value ,(phrase-accum words))))
      (record-synth vis-mod return-dmo :x (px loc) :y (py loc)
                    :width
                    (reduce #'+ 
                            (mapcar #'(lambda (s)
                                        (width (feat-or-synth vis-mod s)))
                                    word-dmos))
                    :height
                    (height (feat-or-synth vis-mod (first word-dmos)))
                    :built-from word-dmos)
      return-dmo)))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; Stuff for supporting other modules (mostly motor).
;;;; ---------------------------------------------------------------------- ;;;;

;;; UPDATE-ATTEDED-LOC      [Method]
;;; Date        : 97.06.01
;;; Description : What is at the focus of visual attention can change.
;;;             : If this might be happening, call this after PM-PROC-SCREEN
;;;             : to make sure the attended location is updated.
;;;             : UNLESS clause added 98.07.17

(defgeneric update-attended-loc (vis-mod)
  (:documentation  "Update whatever is at the attended location"))

(defmethod update-attended-loc ((vis-mod vision-module))
  (when (and (current-marker vis-mod)
             (currently-attended vis-mod)
             (null (tracked-obj vis-mod))
             (not (moving-attention vis-mod))
             (eq 'FREE (exec-s vis-mod))
             )
    (unless (and (currently-attended vis-mod)
                 (object-present-p vis-mod (id (currently-attended vis-mod))))
      (queue-command
       :time (move-attn-latency vis-mod)
       :where :VISION
       :command 'encoding-complete
       :randomize t
       :params `(,(current-marker vis-mod) ,(last-scale vis-mod)))
      (change-state vis-mod :exec 'busy))))



;;; OBJECT-PRESENT-P      [Method]
;;; Description : A visual object is present if its ID is still in the icon
;;;             : or if all the features from which it was synthesized are
;;;             : still in the icon.

(defgeneric object-present-p (vis-mod obj-id)
  (:documentation  "Returns NIL if the object ID passed to it is no longer in the icon."))

(defmethod object-present-p ((vis-mod vision-module) obj-id)
  (if (member obj-id (visicon vis-mod) :key #'dmo-id)
    t
    (let ((synthed (gethash obj-id (synthd-objs vis-mod))))
      (when synthed
        (dolist (obj (built-from synthed) t)
          (unless (object-present-p vis-mod obj)
            (return-from object-present-p nil)))))))


;;; LOC-TO-FEAT      [Method]
;;; Date        : 99.04.02
;;; Description : Since each location has associated with it the feature
;;;             : and the spec used to generate that location, it's possible
;;;             : to do a "best match" here vs. the current icon.  If there
;;;             : isn't a best match, then return a dummy feature which will
;;;             : generate the default width.

(defgeneric loc-to-feat (vis-mod loc)
  (:documentation  "Given a location DMO, return the corresponding icon feature."))

(defmethod loc-to-feat ((vis-mod vision-module) (loc dmo))
  (aif (find-best-feature (visicon vis-mod) 
                          (gethash (id loc) (found-locs vis-mod)))
    it
    (make-instance 'dummy-feature :xy-loc (dmo-to-xy loc))))


;;; OBJ-TO-FEAT      [Method]
;;; Date        : 99.04.02
;;; Description : Visual objects should be associated with either real or
;;;             : synthetic features.  If neither of those can be found, at
;;;             : least the location of the object is known, so we can try
;;;             : to find something based on that.

(defgeneric obj-to-feat (vis-mod obj)
  (:documentation  "Given a visual object DMO, return the corresponding icon feature."))

(defmethod obj-to-feat ((vis-mod vision-module) (obj dmo))
  (aif (feat-or-synth vis-mod (id obj))
    it
    (loc-to-feat vis-mod (psdme-to-dmo (get-attribute obj 'screen-pos)))))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; Finding locations.
;;;; ---------------------------------------------------------------------- ;;;;



;;; FIND-BEST-FEATURE      [Method]
;;; Date        : 99.03.29
;;; Description : The "best" feature is the one with the same ID as the spec. 
;;;             : The next best feature is one that matches the spec and is
;;;             : nearest to that location.  Failing any matches to the spec,
;;;             : then return the nearest feature.

(defgeneric find-best-feature (feat-lst fs)
  (:documentation  "Given a list of features and a spec, return the 'best' feature."))

(defmethod find-best-feature ((feat-lis list) (fs found-spec))
  (awhen (member (dmo-id (feat fs)) feat-lis :key #'dmo-id)
    (return-from find-best-feature (first it)))
  (let ((matches (matching-feats (spec fs) feat-lis)))
    (if matches
      (random-item (nearest-feat matches (xy-loc (feat fs))))
      (random-item (nearest-feat feat-lis (xy-loc (feat fs)))))))


;;; FIND-BEST-FEATURE      [Method]
;;; Date        : 99.03.29
;;; Description : When the spec is null, return a random feature.

(defgeneric find-best-feature (feat-lst fs)
  (:documentation  "Given a list of features and a spec, return the 'best' feature."))

(defmethod find-best-feature ((feat-lis list) (fs null))
  (declare (ignore fs))
  (random-item feat-lis))


;;; FIND-LOCATION      [Method]
;;; Date        : 98.08.11R (rewrite), delta 99.06.24
;;; Description : To find a location, we need to search the icon.  To do this,
;;;             : construct a feature spec based on the parameters passed,
;;;             : and filter the list to those that match the spec.  This 
;;;             : should be faster for large icons because it makes only
;;;             : one pass over the icon.  Regardless, some
;;;             : post-processing of that list might be necessary if LOWEST
;;;             : or HIGHEST was passed as a coordinate or if NEAREST is 
;;;             : true.
;;;             : Once we have a list, randomly pick one (that may change in
;;;             : the future) feature and build a location out of it.

(defgeneric find-location (vis-mod &key kind attended value color 
                                       size screen-x screen-y nearest)
  (:documentation  "Given a set of constraints, build a DMO for that screen location if one matches."))


(defmethod find-location ((vis-mod vision-module) 
                             &key (kind :IGNORE) (attended :IGNORE) 
                             (value :IGNORE) (color :IGNORE) (size :IGNORE) 
                             screen-x screen-y distance nearest)
  
  (let ((spec (construct-findloc-spec 
                :kind kind :attended attended :value value :color color 
                :size size :screen-x screen-x :screen-y screen-y 
                :distance distance :nearest nearest)))
    (awhen (find-current-locs-with-spec vis-mod spec)
      (construct-location vis-mod 
                          (random-item (objs-max-slotval it 'tstamp))
                          spec))))


(defun construct-findloc-spec (&key (kind :IGNORE) (attended :IGNORE) 
                                        (value :IGNORE) (color :IGNORE) 
                                        (size :IGNORE) screen-x screen-y 
                                        distance nearest)
  (make-instance 'feature-spec
    :attended-p attended  :value value  :kind kind  :size size
    :color color :nearest nearest 
    :distance (if (null distance) :IGNORE distance)
    :x (if (null screen-x) :IGNORE screen-x)
    :y (if (null screen-y) :IGNORE screen-y)))


(defmethod find-current-locs-with-spec ((vis-mod vision-module) 
                                             (base-spec feature-spec))
  (let ((feat-lst nil)
        (temp-spec (copy-instance base-spec)))
    (when (or (member (screen-x temp-spec)
                      '(greater-than-current less-than-current current lowest 
                        highest))
              (member (screen-y temp-spec)
                      '(greater-than-current less-than-current current lowest 
                        highest)))
      (setf temp-spec (remap-spec-to-current vis-mod temp-spec)))
    (setf (nearest temp-spec) :IGNORE)
    ;; do the actual search
    (setf feat-lst (objs-match-spec (visicon vis-mod) temp-spec))
    ;; some filtering--there's an ordering issue here!
    (case (screen-x base-spec)
      (lowest (setf feat-lst (objs-min-slotval feat-lst 'screen-x)))
      (highest (setf feat-lst (objs-max-slotval feat-lst 'screen-x))))
    (case (screen-y base-spec)
      (lowest (setf feat-lst (objs-min-slotval feat-lst 'screen-y)))
      (highest (setf feat-lst (objs-max-slotval feat-lst 'screen-y))))
    (case (distance base-spec)
      (lowest (setf feat-lst (objs-min-slotval feat-lst 'distance)))
      (highest (setf feat-lst (objs-max-slotval feat-lst 'distance))))
    ;; handle the NEAREST flag
    (when (and (nearest base-spec) feat-lst)
      (if (eq (nearest base-spec) 'CURRENT)
        (setf feat-lst (nearest-feat feat-lst (current-lof vis-mod)))
        (setf feat-lst (nearest-feat feat-lst 
                                     (dmo-to-xy 
                                      (psdme-to-dmo
                                       (get-safe-wme (nearest base-spec))))))))
    feat-lst))


(defmethod remap-spec-to-current ((vis-mod vision-module) 
                                      (spec feature-spec))
  (let ((current-loc (current-lof vis-mod)))
    (setf (screen-x spec)
          (case (screen-x spec)
            (greater-than-current (greater-than (px current-loc)))
            (less-than-current (less-than (px current-loc)))
            (current (px current-loc))
            (lowest :IGNORE)
            (highest :IGNORE)
            (otherwise (screen-x spec))))
    (setf (screen-y spec)
          (case (screen-y spec)
            (greater-than-current (greater-than (py current-loc)))
            (less-than-current (less-than (py current-loc)))
            (current (py current-loc))
            (lowest :IGNORE)
            (highest :IGNORE)
            (otherwise (screen-y spec))))
    spec))






;;;; ---------------------------------------------------------------------- ;;;;
;;;;  Tracking stuff
;;;; ---------------------------------------------------------------------- ;;;;

;;; START-TRACKING      [Method]
;;; Date        : 97.05.15
;;; Description : Starting tracking is pretty easy, actually.  The target
;;;             : object needs to be found and installed in the relevant
;;;             : slots, and the ACT hook functions need to be set.

(defgeneric start-tracking (vis-mod obj-psdme)
  (:documentation  "Begin tracking an object"))

(defmethod start-tracking ((vis-mod vision-module) obj-psdme)
  (when (not (eql obj-psdme (id (currently-attended vis-mod))))
    (error "Request to track object ~S that is not currently being attended (~S)."
           obj-psdme (id (currently-attended vis-mod))))
  (change-state vis-mod :exec 'BUSY)
  (setf (input-q vis-mod) nil)
  (let ((target (pm-obj (currently-attended vis-mod))))
    (setf (tracked-obj vis-mod) target)
    (setf (tracked-obj-lastloc vis-mod) (current-lof vis-mod))
    ;(set-clof vis-mod (xy-loc (currently-attended vis-mod)))
    target))


;;; UPDATE-TRACKING-MTH      [Method]
;;; Date        : 97.05.15
;;; Description : Updating is kind of a pain.  First, if the tracked object
;;;             : hasn't moved, then do nothing.  If it has moved, however,
;;;             : there's a lot of bookkeeping to be done:
;;;             : [1] The old location need to have its object stripped and
;;;             : removed as an activation source.
;;;             : [2] The new location needs to be created, added to the 
;;;             : attention focus, and have its OBJECTS slot set.
;;;             : [3] The object chunk needs to have its location changed.

(defgeneric update-tracking-mth (vis-mod)
  (:documentation  "Update the state of a tracked object"))

(defmethod update-tracking-mth ((vis-mod vision-module))
  (let ((oldloc-xy (tracked-obj-lastloc vis-mod))
        (newloc-xy (xy-loc (build-features-for (tracked-obj vis-mod)
                                                 vis-mod))))
    (when (not (equal newloc-xy oldloc-xy))
      (setf (tracked-obj-lastloc vis-mod) newloc-xy)
      (let (;(old-loc-dmo (current-marker vis-mod))
            (new-loc-dmo (xy-to-dmo newloc-xy t))
            (obj-dmo (currently-attended vis-mod)))
        ;(clear-loc old-loc-dmo)
        (set-attributes obj-dmo `(screen-pos ,(id new-loc-dmo)))
        (set-clof vis-mod newloc-xy)
        (setf (current-marker vis-mod) new-loc-dmo)))))



;;; REMOVE-TRACKING      [Method]
;;; Date        : 97.05.15
;;; Description : When tracking stops, the slots for tracked objects need to
;;;             : to be cleared, and the ACT hook functions need to be cleared.

(defgeneric remove-tracking (vis-mod)
  (:documentation  "Clears out all the tracking stuff"))

(defmethod remove-tracking ((vis-mod vision-module))
  (setf (tracked-obj vis-mod) nil)
  (awhen (tracked-obj-lastloc vis-mod)
    (set-clof vis-mod it))
  (setf (tracked-obj-lastloc vis-mod) nil)
  (change-state vis-mod :exec 'FREE))


;;; PM-UPDATE-TRACKING      [Function]
;;; Date        : 97.05.15
;;; Description : To be called by the hook functions.

(defun pm-update-tracking (x)
  "Call the Vision Module's tracking update method."
  (declare (ignore x))
  (update-tracking-mth (vis-m *mp*)))



(defgeneric view-loc (view)
  (:documentation  "Return the location of the center of <view> as #(x y)."))

(defmethod view-loc (x)
  (declare (ignore x))
  (error "No method defined for VIEW-LOC."))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Icon Feature class and its children
;;;; ---------------------------------------------------------------------- ;;;;



(defgeneric print-icon-feature (feat)
  (:documentation  "Print out an ASCII representation of the icon."))

#|
(defmethod print-icon-feature ((feat icon-feature))
  (format t "~%(~3D ~3D)  kind: ~A~Catt: ~3A~Cvalue: ~A~Cname: ~A"
          (screen-x feat) (screen-y feat) (kind feat) #\Tab 
          (feat-attended feat (vis-m *mp*)) #\Tab (val feat)
          #\Tab (dmo-id feat)))
|#

(defmethod print-icon-feature ((feat icon-feature))
  (format t "~%(~3D ~3D)~11T~A~17T~A~32T~S~50T~A~66T~A"
          (screen-x feat) (screen-y feat) 
          (feat-attended feat (vis-m *mp*))
          (kind feat)  
          (val feat)
          (color feat)
          (dmo-id feat) 
          ))

(defmethod print-object ((feat icon-feature) stream)
  (print-unreadable-object (feat stream :type t)
    (princ (dmo-id feat) stream)))



(defgeneric enter-into-visicon (feat time)
  (:documentation  "Enter at icon feature into the visicon at the time specified."))

(defmethod enter-into-visicon ((feat icon-feature) (time number))
  (unless (dmo-id feat)
    (setf (dmo-id feat) (new-name-fct (kind feat))))
  (setf (tstamp feat) time)
  feat)



;;; XY-LOC      [Method]
;;; Date        : 97.02.09
;;; Description : Return the location of a feature as a list.

(defgeneric xy-loc (feat)
  (:documentation  "Return the XY location of a feature as a vector."))

(defmethod xy-loc ((feat icon-feature))
  (vector (screen-x feat) (screen-y feat)))


;;; FEAT-TO-DMO      [Method]
;;; Date        : 98.05.28
;;; Description : From an icon feature, create a chunk.

(defgeneric feat-to-dmo (feat)
  (:documentation  "Build a chunk for an icon feature"))

(defmethod feat-to-dmo ((feat icon-feature))
  (setf (attended-p feat) t)
  (make-dme (dmo-id feat) (kind feat)
            `(screen-pos ,(id (xy-to-dmo (xy-loc feat) t))
                         value ,(val feat)
                         color ,(color feat)
                         height ,(height feat)
                         width ,(width feat)
                         )
            :obj (screen-obj feat)
            :where :external))

(defmethod feat-to-dmo :around ((feat cursor-feature))
  (let ((the-dmo (call-next-method)))
    (setf (pm-obj the-dmo) :CURSOR)
    the-dmo))


(defgeneric feat-named (vis-mod id)
  (:documentation  "Returns the icon feature with the given <id>, if any."))

(defmethod feat-named ((vis-mod vision-module) id)
  (first (member id (visicon vis-mod) :key #'dmo-id)))



;;;; ---------------------------------------------------------------------- ;;;;
;;;;  Feature specifications, used to find features in the icon
;;;; ---------------------------------------------------------------------- ;;;;



;;; MATCH-SPEC-P      [Method]
;;; Date        : 98.08.11
;;; Description : Determining a match is based on testing for attribute
;;;             : matches or, in the case of coordinates, acceptable
;;;             : values.  So, check everything and return NIL on the
;;;             : first failure.  If nothing fails to match, return T.

(defgeneric match-spec-p (spec feat)
  (:documentation  "Returns T when <spec> and <feat> match."))

(defmethod match-spec-p ((spec icon-feature) (feat icon-feature))
  (cond ((not (test-attended spec feat)) nil) 
        ;((not (attr-exact-match-p spec feat 'attended-p)) nil)
        ((not (attr-exact-match-p spec feat 'kind)) nil)
        ((not (attr-exact-match-p spec feat 'val)) nil)
        ((not (attr-exact-match-p spec feat 'color)) nil)
        ((and (numberp (size spec))
              (not (attr-exact-match-p spec feat 'size))) nil)
        ((and (numberp (screen-x spec))
              (not (attr-exact-match-p spec feat 'screen-x))) nil)
        ((and (numberp (screen-y spec))
              (not (attr-exact-match-p spec feat 'screen-y))) nil)
        ((and (numberp (distance spec))
              (not (attr-exact-match-p spec feat 'distance))) nil)
        ((and (functionp (size spec))
              (not (funcall (size spec) (size feat)))) nil)
        ((and (functionp (screen-x spec))
              (not (funcall (screen-x spec) (screen-x feat)))) nil)
        ((and (functionp (screen-y spec))
              (not (funcall (screen-y spec) (screen-y feat)))) nil)
        ((and (functionp (distance spec))
              (not (funcall (distance spec) (distance feat)))) nil)
        (t t)))


(defgeneric matching-feats (spec feat-lst)
  (:documentation  "Return a list of features matching a given feature spec."))

(defmethod matching-feats ((spec feature-spec) (feat-lis list))
  (remove-if-not #'(lambda (f) (match-spec-p spec f)) feat-lis))


;;; ATTR-EXACT-MATCH-P      [Method]
;;; Date        : 98.08.11
;;; Description : If the spec says to ignore that attribute, then return T
;;;             : becuase everything matches a don't care.  Otherwise, the
;;;             : spec and the feature values must be equal.

(defgeneric attr-exact-match-p (spec feat slotname)
  (:documentation  "Returns T when <spec> and <feat> match on attribute <slotname> (or if <spec> says :IGNORE)."))

(defmethod attr-exact-match-p ((spec icon-feature) (feat icon-feature) slotname)
  (cond ((eq (slot-value spec slotname) :IGNORE) T)
        ((equal (slot-value spec slotname) (slot-value feat slotname)))))


;;; SLOT-MATCH-P      [Method]
;;; Date        : 01.07.27
;;; Description : One should not be able to test TEXT features for their 
;;;             : value, so this specializer should short-circuit that.

(defmethod slot-match-p ((ts spec) (obj text-feature) 
                           (slotname (eql 'value)))
  t)


;;;; ---------------------------------------------------------------------- ;;;;
;;;;  Messing with features:  Doing icon checking, finding, and listing.
;;;; ---------------------------------------------------------------------- ;;;;

;;; APPROACH-WIDTH      [Method]
;;; Date        : 99.03.30
;;; Description : Remember in high school when someone asked in trig why we
;;;             : needed to know this crap?  Well, this is why.  I'm pretty
;;;             : sure this is all the right trig, but there could be some
;;;             : missed math in here.

(defmethod approach-width ((feat icon-feature) (theta number))
  (let* ((x (width feat))
         (y (height feat))
         (critical-theta (atan y x))
         (theta (abs theta))
         (ret-width nil))
    (when (> theta (/ pi 2))
      (setf theta (- pi theta)))
    (setf ret-width
          (cond ((= theta 0) x)
                ((= theta (/ pi 2)) y)
                ((= theta critical-theta) (sqrt (+ (* y y) (* x x))))
                ((< theta critical-theta) (/ x (cos theta)))
                (t (/ y (cos (- (/ pi 2) theta))))))
    (pm-pixels-to-angle ret-width)))


(defgeneric simple-size (feat)
  (:documentation  "If there are values for the height and width, convert to visual angle and multiply."))

(defmethod simple-size ((feat icon-feature))
  (when (and (width feat) (height feat))
    (* 0.01 (round
             (* (pm-pixels-to-angle (width feat))
                (pm-pixels-to-angle (height feat)))
             0.01))))


;;; CONSTRUCT-LOCATION      [Method]
;;; Date        : 98.08.11, last delta 99.06.18
;;; Description : Building a location is pretty easy--if one exists already,
;;;             : use that.  If not, make one.  Note the commented out part
;;;             : may get used later--the idea is to store the feature and
;;;             : the spec used to find a given location, so that if attention
;;;             : is moved to that location and the feature moves a little
;;;             : bit, that same feature can be found.  And if that feature is
;;;             : gone, we can look for a new match to the spec.

(defgeneric construct-location (vis-mod feat spec)
  (:documentation  "Find or build a DMO based on a feature and the spec used to generate that feature."))


(defmethod construct-location ((vis-mod vision-module) (feat icon-feature) 
                                  (spec icon-feature))
  (let ((loc-dmo (find-loc-dmo (xy-loc feat))))
    ;; make sure we have one
    (unless loc-dmo
      (setf loc-dmo (xy-to-dmo (xy-loc feat) nil)))
    ;; fill in from the feature
    (setf loc-dmo (featinfo->loc vis-mod feat loc-dmo))
    ;; maybe print
    (when *debug*
      (format t "~%Constructing location ~S" (id loc-dmo)))
    ;; record that this loc was found with this spec
    (setf (gethash (id loc-dmo) (found-locs vis-mod))
          (make-instance 'found-spec :feat feat :spec spec))
    ;; return the DMO in a format the PS can understand
    (dmo-to-psdme loc-dmo)))


(defgeneric featinfo->loc (vis-mod feat the-dmo)
  (:documentation "Given a feature and a location DMO, fill in the DMO with information from the feature."))

(defmethod featinfo->loc ((vm vision-module) (feat icon-feature)
                             (the-dmo dmo))
  (set-attributes the-dmo `(color ,(color feat) 
                                  kind ,(kind feat)
                                  attended ,(attended-p feat)
                                  kind ,(kind feat)
                                  value ,(val feat)
                                  size ,(size feat)
                                  distance ,(distance feat)
                                  ))
  the-dmo)


(defmethod featinfo->loc ((vm vision-module) (feat text-feature)
                             (the-dmo dmo))
  (let ((the-dmo (call-next-method)))
    (set-attributes the-dmo '(value TEXT))
    the-dmo))



#|  should be obsolete as of 2002.04.09
(defmethod construct-location ((vis-mod vision-module) (feat icon-feature) 
                                  (spec icon-feature))
  (let ((loc-dmo (find-loc-dmo (xy-loc feat))))
    (if loc-dmo
      (coordinate-feat-loc feat loc-dmo)
      (setf loc-dmo (xy-to-dmo (xy-loc feat) nil)))
    ;; added set-attributes to synch this up right 99.06.18
    (set-attributes loc-dmo `(color ,(color feat) kind ,(kind feat)
                                    value ,(val feat)))
    (when *debug*
      (format t "~%Constructing location ~S" (id loc-dmo)))
    (setf (gethash (id loc-dmo) (found-locs vis-mod))
          (make-instance 'found-spec :feat feat :spec spec))
    (dmo-to-psdme loc-dmo)))  


;;; COORDINATE-FEAT-LOC      [Method]
;;; Date        : 97.03.03
;;; Description : When a location is to correspond to a feature, make sure
;;;             : the ATTENDED slot matches.

(defgeneric coordinate-feat-loc (found-feat found-loc)
  (:documentation  "Matches up a feature and a location"))

(defmethod coordinate-feat-loc ((found-feat icon-feature) (found-loc dmo))
  (set-attributes found-loc `(attended ,(attended-p found-feat)
                                       kind ,(kind found-feat))))
|#


  
  


;;; CHECK-FEAT      [Method]
;;; Date        : 97.06.18
;;; Description : When features persist across calls to PROC-SCREEN, sometimes
;;;             : features that had been attended get wiped.  Use of this 
;;;             : function can check for that.
;;;             : Setting DMO-ID added 98.07.17
;;;             : Wiping old feature (needed with optimizing off) added
;;;             : on 98.07.29.
;;;             : [mdb 00.06.12] Set the timestamp rather than the 
;;;             : attended slot.

#|  mdb 02.03.08  I suspect this is now obsolete
(defgeneric check-feat (feat vis-mod)
  (:documentation  "Checks a feature against the old icon, possibly setting the ATTENDED slot."))

(defmethod check-feat ((feat icon-feature) (vis-mod vision-module))
  (declare (optimize speed))
  (awhen (member feat (old-visicon vis-mod) :test #'feat=)
    (setf (tstamp feat) (tstamp (first it)))
    (unintern (dmo-id feat))
    (setf (dmo-id feat) (dmo-id (first it)))
    (setf (old-visicon vis-mod)
          (delete (first it) (old-visicon vis-mod)
                  :test (lambda (x y) (eq (dmo-id x) (dmo-id y))))))
  (checknew feat vis-mod))
|#

;;; FEAT=      [Method]
;;; Description : Two features are equal if their non-ID attributes are
;;;             : all equal.

(defgeneric feat= (feat1 feat2)
  (:documentation  "Compares two icon features to determine if they're functionally equal."))

(defmethod feat= ((feat1 icon-feature) (feat2 icon-feature))
  (declare (optimize (speed 3)))
  (cond ((neq (type-of feat1) (type-of feat2)) nil)
        ((not (= (screen-x feat1) (screen-x feat2))) nil)
        ((not (= (screen-y feat1) (screen-y feat2))) nil)
        ((not (equal (width feat1) (width feat2))) nil)
        ((not (equal (height feat1) (height feat2))) nil)
        ((neq (kind feat1) (kind feat2)) nil)
        ((not (equal (val feat1) (val feat2))) nil)
        ((neq (color feat1) (color feat2)) nil)
        (t (typed-feat= feat1 feat2))))

(defgeneric typed-feat= (feat1 feat2)
  (:documentation  "Very specific comparison of special properties of icon features.  T is returned if equal."))

;; need one for line features
(defmethod typed-feat= ((feat1 line-feature) (feat2 line-feature))
  (declare (optimize (speed 3)))
  (cond ((not (= (end1-x feat1) (end1-x feat2))) nil)
        ((not (= (end1-y feat1) (end1-y feat2))) nil)
        ((not (= (end2-y feat1) (end2-y feat2))) nil)
        ((not (= (end2-x feat1) (end2-x feat2))) nil)
        (t t)))

;; with no other info, assume they're equal
(defmethod typed-feat= ((feat1 icon-feature) (feat2 icon-feature))
  t)


(defun feature-locs (feat-lst)
  "Given a list of features, return a list of unique feature locations."
  (declare (list feat-lst))
  (remove-duplicates (mapcar #'xy-loc feat-lst) :test #'equal))


(defun feat-max-x (feat-lst)
  "Returns list of features with maximum x value"
  (declare (list feat-lst))
  (objs-max-slotval feat-lst 'screen-x))


(defun feat-min-x (feat-lst)
  "Returns list of features with minimum x value"
  (declare (list feat-lst))
  (objs-min-slotval feat-lst 'screen-x))


(defun feat-max-y (feat-lst)
  "Returns list of features with maximum y value"
  (declare (list feat-lst))
  (objs-max-slotval feat-lst 'screen-y))


(defun feat-min-y (feat-lst)
  "Returns list of features with minimum y value"
  (declare (list feat-lst))
  (objs-min-slotval feat-lst 'screen-y))


(defun feat-match-x (feat-lst x)
  "Returns features that match a given x value"
  (declare (list feat-lst) (fixnum x))
  (objs-match-slotval feat-lst 'screen-x x))


(defun feat-match-y (feat-lst y)
  "Returns features that match a given y value"
  (declare (list feat-lst) (fixnum y))
  (objs-match-slotval feat-lst 'screen-y y))


(defgeneric feat-match-xy (feat-lst loc)
  (:documentation  "Returns the the subset of the list that match the XY location."))

(defmethod feat-match-xy ((feat-lst list) (loc vector))
  (let ((outlis nil))
    (dolist (feat feat-lst outlis)
      (if (and (= (screen-x feat) (px loc)) 
               (= (screen-y feat) (py loc)))
        (push feat outlis)))))


(defun nearest-feat (feat-list loc)
  "Returns list of features nearest to a given location"
  (declare (list feat-lis))
  (unless (vectorp loc)
    (setf loc (dmo-to-xy loc)))
  (when feat-list
    (let ((best (dist (xy-loc (first feat-list)) loc))
          (outlis (list (first feat-list)))
          (the-dist nil))
      (dolist (feat (rest feat-list) outlis)
        (setf the-dist (dist (xy-loc feat) loc))
        (cond ((= the-dist best) (push feat outlis))
              ((< the-dist best) (setf best the-dist)
               (setf outlis (list feat))))))))



;;; DELETE-FEATURES      [Method]
;;; Date        : 97.02.27
;;; Description : Removes features from the icon.  If the scale is SCREEN,
;;;             : then remove all features.  If the scale is WORD, then 
;;;             : find the contiguous locations and remove all features at
;;;             : those locations.  Otherwise just remove all features at
;;;             : the specified location.

(defgeneric delete-features (vis-mod loc scale)
  (:documentation  "Removes features at a specified location"))

(defmethod delete-features ((vis-mod vision-module) loc scale)
  (declare (symbol loc))
  (case scale
    (screen (setf (visicon vis-mod) nil))
    (word 
     (let ((feat-lis (visicon vis-mod))
           (loc-lis (contiguous-locs loc (feat-match-y (visicon vis-mod) 
                                                         (py loc)))))
       (dolist (the-loc loc-lis)
         (setf feat-lis
               (remove-if #'(lambda (feat)
                              (equal the-loc (xy-loc feat)))
                          feat-lis)))
       (setf (visicon vis-mod) feat-lis)))
    (otherwise 
     (setf (visicon vis-mod)
           (remove-if #'(lambda (feat) (equal loc (xy-loc feat)))
                      (visicon vis-mod))))))



;;; BUILD-STRING-FEATS      [Method]
;;; Date        : 99.03.30
;;; Description : In order to build all the features for a string, there is a
;;;             : great deal of stuff that is needed from the interface beyond
;;;             : just the string itself.  Need to know the y coordinate, the
;;;             : starting x coordinate, the line height, the associated
;;;             : screen object, and some way of determining the width (in
;;;             : pixels) of a string.
;;;             : 
;;;             : There are two ways to do it, with and without optimizing. 
;;;             : With optimizing it's easy, just accumulate words.  When
;;;             : optimzing is off, though, have to walk the string
;;;             : character-by-character and build features for each one.

(defgeneric build-string-feats (vis-mod &key text start-x y-pos 
                                      width-fct height obj)
  (:documentation  "Build a list of ICON-FEATURES representing a string with the given geometry."))

(defmethod build-string-feats ((vis-mod vision-module) &key text start-x 
                              y-pos width-fct height obj)
  (declare (fixnum start-x y-pos)  (function width-fct) (string text)
           (number height))
  (when (not (and text start-x y-pos width-fct height))
    (error "NIL passed to BUILD-STRING-FEATS."))
  (unless (equal text "")
    (let ((curr-x start-x)
          (f-accum nil)
          (spc-wdth (funcall width-fct " "))
          (curr-width nil))
      (if (optimize-p vis-mod)
        ;; if optimizing is on, then carve the string into words (strings)
        ;; and space runs (numbers)
        (dolist (word (chop-string text) (nreverse f-accum))
          (when (stringp word)
            (setf curr-width (funcall width-fct word))
            (push (make-instance 'text-feature
                    :y y-pos :screen-obj obj :height height
                    :value (string-downcase word)
                    :width curr-width
                    :x (+ curr-x (round curr-width 2))) f-accum))
          (incf curr-x (if (stringp word) curr-width (* word spc-wdth))))
        ;; if not optimizing, then blast it character-by-character
        (let ((char nil))
          (dotimes (idx (length text) (nreverse (flatten f-accum)))
            (setf char (char text idx))
            (setf curr-width (funcall width-fct (subseq text idx (1+ idx))))
            (cond ((alphanumericp char)
                   (push (char-to-features vis-mod (char-upcase char)
                                           curr-x
                                           (- (+ curr-x curr-width) 1)
                                           y-pos
                                           height obj) f-accum))
                  ((and (graphic-char-p char)
                        (not (char-equal char #\space)))
                   (push (make-instance 'text-feature
                           :y y-pos :screen-obj obj :height height
                           :value (mkstr char)
                           :width curr-width
                           :x (+ curr-x (round curr-width 2))) f-accum))
                  (t nil))
            (incf curr-x curr-width)))))))


;;;; ---------------------------------------------------------------------- ;;;;
;;;;  Those wacky LED features for letters.
;;;; ---------------------------------------------------------------------- ;;;;

;;; CHAR-TO-FEATURES      [Method]
;;; Date        : 99.03.30
;;; Description : For each character, there will usually be many of those
;;;             : CHAR-PRIMITIVE features.  Grab the list of features 
;;;             : associated with a character, and build 'em.

(defgeneric char-to-features (vis-mod char left right y height obj)
  (:documentation  "Returns a list of basic icon-feature objects for a characer"))

(defmethod char-to-features ((vis-mod vision-module) (char character) 
                                (left number) (right number) (y number) 
                                (height number) obj)
  (let ((xpos (+ left (round (- right left) 2)))
        (width (1+ (- right left)))
        (features (pairlis
                     (getfeats (active-cfs vis-mod) char)
                     (get-icon-feats (active-cfs vis-mod) char)))
        (accum nil))
    (dolist (feats features accum)
      (push (make-instance 'char-primitive-feature
              :x xpos :y y :width width :height height 
              :left left :right right :screen-obj obj
              :true-feat (first feats) :value (rest feats))
            accum))))


;;; ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : To synthesize a word, we need to know which locations have
;;;             : LED-LINE features at adjoining locations.  However, 
;;;             : because letter width is variable, the icon has to be
;;;             : searched for LED-LINE locations that have features that
;;;             : are near the boundaries.  Also, because we need to know the
;;;             : width of the word, return the min and max x values, too.

(defgeneric adjoining-led-locs (vis-mod loc)
  (:documentation  "Return a list of locations adjoining <loc>, as well as the max and min x locs."))

(defmethod adjoining-led-locs ((vis-mod vision-module) (loc vector))
  (let ((feat-ls (feat-match-xy (visicon vis-mod) loc))
        (feat nil))
    (while (and (null feat) feat-ls)
      (setf feat (pop feat-ls))
      (unless (typep feat 'char-primitive-feature)
        (setf feat nil)))
    (when feat
      (setf feat-ls (feat-match-y (visicon vis-mod) (screen-y feat)))
      (multiple-value-bind 
        (lowlocs xmin) (left-adjoining-led-locs feat-ls (left-edge feat) nil)
        (multiple-value-bind
          (hilocs xmax) (right-adjoining-led-locs feat-ls (right-edge feat) nil)
          (values
           (append lowlocs (list loc) hilocs)
           xmin xmax))))))


;;; RIGHT-ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : Recursively go right and accumulate locations that share
;;;             : the boundary.

(defgeneric right-adjoining-led-locs (feat-ls x accum)
  (:documentation  "Return a list of all the right-adjoining locs with led features and the min x."))

(defmethod right-adjoining-led-locs ((feat-ls list) x accum)
  (dolist (feat feat-ls)
    (when (typep feat 'char-primitive-feature)
      (when (> 1.5 (abs (- (left-edge feat) x)))
        (return-from right-adjoining-led-locs
          (right-adjoining-led-locs feat-ls (right-edge feat)
                                    (append accum (list (xy-loc feat))))))))
  (values accum x))


;;; LEFT-ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : Recursively go left and accumulate locations that share
;;;             : the boundary.

(defgeneric left-adjoining-led-locs (feat-ls x accum)
  (:documentation  "Return a list of all the left-adjoining locs with led features and the max x."))

(defmethod left-adjoining-led-locs ((feat-ls list) x accum)
  (dolist (feat feat-ls)
    (when (typep feat 'char-primitive-feature)
      (when (> 1.5 (abs (- (right-edge feat) x)))
        (return-from left-adjoining-led-locs
          (left-adjoining-led-locs feat-ls (left-edge feat)
                                   (append (list (xy-loc feat)) accum))))))
  (values accum x))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Misc utils
;;;; 

(defgeneric set-clof (vis-mod new-lof)
  (:documentation "Updates vision module's current location of focus."))

(defmethod set-clof ((vis-mod vision-module) (new-lof vector))
  (setf (current-lof vis-mod) new-lof)
  (when (trace-attn-p vis-mod)
    (push (cons (pm-time) new-lof) (attn-trace vis-mod))))




;;; non-MCL lisps don't define COPY-INSTANCE, so we need one just for 
;;; feature-spec types.

#-:mcl
(defmethod copy-instance ((spec feature-spec))
  (make-instance 'feature-spec
    :x (screen-x spec) :y (screen-y spec) :nearest (nearest spec) 
    :attended-p (attended-p spec) :value (val spec) :color (color spec)
    :kind (kind spec) :size (size spec) :distance (distance spec)))


;;; CHOP-STRING      [Function]
;;; Date        : 97.07.02
;;; Description : Chops up a string according to what's in the string.  
;;;             : The idea is to keep words intact, blocks of nonword characters
;;;             : intact, and know the spacing between words.  Given a string,
;;;             : this will return a list with that kind of info in it.
;;;             : Example:  (chop-string "==foo==   bar") will return:
;;;             : ("==" "foo" "==" 3 "foo").  The 3 in the list represents
;;;             : blanks, and notice how the "==foo==" was carved into three
;;;             : elements.

(defun chop-string (str)
  (declare (string str))
  (let* ((oldstate (char->state (char str 0)))
         (state nil)
         (chr nil)
         (wrd "")
         (cnt 0)
         (accum nil))
    (dotimes (i (length str))
      (setf chr (char str i))
      (setf state (char->state chr))
      (cond
       ;; if we're accumulating chars and the new char matches our state,
       ;; just concat the char
       ((or (and (eq state :WORD) (eq oldstate :WORD))
            (and (eq state :MISC) (eq oldstate :MISC)))
        (setf wrd (mkstr wrd chr))
        (setf cnt 0))
       ;; If we get a state change that finishes a word, then grab the
       ;; word.
       ((and (or (eq oldstate :WORD) (eq oldstate :MISC))
             (not (eq oldstate state)))
        (push wrd accum)
        (if (not (eq state :SPACE))
          (setf wrd (mkstr chr))
          (setf wrd "")))
       ;; when switching from spaces to words, push the counter and start
       ;; the word
       ((and (eq oldstate :SPACE) (not (eq state oldstate)))
        (push (1+ cnt) accum)
        (setf wrd (mkstr wrd chr)))
       ;; from whitespace to whitespace, inc the counter
       (t (incf cnt)))
      (setf oldstate state))
    (when (not (string= wrd ""))
      (push wrd accum))
    (setf accum (nreverse accum))
    (when (numberp (first accum))
      (decf (first accum)))
    accum))


(defun char->state (char)
  "Given a character, return :WORD, :SPACE, or :MISC"
  (declare (character char))
  (cond ((alphanumericp char) :WORD)
        ((whitespace-p char) :SPACE)
        (t :MISC)))


(defun whitespace-p (char)
  "Returns T if <char> is a whitespace character (non-printing or space)"
  (declare (character char))
  (or (not (graphic-char-p char))
      (eq char #\Space)))


(defun break-by-space (str)
  "Return <str> broken into a list of strings. Space is the separator."
  (declare (string str))
  (let ((ans nil)
        (pos nil)
        (start 0))
    (loop
      (setf pos (position #\space str :start start))
      (cond (pos 
             (push (subseq str start pos) ans)
             (setf start (1+ pos)))
            (t
             (push (subseq str start (length str)) ans)
             (return))))
    (setf ans (remove "" ans :test #'string=))
    (reverse ans)))




;;; CONTIGUOUS-LOCS      [Function]
;;; Date        : 97.02.07
;;; Description : Given a location and a feature list, return a list of all the 
;;;             : contiguous locations.  "Contiguous" only in the X direction,
;;;             : in this case.

(defun contiguous-locs (loc feat-lis)
  "Given a location and a feature list, return a list of all the contiguous locations"
  (declare (vector loc) (list feat-lis))
  (let ((workloc (copy-list loc))
        (work-lis nil))
    (while (feat-match-xy feat-lis workloc)
      (push (copy-seq workloc) work-lis)
      (incf (px workloc)))
    (setf workloc (copy-seq loc))
    (decf (px workloc))
    (while (feat-match-xy feat-lis workloc)
      (push (copy-seq workloc) work-lis)
      (decf (px workloc)))
    (sort work-lis #'< :key #'first)))



(defun phrase-accum (lis)
  "Accumulate a list of words into a phrase."
  (let ((accum (first lis)))
    (dolist (item (rest lis) accum)
      (setf accum (mkstr accum " " item)))))


(defun word-accum (lis)
  "Accumulate a list of letters into a word, and downcase it."
  (let ((accum (first lis)))
    (dolist (item (rest lis) (string-downcase accum))
      (setf accum (mkstr accum item)))))