Author: lgiessmann Date: Sun Mar 21 04:36:20 2010 New Revision: 236 Log: new-datamodel: optimized "make-construct" Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Sun Mar 21 04:36:20 2010 @@ -1,4 +1,4 @@ -#;;+----------------------------------------------------------------------------- +;;+----------------------------------------------------------------------------- ;;+ Isidorus ;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann ;;+ Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 21 04:36:20 2010 @@ -1645,7 +1645,7 @@ (eql class-symbol 'NameC))) -(defgeneric initialize-name (construct variants &key start-revision) +(defgeneric complete-name (construct variants &key start-revision) (:documentation "Adds all given variants to the passed construct.") (:method ((construct NameC) (variants list) &key (start-revision *TM-REVISION*)) @@ -1966,7 +1966,7 @@ (CharacteristicC-p class-symbol)))) -(defgeneric initialize-reifiable (construct item-identifiers reifier +(defgeneric complete-reifiable (construct item-identifiers reifier &key start-revision) (:documentation "Adds all item-identifiers and the reifier to the passed construct.") @@ -2146,7 +2146,7 @@ (CharacteristicC-p class-symbol)))) -(defgeneric initialize-typable (construct instance-of &key start-revision) +(defgeneric complete-typable (construct instance-of &key start-revision) (:documentation "Adds the passed instance-of to the given construct.") (:method ((construct TypableC) instance-of &key (start-revision *TM-REVISION*)) @@ -2176,7 +2176,7 @@ (CharacteristicC-p class-symbol)))) -(defgeneric initialize-scopable (construct themes &key start-revision) +(defgeneric complete-scopable (construct themes &key start-revision) (:documentation "Adds all passed themes to the given construct.") (:method ((construct ScopableC) (themes list) &key (start-revision *TM-REVISION*)) @@ -2394,17 +2394,25 @@ ((RoleC-p class-symbol) (make-role args)) ((AssociationC-p class-symbol) - (make-association args))))) - construct)) + (make-association args)))) + (start-revision (getf args :start-revision))) + (when (typep construct 'TypableC) + (complete-typable construct (getf args :instance-of) + :start-revision start-revision)) + (when (typep construct 'ScopableC) + (complete-scopable construct (getf args :themes) + :start-revision start-revision)) + (if (typep construct 'ReifiableConstructC) + (complete-reifiable construct (getf args :item-identtifiers) + (getf args :reifier) :start-revision start-revision) + construct))) (defun make-association (args) "Returns an association object. If the association has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" - (let ((item-identifiers (getf (first args) :item-identifiers)) - (reifier (getf (first args) :reifier)) - (instance-of (getf (first args) :instance-of)) + (let ((instance-of (getf (first args) :instance-of)) (start-revision (getf (first args) :start-revision)) (themes (get (first args) :themes)) (roles (get (first args) :roles)) @@ -2427,23 +2435,16 @@ (if existing-association existing-association (make-instance 'AssociationC))))) - (initialize-typable association instance-of :start-revision - start-revision) (dolist (role roles) (add-role association role :revision start-revision)) - (dolist (theme themes) - (add-theme association theme :revision start-revision)) - (initialize-reifiable association item-identifiers reifier - :start-revision start-revision)))) + association))) (defun make-role (args) "Returns a role object. If the role has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" - (let ((item-identifiers (getf args :item-identifiers)) - (reifier (getf args :reifier)) - (parent (getf args :parent)) + (let ((parent (getf args :parent)) (instance-of (getf args :instance-of)) (player (getf args :player)) (start-revision (getf args :start-revision)) @@ -2467,11 +2468,9 @@ (make-instance 'RoleC))))) (when player (add-player role player :revision start-revision)) - (initialize-typable role instance-of :start-revision start-revision) (when parent (add-parent role parent :revision start-revision)) - (initialize-reifiable role item-identifiers reifier - :start-revision start-revision)))) + role))) (defun make-tm (args) @@ -2505,8 +2504,7 @@ (make-instance 'TopicMapC)))))) (dolist (top-or-assoc (union topics assocs)) (add-to-tm tm top-or-assoc)) - (initialize-reifiable tm item-identifiers reifier - :start-revision start-revision)))) + tm))) (defun make-topic (&rest args) @@ -2543,9 +2541,6 @@ (t (make-instance 'TopicC)))))) (let ((merged-topic topic)) - (setf merged-topic - (initialize-reifiable topic item-identifiers nil - :start-revision start-revision)) (dolist (psi psis) (setf merged-topic (add-psi merged-topic psi :revision start-revision))) @@ -2572,9 +2567,7 @@ (instance-of (getf (first args) :instance-of)) (themes (getf (first args) :themes)) (variants (getf (first args) :variants)) - (reifier (getf (first args) :reifier)) (parent (getf (first args) :parent)) - (item-identifiers (getf (first args) :item-identifiers)) (err "From make-characteristic(): ")) (unless start-revision (error "~astart-revision must be set" err)) (unless charvalue (error "~acharvalue must be set" err)) @@ -2599,14 +2592,10 @@ existing-characteristic (make-instance class-symbol :charvalue charvalue :datatype datatype))))) - (initialize-scopable characteristic themes :start-revision start-revision) - (initialize-typable characteristic instance-of - :start-revision start-revision) - (initialize-name characteristic variants :start-revision start-revision) + (complete-name characteristic variants :start-revision start-revision) (when parent (add-parent characteristic parent :revision start-revision)) - (initialize-reifiable characteristic item-identifiers - reifier :start-revision start-revision)))) + characteristic))) (defun make-pointer (class-symbol &rest args)