# HG changeset patch # User Carsten Dominik # Date 1223792041 0 # Node ID 8339497a5b87e7372928b9b95002f5a2540281fd # Parent e1cc41b9282dd3e28818a7f973dd71882afd67f3 New files org-attach.el, org-list.el, org-plot.el. diff -r e1cc41b9282d -r 8339497a5b87 lisp/org/org-attach.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/org/org-attach.el Sun Oct 12 06:14:01 2008 +0000 @@ -0,0 +1,339 @@ +;;; org-attach.el --- Manage file attachments to org-mode tasks + +;; Copyright (C) 2008 Free Software Foundation, Inc. + +;; Author: John Wiegley +;; Keywords: org data task +;; Version: 6.09a + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; See the Org-mode manual for information on how to use it. +;; +;; Attachments are managed in a special directory called "data", which +;; lives in the directory given by `org-directory'. If this data +;; directory is initialized as a Git repository, then org-attach will +;; automatically commit changes when it sees them. +;; +;; Attachment directories are identified using a UUID generated for the +;; task which has the attachments. These are added as property to the +;; task when necessary, and should not be deleted or changed by the +;; user, ever. UUIDs are generated by a mechanism defined in the variable +;; `org-id-method'. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'org-id) +(require 'org) + +(defgroup org-attach nil + "Options concerning entry attachments in Org-mode." + :tag "Org Attach" + :group 'org) + +(defcustom org-attach-directory "data/" + "The directory where attachments are stored. +If this is a relative path, it will be interpreted relative to the directory +where the Org file lives." + :group 'org-attach + :type 'direcory) + +(defcustom org-attach-auto-tag "ATTACH" + "Tag that will be triggered automatically when an entry has an attachment." + :group 'org-attach + :type '(choice + (const :tag "None" nil) + (string :tag "Tag"))) + +(defcustom org-attach-file-list-property "Attachments" + "The property used to keep a list of attachment belonging to this entry. +This is not really needed, so you may set this to nil if you don't want it." + :group 'org-attach + :type '(choice + (const :tag "None" nil) + (string :tag "Tag"))) + +(defcustom org-attach-method 'cp + "The preferred method to attach a file. +Allowed values are: + +mv rename the file to move it into the attachment directory +cp copy the file +ln create a hard link. Note that this is not supported + on all systems, and then the result is not defined." + :group 'org-attach + :type '(choice + (const :tag "Copy" cp) + (const :tag "Move/Rename" mv) + (const :tag "Link" ln))) + +(defcustom org-attach-expert nil + "Non-nil means do not show the splash buffer with the attach dispatcher." + :group 'org-attach + :type 'boolean) + +;;;###autoload +(defun org-attach () + "The dispatcher for attachment commands. +Shows a list of commands and prompts for another key to execute a command." + (interactive) + (let (c marker) + (when (eq major-mode 'org-agenda-mode) + (setq marker (or (get-text-property (point) 'org-hd-marker) + (get-text-property (point) 'org-marker))) + (unless marker + (error "No task in current line"))) + (save-excursion + (when marker + (set-buffer (marker-buffer marker)) + (goto-char marker)) + (org-back-to-heading t) + (save-excursion + (save-window-excursion + (unless org-attach-expert + (with-output-to-temp-buffer "*Org Attach*" + (princ "Select an Attachment Command: + +a Select a file and attach it to the task, using `org-attach-method'. +c/m/l Attach a file using copy/move/link method. +n Create a new attachment, as an Emacs buffer. +z Synchronize the current task with its attachment + directory, in case you added attachments yourself. + +o Open current task's attachments. +O Like \"o\", but force opening in Emacs. +f Open current task's attachment directory. +F Like \"f\", but force using dired in Emacs. + +d Delete one attachment, you will be prompted for a file name. +D Delete all of a task's attachments. A safer way is + to open the directory in dired and delete from there."))) + (shrink-window-if-larger-than-buffer (get-buffer-window "*Org Attach*")) + (message "Select command: [acmlzoOfFdD]") + (setq c (read-char-exclusive)) + (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*")))) + (cond + ((memq c '(?a ?\C-a)) (call-interactively 'org-attach-attach)) + ((memq c '(?c ?\C-c)) + (let ((org-attach-method 'cp)) (call-interactively 'org-attach-attach))) + ((memq c '(?m ?\C-m)) + (let ((org-attach-method 'mv)) (call-interactively 'org-attach-attach))) + ((memq c '(?l ?\C-l)) + (let ((org-attach-method 'ln)) (call-interactively 'org-attach-attach))) + ((memq c '(?n ?\C-n)) (call-interactively 'org-attach-new)) + ((memq c '(?z ?\C-z)) (call-interactively 'org-attach-sync)) + ((memq c '(?o ?\C-o)) (call-interactively 'org-attach-open)) + ((eq c ?O) (call-interactively 'org-attach-open-in-emacs)) + ((memq c '(?f ?\C-f)) (call-interactively 'org-attach-reveal)) + ((memq c '(?F)) (call-interactively 'org-attach-reveal-in-emacs)) + ((memq c '(?d ?\C-d)) (call-interactively + 'org-attach-delete-one)) + ((eq c ?D) (call-interactively 'org-attach-delete-all)) + ((eq c ?q) (message "Abort")) + (t (error "No such attachment command %c" c)))))) + +(defun org-attach-dir (&optional create-if-not-exists-p) + "Return the directory associated with the current entry. +If the directory does not exist and CREATE-IF-NOT-EXISTS-P is non-nil, +the directory and the corresponding ID will be created." + (let ((uuid (org-id-get (point) create-if-not-exists-p))) + (when (or uuid create-if-not-exists-p) + (unless uuid + (let ((uuid-string (shell-command-to-string "uuidgen"))) + (setf uuid-string + (substring uuid-string 0 (1- (length uuid-string)))) + (org-entry-put (point) "ID" uuid-string) + (setf uuid uuid-string))) + (let ((attach-dir (expand-file-name + (format "%s/%s" + (substring uuid 0 2) + (substring uuid 2)) + (expand-file-name org-attach-directory)))) + (if (and create-if-not-exists-p + (not (file-directory-p attach-dir))) + (make-directory attach-dir t)) + (and (file-exists-p attach-dir) + attach-dir))))) + +(defun org-attach-commit () + "Commit changes to git if `org-attach-directory' is properly initialized. +This checks for the existence of a \".git\" directory in that directory." + (let ((dir (expand-file-name org-attach-directory))) + (if (file-exists-p (expand-file-name ".git" dir)) + (shell-command + (concat "(cd " dir "; " + " git add .; " + " git ls-files --deleted -z | xargs -0 git rm; " + " git commit -m 'Synchronized attachments')"))))) + +(defun org-attach-tag (&optional off) + "Turn the autotag on or (if OFF is set) off." + (when org-attach-auto-tag + (save-excursion + (org-back-to-heading t) + (org-toggle-tag org-attach-auto-tag (if off 'off 'on))))) + +(defun org-attach-untag () + "Turn the autotag off." + (org-attach-tag 'off)) + +(defun org-attach-attach (file &optional visit-dir method) + "Move/copy/link FILE into the attachment directory of the current task. +If VISIT-DIR is non-nil, visit the directory with dired. +METHOD may be `cp', `mv', or `ln', default taken from `org-attach-method'." + (interactive "fFile to keep as an attachment: \nP") + (setq method (or method org-attach-method)) + (let ((basename (file-name-nondirectory file))) + (when org-attach-file-list-property + (org-entry-add-to-multivalued-property + (point) org-attach-file-list-property basename)) + (let* ((attach-dir (org-attach-dir t)) + (fname (expand-file-name basename attach-dir))) + (cond + ((eq method 'mv) (rename-file file fname)) + ((eq method 'cp) (copy-file file fname)) + ((eq method 'ln) (add-name-to-file file fname))) + (org-attach-commit) + (org-attach-tag) + (if visit-dir + (dired attach-dir) + (message "File \"%s\" is now a task attachment." basename))))) + +(defun org-attach-attach-cp () + "Attach a file by copying it." + (interactive) + (let ((org-attach-method 'cp)) (call-interactively 'org-attach-attach))) +(defun org-attach-attach-mv () + "Attach a file by moving (renaming) it." + (interactive) + (let ((org-attach-method 'mv)) (call-interactively 'org-attach-attach))) +(defun org-attach-attach-ln () + "Attach a file by creating a hard link to it. +Beware that this does not work on systems that do not support hard links. +On some systems, this apparently does copy the file instead." + (interactive) + (let ((org-attach-method 'ln)) (call-interactively 'org-attach-attach))) + +(defun org-attach-new (file) + "Create a new attachment FILE for the current task. +The attachment is created as an Emacs buffer." + (interactive "sCreate attachment named: ") + (when org-attach-file-list-property + (org-entry-add-to-multivalued-property + (point) org-attach-file-list-property file)) + (let ((attach-dir (org-attach-dir t))) + (org-attach-tag) + (find-file (expand-file-name file attach-dir)) + (message "New attachment %s" file))) + +(defun org-attach-delete-one (&optional file) + "Delete a single attachment." + (interactive) + (let* ((attach-dir (org-attach-dir t)) + (files (org-attach-file-list attach-dir)) + (file (or file + (completing-read + "Delete attachment: " + (mapcar (lambda (f) + (list (file-name-nondirectory f))) + files))))) + (setq file (expand-file-name file attach-dir)) + (unless (file-exists-p file) + (error "No such attachment: %s" file)) + (delete-file file))) + +(defun org-attach-delete-all (&optional force) + "Delete all attachments from the current task. +This actually deletes the entire attachment directory. +A safer way is to open the directory in dired and delete from there." + (interactive "P") + (when org-attach-file-list-property + (org-entry-delete (point) org-attach-file-list-property)) + (let ((attach-dir (org-attach-dir))) + (when + (and attach-dir + (or force + (y-or-n-p "Are you sure you want to remove all attachments of this entry? "))) + (shell-command (format "rm -fr %s" attach-dir)) + (message "Attachment directory removed") + (org-attach-commit) + (org-attach-untag)))) + +(defun org-attach-sync () + "Synchronize the current tasks with its attachments. +This can be used after files have been added externally." + (interactive) + (org-attach-commit) + (when org-attach-file-list-property + (org-entry-delete (point) org-attach-file-list-property)) + (let ((attach-dir (org-attach-dir))) + (when attach-dir + (let ((files (org-attach-file-list attach-dir))) + (and files (org-attach-tag)) + (when org-attach-file-list-property + (dolist (file files) + (unless (string-match "^\\." file) + (org-entry-add-to-multivalued-property + (point) org-attach-file-list-property file)))))))) + +(defun org-attach-file-list (dir) + "Return a list of files in the attachment directory. +This ignores files starting with a \".\", and files ending in \"~\"." + (delq nil + (mapcar (lambda (x) (if (string-match "^\\." x) nil x)) + (directory-files dir nil "[^~]\\'")))) + +(defun org-attach-reveal () + "Show the attachment directory of the current task in dired." + (interactive) + (let ((attach-dir (org-attach-dir t))) + (org-open-file attach-dir))) + +(defun org-attach-reveal-in-emacs () + "Show the attachment directory of the current task. +This will attempt to use an external program to show the directory." + (interactive) + (let ((attach-dir (org-attach-dir t))) + (dired attach-dir))) + +(defun org-attach-open (&optional in-emacs) + "Open an attachment of the current task. +If there are more than one attachment, you will be prompted for the file name. +This command will open the file using the settings in `org-file-apps' +and in the system-specific variants of this variable. +If IN-EMACS is non-nil, force opening in Emacs." + (interactive "P") + (let* ((attach-dir (org-attach-dir t)) + (files (org-attach-file-list attach-dir)) + (file (if (= (length files) 1) + (car files) + (completing-read "Open attachment: " + (mapcar 'list files) nil t)))) + (org-open-file (expand-file-name file attach-dir) in-emacs))) + +(defun org-attach-open-in-emacs () + "Open attachment, force opening in Emacs. +See `org-attach-open'." + (interactive) + (org-attach-open 'in-emacs)) + +(provide 'org-attach) + +;;; org-attach.el ends here diff -r e1cc41b9282d -r 8339497a5b87 lisp/org/org-list.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/org/org-list.el Sun Oct 12 06:14:01 2008 +0000 @@ -0,0 +1,1042 @@ +;;; org-list.el --- Plain lists for Org-mode +;; +;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik +;; Bastien Guerry +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.09a +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the code dealing with plain lists in Org-mode. + +;;; Code: + +(require 'org-macs) +(require 'org-compat) + +(defvar org-blank-before-new-entry) +(defvar org-M-RET-may-split-line) + +(declare-function org-invisible-p "org" ()) +(declare-function org-on-heading-p "org" (&optional invisible-ok)) +(declare-function outline-next-heading "org" ()) +(declare-function outline-back-to-heading "org" (&optional invisible-ok)) +(declare-function org-back-to-heading "org" (&optional invisible-ok)) +(declare-function org-back-over-empty-lines "org" ()) +(declare-function org-skip-whitespace "org" ()) +(declare-function org-trim "org" (s)) +(declare-function org-get-indentation "org" (&optional line)) + +(defgroup org-plain-lists nil + "Options concerning plain lists in Org-mode." + :tag "Org Plain lists" + :group 'org-structure) + +(defcustom org-cycle-include-plain-lists nil + "Non-nil means, include plain lists into visibility cycling. +This means that during cycling, plain list items will *temporarily* be +interpreted as outline headlines with a level given by 1000+i where i is the +indentation of the bullet. In all other operations, plain list items are +not seen as headlines. For example, you cannot assign a TODO keyword to +such an item." + :group 'org-plain-lists + :type 'boolean) + +(defcustom org-plain-list-ordered-item-terminator t + "The character that makes a line with leading number an ordered list item. +Valid values are ?. and ?\). To get both terminators, use t. While +?. may look nicer, it creates the danger that a line with leading +number may be incorrectly interpreted as an item. ?\) therefore is +the safe choice." + :group 'org-plain-lists + :type '(choice (const :tag "dot like in \"2.\"" ?.) + (const :tag "paren like in \"2)\"" ?\)) + (const :tab "both" t))) + +(defcustom org-empty-line-terminates-plain-lists nil + "Non-nil means, an empty line ends all plain list levels. +When nil, empty lines are part of the preceeding item." + :group 'org-plain-lists + :type 'boolean) + +(defcustom org-auto-renumber-ordered-lists t + "Non-nil means, automatically renumber ordered plain lists. +Renumbering happens when the sequence have been changed with +\\[org-shiftmetaup] or \\[org-shiftmetadown]. After other editing commands, +use \\[org-ctrl-c-ctrl-c] to trigger renumbering." + :group 'org-plain-lists + :type 'boolean) + +(defcustom org-provide-checkbox-statistics t + "Non-nil means, update checkbox statistics after insert and toggle. +When this is set, checkbox statistics is updated each time you either insert +a new checkbox with \\[org-insert-todo-heading] or toggle a checkbox +with \\[org-ctrl-c-ctrl-c\\]." + :group 'org-plain-lists + :type 'boolean) + +(defcustom org-description-max-indent 20 + "Maximum indentation for the second line of a description list. +When the indentation would be larger than this, it will become +5 characters instead." + :group 'org-plain-lists + :type 'integer) + +(defvar org-list-beginning-re + "^\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) +\\(.*\\)$") + +(defcustom org-list-radio-list-templates + '((latex-mode "% BEGIN RECEIVE ORGLST %n +% END RECEIVE ORGLST %n +\\begin{comment} +#+ORGLST: SEND %n org-list-to-latex +| | | +\\end{comment}\n") + (texinfo-mode "@c BEGIN RECEIVE ORGLST %n +@c END RECEIVE ORGLST %n +@ignore +#+ORGLST: SEND %n org-list-to-texinfo +| | | +@end ignore\n") + (html-mode " + +\n")) + "Templates for radio lists in different major modes. +All occurrences of %n in a template will be replaced with the name of the +list, obtained by prompting the user." + :group 'org-plain-lists + :type '(repeat + (list (symbol :tag "Major mode") + (string :tag "Format")))) + +;;;; Plain list items, including checkboxes + +;;; Plain list items + +(defun org-at-item-p () + "Is point in a line starting a hand-formatted item?" + (let ((llt org-plain-list-ordered-item-terminator)) + (save-excursion + (goto-char (point-at-bol)) + (looking-at + (cond + ((eq llt t) "\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)") + ((= llt ?.) "\\([ \t]*\\([-+]\\|\\([0-9]+\\.\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)") + ((= llt ?\)) "\\([ \t]*\\([-+]\\|\\([0-9]+))\\)\\|[ \t]+\\*\\)\\( \\|$\\)") + (t (error "Invalid value of `org-plain-list-ordered-item-terminator'"))))))) + +(defun org-in-item-p () + "It the cursor inside a plain list item. +Does not have to be the first line." + (save-excursion + (condition-case nil + (progn + (org-beginning-of-item) + (org-at-item-p) + t) + (error nil)))) + +(defun org-insert-item (&optional checkbox) + "Insert a new item at the current level. +Return t when things worked, nil when we are not in an item." + (when (save-excursion + (condition-case nil + (progn + (org-beginning-of-item) + (org-at-item-p) + (if (org-invisible-p) (error "Invisible item")) + t) + (error nil))) + (let* ((bul (match-string 0)) + (descp (save-excursion (goto-char (match-beginning 0)) + (beginning-of-line 1) + (save-match-data + (looking-at "[ \t]*.*? ::")))) + (eow (save-excursion (beginning-of-line 1) (looking-at "[ \t]*") + (match-end 0))) + (blank (cdr (assq 'plain-list-item org-blank-before-new-entry))) + pos) + (if descp (setq checkbox nil)) + (cond + ((and (org-at-item-p) (<= (point) eow)) + ;; before the bullet + (beginning-of-line 1) + (open-line (if blank 2 1))) + ((<= (point) eow) + (beginning-of-line 1)) + (t + (unless (org-get-alist-option org-M-RET-may-split-line 'item) + (end-of-line 1) + (delete-horizontal-space)) + (newline (if blank 2 1)))) + (insert bul + (if checkbox "[ ]" "") + (if descp (concat (if checkbox " " "") + (read-string "Term: ") " :: ") "")) + (just-one-space) + (setq pos (point)) + (end-of-line 1) + (unless (= (point) pos) (just-one-space) (backward-delete-char 1))) + (org-maybe-renumber-ordered-list) + (and checkbox (org-update-checkbox-count-maybe)) + t)) + +;;; Checkboxes + +(defun org-at-item-checkbox-p () + "Is point at a line starting a plain-list item with a checklet?" + (and (org-at-item-p) + (save-excursion + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (looking-at "\\[[- X]\\]")))) + +(defun org-toggle-checkbox (&optional arg) + "Toggle the checkbox in the current line." + (interactive "P") + (catch 'exit + (let (beg end status (firstnew 'unknown)) + (cond + ((org-region-active-p) + (setq beg (region-beginning) end (region-end))) + ((org-on-heading-p) + (setq beg (point) end (save-excursion (outline-next-heading) (point)))) + ((org-at-item-checkbox-p) + (let ((pos (point))) + (replace-match + (cond (arg "[-]") + ((member (match-string 0) '("[ ]" "[-]")) "[X]") + (t "[ ]")) + t t) + (goto-char pos)) + (throw 'exit t)) + (t (error "Not at a checkbox or heading, and no active region"))) + (save-excursion + (goto-char beg) + (while (< (point) end) + (when (org-at-item-checkbox-p) + (setq status (equal (match-string 0) "[X]")) + (when (eq firstnew 'unknown) + (setq firstnew (not status))) + (replace-match + (if (if arg (not status) firstnew) "[X]" "[ ]") t t)) + (beginning-of-line 2))))) + (org-update-checkbox-count-maybe)) + +(defun org-update-checkbox-count-maybe () + "Update checkbox statistics unless turned off by user." + (when org-provide-checkbox-statistics + (org-update-checkbox-count))) + +(defun org-update-checkbox-count (&optional all) + "Update the checkbox statistics in the current section. +This will find all statistic cookies like [57%] and [6/12] and update them +with the current numbers. With optional prefix argument ALL, do this for +the whole buffer." + (interactive "P") + (save-excursion + (let* ((buffer-invisibility-spec (org-inhibit-invisibility)) ; Emacs 21 + (beg (condition-case nil + (progn (outline-back-to-heading) (point)) + (error (point-min)))) + (end (move-marker (make-marker) + (progn (outline-next-heading) (point)))) + (re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)") + (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[- X]\\]\\)") + (re-find (concat re "\\|" re-box)) + beg-cookie end-cookie is-percent c-on c-off lim + eline curr-ind next-ind continue-from startsearch + (cstat 0) + ) + (when all + (goto-char (point-min)) + (outline-next-heading) + (setq beg (point) end (point-max))) + (goto-char end) + ;; find each statistic cookie + (while (re-search-backward re-find beg t) + (setq beg-cookie (match-beginning 1) + end-cookie (match-end 1) + cstat (+ cstat (if end-cookie 1 0)) + startsearch (point-at-eol) + continue-from (point-at-bol) + is-percent (match-beginning 2) + lim (cond + ((org-on-heading-p) (outline-next-heading) (point)) + ((org-at-item-p) (org-end-of-item) (point)) + (t nil)) + c-on 0 + c-off 0) + (when lim + ;; find first checkbox for this cookie and gather + ;; statistics from all that are at this indentation level + (goto-char startsearch) + (if (re-search-forward re-box lim t) + (progn + (org-beginning-of-item) + (setq curr-ind (org-get-indentation)) + (setq next-ind curr-ind) + (while (and (bolp) (org-at-item-p) (= curr-ind next-ind)) + (save-excursion (end-of-line) (setq eline (point))) + (if (re-search-forward re-box eline t) + (if (member (match-string 2) '("[ ]" "[-]")) + (setq c-off (1+ c-off)) + (setq c-on (1+ c-on)) + ) + ) + (org-end-of-item) + (setq next-ind (org-get-indentation)) + ))) + (goto-char continue-from) + ;; update cookie + (when end-cookie + (delete-region beg-cookie end-cookie) + (goto-char beg-cookie) + (insert + (if is-percent + (format "[%d%%]" (/ (* 100 c-on) (max 1 (+ c-on c-off)))) + (format "[%d/%d]" c-on (+ c-on c-off))))) + ;; update items checkbox if it has one + (when (org-at-item-p) + (org-beginning-of-item) + (when (and (> (+ c-on c-off) 0) + (re-search-forward re-box (point-at-eol) t)) + (setq beg-cookie (match-beginning 2) + end-cookie (match-end 2)) + (delete-region beg-cookie end-cookie) + (goto-char beg-cookie) + (cond ((= c-off 0) (insert "[X]")) + ((= c-on 0) (insert "[ ]")) + (t (insert "[-]"))) + ))) + (goto-char continue-from)) + (when (interactive-p) + (message "Checkbox satistics updated %s (%d places)" + (if all "in entire file" "in current outline entry") cstat))))) + +(defun org-get-checkbox-statistics-face () + "Select the face for checkbox statistics. +The face will be `org-done' when all relevant boxes are checked. Otherwise +it will be `org-todo'." + (if (match-end 1) + (if (equal (match-string 1) "100%") 'org-done 'org-todo) + (if (and (> (match-end 2) (match-beginning 2)) + (equal (match-string 2) (match-string 3))) + 'org-done + 'org-todo))) + +(defun org-beginning-of-item () + "Go to the beginning of the current hand-formatted item. +If the cursor is not in an item, throw an error." + (interactive) + (let ((pos (point)) + (limit (save-excursion + (condition-case nil + (progn + (org-back-to-heading) + (beginning-of-line 2) (point)) + (error (point-min))))) + (ind-empty (if org-empty-line-terminates-plain-lists 0 10000)) + ind ind1) + (if (org-at-item-p) + (beginning-of-line 1) + (beginning-of-line 1) + (skip-chars-forward " \t") + (setq ind (current-column)) + (if (catch 'exit + (while t + (beginning-of-line 0) + (if (or (bobp) (< (point) limit)) (throw 'exit nil)) + + (if (looking-at "[ \t]*$") + (setq ind1 ind-empty) + (skip-chars-forward " \t") + (setq ind1 (current-column))) + (if (< ind1 ind) + (progn (beginning-of-line 1) (throw 'exit (org-at-item-p)))))) + nil + (goto-char pos) + (error "Not in an item"))))) + +(defun org-end-of-item () + "Go to the end of the current hand-formatted item. +If the cursor is not in an item, throw an error." + (interactive) + (let* ((pos (point)) + ind1 + (ind-empty (if org-empty-line-terminates-plain-lists 0 10000)) + (limit (save-excursion (outline-next-heading) (point))) + (ind (save-excursion + (org-beginning-of-item) + (skip-chars-forward " \t") + (current-column))) + (end (catch 'exit + (while t + (beginning-of-line 2) + (if (eobp) (throw 'exit (point))) + (if (>= (point) limit) (throw 'exit (point-at-bol))) + (if (looking-at "[ \t]*$") + (setq ind1 ind-empty) + (skip-chars-forward " \t") + (setq ind1 (current-column))) + (if (<= ind1 ind) + (throw 'exit (point-at-bol))))))) + (if end + (goto-char end) + (goto-char pos) + (error "Not in an item")))) + +(defun org-next-item () + "Move to the beginning of the next item in the current plain list. +Error if not at a plain list, or if this is the last item in the list." + (interactive) + (let (ind ind1 (pos (point))) + (org-beginning-of-item) + (setq ind (org-get-indentation)) + (org-end-of-item) + (setq ind1 (org-get-indentation)) + (unless (and (org-at-item-p) (= ind ind1)) + (goto-char pos) + (error "On last item")))) + +(defun org-previous-item () + "Move to the beginning of the previous item in the current plain list. +Error if not at a plain list, or if this is the first item in the list." + (interactive) + (let (beg ind ind1 (pos (point))) + (org-beginning-of-item) + (setq beg (point)) + (setq ind (org-get-indentation)) + (goto-char beg) + (catch 'exit + (while t + (beginning-of-line 0) + (if (looking-at "[ \t]*$") + nil + (if (<= (setq ind1 (org-get-indentation)) ind) + (throw 'exit t))))) + (condition-case nil + (if (or (not (org-at-item-p)) + (< ind1 (1- ind))) + (error "") + (org-beginning-of-item)) + (error (goto-char pos) + (error "On first item"))))) + +(defun org-first-list-item-p () + "Is this heading the item in a plain list?" + (unless (org-at-item-p) + (error "Not at a plain list item")) + (org-beginning-of-item) + (= (point) (save-excursion (org-beginning-of-item-list)))) + +(defun org-move-item-down () + "Move the plain list item at point down, i.e. swap with following item. +Subitems (items with larger indentation) are considered part of the item, +so this really moves item trees." + (interactive) + (let ((col (current-column)) + (pos (point)) + beg beg0 end end0 ind ind1 txt ne-end ne-beg) + (org-beginning-of-item) + (setq beg0 (point)) + (save-excursion + (setq ne-beg (org-back-over-empty-lines)) + (setq beg (point))) + (goto-char beg0) + (setq ind (org-get-indentation)) + (org-end-of-item) + (setq end0 (point)) + (setq ind1 (org-get-indentation)) + (setq ne-end (org-back-over-empty-lines)) + (setq end (point)) + (goto-char beg0) + (when (and (org-first-list-item-p) (< ne-end ne-beg)) + ;; include less whitespace + (save-excursion + (goto-char beg) + (forward-line (- ne-beg ne-end)) + (setq beg (point)))) + (goto-char end0) + (if (and (org-at-item-p) (= ind ind1)) + (progn + (org-end-of-item) + (org-back-over-empty-lines) + (setq txt (buffer-substring beg end)) + (save-excursion + (delete-region beg end)) + (setq pos (point)) + (insert txt) + (goto-char pos) (org-skip-whitespace) + (org-maybe-renumber-ordered-list) + (move-to-column col)) + (goto-char pos) + (move-to-column col) + (error "Cannot move this item further down")))) + +(defun org-move-item-up (arg) + "Move the plain list item at point up, i.e. swap with previous item. +Subitems (items with larger indentation) are considered part of the item, +so this really moves item trees." + (interactive "p") + (let ((col (current-column)) (pos (point)) + beg beg0 end ind ind1 txt + ne-beg ne-ins ins-end) + (org-beginning-of-item) + (setq beg0 (point)) + (setq ind (org-get-indentation)) + (save-excursion + (setq ne-beg (org-back-over-empty-lines)) + (setq beg (point))) + (goto-char beg0) + (org-end-of-item) + (org-back-over-empty-lines) + (setq end (point)) + (goto-char beg0) + (catch 'exit + (while t + (beginning-of-line 0) + (if (looking-at "[ \t]*$") + (if org-empty-line-terminates-plain-lists + (progn + (goto-char pos) + (error "Cannot move this item further up")) + nil) + (if (<= (setq ind1 (org-get-indentation)) ind) + (throw 'exit t))))) + (condition-case nil + (org-beginning-of-item) + (error (goto-char beg0) + (move-to-column col) + (error "Cannot move this item further up"))) + (setq ind1 (org-get-indentation)) + (if (and (org-at-item-p) (= ind ind1)) + (progn + (setq ne-ins (org-back-over-empty-lines)) + (setq txt (buffer-substring beg end)) + (save-excursion + (delete-region beg end)) + (setq pos (point)) + (insert txt) + (setq ins-end (point)) + (goto-char pos) (org-skip-whitespace) + + (when (and (org-first-list-item-p) (> ne-ins ne-beg)) + ;; Move whitespace back to beginning + (save-excursion + (goto-char ins-end) + (let ((kill-whole-line t)) + (kill-line (- ne-ins ne-beg)) (point))) + (insert (make-string (- ne-ins ne-beg) ?\n))) + + (org-maybe-renumber-ordered-list) + (move-to-column col)) + (goto-char pos) + (move-to-column col) + (error "Cannot move this item further up")))) + +(defun org-maybe-renumber-ordered-list () + "Renumber the ordered list at point if setup allows it. +This tests the user option `org-auto-renumber-ordered-lists' before +doing the renumbering." + (interactive) + (when (and org-auto-renumber-ordered-lists + (org-at-item-p)) + (if (match-beginning 3) + (org-renumber-ordered-list 1) + (org-fix-bullet-type)))) + +(defun org-maybe-renumber-ordered-list-safe () + (condition-case nil + (save-excursion + (org-maybe-renumber-ordered-list)) + (error nil))) + +(defun org-cycle-list-bullet (&optional which) + "Cycle through the different itemize/enumerate bullets. +This cycle the entire list level through the sequence: + + `-' -> `+' -> `*' -> `1.' -> `1)' + +If WHICH is a string, use that as the new bullet. If WHICH is an integer, +0 meand `-', 1 means `+' etc." + (interactive "P") + (org-preserve-lc + (org-beginning-of-item-list) + (org-at-item-p) + (beginning-of-line 1) + (let ((current (match-string 0)) + (prevp (eq which 'previous)) + new) + (setq new (cond + ((and (numberp which) + (nth (1- which) '("-" "+" "*" "1." "1)")))) + ((string-match "-" current) (if prevp "1)" "+")) + ((string-match "\\+" current) + (if prevp "-" (if (looking-at "\\S-") "1." "*"))) + ((string-match "\\*" current) (if prevp "+" "1.")) + ((string-match "\\." current) (if prevp "*" "1)")) + ((string-match ")" current) (if prevp "1." "-")) + (t (error "This should not happen")))) + (and (looking-at "\\([ \t]*\\)\\S-+") (replace-match (concat "\\1" new))) + (org-fix-bullet-type) + (org-maybe-renumber-ordered-list)))) + +(defun org-get-string-indentation (s) + "What indentation has S due to SPACE and TAB at the beginning of the string?" + (let ((n -1) (i 0) (w tab-width) c) + (catch 'exit + (while (< (setq n (1+ n)) (length s)) + (setq c (aref s n)) + (cond ((= c ?\ ) (setq i (1+ i))) + ((= c ?\t) (setq i (* (/ (+ w i) w) w))) + (t (throw 'exit t))))) + i)) + +(defun org-renumber-ordered-list (arg) + "Renumber an ordered plain list. +Cursor needs to be in the first line of an item, the line that starts +with something like \"1.\" or \"2)\"." + (interactive "p") + (unless (and (org-at-item-p) + (match-beginning 3)) + (error "This is not an ordered list")) + (let ((line (org-current-line)) + (col (current-column)) + (ind (org-get-string-indentation + (buffer-substring (point-at-bol) (match-beginning 3)))) + ;; (term (substring (match-string 3) -1)) + ind1 (n (1- arg)) + fmt bobp) + ;; find where this list begins + (org-beginning-of-item-list) + (setq bobp (bobp)) + (looking-at "[ \t]*[0-9]+\\([.)]\\)") + (setq fmt (concat "%d" (match-string 1))) + (beginning-of-line 0) + ;; walk forward and replace these numbers + (catch 'exit + (while t + (catch 'next + (if bobp (setq bobp nil) (beginning-of-line 2)) + (if (eobp) (throw 'exit nil)) + (if (looking-at "[ \t]*$") (throw 'next nil)) + (skip-chars-forward " \t") (setq ind1 (current-column)) + (if (> ind1 ind) (throw 'next t)) + (if (< ind1 ind) (throw 'exit t)) + (if (not (org-at-item-p)) (throw 'exit nil)) + (delete-region (match-beginning 2) (match-end 2)) + (goto-char (match-beginning 2)) + (insert (format fmt (setq n (1+ n))))))) + (goto-line line) + (org-move-to-column col))) + +(defun org-fix-bullet-type () + "Make sure all items in this list have the same bullet as the firsst item." + (interactive) + (unless (org-at-item-p) (error "This is not a list")) + (let ((line (org-current-line)) + (col (current-column)) + (ind (current-indentation)) + ind1 bullet) + ;; find where this list begins + (org-beginning-of-item-list) + (beginning-of-line 1) + ;; find out what the bullet type is + (looking-at "[ \t]*\\(\\S-+\\)") + (setq bullet (match-string 1)) + ;; walk forward and replace these numbers + (beginning-of-line 0) + (catch 'exit + (while t + (catch 'next + (beginning-of-line 2) + (if (eobp) (throw 'exit nil)) + (if (looking-at "[ \t]*$") (throw 'next nil)) + (skip-chars-forward " \t") (setq ind1 (current-column)) + (if (> ind1 ind) (throw 'next t)) + (if (< ind1 ind) (throw 'exit t)) + (if (not (org-at-item-p)) (throw 'exit nil)) + (skip-chars-forward " \t") + (looking-at "\\S-+") + (replace-match bullet)))) + (goto-line line) + (org-move-to-column col) + (if (string-match "[0-9]" bullet) + (org-renumber-ordered-list 1)))) + +(defun org-beginning-of-item-list () + "Go to the beginning of the current item list. +I.e. to the first item in this list." + (interactive) + (org-beginning-of-item) + (let ((pos (point-at-bol)) + (ind (org-get-indentation)) + ind1) + ;; find where this list begins + (catch 'exit + (while t + (catch 'next + (beginning-of-line 0) + (if (looking-at "[ \t]*$") + (throw (if (bobp) 'exit 'next) t)) + (skip-chars-forward " \t") (setq ind1 (current-column)) + (if (or (< ind1 ind) + (and (= ind1 ind) + (not (org-at-item-p))) + (and (= (point-at-bol) (point-min)) + (setq pos (point-min)))) + (throw 'exit t) + (when (org-at-item-p) (setq pos (point-at-bol))))))) + (goto-char pos))) + + +(defun org-end-of-item-list () + "Go to the end of the current item list. +I.e. to the text after the last item." + (interactive) + (org-beginning-of-item) + (let ((pos (point-at-bol)) + (ind (org-get-indentation)) + ind1) + ;; find where this list begins + (catch 'exit + (while t + (catch 'next + (beginning-of-line 2) + (if (looking-at "[ \t]*$") + (throw (if (eobp) 'exit 'next) t)) + (skip-chars-forward " \t") (setq ind1 (current-column)) + (if (or (< ind1 ind) + (and (= ind1 ind) + (not (org-at-item-p))) + (eobp)) + (progn + (setq pos (point-at-bol)) + (throw 'exit t)))))) + (goto-char pos))) + + +(defvar org-last-indent-begin-marker (make-marker)) +(defvar org-last-indent-end-marker (make-marker)) + +(defun org-outdent-item (arg) + "Outdent a local list item." + (interactive "p") + (org-indent-item (- arg))) + +(defun org-indent-item (arg) + "Indent a local list item." + (interactive "p") + (unless (org-at-item-p) + (error "Not on an item")) + (save-excursion + (let (beg end ind ind1 tmp delta ind-down ind-up) + (if (memq last-command '(org-shiftmetaright org-shiftmetaleft)) + (setq beg org-last-indent-begin-marker + end org-last-indent-end-marker) + (org-beginning-of-item) + (setq beg (move-marker org-last-indent-begin-marker (point))) + (org-end-of-item) + (setq end (move-marker org-last-indent-end-marker (point)))) + (goto-char beg) + (setq tmp (org-item-indent-positions) + ind (car tmp) + ind-down (nth 2 tmp) + ind-up (nth 1 tmp) + delta (if (> arg 0) + (if ind-down (- ind-down ind) 2) + (if ind-up (- ind-up ind) -2))) + (if (< (+ delta ind) 0) (error "Cannot outdent beyond margin")) + (while (< (point) end) + (beginning-of-line 1) + (skip-chars-forward " \t") (setq ind1 (current-column)) + (delete-region (point-at-bol) (point)) + (or (eolp) (org-indent-to-column (+ ind1 delta))) + (beginning-of-line 2)))) + (org-fix-bullet-type) + (org-maybe-renumber-ordered-list-safe) + (save-excursion + (beginning-of-line 0) + (condition-case nil (org-beginning-of-item) (error nil)) + (org-maybe-renumber-ordered-list-safe))) + +(defun org-item-indent-positions () + "Return indentation for plain list items. +This returns a list with three values: The current indentation, the +parent indentation and the indentation a child should habe. +Assumes cursor in item line." + (let* ((bolpos (point-at-bol)) + (ind (org-get-indentation)) + ind-down ind-up pos) + (save-excursion + (org-beginning-of-item-list) + (skip-chars-backward "\n\r \t") + (when (org-in-item-p) + (org-beginning-of-item) + (setq ind-up (org-get-indentation)))) + (setq pos (point)) + (save-excursion + (cond + ((and (condition-case nil (progn (org-previous-item) t) + (error nil)) + (or (forward-char 1) t) + (re-search-forward "^\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)" bolpos t)) + (setq ind-down (org-get-indentation))) + ((and (goto-char pos) + (org-at-item-p)) + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (setq ind-down (current-column))))) + (list ind ind-up ind-down))) + + +;;; Send and receive lists + +(defun org-list-parse-list (&optional delete) + "Parse the list at point and maybe DELETE it. +Return a list containing first level items as strings and +sublevels as a list of strings." + (let* ((item-beginning (org-list-item-beginning)) + (start (car item-beginning)) + (end (org-list-end (cdr item-beginning))) + output itemsep ltype) + (while (re-search-forward org-list-beginning-re end t) + (goto-char (match-beginning 3)) + (save-match-data + (cond ((string-match "[0-9]" (match-string 2)) + (setq itemsep "[0-9]+\\(?:\\.\\|)\\)" + ltype 'ordered)) + ((string-match "^.*::" (match-string 0)) + (setq itemsep "[-+]" ltype 'descriptive)) + (t (setq itemsep "[-+]" ltype 'unordered)))) + (let* ((indent1 (match-string 1)) + (nextitem (save-excursion + (save-match-data + (or (and (re-search-forward + (concat "^" indent1 itemsep " *?") end t) + (match-beginning 0)) end)))) + (item (buffer-substring + (point) + (or (and (re-search-forward + org-list-beginning-re end t) + (goto-char (match-beginning 0))) + (goto-char end)))) + (nextindent (match-string 1)) + (item (org-trim item)) + (item (if (string-match "^\\[.+\\]" item) + (replace-match "\\\\texttt{\\&}" + t nil item) item))) + (push item output) + (when (> (length nextindent) + (length indent1)) + (narrow-to-region (point) nextitem) + (push (org-list-parse-list) output) + (widen)))) + (when delete (delete-region start end)) + (setq output (nreverse output)) + (push ltype output))) + +(defun org-list-item-beginning () + "Find the beginning of the list item. +Return a cons which car is the beginning position of the item and +cdr is the indentation string." + (save-excursion + (if (not (or (looking-at org-list-beginning-re) + (re-search-backward + org-list-beginning-re nil t))) + (progn (goto-char (point-min)) (point)) + (cons (match-beginning 0) (match-string 1))))) + +(defun org-list-end (indent) + "Return the position of the end of the list. +INDENT is the indentation of the list." + (save-excursion + (catch 'exit + (while (or (looking-at org-list-beginning-re) + (looking-at (concat "^" indent "[ \t]+\\|^$"))) + (if (eq (point) (point-max)) + (throw 'exit (point-max))) + (forward-line 1))) (point))) + +(defun org-list-insert-radio-list () + "Insert a radio list template appropriate for this major mode." + (interactive) + (let* ((e (assq major-mode org-list-radio-list-templates)) + (txt (nth 1 e)) + name pos) + (unless e (error "No radio list setup defined for %s" major-mode)) + (setq name (read-string "List name: ")) + (while (string-match "%n" txt) + (setq txt (replace-match name t t txt))) + (or (bolp) (insert "\n")) + (setq pos (point)) + (insert txt) + (goto-char pos))) + +(defun org-list-send-list (&optional maybe) + "Send a tranformed version of this list to the receiver position. +With argument MAYBE, fail quietly if no transformation is defined for +this list." + (interactive) + (catch 'exit + (unless (org-at-item-p) (error "Not at a list")) + (save-excursion + (goto-char (car (org-list-item-beginning))) + (beginning-of-line 0) + (unless (looking-at "#\\+ORGLST: *SEND +\\([a-zA-Z0-9_]+\\) +\\([^ \t\r\n]+\\)\\( +.*\\)?") + (if maybe + (throw 'exit nil) + (error "Don't know how to transform this list")))) + (let* ((name (match-string 1)) + (item-beginning (org-list-item-beginning)) + (transform (intern (match-string 2))) + (txt (buffer-substring-no-properties + (car item-beginning) + (org-list-end (cdr item-beginning)))) + (list (org-list-parse-list)) + beg) + (unless (fboundp transform) + (error "No such transformation function %s" transform)) + (setq txt (funcall transform list)) + ;; Find the insertion place + (save-excursion + (goto-char (point-min)) + (unless (re-search-forward + (concat "BEGIN RECEIVE ORGLST +" name "\\([ \t]\\|$\\)") nil t) + (error "Don't know where to insert translated list")) + (goto-char (match-beginning 0)) + (beginning-of-line 2) + (setq beg (point)) + (unless (re-search-forward (concat "END RECEIVE ORGLST +" name) nil t) + (error "Cannot find end of insertion region")) + (beginning-of-line 1) + (delete-region beg (point)) + (goto-char beg) + (insert txt "\n")) + (message "List converted and installed at receiver location")))) + +(defun org-list-to-generic (list params) + "Convert a LIST parsed through `org-list-parse-list' to other formats. + +Valid parameters PARAMS are + +:ustart String to start an unordered list +:uend String to end an unordered list + +:ostart String to start an ordered list +:oend String to end an ordered list + +:dstart String to start a descriptive list +:dend String to end a descriptive list +:dtstart String to start a descriptive term +:dtend String to end a descriptive term +:ddstart String to start a description +:ddend String to end a description + +:splice When set to t, return only list body lines, don't wrap + them into :[u/o]start and :[u/o]end. Default is nil. + +:istart String to start a list item +:iend String to end a list item +:isep String to separate items +:lsep String to separate sublists" + (interactive) + (let* ((p params) sublist + (splicep (plist-get p :splice)) + (ostart (plist-get p :ostart)) + (oend (plist-get p :oend)) + (ustart (plist-get p :ustart)) + (uend (plist-get p :uend)) + (dstart (plist-get p :dstart)) + (dend (plist-get p :dend)) + (dtstart (plist-get p :dtstart)) + (dtend (plist-get p :dtend)) + (ddstart (plist-get p :ddstart)) + (ddend (plist-get p :ddend)) + (istart (plist-get p :istart)) + (iend (plist-get p :iend)) + (isep (plist-get p :isep)) + (lsep (plist-get p :lsep))) + (let ((wrapper + (cond ((eq (car list) 'ordered) + (concat ostart "\n%s" oend "\n")) + ((eq (car list) 'unordered) + (concat ustart "\n%s" uend "\n")) + ((eq (car list) 'descriptive) + (concat dstart "\n%s" dend "\n")))) + rtn term defstart defend) + (while (setq sublist (pop list)) + (cond ((symbolp sublist) nil) + ((stringp sublist) + (when (string-match "^\\(.*\\) ::" sublist) + (setq term (org-trim (format (concat dtstart "%s" dtend) + (match-string 1 sublist)))) + (setq sublist (substring sublist (1+ (length term))))) + (setq rtn (concat rtn istart term ddstart + sublist ddend iend isep))) + (t (setq rtn (concat rtn ;; previous list + lsep ;; list separator + (org-list-to-generic sublist p) + lsep ;; list separator + ))))) + (format wrapper rtn)))) + +(defun org-list-to-latex (list) + "Convert LIST into a LaTeX list." + (org-list-to-generic + list '(:splicep nil :ostart "\\begin{enumerate}" :oend "\\end{enumerate}" + :ustart "\\begin{itemize}" :uend "\\end{itemize}" + :dstart "\\begin{description}" :dend "\\end{description}" + :dtstart "[" :dtend "]" + :ddstart "" :ddend "" + :istart "\\item " :iend "" + :isep "\n" :lsep "\n"))) + +(defun org-list-to-html (list) + "Convert LIST into a HTML list." + (org-list-to-generic + list '(:splicep nil :ostart "
    " :oend "
" + :ustart "
    " :uend "
" + :dstart "
" :dend "
" + :dtstart "
" :dtend "
" + :ddstart "
" :ddend "
" + :istart "
  • " :iend "
  • " + :isep "\n" :lsep "\n"))) + +(defun org-list-to-texinfo (list) + "Convert LIST into a Texinfo list." + (org-list-to-generic + list '(:splicep nil :ostart "@itemize @minus" :oend "@end itemize" + :ustart "@enumerate" :uend "@end enumerate" + :dstart "@table" :dend "@end table" + :dtstart "@item " :dtend "\n" + :ddstart "" :ddend "" + :istart "@item\n" :iend "" + :isep "\n" :lsep "\n"))) + +(provide 'org-list) + +;;; org-list.el ends here diff -r e1cc41b9282d -r 8339497a5b87 lisp/org/org-plot.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/org/org-plot.el Sun Oct 12 06:14:01 2008 +0000 @@ -0,0 +1,314 @@ +;;; org-plot.el --- Support for plotting from Org-mode + +;; Copyright (C) 2008 Free Software Foundation, Inc. +;; +;; Author: Eric Schulte +;; Keywords: tables, plotting +;; Homepage: http://orgmode.org +;; Version: 6.06b +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Borrows ideas and a couple of lines of code from org-exp.el. + +;; Thanks to the org-mode mailing list for testing and implementation +;; and feature suggestions + +;;; Code: +(require 'org) +(require 'org-exp) +(require 'org-table) +(eval-and-compile + (require 'cl)) + +(declare-function gnuplot-delchar-or-maybe-eof "ext:gnuplot" (arg)) +(declare-function gnuplot-mode "ext:gnuplot" ()) +(declare-function gnuplot-send-buffer-to-gnuplot "ext:gnuplot" ()) + +(defvar org-plot/gnuplot-default-options + '((:plot-type . 2d) + (:with . lines) + (:ind . 0)) + "Default options to gnuplot used by `org-plot/gnuplot'") + +(defun org-plot/add-options-to-plist (p options) + "Parse an OPTIONS line and set values in the property list P. +Returns the resulting property list." + (let (o) + (when options + (let ((op '(("type" . :plot-type) + ("script" . :script) + ("line" . :line) + ("set" . :set) + ("title" . :title) + ("ind" . :ind) + ("deps" . :deps) + ("with" . :with) + ("file" . :file) + ("labels" . :labels) + ("map" . :map))) + (multiples '("set" "line")) + (regexp ":\\([\"][^\"]+?[\"]\\|[(][^)]+?[)]\\|[^ \t\n\r;,.]*\\)") + (start 0) + o) + (while (setq o (pop op)) + (if (member (car o) multiples) ;; keys with multiple values + (while (string-match + (concat (regexp-quote (car o)) regexp) + options start) + (setq start (match-end 0)) + (setq p (plist-put p (cdr o) + (cons (car (read-from-string + (match-string 1 options))) + (plist-get p (cdr o))))) + p) + (if (string-match (concat (regexp-quote (car o)) regexp) + options) + (setq p (plist-put p (cdr o) + (car (read-from-string + (match-string 1 options))))))))))) + p) + +(defun org-plot/goto-nearest-table () + "Move the point forward to the beginning of nearest table. +Return value is the point at the beginning of the table." + (interactive) (move-beginning-of-line 1) + (while (not (or (org-at-table-p) (< 0 (forward-line 1))))) + (goto-char (org-table-begin))) + +(defun org-plot/collect-options (&optional params) + "Collect options from an org-plot '#+Plot:' line. +Accepts an optional property list PARAMS, to which the options +will be added. Returns the resulting property list." + (interactive) + (let ((line (thing-at-point 'line))) + (if (string-match "#\\+PLOT: +\\(.*\\)$" line) + (org-plot/add-options-to-plist params (match-string 1 line)) + params))) + +(defun org-plot-quote-tsv-field (s) + "Quote field S for export to gnuplot." + (if (string-match org-table-number-regexp s) s + (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\""))) + +(defun org-plot/gnuplot-to-data (table data-file params) + "Export TABLE to DATA-FILE in a format readable by gnuplot. +Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE." + (with-temp-file + data-file (insert (orgtbl-to-generic + table + (org-combine-plists + '(:sep "\t" :fmt org-plot-quote-tsv-field) + params)))) + nil) + +(defun org-plot/gnuplot-to-grid-data (table data-file params) + "Export the data in TABLE to DATA-FILE for gnuplot. +This means, in a format appropriate for grid plotting by gnuplot. +PARAMS specifies which columns of TABLE should be plotted as independant +and dependant variables." + (interactive) + (let* ((ind (- (plist-get params :ind) 1)) + (deps (if (plist-member params :deps) + (mapcar (lambda (val) (- val 1)) (plist-get params :deps)) + (let (collector) + (dotimes (col (length (first table))) + (setf collector (cons col collector))) + collector))) + row-vals (counter 0)) + (when (>= ind 0) ;; collect values of ind col + (setf row-vals (mapcar (lambda (row) (setf counter (+ 1 counter)) + (cons counter (nth ind row))) table))) + (when (or deps (>= ind 0)) ;; remove non-plotting columns + (setf deps (delq ind deps)) + (setf table (mapcar (lambda (row) + (dotimes (col (length row)) + (unless (memq col deps) + (setf (nth col row) nil))) + (delq nil row)) + table))) + ;; write table to gnuplot grid datafile format + (with-temp-file data-file + (let ((num-rows (length table)) (num-cols (length (first table))) + front-edge back-edge) + (flet ((gnuplot-row (col row value) + (setf col (+ 1 col)) (setf row (+ 1 row)) + (format "%f %f %f\n%f %f %f\n" + col (- row 0.5) value ;; lower edge + col (+ row 0.5) value))) ;; upper edge + (dotimes (col num-cols) + (dotimes (row num-rows) + (setf back-edge + (concat back-edge + (gnuplot-row (- col 1) row (string-to-number + (nth col (nth row table)))))) + (setf front-edge + (concat front-edge + (gnuplot-row col row (string-to-number + (nth col (nth row table))))))) + ;; only insert once per row + (insert back-edge) (insert "\n") ;; back edge + (insert front-edge) (insert "\n") ;; front edge + (setf back-edge "") (setf front-edge ""))))) + row-vals)) + +(defun org-plot/gnuplot-script (data-file num-cols params) + "Write a gnuplot script to DATA-FILE respecting the options set in PARAMS. +NUM-COLS controls the number of columns plotted in a 2-d plot." + (let* ((type (plist-get params :plot-type)) + (with (if (equal type 'grid) + 'pm3d + (plist-get params :with))) + (sets (plist-get params :set)) + (lines (plist-get params :line)) + (map (plist-get params :map)) + (title (plist-get params :title)) + (file (plist-get params :file)) + (ind (plist-get params :ind)) + (text-ind (plist-get params :textind)) + (deps (if (plist-member params :deps) (plist-get params :deps))) + (col-labels (plist-get params :labels)) + (x-labels (plist-get params :xlabels)) + (y-labels (plist-get params :ylabels)) + (plot-str "'%s' using %s%d%s with %s title '%s'") + (plot-cmd (case type + ('2d "plot") + ('3d "splot") + ('grid "splot"))) + (script "reset") plot-lines) + (flet ((add-to-script (line) (setf script (format "%s\n%s" script line)))) + (when file ;; output file + (add-to-script (format "set term %s" (file-name-extension file))) + (add-to-script (format "set output '%s'" file))) + (case type ;; type + ('2d ()) + ('3d (if map (add-to-script "set map"))) + ('grid (if map + (add-to-script "set pm3d map") + (add-to-script "set pm3d")))) + (when title (add-to-script (format "set title '%s'" title))) ;; title + (when lines (mapc (lambda (el) (add-to-script el)) lines)) ;; line + (when sets ;; set + (mapc (lambda (el) (add-to-script (format "set %s" el))) sets)) + (when x-labels ;; x labels (xtics) + (add-to-script + (format "set xtics (%s)" + (mapconcat (lambda (pair) + (format "\"%s\" %d" (cdr pair) (car pair))) + x-labels ", ")))) + (when y-labels ;; y labels (ytics) + (add-to-script + (format "set ytics (%s)" + (mapconcat (lambda (pair) + (format "\"%s\" %d" (cdr pair) (car pair))) + y-labels ", ")))) + (case type ;; plot command + ('2d (dotimes (col num-cols) + (unless (and (equal type '2d) + (or (and ind (equal (+ 1 col) ind)) + (and deps (not (member (+ 1 col) deps))))) + (setf plot-lines + (cons + (format plot-str data-file + (or (and (not text-ind) ind + (> ind 0) (format "%d:" ind)) "") + (+ 1 col) + (if text-ind (format ":xticlabel(%d)" ind) "") + with + (or (nth col col-labels) (format "%d" (+ 1 col)))) + plot-lines))))) + ('3d + (setq plot-lines (list (format "'%s' matrix with %s title ''" + data-file with)))) + ('grid + (setq plot-lines (list (format "'%s' with %s title ''" + data-file with))))) + (add-to-script + (concat plot-cmd " " (mapconcat 'identity (reverse plot-lines) ",\\\n "))) + script))) + +;;----------------------------------------------------------------------------- +;; facade functions +;;;###autoload +(defun org-plot/gnuplot (&optional params) + "Plot table using gnuplot. Gnuplot options can be specified with PARAMS. +If not given options will be taken from the +PLOT +line directly before or after the table." + (interactive) + (require 'gnuplot) + (save-window-excursion + (delete-other-windows) + (when (get-buffer "*gnuplot*") ;; reset *gnuplot* if it already running + (save-excursion + (set-buffer "*gnuplot*") (goto-char (point-max)) + (gnuplot-delchar-or-maybe-eof nil))) + (org-plot/goto-nearest-table) + ;; set default options + (mapc + (lambda (pair) + (unless (plist-member params (car pair)) + (setf params (plist-put params (car pair) (cdr pair))))) + org-plot/gnuplot-default-options) + ;; collect table and table information + (let* ((data-file (make-temp-file "org-plot")) + (table (org-table-to-lisp)) + (num-cols (length (if (eq (first table) 'hline) (second table) + (first table))))) + (while (equal 'hline (first table)) (setf table (cdr table))) + (when (equal (second table) 'hline) + (setf params (plist-put params :labels (first table))) ;; headers to labels + (setf table (delq 'hline (cdr table)))) ;; clean non-data from table + ;; collect options + (save-excursion (while (and (equal 0 (forward-line -1)) + (looking-at "#\\+")) + (setf params (org-plot/collect-options params)))) + ;; dump table to datafile (very different for grid) + (case (plist-get params :plot-type) + ('2d (org-plot/gnuplot-to-data table data-file params)) + ('3d (org-plot/gnuplot-to-data table data-file params)) + ('grid (let ((y-labels (org-plot/gnuplot-to-grid-data + table data-file params))) + (when y-labels (plist-put params :ylabels y-labels))))) + ;; check for text ind column + (let ((ind (- (plist-get params :ind) 1))) + (when (and (>= ind 0) (equal '2d (plist-get params :plot-type))) + (if (> (length + (delq 0 (mapcar + (lambda (el) + (if (string-match org-table-number-regexp el) + 0 1)) + (mapcar (lambda (row) (nth ind row)) table)))) 0) + (plist-put params :textind t)))) + ;; write script + (with-temp-buffer + (if (plist-get params :script) ;; user script + (progn (insert-file-contents (plist-get params :script)) + (goto-char (point-min)) + (while (re-search-forward "$datafile" nil t) + (replace-match data-file nil nil))) + (insert + (org-plot/gnuplot-script data-file num-cols params))) + ;; graph table + (gnuplot-mode) + (gnuplot-send-buffer-to-gnuplot)) + ;; cleanup + (bury-buffer (get-buffer "*gnuplot*"))(delete-file data-file)))) + +(provide 'org-plot) + +;;; org-plot.el ends here