diff options
author | Luke Shumaker <LukeShu@sbcglobal.net> | 2011-04-13 23:20:15 -0400 |
---|---|---|
committer | Luke Shumaker <LukeShu@sbcglobal.net> | 2011-04-13 23:20:15 -0400 |
commit | f7464fdd2e33e5dc6c159a4adc8f53902e6d4511 (patch) | |
tree | b1d65db982af54cc2088de3228174c4ea710c2f4 /.emacs.d/org-7.4/lisp/org-freemind.el |
Initial commit of Luke Shumaker's "dot-files".
Diffstat (limited to '.emacs.d/org-7.4/lisp/org-freemind.el')
-rw-r--r-- | .emacs.d/org-7.4/lisp/org-freemind.el | 1243 |
1 files changed, 1243 insertions, 0 deletions
diff --git a/.emacs.d/org-7.4/lisp/org-freemind.el b/.emacs.d/org-7.4/lisp/org-freemind.el new file mode 100644 index 0000000..d9486af --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-freemind.el @@ -0,0 +1,1243 @@ +;;; org-freemind.el --- Export Org files to freemind + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; 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 <http://www.gnu.org/licenses/>. + +;; -------------------------------------------------------------------- +;; Features that might be required by this library: +;; +;; `backquote', `bytecomp', `cl', `easymenu', `font-lock', +;; `noutline', `org', `org-compat', `org-faces', `org-footnote', +;; `org-list', `org-macs', `org-src', `outline', `syntax', +;; `time-date', `xml'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This file tries to implement some functions useful for +;; transformation between org-mode and FreeMind files. +;; +;; Here are the commands you can use: +;; +;; M-x `org-freemind-from-org-mode' +;; M-x `org-freemind-from-org-mode-node' +;; M-x `org-freemind-from-org-sparse-tree' +;; +;; M-x `org-freemind-to-org-mode' +;; +;; M-x `org-freemind-show' +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; 2009-02-15: Added check for next level=current+1 +;; 2009-02-21: Fixed bug in `org-freemind-to-org-mode'. +;; 2009-10-25: Added support for `org-odd-levels-only'. +;; Added y/n question before showing in FreeMind. +;; 2009-11-04: Added support for #+BEGIN_HTML. +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program 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 2, or +;; (at your option) any later version. +;; +;; This program 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(require 'xml) +(require 'org) +;(require 'rx) +(require 'org-exp) +(eval-when-compile (require 'cl)) + +(defgroup org-freemind nil + "Customization group for org-freemind export/import." + :group 'org) + +;; Fix-me: I am not sure these are useful: +;; +;; (defcustom org-freemind-main-fgcolor "black" +;; "Color of main node's text." +;; :type 'color +;; :group 'org-freemind) + +;; (defcustom org-freemind-main-color "black" +;; "Background color of main node." +;; :type 'color +;; :group 'org-freemind) + +;; (defcustom org-freemind-child-fgcolor "black" +;; "Color of child nodes' text." +;; :type 'color +;; :group 'org-freemind) + +;; (defcustom org-freemind-child-color "black" +;; "Background color of child nodes." +;; :type 'color +;; :group 'org-freemind) + +(defvar org-freemind-node-style nil "Internal use.") + +(defcustom org-freemind-node-styles nil + "Styles to apply to node. +NOT READY YET." + :type '(repeat + (list :tag "Node styles for file" + (regexp :tag "File name") + (repeat + (list :tag "Node" + (regexp :tag "Node name regexp") + (set :tag "Node properties" + (list :format "%v" (const :format "" node-style) + (choice :tag "Style" + :value bubble + (const bubble) + (const fork))) + (list :format "%v" (const :format "" color) + (color :tag "Color" :value "red")) + (list :format "%v" (const :format "" background-color) + (color :tag "Background color" :value "yellow")) + (list :format "%v" (const :format "" edge-color) + (color :tag "Edge color" :value "green")) + (list :format "%v" (const :format "" edge-style) + (choice :tag "Edge style" :value bezier + (const :tag "Linear" linear) + (const :tag "Bezier" bezier) + (const :tag "Sharp Linear" sharp-linear) + (const :tag "Sharp Bezier" sharp-bezier))) + (list :format "%v" (const :format "" edge-width) + (choice :tag "Edge width" :value thin + (const :tag "Parent" parent) + (const :tag "Thin" thin) + (const 1) + (const 2) + (const 4) + (const 8))) + (list :format "%v" (const :format "" italic) + (const :tag "Italic font" t)) + (list :format "%v" (const :format "" bold) + (const :tag "Bold font" t)) + (list :format "%v" (const :format "" font-name) + (string :tag "Font name" :value "SansSerif")) + (list :format "%v" (const :format "" font-size) + (integer :tag "Font size" :value 12))))))) + :group 'org-freemind) + +;;;###autoload +(defun org-export-as-freemind (&optional hidden ext-plist + to-buffer body-only pub-dir) + "Export the current buffer as a Freemind file. +If there is an active region, export only the region. HIDDEN is +obsolete and does nothing. EXT-PLIST is a property list with +external parameters overriding org-mode's default settings, but +still inferior to file-local settings. When TO-BUFFER is +non-nil, create a buffer with that name and export to that +buffer. If TO-BUFFER is the symbol `string', don't leave any +buffer behind but just return the resulting HTML as a string. +When BODY-ONLY is set, don't produce the file header and footer, +simply return the content of the document (all top level +sections). When PUB-DIR is set, use this as the publishing +directory. + +See `org-freemind-from-org-mode' for more information." + (interactive "P") + (let* ((opt-plist (org-combine-plists (org-default-export-plist) + ext-plist + (org-infile-export-plist))) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (if (plist-get opt-plist :ignore-subtree-p) + nil + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend)))))) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer)))) + (filename (concat (file-name-as-directory + (or pub-dir + (org-export-directory :ascii opt-plist))) + (file-name-sans-extension + (or (and subtree-p + (org-entry-get (region-beginning) + "EXPORT_FILE_NAME" t)) + (file-name-nondirectory bfname))) + ".mm"))) + (when (file-exists-p filename) + (delete-file filename)) + (cond + (subtree-p + (org-freemind-from-org-mode-node (line-number-at-pos rbeg) + filename)) + (t (org-freemind-from-org-mode bfname filename))))) + +;;;###autoload +(defun org-freemind-show (mm-file) + "Show file MM-FILE in Freemind." + (interactive + (list + (save-match-data + (let ((name (read-file-name "FreeMind file: " + nil nil nil + (if (buffer-file-name) + (let* ((name-ext (file-name-nondirectory (buffer-file-name))) + (name (file-name-sans-extension name-ext)) + (ext (file-name-extension name-ext))) + (cond + ((string= "mm" ext) + name-ext) + ((string= "org" ext) + (let ((name-mm (concat name ".mm"))) + (if (file-exists-p name-mm) + name-mm + (message "Not exported to Freemind format yet") + ""))) + (t + ""))) + "") + ;; Fix-me: Is this an Emacs bug? + ;; This predicate function is never + ;; called. + (lambda (fn) + (string-match "^mm$" (file-name-extension fn)))))) + (setq name (expand-file-name name)) + name)))) + (org-open-file mm-file)) + +(defconst org-freemind-org-nfix "--org-mode: ") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Format converters + +(defun org-freemind-escape-str-from-org (org-str) + "Do some html-escaping of ORG-STR and return the result. +The characters \"&<> will be escaped." + (let ((chars (append org-str nil)) + (fm-str "")) + (dolist (cc chars) + (setq fm-str + (concat fm-str + (if (< cc 160) + (cond + ((= cc ?\") """) + ((= cc ?\&) "&") + ((= cc ?\<) "<") + ((= cc ?\>) ">") + (t (char-to-string cc))) + ;; Formatting as &#number; is maybe needed + ;; according to a bug report from kazuo + ;; fujimoto, but I have now instead added a xml + ;; processing instruction saying that the mm + ;; file is utf-8: + ;; + ;; (format "&#x%x;" (- cc ;; ?\x800)) + (format "&#x%x;" (encode-char cc 'ucs)) + )))) + fm-str)) + +;;(org-freemind-unescape-str-to-org "mA≌B<C<=") +;;(org-freemind-unescape-str-to-org "<<") +(defun org-freemind-unescape-str-to-org (fm-str) + "Do some html-unescaping of FM-STR and return the result. +This is the opposite of `org-freemind-escape-str-from-org' but it +will also unescape &#nn;." + (let ((org-str fm-str)) + (setq org-str (replace-regexp-in-string """ "\"" org-str)) + (setq org-str (replace-regexp-in-string "&" "&" org-str)) + (setq org-str (replace-regexp-in-string "<" "<" org-str)) + (setq org-str (replace-regexp-in-string ">" ">" org-str)) + (setq org-str (replace-regexp-in-string + "&#x\\([a-f0-9]\\{2,4\\}\\);" + (lambda (m) + (char-to-string + (+ (string-to-number (match-string 1 m) 16) + 0 ;?\x800 ;; What is this for? Encoding? + ))) + org-str)))) + +;; (let* ((str1 "a quote: \", an amp: &, lt: <; over 256: φεδΦΕΔ") +;; (str2 (org-freemind-escape-str-from-org str1)) +;; (str3 (org-freemind-unescape-str-to-org str2))) +;; (unless (string= str1 str3) +;; (error "Error str3=%s" str3))) + +(defun org-freemind-convert-links-helper (matched) + "Helper for `org-freemind-convert-links-from-org'. +MATCHED is the link just matched." + (let* ((link (match-string 1 matched)) + (text (match-string 2 matched)) + (ext (file-name-extension link)) + (col-pos (string-match-p ":" link)) + (is-img (and (image-type-from-file-name link) + (let ((url-type (substring link 0 col-pos))) + (member url-type '("file" "http" "https"))))) + ) + (if is-img + ;; Fix-me: I can't find a way to get the border to "shrink + ;; wrap" around the image using <div>. + ;; + ;; (concat "<div style=\"border: solid 1px #ddd; width:auto;\">" + ;; "<img src=\"" link "\" alt=\"" text "\" />" + ;; "<br />" + ;; "<i>" text "</i>" + ;; "</div>") + (concat "<table border=\"0\" style=\"border: solid 1px #ddd;\"><tr><td>" + "<img src=\"" link "\" alt=\"" text "\" />" + "<br />" + "<i>" text "</i>" + "</td></tr></table>") + (concat "<a href=\"" link "\">" text "</a>")))) + +(defun org-freemind-convert-links-from-org (org-str) + "Convert org links in ORG-STR to freemind links and return the result." + (let ((fm-str (replace-regexp-in-string + ;;(rx (not (any "[\"")) + ;; (submatch + ;; "http" + ;; (opt ?\s) + ;; "://" + ;; (1+ + ;; (any "-%.?@a-zA-Z0-9()_/:~=&#")))) + "[^\"[]\\(http ?://[--:#%&()=?-Z_a-z~]+\\)" + "[[\\1][\\1]]" + org-str + nil ;; fixedcase + nil ;; literal + 1 ;; subexp + ))) + (replace-regexp-in-string + ;;(rx "[[" + ;; (submatch (*? nonl)) + ;; "][" + ;; (submatch (*? nonl)) + ;; "]]") + "\\[\\[\\(.*?\\)]\\[\\(.*?\\)]]" + ;;"<a href=\"\\1\">\\2</a>" + 'org-freemind-convert-links-helper + fm-str))) + +;;(org-freemind-convert-links-to-org "<a href=\"http://www.somewhere/\">link-text</a>") +(defun org-freemind-convert-links-to-org (fm-str) + "Convert freemind links in FM-STR to org links and return the result." + (let ((org-str (replace-regexp-in-string + ;;(rx "<a" + ;; space + ;; (0+ + ;; (0+ (not (any ">"))) + ;; space) + ;; "href=\"" + ;; (submatch (0+ (not (any "\"")))) + ;; "\"" + ;; (0+ (not (any ">"))) + ;; ">" + ;; (submatch (0+ (not (any "<")))) + ;; "</a>") + "<a[[:space:]]\\(?:[^>]*[[:space:]]\\)*href=\"\\([^\"]*\\)\"[^>]*>\\([^<]*\\)</a>" + "[[\\1][\\2]]" + fm-str))) + org-str)) + +;; Fix-me: +;;(defun org-freemind-convert-drawers-from-org (text) +;; ) + +;; (let* ((str1 "[[http://www.somewhere/][link-text]") +;; (str2 (org-freemind-convert-links-from-org str1)) +;; (str3 (org-freemind-convert-links-to-org str2))) +;; (unless (string= str1 str3) +;; (error "Error str3=%s" str3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Org => FreeMind + +(defvar org-freemind-bol-helper-base-indent nil) + +(defun org-freemind-bol-helper (matched) + "Helper for `org-freemind-convert-text-p'. +MATCHED is the link just matched." + (let ((res "") + (bi org-freemind-bol-helper-base-indent)) + (dolist (cc (append matched nil)) + (if (= 32 cc) + ;;(setq res (concat res " ")) + ;; We need to use the numerical version. Otherwise Freemind + ;; ver 0.9.0 RC9 can not export to html/javascript. + (progn + (if (< 0 bi) + (setq bi (1- bi)) + (setq res (concat res " ")))) + (setq res (concat res (char-to-string cc))))) + res)) +;; (setq x (replace-regexp-in-string "\n +" 'org-freemind-bol-nbsp-helper "\n ")) + +(defun org-freemind-convert-text-p (text) + "Convert TEXT to html with <p> paragraphs." + ;; (string-match-p "[^ ]" " a") + (setq org-freemind-bol-helper-base-indent (string-match-p "[^ ]" text)) + (setq text (org-freemind-escape-str-from-org text)) + + (setq text (replace-regexp-in-string "\\([[:space:]]\\)\\(/\\)\\([^/]+\\)\\(/\\)\\([[:space:]]\\)" "\\1<i>\\3</i>\\5" text)) + (setq text (replace-regexp-in-string "\\([[:space:]]\\)\\(\*\\)\\([^*]+\\)\\(\*\\)\\([[:space:]]\\)" "\\1<b>\\3</b>\\5" text)) + + (setq text (concat "<p>" text)) + (setq text (replace-regexp-in-string "\n[[:blank:]]*\n" "</p><p>" text)) + (setq text (replace-regexp-in-string "\\(?:<p>\\|\n\\) +" 'org-freemind-bol-helper text)) + (setq text (replace-regexp-in-string "\n" "<br />" text)) + (setq text (concat text "</p>")) + + (org-freemind-convert-links-from-org text)) + +(defcustom org-freemind-node-css-style + "p { margin-top: 3px; margin-bottom: 3px; }" + "CSS style for Freemind nodes." + ;; Fix-me: I do not understand this. It worked to export from Freemind + ;; with this setting now, but not before??? Was this perhaps a java + ;; bug or is it a windows xp bug (some resource gets exhausted if you + ;; use sticky keys which I do). + :group 'org-freemind) + +(defun org-freemind-org-text-to-freemind-subnode/note (node-name start end drawers-regexp) + "Convert text part of org node to freemind subnode or note. +Convert the text part of the org node named NODE-NAME. The text +is in the current buffer between START and END. Drawers matching +DRAWERS-REGEXP are converted to freemind notes." + ;; fix-me: doc + (let ((text (buffer-substring-no-properties start end)) + (node-res "") + (note-res "")) + (save-match-data + ;;(setq text (org-freemind-escape-str-from-org text)) + ;; First see if there is something that should be moved to the + ;; note part: + (let (drawers) + (while (string-match drawers-regexp text) + (setq drawers (cons (match-string 0 text) drawers)) + (setq text + (concat (substring text 0 (match-beginning 0)) + (substring text (match-end 0)))) + ) + (when drawers + (dolist (drawer drawers) + (let ((lines (split-string drawer "\n"))) + (dolist (line lines) + (setq note-res (concat + note-res + org-freemind-org-nfix line "<br />\n"))) + )))) + + (when (> (length note-res) 0) + (setq note-res (concat + "<richcontent TYPE=\"NOTE\"><html>\n" + "<head>\n" + "</head>\n" + "<body>\n" + note-res + "</body>\n" + "</html>\n" + "</richcontent>\n")) + ) + + ;; There is always an LF char: + (when (> (length text) 1) + (setq node-res (concat + "<node style=\"bubble\" background_color=\"#eeee00\">\n" + "<richcontent TYPE=\"NODE\"><html>\n" + "<head>\n" + (if (= 0 (length org-freemind-node-css-style)) + "" + (concat + "<style type=\"text/css\">\n" + "<!--\n" + org-freemind-node-css-style + "-->\n" + "</style>\n")) + "</head>\n" + "<body>\n")) + (let ((begin-html-mark (regexp-quote "#+BEGIN_HTML")) + (end-html-mark (regexp-quote "#+END_HTML")) + head + end-pos + end-pos-match + ) + ;; Take care of #+BEGIN_HTML - #+END_HTML + (while (string-match begin-html-mark text) + (setq head (substring text 0 (match-beginning 0))) + (setq end-pos-match (match-end 0)) + (setq node-res (concat node-res + (org-freemind-convert-text-p head))) + (setq text (substring text end-pos-match)) + (setq end-pos (string-match end-html-mark text)) + (if end-pos + (setq end-pos-match (match-end 0)) + (message "org-freemind: Missing #+END_HTML") + (setq end-pos (length text)) + (setq end-pos-match end-pos)) + (setq node-res (concat node-res + (substring text 0 end-pos))) + (setq text (substring text end-pos-match))) + (setq node-res (concat node-res + (org-freemind-convert-text-p text)))) + (setq node-res (concat + node-res + "</body>\n" + "</html>\n" + "</richcontent>\n" + ;; Put a note that this is for the parent node + ;; "<richcontent TYPE=\"NOTE\"><html>" + ;; "<head>" + ;; "</head>" + ;; "<body>" + ;; "<p>" + ;; "-- This is more about \"" node-name "\" --" + ;; "</p>" + ;; "</body>" + ;; "</html>" + ;; "</richcontent>\n" + note-res + "</node>\n" ;; ok + ))) + (list node-res note-res)))) + +(defun org-freemind-write-node (mm-buffer drawers-regexp + num-left-nodes base-level + current-level next-level this-m2 + this-node-end + this-children-visible + next-node-start + next-has-some-visible-child) + (let* (this-icons + this-bg-color + this-m2-escaped + this-rich-node + this-rich-note + ) + (when (string-match "TODO" this-m2) + (setq this-m2 (replace-match "" nil nil this-m2)) + (add-to-list 'this-icons "button_cancel") + (setq this-bg-color "#ffff88") + (when (string-match "\\[#\\(.\\)\\]" this-m2) + (let ((prior (string-to-char (match-string 1 this-m2)))) + (setq this-m2 (replace-match "" nil nil this-m2)) + (cond + ((= prior ?A) + (add-to-list 'this-icons "full-1") + (setq this-bg-color "#ff0000")) + ((= prior ?B) + (add-to-list 'this-icons "full-2") + (setq this-bg-color "#ffaa00")) + ((= prior ?C) + (add-to-list 'this-icons "full-3") + (setq this-bg-color "#ffdd00")) + ((= prior ?D) + (add-to-list 'this-icons "full-4") + (setq this-bg-color "#ffff00")) + ((= prior ?E) + (add-to-list 'this-icons "full-5")) + ((= prior ?F) + (add-to-list 'this-icons "full-6")) + ((= prior ?G) + (add-to-list 'this-icons "full-7")) + )))) + (setq this-m2 (org-trim this-m2)) + (setq this-m2-escaped (org-freemind-escape-str-from-org this-m2)) + (let ((node-notes (org-freemind-org-text-to-freemind-subnode/note + this-m2-escaped + this-node-end + (1- next-node-start) + drawers-regexp))) + (setq this-rich-node (nth 0 node-notes)) + (setq this-rich-note (nth 1 node-notes))) + (with-current-buffer mm-buffer + (insert "<node text=\"" this-m2-escaped "\"") + (org-freemind-get-node-style this-m2) + (when (> next-level current-level) + (unless (or this-children-visible + next-has-some-visible-child) + (insert " folded=\"true\""))) + (when (and (= current-level (1+ base-level)) + (> num-left-nodes 0)) + (setq num-left-nodes (1- num-left-nodes)) + (insert " position=\"left\"")) + (when this-bg-color + (insert " background_color=\"" this-bg-color "\"")) + (insert ">\n") + (when this-icons + (dolist (icon this-icons) + (insert "<icon builtin=\"" icon "\"/>\n"))) + ) + (with-current-buffer mm-buffer + ;;(when this-rich-note (insert this-rich-note)) + (when this-rich-node (insert this-rich-node)))) + num-left-nodes) + +(defun org-freemind-check-overwrite (file interactively) + "Check if file FILE already exists. +If FILE does not exists return t. + +If INTERACTIVELY is non-nil ask if the file should be replaced +and return t/nil if it should/should not be replaced. + +Otherwise give an error say the file exists." + (if (file-exists-p file) + (if interactively + (y-or-n-p (format "File %s exists, replace it? " file)) + (error "File %s already exists" file)) + t)) + +(defvar org-freemind-node-pattern + ;;(rx bol + ;; (submatch (1+ "*")) + ;; (1+ space) + ;; (submatch (*? nonl)) + ;; eol) + "^\\(\\*+\\)[[:space:]]+\\(.*?\\)$") + +(defun org-freemind-look-for-visible-child (node-level) + (save-excursion + (save-match-data + (let ((found-visible-child nil)) + (while (and (not found-visible-child) + (re-search-forward org-freemind-node-pattern nil t)) + (let* ((m1 (match-string-no-properties 1)) + (level (length m1))) + (if (>= node-level level) + (setq found-visible-child 'none) + (unless (get-char-property (line-beginning-position) 'invisible) + (setq found-visible-child 'found))))) + (eq found-visible-child 'found) + )))) + +(defun org-freemind-goto-line (line) + "Go to line number LINE." + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)))) + +(defun org-freemind-write-mm-buffer (org-buffer mm-buffer node-at-line) + (with-current-buffer org-buffer + (dolist (node-style org-freemind-node-styles) + (when (string-match-p (car node-style) buffer-file-name) + (setq org-freemind-node-style (cadr node-style)))) + ;;(message "org-freemind-node-style =%s" org-freemind-node-style) + (save-match-data + (let* ((drawers (copy-sequence org-drawers)) + drawers-regexp + (num-top1-nodes 0) + (num-top2-nodes 0) + num-left-nodes + (unclosed-nodes 0) + (odd-only org-odd-levels-only) + (first-time t) + (current-level 1) + base-level + prev-node-end + rich-text + unfinished-tag + node-at-line-level + node-at-line-last) + (with-current-buffer mm-buffer + (erase-buffer) + (setq buffer-file-coding-system 'utf-8) + ;; Fix-me: Currentl Freemind (ver 0.9.0 RC9) does not support this: + ;;(insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") + (insert "<map version=\"0.9.0\">\n") + (insert "<!-- To view this file, download free mind mapping software FreeMind from http://freemind.sourceforge.net -->\n")) + (save-excursion + ;; Get special buffer vars: + (goto-char (point-min)) + (message "Writing Freemind file...") + (while (re-search-forward "^#\\+DRAWERS:" nil t) + (let ((dr-txt (buffer-substring-no-properties (match-end 0) (line-end-position)))) + (setq drawers (append drawers (split-string dr-txt) nil)))) + (setq drawers-regexp + (concat "^[[:blank:]]*:" + (regexp-opt drawers) + ;;(rx ":" (0+ blank) + ;; "\n" + ;; (*? anything) + ;; "\n" + ;; (0+ blank) + ;; ":END:" + ;; (0+ blank) + ;; eol) + ":[[:blank:]]*\n\\(?:.\\|\n\\)*?\n[[:blank:]]*:END:[[:blank:]]*$" + )) + + (if node-at-line + ;; Get number of top nodes and last line for this node + (progn + (org-freemind-goto-line node-at-line) + (unless (looking-at org-freemind-node-pattern) + (error "No node at line %s" node-at-line)) + (setq node-at-line-level (length (match-string-no-properties 1))) + (forward-line) + (setq node-at-line-last + (catch 'last-line + (while (re-search-forward org-freemind-node-pattern nil t) + (let* ((m1 (match-string-no-properties 1)) + (level (length m1))) + (if (<= level node-at-line-level) + (progn + (beginning-of-line) + (throw 'last-line (1- (point)))) + (if (= level (1+ node-at-line-level)) + (setq num-top2-nodes (1+ num-top2-nodes)))))))) + (setq current-level node-at-line-level) + (setq num-top1-nodes 1) + (org-freemind-goto-line node-at-line)) + + ;; First get number of top nodes + (goto-char (point-min)) + (while (re-search-forward org-freemind-node-pattern nil t) + (let* ((m1 (match-string-no-properties 1)) + (level (length m1))) + (if (= level 1) + (setq num-top1-nodes (1+ num-top1-nodes)) + (if (= level 2) + (setq num-top2-nodes (1+ num-top2-nodes)))))) + ;; If there is more than one top node we need to insert a node + ;; to keep them together. + (goto-char (point-min)) + (when (> num-top1-nodes 1) + (setq num-top2-nodes num-top1-nodes) + (setq current-level 0) + (let ((orig-name (if buffer-file-name + (file-name-nondirectory (buffer-file-name)) + (buffer-name)))) + (with-current-buffer mm-buffer + (insert "<node text=\"" orig-name "\" background_color=\"#00bfff\">\n" + ;; Put a note that this is for the parent node + "<richcontent TYPE=\"NOTE\"><html>" + "<head>" + "</head>" + "<body>" + "<p>" + org-freemind-org-nfix "WHOLE FILE" + "</p>" + "</body>" + "</html>" + "</richcontent>\n"))))) + + (setq num-left-nodes (floor num-top2-nodes 2)) + (setq base-level current-level) + (let (this-m2 + this-node-end + this-children-visible + next-m2 + next-node-start + next-level + next-has-some-visible-child + next-children-visible + ) + (while (and + (re-search-forward org-freemind-node-pattern nil t) + (if node-at-line-last (<= (point) node-at-line-last) t) + ) + (let* ((next-m1 (match-string-no-properties 1)) + (next-node-end (match-end 0)) + ) + (setq next-node-start (match-beginning 0)) + (setq next-m2 (match-string-no-properties 2)) + (setq next-level (length next-m1)) + (setq next-children-visible + (not (eq 'outline + (get-char-property (line-end-position) 'invisible)))) + (setq next-has-some-visible-child + (if next-children-visible t + (org-freemind-look-for-visible-child next-level))) + (when this-m2 + (setq num-left-nodes (org-freemind-write-node mm-buffer drawers-regexp num-left-nodes base-level current-level next-level this-m2 this-node-end this-children-visible next-node-start next-has-some-visible-child))) + (when (if (= num-top1-nodes 1) (> current-level base-level) t) + (while (>= current-level next-level) + (with-current-buffer mm-buffer + (insert "</node>\n") + (setq current-level + (- current-level (if odd-only 2 1)))))) + (setq this-node-end (1+ next-node-end)) + (setq this-m2 next-m2) + (setq current-level next-level) + (setq this-children-visible next-children-visible) + (forward-char) + )) +;;; (unless (if node-at-line-last +;;; (>= (point) node-at-line-last) +;;; nil) + ;; Write last node: + (setq this-m2 next-m2) + (setq current-level next-level) + (setq next-node-start (if node-at-line-last + (1+ node-at-line-last) + (point-max))) + (setq num-left-nodes (org-freemind-write-node mm-buffer drawers-regexp num-left-nodes base-level current-level next-level this-m2 this-node-end this-children-visible next-node-start next-has-some-visible-child)) + (with-current-buffer mm-buffer (insert "</node>\n")) + ;) + ) + (with-current-buffer mm-buffer + (while (> current-level base-level) + (insert "</node>\n") + (setq current-level + (- current-level (if odd-only 2 1))) + )) + (with-current-buffer mm-buffer + (insert "</map>") + (delete-trailing-whitespace) + (goto-char (point-min)) + )))))) + +(defun org-freemind-get-node-style (node-name) + "NOT READY YET." + ;;<node BACKGROUND_COLOR="#eeee00" CREATED="1234668815593" MODIFIED="1234668815593" STYLE="bubble"> + ;;<font BOLD="true" NAME="SansSerif" SIZE="12"/> + (let (node-styles + node-style) + (dolist (style-list org-freemind-node-style) + (let ((node-regexp (car style-list))) + (message "node-regexp=%s node-name=%s" node-regexp node-name) + (when (string-match-p node-regexp node-name) + ;;(setq node-style (org-freemind-do-apply-node-style style-list)) + (setq node-style (cadr style-list)) + (when node-style + (message "node-style=%s" node-style) + (setq node-styles (append node-styles node-style))) + ))))) + +(defun org-freemind-do-apply-node-style (style-list) + (message "style-list=%S" style-list) + (let ((node-style 'fork) + (color "red") + (background-color "yellow") + (edge-color "green") + (edge-style 'bezier) + (edge-width 'thin) + (italic t) + (bold t) + (font-name "SansSerif") + (font-size 12)) + (dolist (style (cadr style-list)) + (message " style=%s" style) + (let ((what (car style))) + (cond + ((eq what 'node-style) + (setq node-style (cadr style))) + ((eq what 'color) + (setq color (cadr style))) + ((eq what 'background-color) + (setq background-color (cadr style))) + + ((eq what 'edge-color) + (setq edge-color (cadr style))) + + ((eq what 'edge-style) + (setq edge-style (cadr style))) + + ((eq what 'edge-width) + (setq edge-width (cadr style))) + + ((eq what 'italic) + (setq italic (cadr style))) + + ((eq what 'bold) + (setq bold (cadr style))) + + ((eq what 'font-name) + (setq font-name (cadr style))) + + ((eq what 'font-size) + (setq font-size (cadr style))) + ) + (insert (format " style=\"%s\"" node-style)) + (insert (format " color=\"%s\"" color)) + (insert (format " background_color=\"%s\"" background-color)) + (insert ">\n") + (insert "<edge") + (insert (format " color=\"%s\"" edge-color)) + (insert (format " style=\"%s\"" edge-style)) + (insert (format " width=\"%s\"" edge-width)) + (insert "/>\n") + (insert "<font") + (insert (format " italic=\"%s\"" italic)) + (insert (format " bold=\"%s\"" bold)) + (insert (format " name=\"%s\"" font-name)) + (insert (format " size=\"%s\"" font-size)) + )))) + +;;;###autoload +(defun org-freemind-from-org-mode-node (node-line mm-file) + "Convert node at line NODE-LINE to the FreeMind file MM-FILE. +See `org-freemind-from-org-mode' for more information." + (interactive + (progn + (unless (org-back-to-heading nil) + (error "Can't find org-mode node start")) + (let* ((line (line-number-at-pos)) + (default-mm-file (concat (if buffer-file-name + (file-name-nondirectory buffer-file-name) + "nofile") + "-line-" (number-to-string line) + ".mm")) + (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file))) + (list line mm-file)))) + (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any)) + (let ((org-buffer (current-buffer)) + (mm-buffer (find-file-noselect mm-file))) + (org-freemind-write-mm-buffer org-buffer mm-buffer node-line) + (with-current-buffer mm-buffer + (basic-save-buffer) + (when (org-called-interactively-p 'any) + (switch-to-buffer-other-window mm-buffer) + (when (y-or-n-p "Show in FreeMind? ") + (org-freemind-show buffer-file-name))))))) + +;;;###autoload +(defun org-freemind-from-org-mode (org-file mm-file) + "Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE. +All the nodes will be opened or closed in Freemind just as you +have them in `org-mode'. + +Note that exporting to Freemind also gives you an alternative way +to export from `org-mode' to html. You can create a dynamic html +version of the your org file, by first exporting to Freemind and +then exporting from Freemind to html. The 'As +XHTML (JavaScript)' version in Freemind works very well \(and you +can use a CSS stylesheet to style it)." + ;; Fix-me: better doc, include recommendations etc. + (interactive + (let* ((org-file buffer-file-name) + (default-mm-file (concat + (if org-file + (file-name-nondirectory org-file) + "nofile") + ".mm")) + (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file))) + (list org-file mm-file))) + (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any)) + (let ((org-buffer (if org-file (find-file-noselect org-file) (current-buffer))) + (mm-buffer (find-file-noselect mm-file))) + (org-freemind-write-mm-buffer org-buffer mm-buffer nil) + (with-current-buffer mm-buffer + (basic-save-buffer) + (when (org-called-interactively-p 'any) + (switch-to-buffer-other-window mm-buffer) + (when (y-or-n-p "Show in FreeMind? ") + (org-freemind-show buffer-file-name))))))) + +;;;###autoload +(defun org-freemind-from-org-sparse-tree (org-buffer mm-file) + "Convert visible part of buffer ORG-BUFFER to FreeMind file MM-FILE." + (interactive + (let* ((org-file buffer-file-name) + (default-mm-file (concat + (if org-file + (file-name-nondirectory org-file) + "nofile") + "-sparse.mm")) + (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file))) + (list (current-buffer) mm-file))) + (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any)) + (let (org-buffer + (mm-buffer (find-file-noselect mm-file))) + (save-window-excursion + (org-export-visible ?\ nil) + (setq org-buffer (current-buffer))) + (org-freemind-write-mm-buffer org-buffer mm-buffer nil) + (with-current-buffer mm-buffer + (basic-save-buffer) + (when (org-called-interactively-p 'any) + (switch-to-buffer-other-window mm-buffer) + (when (y-or-n-p "Show in FreeMind? ") + (org-freemind-show buffer-file-name))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; FreeMind => Org + +;; (sort '(b a c) 'org-freemind-lt-symbols) +(defun org-freemind-lt-symbols (sym-a sym-b) + (string< (symbol-name sym-a) (symbol-name sym-b))) +;; (sort '((b . 1) (a . 2) (c . 3)) 'org-freemind-lt-xml-attrs) +(defun org-freemind-lt-xml-attrs (attr-a attr-b) + (string< (symbol-name (car attr-a)) (symbol-name (car attr-b)))) + +;; xml-parse-region gives things like +;; ((p nil "\n" +;; (a +;; ((href . "link")) +;; "text") +;; "\n" +;; (b nil "hej") +;; "\n")) + +;; '(a . nil) + +;; (org-freemind-symbols= 'a (car '(A B))) +(defsubst org-freemind-symbols= (sym-a sym-b) + "Return t if downcased names of SYM-A and SYM-B are equal. +SYM-A and SYM-B should be symbols." + (or (eq sym-a sym-b) + (string= (downcase (symbol-name sym-a)) + (downcase (symbol-name sym-b))))) + +(defun org-freemind-get-children (parent path) + "Find children node to PARENT from PATH. +PATH should be a list of steps, where each step has the form + + '(NODE-NAME (ATTR-NAME . ATTR-VALUE))" + ;; Fix-me: maybe implement op? step: Name, number, attr, attr op val + ;; Fix-me: case insensitive version for children? + (let* ((children (if (not (listp (car parent))) + (cddr parent) + (let (cs) + (dolist (p parent) + (dolist (c (cddr p)) + (add-to-list 'cs c))) + cs) + )) + (step (car path)) + (step-node (if (listp step) (car step) step)) + (step-attr-list (when (listp step) (sort (cdr step) 'org-freemind-lt-xml-attrs))) + (path-tail (cdr path)) + path-children) + (dolist (child children) + ;; skip xml.el formatting nodes + (unless (stringp child) + ;; compare node name + (when (if (not step-node) + t ;; any node name + (org-freemind-symbols= step-node (car child))) + (if (not step-attr-list) + ;;(throw 'path-child child) ;; no attr to care about + (add-to-list 'path-children child) + (let* ((child-attr-list (cadr child)) + (step-attr-copy (copy-sequence step-attr-list))) + (dolist (child-attr child-attr-list) + ;; Compare attr names: + (when (org-freemind-symbols= (caar step-attr-copy) (car child-attr)) + ;; Compare values: + (let ((step-val (cdar step-attr-copy)) + (child-val (cdr child-attr))) + (when (if (not step-val) + t ;; any value + (string= step-val child-val)) + (setq step-attr-copy (cdr step-attr-copy)))))) + ;; Did we find all? + (unless step-attr-copy + ;;(throw 'path-child child) + (add-to-list 'path-children child) + )))))) + (if path-tail + (org-freemind-get-children path-children path-tail) + path-children))) + +(defun org-freemind-get-richcontent-node (node) + (let ((rc-nodes + (org-freemind-get-children node '((richcontent (type . "NODE")) html body)))) + (when (> (length rc-nodes) 1) + (lwarn t :warning "Unexpected structure: several <richcontent type=\"NODE\" ...>")) + (car rc-nodes))) + +(defun org-freemind-get-richcontent-note (node) + (let ((rc-notes + (org-freemind-get-children node '((richcontent (type . "NOTE")) html body)))) + (when (> (length rc-notes) 1) + (lwarn t :warning "Unexpected structure: several <richcontent type=\"NOTE\" ...>")) + (car rc-notes))) + +(defun org-freemind-test-get-tree-text () + (let ((node '(p nil "\n" + (a + ((href . "link")) + "text") + "\n" + (b nil "hej") + "\n"))) + (org-freemind-get-tree-text node))) +;; (org-freemind-test-get-tree-text) + +(defun org-freemind-get-tree-text (node) + (when node + (let ((ntxt "") + (link nil) + (lf-after nil)) + (dolist (n node) + (case n + ;;(a (setq is-link t) ) + ((h1 h2 h3 h4 h5 h6 p) + ;;(setq ntxt (concat "\n" ntxt)) + (setq lf-after 2) + ) + (br + (setq lf-after 1) + ) + (t + (cond + ((stringp n) + (when (string= n "\n") (setq n "")) + (if link + (setq ntxt (concat ntxt + "[[" link "][" n "]]")) + (setq ntxt (concat ntxt n)))) + ((and n (listp n)) + (if (symbolp (car n)) + (setq ntxt (concat ntxt (org-freemind-get-tree-text n))) + ;; This should be the attributes: + (dolist (att-val n) + (let ((att (car att-val)) + (val (cdr att-val))) + (when (eq att 'href) + (setq link val))))) + ))))) + (if lf-after + (setq ntxt (concat ntxt (make-string lf-after ?\n))) + (setq ntxt (concat ntxt " "))) + ;;(setq ntxt (concat ntxt (format "{%s}" n))) + ntxt))) + +(defun org-freemind-get-richcontent-node-text (node) + "Get the node text as from the richcontent node NODE." + (save-match-data + (let* ((rc (org-freemind-get-richcontent-node node)) + (txt (org-freemind-get-tree-text rc))) + ;;(when txt (setq txt (replace-regexp-in-string "[[:space:]]+" " " txt))) + txt + ))) + +(defun org-freemind-get-richcontent-note-text (node) + "Get the node text as from the richcontent note NODE." + (save-match-data + (let* ((rc (org-freemind-get-richcontent-note node)) + (txt (when rc (org-freemind-get-tree-text rc)))) + ;;(when txt (setq txt (replace-regexp-in-string "[[:space:]]+" " " txt))) + txt + ))) + +(defun org-freemind-get-icon-names (node) + (let* ((icon-nodes (org-freemind-get-children node '((icon )))) + names) + (dolist (icn icon-nodes) + (setq names (cons (cdr (assq 'builtin (cadr icn))) names))) + ;; (icon (builtin . "full-1")) + names)) + +(defun org-freemind-node-to-org (node level skip-levels) + (let ((qname (car node)) + (attributes (cadr node)) + text + ;; Fix-me: note is never inserted + (note (org-freemind-get-richcontent-note-text node)) + (mark "-- This is more about ") + (icons (org-freemind-get-icon-names node)) + (children (cddr node))) + (when (< 0 (- level skip-levels)) + (dolist (attrib attributes) + (case (car attrib) + ('TEXT (setq text (cdr attrib))) + ('text (setq text (cdr attrib))))) + (unless text + ;; There should be a richcontent node holding the text: + (setq text (org-freemind-get-richcontent-node-text node))) + (when icons + (when (member "full-1" icons) (setq text (concat "[#A] " text))) + (when (member "full-2" icons) (setq text (concat "[#B] " text))) + (when (member "full-3" icons) (setq text (concat "[#C] " text))) + (when (member "full-4" icons) (setq text (concat "[#D] " text))) + (when (member "full-5" icons) (setq text (concat "[#E] " text))) + (when (member "full-6" icons) (setq text (concat "[#F] " text))) + (when (member "full-7" icons) (setq text (concat "[#G] " text))) + (when (member "button_cancel" icons) (setq text (concat "TODO " text))) + ) + (if (and note + (string= mark (substring note 0 (length mark)))) + (progn + (setq text (replace-regexp-in-string "\n $" "" text)) + (insert text)) + (case qname + ('node + (insert (make-string (- level skip-levels) ?*) " " text "\n") + (when note + (insert ":COMMENT:\n" note "\n:END:\n")) + )))) + (dolist (child children) + (unless (or (null child) + (stringp child)) + (org-freemind-node-to-org child (1+ level) skip-levels))))) + +;; Fix-me: put back special things, like drawers that are stored in +;; the notes. Should maybe all notes contents be put in drawers? +;;;###autoload +(defun org-freemind-to-org-mode (mm-file org-file) + "Convert FreeMind file MM-FILE to `org-mode' file ORG-FILE." + (interactive + (save-match-data + (let* ((mm-file (buffer-file-name)) + (default-org-file (concat (file-name-nondirectory mm-file) ".org")) + (org-file (read-file-name "Output org-mode file: " nil nil nil default-org-file))) + (list mm-file org-file)))) + (when (org-freemind-check-overwrite org-file (org-called-interactively-p 'any)) + (let ((mm-buffer (find-file-noselect mm-file)) + (org-buffer (find-file-noselect org-file))) + (with-current-buffer mm-buffer + (let* ((xml-list (xml-parse-file mm-file)) + (top-node (cadr (cddar xml-list))) + (note (org-freemind-get-richcontent-note-text top-node)) + (skip-levels + (if (and note + (string-match "^--org-mode: WHOLE FILE$" note)) + 1 + 0))) + (with-current-buffer org-buffer + (erase-buffer) + (org-freemind-node-to-org top-node 1 skip-levels) + (goto-char (point-min)) + (org-set-tags t t) ;; Align all tags + ) + (switch-to-buffer-other-window org-buffer) + ))))) + +(provide 'org-freemind) + +;; arch-tag: e7b0d776-94fd-404a-b35e-0f855fae3627 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; org-freemind.el ends here |