;;;-*- Mode: Lisp; Package: CCL -*- ;********************************************************************* ;* * ;* PROGRAM H E L P T A G M A N A G E R * ;* * ;********************************************************************* ;* Author : Alexander Repenning (alexander@agentsheets.com) * ;* http://www.agentsheets.com * ;* Copyright : (c) 1996-2007, AgentSheets Inc. * ;* Filename : Help-Tag-Manager.lisp * ;* Updated : 11/27/07 * ;* Version : * ;* 1.0 06/23/03 * ;* 1.1 06/27/03 ("spec" . "extended spec") idea Octav Popescu * ;* 1.1.1 04/30/04 ignore non-string help-specs * ;* 1.2 02/07/07 screen-help-corners * ;* 1.3 11/27/07 Leopard support * ;* SW/HW : PowerPC G4, MCL 5.2, OS X 10.5.0 * ;* Abstract : Help tags for views * ;* * ;****************************************************************** (in-package :ccl) (export '(start-help-tag-manager stop-help-tag-manager help-tag-manager-running-p screen-help-corners)) ;; Specification (defgeneric SCREEN-HELP-CORNERS (Simple-View Position) (:documentation "return topleft and bottomright corners of view for help manager as screen coordinate points. Tooltip will be placed below, above, left or right of this box.")) ;; Helper functions (defun HELP-TAG-WAIT-FOR-TIME-OR-KEY-EVENT (Time) ;; only needed for OS X >= Leopard ;; practically identical to version in anticipatory-symbol-complete.lisp (let ((Wakeup-Time (+ (get-internal-real-time) (* Time internal-time-units-per-second)))) (without-interrupts ;; don't allow other threads to steal events (loop ;; timeout (when (>= (get-internal-real-time) Wakeup-Time) (return)) (when (mouse-down-p) (return)) ;; poll for key events (rlet ((Event :eventrecord)) (when (#_EventAvail #$everyEvent Event) (case (rref Event :eventrecord.what) ((#.#$keyDown #.#$keyUp #.#$autoKey) ;; Key Event (let ((Char (code-char (logand #$charCodeMask (rref Event :eventrecord.message))))) (unless (char= Char #\null) ;;(#_postevent (rref event :eventrecord.what) (rref event :eventrecord.message)) (return Char)))) ((#.#$activateEvt #.#$osEvt #.#$mouseDown #.#$mouseUp #.#$updateEvt) ;; Window activation or OS event (#_getNextEvent #$everyEvent Event)) ;; let OS X handle this high level event ;; http://developer.apple.com/documentation/AppleScript/Conceptual/AppleEvents/dispatch_aes_aepg/chapter_4_section_3.html ;; listing 3-5 (#.#$kHighLevelEvent (#_AEProcessAppleEvent Event)) (t ;; unexpected event: send email to Alex if this happens (ed-beep) (format t "unexpected event=~A (send email to Alex)" (rref Event :eventrecord.what)))))))))) ;; Implementation (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro WITH-HELP-TAG ((Helptag text topleft bottomright) &body Body) "Shouldn't have to be a macro but I couldn't get it to work with make-record without crashing." ;; macro by Shannon Spires (let ((Cftextvar (gensym))) `(with-cfstrs ((,cftextvar ,text)) (rlet ((,helptag :hmhelpcontentrec :version #$kMacHelpVersion :tagside #$kHMDefaultSide)) (#_SetRect :ptr (pref ,helptag :hmhelpcontentrec.abshotrect) :long ,topleft :long ,bottomright) (setf (pref (pref ,helptag (:hmhelpcontentrec.content #$kHMMaximumContentIndex)) :hmhelpcontent.contenttype) #$kHMNoContent) (setf (pref (pref ,helptag (:hmhelpcontentrec.content #$kHMMinimumContentIndex)) :hmhelpcontent.contenttype) #$kHMCFStringContent) (setf (pref (pref ,helptag (:hmhelpcontentrec.content #$kHMMinimumContentIndex)) :hmhelpcontent.tagcfstring) ,cftextvar) (progn ,@body)))))) (defmethod HELP-SPEC ((Self t)) ;; no help spec as default nil) (defmethod HELP-SPEC ((Self dialog-item)) (rest (assoc :help-spec (view-alist Self)))) (defun HELP-TEXT (Tag-Spec Expandedp) " Extract help text from help-spec." (if Expandedp (if (consp Tag-Spec) (rest Tag-Spec) Tag-Spec) (if (consp Tag-Spec) (first Tag-Spec) Tag-Spec))) (defmethod SCREEN-HELP-CORNERS ((Self simple-view) Mouse-Position) ;; default: do not worry about mouse position ;; use view extend on screen as help corners (declare (ignore Mouse-Position)) (let* ((Topleft (add-points (view-position (view-window Self)) (convert-coordinates (view-position Self) (view-container Self) (view-window Self)))) (Bottomright (add-points Topleft (view-size Self)))) (values Topleft Bottomright))) (defun SHOW-HELP-TAG (Expandedp) ;; If there is a view at the cursor position containing some help-spec display it (let ((Window (front-window))) (when (and Window (window-active-p Window)) (let ((Position (view-mouse-position Window))) (let ((View (find-view-containing-point Window Position))) (when (view-container View) (let ((Help-Text (help-text (help-spec View) Expandedp))) ;; only with valid help text (when (stringp Help-Text) (multiple-value-bind (Topleft Bottomright) (screen-help-corners View (add-points Position (view-position (view-window View)))) (with-help-tag (Helptag Help-Text Topleft Bottomright) (#_HMDisplayTag Helptag) ;; begin evil hack!! (help-tag-wait-for-time-or-key-event 5) ;; keyboard is not getting rid of tag in OS X Leopard: manual event detection (#_HMHideTag))))))))))) (defvar *Help-Tag-Process* nil "a low CPU% process checking for the need to display help tags") (defvar *Help-Tag-Delay-Time* 0.5 "seconds before a help tag pops up") (defun START-HELP-TAG-MANAGER () (when *Help-Tag-Process* (return-from start-help-tag-manager)) (setq *Help-Tag-Process* (process-run-function '(:name "Help Tag Manager" :priority 0 :quantum 1) #'(lambda () ;; allow show-help-tag function to be called ASAP in case of using keyboard to enable/disable help (let ((Mouse-Position (view-mouse-position nil)) (Help-Display-Time 0) (Tag-Position 0) (Expandedp nil)) (loop (let ((New-Mouse-Position (view-mouse-position nil))) (cond ;; it's time to show a tag ((and (= Mouse-Position New-Mouse-Position) (>= (get-internal-real-time) Help-Display-Time) (not (= New-Mouse-Position Tag-Position))) (setq Expandedp (command-key-p)) (show-help-tag Expandedp) (setq Tag-Position New-Mouse-Position)) ;; Help Tag is up but users toggles between normal and expanded tag version ((and (= Mouse-Position New-Mouse-Position) (= Mouse-Position Tag-Position) (not (equal Expandedp (command-key-p)))) (setq Expandedp (not Expandedp)) (show-help-tag Expandedp)) ;; mouse got moved: get rid of tag and restart timer ((not (= Mouse-Position New-Mouse-Position)) (setq Mouse-Position New-Mouse-Position) (setq Help-Display-Time (+ (get-internal-real-time) (* *Help-Tag-Delay-Time* internal-time-units-per-second))) (setq Tag-Position 0) (#_HMHideTag)))) ;; make sure this process is not using too much CPU (sleep 0.3))))))) (defun STOP-HELP-TAG-MANAGER () (#_HMHideTag) ;; just in case (when *Help-Tag-Process* (process-kill *Help-Tag-Process*) (setq *Help-Tag-Process* nil))) (defun HELP-TAG-MANAGER-RUNNING-P () *Help-Tag-Process*) #| Examples: (start-help-tag-manager) (make-instance 'window :view-subviews (list (make-instance 'editable-text-dialog-item :view-position #@(20 20) :view-size #@(200 20) :dialog-item-text "Boulder" :help-spec '("City ð" . "please edit the name of the city or else")) (make-instance 'editable-text-dialog-item :view-position #@(20 50) :view-size #@(200 20) :dialog-item-text "80301" :help-spec "ZIP"))) (stop-help-tag-manager) |#