p006.lisp 4.89 KB
Newer Older
Dave Cooper's avatar
Dave Cooper committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
(in-package :gdl)

(defparameter *1588p006-doc* 
" Keep the items in internal %version-tree% sorted based on root-path length.")


(define-object-amendment vanilla-mixin* ()

  :functions
  (("NIL. Restores the value of the given slot to its default, thus ``undoing'' any forcibly set value
 in the slot. Any dependent slots in the tree will respond accordingly when they are next demanded. 
 Note that the slot must be specified as a keyword symbol (i.e. prepended with a colon (``:'')), 
 otherwise it will be evaluated as a variable according to normal Lisp functional evaluation rules.
 :arguments (slot \"Keyword Symbol\")
 :key (force? \"Boolean. Specify as t if you want to force non-settable slots to recompute (e.g. 
reading from databases or external files). Defaults to nil.\")"
    restore-slot-default!
    (attribute &key (force? *force-restore-slot-default?*))
    (when (or force? (eql (the (slot-status attribute)) :set))
      (let (*leaf-resets*)
        (let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
          (unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
            (unbind-dependent-slots self slot) 
            (setf (slot-value self slot) 
              (if *remember-previous-slot-values?*
                  (list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
                'gdl-rule::%unbound%))))
        (let ((root (let ((maybe-root (the :root)))
		      (if (the-object maybe-root root?)
			  maybe-root
			  (the-object maybe-root parent))))
              
              ;;(root-path (remove :root-object-object (the root-path)))
              (root-path (the root-path))
              
              )
          ;;
          ;; FLAG -- this pushnew should never be necessary...
          ;;
          (pushnew (list root-path)
                   (gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
          (setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) 
            (remove-plist-key  (rest (assoc root-path
                                            (gdl-acc::%version-tree% root) :test #'equalp)) attribute))

	  (setf (gdl-acc::%version-tree% root)
		(sort (gdl-acc::%version-tree% root)
		      #'(lambda(item1 item2)
			  (< (length (first item1)) (length (first item2)))))))

        (when *eager-setting-enabled?*
          (dolist (reset *leaf-resets*)
            (the-object (first reset) (evaluate (second reset))))))))



   ("Void. Writes a file containing the toplevel inputs and modified settable-slots starting from the root of the 
 current instance. Typically this file can be read back into the system using the <tt>read-snapshot</tt> function.

 :&key ((filename \"/tmp/snap.gdl\") \"String or pathname. The target file to be written.\"
       (root-paths-to-ignore nil) \"List of root-paths or nil. Any objects with matching root-path will be ignored for the snapshot write.\"
       )"
    write-snapshot
    (&key (filename "/tmp/snap.gdl") (root-paths-to-ignore nil))

    
    (let (*print-level*
	  (root-object-object? (and (the parent) (the parent root?)
				    (defaulting (the parent root-object-object))
				    (eql (the parent root-object-object) self))))

      (let ((root (if root-object-object? (the root parent) (the root))))

	(setf (gdl-acc::%version-tree% root)
	      (sort (gdl-acc::%version-tree% root)
		    #'(lambda(item1 item2)
			(< (length (first item1)) (length (first item2))))))

	(with-open-file (out filename :direction :output :if-exists :supersede :if-does-not-exist :create)
	  (print `(in-package ,(make-keyword (package-name *package*))) out)
	  (mapcar #'(lambda(node)
		      (let ((root-path (first node)) (value-plist (rest node)))
			(unless (or (member root-path root-paths-to-ignore :test #'equalp)
				    (and root-object-object? 
					 (not (eql (lastcar root-path) :root-object-object))))
			  (when root-object-object? 
			    (setq root-path (if (consp (rest root-path))
						(butlast root-path)
						(the type))))
			  (let ((keys (plist-keys value-plist)) (values (plist-values value-plist)))
			    (let ((snap (cons root-path 
					      (append (when (atom root-path)
							(let (result)
							  (let* ((toplevel-inputs 
								  (remove-plist-key (the root active-inputs)
										    :remote-id))
								 (toplevel-input-keys (plist-keys toplevel-inputs))
								 (toplevel-input-values (plist-values toplevel-inputs)))
							    (mapc #'(lambda(key value) 
								      (when (not (member key keys)) 
									(push key result) (push value result)))
								  toplevel-input-keys toplevel-input-values))
							  (nreverse result)))
						      (mapcan #'(lambda(key val)
								  (let ((expression (readable-expression val self)))
								    (unless (eql expression :%unreadable%)
								      (list key expression))))
							      keys values))))) (print snap out))))))
		
		  (or (gdl-acc::%version-tree% root) (list nil))))))
    filename)))