lisp/org/org-freemind.el

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