;;;---------------------AXStruct.lsp--------------------------------
;;; Purpose: Create data structures in AutoLISP using Active X datatypes
;;; Version: 0.75
;;; Date: July 2009
;;; Author: Herman Mayfarth
;;; Copyright © 2009 by Herman Mayfarth. All rights reserved.
;;; Provided "as is" and without warranty, express or implied.
;;; Use at your own risk.
;;;-----------------------------------------------------------------
;;; define the following functions:
;;; axstruct - define a structure type  <== to do: case II
;;; axstruct-types - return a list of defined structure types
;;; axstruct-get-type - get the representation of a structure type
;;; axstruct-delete - delete a defined structure type
;;; axstruct-redefine - redefine a structure type
;;; axstruct-new - create an instance of a structure defined by axstruct
;;; axstruct-getval - get the value of a structure element
;;; axstruct-setval - set the value of a structure element
;;; axstruct->list - return the element values as a list
;;; axstruct-create-accessors - create accessor functions for a structure type
;;; axstruct-destroy-accessors - destroy accessor functions for a structure type
;;; to do:
;;; 1. default values for a structure type
;;; 2. additional functions:
;;; axstruct-update - update instances of a redefined type
;;;-----------------------------------------------------------------
(vl-load-com);load COM support
;;;--------------------
;;; Function: axstruct
;;; Params: name    : symbol - name of the structure type
;;;         elements: list which defines the elements of the structure
;;;                   and optionally provides default values for elements
;;;        accessors: automatically create accessor functions
;;; Usage: (axstruct 'mysymbol (list 'slot1 'slot2 <etc.>) nil)
;;;        (axstruct "mystring" (list 'slot1 'slot2 <etc.>) 1)
;;;        (axstruct 'mysymbol '(slot1 slot2 <etc.>) "Yes")
;;;        (axstruct "mystring" '(slot1 slot2 <etc.>) T)
;;;--------------------
(defun axstruct (symbol elements / i alist)
; two cases exist:
; case I: only a definition
; case II: one or more elements have default values
;consider only case I for now
;;allow passing symbol as a string
  (if (= (type symbol) 'STR) (setq symbol (read symbol)))
;;create an association list of the elements and their positions
  (setq i 0)
  (while elements
    (setq alist (cons (cons (car elements) i) alist)
          elements (cdr elements)
          i (1+ i))
  );while
  (setq alist (cons symbol (reverse alist)))
;;define a global variable to hold all user-defined structure types
;;add the association list to the global list of structure types
  (if axstruct-structures ;structures list already exists
    (if (null (assoc symbol axstruct-structures));check for duplicate
      (setq axstruct-structures (cons alist axstruct-structures))
      (progn
        (princ (strcat "\nStructure " (vl-symbol-name symbol)
                       " already defined. Structure not created.\n"))
        (princ)
      );progn
    );if
    (setq axstruct-structures (list alist));otherwise create structures list
  );if
;;create list-, new-, get- and set- functions
    (axstruct-create-accessors symbol)
);axstruct
;;;--------------------
;;; Function: axstruct-types
;;; Params: none
;;; Return: list of defined structure types
;;;--------------------
(defun axstruct-types ()
  (mapcar 'car axstruct-structures)
);axstruct-types
;;---------------------
;;; Function: axstruct-get-type
;;; Params:   symbol
;;---------------------
(defun axstruct-get-type (symbol / index)
;;allow passing symbol as a string
  (if (= (type symbol) 'STR) (setq symbol (read symbol)))
;if the structure type is defined
  (if (setq index (vl-position symbol (axstruct-types)))
    (nth index axstruct-structures)
  );if
);axstruct-get-type
;;---------------------
;;; Function: axstruct-redefine
;;; Params:   symbol
;;---------------------
(defun axstruct-redefine (symbol elements / index )
;;allow passing symbol as a string
  (if (= (type symbol) 'STR) (setq symbol (read symbol)))
;if the structure type is defined
  (if (setq index (member symbol (axstruct-types)))
    (progn
      (axstruct-delete symbol);delete old definition
      (axstruct symbol elements);new definition cons'ed to front of list
    );progn
  );if
);axstruct-redefine
;;---------------------
;;; Function: axstruct-delete
;;; Params:   symbol
;;; To do:    delete accessor functions
;;---------------------
(defun axstruct-delete (symbol / index)
;;allow passing symbol as a string
  (if (= (type symbol) 'STR) (setq symbol (read symbol)))
;if the structure type is defined
  (if (member symbol (axstruct-types))
    (progn
      (axstruct-destroy-accessors symbol)
      (setq axstruct-structures
      (vl-remove-if (function (lambda (a) (eq (car a) symbol)))
          axstruct-structures))
    );progn
  );if
);axstruct-delete
;;---------------------
;;; Function: axstruct-new
;;; Params: symbol: name of the structure datatype
;;;         values: list containing initial values
;;; Usage: (axstruct-new symbol nil) => no initialization
;;;        (axstruct-new symbol '("Val1" "Val2" <etc.>))
;;;        (axstruct-new symbol '(:slot1 "Val1" :slot2 "Val2" <etc.>))
;;;        (axstruct-new symbol '("Val1" "Val2" :slotn "Valn" <etc.>))
;;; Rules: 1. "Valn" which exceed #slots are discarded
;;;        2. "Value" index is independent of :slot "Value" pairs
;;;        3. Last one wins
;;;--------------------
(defun axstruct-new (symbol values / array index pos #slots slots val)
;;allow passing symbol as a string
  (if (= (type symbol) 'STR) (setq symbol (read symbol)))
;if the structure type is defined
  (if (setq index (vl-position symbol (axstruct-types)))
;;create an instance
    (progn
      (setq #slots (1- (length (nth index axstruct-structures)))
            array (safearray vlax-vbVariant (cons 0 (1- #slots))))
;;initialize any values provided
;;allow partial initialization
      (if values
        (progn
          (setq slots (cdr(nth index axstruct-structures))
                index 0);reuse index
          (while values
            (cond ((vl-symbolp (setq val (car values)));first element a symbol
                   (setq val (vl-symbol-name val));convert it to string
                    (and (eq 58 (vl-string-elt val 0));1st char is colon
                    ;;strip the colon and convert remainder back to symbol
                         (setq val (read (vl-string-left-trim ":" val)))
                    ;;calculate the position of the symbol in slots
                         (setq pos (vl-position val (mapcar 'car slots)))
                    ;;remove the symbol from values
                         (setq values (cdr values))
                    ;;initialize the corresponding safearray element
                    ;;using the next element of values
                         (safearray-put-element array pos (car values))
                    ;;excise the first element of values
                         (setq values (cdr values))
                    );and
                  );pred
                  ( 1 ;value is not a symbol
                    (if (< index #slots);range check
                    ;;initialize the corresponding safearray element
                        (safearray-put-element array index val));end if
                    ;;always excise the first element of values
                        (setq values (cdr values))
                  );pred
            );cond
            (setq index (1+ index))
          );while
        );progn
      );if
      (list symbol array);return the structure
    );progn
  );if
);axstruct-new
;;--------------
;;; Function: axstruct-create-accessors
;;; Purpose: create list-, new-, get-<type>-prop & set-<type>-prop functions
;;; Params: symbol: symbol which is first element of structure
;;--------------
(defun axstruct-create-accessors (symbol / index
                                           param1
                                           param2
                                           proplist
                                           struct
                                           stype)
;;allow passing symbol as a string
  (if (= (type symbol) 'STR) (setq symbol (read symbol)))
;if the structure type is defined
  (if (setq index (vl-position symbol (axstruct-types)))
;;get the structure definition
    (progn
      (setq struct (nth index axstruct-structures)
            stype (vl-symbol-name symbol);(car struct))
            proplist (mapcar 'car (cdr struct)))
;;create list-<type> function
      (eval
        (list 'defun
              (read (strcat "list-" stype));function name
              (list 'param1)
              (list ;check structure type
                'if
                (list
                  'eq
                  (list 'car 'param1)
                  (list 'quote symbol)
                )
                (list 'axstruct->list 'param1)
              )
        );list
      );eval
;create new-<type> function
      (eval
        (list 'defun
              (read (strcat "new-" stype))
              (list 'param1)
              (list 'axstruct-new stype 'param1)
        );list
      );eval
;create get-<type>-<property> functions
      (foreach prop proplist
        (eval
          (list 'defun
                (read (strcat "get-" stype "-" (vl-symbol-name prop)))
                (list 'param1)
                (list ;check structure type
                 'if
                 (list
                    'eq
                    (list 'car 'param1)
                    (list 'quote symbol)
                  )
                 (list 'axstruct-getval 'param1
                  (list 'quote prop)
                 )
                )
          );list
        );eval
      );foreach
;create set-<type>-<property> functions
      (foreach prop proplist
        (eval
          (list 'defun
                (read (strcat "set-" stype "-" (vl-symbol-name prop)))
                (list 'param1 'param2)
                (list ;check structure type
                 'if
                 (list
                    'eq
                    (list 'car 'param1)
                    (list 'quote symbol)
                  )
                 (list 'axstruct-setval 'param1
                  (list 'quote prop)
                  'param2
                 )
                )
          );list
        );eval
      );foreach
    );progn
  );if
);axstruct-create-accessors
;;; Function: axstruct-destroy-accessors
;;; Purpose: destroy list-, new-, get-<type>-prop & set-<type>-prop functions
;;; Params: symbol: symbol which is first element of structure
;;--------------
(defun axstruct-destroy-accessors (symbol / index
                                           param1
                                           param2
                                           proplist
                                           struct
                                           stype)
;;allow passing symbol as a string
  (if (= (type symbol) 'STR) (setq symbol (read symbol)))
;if the structure type is defined
  (if (setq index (vl-position symbol (axstruct-types)))
;;get the structure definition
    (progn
      (setq struct (nth index axstruct-structures)
            stype (vl-symbol-name symbol);(car struct))
            proplist (mapcar 'car (cdr struct)))
;;destroy list-<type> function
      (eval
        (list 'setq
              (read (strcat "list-" stype));function name
              'nil
        );list
      );eval
;destroy new-<type> function
      (eval
        (list 'setq
              (read (strcat "new-" stype))
              'nil
        );list
      );eval
;destroy get-<type>-<property> functions
      (foreach prop proplist
        (eval
          (list 'setq
                (read (strcat "get-" stype "-" (vl-symbol-name prop)))
                'nil
          );list
        );eval
      );foreach
;destroy set-<type>-<property> functions
      (foreach prop proplist
        (eval
          (list 'setq
                (read (strcat "set-" stype "-" (vl-symbol-name prop)))
                'nil
          );list
        );eval
      );foreach
    );progn
  );if
);axstruct-destroy-accessors
;;--------------
;;; Function: axstruct-getval
;;; Params: symbol :  symbol which evaluates to the structure
;;;         element:  quoted - element from which to get value
;;--------------
(defun axstruct-getval (symbol element / index map)
;;allow passing element as a string
  (if (= (type element) 'STR) (setq element (read element)))
;if the structure type is defined
  (if (setq index (vl-position (car symbol) (axstruct-types)))
;get the map from the global structure list
    (progn
        (setq map (nth index axstruct-structures))
;use the element index from the map
    (variant-value
      (safearray-get-element (cadr symbol) (cdr (assoc element (cdr map)))))
    );progn
  );if
);axstruct-getval
;;--------------
;;; Function: axstruct-setval
;;; Params: symbol :  symbol which evaluates to the structure
;;;         element:  element to set value
;;;         value  :  desired value
(defun axstruct-setval (symbol element value / map)
;;allow passing element as a string
  (if (= (type element) 'STR) (setq element (read element)))
;if the structure type is defined
  (if (setq index (vl-position (car symbol) (axstruct-types)))
;get the map from the global structure list
    (progn
        (setq map (nth index axstruct-structures))
;use the element index from the map
      (safearray-put-element
       (cadr symbol) (cdr (assoc element (cdr map))) value)
    );progn
  );if
);axstruct-setval
;;--------------
;;; Function: axstruct->list
;;; Params: symbol :  symbol which evaluates to the structure
(defun axstruct->list (symbol / )
  (cons (car symbol) (mapcar 'variant-value (vlax-safearray->list (cadr symbol))))
);axstruct->list
;;--------------
;;load prompt
(princ "\nAXStruct V0.75 © 2009 Herman Mayfarth.")
(princ)