lisp/org-freemind.el

   1 ;;; org-freemind.el --- Export Org files to freemind
   2
   3 ;; Copyright (C) 2009 Free Software Foundation, Inc.
   4
   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.32trans
   9 ;;
  10 ;; This file is part of GNU Emacs.
  11 ;;
  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.
  16
  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.
  21
  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/>.
  24
  25 ;; --------------------------------------------------------------------
  26 ;; Features that might be required by this library:
  27 ;;
  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'.
  32 ;;
  33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 ;;
  35 ;;; Commentary:
  36 ;;
  37 ;; This file tries to implement some functions useful for
  38 ;; transformation between org-mode and FreeMind files.
  39 ;;
  40 ;; Here are the commands you can use:
  41 ;;
  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'
  45 ;;
  46 ;;    M-x `org-freemind-to-org-mode'
  47 ;;
  48 ;;    M-x `org-freemind-show'
  49 ;;
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51 ;;
  52 ;;; Change log:
  53 ;;
  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.
  59 ;;
  60 ;;
  61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62 ;;
  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.
  67 ;;
  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.
  72 ;;
  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.
  77 ;;
  78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79 ;;
  80 ;;; Code:
  81
  82 (require 'xml)
  83 (require 'org)
  84 (require 'org-exp)
  85 (eval-when-compile (require 'cl))
  86
  87 ;; Fix-me: I am not sure these are useful:
  88 ;;
  89 ;; (defcustom org-freemind-main-fgcolor "black"
  90 ;;   "Color of main node's text."
  91 ;;   :type 'color
  92 ;;   :group 'freemind)
  93
  94 ;; (defcustom org-freemind-main-color "black"
  95 ;;   "Background color of main node."
  96 ;;   :type 'color
  97 ;;   :group 'freemind)
  98
  99 ;; (defcustom org-freemind-child-fgcolor "black"
 100 ;;   "Color of child nodes' text."
 101 ;;   :type 'color
 102 ;;   :group 'freemind)
 103
 104 ;; (defcustom org-freemind-child-color "black"
 105 ;;   "Background color of child nodes."
 106 ;;   :type 'color
 107 ;;   :group 'freemind)
 108
 109 (defvar org-freemind-node-style nil "Internal use.")
 110
 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)
 155
 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)
 168               nil
 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)))))
 195
 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))
 206                                     "")
 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))
 215
 216 (defconst org-freemind-org-nfix "--org-mode: ")
 217
 218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 219 ;;; Format converters
 220
 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:
 241                       ;;
 242                       ;; (format "&#x%x;" (- cc ;; ?\x800))
 243                       (char-to-string cc)
 244                       ))))
 245     fm-str))
 246
 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?
 264                         )))
 265                   org-str))))
 266
 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))
 272         )
 273     (unless (string= str1 str3)
 274       (error "str3=%s" str3))
 275     ))
 276
 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                       "://"
 285                       (1+
 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)))
 296
 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
 303                       (0+
 304                        (0+ (not (any ">")))
 305                        space)
 306                       "href=\""
 307                       (submatch (0+ (not (any "\""))))
 308                       "\""
 309                       (0+ (not (any ">")))
 310                        ">"
 311                        (submatch (0+ (not (any "<"))))
 312                        "</a>")
 313                   "[[\\1][\\2]]"
 314                   fm-str)))
 315     org-str))
 316
 317 ;; Fix-me:
 318 ;;(defun org-freemind-convert-drawers-from-org (text)
 319 ;;  )
 320
 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 ;;     ))
 330
 331 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 332 ;;; Org => FreeMind
 333
 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"))
 344
 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))))
 364           )
 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               ))))
 373
 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"))
 384         )
 385
 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
 404               )
 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
 440                         )))
 441       (list node-res note-res))))
 442
 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
 449          )
 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")))
 503       )
 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)
 508
 509 (defun org-freemind-check-overwrite (file interactively)
 510   "Check if file FILE already exists.
 511 If FILE does not exists return t.
 512
 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.
 515
 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))
 521     t))
 522
 523 (defvar org-freemind-node-pattern (rx bol
 524                          (submatch (1+ "*"))
 525                          (1+ space)
 526                          (submatch (*? nonl))
 527                          eol))
 528
 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         ))))
 543
 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))))
 550
 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)
 596                         ))
 597
 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))
 620
 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")))))
 652
 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
 663                 )
 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)
 667                     )
 668               (let* ((next-m1 (match-string-no-properties 1))
 669                      (next-node-end (match-end 0))
 670                      )
 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)))
 688                     ))
 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)))
 705                       )))
 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)
 711                 ))
 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"))
 723               ;)
 724             )
 725           (with-current-buffer mm-buffer
 726             (while (> current-level base-level)
 727               (insert "</node>\n")
 728               (setq current-level (1- current-level))
 729               ))
 730           (with-current-buffer mm-buffer
 731             (insert "</map>")
 732             (delete-trailing-whitespace)
 733             (goto-char (point-min))
 734             ))))))
 735
 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           )))))
 752
 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)))
 775
 776          ((eq what 'edge-color)
 777           (setq edge-color (cadr style)))
 778
 779          ((eq what 'edge-style)
 780           (setq edge-style (cadr style)))
 781
 782          ((eq what 'edge-width)
 783           (setq edge-width (cadr style)))
 784
 785          ((eq what 'italic)
 786           (setq italic (cadr style)))
 787
 788          ((eq what 'bold)
 789           (setq bold (cadr style)))
 790
 791          ((eq what 'font-name)
 792           (setq font-name (cadr style)))
 793
 794          ((eq what 'font-size)
 795           (setq font-size (cadr style)))
 796          )
 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         ))))
 812
 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)))))))
 838
 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)))))))
 862
 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)))))))
 888
 889
 890 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 891 ;;; FreeMind => Org
 892
 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))))
 899
 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"))
 908
 909 ;; '(a . nil)
 910
 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)))))
 918
 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
 922
 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)))
 932                        cs)
 933                      ))
 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)))
 969
 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)))
 976
 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)))
 983
 984 (defun org-freemind-test-get-tree-text ()
 985   (let ((node '(p nil "\n"
 986                  (a
 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)
 994
 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)
1006            )
1007           (br
1008            (setq lf-after 1)
1009            )
1010           (t
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)))
1033
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)))
1040       txt
1041       )))
1042
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)))
1049       txt
1050       )))
1051
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))
1059
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)))
1085         )
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)))))
1099
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))
1121                     1
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
1128             )
1129           (switch-to-buffer-other-window org-buffer)
1130           )))))
1131
1132 (provide 'org-freemind)
1133
1134 ;; arch-tag: e7b0d776-94fd-404a-b35e-0f855fae3627
1135
1136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1137 ;;; org-freemind.el ends here