;; SaveData.lsp
;; Save *any* variable with the DWG
;;    Written  Nov 30, 1997.
;;    Updated for r15 and xdict-* functions added Dec 7, 1999.
;;
;;*************************************************************
;;   Copyright Vladimir Nesterovsky 1997, All Rights Reserved
;;
;; You may use, copy and distribute this program *unmodified*
;; for any non-commercial, non-profit purpose and without
;; charging any fee, if you keep this notice in its entirety
;;       in all copies and in all your derived works.
;;
;; This program is provided "AS IS" and has absolutely
;;  no warranty of any kind. Use it at your own risk.
;;
;; You're welcome to contact me about the possibility to use
;; this program commercially, and also with any comments and
;;        requests at vnestr@netvision.net.il,
;;              http://vnestr.tripod.com/
;;*************************************************************
;;
;; This file contains functions that will let you save any
;; list of data without dotted pairs inside dictionary with
;;      (dict-put "mydict" "mykey" "myval")
;; and retrieve it later with
;;      (dict-get "mydict" "mykey")
;; OR store it in xdictionary under some entity with
;;      (xdict-put ename "mykey" "myval")
;; and retrieve it similarly with
;;      (xdict-get ename "mykey")
;; xdictionary only allows for one key to hold the data,
;; regular dictionaries don't have this restriction, so you
;; may use any number of keys inside your dictionary
;;*************************************************************
;;
;; BEWARE that these functions use recursion in encoding / decoding
;; so for very long and complex lists they can use up all available
;; AutoLISP stack space and cause "AutoLISP stack overflow" error.
;;
;; look into http://vnestr.tripod.com/SaveData.txt !


;;;;;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~;;;;;;;
;;;;;;; The two working functions: ;;;;;;;
;;;;;;;____________________________;;;;;;;
;;
;;Sample use:
;; (dict-put "mydict" "mykey" '(1 (2 ("3" (44.4) (5.5 6.6 7.7) 8)) 999999))
;; (dict-get "mydict" "mykey")
;;POSSIBLE IMPROVEMENTS:
;; implement dict-append ( APPEND PREPEND )


;; Get A [Key] Value From Dictionary [Name]
(cond
 ((member (substr (getvar "acadver") 1 2)  '( "13" "14"))
  (defun dict-get ( name key ) ;; name and key As strings
    (x-relist                  ;; decode the data!
      (cdr (member '(100 . "AcDbXrecord")
        (dict-getrawdata name key))))))
 ((= "15" (substr (getvar "acadver") 1 2))
  (defun dict-get ( name key ) ;; name and key As strings
    (x-relist                  ;; decode the data!
      (cddr (member '(100 . "AcDbXrecord") ;; new (280) code group in r15
        (dict-getrawdata name key)))))))

;; Put A [Val]ue Into [Name] Dictionary Under [Key]
;; Dictionary is created automatically if was not existing
;; three arguments As strings
;; NAME may also be an entity name of some existing dictionary
(defun dict-put ( name key val )
  (dict-clear name key) ;;  clear the old value under this Key
  (dictadd
    (setq name (cond ((dict-name name)) ((dict-new name)) ))
    key
    (entmakex
      (cons '(0 . "XRECORD")
        (cons '(100 . "AcDbXrecord")
          (x-enlist val)))) ) ;; encode the data!
  name )  ;; return the dictionary altered


;;;;;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~;;;;;;;
;;        XDICTIONARY SUPPORT
;;  two more similar functions to use:
;;;;;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~;;;;;;;

(defun xdict-put ( ename key val )
 (addxdict ename (dict-put nil key val)))

(defun xdict-get ( ename key )
 (dict-get (cdr (assoc 360 (entget ename))) key))


;;;;;;; utility functions in use ;;;;;;;

;; a general utility -- pop first value off the list
(defun pop (a / b)
  (setq b (eval a))
  (set a (cdr b))
  (car b))

;; general functions re/en-list, just to try things out
;; re-list can be also used in decoding xdata
(defun re-list ( lst / tok )
 (re-list-aux))

(defun re-list-aux()
 (cond
  ((atom lst) lst)
  ((/= "}" (setq tok (pop 'lst)))
   (cons (if (= "{" tok) (re-list-aux) tok)
         (re-list-aux)))))

(defun en-list ( lst )
  (cond
   ((null lst) lst)
   ((atom lst) (list lst))
   ((cons "{"    ;; add the markers around the list!
      (reverse
        (cons "}"
          (reverse
            (apply 'append  ;; open the lists
              (mapcar 'en-list lst) ;; recursion!
      ))))))))

;; a special encoding function for Xrecords to be used in dictionaries
(defun x-enlist ( lst )  ;; encode!
  (cond
   ((null lst) lst)
   ((atom lst)           ;; automatic code groups
     (cond
      ((= 'REAL (type lst))
        (list (cons 40 lst)))
      ((= 'INT (type lst))
       (if               ;; special handling of long integers
         (< -32768 lst 32767)
          (list (cons 70 lst))
          (list (cons 41 (float lst)))))
      ((= 'STR (type lst))
        (list (cons  1 lst)))
      (T nil)))
   ((and (cdr lst) (atom (cdr lst)))
      (list lst))      ;; pass dotted pair AS IS -- must be valid!!
   ((and (= (length lst) 3)
         (apply 'and (mapcar 'numberp lst)))
     (list (cons 10 lst)))
   ((cons '(2 . "{")
     (reverse
      (cons '(2 . "}")
       (reverse
        (apply 'append
         (mapcar 'x-enlist lst) ))))))))


(defun x-relist ( lst / tok )  ;; decode it!
 (car (x-relist-aux)))

(defun x-relist-aux()
 (cond
  ((null lst) nil)
  ((not (equal '(2 . "}") (setq tok (pop 'lst))))
   (cons (if (equal '(2 . "{") tok)
           (x-relist-aux)
           (cond      ;; special processing of TOK to recover
             ((= 41 (car tok)) ;; long integers back
              (fix (cdr tok)))
             (T
              (cdr tok)))
           )
         (x-relist-aux)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dictionary functions for R14
;; POSSIBLE IMPROVEMENTS: support trees of dictionaries
;;      now: all custom dictionaries are under the Root.
;;
;; Get Dictionary Object Name From Root Dictionary
(defun dict-name ( name ) ;; name As string or ename of exist dict
 (cond
   ( (= 'STR (type name))
     (cdr (assoc -1 (dictsearch (namedobjdict) name))))
   ( (and (= 'ENAME (type name))
          (= "AcDbDictionary" (cdr (assoc 100 (entget name)))) )
     name )))

;; Remove Dictionary [Name] From Root Dictionary
(defun dict-remove ( name / d0 ) ;; name As string
  (if (dictsearch (Setq d0 (namedobjdict)) name)
    (dictremove d0 name))
  )

;; Make A New Empty Dictionary and put into into Root; Reset Existing.
(defun dict-new ( name / d0 ) ;; name As string
  (cond
    ( (/= 'STR (type name))
      (dict-new-orphan) )
    ('t
      (if (dictsearch (Setq d0 (namedobjdict)) name)
        (dictremove d0 name))
      (dictadd d0 name
        (dict-new-orphan) ))
    ))

;; (dict-new-ex parent name) parent := ROOT | ename (dict or reg for xdict)

(defun dict-new-orphan ()
  (entmakex '((0 . "DICTIONARY")(100 . "AcDbDictionary"))))

;; List A Dictionary As Pairs {Name . Object Name}
(defun dict-list ( dname / d nl ) ;; dname As object name or string else ROOT
  (cond
    ((and (Setq d (cond
                    ((= 'ENAME (type dname))
                      dname)
                    ((= 'STR (type dname))
                      (dict-name dname))
                    (T (namedobjdict))))
          (Setq d (entget d)))
      (while (setq d (member (assoc 3 d) d))
        (if (or (= 350 (caadr d)) ;; regular dict
                (= 360 (caadr d)) ;; extension dict
                )
          (setq nl (cons (cons (cdar d) (cdadr d)) nl)))
        (setq d (cdr d)))
      (reverse nl))))

;; Get Raw [Name] Dictionary Data for [Key]
(defun dict-getrawdata ( name key / d ) ;; name and key As strings
  (cond
    ((='STR (type name))
      (if (setq d (dict-name name))
        (dictsearch d key)))
    ((='ENAME (type name))
      (dictsearch name key) )
    ( (dictsearch (namedobjdict) key) )))

;; Clear The [Key] From Dictionary [Name]
(defun dict-clear ( name key / d) ;; name and key As strings
  (if (setq d (dict-name name))
    (dictremove d key)))

;; add xdictionary DK into the carrier entity data ECD
;; you can use it like (addxdict _entname_ (dict-put nil _key_ _val_))
;; eg. (addxdict (tblobjname"layer""0") (dict-put nil "MYDATA" 1.23))
;; to associate some data with layer "0".
;; you'll retrieve this data later with
;;   (setq d (cdr(assoc 360 (entget (tblobjname "layer""0")))))
;; and
;;   (dict-get d _key_)
(defun addxdict (ECD DK / TT)
 (cond
   ( (= 'ENAME (type ecd))
     (addxdict (entget ecd) dk) )
   ( (or (atom ecd) (atom (car ecd)) (not (atom (cdar ecd))))
     nil )
   ( (= 'STR (type dk))
     (addxdict ecd (dictsearch (namedobjdict) dk)) )
   ( (/= 'ENAME (type dk))
     nil )
   ( (/= "AcDbDictionary" (cdr (assoc 100 (entget dk))))
     nil )
   ( (assoc 102 ecd)
   ;; there already is an extension dictionary attached to this entity
   ;; can I prepend another dictionary into it?? No! :-(
     (while (/= (caar ecd) 102)
       (setq tt  (cons (car ecd) tt)
             ecd (cdr  ecd)))
     (setq tt  (cons (car ecd) tt) ;; {
           ecd (cdr ecd))
     (while (/= 102 (caar ecd))    ;; }
       (setq ecd (cdr ecd)))

     (setq ecd (cons (cons 360 dk) ecd) )
     (while tt
       (setq ecd (cons (car tt) ecd)
             tt  (cdr tt)))
     (entmod ecd))
   ( (assoc 100 ecd)
     (while (/= (caar ecd) 100)
       (setq tt (cons (car ecd) tt)
            ecd (cdr  ecd)))
     (setq ecd
       (cons (quote (102 . "{ACAD_XDICTIONARY"))
         (cons (cons 360 dk)
           (cons (quote (102 . "}")) ecd))))
     (while tt
       (setq ecd (cons (car tt) ecd)
             tt  (cdr tt)))
     (entmod ecd))
 ))

;; EOF SaveData.lsp
Make your own free website on Tripod.com