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: TAG=6.35c
   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                       (format "&#x%x;" (encode-char cc 'ucs))
 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              (odd-only org-odd-levels-only)
 565              (first-time t)
 566              (current-level 1)
 567              base-level
 568              prev-node-end
 569              rich-text
 570              unfinished-tag
 571              node-at-line-level
 572              node-at-line-last)
 573         (with-current-buffer mm-buffer
 574           (erase-buffer)
 575           (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
 576           (insert "<map version=\"0.9.0\">\n")
 577           (insert "<!-- To view this file, download free mind mapping software FreeMind from http://freemind.sourceforge.net -->\n"))
 578         (save-excursion
 579           ;; Get special buffer vars:
 580           (goto-char (point-min))
 581           (while (re-search-forward (rx bol "#+DRAWERS:") nil t)
 582             (let ((dr-txt (buffer-substring-no-properties (match-end 0) (line-end-position))))
 583               (setq drawers (append drawers (split-string dr-txt) nil))))
 584           (setq drawers-regexp
 585                 (concat (rx bol (0+ blank) ":")
 586                         (regexp-opt drawers)
 587                         (rx ":" (0+ blank)
 588                             "\n"
 589                             (*? anything)
 590                             "\n"
 591                             (0+ blank)
 592                             ":END:"
 593                             (0+ blank)
 594                             eol)
 595                         ))
 596
 597           (if node-at-line
 598               ;; Get number of top nodes and last line for this node
 599               (progn
 600                 (org-freemind-goto-line node-at-line)
 601                 (unless (looking-at org-freemind-node-pattern)
 602                   (error "No node at line %s" node-at-line))
 603                 (setq node-at-line-level (length (match-string-no-properties 1)))
 604                 (forward-line)
 605                 (setq node-at-line-last
 606                       (catch 'last-line
 607                         (while (re-search-forward org-freemind-node-pattern nil t)
 608                           (let* ((m1 (match-string-no-properties 1))
 609                                  (level (length m1)))
 610                             (if (<= level node-at-line-level)
 611                                 (progn
 612                                   (beginning-of-line)
 613                                   (throw 'last-line (1- (point))))
 614                               (if (= level (1+ node-at-line-level))
 615                                   (setq num-top2-nodes (1+ num-top2-nodes))))))))
 616                 (setq current-level node-at-line-level)
 617                 (setq num-top1-nodes 1)
 618                 (org-freemind-goto-line node-at-line))
 619
 620             ;; First get number of top nodes
 621             (goto-char (point-min))
 622             (while (re-search-forward org-freemind-node-pattern nil t)
 623               (let* ((m1 (match-string-no-properties 1))
 624                      (level (length m1)))
 625                 (if (= level 1)
 626                     (setq num-top1-nodes (1+ num-top1-nodes))
 627                   (if (= level 2)
 628                       (setq num-top2-nodes (1+ num-top2-nodes))))))
 629             ;; If there is more than one top node we need to insert a node
 630             ;; to keep them together.
 631             (goto-char (point-min))
 632             (when (> num-top1-nodes 1)
 633               (setq num-top2-nodes num-top1-nodes)
 634               (setq current-level 0)
 635               (let ((orig-name (if buffer-file-name
 636                                    (file-name-nondirectory (buffer-file-name))
 637                                  (buffer-name))))
 638                 (with-current-buffer mm-buffer
 639                   (insert "<node text=\"" orig-name "\" background_color=\"#00bfff\">\n"
 640                           ;; Put a note that this is for the parent node
 641                           "<richcontent TYPE=\"NOTE\"><html>"
 642                           "<head>"
 643                           "</head>"
 644                           "<body>"
 645                           "<p>"
 646                           org-freemind-org-nfix "WHOLE FILE"
 647                           "</p>"
 648                           "</body>"
 649                           "</html>"
 650                           "</richcontent>\n")))))
 651
 652           (setq num-left-nodes (floor num-top2-nodes 2))
 653           (setq base-level current-level)
 654           (let (this-m2
 655                 this-node-end
 656                 this-children-visible
 657                 next-m2
 658                 next-node-start
 659                 next-level
 660                 next-has-some-visible-child
 661                 next-children-visible
 662                 )
 663             (while (and
 664                     (re-search-forward org-freemind-node-pattern nil t)
 665                     (if node-at-line-last (<= (point) node-at-line-last) t)
 666                     )
 667               (let* ((next-m1 (match-string-no-properties 1))
 668                      (next-node-end (match-end 0))
 669                      )
 670                 (setq next-node-start (match-beginning 0))
 671                 (setq next-m2 (match-string-no-properties 2))
 672                 (setq next-level (length next-m1))
 673                 (setq next-children-visible
 674                       (not (eq 'outline
 675                                (get-char-property (line-end-position) 'invisible))))
 676                 (setq next-has-some-visible-child
 677                       (if next-children-visible t
 678                         (org-freemind-look-for-visible-child next-level)))
 679                 (when this-m2
 680                   (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)))
 681                 (when (if (= num-top1-nodes 1) (> current-level base-level) t)
 682                   (while (>= current-level next-level)
 683                     (with-current-buffer mm-buffer
 684                       (insert "</node>\n")
 685                       (setq current-level
 686                             (- current-level (if odd-only 2 1))))))
 687                 (setq this-node-end (1+ next-node-end))
 688                 (setq this-m2 next-m2)
 689                 (setq current-level next-level)
 690                 (setq this-children-visible next-children-visible)
 691                 (forward-char)
 692                 ))
 693 ;;;             (unless (if node-at-line-last
 694 ;;;                         (>= (point) node-at-line-last)
 695 ;;;                       nil)
 696               ;; Write last node:
 697               (setq this-m2 next-m2)
 698               (setq current-level next-level)
 699               (setq next-node-start (if node-at-line-last
 700                                         (1+ node-at-line-last)
 701                                       (point-max)))
 702               (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))
 703               (with-current-buffer mm-buffer (insert "</node>\n"))
 704               ;)
 705             )
 706           (with-current-buffer mm-buffer
 707             (while (> current-level base-level)
 708               (insert "</node>\n")
 709               (setq current-level
 710                     (- current-level (if odd-only 2 1)))
 711               ))
 712           (with-current-buffer mm-buffer
 713             (insert "</map>")
 714             (delete-trailing-whitespace)
 715             (goto-char (point-min))
 716             ))))))
 717
 718 (defun org-freemind-get-node-style (node-name)
 719   "NOT READY YET."
 720   ;;<node BACKGROUND_COLOR="#eeee00" CREATED="1234668815593" MODIFIED="1234668815593" STYLE="bubble">
 721   ;;<font BOLD="true" NAME="SansSerif" SIZE="12"/>
 722   (let (node-styles
 723         node-style)
 724     (dolist (style-list org-freemind-node-style)
 725       (let ((node-regexp (car style-list)))
 726         (message "node-regexp=%s node-name=%s" node-regexp node-name)
 727         (when (string-match-p node-regexp node-name)
 728           ;;(setq node-style (org-freemind-do-apply-node-style style-list))
 729           (setq node-style (cadr style-list))
 730           (when node-style
 731             (message "node-style=%s" node-style)
 732             (setq node-styles (append node-styles node-style)))
 733           )))))
 734
 735 (defun org-freemind-do-apply-node-style (style-list)
 736   (message "style-list=%S" style-list)
 737   (let ((node-style 'fork)
 738         (color "red")
 739         (background-color "yellow")
 740         (edge-color "green")
 741         (edge-style 'bezier)
 742         (edge-width 'thin)
 743         (italic t)
 744         (bold t)
 745         (font-name "SansSerif")
 746         (font-size 12))
 747     (dolist (style (cadr style-list))
 748       (message "    style=%s" style)
 749       (let ((what (car style)))
 750         (cond
 751          ((eq what 'node-style)
 752           (setq node-style (cadr style)))
 753          ((eq what 'color)
 754           (setq color (cadr style)))
 755          ((eq what 'background-color)
 756           (setq background-color (cadr style)))
 757
 758          ((eq what 'edge-color)
 759           (setq edge-color (cadr style)))
 760
 761          ((eq what 'edge-style)
 762           (setq edge-style (cadr style)))
 763
 764          ((eq what 'edge-width)
 765           (setq edge-width (cadr style)))
 766
 767          ((eq what 'italic)
 768           (setq italic (cadr style)))
 769
 770          ((eq what 'bold)
 771           (setq bold (cadr style)))
 772
 773          ((eq what 'font-name)
 774           (setq font-name (cadr style)))
 775
 776          ((eq what 'font-size)
 777           (setq font-size (cadr style)))
 778          )
 779         (insert (format " style=\"%s\"" node-style))
 780         (insert (format " color=\"%s\"" color))
 781         (insert (format " background_color=\"%s\"" background-color))
 782         (insert ">\n")
 783         (insert "<edge")
 784         (insert (format " color=\"%s\"" edge-color))
 785         (insert (format " style=\"%s\"" edge-style))
 786         (insert (format " width=\"%s\"" edge-width))
 787         (insert "/>\n")
 788         (insert "<font")
 789         (insert (format " italic=\"%s\"" italic))
 790         (insert (format " bold=\"%s\"" bold))
 791         (insert (format " name=\"%s\"" font-name))
 792         (insert (format " size=\"%s\"" font-size))
 793         ))))
 794
 795 ;;;###autoload
 796 (defun org-freemind-from-org-mode-node (node-line mm-file)
 797   "Convert node at line NODE-LINE to the FreeMind file MM-FILE."
 798   (interactive
 799    (progn
 800      (unless (org-back-to-heading nil)
 801        (error "Can't find org-mode node start"))
 802      (let* ((line (line-number-at-pos))
 803             (default-mm-file (concat (if buffer-file-name
 804                                          (file-name-nondirectory buffer-file-name)
 805                                        "nofile")
 806                                      "-line-" (number-to-string line)
 807                                      ".mm"))
 808             (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
 809        (list line mm-file))))
 810   (when (org-freemind-check-overwrite mm-file (called-interactively-p))
 811     (let ((org-buffer (current-buffer))
 812           (mm-buffer (find-file-noselect mm-file)))
 813       (org-freemind-write-mm-buffer org-buffer mm-buffer node-line)
 814       (with-current-buffer mm-buffer
 815         (basic-save-buffer)
 816         (when (called-interactively-p)
 817           (switch-to-buffer-other-window mm-buffer)
 818           (when (y-or-n-p "Show in FreeMind? ")
 819             (org-freemind-show buffer-file-name)))))))
 820
 821 ;;;###autoload
 822 (defun org-freemind-from-org-mode (org-file mm-file)
 823   "Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE."
 824   ;; Fix-me: better doc, include recommendations etc.
 825   (interactive
 826    (let* ((org-file buffer-file-name)
 827           (default-mm-file (concat
 828                             (if org-file
 829                                 (file-name-nondirectory org-file)
 830                               "nofile")
 831                             ".mm"))
 832           (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
 833      (list org-file mm-file)))
 834   (when (org-freemind-check-overwrite mm-file (called-interactively-p))
 835     (let ((org-buffer (if org-file (find-file-noselect org-file) (current-buffer)))
 836           (mm-buffer (find-file-noselect mm-file)))
 837       (org-freemind-write-mm-buffer org-buffer mm-buffer nil)
 838       (with-current-buffer mm-buffer
 839         (basic-save-buffer)
 840         (when (called-interactively-p)
 841           (switch-to-buffer-other-window mm-buffer)
 842           (when (y-or-n-p "Show in FreeMind? ")
 843             (org-freemind-show buffer-file-name)))))))
 844
 845 ;;;###autoload
 846 (defun org-freemind-from-org-sparse-tree (org-buffer mm-file)
 847   "Convert visible part of buffer ORG-BUFFER to FreeMind file MM-FILE."
 848   (interactive
 849    (let* ((org-file buffer-file-name)
 850           (default-mm-file (concat
 851                             (if org-file
 852                                 (file-name-nondirectory org-file)
 853                               "nofile")
 854                             "-sparse.mm"))
 855           (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
 856      (list (current-buffer) mm-file)))
 857   (when (org-freemind-check-overwrite mm-file (called-interactively-p))
 858     (let (org-buffer
 859           (mm-buffer (find-file-noselect mm-file)))
 860       (save-window-excursion
 861         (org-export-visible ?\  nil)
 862         (setq org-buffer (current-buffer)))
 863       (org-freemind-write-mm-buffer org-buffer mm-buffer nil)
 864       (with-current-buffer mm-buffer
 865         (basic-save-buffer)
 866         (when (called-interactively-p)
 867           (switch-to-buffer-other-window mm-buffer)
 868           (when (y-or-n-p "Show in FreeMind? ")
 869             (org-freemind-show buffer-file-name)))))))
 870
 871
 872 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 873 ;;; FreeMind => Org
 874
 875 ;; (sort '(b a c) 'org-freemind-lt-symbols)
 876 (defun org-freemind-lt-symbols (sym-a sym-b)
 877   (string< (symbol-name sym-a) (symbol-name sym-b)))
 878 ;; (sort '((b . 1) (a . 2) (c . 3)) 'org-freemind-lt-xml-attrs)
 879 (defun org-freemind-lt-xml-attrs (attr-a attr-b)
 880   (string< (symbol-name (car attr-a)) (symbol-name (car attr-b))))
 881
 882 ;; xml-parse-region gives things like
 883 ;; ((p nil "\n"
 884 ;;     (a
 885 ;;      ((href . "link"))
 886 ;;      "text")
 887 ;;     "\n"
 888 ;;     (b nil "hej")
 889 ;;     "\n"))
 890
 891 ;; '(a . nil)
 892
 893 ;; (org-freemind-symbols= 'a (car '(A B)))
 894 (defsubst org-freemind-symbols= (sym-a sym-b)
 895   "Return t if downcased names of SYM-A and SYM-B are equal.
 896 SYM-A and SYM-B should be symbols."
 897   (or (eq sym-a sym-b)
 898       (string= (downcase (symbol-name sym-a))
 899                (downcase (symbol-name sym-b)))))
 900
 901 (defun org-freemind-get-children (parent path)
 902   "Find children node to PARENT from PATH.
 903 PATH should be a list of steps, where each step has the form
 904
 905   '(NODE-NAME (ATTR-NAME . ATTR-VALUE))"
 906   ;; Fix-me: maybe implement op? step: Name, number, attr, attr op val
 907   ;; Fix-me: case insensitive version for children?
 908   (let* ((children (if (not (listp (car parent)))
 909                        (cddr parent)
 910                      (let (cs)
 911                        (dolist (p parent)
 912                          (dolist (c (cddr p))
 913                            (add-to-list 'cs c)))
 914                        cs)
 915                      ))
 916          (step (car path))
 917          (step-node (if (listp step) (car step) step))
 918          (step-attr-list (when (listp step) (sort (cdr step) 'org-freemind-lt-xml-attrs)))
 919          (path-tail (cdr path))
 920          path-children)
 921     (dolist (child children)
 922       ;; skip xml.el formatting nodes
 923       (unless (stringp child)
 924         ;; compare node name
 925         (when (if (not step-node)
 926                   t ;; any node name
 927                 (org-freemind-symbols= step-node (car child)))
 928           (if (not step-attr-list)
 929               ;;(throw 'path-child child) ;; no attr to care about
 930               (add-to-list 'path-children child)
 931             (let* ((child-attr-list (cadr child))
 932                    (step-attr-copy (copy-sequence step-attr-list)))
 933               (dolist (child-attr child-attr-list)
 934                                    ;; Compare attr names:
 935                 (when (org-freemind-symbols= (caar step-attr-copy) (car child-attr))
 936                   ;; Compare values:
 937                   (let ((step-val (cdar step-attr-copy))
 938                         (child-val (cdr child-attr)))
 939                     (when (if (not step-val)
 940                               t ;; any value
 941                             (string= step-val child-val))
 942                       (setq step-attr-copy (cdr step-attr-copy))))))
 943               ;; Did we find all?
 944               (unless step-attr-copy
 945                 ;;(throw 'path-child child)
 946                 (add-to-list 'path-children child)
 947                 ))))))
 948     (if path-tail
 949         (org-freemind-get-children path-children path-tail)
 950       path-children)))
 951
 952 (defun org-freemind-get-richcontent-node (node)
 953   (let ((rc-nodes
 954          (org-freemind-get-children node '((richcontent (type . "NODE")) html body))))
 955     (when (> (length rc-nodes) 1)
 956       (lwarn t :warning "Unexpected structure: several <richcontent type=\"NODE\" ...>"))
 957     (car rc-nodes)))
 958
 959 (defun org-freemind-get-richcontent-note (node)
 960   (let ((rc-notes
 961          (org-freemind-get-children node '((richcontent (type . "NOTE")) html body))))
 962     (when (> (length rc-notes) 1)
 963       (lwarn t :warning "Unexpected structure: several <richcontent type=\"NOTE\" ...>"))
 964     (car rc-notes)))
 965
 966 (defun org-freemind-test-get-tree-text ()
 967   (let ((node '(p nil "\n"
 968                  (a
 969                   ((href . "link"))
 970                   "text")
 971                  "\n"
 972                  (b nil "hej")
 973                  "\n")))
 974     (org-freemind-get-tree-text node)))
 975 ;; (org-freemind-test-get-tree-text)
 976
 977 (defun org-freemind-get-tree-text (node)
 978   (when node
 979     (let ((ntxt "")
 980           (link nil)
 981           (lf-after nil))
 982       (dolist (n node)
 983         (case n
 984           ;;(a (setq is-link t) )
 985           ((h1 h2 h3 h4 h5 h6 p)
 986            ;;(setq ntxt (concat "\n" ntxt))
 987            (setq lf-after 2)
 988            )
 989           (br
 990            (setq lf-after 1)
 991            )
 992           (t
 993            (cond
 994             ((stringp n)
 995              (when (string= n "\n") (setq n ""))
 996              (if link
 997                  (setq ntxt (concat ntxt
 998                                     "[[" link "][" n "]]"))
 999                (setq ntxt (concat ntxt n))))
1000             ((and n (listp n))
1001              (if (symbolp (car n))
1002                  (setq ntxt (concat ntxt (org-freemind-get-tree-text n)))
1003                ;; This should be the attributes:
1004                (dolist (att-val n)
1005                  (let ((att (car att-val))
1006                        (val (cdr att-val)))
1007                    (when (eq att 'href)
1008                      (setq link val)))))
1009              )))))
1010       (if lf-after
1011           (setq ntxt (concat ntxt (make-string lf-after ?\n)))
1012         (setq ntxt (concat ntxt " ")))
1013       ;;(setq ntxt (concat ntxt (format "{%s}" n)))
1014       ntxt)))
1015
1016 (defun org-freemind-get-richcontent-node-text (node)
1017   "Get the node text as from the richcontent node NODE."
1018   (save-match-data
1019     (let* ((rc (org-freemind-get-richcontent-node node))
1020            (txt (org-freemind-get-tree-text rc)))
1021       ;;(when txt (setq txt (replace-regexp-in-string (rx (1+ whitespace)) " " txt)))
1022       txt
1023       )))
1024
1025 (defun org-freemind-get-richcontent-note-text (node)
1026   "Get the node text as from the richcontent note NODE."
1027   (save-match-data
1028     (let* ((rc (org-freemind-get-richcontent-note node))
1029            (txt (when rc (org-freemind-get-tree-text rc))))
1030       ;;(when txt (setq txt (replace-regexp-in-string (rx (1+ whitespace)) " " txt)))
1031       txt
1032       )))
1033
1034 (defun org-freemind-get-icon-names (node)
1035   (let* ((icon-nodes (org-freemind-get-children node '((icon ))))
1036          names)
1037     (dolist (icn icon-nodes)
1038       (setq names (cons (cdr (assq 'builtin (cadr icn))) names)))
1039     ;; (icon (builtin . "full-1"))
1040     names))
1041
1042 (defun org-freemind-node-to-org (node level skip-levels)
1043   (let ((qname (car node))
1044         (attributes (cadr node))
1045         text
1046         (note (org-freemind-get-richcontent-note-text node))
1047         (mark "-- This is more about ")
1048         (icons (org-freemind-get-icon-names node))
1049         (children (cddr node)))
1050     (when (< 0 (- level skip-levels))
1051       (dolist (attrib attributes)
1052         (case (car attrib)
1053           ('TEXT (setq text (cdr attrib)))
1054           ('text (setq text (cdr attrib)))))
1055       (unless text
1056         ;; There should be a richcontent node holding the text:
1057         (setq text (org-freemind-get-richcontent-node-text node)))
1058       (when icons
1059         (when (member "full-1" icons) (setq text (concat "[#A] " text)))
1060         (when (member "full-2" icons) (setq text (concat "[#B] " text)))
1061         (when (member "full-3" icons) (setq text (concat "[#C] " text)))
1062         (when (member "full-4" icons) (setq text (concat "[#D] " text)))
1063         (when (member "full-5" icons) (setq text (concat "[#E] " text)))
1064         (when (member "full-6" icons) (setq text (concat "[#F] " text)))
1065         (when (member "full-7" icons) (setq text (concat "[#G] " text)))
1066         (when (member "button_cancel" icons) (setq text (concat "TODO " text)))
1067         )
1068       (if (and note
1069                (string= mark (substring note 0 (length mark))))
1070           (progn
1071             (setq text (replace-regexp-in-string "\n $" "" text))
1072             (insert text))
1073         (case qname
1074           ('node
1075            (insert (make-string (- level skip-levels) ?*) " " text "\n")
1076            ))))
1077     (dolist (child children)
1078       (unless (or (null child)
1079                   (stringp child))
1080         (org-freemind-node-to-org child (1+ level) skip-levels)))))
1081
1082 ;; Fix-me: put back special things, like drawers that are stored in
1083 ;; the notes. Should maybe all notes contents be put in drawers?
1084 ;;;###autoload
1085 (defun org-freemind-to-org-mode (mm-file org-file)
1086   "Convert FreeMind file MM-FILE to `org-mode' file ORG-FILE."
1087   (interactive
1088    (save-match-data
1089      (let* ((mm-file (buffer-file-name))
1090             (default-org-file (concat (file-name-nondirectory mm-file) ".org"))
1091             (org-file (read-file-name "Output org-mode file: " nil nil nil default-org-file)))
1092        (list mm-file org-file))))
1093   (when (org-freemind-check-overwrite org-file (called-interactively-p))
1094     (let ((mm-buffer (find-file-noselect mm-file))
1095           (org-buffer (find-file-noselect org-file)))
1096       (with-current-buffer mm-buffer
1097         (let* ((xml-list (xml-parse-file mm-file))
1098                (top-node (cadr (cddar xml-list)))
1099                (note (org-freemind-get-richcontent-note-text top-node))
1100                (skip-levels
1101                 (if (and note
1102                          (string-match (rx bol "--org-mode: WHOLE FILE" eol) note))
1103                     1
1104                   0)))
1105           (with-current-buffer org-buffer
1106             (erase-buffer)
1107             (org-freemind-node-to-org top-node 1 skip-levels)
1108             (goto-char (point-min))
1109             (org-set-tags t t) ;; Align all tags
1110             )
1111           (switch-to-buffer-other-window org-buffer)
1112           )))))
1113
1114 (provide 'org-freemind)
1115
1116 ;; arch-tag: e7b0d776-94fd-404a-b35e-0f855fae3627
1117
1118 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1119 ;;; org-freemind.el ends here