;;; -*- Mode: Lisp; Syntax: Common-lisp; Package: MU; Base: 10 -*- ;;; Copyright (c) 1987, Massachusetts Institute of Technology ;;; Author: Mike Drumheller ;;;***************************************************************************** ;;; CHANGE HISTORY ;;; ;;; 10/12/87 Changed the package to mu. Recompiled for Release 7. (W. Gillett) ;;;***************************************************************************** ;;; THIS FILE MUST BE USED IN A COMMON LISP ENVIRONMENT. Otherwise, some functions ;;; (like IS-AN-ARRAY, for example) will fail... ;;; ;;; This file contains some code which converts STRUCTURES into special LISTS so that they ;;; may be stored on disk relatively safely. ;;; ;;; "Safely" means that the structure definition (i.e., the DEFSTRUCT) can change in an ;;; arbitrary way between the events of SAVING and LOADING the structure on disk, and ;;; you will probably still be able to load it without any disasters. ;;; ;;; The magic functions that make all this possible are ;;; ;;; LISTIFY-ANY-EMBEDDED-STRUCTURES ;;; and ;;; REBUILD-ANY-EMBEDDED-LISTIFIED-STRUCTURES, ;;; ;;; which search through any Lisp data structure (lists, arrays, structures, strings, etc.) ;;; searching for occurences of structures. Whenever they find one, they turn it into a list ;;; (or rebuild it into a structure. ;;; ;;; That is the basic concept. You will just have to read the code to get more information; ;;; some of the stuff is hard to explain. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PLEASE NOTE the addition of the optional argument ;;; DONT-BOTHER-SEARCHING-FOR-STRUCTS-IN->-1-DIMENSIONAL-ARRAYS ;;; on March 3 1987. (Mike) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Main functions defined herein: ;;; ;;; SAVE-DATA ;;; data &optional (filename-string "saved-data") (directory *save-directory*) ;;; (listify-any-embedded-structures? t) ;;; ;;; LOAD-DATA ;;; filename-string ;;; &optional (symbol-to-bind '*disk-data*) (directory *save-directory*) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :mu) ;;; ;;; Conversion from structures to lists: (defun IS-A-STRUCTURE (object) ;;; ;;; Returns T if the object is a STRUCTURE created by DEFSTRUCT; otherwise NIL. ;;; #+symbolics (if (get (si:named-structure-p object) 'si:defstruct-description) t nil) #-symbolics (typep object 'structure)) (defun IS-AN-ARRAY (object) (and (not (stringp object)) #+symbolics (not (zl:stringp object)) (arrayp object))) #+symbolics (defun STRUCTURE-TO-LIST (structure &optional dont-bother-searching-for-structs-in->-1-dimensional-arrays) ;;; ;;; This function should never be called by the user. It is meant to be used ;;; strictly as part of the recursive process carried out by the function ;;; LISTIFY-ANY-EMBEDDED-STRUCTURES (see below). ;;; ;;; This function takes a STRUCTURE (which was created by DEFSTRUCT) and returns a list ;;; containing all the information necessary to rebuild the structure exactly. The list ;;; looks like this: ;;; ;;; (:LIST-VERSION-OF-A-STRUCTURE ( ) . . . ;;; ( )). ;;; ;;; (The reason :LIST-VERSION-OF-A-STRUCTURE appears at the head is so that ;;; other code can distinguish one of these lists from any old random list.) ;;; ;;; is the name of the kind of structure. For example, if ;;; the structure was created by (DEFSTRUCT (MILK-BONE) . . .), then ;;; would be the symbol MILK-BONE. ;;; ;;; There is a ( ) pair corresponding to every non-defaulted ;;; slot in the structure at the time the list version of it was created. If ;;; a slot contains its default value at the time it is "listified," then that ;;; slot is NOT included in the list version of the structure. This makes it ;;; much safer to rebuild the structures, in case somebody adds or removes ;;; slots in the structure definition, or otherwise changes the implementation ;;; of the structure (changes it from list to array, for example). ;;; ;;; See the documentation of LISTIFY-ANY-EMBEDDED-STRUCTURES for the ;;; meaning of the optional argument ;;; DONT-BOTHER-SEARCHING-FOR-STRUCTS-IN->-1-DIMENSIONAL-ARRAYS. ;;; (let* ((symbol-that-names-this-kind-of-structure (si:named-structure-p structure)) (defstruct-description (GET SYMBOL-THAT-NAMES-THIS-KIND-OF-STRUCTURE 'SI:DEFSTRUCT-DESCRIPTION)) (slot-descriptions (nth 3 defstruct-description)) (slot-names (loop for slot-description in slot-descriptions collecting (nth 0 slot-description))) (slot-accessors (loop for slot-description in slot-descriptions collecting (nth 6 slot-description))) (example-of-structure-with-default-values (eval (car (nth 5 defstruct-description)))) (list-version-of-the-structure nil)) (loop for slot-name in slot-names for slot-accessor in slot-accessors do (let ((actual-value (funcall slot-accessor structure)) (default-value (FUNCALL SLOT-ACCESSOR EXAMPLE-OF-STRUCTURE-WITH-DEFAULT-VALUES))) (unless (equal actual-value default-value) (push (list slot-name (listify-any-embedded-structures actual-value dont-bother-searching-for-structs-in->-1-dimensional-arrays)) list-version-of-the-structure)))) (setq list-version-of-the-structure (nreverse list-version-of-the-structure)) (push symbol-that-names-this-kind-of-structure list-version-of-the-structure) (push :list-version-of-a-structure list-version-of-the-structure) list-version-of-the-structure)) (defun LISTIFY-ANY-EMBEDDED-STRUCTURES (object &optional (dont-bother-searching-for-structs-in->-1-dimensional-arrays t)) ;;; ;;; OBJECT can be one of the following: ;;; 1) ATOM ;;; 2) ARRAY (of any dimension) ;;; 3) LIST ;;; 4) STRUCTURE ;;; ;;; Any element in OBJECT can can contain any object of these four types, ;;; recursing arbitrarily bla bla bla. ;;; ;;; This function makes a copy of OBJECT, with the only difference being that ;;; any STRUCTURE encountered during the copying process is converted to a ;;; list. ;;; ;;; STRUCTURE-TO-LIST (see above) does the "real work;" this just implements ;;; the recursion. ;;; ;;; If DONT-BOTHER-SEARCHING-FOR-STRUCTS-IN->-1-DIMENSIONAL-ARRAYS is T ;;; and OBJECT is an array having more than one dimension, then the ;;; function will NOT try to find embedded structures in the object. It ;;; will just return the object. ;;; ;;; DONT-BOTHER-SEARCHING-FOR-STRUCTS-IN->-1-DIMENSIONAL-ARRAYS should ;;; almost always be T, because in our applications, high-dimensional ;;; arrays are probably IMAGES; no way will they contain any structures. ;;; ;;; The function will ALWAYS search for structures in 1-dimensional arrays. ;;; ;;; NOTE that having this ;;; DONT-BOTHER-SEARCHING-FOR-STRUCTS-IN->-1-DIMENSIONAL-ARRAYS option ;;; is strictly a time- and space-saving device and is not very elegant, ;;; and might even be a little dangerous. ;;; ;;; Note: I considered having an optional argument like ;;; dimensions-of-arrays-search-for-structures-in, which would default ;;; to 1, meaning that any array that was not 1-dimensional would not ;;; be searched, but I decided to bag it because this way is clearer. ;;; Let me know if you object. --Mike ;;; (cond ((is-a-structure object) (structure-to-list object dont-bother-searching-for-structs-in->-1-dimensional-arrays)) ((listp object) (loop for item in object collecting (funcall #'listify-any-embedded-structures item dont-bother-searching-for-structs-in->-1-dimensional-arrays))) ((is-an-array object) (if (> (length (array-dimensions object)) 1) (if dont-bother-searching-for-structs-in->-1-dimensional-arrays object (let* ((new-array (make-array (array-dimensions object) :element-type (array-element-type object))) (1d-displaced-to-old (make-array (array-total-size object) :displaced-to object :element-type (array-element-type object))) (1d-displaced-to-new (make-array (array-total-size object) :displaced-to new-array :element-type (array-element-type object)))) (loop for i from 0 below (array-total-size object) do (setf (aref 1d-displaced-to-new i) (listify-any-embedded-structures (aref 1d-displaced-to-old i) dont-bother-searching-for-structs-in->-1-dimensional-arrays))) new-array)) (let ((new-array (make-array (array-total-size object) :element-type (array-element-type object)))) (loop for i from 0 below (array-total-size object) do (setf (aref new-array i) (listify-any-embedded-structures (aref object i) dont-bother-searching-for-structs-in->-1-dimensional-arrays))) new-array))) (t object))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Conversion from lists back to structures: (defun LIST-VERSION-OF-A-STRUCTURE-P (object) (if (and (listp object) (eq :list-version-of-a-structure (car object))) t nil)) #+symbolics (defun LIST-TO-STRUCTURE (list &optional (ignore-slots-that-no-longer-exist? t) (dont-bother-searching-for-structs-in->-1-dimensional-arrays t)) ;;; ;;; The inverse of STRUCTURE-TO-LIST (see above). ;;; ;;; This function should never be called by the user. It is meant to be ;;; used strictly as part of the recursive process carried out by the ;;; function REBUILD-ANY-EMBEDDED-LISTIFIED-STRUCTURES (see below). ;;; ;;; This function takes a list whose CAR is the symbol ;;; :LIST-VERSION-OF-A-STRUCTURE (see documentation for the function ;;; STRUCTURE-TO-LIST, above) and converts it back into the appropriate kind ;;; of structure, using the most current DEFSTRUCT definition of the ;;; structure. ;;; ;;; There is the possibility that the "listified" structure that you are ;;; trying to convert back into a regular old structure will be ;;; inconsistent with the current definition of the structure. That is, ;;; the DEFSTRUCT may have changed between save- and load- times. (This ;;; is exactly the event that most of the code in this file to designed ;;; to render painless.) The most serious problem would arise be if a ;;; slot that the structure was saved with no longer appears in the ;;; current definition of the structure. We have guessed that what you ;;; would most likely want to do is simply NOT FILL IN the "foreign" ;;; slot at load-time. If you specify ;;; IGNORE-SLOTS-THAT-NO-LONGER-EXIST? to be T, then this will happen, ;;; and you won't notice anything except that the new structure has some ;;; default-valued slots that you might not have expected. No big deal. ;;; If IGNORE-SLOTS-THAT-NO-LONGER-EXIST? is NIL, then this case will ;;; produce an error. ;;; (if (not (list-version-of-a-structure-p list)) (error "You are trying to convert some random list into a structure. The list must be a :LIST-VERSION-OF-A-STRUCTURE") (let* ((name-of-structure (cadr list)) (defstruct-description (GET NAME-OF-STRUCTURE 'SI:DEFSTRUCT-DESCRIPTION)) (structure (eval (car (nth 5 defstruct-description)))) (slot-descriptions (nth 3 defstruct-description)) (slotnames-in-current-defstruct (loop for slot-description in slot-descriptions collecting (first slot-description))) (slot-numbers-in-current-defstruct ;;;<--Used to be "slot-accessors," but this (loop for slot-description in slot-descriptions ;;; didn't work well. ;;; See below. collecting (second slot-description))) (slotname-value-pairs (cddr list))) (loop for slotname-value-pair in slotname-value-pairs do (let ((name (car slotname-value-pair)) (value (rebuild-any-embedded-listified-structures (cadr slotname-value-pair) ignore-slots-that-no-longer-exist? dont-bother-searching-for-structs-in->-1-dimensional-arrays ))) (let ((found-an-accessor nil)) (loop for slotname-in-curr-destruct in slotnames-in-current-defstruct for slot-num-in-curr-defstruct in slot-numbers-in-current-defstruct do (cond ((eq name slotname-in-curr-destruct) (setq found-an-accessor t) (setf (elt structure (1+ slot-num-in-curr-defstruct)) value) ))) ;;; Note that this line ^^^ used to be done like this: ;;; (eval `(setf (,slot-accessor ,structure) ',value)), ;;; or with something like ;;; (mulitple-value-bind (v v v store-form v) ;;; (get-setf-method (slot-accessor structure)) ;;; (setf store-form value) etc. etc., ;;; but it turned out that no matter what gyrations we went through to get ;;; the setf done using the real accessors was slow as molasses and ;;; consed like a bat out of hell. Carlf figured out the fix of using the ;;; slot numbers. Note the slot 0 is used to stor the structure name, ;;; hence the "1+". (if (and (not found-an-accessor) (not ignore-slots-that-no-longer-exist?)) (error "Big trouble. Apparently, there no longer exists a slot named ~a." name))))) structure))) (defun REBUILD-ANY-EMBEDDED-LISTIFIED-STRUCTURES (listified-object &optional (ignore-slots-that-no-longer-exist? t) (dont-bother-searching-for-structs-in->-1-dimensional-arrays t)) ;;; ;;; The inverse of LISTIFY-ANY-EMBEDDED-STRUCTURES (see above). ;;; LIST-TO-STRUCTURE does the "real work;" this just implements the ;;; recursion. ;;; (cond ((list-version-of-a-structure-p listified-object) (list-to-structure listified-object ignore-slots-that-no-longer-exist? dont-bother-searching-for-structs-in->-1-dimensional-arrays) ) ((listp listified-object) (loop for item in listified-object collecting (funcall #'rebuild-any-embedded-listified-structures item ignore-slots-that-no-longer-exist? dont-bother-searching-for-structs-in->-1-dimensional-arrays)) ) ((is-an-array listified-object) (if (> (length (array-dimensions listified-object)) 1) (if dont-bother-searching-for-structs-in->-1-dimensional-arrays listified-object (let* ((new-array (make-array (array-dimensions listified-object) :element-type (array-element-type listified-object))) (1d-displaced-to-old (make-array (array-total-size listified-object) :displaced-to listified-object :element-type (array-element-type listified-object))) (1d-displaced-to-new (make-array (array-total-size listified-object) :displaced-to new-array :element-type (array-element-type listified-object)))) (loop for i from 0 below (array-total-size listified-object) do (setf (aref 1d-displaced-to-new i) (rebuild-any-embedded-listified-structures (aref 1d-displaced-to-old i) ignore-slots-that-no-longer-exist? dont-bother-searching-for-structs-in->-1-dimensional-arrays))) new-array)) (let* ((new-array (make-array (array-total-size listified-object) :element-type (array-element-type listified-object)))) (loop for i from 0 below (array-total-size listified-object) do (setf (aref new-array i) (rebuild-any-embedded-listified-structures (aref listified-object i) ignore-slots-that-no-longer-exist? dont-bother-searching-for-structs-in->-1-dimensional-arrays))) new-array)) ) (t listified-object) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *save-directory* "b:>gillett>data>") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; "Primitives" for saving data on disk: (defvar *DISK-DATA* nil) #+symbolics (defun SAVE-DATA-INTERNAL (data filename-string directory) (sys:dump-forms-to-file (fs:merge-pathnames directory filename-string ".bin") `((setq *disk-data* ',data)))) (defun SAVE-DATA (data &optional (filename-string "saved-data") (directory *save-directory*) (listify-any-embedded-structures? t)) ;;; ;;; Saves "anything" on disk, but if you ask it to it will first makes a copy of it in ;;; which any structures are converted to lists (see above). ;;; (save-data-internal (if listify-any-embedded-structures? (listify-any-embedded-structures data) data) filename-string directory)) #+symbolics (defun LOAD-DATA (filename-string &optional (symbol-to-bind '*disk-data*) (directory *save-directory*)) ;;; ;;; Loads ANYTHING SAVED USING SAVE-DATA OR SAVE-DATA-IN-LIST-FORM from the ;;; disk, and builds a new copy in which any embedded "listified" structures ;;; are converted back into structures (see above). ;;; (load (fs:merge-pathnames directory filename-string ".bin")) (set symbol-to-bind (rebuild-any-embedded-listified-structures *disk-data*)) (symbol-value symbol-to-bind)) ;;; Hack to retrieve stereo data. (WEG 10/27/87) ;;; Why do I coerce strings to lower-case? Because UNIX uses case-sensitive ;;; file names. Obnoxious. ;; This isn't defined unless GROK is loaded (?). Obnoxoius. -- PAO 4/14/89 16:49:41 #+symbolics (compiler:function-defined 'grok::read-array-from-file) (defun GET-SCENE (name &optional (directory *calibration-data-directory*)) (declare (special *calibration-data-directory*)) (declare (special *left-array* *left-256* *right-256*)) (let ((namel (*lx::symbol-append name 'l)) (namels (*lx::symbol-append name 'ls)) (namerw (*lx::symbol-append name 'rw))) (declare (ignore namel)) ;-- pao 4/14/89 16:47:53 ;; let's skip retrieving the full left view, at least for now ; (setf (symbol-value namel) ; (ignore-errors ; (grok::read-array-from-file ; (string-downcase (concatenate 'string directory namel ".i"))))) (setf (symbol-value namels) (car (grok:new-loadimage ;;grok::read-array-from-file (string-downcase (concatenate 'string directory (symbol-name namels) ".i"))))) (setf (symbol-value namerw) (car (grok:new-loadimage ;;grok::read-array-from-file (string-downcase (concatenate 'string directory (symbol-name namerw) ".i"))))))) ;(defun GET-SCENE (name &optional (directory *calibration-data-directory*)) ; (setq *left-array* (grok::read-array-from-file (string-append directory name "l.i")) ; *left-256* (grok::read-array-from-file (string-append directory name "ls.i")) ; *right-256* (grok::read-array-from-file (string-append directory name "rw.i")))) ;;; Sigh. I'd prefer to write a fast vu:copy-raster, but I'm not interested in spending ;;; the time right now. Lucid doesn't seem to have any bitblt-type primitives, so ;;; I'm not sure what the fastest way to copy it is, anyway. -- PAO 3/04/92 12:26:32 #+symbolics (scl:deff copy-scene-raster #'vu:copy-raster) #-symbolics (defun copy-scene-raster (from-raster &key to-raster) (when (null to-raster) (multiple-value-bind (width height) (decode-raster-array from-raster) (setq to-raster (make-raster-array width height :element-type (array-element-type from-raster))))) (let ((from-vector #-lucid (make-array (array-total-size from-raster) :element-type (array-element-type from-raster)) #+lucid (sys:underlying-simple-vector from-raster)) (to-vector #-lucid (make-array (array-total-size to-raster) :element-type (array-element-type to-raster)) #+lucid (sys:underlying-simple-vector to-raster))) (replace to-vector from-vector))) (defun USE-SCENE (image) (declare (special *calibration-data-directory*)) (declare (special *left-array* *left-256* *right-256*)) (let* ((imagel-symbol (*lx::symbol-append image 'l)) (imagel (if (boundp imagel-symbol) (eval imagel-symbol))) (imagels (eval (*lx::symbol-append image 'ls))) (imagerw (eval (*lx::symbol-append image 'rw)))) (if imagel (copy-scene-raster imagel :to-raster *left-array*)) (copy-scene-raster imagels :to-raster *left-256*) (copy-scene-raster imagerw :to-raster *right-256*))) (defun GET-AND-USE-SCENE (name &optional (directory *calibration-data-directory*)) (declare (special *calibration-data-directory*)) (declare (special *left-array* *left-256* *right-256*)) (get-scene name directory) (use-scene name))