lisp/org-freemind.el

   1 ;;; org-freemind.el --- Export Org files to freemind
   2
   3 ;; Copyright (C) 2009, 2010 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: 7.01f
   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 'rx)
  85 (require 'org-exp)
  86 (eval-when-compile (require 'cl))
  87
  88 ;; Fix-me: I am not sure these are useful:
  89 ;;
  90 ;; (defcustom org-freemind-main-fgcolor "black"
  91 ;;   "Color of main node's text."
  92 ;;   :type 'color
  93 ;;   :group 'freemind)
  94
  95 ;; (defcustom org-freemind-main-color "black"
  96 ;;   "Background color of main node."
  97 ;;   :type 'color
  98 ;;   :group 'freemind)
  99
 100 ;; (defcustom org-freemind-child-fgcolor "black"
 101 ;;   "Color of child nodes' text."
 102 ;;   :type 'color
 103 ;;   :group 'freemind)
 104
 105 ;; (defcustom org-freemind-child-color "black"
 106 ;;   "Background color of child nodes."
 107 ;;   :type 'color
 108 ;;   :group 'freemind)
 109
 110 (defvar org-freemind-node-style nil "Internal use.")
 111
 112 (defcustom org-freemind-node-styles nil
 113   "Styles to apply to node.
 114 NOT READY YET."
 115   :type '(repeat
 116           (list :tag "Node styles for file"
 117                 (regexp :tag "File name")
 118                 (repeat
 119                  (list :tag "Node"
 120                        (regexp :tag "Node name regexp")
 121                        (set :tag "Node properties"
 122                             (list :format "%v" (const :format "" node-style)
 123                                   (choice :tag "Style"
 124                                           :value bubble
 125                                           (const bubble)
 126                                           (const fork)))
 127                             (list :format "%v" (const :format "" color)
 128                                   (color :tag "Color" :value "red"))
 129                             (list :format "%v" (const :format "" background-color)
 130                                   (color :tag "Background color" :value "yellow"))
 131                             (list :format "%v" (const :format "" edge-color)
 132                                   (color :tag "Edge color" :value "green"))
 133                             (list :format "%v" (const :format "" edge-style)
 134                                   (choice :tag "Edge style" :value bezier
 135                                           (const :tag "Linear" linear)
 136                                           (const :tag "Bezier" bezier)
 137                                           (const :tag "Sharp Linear" sharp-linear)
 138                                           (const :tag "Sharp Bezier" sharp-bezier)))
 139                             (list :format "%v" (const :format "" edge-width)
 140                                   (choice :tag "Edge width" :value thin
 141                                           (const :tag "Parent" parent)
 142                                           (const :tag "Thin" thin)
 143                                           (const 1)
 144                                           (const 2)
 145                                           (const 4)
 146                                           (const 8)))
 147                             (list :format "%v" (const :format "" italic)
 148                                   (const :tag "Italic font" t))
 149                             (list :format "%v" (const :format "" bold)
 150                                   (const :tag "Bold font" t))
 151                             (list :format "%v" (const :format "" font-name)
 152                                   (string :tag "Font name" :value "SansSerif"))
 153                             (list :format "%v" (const :format "" font-size)
 154                                   (integer :tag "Font size" :value 12)))))))
 155   :group 'freemind)
 156
 157 ;;;###autoload
 158 (defun org-export-as-freemind (arg &optional hidden ext-plist
 159                                    to-buffer body-only pub-dir)
 160   (interactive "P")
 161   (let* ((opt-plist (org-combine-plists (org-default-export-plist)
 162                                         ext-plist
 163                                         (org-infile-export-plist)))
 164          (region-p (org-region-active-p))
 165          (rbeg (and region-p (region-beginning)))
 166          (rend (and region-p (region-end)))
 167          (subtree-p
 168           (if (plist-get opt-plist :ignore-subtree-p)
 169               nil
 170             (when region-p
 171               (save-excursion
 172                 (goto-char rbeg)
 173                 (and (org-at-heading-p)
 174                      (>= (org-end-of-subtree t t) rend))))))
 175          (opt-plist (setq org-export-opt-plist
 176                           (if subtree-p
 177                               (org-export-add-subtree-options opt-plist rbeg)
 178                             opt-plist)))
 179          (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer))))
 180          (filename (concat (file-name-as-directory
 181                             (or pub-dir
 182                                 (org-export-directory :ascii opt-plist)))
 183                            (file-name-sans-extension
 184                             (or (and subtree-p
 185                                      (org-entry-get (region-beginning)
 186                                                     "EXPORT_FILE_NAME" t))
 187                                 (file-name-nondirectory bfname)))
 188                            ".mm")))
 189     (when (file-exists-p filename)
 190       (delete-file filename))
 191     (cond
 192      (subtree-p
 193       (org-freemind-from-org-mode-node (line-number-at-pos rbeg)
 194                                        filename))
 195      (t (org-freemind-from-org-mode bfname filename)))))
 196
 197 ;;;###autoload
 198 (defun org-freemind-show (mm-file)
 199   "Show file MM-FILE in FreeMind."
 200   (interactive
 201    (list
 202     (save-match-data
 203       (let ((name (read-file-name "FreeMind file: "
 204                                   nil nil nil
 205                                   (if (buffer-file-name)
 206                                       (file-name-nondirectory (buffer-file-name))
 207                                     "")
 208                                   ;; Fix-me: Is this an Emacs bug?
 209                                   ;; This predicate function is never
 210                                   ;; called.
 211                                   (lambda (fn)
 212                                     (string-match "^mm$" (file-name-extension fn))))))
 213         (setq name (expand-file-name name))
 214         name))))
 215   (org-open-file mm-file))
 216
 217 (defconst org-freemind-org-nfix "--org-mode: ")
 218
 219 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 220 ;;; Format converters
 221
 222 (defun org-freemind-escape-str-from-org (org-str)
 223   "Do some html-escaping of ORG-STR and return the result.
 224 The characters \"&<> will be escaped."
 225   (let ((chars (append org-str nil))
 226         (fm-str ""))
 227     (dolist (cc chars)
 228       (setq fm-str
 229             (concat fm-str
 230                     (if (< cc 256)
 231                         (cond
 232                          ((= cc ?\") "&quot;")
 233                          ((= cc ?\&) "&amp;")
 234                          ((= cc ?\<) "&lt;")
 235                          ((= cc ?\>) "&gt;")
 236                          (t (char-to-string cc)))
 237                       ;; Formatting as &#number; is maybe needed
 238                       ;; according to a bug report from kazuo
 239                       ;; fujimoto, but I have now instead added a xml
 240                       ;; processing instruction saying that the mm
 241                       ;; file is utf-8:
 242                       ;;
 243                       ;; (format "&#x%x;" (- cc ;; ?\x800))
 244                       (format "&#x%x;" (encode-char cc 'ucs))
 245                       ))))
 246     fm-str))
 247
 248 ;;(org-freemind-unescape-str-to-org "&#x6d;A&#x224C;B&lt;C&#x3C;&#x3D;")
 249 ;;(org-freemind-unescape-str-to-org "&#x3C;&lt;")
 250 (defun org-freemind-unescape-str-to-org (fm-str)
 251  "Do some html-unescaping of FM-STR and return the result.
 252 This is the opposite of `org-freemind-escape-str-from-org' but it
 253 will also unescape &#nn;."
 254  (let ((org-str fm-str))
 255    (setq org-str (replace-regexp-in-string "&quot;" "\"" org-str))
 256    (setq org-str (replace-regexp-in-string "&amp;" "&" org-str))
 257    (setq org-str (replace-regexp-in-string "&lt;" "<" org-str))
 258    (setq org-str (replace-regexp-in-string "&gt;" ">" org-str))
 259    (setq org-str (replace-regexp-in-string
 260                   "&#x\\([a-f0-9]\\{2,4\\}\\);"
 261                   (lambda (m)
 262                     (char-to-string
 263                      (+ (string-to-number (match-string 1 m) 16)
 264                         0 ;?\x800 ;; What is this for? Encoding?
 265                         )))
 266                   org-str))))
 267
 268 ;; (org-freemind-test-escape)
 269 (defun org-freemind-test-escape ()
 270   (let* ((str1 "a quote: \", an amp: &, lt: <; over 256: öåäÖÅÄ")
 271          (str2 (org-freemind-escape-str-from-org str1))
 272          (str3 (org-freemind-unescape-str-to-org str2))
 273         )
 274     (unless (string= str1 str3)
 275       (error "str3=%s" str3))
 276     ))
 277
 278 (defun org-freemind-convert-links-from-org (org-str)
 279   "Convert org links in ORG-STR to FreeMind links and return the result."
 280   (let ((fm-str (replace-regexp-in-string
 281                  (rx (not (any "[\""))
 282                      (submatch
 283                       "http"
 284                       (opt ?\s)
 285                       "://"
 286                       (1+
 287                        (any "-%.?@a-zA-Z0-9()_/:~=&#"))))
 288                  "[[\\1][\\1]]"
 289                  org-str)))
 290     (replace-regexp-in-string (rx "[["
 291                                   (submatch (*? nonl))
 292                                   "]["
 293                                   (submatch (*? nonl))
 294                                   "]]")
 295                               "<a href=\"\\1\">\\2</a>"
 296                               fm-str)))
 297
 298 ;;(org-freemind-convert-links-to-org "<a href=\"http://www.somewhere/\">link-text</a>")
 299 (defun org-freemind-convert-links-to-org (fm-str)
 300   "Convert FreeMind links in FM-STR to org links and return the result."
 301   (let ((org-str (replace-regexp-in-string
 302                   (rx "<a"
 303                       space
 304                       (0+
 305                        (0+ (not (any ">")))
 306                        space)
 307                       "href=\""
 308                       (submatch (0+ (not (any "\""))))
 309                       "\""
 310                       (0+ (not (any ">")))
 311                        ">"
 312                        (submatch (0+ (not (any "<"))))
 313                        "</a>")
 314                   "[[\\1][\\2]]"
 315                   fm-str)))
 316     org-str))
 317
 318 ;; Fix-me:
 319 ;;(defun org-freemind-convert-drawers-from-org (text)
 320 ;;  )
 321
 322 ;; (org-freemind-test-links)
 323 ;; (defun org-freemind-test-links ()
 324 ;;   (let* ((str1 "[[http://www.somewhere/][link-text]")
 325 ;;          (str2 (org-freemind-convert-links-from-org str1))
 326 ;;          (str3 (org-freemind-convert-links-to-org str2))
 327 ;;         )
 328 ;;     (unless (string= str1 str3)
 329 ;;       (error "str3=%s" str3))
 330 ;;     ))
 331
 332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 333 ;;; Org => FreeMind
 334
 335 (defun org-freemind-convert-text-p (text)
 336   "Convert TEXT to html with <p> paragraphs."
 337   (setq text (org-freemind-escape-str-from-org text))
 338   (setq text (replace-regexp-in-string (rx "\n" (0+ blank) "\n") "</p><p>\n" text))
 339   ;;(setq text (replace-regexp-in-string (rx bol (1+ blank) eol) "" text))
 340   ;;(setq text (replace-regexp-in-string (rx bol (1+ blank)) "<br />" text))
 341   (setq text (replace-regexp-in-string "\n" "<br />" text))
 342   (concat "<p>"
 343           (org-freemind-convert-links-from-org text)
 344           "</p>\n"))
 345
 346 (defun org-freemind-org-text-to-freemind-subnode/note (node-name start end drawers-regexp)
 347   "Convert text part of org node to FreeMind subnode or note.
 348 Convert the text part of the org node named NODE-NAME.  The text
 349 is in the current buffer between START and END.  Drawers matching
 350 DRAWERS-REGEXP are converted to FreeMind notes."
 351   ;; fix-me: doc
 352   (let ((text (buffer-substring-no-properties start end))
 353         (node-res "")
 354         (note-res ""))
 355     (save-match-data
 356       ;;(setq text (org-freemind-escape-str-from-org text))
 357       ;; First see if there is something that should be moved to the
 358       ;; note part:
 359       (let (drawers)
 360         (while (string-match drawers-regexp text)
 361           (setq drawers (cons (match-string 0 text) drawers))
 362           (setq text
 363                 (concat (substring text 0 (match-beginning 0))
 364                         (substring text (match-end 0))))
 365           )
 366         (when drawers
 367           (dolist (drawer drawers)
 368             (let ((lines (split-string drawer "\n")))
 369               (dolist (line lines)
 370                 (setq note-res (concat
 371                                 note-res
 372                                 org-freemind-org-nfix line "<br />\n")))
 373               ))))
 374
 375       (when (> (length note-res) 0)
 376         (setq note-res (concat
 377                         "<richcontent TYPE=\"NOTE\"><html>\n"
 378                         "<head>\n"
 379                         "</head>\n"
 380                         "<body>\n"
 381                         note-res
 382                         "</body>\n"
 383                         "</html>\n"
 384                         "</richcontent>\n"))
 385         )
 386
 387       ;; There is always an LF char:
 388       (when (> (length text) 1)
 389         (setq node-res (concat
 390                         "<node style=\"bubble\" background_color=\"#eeee00\">\n"
 391                         "<richcontent TYPE=\"NODE\"><html>\n"
 392                         "<head>\n"
 393                         "<style type=\"text/css\">\n"
 394                         "<!--\n"
 395                         "p { margin-top: 0 }\n"
 396                         "-->\n"
 397                         "</style>\n"
 398                         "</head>\n"
 399                         "<body>\n"))
 400         (let ((begin-html-mark (regexp-quote "#+BEGIN_HTML"))
 401               (end-html-mark   (regexp-quote "#+END_HTML"))
 402               head
 403               end-pos
 404               end-pos-match
 405               )
 406           ;; Take care of #+BEGIN_HTML - #+END_HTML
 407           (while (string-match begin-html-mark text)
 408             (setq head (substring text 0 (match-beginning 0)))
 409             (setq end-pos-match (match-end 0))
 410             (setq node-res (concat node-res
 411                                    (org-freemind-convert-text-p head)))
 412             (setq text (substring text end-pos-match))
 413             (setq end-pos (string-match end-html-mark text))
 414             (if end-pos
 415                 (setq end-pos-match (match-end 0))
 416               (message "org-freemind: Missing #+END_HTML")
 417               (setq end-pos (length text))
 418               (setq end-pos-match end-pos))
 419             (setq node-res (concat node-res
 420                                    (substring text 0 end-pos)))
 421             (setq text (substring text end-pos-match)))
 422           (setq node-res (concat node-res
 423                                  (org-freemind-convert-text-p text))))
 424         (setq node-res (concat
 425                         node-res
 426                         "</body>\n"
 427                         "</html>\n"
 428                         "</richcontent>\n"
 429                         ;; Put a note that this is for the parent node
 430                         "<richcontent TYPE=\"NOTE\"><html>"
 431                         "<head>"
 432                         "</head>"
 433                         "<body>"
 434                         "<p>"
 435                         "-- This is more about \"" node-name "\" --"
 436                         "</p>"
 437                         "</body>"
 438                         "</html>"
 439                         "</richcontent>\n"
 440                         "</node>\n" ;; ok
 441                         )))
 442       (list node-res note-res))))
 443
 444 (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)
 445   (let* (this-icons
 446          this-bg-color
 447          this-m2-escaped
 448          this-rich-node
 449          this-rich-note
 450          )
 451     (when (string-match "TODO" this-m2)
 452       (setq this-m2 (replace-match "" nil nil this-m2))
 453       (add-to-list 'this-icons "button_cancel")
 454       (setq this-bg-color "#ffff88")
 455       (when (string-match "\\[#\\(.\\)\\]" this-m2)
 456         (let ((prior (string-to-char (match-string 1 this-m2))))
 457           (setq this-m2 (replace-match "" nil nil this-m2))
 458           (cond
 459            ((= prior ?A)
 460             (add-to-list 'this-icons "full-1")
 461             (setq this-bg-color "#ff0000"))
 462            ((= prior ?B)
 463             (add-to-list 'this-icons "full-2")
 464             (setq this-bg-color "#ffaa00"))
 465            ((= prior ?C)
 466             (add-to-list 'this-icons "full-3")
 467             (setq this-bg-color "#ffdd00"))
 468            ((= prior ?D)
 469             (add-to-list 'this-icons "full-4")
 470             (setq this-bg-color "#ffff00"))
 471            ((= prior ?E)
 472             (add-to-list 'this-icons "full-5"))
 473            ((= prior ?F)
 474             (add-to-list 'this-icons "full-6"))
 475            ((= prior ?G)
 476             (add-to-list 'this-icons "full-7"))
 477            ))))
 478     (setq this-m2 (org-trim this-m2))
 479     (setq this-m2-escaped (org-freemind-escape-str-from-org this-m2))
 480     (let ((node-notes (org-freemind-org-text-to-freemind-subnode/note
 481                        this-m2-escaped
 482                        this-node-end
 483                        (1- next-node-start)
 484                        drawers-regexp)))
 485       (setq this-rich-node (nth 0 node-notes))
 486       (setq this-rich-note (nth 1 node-notes)))
 487     (with-current-buffer mm-buffer
 488       (insert "<node text=\"" this-m2-escaped "\"")
 489       (org-freemind-get-node-style this-m2)
 490       (when (> next-level current-level)
 491         (unless (or this-children-visible
 492                     next-has-some-visible-child)
 493           (insert " folded=\"true\"")))
 494       (when (and (= current-level (1+ base-level))
 495                  (> num-left-nodes 0))
 496         (setq num-left-nodes (1- num-left-nodes))
 497         (insert " position=\"left\""))
 498       (when this-bg-color
 499         (insert " background_color=\"" this-bg-color "\""))
 500       (insert ">\n")
 501       (when this-icons
 502         (dolist (icon this-icons)
 503           (insert "<icon builtin=\"" icon "\"/>\n")))
 504       )
 505     (with-current-buffer mm-buffer
 506       (when this-rich-note (insert this-rich-note))
 507       (when this-rich-node (insert this-rich-node))))
 508   num-left-nodes)
 509
 510 (defun org-freemind-check-overwrite (file interactively)
 511   "Check if file FILE already exists.
 512 If FILE does not exists return t.
 513
 514 If INTERACTIVELY is non-nil ask if the file should be replaced
 515 and return t/nil if it should/should not be replaced.
 516
 517 Otherwise give an error say the file exists."
 518   (if (file-exists-p file)
 519       (if interactively
 520           (y-or-n-p (format "File %s exists, replace it? " file))
 521         (error "File %s already exists" file))
 522     t))
 523
 524 (defvar org-freemind-node-pattern (rx bol
 525                          (submatch (1+ "*"))
 526                          (1+ space)
 527                          (submatch (*? nonl))
 528                          eol))
 529
 530 (defun org-freemind-look-for-visible-child (node-level)
 531   (save-excursion
 532     (save-match-data
 533       (let ((found-visible-child nil))
 534         (while (and (not found-visible-child)
 535                     (re-search-forward org-freemind-node-pattern nil t))
 536           (let* ((m1 (match-string-no-properties 1))
 537                  (level (length m1)))
 538             (if (>= node-level level)
 539                 (setq found-visible-child 'none)
 540               (unless (get-char-property (line-beginning-position) 'invisible)
 541                 (setq found-visible-child 'found)))))
 542         (eq found-visible-child 'found)
 543         ))))
 544
 545 (defun org-freemind-goto-line (line)
 546   "Go to line number LINE."
 547   (save-restriction
 548     (widen)
 549     (goto-char (point-min))
 550     (forward-line (1- line))))
 551
 552 (defun org-freemind-write-mm-buffer (org-buffer mm-buffer node-at-line)
 553   (with-current-buffer org-buffer
 554     (dolist (node-style org-freemind-node-styles)
 555       (when (org-string-match-p (car node-style) buffer-file-name)
 556         (setq org-freemind-node-style (cadr node-style))))
 557     ;;(message "org-freemind-node-style =%s" org-freemind-node-style)
 558     (save-match-data
 559       (let* ((drawers (copy-sequence org-drawers))
 560              drawers-regexp
 561              (num-top1-nodes 0)
 562              (num-top2-nodes 0)
 563              num-left-nodes
 564              (unclosed-nodes 0)
 565              (odd-only org-odd-levels-only)
 566              (first-time t)
 567              (current-level 1)
 568              base-level
 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                 (setq next-children-visible
 675                       (not (eq 'outline
 676                                (get-char-property (line-end-position) 'invisible))))
 677                 (setq next-has-some-visible-child
 678                       (if next-children-visible t
 679                         (org-freemind-look-for-visible-child next-level)))
 680                 (when this-m2
 681                   (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)))
 682                 (when (if (= num-top1-nodes 1) (> current-level base-level) t)
 683                   (while (>= current-level next-level)
 684                     (with-current-buffer mm-buffer
 685                       (insert "</node>\n")
 686                       (setq current-level
 687                             (- current-level (if odd-only 2 1))))))
 688                 (setq this-node-end (1+ next-node-end))
 689                 (setq this-m2 next-m2)
 690                 (setq current-level next-level)
 691                 (setq this-children-visible next-children-visible)
 692                 (forward-char)
 693                 ))
 694 ;;;             (unless (if node-at-line-last
 695 ;;;                         (>= (point) node-at-line-last)
 696 ;;;                       nil)
 697               ;; Write last node:
 698               (setq this-m2 next-m2)
 699               (setq current-level next-level)
 700               (setq next-node-start (if node-at-line-last
 701                                         (1+ node-at-line-last)
 702                                       (point-max)))
 703               (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))
 704               (with-current-buffer mm-buffer (insert "</node>\n"))
 705               ;)
 706             )
 707           (with-current-buffer mm-buffer
 708             (while (> current-level base-level)
 709               (insert "</node>\n")
 710               (setq current-level
 711                     (- current-level (if odd-only 2 1)))
 712               ))
 713           (with-current-buffer mm-buffer
 714             (insert "</map>")
 715             (delete-trailing-whitespace)
 716             (goto-char (point-min))
 717             ))))))
 718
 719 (defun org-freemind-get-node-style (node-name)
 720   "NOT READY YET."
 721   ;;<node BACKGROUND_COLOR="#eeee00" CREATED="1234668815593" MODIFIED="1234668815593" STYLE="bubble">
 722   ;;<font BOLD="true" NAME="SansSerif" SIZE="12"/>
 723   (let (node-styles
 724         node-style)
 725     (dolist (style-list org-freemind-node-style)
 726       (let ((node-regexp (car style-list)))
 727         (message "node-regexp=%s node-name=%s" node-regexp node-name)
 728         (when (org-string-match-p node-regexp node-name)
 729           ;;(setq node-style (org-freemind-do-apply-node-style style-list))
 730           (setq node-style (cadr style-list))
 731           (when node-style
 732             (message "node-style=%s" node-style)
 733             (setq node-styles (append node-styles node-style)))
 734           )))))
 735
 736 (defun org-freemind-do-apply-node-style (style-list)
 737   (message "style-list=%S" style-list)
 738   (let ((node-style 'fork)
 739         (color "red")
 740         (background-color "yellow")
 741         (edge-color "green")
 742         (edge-style 'bezier)
 743         (edge-width 'thin)
 744         (italic t)
 745         (bold t)
 746         (font-name "SansSerif")
 747         (font-size 12))
 748     (dolist (style (cadr style-list))
 749       (message "    style=%s" style)
 750       (let ((what (car style)))
 751         (cond
 752          ((eq what 'node-style)
 753           (setq node-style (cadr style)))
 754          ((eq what 'color)
 755           (setq color (cadr style)))
 756          ((eq what 'background-color)
 757           (setq background-color (cadr style)))
 758
 759          ((eq what 'edge-color)
 760           (setq edge-color (cadr style)))
 761
 762          ((eq what 'edge-style)
 763           (setq edge-style (cadr style)))
 764
 765          ((eq what 'edge-width)
 766           (setq edge-width (cadr style)))
 767
 768          ((eq what 'italic)
 769           (setq italic (cadr style)))
 770
 771          ((eq what 'bold)
 772           (setq bold (cadr style)))
 773
 774          ((eq what 'font-name)
 775           (setq font-name (cadr style)))
 776
 777          ((eq what 'font-size)
 778           (setq font-size (cadr style)))
 779          )
 780         (insert (format " style=\"%s\"" node-style))
 781         (insert (format " color=\"%s\"" color))
 782         (insert (format " background_color=\"%s\"" background-color))
 783         (insert ">\n")
 784         (insert "<edge")
 785         (insert (format " color=\"%s\"" edge-color))
 786         (insert (format " style=\"%s\"" edge-style))
 787         (insert (format " width=\"%s\"" edge-width))
 788         (insert "/>\n")
 789         (insert "<font")
 790         (insert (format " italic=\"%s\"" italic))
 791         (insert (format " bold=\"%s\"" bold))
 792         (insert (format " name=\"%s\"" font-name))
 793         (insert (format " size=\"%s\"" font-size))
 794         ))))
 795
 796 ;;;###autoload
 797 (defun org-freemind-from-org-mode-node (node-line mm-file)
 798   "Convert node at line NODE-LINE to the FreeMind file MM-FILE."
 799   (interactive
 800    (progn
 801      (unless (org-back-to-heading nil)
 802        (error "Can't find org-mode node start"))
 803      (let* ((line (line-number-at-pos))
 804             (default-mm-file (concat (if buffer-file-name
 805                                          (file-name-nondirectory buffer-file-name)
 806                                        "nofile")
 807                                      "-line-" (number-to-string line)
 808                                      ".mm"))
 809             (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
 810        (list line mm-file))))
 811   (when (org-freemind-check-overwrite mm-file (interactive-p))
 812     (let ((org-buffer (current-buffer))
 813           (mm-buffer (find-file-noselect mm-file)))
 814       (org-freemind-write-mm-buffer org-buffer mm-buffer node-line)
 815       (with-current-buffer mm-buffer
 816         (basic-save-buffer)
 817         (when (interactive-p)
 818           (switch-to-buffer-other-window mm-buffer)
 819           (when (y-or-n-p "Show in FreeMind? ")
 820             (org-freemind-show buffer-file-name)))))))
 821
 822 ;;;###autoload
 823 (defun org-freemind-from-org-mode (org-file mm-file)
 824   "Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE."
 825   ;; Fix-me: better doc, include recommendations etc.
 826   (interactive
 827    (let* ((org-file buffer-file-name)
 828           (default-mm-file (concat
 829                             (if org-file
 830                                 (file-name-nondirectory org-file)
 831                               "nofile")
 832                             ".mm"))
 833           (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
 834      (list org-file mm-file)))
 835   (when (org-freemind-check-overwrite mm-file (interactive-p))
 836     (let ((org-buffer (if org-file (find-file-noselect org-file) (current-buffer)))
 837           (mm-buffer (find-file-noselect mm-file)))
 838       (org-freemind-write-mm-buffer org-buffer mm-buffer nil)
 839       (with-current-buffer mm-buffer
 840         (basic-save-buffer)
 841         (when (interactive-p)
 842           (switch-to-buffer-other-window mm-buffer)
 843           (when (y-or-n-p "Show in FreeMind? ")
 844             (org-freemind-show buffer-file-name)))))))
 845
 846 ;;;###autoload
 847 (defun org-freemind-from-org-sparse-tree (org-buffer mm-file)
 848   "Convert visible part of buffer ORG-BUFFER to FreeMind file MM-FILE."
 849   (interactive
 850    (let* ((org-file buffer-file-name)
 851           (default-mm-file (concat
 852                             (if org-file
 853                                 (file-name-nondirectory org-file)
 854                               "nofile")
 855                             "-sparse.mm"))
 856           (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
 857      (list (current-buffer) mm-file)))
 858   (when (org-freemind-check-overwrite mm-file (interactive-p))
 859     (let (org-buffer
 860           (mm-buffer (find-file-noselect mm-file)))
 861       (save-window-excursion
 862         (org-export-visible ?\  nil)
 863         (setq org-buffer (current-buffer)))
 864       (org-freemind-write-mm-buffer org-buffer mm-buffer nil)
 865       (with-current-buffer mm-buffer
 866         (basic-save-buffer)
 867         (when (interactive-p)
 868           (switch-to-buffer-other-window mm-buffer)
 869           (when (y-or-n-p "Show in FreeMind? ")
 870             (org-freemind-show buffer-file-name)))))))
 871
 872
 873 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 874 ;;; FreeMind => Org
 875
 876 ;; (sort '(b a c) 'org-freemind-lt-symbols)
 877 (defun org-freemind-lt-symbols (sym-a sym-b)
 878   (string< (symbol-name sym-a) (symbol-name sym-b)))
 879 ;; (sort '((b . 1) (a . 2) (c . 3)) 'org-freemind-lt-xml-attrs)
 880 (defun org-freemind-lt-xml-attrs (attr-a attr-b)
 881   (string< (symbol-name (car attr-a)) (symbol-name (car attr-b))))
 882
 883 ;; xml-parse-region gives things like
 884 ;; ((p nil "\n"
 885 ;;     (a
 886 ;;      ((href . "link"))
 887 ;;      "text")
 888 ;;     "\n"
 889 ;;     (b nil "hej")
 890 ;;     "\n"))
 891
 892 ;; '(a . nil)
 893
 894 ;; (org-freemind-symbols= 'a (car '(A B)))
 895 (defsubst org-freemind-symbols= (sym-a sym-b)
 896   "Return t if downcased names of SYM-A and SYM-B are equal.
 897 SYM-A and SYM-B should be symbols."
 898   (or (eq sym-a sym-b)
 899       (string= (downcase (symbol-name sym-a))
 900                (downcase (symbol-name sym-b)))))
 901
 902 (defun org-freemind-get-children (parent path)
 903   "Find children node to PARENT from PATH.
 904 PATH should be a list of steps, where each step has the form
 905
 906   '(NODE-NAME (ATTR-NAME . ATTR-VALUE))"
 907   ;; Fix-me: maybe implement op? step: Name, number, attr, attr op val
 908   ;; Fix-me: case insensitive version for children?
 909   (let* ((children (if (not (listp (car parent)))
 910                        (cddr parent)
 911                      (let (cs)
 912                        (dolist (p parent)
 913                          (dolist (c (cddr p))
 914                            (add-to-list 'cs c)))
 915                        cs)
 916                      ))
 917          (step (car path))
 918          (step-node (if (listp step) (car step) step))
 919          (step-attr-list (when (listp step) (sort (cdr step) 'org-freemind-lt-xml-attrs)))
 920          (path-tail (cdr path))
 921          path-children)
 922     (dolist (child children)
 923       ;; skip xml.el formatting nodes
 924       (unless (stringp child)
 925         ;; compare node name
 926         (when (if (not step-node)
 927                   t ;; any node name
 928                 (org-freemind-symbols= step-node (car child)))
 929           (if (not step-attr-list)
 930               ;;(throw 'path-child child) ;; no attr to care about
 931               (add-to-list 'path-children child)
 932             (let* ((child-attr-list (cadr child))
 933                    (step-attr-copy (copy-sequence step-attr-list)))
 934               (dolist (child-attr child-attr-list)
 935                                    ;; Compare attr names:
 936                 (when (org-freemind-symbols= (caar step-attr-copy) (car child-attr))
 937                   ;; Compare values:
 938                   (let ((step-val (cdar step-attr-copy))
 939                         (child-val (cdr child-attr)))
 940                     (when (if (not step-val)
 941                               t ;; any value
 942                             (string= step-val child-val))
 943                       (setq step-attr-copy (cdr step-attr-copy))))))
 944               ;; Did we find all?
 945               (unless step-attr-copy
 946                 ;;(throw 'path-child child)
 947                 (add-to-list 'path-children child)
 948                 ))))))
 949     (if path-tail
 950         (org-freemind-get-children path-children path-tail)
 951       path-children)))
 952
 953 (defun org-freemind-get-richcontent-node (node)
 954   (let ((rc-nodes
 955          (org-freemind-get-children node '((richcontent (type . "NODE")) html body))))
 956     (when (> (length rc-nodes) 1)
 957       (lwarn t :warning "Unexpected structure: several <richcontent type=\"NODE\" ...>"))
 958     (car rc-nodes)))
 959
 960 (defun org-freemind-get-richcontent-note (node)
 961   (let ((rc-notes
 962          (org-freemind-get-children node '((richcontent (type . "NOTE")) html body))))
 963     (when (> (length rc-notes) 1)
 964       (lwarn t :warning "Unexpected structure: several <richcontent type=\"NOTE\" ...>"))
 965     (car rc-notes)))
 966
 967 (defun org-freemind-test-get-tree-text ()
 968   (let ((node '(p nil "\n"
 969                  (a
 970                   ((href . "link"))
 971                   "text")
 972                  "\n"
 973                  (b nil "hej")
 974                  "\n")))
 975     (org-freemind-get-tree-text node)))
 976 ;; (org-freemind-test-get-tree-text)
 977
 978 (defun org-freemind-get-tree-text (node)
 979   (when node
 980     (let ((ntxt "")
 981           (link nil)
 982           (lf-after nil))
 983       (dolist (n node)
 984         (case n
 985           ;;(a (setq is-link t) )
 986           ((h1 h2 h3 h4 h5 h6 p)
 987            ;;(setq ntxt (concat "\n" ntxt))
 988            (setq lf-after 2)
 989            )
 990           (br
 991            (setq lf-after 1)
 992            )
 993           (t
 994            (cond
 995             ((stringp n)
 996              (when (string= n "\n") (setq n ""))
 997              (if link
 998                  (setq ntxt (concat ntxt
 999                                     "[[" link "][" n "]]"))
1000                (setq ntxt (concat ntxt n))))
1001             ((and n (listp n))
1002              (if (symbolp (car n))
1003                  (setq ntxt (concat ntxt (org-freemind-get-tree-text n)))
1004                ;; This should be the attributes:
1005                (dolist (att-val n)
1006                  (let ((att (car att-val))
1007                        (val (cdr att-val)))
1008                    (when (eq att 'href)
1009                      (setq link val)))))
1010              )))))
1011       (if lf-after
1012           (setq ntxt (concat ntxt (make-string lf-after ?\n)))
1013         (setq ntxt (concat ntxt " ")))
1014       ;;(setq ntxt (concat ntxt (format "{%s}" n)))
1015       ntxt)))
1016
1017 (defun org-freemind-get-richcontent-node-text (node)
1018   "Get the node text as from the richcontent node NODE."
1019   (save-match-data
1020     (let* ((rc (org-freemind-get-richcontent-node node))
1021            (txt (org-freemind-get-tree-text rc)))
1022       ;;(when txt (setq txt (replace-regexp-in-string (rx (1+ whitespace)) " " txt)))
1023       txt
1024       )))
1025
1026 (defun org-freemind-get-richcontent-note-text (node)
1027   "Get the node text as from the richcontent note NODE."
1028   (save-match-data
1029     (let* ((rc (org-freemind-get-richcontent-note node))
1030            (txt (when rc (org-freemind-get-tree-text rc))))
1031       ;;(when txt (setq txt (replace-regexp-in-string (rx (1+ whitespace)) " " txt)))
1032       txt
1033       )))
1034
1035 (defun org-freemind-get-icon-names (node)
1036   (let* ((icon-nodes (org-freemind-get-children node '((icon ))))
1037          names)
1038     (dolist (icn icon-nodes)
1039       (setq names (cons (cdr (assq 'builtin (cadr icn))) names)))
1040     ;; (icon (builtin . "full-1"))
1041     names))
1042
1043 (defun org-freemind-node-to-org (node level skip-levels)
1044   (let ((qname (car node))
1045         (attributes (cadr node))
1046         text
1047         (note (org-freemind-get-richcontent-note-text node))
1048         (mark "-- This is more about ")
1049         (icons (org-freemind-get-icon-names node))
1050         (children (cddr node)))
1051     (when (< 0 (- level skip-levels))
1052       (dolist (attrib attributes)
1053         (case (car attrib)
1054           ('TEXT (setq text (cdr attrib)))
1055           ('text (setq text (cdr attrib)))))
1056       (unless text
1057         ;; There should be a richcontent node holding the text:
1058         (setq text (org-freemind-get-richcontent-node-text node)))
1059       (when icons
1060         (when (member "full-1" icons) (setq text (concat "[#A] " text)))
1061         (when (member "full-2" icons) (setq text (concat "[#B] " text)))
1062         (when (member "full-3" icons) (setq text (concat "[#C] " text)))
1063         (when (member "full-4" icons) (setq text (concat "[#D] " text)))
1064         (when (member "full-5" icons) (setq text (concat "[#E] " text)))
1065         (when (member "full-6" icons) (setq text (concat "[#F] " text)))
1066         (when (member "full-7" icons) (setq text (concat "[#G] " text)))
1067         (when (member "button_cancel" icons) (setq text (concat "TODO " text)))
1068         )
1069       (if (and note
1070                (string= mark (substring note 0 (length mark))))
1071           (progn
1072             (setq text (replace-regexp-in-string "\n $" "" text))
1073             (insert text))
1074         (case qname
1075           ('node
1076            (insert (make-string (- level skip-levels) ?*) " " text "\n")
1077            ))))
1078     (dolist (child children)
1079       (unless (or (null child)
1080                   (stringp child))
1081         (org-freemind-node-to-org child (1+ level) skip-levels)))))
1082
1083 ;; Fix-me: put back special things, like drawers that are stored in
1084 ;; the notes. Should maybe all notes contents be put in drawers?
1085 ;;;###autoload
1086 (defun org-freemind-to-org-mode (mm-file org-file)
1087   "Convert FreeMind file MM-FILE to `org-mode' file ORG-FILE."
1088   (interactive
1089    (save-match-data
1090      (let* ((mm-file (buffer-file-name))
1091             (default-org-file (concat (file-name-nondirectory mm-file) ".org"))
1092             (org-file (read-file-name "Output org-mode file: " nil nil nil default-org-file)))
1093        (list mm-file org-file))))
1094   (when (org-freemind-check-overwrite org-file (interactive-p))
1095     (let ((mm-buffer (find-file-noselect mm-file))
1096           (org-buffer (find-file-noselect org-file)))
1097       (with-current-buffer mm-buffer
1098         (let* ((xml-list (xml-parse-file mm-file))
1099                (top-node (cadr (cddar xml-list)))
1100                (note (org-freemind-get-richcontent-note-text top-node))
1101                (skip-levels
1102                 (if (and note
1103                          (string-match (rx bol "--org-mode: WHOLE FILE" eol) note))
1104                     1
1105                   0)))
1106           (with-current-buffer org-buffer
1107             (erase-buffer)
1108             (org-freemind-node-to-org top-node 1 skip-levels)
1109             (goto-char (point-min))
1110             (org-set-tags t t) ;; Align all tags
1111             )
1112           (switch-to-buffer-other-window org-buffer)
1113           )))))
1114
1115 (provide 'org-freemind)
1116
1117 ;; arch-tag: e7b0d776-94fd-404a-b35e-0f855fae3627
1118
1119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1120 ;;; org-freemind.el ends here