device.lisp 32.6 KB
Newer Older
1 2 3 4 5
; ----------------------------------------------------------------------
; Begin file: actr6/devices/ccl/device.lisp
; ----------------------------------------------------------------------


root's avatar
root committed
6
;;;  -*- mode: LISP; Syntax: COMMON-LISP;  Base: 10 -*-
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Address     : Rice University, MS-25
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;; Copyright   : (c)1998-2004 Mike Byrne
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : device.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : MCL-specific functions for RPM.  This consists primarily
;;;             : of stuff for vision (parsing the screen), and output
;;;             : stuff for motor.
;;; 
;;; Bugs        : 
;;; 
;;; --- History ---
root's avatar
root committed
30
;;; 01.09.21   mdb [b2]
31 32
;;;             : Fixed an infinite recursion bug in APPROACH-WIDTH.
;;; 2002.04.16 mdb [b6]
root's avatar
root committed
33 34 35 36
;;;             : Rolled in color text stuff.
;;;             : Added BUILD-FEATURES-FOR methods for radio buttons and
;;;               check boxes.
;;; 2002.04.18 mdb
37
;;;             : Fixed minor glitch created by color text stuff--if the part
root's avatar
root committed
38
;;;               color was not set, that passed NIL to the color parser.  No.
39 40 41 42 43 44 45
;;; 2002.05.17 mdb
;;;             : Moved COLOR-SYMBOL->MAC-COLOR here.
;;; 2002.06.05 mdb
;;;             : Grr, fixed what is hopefully the last vector bug issue.
;;; 
;;; 2002.06.21 Dan [b7]
;;;             : Changed the rpm-window class to rpm-real-window and
root's avatar
root committed
46
;;;               updated the methods accordingly.
47 48
;;; 2002.06.30 Dan
;;;             : Changed the COLOR-SYMBOL->MAC-COLOR and MAC-COLOR->SYMBOL
root's avatar
root committed
49 50 51
;;;               function names by replacing MAC with SYSTEM to be a little
;;;               more consistent (that way there aren't as many 'different'
;;;               function names floating around in these files).
52
;;;             : Moved the view-line stuff in here from the separate file and
root's avatar
root committed
53
;;;               documented it better.
54 55 56 57 58 59 60 61 62
;;;             : Removed all of the UWI code from this file.
;;; 2002.07.03 mdb
;;;             : Makes sure that SPEECH-AVAILABLE-P is defined.
;;; 2002.11.25 mdb [2.1f1]
;;;             : Added DEVICE-MOVE-CURSOR-TO for MCL5.0 on OSX. 
;;; 2003.03.11 mdb [2.1.2]
;;;             : Per DB's suggestion, cut back on EVENT-DISPATCHing. 
;;; 2003.06.18 mdb
;;;             : Turns out static text dialog items support multiple kinds
root's avatar
root committed
63 64
;;;               of justifications, though it's hard to get at it.  Now
;;;               handled properly. 
65 66 67 68
;;; 2003.06.23 mdb [2.1.3]
;;;             : Under-the-hood addition of RPM-OVERLAY class. 
;;; 2004.03.11 mdb [2.2]
;;;             : Added a VIEW-KEY-EVENT-HANDLER method for editable text dialog
root's avatar
root committed
69
;;;               items, which used to break.
70
;;;
root's avatar
root committed
71
;;; 04.10.19   Dan [Moved into ACT-R 6]
72 73 74 75 76 77
;;;             : Reset the version to 1.0a1
;;;             : added the packaging switches
;;;             : changed the name to device to be placed in a folder called MCL 
;;;             : removed references to *mp* and other minor
;;;             : ACT-R 6 updates
;;; 2006.09.07 Dan
root's avatar
root committed
78 79
;;;             : Removed the fill-default-dimensions method because it's
;;;               now defined in the vision file.
80
;;; 2007.07.02 Dan
root's avatar
root committed
81
;;;             : Converted things over for the new vision module.
82
;;; 2007.07.05 Dan
root's avatar
root committed
83
;;;             : Rolled in the multi-line fix Mike made to the old MCL device.
84 85 86 87
;;; 2010.03.11 mdb
;;;             : Fixed DEVICE-MOVE-CURSOR-TO for (R)MCL 5.2 under OS X.
;;; 2010.06.03 mdb
;;;             : Fixed XSTART for (R)MCL 5.2 under OS X, which uses NIL for 
root's avatar
root committed
88
;;;               left-justified text as a default (rather than :left).
89
;;; 2011.11.21 Dan
root's avatar
root committed
90 91 92
;;;             : Using model-generated-action instead of *actr-enabled-p*
;;;               in view-key-event-handler  for editable-text-dialog-items
;;;               to determine when to hack the output.
93 94 95
;;; 2012.08.07 cts
;;;             : Tweaked original MCL device.lisp code, and used it to build a
;;;               device for CCL that leverages ccl-simple-view.lisp.
root's avatar
root committed
96 97 98 99
;;;               Note that for any commented-out code that is left in this file,
;;;               I do not fully understand exactly what it
;;;               is meant for. But all tests are passing without adding the
;;;               code back in. So I'm keeping it commented out for now. If someone
100 101 102 103
;;;               fully understands how these pieces should
;;;               work, and sees that the code isn't needed, feel free to
;;;               remove. Or if it is needed, please add it back in.
;;; 2012.08.27 Dan
root's avatar
root committed
104 105 106 107 108 109 110 111
;;;             : The device-handle-keypress method now selects the window
;;;               before generating the events so that it goes to the right
;;;               window.
;;;             : In the device-handle-keypress method it now waits on a 
;;;               semaphore to be set by the view-key-event-handler method
;;;               before returning to guarantee the press gets processed.
;;;               It doesn't need to delay in the keypress action because of
;;;               that so it passes nil for the delay.
112
;;; 2012.08.29 Dan
root's avatar
root committed
113 114 115
;;;             : Added a timeout to device-handle-keypress so that it doesn't
;;;               hang if the semaphore never gets set.  If it's not set in
;;;               500ms it prints a warning and just gives up.
116
;;; 2012.08.30 cts
root's avatar
root committed
117 118 119 120 121 122 123
;;;             : Added the semaphore method for mouse clicks. Wrapped the 
;;;               timeout code into a function and using it for key presses
;;;               and mouse clicks. 
;;;             : Calling event-dispatch one final time after semaphore is triggered,
;;;               so that any events created during the keypress/mouseclick
;;;               that were queued to run on the NSRunLoop are run before the
;;;               keypress/mouseclick method returns.
124
;;; 2013.01.03 Dan
root's avatar
root committed
125 126 127 128 129 130 131
;;;             : Clipped the rpm-view-line function (which was already commented out)
;;;               to avoid confusion since it isn't needed and contained outdated code.
;;; 2013.02.01 cts 
;;;             : Streamlined the device-move-cursor-to call.
;;;               The function no longer pauses for a set time to ensure that the move
;;;               is registered. Instead, it polls and checks that the move is registered
;;;               and exits immediately after success.
132
;;; 2013.04.10 cts
root's avatar
root committed
133 134
;;;             : Feature was added in ccl device to change text color for buttons.
;;;               Visicon representation for buttons now shows text in appropriate color
135
;;; 2013.04.20 cts
root's avatar
root committed
136 137
;;;             : Removed stray commented out code that is no longer necessary.
;;;             : Now spell checking comments and strings in the code.
138
;;; 2013.04.27 cts
root's avatar
root committed
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
;;;             : Removed unnecessary code duplication when building visual objects for lines
;;; 2014.01.24 Dan
;;;             : Updated the build-vis-locs-for methods for text and button
;;;               items so that they use the updated build-string-feats to
;;;               deal with newlines in the text.
;;;             : Added an optional parameter to startx to provide a string to
;;;               use instead of the whole dialog-item-text so that when there
;;;               are multiple lines each gets justified appropriately.
;;; 2014.01.27 Dan
;;;             : Fixed some bugs with the last update.
;;;             : Round all the string-width and ascent/descent values because
;;;               they return floats.
;;;             : Fix the y-coordinate for button text because it shifted when
;;;               I updated build-string-feats.
;;; 2014.02.10 Dan
;;;             : Read a button's color out of the background slot.
;;; 2014.02.08 cts
;;;             : Removed the fixmum declaration in loc-avg since it's not needed b/c the function rounds
;;;               to the nearest whole number anyways. It was also causing ccl to crash when a
;;;               double type floating point was passed to it that function, which kept happening in
;;;               some of the more complicated, closer-to-real-world regression tests.
;;;             : Visicon positions now correct for nested views.
;;; 2014.11.25 cts
;;;             : Ensured that device-move-cursor-to works properly when a non-integer value is passed in
;;;               the new mouse position argument. This does not commonly occur when the positions of all
;;;               of the views in the window are static, since those positions were most likely specified 
;;;               as integers when the views were placed in the window. However, for dynamic views
;;;               (e.g., a scroll-bar-dialog-item) the position of items contained within that view may
;;;               be represented as non-integers. Moving a mouse to a non-integer location does not make sense,
;;;               since the pointer must be placed on a pixel. So the fix is to simply round non-integer values
;;;               to their nearest integer when determining the pixel location to move the mouse to.
;;;             
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (in-package :act-r)
#+(and :clean-actr (not :packaged-actr) :allegro-ide) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :allegro-ide) (in-package :cl-user)

(require-compiled "CCL-SIMPLE-VIEW" "ACT-R6:support;ccl-simple-view")

(defun loc-avg (x y)
  "Return the 'location' (integer) average of <x> and <y>."
  (floor (/ (+ x y) 2)))


;;;; ---------------------------------------------------------------------- ;;;;;;;
;;;; MCL screen-to-icon interface
;;;; ---------------------------------------------------------------------- ;;;;;;;



(defmethod build-vis-locs-for ((self window) (vis-mod vision-module))
  (let ((base-ls (flatten
                   (mapcar #'(lambda (obj) (build-vis-locs-for obj vis-mod))
                           (get-sub-objects self)))))
    base-ls))

(defmethod vis-loc-to-obj ((device window) loc)
  (case (chunk-slot-value-fct loc 'kind)
    (cursor
      (fill-default-vis-obj-slots (car (define-chunks (isa cursor))) loc))))

(defgeneric get-sub-objects (view)
  (:documentation  "Grabbing the sub-objects of a view by default returns the subviews."))

(defmethod get-sub-objects ((v simple-view))
  (subviews v))



(defmethod build-vis-locs-for ((self simple-view) (vis-mod vision-module))
  (let ((subs (get-sub-objects self))
        (outlis nil))
    (dolist (sub subs outlis)
      (push (build-vis-locs-for sub vis-mod) outlis))))



(defmethod button-p (obj)
  (declare (ignore obj))
  nil)

(defmethod button-p ((obj button-dialog-item))
  (declare (ignore obj))
  t)

(defmethod build-vis-locs-for ((self static-text-dialog-item)
                               (vis-mod vision-module))
  (let ((text (dialog-item-text self)))
    (unless (equal text "")
      (let* ((font-spec (view-font self))
             (accum nil)
root's avatar
root committed
231
             (width-fct #'(lambda (str) (round (string-width str font-spec))))
232 233 234
             (color (system-color->symbol (aif (part-color self :text)
                                            it
                                            *black-color*))))
root's avatar
root committed
235

236
        (multiple-value-bind (ascent descent) (font-info font-spec)
root's avatar
root committed
237 238 239 240 241 242 243 244 245 246 247 248
          (setf accum (build-string-feats vis-mod :text text
                                          :start-x 0
                                          :x-fct (lambda (string startx obj)
                                                   (+ startx (xstart obj string)))
                                          :y-pos 
                                          (+ (point-v (view-global-position self)) (round (+ ascent descent) 2))
                                          :width-fct width-fct 
                                          :height (round ascent)
                                          :obj self
                                          :line-height (round (+ ascent descent)))))


249 250 251 252
        (dolist (x accum accum)
          (set-chunk-slot-value-fct x 'color color)
          (setf (chunk-visual-object x) self))))))

root's avatar
root committed
253 254 255 256 257
(defmethod xstart ((self static-text-dialog-item) &optional string)
  (let* ((left-x (point-h (view-global-position self)))
         (text (if (stringp string) string (dialog-item-text self)))
         (text-width (round (string-width text (view-font self))))
         (text-justification (text-just self)))
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287
    (ecase text-justification
      (#.#$tejustleft (1+ left-x))
      (#.#$tejustcenter (+ 1 left-x (round (/ (- (width self) text-width) 2))))
      (#.#$tejustright (+ 1 left-x (- (width self) text-width))))))

(defmethod cursor-to-vis-loc ((the-window window))
  (let ((pos (view-mouse-position the-window))
        (shape (window-cursor the-window)))
    (when (cursor-in-window-p the-window)
      (car (define-chunks-fct `((isa visual-location kind cursor 
                                     screen-x ,(round (point-h pos))
                                     screen-y ,(round (point-v pos))
                                     color ,(system-color->symbol (color shape))
                                     value ,(cond ((eq shape *i-beam-cursor*) 'i-beam)
                                                  ((eq shape *crosshair-cursor*) 'crosshair)
                                                  (t 'pointer)))))))))

(defgeneric cursor-in-window-p (wind)
  (:documentation  "Returns T if the cursor is over <wind>, NIL otherwise."))

(defmethod cursor-in-window-p ((tw window))
  (when (window-shown-p tw)
    (let ((size (view-size tw))
          (cpos (view-mouse-position tw)))
      (and (>= (point-h cpos) 0)
           (>= (point-v cpos) 0)
           (<= (point-h cpos) (point-h size))
           (<= (point-v cpos) (point-v size))))))

(defmethod view-loc ((self view))
root's avatar
root committed
288
  (let ((pos (view-global-position self))
289 290 291 292 293 294
        (size (view-size self)))
    (vector (round (+ (point-h pos) (/ (point-h size) 2)))
            (round (+ (point-v pos) (/ (point-v size) 2))))))


(defmethod view-loc ((self simple-view))
root's avatar
root committed
295
  (let ((pos (view-global-position self))
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441
        (size (view-size self)))
    (vector (round (+ (point-h pos) (/ (point-h size) 2)))
            (round (+ (point-v pos) (/ (point-v size) 2))))))


(defmethod view-loc ((self symbol))
  (if (eq self :cursor)
    ;DAN (get-mouse-coordinates (device (device-interface *mp*)))
    (get-mouse-coordinates (current-device))
    (error "!! Can't find location of ~S" self)))


;;; VIEW-DRAW-CONTENTS [Method]
;;; Description : A liner is just a line feature located at its mid-point

(defun 1-not<0 (val)
  (guard ((>= val 0) "subtracting one from an already negative value"))
  (max (1- val) 0))

(defun subtract-point-1-not<0 (point)
  (make-point
    (1-not<0 (point-h point))
    (1-not<0 (point-v point))))

(defmethod build-vis-locs-for ((lnr liner) (vis-mod vision-module))
  "Convert the view to a feature to be placed into the visual icon"
  (let ((start-pt (local-to-global lnr (subtract-point-1-not<0 (get-start lnr))))
        (end-pt (local-to-global lnr (subtract-point-1-not<0 (get-end lnr)))))
    (let ((f (car (define-chunks-fct
                    `((isa visual-location
                           color ,(system-color->symbol (color lnr))
                           value line
                           kind line
                           screen-x ,(loc-avg (point-h start-pt) (point-h end-pt))
                           screen-y ,(loc-avg (point-v start-pt) (point-v end-pt))
                           width ,(abs (- (point-h start-pt) (point-h end-pt)))
                           height ,(abs (- (point-v start-pt) (point-v end-pt)))))))))
      (setf (chunk-visual-object f) lnr)
      f)))

(defmethod vis-loc-to-obj ((lnr liner) loc)
  (let ((start-pt (local-to-global lnr (subtract-point-1-not<0 (get-start lnr))))
        (end-pt (local-to-global lnr (subtract-point-1-not<0 (get-end lnr))))
        (v-o (fill-default-vis-obj-slots (car (define-chunks (isa line))) loc)))
    (set-chunk-slot-value-fct v-o 'end1-x (point-h start-pt))
    (set-chunk-slot-value-fct v-o 'end1-y (point-v start-pt))
    (set-chunk-slot-value-fct v-o 'end2-x (point-h end-pt))
    (set-chunk-slot-value-fct v-o 'end2-y (point-v end-pt))
    v-o))

;;;; ---------------------------------------------------------------------- ;;;;
;;;; Utilities
;;;; ---------------------------------------------------------------------- ;;;;

;;; XY->POINT      [Function]
;;; Description : Converts an (X Y) list into an MCL/Quickdraw point.

(defun xy->point (xy)
  "(x y) to point conversion function. Deprecated, use vpt2p instead."
  (declare (list xy))
  (make-point (first xy) (second xy)))


;;; P2XY      [Function]
;;; Description : Takes an MCL/Quickdraw point and returns an XY list

(defun p2xy (p)
  "Coverts an MCL/Quickdraw point to an XY list.  Deprecated, use p2vpt instead."
  ;  (declare (point p))
  (list (point-h p) (point-v p)))


(defun p2vpt (p)
  "Convert an MCL/Quickdraw point to #(x y) format."
  (declare (inline p2vpt))
  (vector (point-h p) (point-v p)))


(defun vpt2p (mpt)
  "Convert an #(x y) format point to MCL/Quickdraw format."
  (declare (vector mpt) (inline vpt2p))
  (make-point (px mpt) (py mpt)))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; RPM device methods.
;;;; ---------------------------------------------------------------------- ;;;;

;;; To guarantee that a keypress by the model gets processed before returning
;;; from the device-handle-keypress method use a semaphore that gets cleared
;;; when the view-key-event-handler method gets called.  Since this is a complete
;;; lock-out (never have two keypresses pending at the same time regardless of
;;; whether they're from different models or not) only need the single semaphore
;;; instead of something fancy like a semaphore per model or window.

(defvar *keypress-wait* (make-semaphore))

(defun wait-n-times (fun n delay-secs)
  (let ((count -1)
        (max-count n))
    (while (and (null (funcall fun))
                (< (incf count) max-count))
      (event-dispatch)
      (awhen delay-secs 
        (spin-for-fct (* 1000 it))))
    (not (= count max-count))))

(defun wait-n-times-on-semaphore (sema n delay-secs)
  (wait-n-times
    (lambda () (timed-wait-on-semaphore sema delay-secs))
    n
    nil))

;;; DEVICE-HANDLE-KEYPRESS      [Method]
;;; Description : Generate a real keypress and then wait for VIEW-KEY-EVENT-HANDLER 
;;;             : to deal with it.
;;;             : To make sure the event is dealt with wait for the semaphore
;;;             : to be set and call event-dispatch periodically (every 50ms)
;;;             : while the semaphore is still clear.

(defmethod device-handle-keypress ((device window) key)
  (window-select device)
  (sv-log-n 1 "starting device-handle-keypress")
  (keypress key nil)
  (unless (wait-n-times-on-semaphore *keypress-wait* 10 .05)
    (print-warning "Model keypress event was not handled correctly within 500ms."))
  (event-dispatch)
  (sv-log-n 1 "ending device-handle-keypress"))

(defvar *mouseclick-wait* (make-semaphore))

;;; DEVICE-HANDLE-CLICK      [Method]
;;; Description : Again, just call the base MCL method and dispatch.

(defmethod device-handle-click ((device window))
  (window-select device)
  (sv-log-n 1 "starting device-handle-click")
  (left-mouse-click
    (local-to-global device (view-mouse-position device))
    nil)
  (unless (wait-n-times-on-semaphore *mouseclick-wait* 10 .05)
    (print-warning "Model mouse click was not handled correctly within 500ms."))
  (event-dispatch)
  (sv-log-n 1 "ending device-handle-click"))

;;; DEVICE-MOVE-CURSOR-TO      [Method]
root's avatar
root committed
442 443 444 445 446 447 448 449 450 451
;;; Date        : 2014-11-03
;;; Description : Uses the Quartz framework to move the cursor across the screen.
;;;             : Polls after the cursor moves to confirm that the cursor has moved
;;;               to the new location. If it has, return quickly. If it hasn't, keep
;;;               polling for 500 ms and bail if it hasn't within 500 ms.
;;;             : Since the cursor can only move to integer positions, make sure that the
;;;               xyloc passed to the method specifies an integer location, and round if not.
;;;               Otherwise, the check to ensure that the cursor moved to the specified position
;;;               will not work, since the cursor will move to an integer location, and xyloc will
;;;               be expecting a non-integer location
452 453

(defmethod device-move-cursor-to ((device window) (xyloc vector))
root's avatar
root committed
454 455 456 457 458 459 460 461 462 463 464 465
  (let ((xyloc (map 'vector #'round xyloc)))
    (window-select device)
    (sv-log-n 1 "moving cursor to ~a" xyloc)
    (easygui::running-on-main-thread ()
      (let ((xyloc (local-to-global device (vpt2p xyloc))))
        (#_CGWarpMouseCursorPosition   
         (ns:make-ns-point (point-h xyloc) (point-v xyloc)))))
    (unless (wait-n-times (lambda ()
                            (vpt= xyloc (p2vpt (view-mouse-position device)))) 10 .05)
      (print-warning "Model cursor movement was not handled correctly within 500ms."))
    (event-dispatch)
    (sv-log-n 1 "ending move cursor")))
466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650

;;; DEVICE-SPEAK-STRING      [Method]
;;; Description : If the Mac Speech Manager is installed, actually speak the
;;;             : string.

#+:digitool
(defmethod device-speak-string ((device window) string)
  (when (speech-available-p)
    (speak-string string)
    ))

; Haven't ported MCL's speech code yet.

#+:clozure
(defmethod device-speak-string ((device window) string)
  #-:sv-dev (declare (ignore string))
  nil)


;;; GET-MOUSE-COORDINATES      [Method]
;;; Description : Return the current mouse location in #(x y) format.

(defmethod get-mouse-coordinates ((device window))
  (p2vpt (view-mouse-position device)))

#|
;;; DEVICE-UPDATE      [Method]
;;; Date        : 03.03.11
;;; Description : Rather than calling EVENT-DISPATCH on every cycle, call it
;;;             : only at about 10Hz.

(defmethod device-update :after ((wind window) time)
  (declare (ignore wind time))
  (when (< 100 (- (get-internal-real-time) *last-update*))
    (event-dispatch)
    (setf *last-update* (get-internal-real-time)))
  )


|#

#|
(defmethod do-update :after ((mstr-proc master-process) current-time 
                                                        &key (real-wait nil))
  (declare (ignore current-time real-wait))
  (event-dispatch))
|#


;;;; ---------------------------------------------------------------------- ;;;;
;;;; RPM overlay and Focus ring stuff


;;; RPM-OVERLAY      [Class]
;;; Description : If you want a view to be superimposed on a window, but not
;;;             : be visible to RPM, use this class.  The focus ring in RPM
;;;             : is a subclass.
;;;
;;;             : The OFFSET slot is for the difference between the center of
;;;             : the view and the upper-left corner, as a QuickDraw point.
;;;             : For example, for the focus ring its #@(-10 -10).

(defclass rpm-overlay (simple-overlay-view)
  ((offset :accessor offset :initarg :offset :initform nil)))


(defgeneric update-me (olay wind xyloc)
  (:documentation "Call this to move the overlay to a specific location within a window."))

(defmethod update-me ((olay rpm-overlay) (wind window) (xyloc vector))
  (set-view-position olay (add-points (offset olay) (vpt2p xyloc)))
  (unless (equal (view-window olay) wind) (add-subviews wind olay))
  (when (wptr (view-window olay)) (view-draw-contents olay)))

(defmethod update-me ((olay rpm-overlay) (wind window) (xyloc (eql nil)))
  (sv-log "calling update-me with nil xyloc"))

;;; BUILD-FEATURES-FOR      [Method]
;;; Description : We don't want icon features for the focus ring, and since 
;;;             : it'll be a subview a null BUILD-FEATURES-FOR method is 
;;;             : necessary.

(defmethod build-vis-locs-for ((olay rpm-overlay) (vm vision-module))
  (declare (ignore olay vm))
  nil)

;;; POINT-IN-CLICK-REGION-P      [Method]
;;; Description : The focus ring will generally be the "front" view, but 
;;;             : having it receive clicks is a Bad Thing (tm) so it's 
;;;             : necessary to override the POINT-IN-CLICK-REGION-P method
;;;             : for this view class.

(defmethod point-in-click-region-p ((olay rpm-overlay) where)
  (declare (ignore olay where))
  nil)


;;; here's the actual focus ring itself

(defclass focus-ring (rpm-overlay)
  ((easygui::foreground :reader color :initform *red-color*))
  (:default-initargs 
    :view-size #@(19 19)
    :offset #@(-10 -10)))

(defmethod rpm-overlay-p ((view rpm-overlay))
  t)

(defmethod rpm-overlay-p ((view simple-view))
  nil)

(defmethod view-draw-contents ((self focus-ring))
  (let ((oldmode (pen-mode self))
        (oldpat (pen-pattern self))
        (oldsize (pen-size self)))
    (set-pen-mode self :pator)
    (set-pen-pattern self *light-gray-pattern*)
    (set-pen-size self 4 4)
    (with-focused-view self
      (with-fore-color (color self)
        (frame-oval self #@(0 0) (view-size self))))
    (set-pen-mode self oldmode)
    (set-pen-pattern self oldpat)
    (set-pen-size self (point-h oldsize) (point-v oldsize))
    ))


;;; DEVICE-UPDATE-ATTENDED-LOC      [Method]
;;; Date        : 00.07.11
;;; Description : When the attended location is updated, update the focus
;;;             : ring.

(defmethod device-update-attended-loc ((wind window) xyloc)
  (unless (aand (visual-fixation-marker) (eq (type-of it) 'focus-ring)
                (view-window (visual-fixation-marker)) (eq it wind))
    (setf (visual-fixation-marker) (make-instance 'focus-ring)))
  (when (wptr wind)
    (update-me (visual-fixation-marker) wind xyloc)))

; When called with nil xyloc, remove the current visual-fixation-marker.
; Note that this is called in cases where the current marker is not a subview in wind.
; For instance, at the start of a model run after a previous model has been run,
; the vis location marker might still be non-nil, but there is not a focus ring
; on the current window (window for new model). In this case, just set the vis
; location marker to nil.

(defmethod device-update-attended-loc ((wind window) (xyloc (eql nil)))
  (when (aand (visual-fixation-marker) (eq (type-of it) 'focus-ring)
              (view-window (visual-fixation-marker)) (eq it wind) (wptr wind))
    (remove-subviews wind (visual-fixation-marker)))
  (setf (visual-fixation-marker) nil))

#|
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
|#



; ----------------------------------------------------------------------
; End file: actr6/devices/ccl/device.lisp
; ----------------------------------------------------------------------
; ----------------------------------------------------------------------
; Begin file: bincarbon/device-patches-mcl.lisp
; ----------------------------------------------------------------------


(defun set-color-of-feats (color feats)
  (dolist (feat feats feats)
    (set-chunk-slot-value-fct feat 'color color)))

(defmethod build-vis-locs-for ((self dialog-item) (vis-mod vision-module))
  (declare (ignore vis-mod))
  (let ((f (car (define-chunks-fct `((isa visual-location
root's avatar
root committed
651 652 653 654 655
                                          screen-x ,(px (view-loc self))
                                          screen-y ,(py (view-loc self))
                                          kind visual-object
                                          color ,(system-color->symbol (part-color self :text))
                                          value unknown))))))
656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674
    (setf (chunk-visual-object f) self)
    f))

(defmethod build-vis-locs-for ((self editable-text-dialog-item) (vis-mod vision-module))
  (let* ((font-spec (view-font self))
         (text (dialog-item-text self))
         (feats 
           (cons
             (car (define-chunks-fct `((isa visual-location
                                            screen-x ,(px (view-loc self))
                                            screen-y ,(py (view-loc self))
                                            kind visual-object
                                            value box
                                            height ,(point-v (view-size self))
                                            width ,(point-h (view-size self))))))
             (unless (equal text "")
               (multiple-value-bind (ascent descent) (font-info font-spec)
                 (set-color-of-feats (system-color->symbol (part-color self :text))
                                     (build-string-feats vis-mod :text text
root's avatar
root committed
675 676 677
                                                         :start-x (1+ (point-h (view-global-position self)))
                                                         :y-pos (round (+ (point-v (view-global-position self))
                                                                          descent (round ascent 2)))
678
                                                         :width-fct #'(lambda (str)
root's avatar
root committed
679 680 681
                                                                        (round (string-width str font-spec)))
                                                         :height ascent :obj self
                                                         :line-height (round (+ ascent descent)))))))))
682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
    (dolist (x feats)
      (setf (chunk-visual-object x) self))
    feats))

(defmethod build-vis-locs-for ((self button-dialog-item) (vis-mod vision-module))
  (let* ((btn-width (point-h (view-size self)))
         (btn-height (point-v (view-size self)))
         (text (dialog-item-text self))
         (feats (cons
                  (car (define-chunks-fct `((isa visual-location
                                                 screen-x ,(px (view-loc self))
                                                 screen-y ,(py (view-loc self))
                                                 kind oval
                                                 value oval
                                                 height ,(point-v (view-size self))
                                                 width ,(point-h (view-size self))
root's avatar
root committed
698
                                                 color ,(system-color->symbol (get-back-color self))))))
699 700 701
                  (unless (equal text "")
                    (let* ((font-spec (view-font self))
                           (start-y nil)
root's avatar
root committed
702 703
                           (lines (count #\newline text))
                           (width-fct #'(lambda (str) (round (string-width str font-spec)))))
704
                      (multiple-value-bind (ascent descent) (font-info font-spec)
root's avatar
root committed
705 706
                        (setf start-y (+ (point-v (view-global-position self))
                                         (round (- btn-height (* lines
707
                                                                 (+ ascent descent))) 2)))
root's avatar
root committed
708 709 710 711 712 713 714 715 716 717 718 719 720 721
                        (set-color-of-feats (system-color->symbol (part-color self :text))
                                            (build-string-feats vis-mod :text text
                                                                :start-x 
                                                                (+ (point-h (view-global-position self))
                                                                   (round  btn-width 2))
                                                                :x-fct (lambda (string startx obj)
                                                                         (declare (ignore obj))
                                                                         (- startx
                                                                            (round (funcall width-fct string) 2))) 
                                                                :y-pos start-y
                                                                :width-fct width-fct 
                                                                :height (round (min ascent btn-height))
                                                                :obj self
                                                                :line-height (round (+ ascent descent))))))))))
722 723 724
    (let ((fun (lambda (x y) (declare (ignore x)) (approach-width (car feats) y))))
      (dolist (x (cdr feats))
        (setf (chunk-visual-approach-width-fn x) fun)))
root's avatar
root committed
725 726 727
    (dolist (x feats)
      (setf (chunk-visual-object x) self))
    feats))
728 729 730 731 732 733



; ----------------------------------------------------------------------
; End file: bincarbon/device-patches-mcl.lisp
; ----------------------------------------------------------------------