;;; -*- Mode: Common-Lisp; Package: SEGMAN; Base: 10 -*- ;;;******************************************************************************** ;;; Project: Interface softbots ;;; Contact: Rob St. Amant (stamant@csc.ncsu.edu) ;;; Department of Computer Science ;;; North Carolina State University ;;; Raleigh, NC 27695 ;;; This code was written as part of the Interface Softbots project at ;;; North Carolina State University, and has been placed in the public ;;; domain. ;;; This file contains glue to connect SegMan with ACT-R 5.0. It is ;;; based on the functions contained in ACT-R files such as ;;; acl-interface and mcl-interface. In those ports, features for ;;; objects are generated from hooks into the user interface ;;; management system; ACT-R would be able to define a visual button ;;; object, for example, by function calls that access the button's ;;; position, text, and so forth. In SegMan this information is ;;; extracted from the screen. ;;; Outline: ;;; I. Definitions and support functions for build-features-for. ;;; II. Device dependency functions. ;;; Change history (most recent first): ;;; 2002-03-10. Added code for processing the entire screen, rather ;;; than the window-based code ACTR generally uses. Also ;;; added a *features-recognized* parameter to allow a ;;; model to restrict the type of features that are ;;; visually processed. (RSA) ;;; 2002-03-10. File created, based on ACTR:acl-interface.lisp (RSA) ;;;******************************************************************************** (in-package :segman) ;;;******************************************************************************** (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "ACTR") (let ((package (or (find-package "COMMON-GRAPHICS-USER") (find-package "COMMON-LISP-USER")))) (rename-package package (package-name package) (list* "ACTR" "ACT-R" (package-nicknames package)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(actr::*mp* actr::vis-m actr::process-display actr::device actr::device-interface actr::pm-install-window actr::vision-module actr::build-features-for actr::icon-feature actr::visual-object actr::unknown actr::vision-module actr::rect-feature actr::oval-feature actr::build-string-feats actr::cursor-to-feature actr::cursor-feature actr::cursor-in-window-p actr::get-mouse-coordinates actr::device-move-cursor-to actr::device-handle-keypress actr::device-handle-click) :actr)) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(segman::build-group-features-for) :segman)) ;;;******************************************************************************** ;;; I. Definitions and support functions for build-features-for. ;;; For the sake of running experiments, we may only want to have the ;;; system recognize a limited set of objects. We set the variable ;;; *recognized-features* to a list of their types, and no other ;;; feature types will be returned. (defparameter *recognized-features* t) ;;; Notice that all of these build-features-for methods (except for ;;; the first one, which acts as a hook) are defined in the segman ;;; package rather than the actr package; this means that we can ;;; define methods whose arguments are not congruent with the original ;;; versions, because we need additional information. ;;; BUILD-FEATURES-FOR [Method] ;;; Date : 02.03.10 ;;; Description : The original actr:build-features-for method for a ;;; window walks the subviews of the window, calling ;;; build-features-for recursively. For segman, we want to be able to ;;; handle arbitrary screen regions as well as windows. To build ;;; features in a modular way, we redirect to a set of different ;;; methods, segman::build-group-features-for. ;;; Note on feature collection: I don't like all the consing that ;;; needs to be done because of the hierarchical traversal of objects ;;; that ACTR relies on. Further, we don't really need to do the ;;; hierarchical traversal, since containment relationships are not ;;; recorded explicitly. Let's instead have an accumulator that ;;; everything gets pushed onto. (defvar *feature-accumulator*) (defmethod actr:build-features-for ((bounds list) (vis-mod actr:vision-module)) (let* ((*feature-accumulator* nil) (groups (groups-within-bounds bounds)) (contained-objects (all-objects-of-all-types groups))) (loop for (object . type) in contained-objects do (when (or (eq *recognized-features* t) (member type *recognized-features*)) (build-group-features-for object type vis-mod))) (when (or (eq *recognized-features* t) (member :text *recognized-features*)) (let ((word-groups-list (groups-within-bounds bounds (nth-value 1 (all-words *all-letters* 0))))) (loop for word-groups in word-groups-list do (build-group-features-for word-groups :text vis-mod)))) *feature-accumulator*)) ;;; For a window, we just grab the contained objects and call the same ;;; function. This is defined to be accessible in the ACTR package so ;;; that it can be called directly by experiment code. (defmethod actr:build-features-for ((segman-window fixnum) (vis-mod actr:vision-module)) (let* ((bounds (get-bounds segman-window))) (actr:build-features-for bounds vis-mod))) ;;; ;;; BUILD-GROUP-FEATURES-FOR [Method] ;;; ;;; Date : 02.03.10 ;;; ;;; Description : For a SegMan window, walk the objects and build features. ;;; ;;; In the current version, all words are treated as being independent, even ;;; ;;; if they're aligned as for a sentence. ;;; (defmethod build-group-features-for ((window fixnum) (type (eql :window)) ;;; (vis-mod actr:vision-module)) ;;; (let* ((bounds (get-bounds window)) ;;; (contained-objects (all-objects-of-all-types (groups-within-bounds bounds)))) ;;; (loop for (object . type) in contained-objects ;;; do (when (or (eq *recognized-features* t) ;;; (member type *recognized-features*)) ;;; (build-group-features-for object type vis-mod))) ;;; (when (or (eq *recognized-features* t) ;;; (member :text *recognized-features*)) ;;; (let ((word-groups-list (groups-within-bounds ;;; bounds (nth-value 1 (all-words *all-letters* 0))))) ;;; (loop for word-groups in word-groups-list ;;; do (build-group-features-for word-groups :text vis-mod)))))) ;;; BUILD-GROUP-FEATURES-FOR [Method] ;;; Date : 02.03.10 ;;; Description : The default method for building features, returns an object ;;; : of the ICON-FEATURE class with the location and ISA fields ;;; : set. (defmethod build-group-features-for ((object fixnum) (type t) (vis-mgr actr:vision-module)) "Build an icon feature for the dialog item" (push (make-instance 'actr:icon-feature :kind 'actr:visual-object :value 'actr:unknown :screen-obj object :x (get-left object) :y (get-top object) :height (get-height object) :width (get-width object)) *feature-accumulator*)) ;;; BUILD-GROUP-FEATURES-FOR [Method] ;;; Date : 02.03.10 ;;; Description : Constructs features for an editable text area. ;;; Currently only handles single line text boxes. (defmethod build-group-features-for ((text-area fixnum) (type (eql :text-area)) (vis-mod actr:vision-module)) "Builds an icon feature for an EDITABLE-TEXT-DIALOG-ITEM" (push (make-instance 'actr:rect-feature :x (get-left text-area) :y (get-top text-area) :width (get-width text-area) :height (get-height text-area) :screen-obj text-area) *feature-accumulator*)) ;;; BUILD-GROUP-FEATURES-FOR [Method] ;;; Date : 02.03.10 ;;; Description : A button dialog item is a lot like a static text item, ;;; : except there's an oval associated with it and the text ;;; : is centered both horizontally and vertically. (defmethod build-group-features-for ((button fixnum) (type (eql :button)) (vis-mod actr:vision-module)) "Builds an icon feature for a BUTTON object." (push (make-instance 'actr:oval-feature :x (get-left button) :y (get-top button) :width (get-width button) :height (get-height button) :screen-obj button) *feature-accumulator*)) ;;; BUILD-GROUP-FEATURES-FOR [Method] ;;; Date : 02.03.10 ;;; Description : A static text dialog item is just text, so just ;;; build the string features for it. This gets called after all ;;; other object features, because there's no good way for SegMan ;;; to determine what text is standalone until other objects have ;;; claimed those strings that they contain. (defparameter *space-width* 7) (defmethod build-group-features-for ((word-groups list) (type (eql :text)) (vis-mod actr:vision-module)) (dolist (feature (actr:build-string-feats vis-mod :text (groups-to-string word-groups) :start-x (get-left word-groups) :y-pos (get-bottom word-groups) :width-fct #'(lambda (string) (declare (dynamic-extent word-groups)) ; Necessary? ;; Apparently this function has three applications: ;; - the entire string ;; - an individual character in the string ;; - a space (cond ((string= string " ") *space-width*) ; Assumes 'standard' font size ((= (length string) 1) (get-width (find (char string 0) word-groups :key #'letter*))) ((= (length string) (length word-groups)) (- (get-right (first (last word-groups))) (get-left (first word-groups)))) (t (error "Unexpected input in width-fct")))) :height (get-height word-groups))) (push feature *feature-accumulator*))) ;;;******************************************************************************** ;;; II. Device dependencies ;;; CURSOR-TO-FEATURE [Function] ;;; Date : 02.03.10 ;;; Description : Returns a feature representing the current state of the cursor. ;;; The shape is not handled. (defmethod actr:cursor-to-feature ((segman-window fixnum)) "Returns a feature corresponding to the current cursor." (let ((position (get-cursor))) (make-instance 'actr:cursor-feature :x (point-x position) :y (point-y position) :value 'POINTER))) (defmethod actr:cursor-in-window-p (window-group) "Returns T if the cursor is over the input window, NIL otherwise." (contains-point-p window-group (get-cursor))) (defmethod actr:get-mouse-coordinates ((segman-window fixnum)) "Returns window-origin mouse coordinates" (apply #'vector (subtract-points (get-cursor) (get-position segman-window)))) (defmethod actr:get-mouse-coordinates ((segman-region list)) "Returns region-origin mouse coordinates" (let ((point (get-cursor))) (vector (point-x point) (point-y point))) #+testing (let ((point (get-cursor))) (destructuring-bind (left top . rest) segman-region rest (vector (- (point-x point) left) (- (point-y point) top))))) (defmethod actr:device-move-cursor-to ((segman-window fixnum) point) (move-mouse-to (add-points (get-position segman-window) (make-point (aref point 0) (aref point 1))))) (defmethod actr:device-move-cursor-to ((segman-region list) point) (declare (ignorable segman-region)) (move-mouse-to (make-point (aref point 0) (aref point 1))) #+testing (destructuring-bind (left top . rest) segman-region rest (move-mouse-to (make-point (+ left (aref point 0)) (+ top (aref point 1)))))) (defmethod actr:device-handle-keypress ((segman-window fixnum) the-key) (press-key the-key)) (defmethod actr:device-handle-click ((segman-window fixnum)) (single-click)) (defmethod actr:device-handle-click ((segman-region list)) (declare (ignorable segman-region)) (single-click)) ;;;******************************************************************************** ;;; Testing #+ignore (progn ;; Put up a window, and position the mouse over it. (single-click) ; Raise the window (sleep 1) ; Wait a sec. . . (segment-screen '(-1 -1 -1 -1)) ; Segment everything, or just some area ;; Now we can set the device-interface to look just at a single window. #+ignore (actr::pm-install-window (first (all-groups-of-type :window))) ;; Alternatively, we can juse use an area. (actr::pm-install-window '(150 200 545 680)) ;; Now let ACT-R/PM process the screen. (actr:process-display (actr:device-interface actr:*mp*) (actr:vis-m actr:*mp*)) ;; Here's what's in the visual icon. (print (actr::visicon (actr:vis-m actr:*mp*)))) ;;;******************************************************************************** ;;; EOF