babel: improve doc strings for org-babel-execute-buffer and org-babel-execute-subtree
[rgr-org-mode.git] / lisp / org-freemind.el
blobbc13648cf12629b9256180919e7f912b2f686114
1 ;;; org-freemind.el --- Export Org files to freemind
3 ;; Copyright (C) 2009 Free Software Foundation, Inc.
5 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
6 ;; Keywords: outlines, hypermedia, calendar, wp
7 ;; Homepage: http://orgmode.org
8 ;; Version: 6.34
9 ;;
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; --------------------------------------------------------------------
26 ;; Features that might be required by this library:
28 ;; `backquote', `bytecomp', `cl', `easymenu', `font-lock',
29 ;; `noutline', `org', `org-compat', `org-faces', `org-footnote',
30 ;; `org-list', `org-macs', `org-src', `outline', `syntax',
31 ;; `time-date', `xml'.
33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35 ;;; Commentary:
37 ;; This file tries to implement some functions useful for
38 ;; transformation between org-mode and FreeMind files.
40 ;; Here are the commands you can use:
42 ;; M-x `org-freemind-from-org-mode'
43 ;; M-x `org-freemind-from-org-mode-node'
44 ;; M-x `org-freemind-from-org-sparse-tree'
46 ;; M-x `org-freemind-to-org-mode'
48 ;; M-x `org-freemind-show'
50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 ;;; Change log:
54 ;; 2009-02-15: Added check for next level=current+1
55 ;; 2009-02-21: Fixed bug in `org-freemind-to-org-mode'.
56 ;; 2009-10-25: Added support for `org-odd-levels-only'.
57 ;; Added y/n question before showing in FreeMind.
58 ;; 2009-11-04: Added support for #+BEGIN_HTML.
61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
63 ;; This program is free software; you can redistribute it and/or
64 ;; modify it under the terms of the GNU General Public License as
65 ;; published by the Free Software Foundation; either version 2, or
66 ;; (at your option) any later version.
68 ;; This program is distributed in the hope that it will be useful,
69 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
70 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
71 ;; General Public License for more details.
73 ;; You should have received a copy of the GNU General Public License
74 ;; along with this program; see the file COPYING. If not, write to
75 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
76 ;; Floor, Boston, MA 02110-1301, USA.
78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80 ;;; Code:
82 (require 'xml)
83 (require 'org)
84 (require 'org-exp)
85 (eval-when-compile (require 'cl))
87 ;; Fix-me: I am not sure these are useful:
89 ;; (defcustom org-freemind-main-fgcolor "black"
90 ;; "Color of main node's text."
91 ;; :type 'color
92 ;; :group 'freemind)
94 ;; (defcustom org-freemind-main-color "black"
95 ;; "Background color of main node."
96 ;; :type 'color
97 ;; :group 'freemind)
99 ;; (defcustom org-freemind-child-fgcolor "black"
100 ;; "Color of child nodes' text."
101 ;; :type 'color
102 ;; :group 'freemind)
104 ;; (defcustom org-freemind-child-color "black"
105 ;; "Background color of child nodes."
106 ;; :type 'color
107 ;; :group 'freemind)
109 (defvar org-freemind-node-style nil "Internal use.")
111 (defcustom org-freemind-node-styles nil
112 "Styles to apply to node.
113 NOT READY YET."
114 :type '(repeat
115 (list :tag "Node styles for file"
116 (regexp :tag "File name")
117 (repeat
118 (list :tag "Node"
119 (regexp :tag "Node name regexp")
120 (set :tag "Node properties"
121 (list :format "%v" (const :format "" node-style)
122 (choice :tag "Style"
123 :value bubble
124 (const bubble)
125 (const fork)))
126 (list :format "%v" (const :format "" color)
127 (color :tag "Color" :value "red"))
128 (list :format "%v" (const :format "" background-color)
129 (color :tag "Background color" :value "yellow"))
130 (list :format "%v" (const :format "" edge-color)
131 (color :tag "Edge color" :value "green"))
132 (list :format "%v" (const :format "" edge-style)
133 (choice :tag "Edge style" :value bezier
134 (const :tag "Linear" linear)
135 (const :tag "Bezier" bezier)
136 (const :tag "Sharp Linear" sharp-linear)
137 (const :tag "Sharp Bezier" sharp-bezier)))
138 (list :format "%v" (const :format "" edge-width)
139 (choice :tag "Edge width" :value thin
140 (const :tag "Parent" parent)
141 (const :tag "Thin" thin)
142 (const 1)
143 (const 2)
144 (const 4)
145 (const 8)))
146 (list :format "%v" (const :format "" italic)
147 (const :tag "Italic font" t))
148 (list :format "%v" (const :format "" bold)
149 (const :tag "Bold font" t))
150 (list :format "%v" (const :format "" font-name)
151 (string :tag "Font name" :value "SansSerif"))
152 (list :format "%v" (const :format "" font-size)
153 (integer :tag "Font size" :value 12)))))))
154 :group 'freemind)
156 ;;;###autoload
157 (defun org-export-as-freemind (arg &optional hidden ext-plist
158 to-buffer body-only pub-dir)
159 (interactive "P")
160 (let* ((opt-plist (org-combine-plists (org-default-export-plist)
161 ext-plist
162 (org-infile-export-plist)))
163 (region-p (org-region-active-p))
164 (rbeg (and region-p (region-beginning)))
165 (rend (and region-p (region-end)))
166 (subtree-p
167 (if (plist-get opt-plist :ignore-subtree-p)
169 (when region-p
170 (save-excursion
171 (goto-char rbeg)
172 (and (org-at-heading-p)
173 (>= (org-end-of-subtree t t) rend))))))
174 (opt-plist (setq org-export-opt-plist
175 (if subtree-p
176 (org-export-add-subtree-options opt-plist rbeg)
177 opt-plist)))
178 (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer))))
179 (filename (concat (file-name-as-directory
180 (or pub-dir
181 (org-export-directory :ascii opt-plist)))
182 (file-name-sans-extension
183 (or (and subtree-p
184 (org-entry-get (region-beginning)
185 "EXPORT_FILE_NAME" t))
186 (file-name-nondirectory bfname)))
187 ".mm")))
188 (when (file-exists-p filename)
189 (delete-file filename))
190 (cond
191 (subtree-p
192 (org-freemind-from-org-mode-node (line-number-at-pos rbeg)
193 filename))
194 (t (org-freemind-from-org-mode bfname filename)))))
196 ;;;###autoload
197 (defun org-freemind-show (mm-file)
198 "Show file MM-FILE in Freemind."
199 (interactive
200 (list
201 (save-match-data
202 (let ((name (read-file-name "FreeMind file: "
203 nil nil nil
204 (if (buffer-file-name)
205 (file-name-nondirectory (buffer-file-name))
207 ;; Fix-me: Is this an Emacs bug?
208 ;; This predicate function is never
209 ;; called.
210 (lambda (fn)
211 (string-match "^mm$" (file-name-extension fn))))))
212 (setq name (expand-file-name name))
213 name))))
214 (org-open-file mm-file))
216 (defconst org-freemind-org-nfix "--org-mode: ")
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
219 ;;; Format converters
221 (defun org-freemind-escape-str-from-org (org-str)
222 "Do some html-escaping of ORG-STR and return the result.
223 The characters \"&<> will be escaped."
224 (let ((chars (append org-str nil))
225 (fm-str ""))
226 (dolist (cc chars)
227 (setq fm-str
228 (concat fm-str
229 (if (< cc 256)
230 (cond
231 ((= cc ?\") "&quot;")
232 ((= cc ?\&) "&amp;")
233 ((= cc ?\<) "&lt;")
234 ((= cc ?\>) "&gt;")
235 (t (char-to-string cc)))
236 ;; Formatting as &#number; is maybe needed
237 ;; according to a bug report from kazuo
238 ;; fujimoto, but I have now instead added a xml
239 ;; processing instruction saying that the mm
240 ;; file is utf-8:
242 ;; (format "&#x%x;" (- cc ;; ?\x800))
243 (format "&#x%x;" (encode-char cc 'ucs))
244 ))))
245 fm-str))
247 ;;(org-freemind-unescape-str-to-org "&#x6d;A&#x224C;B&lt;C&#x3C;&#x3D;")
248 ;;(org-freemind-unescape-str-to-org "&#x3C;&lt;")
249 (defun org-freemind-unescape-str-to-org (fm-str)
250 "Do some html-unescaping of FM-STR and return the result.
251 This is the opposite of `org-freemind-escape-str-from-org' but it
252 will also unescape &#nn;."
253 (let ((org-str fm-str))
254 (setq org-str (replace-regexp-in-string "&quot;" "\"" org-str))
255 (setq org-str (replace-regexp-in-string "&amp;" "&" org-str))
256 (setq org-str (replace-regexp-in-string "&lt;" "<" org-str))
257 (setq org-str (replace-regexp-in-string "&gt;" ">" org-str))
258 (setq org-str (replace-regexp-in-string
259 "&#x\\([a-f0-9]\\{2,4\\}\\);"
260 (lambda (m)
261 (char-to-string
262 (+ (string-to-number (match-string 1 m) 16)
263 0 ;?\x800 ;; What is this for? Encoding?
265 org-str))))
267 ;; (org-freemind-test-escape)
268 (defun org-freemind-test-escape ()
269 (let* ((str1 "a quote: \", an amp: &, lt: <; over 256: öåäÖÅÄ")
270 (str2 (org-freemind-escape-str-from-org str1))
271 (str3 (org-freemind-unescape-str-to-org str2))
273 (unless (string= str1 str3)
274 (error "str3=%s" str3))
277 (defun org-freemind-convert-links-from-org (org-str)
278 "Convert org links in ORG-STR to freemind links and return the result."
279 (let ((fm-str (replace-regexp-in-string
280 (rx (not (any "[\""))
281 (submatch
282 "http"
283 (opt ?\s)
284 "://"
286 (any "-%.?@a-zA-Z0-9()_/:~=&#"))))
287 "[[\\1][\\1]]"
288 org-str)))
289 (replace-regexp-in-string (rx "[["
290 (submatch (*? nonl))
291 "]["
292 (submatch (*? nonl))
293 "]]")
294 "<a href=\"\\1\">\\2</a>"
295 fm-str)))
297 ;;(org-freemind-convert-links-to-org "<a href=\"http://www.somewhere/\">link-text</a>")
298 (defun org-freemind-convert-links-to-org (fm-str)
299 "Convert freemind links in FM-STR to org links and return the result."
300 (let ((org-str (replace-regexp-in-string
301 (rx "<a"
302 space
304 (0+ (not (any ">")))
305 space)
306 "href=\""
307 (submatch (0+ (not (any "\""))))
308 "\""
309 (0+ (not (any ">")))
311 (submatch (0+ (not (any "<"))))
312 "</a>")
313 "[[\\1][\\2]]"
314 fm-str)))
315 org-str))
317 ;; Fix-me:
318 ;;(defun org-freemind-convert-drawers-from-org (text)
319 ;; )
321 ;; (org-freemind-test-links)
322 ;; (defun org-freemind-test-links ()
323 ;; (let* ((str1 "[[http://www.somewhere/][link-text]")
324 ;; (str2 (org-freemind-convert-links-from-org str1))
325 ;; (str3 (org-freemind-convert-links-to-org str2))
326 ;; )
327 ;; (unless (string= str1 str3)
328 ;; (error "str3=%s" str3))
329 ;; ))
331 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
332 ;;; Org => FreeMind
334 (defun org-freemind-convert-text-p (text)
335 "Convert TEXT to html with <p> paragraphs."
336 (setq text (org-freemind-escape-str-from-org text))
337 (setq text (replace-regexp-in-string (rx "\n" (0+ blank) "\n") "</p><p>\n" text))
338 ;;(setq text (replace-regexp-in-string (rx bol (1+ blank) eol) "" text))
339 ;;(setq text (replace-regexp-in-string (rx bol (1+ blank)) "<br />" text))
340 (setq text (replace-regexp-in-string "\n" "<br />" text))
341 (concat "<p>"
342 (org-freemind-convert-links-from-org text)
343 "</p>\n"))
345 (defun org-freemind-org-text-to-freemind-subnode/note (node-name start end drawers-regexp)
346 "Convert text part of org node to freemind subnode or note.
347 Convert the text part of the org node named NODE-NAME. The text
348 is in the current buffer between START and END. Drawers matching
349 DRAWERS-REGEXP are converted to freemind notes."
350 ;; fix-me: doc
351 (let ((text (buffer-substring-no-properties start end))
352 (node-res "")
353 (note-res ""))
354 (save-match-data
355 ;;(setq text (org-freemind-escape-str-from-org text))
356 ;; First see if there is something that should be moved to the
357 ;; note part:
358 (let (drawers)
359 (while (string-match drawers-regexp text)
360 (setq drawers (cons (match-string 0 text) drawers))
361 (setq text
362 (concat (substring text 0 (match-beginning 0))
363 (substring text (match-end 0))))
365 (when drawers
366 (dolist (drawer drawers)
367 (let ((lines (split-string drawer "\n")))
368 (dolist (line lines)
369 (setq note-res (concat
370 note-res
371 org-freemind-org-nfix line "<br />\n")))
372 ))))
374 (when (> (length note-res) 0)
375 (setq note-res (concat
376 "<richcontent TYPE=\"NOTE\"><html>\n"
377 "<head>\n"
378 "</head>\n"
379 "<body>\n"
380 note-res
381 "</body>\n"
382 "</html>\n"
383 "</richcontent>\n"))
386 ;; There is always an LF char:
387 (when (> (length text) 1)
388 (setq node-res (concat
389 "<node style=\"bubble\" background_color=\"#eeee00\">\n"
390 "<richcontent TYPE=\"NODE\"><html>\n"
391 "<head>\n"
392 "<style type=\"text/css\">\n"
393 "<!--\n"
394 "p { margin-top: 0 }\n"
395 "-->\n"
396 "</style>\n"
397 "</head>\n"
398 "<body>\n"))
399 (let ((begin-html-mark (regexp-quote "#+BEGIN_HTML"))
400 (end-html-mark (regexp-quote "#+END_HTML"))
401 head
402 end-pos
403 end-pos-match
405 ;; Take care of #+BEGIN_HTML - #+END_HTML
406 (while (string-match begin-html-mark text)
407 (setq head (substring text 0 (match-beginning 0)))
408 (setq end-pos-match (match-end 0))
409 (setq node-res (concat node-res
410 (org-freemind-convert-text-p head)))
411 (setq text (substring text end-pos-match))
412 (setq end-pos (string-match end-html-mark text))
413 (if end-pos
414 (setq end-pos-match (match-end 0))
415 (message "org-freemind: Missing #+END_HTML")
416 (setq end-pos (length text))
417 (setq end-pos-match end-pos))
418 (setq node-res (concat node-res
419 (substring text 0 end-pos)))
420 (setq text (substring text end-pos-match)))
421 (setq node-res (concat node-res
422 (org-freemind-convert-text-p text))))
423 (setq node-res (concat
424 node-res
425 "</body>\n"
426 "</html>\n"
427 "</richcontent>\n"
428 ;; Put a note that this is for the parent node
429 "<richcontent TYPE=\"NOTE\"><html>"
430 "<head>"
431 "</head>"
432 "<body>"
433 "<p>"
434 "-- This is more about \"" node-name "\" --"
435 "</p>"
436 "</body>"
437 "</html>"
438 "</richcontent>\n"
439 "</node>\n" ;; ok
441 (list node-res note-res))))
443 (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)
444 (let* (this-icons
445 this-bg-color
446 this-m2-escaped
447 this-rich-node
448 this-rich-note
450 (when (string-match "TODO" this-m2)
451 (setq this-m2 (replace-match "" nil nil this-m2))
452 (add-to-list 'this-icons "button_cancel")
453 (setq this-bg-color "#ffff88")
454 (when (string-match "\\[#\\(.\\)\\]" this-m2)
455 (let ((prior (string-to-char (match-string 1 this-m2))))
456 (setq this-m2 (replace-match "" nil nil this-m2))
457 (cond
458 ((= prior ?A)
459 (add-to-list 'this-icons "full-1")
460 (setq this-bg-color "#ff0000"))
461 ((= prior ?B)
462 (add-to-list 'this-icons "full-2")
463 (setq this-bg-color "#ffaa00"))
464 ((= prior ?C)
465 (add-to-list 'this-icons "full-3")
466 (setq this-bg-color "#ffdd00"))
467 ((= prior ?D)
468 (add-to-list 'this-icons "full-4")
469 (setq this-bg-color "#ffff00"))
470 ((= prior ?E)
471 (add-to-list 'this-icons "full-5"))
472 ((= prior ?F)
473 (add-to-list 'this-icons "full-6"))
474 ((= prior ?G)
475 (add-to-list 'this-icons "full-7"))
476 ))))
477 (setq this-m2 (org-trim this-m2))
478 (setq this-m2-escaped (org-freemind-escape-str-from-org this-m2))
479 (let ((node-notes (org-freemind-org-text-to-freemind-subnode/note
480 this-m2-escaped
481 this-node-end
482 (1- next-node-start)
483 drawers-regexp)))
484 (setq this-rich-node (nth 0 node-notes))
485 (setq this-rich-note (nth 1 node-notes)))
486 (with-current-buffer mm-buffer
487 (insert "<node text=\"" this-m2-escaped "\"")
488 (org-freemind-get-node-style this-m2)
489 (when (> next-level current-level)
490 (unless (or this-children-visible
491 next-has-some-visible-child)
492 (insert " folded=\"true\"")))
493 (when (and (= current-level (1+ base-level))
494 (> num-left-nodes 0))
495 (setq num-left-nodes (1- num-left-nodes))
496 (insert " position=\"left\""))
497 (when this-bg-color
498 (insert " background_color=\"" this-bg-color "\""))
499 (insert ">\n")
500 (when this-icons
501 (dolist (icon this-icons)
502 (insert "<icon builtin=\"" icon "\"/>\n")))
504 (with-current-buffer mm-buffer
505 (when this-rich-note (insert this-rich-note))
506 (when this-rich-node (insert this-rich-node))))
507 num-left-nodes)
509 (defun org-freemind-check-overwrite (file interactively)
510 "Check if file FILE already exists.
511 If FILE does not exists return t.
513 If INTERACTIVELY is non-nil ask if the file should be replaced
514 and return t/nil if it should/should not be replaced.
516 Otherwise give an error say the file exists."
517 (if (file-exists-p file)
518 (if interactively
519 (y-or-n-p (format "File %s exists, replace it? " file))
520 (error "File %s already exists" file))
523 (defvar org-freemind-node-pattern (rx bol
524 (submatch (1+ "*"))
525 (1+ space)
526 (submatch (*? nonl))
527 eol))
529 (defun org-freemind-look-for-visible-child (node-level)
530 (save-excursion
531 (save-match-data
532 (let ((found-visible-child nil))
533 (while (and (not found-visible-child)
534 (re-search-forward org-freemind-node-pattern nil t))
535 (let* ((m1 (match-string-no-properties 1))
536 (level (length m1)))
537 (if (>= node-level level)
538 (setq found-visible-child 'none)
539 (unless (get-char-property (line-beginning-position) 'invisible)
540 (setq found-visible-child 'found)))))
541 (eq found-visible-child 'found)
542 ))))
544 (defun org-freemind-goto-line (line)
545 "Go to line number LINE."
546 (save-restriction
547 (widen)
548 (goto-char (point-min))
549 (forward-line (1- line))))
551 (defun org-freemind-write-mm-buffer (org-buffer mm-buffer node-at-line)
552 (with-current-buffer org-buffer
553 (dolist (node-style org-freemind-node-styles)
554 (when (string-match-p (car node-style) buffer-file-name)
555 (setq org-freemind-node-style (cadr node-style))))
556 ;;(message "org-freemind-node-style =%s" org-freemind-node-style)
557 (save-match-data
558 (let* ((drawers (copy-sequence org-drawers))
559 drawers-regexp
560 (num-top1-nodes 0)
561 (num-top2-nodes 0)
562 num-left-nodes
563 (unclosed-nodes 0)
564 (first-time t)
565 (current-level 1)
566 base-level
567 skipping-odd
568 (skipped-odd 0)
569 prev-node-end
570 rich-text
571 unfinished-tag
572 node-at-line-level
573 node-at-line-last)
574 (with-current-buffer mm-buffer
575 (erase-buffer)
576 (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
577 (insert "<map version=\"0.9.0\">\n")
578 (insert "<!-- To view this file, download free mind mapping software FreeMind from http://freemind.sourceforge.net -->\n"))
579 (save-excursion
580 ;; Get special buffer vars:
581 (goto-char (point-min))
582 (while (re-search-forward (rx bol "#+DRAWERS:") nil t)
583 (let ((dr-txt (buffer-substring-no-properties (match-end 0) (line-end-position))))
584 (setq drawers (append drawers (split-string dr-txt) nil))))
585 (setq drawers-regexp
586 (concat (rx bol (0+ blank) ":")
587 (regexp-opt drawers)
588 (rx ":" (0+ blank)
589 "\n"
590 (*? anything)
591 "\n"
592 (0+ blank)
593 ":END:"
594 (0+ blank)
595 eol)
598 (if node-at-line
599 ;; Get number of top nodes and last line for this node
600 (progn
601 (org-freemind-goto-line node-at-line)
602 (unless (looking-at org-freemind-node-pattern)
603 (error "No node at line %s" node-at-line))
604 (setq node-at-line-level (length (match-string-no-properties 1)))
605 (forward-line)
606 (setq node-at-line-last
607 (catch 'last-line
608 (while (re-search-forward org-freemind-node-pattern nil t)
609 (let* ((m1 (match-string-no-properties 1))
610 (level (length m1)))
611 (if (<= level node-at-line-level)
612 (progn
613 (beginning-of-line)
614 (throw 'last-line (1- (point))))
615 (if (= level (1+ node-at-line-level))
616 (setq num-top2-nodes (1+ num-top2-nodes))))))))
617 (setq current-level node-at-line-level)
618 (setq num-top1-nodes 1)
619 (org-freemind-goto-line node-at-line))
621 ;; First get number of top nodes
622 (goto-char (point-min))
623 (while (re-search-forward org-freemind-node-pattern nil t)
624 (let* ((m1 (match-string-no-properties 1))
625 (level (length m1)))
626 (if (= level 1)
627 (setq num-top1-nodes (1+ num-top1-nodes))
628 (if (= level 2)
629 (setq num-top2-nodes (1+ num-top2-nodes))))))
630 ;; If there is more than one top node we need to insert a node
631 ;; to keep them together.
632 (goto-char (point-min))
633 (when (> num-top1-nodes 1)
634 (setq num-top2-nodes num-top1-nodes)
635 (setq current-level 0)
636 (let ((orig-name (if buffer-file-name
637 (file-name-nondirectory (buffer-file-name))
638 (buffer-name))))
639 (with-current-buffer mm-buffer
640 (insert "<node text=\"" orig-name "\" background_color=\"#00bfff\">\n"
641 ;; Put a note that this is for the parent node
642 "<richcontent TYPE=\"NOTE\"><html>"
643 "<head>"
644 "</head>"
645 "<body>"
646 "<p>"
647 org-freemind-org-nfix "WHOLE FILE"
648 "</p>"
649 "</body>"
650 "</html>"
651 "</richcontent>\n")))))
653 (setq num-left-nodes (floor num-top2-nodes 2))
654 (setq base-level current-level)
655 (let (this-m2
656 this-node-end
657 this-children-visible
658 next-m2
659 next-node-start
660 next-level
661 next-has-some-visible-child
662 next-children-visible
664 (while (and
665 (re-search-forward org-freemind-node-pattern nil t)
666 (if node-at-line-last (<= (point) node-at-line-last) t)
668 (let* ((next-m1 (match-string-no-properties 1))
669 (next-node-end (match-end 0))
671 (setq next-node-start (match-beginning 0))
672 (setq next-m2 (match-string-no-properties 2))
673 (setq next-level (length next-m1))
674 (when (> next-level current-level)
675 (if (not (and org-odd-levels-only
676 (/= (mod current-level 2) 0)
677 (= next-level (+ 2 current-level))))
678 (setq skipping-odd nil)
679 (setq skipping-odd t)
680 (setq skipped-odd (1+ skipped-odd)))
681 (unless (or (= next-level (1+ current-level))
682 skipping-odd)
683 (if (or org-odd-levels-only
684 (/= next-level (+ 2 current-level)))
685 (error "Next level step > +1 for node ending at line %s" (line-number-at-pos))
686 (error "Next level step = +2 for node ending at line %s, forgot org-odd-levels-only?"
687 (line-number-at-pos)))
689 (setq next-children-visible
690 (not (eq 'outline
691 (get-char-property (line-end-position) 'invisible))))
692 (setq next-has-some-visible-child
693 (if next-children-visible t
694 (org-freemind-look-for-visible-child next-level)))
695 (when this-m2
696 (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)))
697 (when (if (= num-top1-nodes 1) (> current-level base-level) t)
698 (while (>= current-level next-level)
699 (with-current-buffer mm-buffer
700 (insert "</node>\n")
701 (setq current-level (1- current-level))
702 (when (< 0 skipped-odd)
703 (setq skipped-odd (1- skipped-odd))
704 (setq current-level (1- current-level)))
706 (setq this-node-end (1+ next-node-end))
707 (setq this-m2 next-m2)
708 (setq current-level next-level)
709 (setq this-children-visible next-children-visible)
710 (forward-char)
712 ;;; (unless (if node-at-line-last
713 ;;; (>= (point) node-at-line-last)
714 ;;; nil)
715 ;; Write last node:
716 (setq this-m2 next-m2)
717 (setq current-level next-level)
718 (setq next-node-start (if node-at-line-last
719 (1+ node-at-line-last)
720 (point-max)))
721 (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))
722 (with-current-buffer mm-buffer (insert "</node>\n"))
725 (with-current-buffer mm-buffer
726 (while (> current-level base-level)
727 (insert "</node>\n")
728 (setq current-level (1- current-level))
730 (with-current-buffer mm-buffer
731 (insert "</map>")
732 (delete-trailing-whitespace)
733 (goto-char (point-min))
734 ))))))
736 (defun org-freemind-get-node-style (node-name)
737 "NOT READY YET."
738 ;;<node BACKGROUND_COLOR="#eeee00" CREATED="1234668815593" MODIFIED="1234668815593" STYLE="bubble">
739 ;;<font BOLD="true" NAME="SansSerif" SIZE="12"/>
740 (let (node-styles
741 node-style)
742 (dolist (style-list org-freemind-node-style)
743 (let ((node-regexp (car style-list)))
744 (message "node-regexp=%s node-name=%s" node-regexp node-name)
745 (when (string-match-p node-regexp node-name)
746 ;;(setq node-style (org-freemind-do-apply-node-style style-list))
747 (setq node-style (cadr style-list))
748 (when node-style
749 (message "node-style=%s" node-style)
750 (setq node-styles (append node-styles node-style)))
751 )))))
753 (defun org-freemind-do-apply-node-style (style-list)
754 (message "style-list=%S" style-list)
755 (let ((node-style 'fork)
756 (color "red")
757 (background-color "yellow")
758 (edge-color "green")
759 (edge-style 'bezier)
760 (edge-width 'thin)
761 (italic t)
762 (bold t)
763 (font-name "SansSerif")
764 (font-size 12))
765 (dolist (style (cadr style-list))
766 (message " style=%s" style)
767 (let ((what (car style)))
768 (cond
769 ((eq what 'node-style)
770 (setq node-style (cadr style)))
771 ((eq what 'color)
772 (setq color (cadr style)))
773 ((eq what 'background-color)
774 (setq background-color (cadr style)))
776 ((eq what 'edge-color)
777 (setq edge-color (cadr style)))
779 ((eq what 'edge-style)
780 (setq edge-style (cadr style)))
782 ((eq what 'edge-width)
783 (setq edge-width (cadr style)))
785 ((eq what 'italic)
786 (setq italic (cadr style)))
788 ((eq what 'bold)
789 (setq bold (cadr style)))
791 ((eq what 'font-name)
792 (setq font-name (cadr style)))
794 ((eq what 'font-size)
795 (setq font-size (cadr style)))
797 (insert (format " style=\"%s\"" node-style))
798 (insert (format " color=\"%s\"" color))
799 (insert (format " background_color=\"%s\"" background-color))
800 (insert ">\n")
801 (insert "<edge")
802 (insert (format " color=\"%s\"" edge-color))
803 (insert (format " style=\"%s\"" edge-style))
804 (insert (format " width=\"%s\"" edge-width))
805 (insert "/>\n")
806 (insert "<font")
807 (insert (format " italic=\"%s\"" italic))
808 (insert (format " bold=\"%s\"" bold))
809 (insert (format " name=\"%s\"" font-name))
810 (insert (format " size=\"%s\"" font-size))
811 ))))
813 ;;;###autoload
814 (defun org-freemind-from-org-mode-node (node-line mm-file)
815 "Convert node at line NODE-LINE to the FreeMind file MM-FILE."
816 (interactive
817 (progn
818 (unless (org-back-to-heading nil)
819 (error "Can't find org-mode node start"))
820 (let* ((line (line-number-at-pos))
821 (default-mm-file (concat (if buffer-file-name
822 (file-name-nondirectory buffer-file-name)
823 "nofile")
824 "-line-" (number-to-string line)
825 ".mm"))
826 (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
827 (list line mm-file))))
828 (when (org-freemind-check-overwrite mm-file (called-interactively-p))
829 (let ((org-buffer (current-buffer))
830 (mm-buffer (find-file-noselect mm-file)))
831 (org-freemind-write-mm-buffer org-buffer mm-buffer node-line)
832 (with-current-buffer mm-buffer
833 (basic-save-buffer)
834 (when (called-interactively-p)
835 (switch-to-buffer-other-window mm-buffer)
836 (when (y-or-n-p "Show in FreeMind? ")
837 (org-freemind-show buffer-file-name)))))))
839 ;;;###autoload
840 (defun org-freemind-from-org-mode (org-file mm-file)
841 "Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE."
842 ;; Fix-me: better doc, include recommendations etc.
843 (interactive
844 (let* ((org-file buffer-file-name)
845 (default-mm-file (concat
846 (if org-file
847 (file-name-nondirectory org-file)
848 "nofile")
849 ".mm"))
850 (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
851 (list org-file mm-file)))
852 (when (org-freemind-check-overwrite mm-file (called-interactively-p))
853 (let ((org-buffer (if org-file (find-file-noselect org-file) (current-buffer)))
854 (mm-buffer (find-file-noselect mm-file)))
855 (org-freemind-write-mm-buffer org-buffer mm-buffer nil)
856 (with-current-buffer mm-buffer
857 (basic-save-buffer)
858 (when (called-interactively-p)
859 (switch-to-buffer-other-window mm-buffer)
860 (when (y-or-n-p "Show in FreeMind? ")
861 (org-freemind-show buffer-file-name)))))))
863 ;;;###autoload
864 (defun org-freemind-from-org-sparse-tree (org-buffer mm-file)
865 "Convert visible part of buffer ORG-BUFFER to FreeMind file MM-FILE."
866 (interactive
867 (let* ((org-file buffer-file-name)
868 (default-mm-file (concat
869 (if org-file
870 (file-name-nondirectory org-file)
871 "nofile")
872 "-sparse.mm"))
873 (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
874 (list (current-buffer) mm-file)))
875 (when (org-freemind-check-overwrite mm-file (called-interactively-p))
876 (let (org-buffer
877 (mm-buffer (find-file-noselect mm-file)))
878 (save-window-excursion
879 (org-export-visible ?\ nil)
880 (setq org-buffer (current-buffer)))
881 (org-freemind-write-mm-buffer org-buffer mm-buffer nil)
882 (with-current-buffer mm-buffer
883 (basic-save-buffer)
884 (when (called-interactively-p)
885 (switch-to-buffer-other-window mm-buffer)
886 (when (y-or-n-p "Show in FreeMind? ")
887 (org-freemind-show buffer-file-name)))))))
890 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
891 ;;; FreeMind => Org
893 ;; (sort '(b a c) 'org-freemind-lt-symbols)
894 (defun org-freemind-lt-symbols (sym-a sym-b)
895 (string< (symbol-name sym-a) (symbol-name sym-b)))
896 ;; (sort '((b . 1) (a . 2) (c . 3)) 'org-freemind-lt-xml-attrs)
897 (defun org-freemind-lt-xml-attrs (attr-a attr-b)
898 (string< (symbol-name (car attr-a)) (symbol-name (car attr-b))))
900 ;; xml-parse-region gives things like
901 ;; ((p nil "\n"
902 ;; (a
903 ;; ((href . "link"))
904 ;; "text")
905 ;; "\n"
906 ;; (b nil "hej")
907 ;; "\n"))
909 ;; '(a . nil)
911 ;; (org-freemind-symbols= 'a (car '(A B)))
912 (defsubst org-freemind-symbols= (sym-a sym-b)
913 "Return t if downcased names of SYM-A and SYM-B are equal.
914 SYM-A and SYM-B should be symbols."
915 (or (eq sym-a sym-b)
916 (string= (downcase (symbol-name sym-a))
917 (downcase (symbol-name sym-b)))))
919 (defun org-freemind-get-children (parent path)
920 "Find children node to PARENT from PATH.
921 PATH should be a list of steps, where each step has the form
923 '(NODE-NAME (ATTR-NAME . ATTR-VALUE))"
924 ;; Fix-me: maybe implement op? step: Name, number, attr, attr op val
925 ;; Fix-me: case insensitive version for children?
926 (let* ((children (if (not (listp (car parent)))
927 (cddr parent)
928 (let (cs)
929 (dolist (p parent)
930 (dolist (c (cddr p))
931 (add-to-list 'cs c)))
934 (step (car path))
935 (step-node (if (listp step) (car step) step))
936 (step-attr-list (when (listp step) (sort (cdr step) 'org-freemind-lt-xml-attrs)))
937 (path-tail (cdr path))
938 path-children)
939 (dolist (child children)
940 ;; skip xml.el formatting nodes
941 (unless (stringp child)
942 ;; compare node name
943 (when (if (not step-node)
944 t ;; any node name
945 (org-freemind-symbols= step-node (car child)))
946 (if (not step-attr-list)
947 ;;(throw 'path-child child) ;; no attr to care about
948 (add-to-list 'path-children child)
949 (let* ((child-attr-list (cadr child))
950 (step-attr-copy (copy-sequence step-attr-list)))
951 (dolist (child-attr child-attr-list)
952 ;; Compare attr names:
953 (when (org-freemind-symbols= (caar step-attr-copy) (car child-attr))
954 ;; Compare values:
955 (let ((step-val (cdar step-attr-copy))
956 (child-val (cdr child-attr)))
957 (when (if (not step-val)
958 t ;; any value
959 (string= step-val child-val))
960 (setq step-attr-copy (cdr step-attr-copy))))))
961 ;; Did we find all?
962 (unless step-attr-copy
963 ;;(throw 'path-child child)
964 (add-to-list 'path-children child)
965 ))))))
966 (if path-tail
967 (org-freemind-get-children path-children path-tail)
968 path-children)))
970 (defun org-freemind-get-richcontent-node (node)
971 (let ((rc-nodes
972 (org-freemind-get-children node '((richcontent (type . "NODE")) html body))))
973 (when (> (length rc-nodes) 1)
974 (lwarn t :warning "Unexpected structure: several <richcontent type=\"NODE\" ...>"))
975 (car rc-nodes)))
977 (defun org-freemind-get-richcontent-note (node)
978 (let ((rc-notes
979 (org-freemind-get-children node '((richcontent (type . "NOTE")) html body))))
980 (when (> (length rc-notes) 1)
981 (lwarn t :warning "Unexpected structure: several <richcontent type=\"NOTE\" ...>"))
982 (car rc-notes)))
984 (defun org-freemind-test-get-tree-text ()
985 (let ((node '(p nil "\n"
987 ((href . "link"))
988 "text")
989 "\n"
990 (b nil "hej")
991 "\n")))
992 (org-freemind-get-tree-text node)))
993 ;; (org-freemind-test-get-tree-text)
995 (defun org-freemind-get-tree-text (node)
996 (when node
997 (let ((ntxt "")
998 (link nil)
999 (lf-after nil))
1000 (dolist (n node)
1001 (case n
1002 ;;(a (setq is-link t) )
1003 ((h1 h2 h3 h4 h5 h6 p)
1004 ;;(setq ntxt (concat "\n" ntxt))
1005 (setq lf-after 2)
1008 (setq lf-after 1)
1011 (cond
1012 ((stringp n)
1013 (when (string= n "\n") (setq n ""))
1014 (if link
1015 (setq ntxt (concat ntxt
1016 "[[" link "][" n "]]"))
1017 (setq ntxt (concat ntxt n))))
1018 ((and n (listp n))
1019 (if (symbolp (car n))
1020 (setq ntxt (concat ntxt (org-freemind-get-tree-text n)))
1021 ;; This should be the attributes:
1022 (dolist (att-val n)
1023 (let ((att (car att-val))
1024 (val (cdr att-val)))
1025 (when (eq att 'href)
1026 (setq link val)))))
1027 )))))
1028 (if lf-after
1029 (setq ntxt (concat ntxt (make-string lf-after ?\n)))
1030 (setq ntxt (concat ntxt " ")))
1031 ;;(setq ntxt (concat ntxt (format "{%s}" n)))
1032 ntxt)))
1034 (defun org-freemind-get-richcontent-node-text (node)
1035 "Get the node text as from the richcontent node NODE."
1036 (save-match-data
1037 (let* ((rc (org-freemind-get-richcontent-node node))
1038 (txt (org-freemind-get-tree-text rc)))
1039 ;;(when txt (setq txt (replace-regexp-in-string (rx (1+ whitespace)) " " txt)))
1043 (defun org-freemind-get-richcontent-note-text (node)
1044 "Get the node text as from the richcontent note NODE."
1045 (save-match-data
1046 (let* ((rc (org-freemind-get-richcontent-note node))
1047 (txt (when rc (org-freemind-get-tree-text rc))))
1048 ;;(when txt (setq txt (replace-regexp-in-string (rx (1+ whitespace)) " " txt)))
1052 (defun org-freemind-get-icon-names (node)
1053 (let* ((icon-nodes (org-freemind-get-children node '((icon ))))
1054 names)
1055 (dolist (icn icon-nodes)
1056 (setq names (cons (cdr (assq 'builtin (cadr icn))) names)))
1057 ;; (icon (builtin . "full-1"))
1058 names))
1060 (defun org-freemind-node-to-org (node level skip-levels)
1061 (let ((qname (car node))
1062 (attributes (cadr node))
1063 text
1064 (note (org-freemind-get-richcontent-note-text node))
1065 (mark "-- This is more about ")
1066 (icons (org-freemind-get-icon-names node))
1067 (children (cddr node)))
1068 (when (< 0 (- level skip-levels))
1069 (dolist (attrib attributes)
1070 (case (car attrib)
1071 ('TEXT (setq text (cdr attrib)))
1072 ('text (setq text (cdr attrib)))))
1073 (unless text
1074 ;; There should be a richcontent node holding the text:
1075 (setq text (org-freemind-get-richcontent-node-text node)))
1076 (when icons
1077 (when (member "full-1" icons) (setq text (concat "[#A] " text)))
1078 (when (member "full-2" icons) (setq text (concat "[#B] " text)))
1079 (when (member "full-3" icons) (setq text (concat "[#C] " text)))
1080 (when (member "full-4" icons) (setq text (concat "[#D] " text)))
1081 (when (member "full-5" icons) (setq text (concat "[#E] " text)))
1082 (when (member "full-6" icons) (setq text (concat "[#F] " text)))
1083 (when (member "full-7" icons) (setq text (concat "[#G] " text)))
1084 (when (member "button_cancel" icons) (setq text (concat "TODO " text)))
1086 (if (and note
1087 (string= mark (substring note 0 (length mark))))
1088 (progn
1089 (setq text (replace-regexp-in-string "\n $" "" text))
1090 (insert text))
1091 (case qname
1092 ('node
1093 (insert (make-string (- level skip-levels) ?*) " " text "\n")
1094 ))))
1095 (dolist (child children)
1096 (unless (or (null child)
1097 (stringp child))
1098 (org-freemind-node-to-org child (1+ level) skip-levels)))))
1100 ;; Fix-me: put back special things, like drawers that are stored in
1101 ;; the notes. Should maybe all notes contents be put in drawers?
1102 ;;;###autoload
1103 (defun org-freemind-to-org-mode (mm-file org-file)
1104 "Convert FreeMind file MM-FILE to `org-mode' file ORG-FILE."
1105 (interactive
1106 (save-match-data
1107 (let* ((mm-file (buffer-file-name))
1108 (default-org-file (concat (file-name-nondirectory mm-file) ".org"))
1109 (org-file (read-file-name "Output org-mode file: " nil nil nil default-org-file)))
1110 (list mm-file org-file))))
1111 (when (org-freemind-check-overwrite org-file (called-interactively-p))
1112 (let ((mm-buffer (find-file-noselect mm-file))
1113 (org-buffer (find-file-noselect org-file)))
1114 (with-current-buffer mm-buffer
1115 (let* ((xml-list (xml-parse-file mm-file))
1116 (top-node (cadr (cddar xml-list)))
1117 (note (org-freemind-get-richcontent-note-text top-node))
1118 (skip-levels
1119 (if (and note
1120 (string-match (rx bol "--org-mode: WHOLE FILE" eol) note))
1122 0)))
1123 (with-current-buffer org-buffer
1124 (erase-buffer)
1125 (org-freemind-node-to-org top-node 1 skip-levels)
1126 (goto-char (point-min))
1127 (org-set-tags t t) ;; Align all tags
1129 (switch-to-buffer-other-window org-buffer)
1130 )))))
1132 (provide 'org-freemind)
1134 ;; arch-tag: e7b0d776-94fd-404a-b35e-0f855fae3627
1136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1137 ;;; org-freemind.el ends here