diff --git a/EXPERIMENTAL/interactive-query/org-iq.el b/EXPERIMENTAL/interactive-query/org-iq.el new file mode 100644 index 000000000..35c47a5a1 --- /dev/null +++ b/EXPERIMENTAL/interactive-query/org-iq.el @@ -0,0 +1,328 @@ +--- org-vendor/org.el 2008-01-06 10:30:26.000000000 -0500 ++++ org/org.el 2008-01-12 17:19:15.000000000 -0500 +@@ -15078,7 +15078,8 @@ + (let ((org-last-tags-completion-table + (org-global-tags-completion-table))) + (setq match (completing-read +- "Match: " 'org-tags-completion-function nil nil nil ++ "Match: " 'org-tags-completion-function nil nil ++ org-agenda-query-string + 'org-tags-history)))) + + ;; Parse the string and create a lisp form +@@ -18812,6 +18813,7 @@ + (defvar org-agenda-follow-mode nil) + (defvar org-agenda-show-log nil) + (defvar org-agenda-redo-command nil) ++(defvar org-agenda-query-string nil) + (defvar org-agenda-mode-hook nil) + (defvar org-agenda-type nil) + (defvar org-agenda-force-single-file nil) +@@ -18947,6 +18949,10 @@ + (org-defkey org-agenda-mode-map [(right)] 'org-agenda-later) + (org-defkey org-agenda-mode-map [(left)] 'org-agenda-earlier) + (org-defkey org-agenda-mode-map "\C-c\C-x\C-c" 'org-agenda-columns) ++(org-defkey org-agenda-mode-map "=" 'org-agenda-query-clear-cmd) ++(org-defkey org-agenda-mode-map "/" 'org-agenda-query-and-cmd) ++(org-defkey org-agenda-mode-map ";" 'org-agenda-query-or-cmd) ++(org-defkey org-agenda-mode-map "\\" 'org-agenda-query-not-cmd) + + (defvar org-agenda-keymap (copy-keymap org-agenda-mode-map) + "Local keymap for agenda entries from Org-mode.") +@@ -20423,9 +20429,10 @@ + (setq matcher (org-make-tags-matcher match) + match (car matcher) matcher (cdr matcher)) + (org-prepare-agenda (concat "TAGS " match)) ++ (setq org-agenda-query-string match) + (setq org-agenda-redo-command + (list 'org-tags-view (list 'quote todo-only) +- (list 'if 'current-prefix-arg nil match))) ++ (list 'if 'current-prefix-arg nil 'org-agenda-query-string))) + (setq files (org-agenda-files) + rtnall nil) + (while (setq file (pop files)) +@@ -20461,7 +20468,7 @@ + (add-text-properties pos (1- (point)) (list 'face 'org-warning)) + (setq pos (point)) + (unless org-agenda-multi +- (insert "Press `C-u r' to search again with new search string\n")) ++ (insert "Press `C-u r' to enter new search string; use `/;\\=' to adjust interactively\n")) + (add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure))) + (when rtnall + (insert (org-finalize-agenda-entries rtnall) "\n")) +@@ -20471,6 +20478,275 @@ + (org-finalize-agenda) + (setq buffer-read-only t))) + ++;;; Agenda interactive query manipulation ++ ++(defcustom org-agenda-query-selection-single-key t ++ "Non-nil means, query manipulation exits after first change. ++When nil, you have to press RET to exit it. ++During query selection, you can toggle this flag with `C-c'. ++This variable can also have the value `expert'. In this case, the window ++displaying the tags menu is not even shown, until you press C-c again." ++ :group 'org-agenda ++ :type '(choice ++ (const :tag "No" nil) ++ (const :tag "Yes" t) ++ (const :tag "Expert" expert))) ++ ++(defun org-agenda-query-selection (current op table &optional todo-table) ++ "Fast query manipulation with single keys. ++CURRENT is the current query string, OP is the initial ++operator (one of \"+|-=\"), TABLE is an alist of tags and ++corresponding keys, possibly with grouping information. ++TODO-TABLE is a similar table with TODO keywords, should these ++have keys assigned to them. If the keys are nil, a-z are ++automatically assigned. Returns the new query string, or nil to ++not change the current one." ++ (let* ((fulltable (append table todo-table)) ++ (maxlen (apply 'max (mapcar ++ (lambda (x) ++ (if (stringp (car x)) (string-width (car x)) 0)) ++ fulltable))) ++ (fwidth (+ maxlen 3 1 3)) ++ (ncol (/ (- (window-width) 4) fwidth)) ++ (expert (eq org-agenda-query-selection-single-key 'expert)) ++ (exit-after-next org-agenda-query-selection-single-key) ++ (done-keywords org-done-keywords) ++ tbl char cnt e groups ingroup ++ tg c2 c c1 ntable rtn) ++ (save-window-excursion ++ (if expert ++ (set-buffer (get-buffer-create " *Org tags*")) ++ (delete-other-windows) ++ (split-window-vertically) ++ (org-switch-to-buffer-other-window (get-buffer-create " *Org tags*"))) ++ (erase-buffer) ++ (org-set-local 'org-done-keywords done-keywords) ++ (insert "Query: " current "\n") ++ (org-agenda-query-op-line op) ++ (insert "\n\n") ++ (org-fast-tag-show-exit exit-after-next) ++ (setq tbl fulltable char ?a cnt 0) ++ (while (setq e (pop tbl)) ++ (cond ++ ((equal e '(:startgroup)) ++ (push '() groups) (setq ingroup t) ++ (when (not (= cnt 0)) ++ (setq cnt 0) ++ (insert "\n")) ++ (insert "{ ")) ++ ((equal e '(:endgroup)) ++ (setq ingroup nil cnt 0) ++ (insert "}\n")) ++ (t ++ (setq tg (car e) c2 nil) ++ (if (cdr e) ++ (setq c (cdr e)) ++ ;; automatically assign a character. ++ (setq c1 (string-to-char ++ (downcase (substring ++ tg (if (= (string-to-char tg) ?@) 1 0))))) ++ (if (or (rassoc c1 ntable) (rassoc c1 table)) ++ (while (or (rassoc char ntable) (rassoc char table)) ++ (setq char (1+ char))) ++ (setq c2 c1)) ++ (setq c (or c2 char))) ++ (if ingroup (push tg (car groups))) ++ (setq tg (org-add-props tg nil 'face ++ (cond ++ ((not (assoc tg table)) ++ (org-get-todo-face tg)) ++ (t nil)))) ++ (if (and (= cnt 0) (not ingroup)) (insert " ")) ++ (insert "[" c "] " tg (make-string ++ (- fwidth 4 (length tg)) ?\ )) ++ (push (cons tg c) ntable) ++ (when (= (setq cnt (1+ cnt)) ncol) ++ (insert "\n") ++ (if ingroup (insert " ")) ++ (setq cnt 0))))) ++ (setq ntable (nreverse ntable)) ++ (insert "\n") ++ (goto-char (point-min)) ++ (if (and (not expert) (fboundp 'fit-window-to-buffer)) ++ (fit-window-to-buffer)) ++ (setq rtn ++ (catch 'exit ++ (while t ++ (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free%s%s" ++ (if groups " [!] no groups" " [!]groups") ++ (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) ++ (setq c (let ((inhibit-quit t)) (read-char-exclusive))) ++ (cond ++ ((= c ?\r) (throw 'exit t)) ++ ((= c ?!) ++ (setq groups (not groups)) ++ (goto-char (point-min)) ++ (while (re-search-forward "[{}]" nil t) (replace-match " "))) ++ ((= c ?\C-c) ++ (if (not expert) ++ (org-fast-tag-show-exit ++ (setq exit-after-next (not exit-after-next))) ++ (setq expert nil) ++ (delete-other-windows) ++ (split-window-vertically) ++ (org-switch-to-buffer-other-window " *Org tags*") ++ (and (fboundp 'fit-window-to-buffer) ++ (fit-window-to-buffer)))) ++ ((or (= c ?\C-g) ++ (and (= c ?q) (not (rassoc c ntable)))) ++ (setq quit-flag t)) ++ ((= c ?\ ) ++ (setq current "") ++ (if exit-after-next (setq exit-after-next 'now))) ++ ((= c ?\[) ; clear left ++ (org-agenda-query-decompose current) ++ (setq current (concat "/" (match-string 2 current))) ++ (if exit-after-next (setq exit-after-next 'now))) ++ ((= c ?\]) ; clear right ++ (org-agenda-query-decompose current) ++ (setq current (match-string 1 current)) ++ (if exit-after-next (setq exit-after-next 'now))) ++ ((= c ?\t) ++ (condition-case nil ++ (setq current (read-string "Query: " current)) ++ (quit)) ++ (if exit-after-next (setq exit-after-next 'now))) ++ ;; operators ++ ((or (= c ?/) (= c ?+)) (setq op "+")) ++ ((or (= c ?\;) (= c ?|)) (setq op "|")) ++ ((or (= c ?\\) (= c ?-)) (setq op "-")) ++ ((= c ?=) (setq op "=")) ++ ;; todos ++ ((setq e (rassoc c todo-table) tg (car e)) ++ (setq current (org-agenda-query-manip ++ current op groups 'todo tg)) ++ (if exit-after-next (setq exit-after-next 'now))) ++ ;; tags ++ ((setq e (rassoc c ntable) tg (car e)) ++ (setq current (org-agenda-query-manip ++ current op groups 'tag tg)) ++ (if exit-after-next (setq exit-after-next 'now)))) ++ (if (eq exit-after-next 'now) (throw 'exit t)) ++ (goto-char (point-min)) ++ (beginning-of-line 1) ++ (delete-region (point) (point-at-eol)) ++ (insert "Query: " current) ++ (beginning-of-line 2) ++ (delete-region (point) (point-at-eol)) ++ (org-agenda-query-op-line op) ++ (goto-char (point-min))))) ++ (if rtn current nil)))) ++ ++(defun org-agenda-query-op-line (op) ++ (insert "Operator: " ++ (org-agenda-query-op-entry (equal op "+") "/+" "and") ++ (org-agenda-query-op-entry (equal op "|") ";|" "or") ++ (org-agenda-query-op-entry (equal op "-") "\\-" "not") ++ (org-agenda-query-op-entry (equal op "=") "=" "clear"))) ++ ++(defun org-agenda-query-op-entry (matchp chars str) ++ (if matchp ++ (org-add-props (format "[%s %s] " chars (upcase str)) ++ nil 'face 'org-todo) ++ (format "[%s]%s " chars str))) ++ ++(defun org-agenda-query-decompose (current) ++ (string-match "\\([^/]*\\)/?\\(.*\\)" current)) ++ ++(defun org-agenda-query-clear (current prefix tag) ++ (if (string-match (concat prefix "\\b" (regexp-quote tag) "\\b") current) ++ (replace-match "" t t current) ++ current)) ++ ++(defun org-agenda-query-manip (current op groups kind tag) ++ "Apply an operator to a query string and a tag. ++CURRENT is the current query string, OP is the operator, GROUPS is a ++list of lists of tags that are mutually exclusive. KIND is 'tag for a ++regular tag, or 'todo for a TODO keyword, and TAG is the tag or ++keyword string." ++ ;; If this tag is already in query string, remove it. ++ (setq current (org-agenda-query-clear current "[-\\+&|]?" tag)) ++ (if (equal op "=") current ++ ;; When using AND, also remove mutually exclusive tags. ++ (if (equal op "+") ++ (loop for g in groups do ++ (if (member tag g) ++ (mapc (lambda (x) ++ (setq current ++ (org-agenda-query-clear current "\\+" x))) ++ g)))) ++ ;; Decompose current query into q1 (tags) and q2 (TODOs). ++ (org-agenda-query-decompose current) ++ (let* ((q1 (match-string 1 current)) ++ (q2 (match-string 2 current))) ++ (cond ++ ((eq kind 'tag) ++ (concat q1 op tag "/" q2)) ++ ;; It's a TODO; when using AND, drop all other TODOs. ++ ((equal op "+") ++ (concat q1 "/+" tag)) ++ (t ++ (concat q1 "/" q2 op tag)))))) ++ ++(defun org-agenda-query-global-todo-keys (&optional files) ++ "Return alist of all TODO keywords and their fast keys, in all FILES." ++ (let (alist) ++ (unless (and files (car files)) ++ (setq files (org-agenda-files))) ++ (save-excursion ++ (loop for f in files do ++ (set-buffer (find-file-noselect f)) ++ (loop for k in org-todo-key-alist do ++ (setq alist (org-agenda-query-merge-todo-key ++ alist k))))) ++ alist)) ++ ++(defun org-agenda-query-merge-todo-key (alist entry) ++ (let (e) ++ (cond ++ ;; if this is not a keyword (:startgroup, etc), ignore it ++ ((not (stringp (car entry)))) ++ ;; if keyword already exists, replace char if it's null ++ ((setq e (assoc (car entry) alist)) ++ (when (null (cdr e)) (setcdr e (cdr entry)))) ++ ;; if char already exists, prepend keyword but drop char ++ ((rassoc (cdr entry) alist) ++ (error "TRACE POSITION 2") ++ (setq alist (cons (cons (car entry) nil) alist))) ++ ;; else, prepend COPY of entry ++ (t ++ (setq alist (cons (cons (car entry) (cdr entry)) alist))))) ++ alist) ++ ++(defun org-agenda-query-generic-cmd (op) ++ "Activate query manipulation with OP as initial operator." ++ (let ((q (org-agenda-query-selection org-agenda-query-string op ++ org-tag-alist ++ (org-agenda-query-global-todo-keys)))) ++ (when q ++ (setq org-agenda-query-string q) ++ (org-agenda-redo)))) ++ ++(defun org-agenda-query-clear-cmd () ++ "Activate query manipulation, to clear a tag from the string." ++ (interactive) ++ (org-agenda-query-generic-cmd "=")) ++ ++(defun org-agenda-query-and-cmd () ++ "Activate query manipulation, initially using the AND (+) operator." ++ (interactive) ++ (org-agenda-query-generic-cmd "+")) ++ ++(defun org-agenda-query-or-cmd () ++ "Activate query manipulation, initially using the OR (|) operator." ++ (interactive) ++ (org-agenda-query-generic-cmd "|")) ++ ++(defun org-agenda-query-not-cmd () ++ "Activate query manipulation, initially using the NOT (-) operator." ++ (interactive) ++ (org-agenda-query-generic-cmd "-")) ++ + ;;; Agenda Finding stuck projects + + (defvar org-agenda-skip-regexp nil