emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
From: Simon Guest <simon.guest@tesujimath.org>
To: Eric S Fraga <e.fraga@ucl.ac.uk>
Cc: emacs-org list <emacs-orgmode@gnu.org>
Subject: Sub-tree word count v2
Date: Fri, 29 Apr 2011 10:05:47 +1200	[thread overview]
Message-ID: <86y62uxc90.wl%simon.guest@tesujimath.org> (raw)
In-Reply-To: <87oc3qg4f8.fsf@ucl.ac.uk>

At Thu, 28 Apr 2011 09:34:35 +0100,
Eric S Fraga wrote:
> However, it would be helpful if the modification flag were not changed
> by asking for the word count.  I don't know enough elisp to suggest what
> to change but you should be able to add the text properties without
> causing the buffer modification flag to change?  Column view, for
> instance, doesn't do this.

Hi Eric,

OK, I fixed this.  Now buffer modification state is preserved.  Also
now handles empty sections properly.

Version 2 attached below.

cheers,
Simon

;; org-wc.el
;;
;; Count words in org mode trees.
;; Shows word count per heading line, summed over sub-headings.
;; Aims to be fast, so doesn't check carefully what it's counting.  ;-)
;;
;; Simon Guest, 23/4/11
;;
;; Implementation based on:
;; - Paul Sexton's word count posted on org-mode mailing list 21/2/11.
;; - clock overlays
;;
;; v2 
;; 29/4/11
;; Don't modify buffer, and fixed handling of empty sections.

(defun org-in-heading-line ()
  "Is point in a line starting with `*'?"
  (equal (char-after (point-at-bol)) ?*))

(defun org-word-count (beg end) 
  "Report the number of words in the Org mode buffer or selected region."
  (interactive "r")
  (unless mark-active
    (setf beg (point-min)
	  end (point-max)))
  (let ((wc (org-word-count-aux beg end)))
    (message (format "%d words in %s." wc
                     (if mark-active "region" "buffer")))))

(defun org-word-count-aux (beg end)
  "Report the number of words in the selected region.
Ignores: heading lines,
         blocks,
         comments,
         drawers.
LaTeX macros are counted as 1 word."

  (let ((wc 0)
        (block-begin-re "^#\\\+BEGIN")
        (block-end-re "^#\\+END")
	(latex-macro-regexp "\\\\[A-Za-z]+\\(\\[[^]]*\\]\\|\\){\\([^}]*\\)}")
        (drawers-re (concat "^[ \t]*:\\("
                            (mapconcat 'regexp-quote org-drawers "\\|")
                            "\\):[ \t]*$"))
        (drawers-end-re "^[ \t]*:END:"))
    (save-excursion
      (goto-char beg)
      (while (< (point) end)
        (cond
         ;; Ignore heading lines.
         ((org-in-heading-line)
          (forward-line))
         ;; Ignore blocks.
         ((looking-at block-begin-re)
          (re-search-forward block-end-re))
         ;; Ignore comments.
         ((org-in-commented-line)
          (forward-line))
         ;; Ignore drawers.
         ((looking-at drawers-re)
          (re-search-forward drawers-end-re nil t))
         ;; Count latex macros as 1 word, ignoring their arguments.
         ((save-excursion
            (backward-char)
            (looking-at latex-macro-regexp))
          (goto-char (match-end 0))
          (setf wc (+ 2 wc)))
         (t
          (progn
            (and (re-search-forward "\\w+\\W*" end 'skip)
                 (incf wc)))))))
    wc))

(defun org-wc-count-subtrees ()
  "Count words in each subtree, putting result as the property :org-wc on that heading."
  (interactive)
  (remove-text-properties (point-min) (point-max)
                          '(:org-wc t))
  (save-excursion
    (goto-char (point-max))
    (while (outline-previous-heading)
      (org-narrow-to-subtree)
      (let ((wc (org-word-count-aux (point-min) (point-max))))
        (put-text-property (point) (point-at-eol) :org-wc wc)
        (goto-char (point-min))
        (widen)))))

(defun org-wc-display (beg end total-only)
  "Show subtree word counts in the entire buffer.
With prefix argument, only show the total wordcount for the buffer or region
in the echo area.

Use \\[org-wc-remove-overlays] to remove the subtree times.

Ignores: heading lines,
         blocks,
         comments,
         drawers.
LaTeX macros are counted as 1 word."
  (interactive "r\nP")
  (org-wc-remove-overlays)
  (unless total-only
    (let ((bmp (buffer-modified-p))
          wc 
          p)
      (org-wc-count-subtrees)
      (save-excursion
        (goto-char (point-min))
        (while (or (and (equal (setq p (point)) (point-min))
                        (get-text-property p :org-wc))
                   (setq p (next-single-property-change
                            (point) :org-wc)))
          (goto-char p)
          (when (setq wc (get-text-property p :org-wc))
            (org-wc-put-overlay wc (funcall outline-level))))
        ;; Arrange to remove the overlays upon next change.
        (when org-remove-highlights-with-change
          (org-add-hook 'before-change-functions 'org-wc-remove-overlays
                        nil 'local)))
    (set-buffer-modified-p bmp)))
  (if mark-active
      (org-word-count beg end)
    (org-word-count (point-min) (point-max))))

(defvar org-wc-overlays nil)
(make-variable-buffer-local 'org-wc-overlays)

(defun org-wc-put-overlay (wc &optional level)
  "Put an overlays on the current line, displaying word count.
If LEVEL is given, prefix word count with a corresponding number of stars.
This creates a new overlay and stores it in `org-wc-overlays', so that it
will be easy to remove."
  (let* ((c 60)
         (l (if level (org-get-valid-level level 0) 0))
	 (off 0)
	 ov tx)
    (org-move-to-column c)
    (unless (eolp) (skip-chars-backward "^ \t"))
    (skip-chars-backward " \t")
    (setq ov (make-overlay (1- (point)) (point-at-eol))
	  tx (concat (buffer-substring (1- (point)) (point))
		     (make-string (+ off (max 0 (- c (current-column)))) ?.)
		     (org-add-props (format "%s" (number-to-string wc))
			 (list 'face 'org-wc-overlay))
		     ""))
    (if (not (featurep 'xemacs))
	(overlay-put ov 'display tx)
      (overlay-put ov 'invisible t)
      (overlay-put ov 'end-glyph (make-glyph tx)))
    (push ov org-wc-overlays)))

(defun org-wc-remove-overlays (&optional beg end noremove)
  "Remove the occur highlights from the buffer.
BEG and END are ignored.  If NOREMOVE is nil, remove this function
from the `before-change-functions' in the current buffer."
  (interactive)
  (unless org-inhibit-highlight-removal
    (mapc 'delete-overlay org-wc-overlays)
    (setq org-wc-overlays nil)
    (unless noremove
      (remove-hook 'before-change-functions
		   'org-wc-remove-overlays 'local))))

(provide 'org-wc)

  reply	other threads:[~2011-04-28 22:05 UTC|newest]

Thread overview: 19+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2011-04-23  8:57 Implemented word count for subtrees Simon Guest
2011-04-27 17:51 ` Eric S Fraga
2011-04-27 22:41   ` Simon Guest
2011-04-28  8:34     ` Eric S Fraga
2011-04-28 22:05       ` Simon Guest [this message]
2011-04-28 22:47         ` Sub-tree word count v2 Samuel Wales
2011-04-29  1:57           ` v3, with support for narrowing Simon Guest
2011-04-29  2:41             ` Eric Abrahamsen
2011-04-29  3:35               ` Nick Dokos
2011-04-29  4:31                 ` Eric Abrahamsen
2011-04-29 14:56                   ` Nick Dokos
2011-04-29 21:42                     ` Simon Guest
2011-06-09  1:33                       ` v4, now with properties and inclusion tags Eric Abrahamsen
2011-05-14 22:48             ` v3, with support for narrowing Samuel Wales
2011-05-15  4:25               ` Simon Guest
2011-04-28 23:16         ` Sub-tree word count v2 Eric S Fraga
2011-04-28  7:53 ` Implemented word count for subtrees Sébastien Vauban
2011-04-28  8:35   ` Eric S Fraga
2011-05-02 12:19   ` Daniel Clemente

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.orgmode.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=86y62uxc90.wl%simon.guest@tesujimath.org \
    --to=simon.guest@tesujimath.org \
    --cc=e.fraga@ucl.ac.uk \
    --cc=emacs-orgmode@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).