;;;; -*- Mode:LISP; Syntax:COMMON-LISP; Package:GBB; Base:10 -*-
;;;; *-* File: VAX6:DIS$DISK:[GBB.V-120.DISTRIBUTION]SAVE-BLACKBOARD.LISP *-*
;;;; *-* Edited-By: Gallagher *-*
;;;; *-* Last-Edit: Tuesday, July 25, 1989  19:56:00 *-*
;;;; *-* Machine: Gilgamesh (Explorer II, Microcode 416) *-*
;;;; *-* Software: TI Common Lisp System 4.105 *-*
;;;; *-* Lisp: TI Common Lisp System 4.105 (0.0) *-*

;;;; **************************************************************************
;;;; **************************************************************************
;;;; *
;;;; *                       BLACKBOARD SAVING FUNCTIONS                       
;;;; *
;;;; **************************************************************************
;;;; **************************************************************************
;;;
;;; Written by: Philip Johnson
;;;             Department of Computer and Information Science
;;;             University of Massachusetts
;;;             Amherst, Massachusetts 01003.
;;;
;;; This code was written as part of the GBB (Generic Blackboard) system at
;;; the Department of Computer and Information Science (COINS), University of 
;;; Massachusetts, Amherst.
;;;
;;; Copyright (c) 1987, 1988, 1989 COINS.  All rights reserved.
;;;
;;; Development of this code was partially supported by:
;;;    NSF CER grant DCR-8500332;
;;;    A donation from Texas Instruments;
;;;    ONR URI grant N00014-86-K-0764;
;;;    NSF CDPS grant MCS-8318776;
;;;    ONR CDPS contract N00014-79-C-0439;
;;;    NSF maintenance grant DCR-8318776.
;;;
;;; Permission to copy this software, to redistribute it, and to use it for
;;; any purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1.  Title and copyright to this software and any material associated
;;; therewith shall at all times remain with COINS.  Any copy made of this
;;; software must include this copyright notice in full.
;;;
;;; 2.  The user acknowledges that the software and associated materials
;;; are provided as a research tool that remains under active development
;;; and is being supplied ``as is'' for the purposes of scientific
;;; collaboration aimed at further development and application of the
;;; software and the exchange of technical data.
;;;
;;; 3.  All software and materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance with the
;;; usual standards of acknowledging credit in academic research.
;;;
;;; 4.  Users of this software agree to make their best efforts to inform
;;; the COINS GBB Development Group of noteworthy uses of this software.
;;; The COINS GBB Development Group can be reached at:
;;;
;;;     GBB Development Group
;;;     C/O Dr. Daniel D. Corkill
;;;     Department of Computer and Information Science
;;;     Lederle Graduate Research Center
;;;     University of Massachusetts
;;;     Amherst, Massachusetts 01003
;;;
;;;     (413) 545-0156
;;;
;;; or via electronic mail:
;;;
;;;     Corkill@CS.UMass.Edu
;;;
;;; Users are further encouraged to make themselves known to this group so
;;; that new releases, bug fixes, and tutorial information can be
;;; distributed as they become available.
;;;
;;; 5.  COINS makes no representations or warranties of the merchantability
;;; or fitness of this software for any particular purpose; that uses of
;;; the software and associated materials will not infringe any patents,
;;; copyrights, trademarks, or other rights; nor that the operation of this
;;; software will be error-free.  COINS is under no obligation to provide
;;; any services, by way of maintenance, update, or otherwise.  
;;;
;;; 6.  In conjunction with products or services arising from the use of
;;; this material, there shall be no use of the name of the Department of
;;; Computer and Information Science or the University of Massachusetts in
;;; any advertising, promotional, or sales literature without prior written
;;; consent from COINS in each case.
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;;
;;;  07-07-86 File Created.  (Johnson)
;;;  01-15-87 Rewrite of just about everything for GBB V1.0 (Johnson)
;;;  02-06-87 Several changes because the name slot of a unit-instance is now a
;;;           slot in basic-unit.  (Gallagher)
;;;  07-13-88 Fixed BUILD-DEFINE-UNIT-MAPPINGS so that it writes a
;;;           space-name instead of a space instance to the file.
;;;           Revised BUILD-MAKE-<UNIT-TYPE>, BUILD-UNIT-INSTANCE-LINKS so
;;;           they can write to FILE or NET stream.
;;;           BUILD-DEFINE-INDEX-STRUCTURES now correctly writes out :NONE if
;;;           the composite-index is nil.
;;;           BUILD-MAKE-<UNIT-TYPE> now calls a function to restore the unit
;;;           to all the spaces it was on when saved.  (Brolio)  
;;;  10-24-88 Made the save file more robust by using WITH-PROTECTED-WRITE and
;;;           ensuring that package prefixes were printed with all symbols. 
;;;           Also added WITH-PROTECTED-READ to RESTORE-BLACKBOARD-DATABASE.
;;;           (Gallagher)
;;;  06-20-89 Changed LINKF to LINKF! to insure that we don't signal an error
;;;           when setting a singular link from both ends.  (Cork)
;;;  07-25-89 Added COLLAPSE-REPLICATION-DESCRIPTIONS to fix the problem that
;;;           a single blackboard tree would get expanded into multiple
;;;           single-space trees after a save/restore cycle.  Fixed
;;;           INITIALIZE-SAVE-BLACKBOARD to ensure that all necessary included
;;;           unit definitions get saved.  Changed BUILD-DEFINE-SPACES and
;;;           BUILD-DEFINE-UNIT-MAPPINGS to only refer to units that are being
;;;           saved.  (Gallagher)
;;;           
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

(in-package 'GBB)

(export '(save-blackboard-database
	  restore-blackboard-database
	  check-gbb-and-save-file-consistency))

(use-package '(lisp umass-extended-lisp))

(proclaim `(optimize (speed ,*gbb-optimize-speed*)
                     (safety ,*gbb-optimize-safety*)))


;;; ===========================================================================
;;; Global symbols
;;; ===========================================================================

(defvar *save-space-instances* nil  "List of space instances to save.")
(defvar *save-unit-types*      nil  "List of unit names to save.")
(defvar *save-unit-instances*  nil  "List of unit instances to save.")
(defvar *save-paths*           nil  "List of bb/space paths to save")
(defvar %%omit-instantiation%% nil
  "Runtime flag based on RESTORE-BLACKBOARD-DATABASE argument.")

;;;================================================================================
;;;  The user interface: SAVE-BLACKBOARD-DATABASE
;;;================================================================================

(defun save-blackboard-database (file-or-stream path-structures
                                 &KEY (comment "Blackboard Save")
			     (instantiate-mode :ask))
  
  "SAVE-BLACKBOARD-DATABASE file-or-stream path-structures
                            &KEY comment instantiate-mode

   Save-blackboard-database saves the subset of the blackboard database specified
   by the single or list of PATH-STRUCTURES into FILE-OR-STREAM.  COMMENT is a
   string to be written to FILE-OR-STREAM as a comment.  INSTANTIATE-MODE allows 
   the user to specify a mode other than the default to be included in the call to
   instantiate-blackboard-database."
  
  (setf path-structures (assure-list path-structures))
  
  (initialize-save-blackboard path-structures)
  (if (streamp file-or-stream)
      (save-blackboard-aux file-or-stream comment instantiate-mode) 
      (with-open-file (stream (merge-pathnames file-or-stream "*.lisp")
			      :direction :output
			      :if-exists :new-version)
	(save-blackboard-aux stream comment instantiate-mode))))


(defun save-blackboard-aux (stream comment instantiate-mode)
					   
  "SAVE-BLACKBOARD-AUX stream comment instantiate-mode

   Writes out the save info to STREAM."

  (print-header stream comment)
  
  (with-protected-write
    ;; *print-circle* is turned off because if it is on then the same
    ;; label might be used in #n= notation.  This happens because each
    ;; slot is printed with a sepaarate call to print.
    (let ((*print-circle* nil))

      (print-section-comment stream "Define spaces.")
      (build-define-spaces stream)

      (print-section-comment stream "Define blackboards.") 
      (build-define-blackboards stream)

      (print-section-comment stream "Define the index-structures.")
      (build-define-index-structures stream)

      (print-section-comment stream "Define the units")
      (build-define-units stream)

      (print-section-comment stream "Define the unit-mappings.")
      (build-define-unit-mappings stream)

      (print-section-comment stream "Rebuild the BB structure")
      (build-instantiate-blackboard-database stream instantiate-mode)

      (print-section-comment stream "Make the Units to be saved on the bb")
      (build-make-<unit-type>s stream)

      (print-section-comment stream "Relink the units together.")
      (build-links stream))))


;;;================================================================================
;;;  The user interface: RESTORE-BLACKBOARD-DATABASE and
;;;   CHECK-GBB-AND-SAVE-FILE-CONSISTENCY
;;;================================================================================

(defun restore-blackboard-database (file-name &key (run-events nil)
                                                   (omit-instantiation nil))
  
  "RESTORE-BLACKBOARD-DATABASE file-name &KEY (run-events nil)
                                              (omit-instantiation nil)

   Restores the blackboard saved into FILE-NAME.  Events are run if
   RUN-EVENTS is non-NIL. The call to instantiate-blackboard-database
   is omitted if OMIT-INSTANTIATION is non-NIL."
  
  (let ((%%omit-instantiation%% omit-instantiation))
    (with-protected-read
      (if run-events
          (with-events-enabled
            (load file-name))
          (with-events-disabled
            (load file-name))))))


(defun check-gbb-and-save-file-consistency (version-number)

  "CHECK-GBB-AND-SAVE-FILE-CONSISTENCY version-number

   Checks for compatibility between GBB system and saved blackboard file code."

  ;; save-blackboard-database currently works with all versions of GBB.
  (declare (ignore version-number))
  t)

;;;================================================================================
;;; Initialize global structures.
;;;================================================================================


(defun initialize-save-blackboard (path-structures)
  
  "INITIALIZE-SAVE-BLACKBOARD path-structures

   Initializes global data structures from the passed path structures."

  (setf *save-unit-instances* nil
        *save-unit-types* nil
        *save-space-instances* (mapcar #'get-space-instance-from-path-structure
                                       path-structures)
        *save-paths* (mapcar #'get-path-from-path-structure path-structures))
  
  ;; Initialize *save-unit-instances* and *save-unit-types*.  This is a list
  ;; of the named instances to be saved.  No anonymous units are saved.
  (map-space #'(lambda (unit-inst)
		 (unless (anonymous-unit-instance-p unit-inst)
		   (pushnew unit-inst *save-unit-instances* :test #'equal-unit-instance-p)
                   (pushnew (type-of unit-inst) *save-unit-types* :test #'eq)))
             t
             path-structures)

  ;; Make sure that all necessary included unit types are on the list *save-unit-types*.
  (do* ((unit-types *save-unit-types* (cdr unit-types))
        (unit-type (car unit-types) (car unit-types))
        description included)
       ((endp unit-types))
    (setf description (get-unit-description unit-type))
    (setf included (unit.included description))
    (when (and included
               (not (member included *save-unit-types* :test #'eq)))
      ;; Add the included unit type to the end of the list *save-unit-types*.
      ;; I know that *save-unit-types* isn't going to be nil so this side
      ;; effect will work properly.  In particular, unit-types will eventually
      ;; cdr down to this newly added type.
      (nconc *save-unit-types* (list (unit.included description)))))

  ;; Sort *save-unit-types* so that any unit included by another will
  ;; be defined before it is needed.
  (flet ((unit-included-by-unit (u1 u2)
           ;; Returns true if u1 is included by u2 (directly or indirectly).
           (search-included-units
             #'(lambda (description) (eq u1 (unit.name description)))
             (get-unit-description u2))))
    (setf *save-unit-types*
          (sort *save-unit-types* #'unit-included-by-unit))))


;;;================================================================================
;;;  Build the define-spaces calls.
;;;================================================================================

(defun build-define-spaces (stream)
  
  "BUILD-DEFINE-SPACES

   Prints out calls to define-spaces."

  (dolist (space-type (mapcar #'space-instance.space
			      (remove-duplicates *save-space-instances* :key #'space-instance.space)))
    (format stream   "~2%(gbb::unless (gbb::space-name-p '~s) ~
                       ~%  (gbb::define-spaces (~s) ~
                       ~%    :UNITS ~s ~
                       ~%    :DIMENSIONS ("
            (space.name space-type)
            (space.name space-type)
            (intersection (space.units space-type) *save-unit-types*))
    (dolist (dimension (space.dimensions space-type))
      (format stream  "~%       (~s" (dimension.name dimension))
      (case (dimension.type dimension)
	 (:ordered
	  (format stream "   :ORDERED (~s ~s))"
		  (%range-start (odim.range dimension))
		  (%range-end (odim.range dimension))))
	 (:enumerated
	  (format stream "   :ENUMERATED (~{~s ~}))" (edim.labelset dimension)))
	 (otherwise
	  (error "Save-blackboard-database does not currently support ~s dimension types."
		 (dimension.type dimension)))))
    (format stream ")))")))

	
;;;================================================================================
;;;  Build the define-blackboards call.
;;;================================================================================

(defun build-define-blackboards (stream)
  
  "BUILD-DEFINE-BLACKBOARDS

   Prints out calls to define-blackboards."
  
  (let ((parents-and-sibs nil))	       ;assoc of bb nodes and their children
    ;; we just want to assoc each level of the bb with its children.
    ;; but we need to skip over the replication counts in the path spec.
    (dolist (path *save-paths*)
      (do* ((remaining-path path (cddr remaining-path))
	    (parent (first remaining-path) (first remaining-path))
	    (new-sibling (third remaining-path) (third remaining-path))
	    (old-siblings (cdr (assoc parent parents-and-sibs))
			  (cdr (assoc parent parents-and-sibs))))
	   ((equal (length remaining-path) 2))
	(if old-siblings
	    (pushnew new-sibling (cdr (assoc parent parents-and-sibs)))
	    (push-acons parents-and-sibs parent (list new-sibling)))))

    ;; now parents-and-sibs is in the form of:
    ;;   ((parent1 child child child) (parent2 child child child) etc..)
    (dolist (bb-level parents-and-sibs)
      (format stream "~2%(gbb::unless (gbb::blackboard-name-p '~s) ~
                       ~%  (gbb::define-blackboards (~s) ~s))"
	      (first bb-level) (first bb-level) (rest bb-level)))))

	
;;;================================================================================
;;;  Build the define-index-structure calls.
;;;================================================================================

(defun build-define-index-structures (stream)

  "BUILD-DEFINE-INDEX-STRUCTURES

   Builds the calls to define-index-structure."
  
  (let ((index-structures nil))
    (dolist (unit *save-unit-types*)
      (let ((unit-index-instances
              (append (unit.d-indexes (get-unit-description unit))
                      (unit.p-indexes (get-unit-description unit)))))
	(dolist (unit-index-instance unit-index-instances)
	  (unless (null (unit-index.index-structure unit-index-instance))
            (pushnew (unit-index.index-structure unit-index-instance) index-structures)))))
    
    (dolist (index-structure-instance index-structures)
      (format stream "~2%(gbb::unless (gbb::index-structure-name-p '~s) ~
                       ~%  (gbb::define-index-structure ~:*~s"
              (index-structure.name index-structure-instance))
      
      (cond ((index-structure.composite-type index-structure-instance)
             
             (format stream "~%    :COMPOSITE-TYPE ~s ~
                             ~%    :COMPOSITE-INDEX ~s ~
                             ~%    :ELEMENT-TYPE ~s"
                     (index-structure.composite-type index-structure-instance)
                     (or (index-structure.composite-index index-structure-instance) :none) 
                     (index-structure.element-type index-structure-instance)))
            (t             
             (format stream "~%    :TYPE ~s"
                     (index-structure.element-type index-structure-instance))))
      
      (format stream        "~%    :INDEXES ~s"
	      (index-structure.index-list index-structure-instance))
      (format stream "))"))))

;;;================================================================================
;;;  Build the define-unit calls.
;;;================================================================================

(defun build-define-units (stream)

  "BUILD-DEFINE-UNITS (stream)

   Rebuilds the define-unit calls for each unit type."

  (dolist (unit-type (sort *save-unit-types*
			   #'(lambda (x y) (not (unit-subtypep x y)))))
    (let ((description (get-unit-description unit-type)))
      (format stream "~2%(gbb::unless (gbb::unit-type-p '~s) ~
                        ~% (gbb::define-unit ~s ~
                        ~%    :SLOTS (~
                      ~{~%        ~s~})~
                        ~%    :LINKS (~
                      ~{~%        ~s~})~
                        ~%    :DIMENSIONAL-INDEXES (~
                      ~{~%        ~s~})~
                        ~%    :PATH-INDEXES (~
                      ~{~%        ~s~})~
                        ~%    :PATHS (~
                      ~{~%        ~s~})))"
	      unit-type
	      (unit.name-and-options description)
	      (unit.slot-list description)
	      (unit.link-list description)
	      (unit.d-index-list description)
	      (unit.p-index-list description)
	      (unit.paths description)))))
	      
;;;================================================================================
;;;  Build the define-unit-mapping calls.
;;;================================================================================

(defun build-define-unit-mappings (stream)

  "BUILD-DEFINE-UNIT-MAPPINGS

   Prints out the calls to define-unit-mappings."

  ;; DOLIST and lexical closures have a nasty interaction on the
  ;; Explorer, so turn off optimization for this function.  (The
  ;; closure is near the end of the function in a call to sort.)
  #+EXPLORER-RELEASE-2
  (declare (optimize (speed 1) (safety 3)))

  (let ((dereplicated-space-list (remove-duplicates *save-space-instances* :key #'space-instance.name))
        (already-mapped-list nil))

    (dolist (space-instance dereplicated-space-list)

      (dolist (unit-mapping-instance
		(space.unit-mappings (space-instance.space space-instance)))

        (let* ((units (intersection (unit-mapping.units unit-mapping-instance)
                                    *save-unit-types*))
               (space-names (map 'list #'space.name
                                 (unit-mapping.spaces unit-mapping-instance)))
               (indexes (unit-mapping.indexes unit-mapping-instance))
               (already-mapped-key (list units space-names)))
          (unless (or (member already-mapped-key already-mapped-list)
                      (and (null indexes) (null (unit-mapping.umi-list unit-mapping-instance))))
            (push already-mapped-key already-mapped-list)
            (format stream "~2%(gbb::unless (gbb::unit-mapping-specified-p '~s '~s)~
                             ~%  (gbb::define-unit-mapping ~2:*~s ~s ~
                             ~%    :INDEXES ~s ~
                             ~%    :INDEX-STRUCTURE ("
                             units space-names indexes)
            (dolist (umi-instance (unit-mapping.umi-list unit-mapping-instance))
              (let ((name (umi.name umi-instance))
                    (type (umi.type umi-instance)))
                (format stream "~%     (~s ~s " name type)
                (case type
		   (:subranges
		    (dolist (bucket-instance (umi.buckets umi-instance))
		      (let ((start (bucket.start bucket-instance))
			    (end (bucket.end bucket-instance))
			    (width (bucket.width bucket-instance)))
			(format stream "~%     (~s ~s (:WIDTH ~s))" start end width)))
		    (format stream ")"))
		   (:groups
		    (let* ((bucket-table (umi.buckets umi-instance))
			   (label-set
			     (sort (list-of-labels bucket-table)
				   #'< :key #'(lambda (label)
						    (get-label-index bucket-table label))))
			   (grouped-bucket nil))
		      (dolist (label label-set)
			(cond ((null grouped-bucket)
			       (push label grouped-bucket))
			      ((not (equal (get-label-index bucket-table (first grouped-bucket))
					   (get-label-index bucket-table label)))
			       (format stream " ~s" grouped-bucket)
			       (setf grouped-bucket nil))
			      (t                                 
			       (push label grouped-bucket)))))
		    (format stream ")"))
		   (otherwise
		    (error "Save-blackboard-database hasn't implemented ~s in unit-mappings" type)))))
            (Format stream ")))")))))))


;;;================================================================================
;;;  Build the call to instantiate-blackboard database
;;;================================================================================


(defun BUILD-INSTANTIATE-BLACKBOARD-DATABASE (stream instantiate-mode)

  "BUILD-INSTANTIATE-BLACKBOARD-DATABASE stream instantiate-mode

   Writes out a call to instantiate-blackboard-database to create the portion
   of the blackboard specified by the call to save-blackboard-database.  
   INSTANTIATE-MODE is a value to be supplied with the :MODE keyword."

  (format stream "~2%(GBB::UNLESS GBB::%%OMIT-INSTANTIATION%% ~
                   ~%  ~S)"
          `(instantiate-blackboard-database
             ,@(mapcar #'(lambda (x) (cons 'quote (list x)))
                       (collapse-replication-descriptions
                         (mapcar #'get-replication-description-from-path
                                 *save-paths*)))
	     :include-all-components nil
	     :mode ,instantiate-mode)))


(defun get-replication-description-from-path (path)

  "GET-REPLICATION-DESCRIPTION-FROM-PATH path

   Returns a replication description from a (fully replicated)
   path description.  For instance:
   (root 0 a 0 space1 0) => (root 0 (a 0 (space1 0)))"

    `(,(first path)
      (,(second path)
       ,(1+ (second path)))
      ,@(if (cddr path)
	    `(,(get-replication-description-from-path (cddr path))))))


(defun COLLAPSE-REPLICATION-DESCRIPTIONS (descriptions)
  "Reduce DESCRIPTIONS, which is a list of replication descriptions, into
   a more compact form."
  (collapse-replication-descriptions-1 (copy-tree descriptions)))


(defun COLLAPSE-REPLICATION-DESCRIPTIONS-1 (descriptions)

  (let ((any-modifications nil))

    (macrolet ((NODE-NAME (d) `(car ,d))
               (INDEXES (d) `(cadr ,d))
               (START-INDEX (d) `(car (indexes ,d)))
               (END-INDEX (d) `(cadr (indexes ,d))))

    (labels
      ((MERGE-SIBLINGS (descriptions)
         ;; Merge separate replication descriptions for sibling nodes.
         ;; E.g. ( (node (0 1) (a (0 1))) (node (0 1) (b (0 1))))
         ;; Will become ( (node (0 1) (a (0 1)) (b (0 1))) )
         (do* ((dl descriptions)
               (d (pop dl) (pop dl))
               sibling)
              ((endp dl)
               descriptions)
           (setf sibling (find d dl
                               :test #'(lambda (x y)
                                         (and
                                           (eq (node-name x) (node-name y))
                                           (equal (indexes x) (indexes y))))))
           (when sibling
             ;; Found a sibling description.
             (setf (cdr (last d)) (cddr sibling))
             (setf descriptions (delete sibling descriptions :test #'eq))
             (setf dl descriptions)
             (setf any-modifications t))))
       (MERGE-SUBSEQUENT (descriptions)
         ;; Merge separate replication descriptions for subsequent
         ;; replicated nodes.
         ;; E.g. ( (node (2 5) (a (0 1))) (node (5 6) (a (0 1))))
         ;; Will become ( (node (2 6) (a (0 1))) )
         (do* ((dl descriptions)
               (d (pop dl) (pop dl))
               next)
              ((endp dl)
               descriptions)
           (setf next (find d dl
                            :test #'(lambda (x y)
                                      (and
                                        ;; Node names are the same;
                                        (eq (node-name x) (node-name y))
                                        ;; End index of x = start index of y;
                                        (= (end-index x) (start-index y))
                                        ;; Children nodes are the same.
                                        (equal (cddr x) (cddr y))))))
           (when next
             ;; Found a subsequent description
             (setf (end-index d) (end-index next))
             (setf descriptions (delete next descriptions :test #'eq))
             (setf dl descriptions)
             (setf any-modifications t)))))

      ;; Merge the descriptions.  It may be the case that I can get a few
      ;; more potential merges by looping here, but I haven't found an
      ;; example of that yet.
      (setf descriptions (merge-siblings descriptions))
      (setf descriptions (merge-subsequent descriptions))
    
      ;; Recursively collapse subtrees immediately below each node.
      (dolist (description descriptions)
        (multiple-value-bind (new-description change-p)
            (collapse-replication-descriptions-1 (cddr description))
          (when change-p
            (setf (cddr description) new-description)
            (setf any-modifications t))))

      (values descriptions any-modifications)))))


;; I don't think this gets called anymore (kqg 7/25/89)
#+COMMENT
(defun build-one-blackboard-tree (node)
 
  "BUILD-ONE-BLACKBOARD-TREE node

  Traverses the passed blackboard structure and returns the blackboard structure
  in a form suitable for INSTANTIATE-BLACKBOARD-DATABASE."

 (cond ((typep (svref (db-node.vector node) 0) 'space-instance)  ;;bottom of tree
         (list (db-node.name node) (db-node.end node)))  ;; all done.
         
        ((typep node 'database-node)   ;;intermediate node
	 (nconc (list (db-node.name node) (db-node.end node))
	       (mapc-condcons #'build-one-blackboard-tree
			  (svref (db-node.vector node) 0))))
        
	;; If the blackboard database is screwed up.
        (t (error "Unplanned case in BUILD-ONE-BLACKBOARD. Blackboard database is corrupted."))))



;;;================================================================================
;;;  Build the calls to make-<unit-type>.
;;;================================================================================

(defun build-make-<unit-type>s (stream)

  "BUILD-MAKE-<UNIT-TYPE>S stream

   Calls build-make-<unit-type> with each of the unit instances to be restored."

  (dolist (unit-instance *save-unit-instances*)
    (build-make-<unit-type> stream unit-instance)))



(defmacro alias-unit-instance (name type)
  "This macro finds a unit or makes a dummy unit."
  `(or (find-unit-by-name ,name ',type)
       (,(form-gbb-symbol "MAKE-DUMMY-" type) :name ,name)))

(defun file-find-or-build-referenced-unit (unit)
  "Returns a lisp form that will find this unit.  If we are writing
   to a file, we do the work when saving, assuming that the user is
   saving at the end of a session and reading at the beginning."
  (let ((unit-name (basic-unit.name unit))
        (unit-type (unit-type-of unit)))
    `(or (find-unit-by-name ',unit-name ',unit-type)
         (,(form-symbol-in-package 'gbb "MAKE-DUMMY-" unit-type)
          :name ',unit-name))))

(defun net-find-or-build-referenced-unit (unit)
  "Returns a lisp form that will find this unit.  In this case
   (network), we make the receiver do the work, because it is
   requesting the information.  This also decreases somewhat the net
   traffic."
  `(alias-unit-instance ',(basic-unit.name unit) ',(UNIT-TYPE-OF unit)))

(defun build-make-<unit-type> (stream unit-instance &optional (stream-type :file))
  
  "BUILD-MAKE-<UNIT-TYPE> stream unit-instance &optional (stream-type :file))

   Writes out a call to make-<unit-type> for UNIT-INSTANCE.  Depending on the value
   of %%run-events%% at the time of the make, events will be run."
  
  (with-protected-write

    ;; write out the call to make-<unit-type>.
    (format stream
            "~2%(gbb::restore-units-to-spaces (lisp:or (gbb::find-unit-by-name ~s '~s)~%  (~s"
            (basic-unit.name unit-instance)
            (unit-type-of unit-instance)
            (unit.external-constructor (get-unit-description unit-instance)))
    ;;
    (dolist (slot *external-unit-slots*)
      (format stream "~%    ~s ~s"
              (form-keyword slot)
              (get-structure-slot unit-instance slot)))
    ;;
    ;; write out the slot names and their values.
    (dolist (slot (slot-names unit-instance))
      (let ((print-function (slot.save-print-function
                              (find-slot slot unit-instance)))
            (slot-value (get-structure-slot unit-instance slot)))
        (format stream "~%    ~s " (form-keyword slot))
        ;;if there is a print-function use it, otherwise if the slot-value
        ;;is a unit, output code to find or dummy the unit
        ;;else just output the value
        (cond (print-function
               (funcall print-function stream slot-value))
              ((UNIT-INSTANCE-P slot-value)
               (format stream "~%    ~s"
                       (case stream-type
                         (:file (file-find-or-build-referenced-unit slot-value))
                         (:net (net-find-or-build-referenced-unit slot-value)))))
              (t (format stream "'~s" slot-value)))))
    (format stream "))") ;; close MAKE-<UNIT> and close OR
    (format stream "~%  (make-paths :paths ~%   '(~{~s~%     ~})))" ;; and close restore-units-to-spaces
            (map 'list #'(lambda (p) (get-structure-slot p 'path-value))
                 (make-paths :unit-instances unit-instance)))
    ))

(defun restore-units-to-spaces (unit-instance paths)
  
  "RESTORE-UNITS-TO-SPACES unit-instance paths

   acts at load-time to make sure the unit-instance is added
   to any space-instances which it was on at save-time."

  (let ((ps (set-difference
               paths
               (make-paths :unit-instances unit-instance)
               :test #'equal-paths-p)))
    (when ps (add-unit-to-space unit-instance ps))))


;;;================================================================================
;;;  Links.  
;;;================================================================================

(defun build-links (stream)
  
  "BUILD-LINKS stream

   Calls build-unit-instance-links with each of the unit instances to be
   relinked into the GBB database."

  (dolist (unit-instance *save-unit-instances*)
    (build-unit-instance-links stream unit-instance)))

(defun build-unit-instance-links (stream unit-instance
                                  &optional (stream-type :file))
  
  "BUILD-UNIT-INSTANCE-LINKS stream unit-instance

   Write out the calls to LINKF to relink UNIT-INSTANCE to the other
   units in the database.  If the correct unit instance cannot be found,
   a dummy unit instance will be created and linked to."
  
  (let* ((description (get-unit-description unit-instance))
         (this-unit-type (unit.name description))
         (unit-package (unit.package (get-unit-description unit-instance)))
         (conc-name (unit.external-conc-name description))
         (this-unit-name (basic-unit.name unit-instance)))
    
    (dolist (the-link (unit.links description))
      (let* ((link-name (link.name the-link))
             (accessor
	       ;; This ugly hack required because Symbolics' pkg-find-package
	       ;; interprets "USER" relative to *package*.  My choice of CL-USER
	       ;; here will be wrong for someone...
	       (let (#+SYMBOLICS (*package* (find-package "CL-USER")))
			 (form-symbol-in-package unit-package
						 conc-name
						 link-name)))
             (link-value (remove-if #'anonymous-unit-instance-p
                                    (assure-list (get-structure-slot
                                                   unit-instance link-name)))))
	(when link-value
	  (dolist (other-unit-instance link-value)
            (format stream "~2%(gbb::linkf! (~s (gbb::find-unit-by-name ~s '~s))~%  ~s)"
                    accessor
                    this-unit-name
                    this-unit-type 
                    (case stream-type
                      (:file (file-find-or-build-referenced-unit other-unit-instance))
                      (:net (net-find-or-build-referenced-unit other-unit-instance))))
            ))))))

;;;================================================================================
;;;  Printing functions
;;;================================================================================

(defun print-section-comment (stream section)

  "PRINT-SECTION-COMMENT stream section

   Separates sections of the save file."
  
  (format stream
    "~2%;;; ~72,,,'=<=~>~%;;;   ~a~%;;; ~72,,,'=<=~>~%"
    section))


(defun print-header (stream comment)

  "PRINT-HEADER stream comment

   Writes out attribute list info, and other initial stuff."

  (let ((package-name (if *package* (package-name *package*) "USER")))

    (format stream
            #-SYMBOLICS ";;;; -*- Mode: Common-Lisp; Package: ~a; Base: 10 -*-"
            #+SYMBOLICS ";;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: ~a; Base: 10 -*-"
            package-name)
    (print-section-comment stream (string-concatenate (short-date-and-time) " --- " comment))
    (format stream "~2%(lisp::in-package ~s)~@
                    ~%(gbb::check-gbb-and-save-file-consistency ~s)"
            package-name
            (gbb-implementation-version))))


(defun pp-save-blackboard (file &aux (form t))
  
  "This reprints the save file in a prettier format.
   It's useful for debugging, but since defstruct structures are
   printed using their print-function rather than the #<...> syntax,
   the resulting 'pretty' file can't be loaded in many cases."

  (with-open-file (*in-file* (merge-pathnames file "*.lisp")
                             :direction :input)
    (with-open-file (*out-file* (merge-pathnames file "*.lisp")
                                :direction :output
                                :if-exists :new-version)
      (while form
        (setf form (read *in-file* nil nil))
	(pprint form *out-file*)))))


;;; ---------------------------------------------------------------------------
;;;                                End of File
;;; ---------------------------------------------------------------------------
