(setf *load-print* T)
                                                                    
(defstruct link (key nil) (sublinks nil))                        

(defun link-contents (link) (link-sublinks link))                

(defsetf link-contents (link) (value)                            
  `(setf (link-sublinks ,link) ,value))                          

(defun next-link (key link flag)                                 
  (cond ( (find key (link-sublinks link) :key #'link-key) )    
	( flag                                                 
	  (let  ((sublink (make-link :key key)))             
	    (push sublink (link-sublinks link))            
	    sublink))                                      
	( T NIL)))                                             

(defun query-update (s-expr link flag)                          
  (cond ( (and (not flag) (not (link-p link)))  NIL )         
	( (atom s-expr)   (next-link s-expr link flag) )      
	(  T  (let* ((A  (next-link    '*CONS*   link flag))  
		     (B  (query-update (car s-expr) A flag))  
		     (C  (query-update (cdr s-expr) B flag))) 
		C))))                                       

(defun query (s-expr link)                                       
  (let  ((result (query-update s-expr link NIL)))              
    (and (link-p result) (link-contents result))))           

(defun update (s-expr link)                                      
  (let ((result (query-update s-expr link T)))                
    (and (link-p result)                                    
	 (or (link-contents result)                          
	     (setf (link-contents result) s-expr)))))        

(setf *FOO*
    (make-link :key 'FOO :sublinks
        (list
        (make-link :key '*CONS* :sublinks
            (list
            (make-link :key 'BOY :sublinks
                (list
                (make-link :key '*CONS* :sublinks
                    (list
                    (make-link :key 'JACK :sublinks
                        (list
                        (make-link :key NIL :sublinks '(BOY JACK)))
                     ))
                 ))
            )
            (make-link :key 'GIRL :sublinks
                (list
                (make-link :key '*CONS* :sublinks
                    (list
                    (make-link :key 'JILL :sublinks
                        (list
                        (make-link :key NIL :sublinks '(GIRL JILL)))
                    ))
                ))
            )
            (make-link :key 'DOG :sublinks
                (list
                (make-link :key '*CONS* :sublinks
                    (list
                    (make-link :key 'REX :sublinks
                        (list
                        (make-link :key NIL :sublinks '(DOG REX)))
                    )
                    (make-link :key 'SPOT :sublinks
                        (list
                        (make-link :key NIL :sublinks '(DOG SPOT)))
                    ))
                ))
            ))
        ))
    )
)

; Loading #p"/h/tas/fischman/h06-solved".
; LINK
; LINK-CONTENTS
; LINK-CONTENTS
; NEXT-LINK
; QUERY-UPDATE
; QUERY
; UPDATE
; (*CONS* *CONS* A B C)
; Warning:  Declaring *FOO* special.
; #S(LINK
;  etc. etc. etc.

(defun del (s-expr node) 
  (labels 
   ((del-s (s-expr link cut cp) 
	  (let* ((kid1 (next-link '*CONS* link NIL))
		 (kid (next-link (car s-expr) kid1 NIL)))
	    (cond ((or (not link) (not kid) (not cp) (not kid1)) NIL)
		  ((null (link-sublinks link)) NIL)
		  ((null (cdr (link-sublinks kid1)))  ;Only one child of link
		   (cond ((equal (link-key kid) 
				 (car (reverse s-expr)))  ;Right above terminal
			  (setf (link-sublinks cp)
				(delete (link-key cut) 
					(link-sublinks cp) :key #'link-key)
				)
			  T)
			 (T (del-s (cdr s-expr) kid cut cp))      ;far up
			 ))
		  (T (cond ((equal (link-key kid) 
				   (car (reverse s-expr)))  ;mult. kids/done
			    (setf (link-sublinks kid1)
				  (delete (link-key kid) 
					  (link-sublinks kid1) :key #'link-key)
				  )
			    )
			   ;mult. kids/not done
			   (T (del-s (cdr s-expr) kid kid kid1)) 
			   )
		     )
		  )
	    )
	  ))
    (del-s s-expr node node node)
   )			
  )

(update '(pres bill clinton) *FOO*)		
(query '(girl jill) *FOO*)
(query '(dog rex) *FOO*)
(del '(dog rex) *FOO*)
(query '(dog rex) *FOO*)
(query '(girl jill) *FOO*)
(query '(dog spot) *FOO*)

(query '(pres bill clinton) *FOO*)
(del '(pres bill clinton) *FOO*)
(query '(pres bill clinton) *FOO*)

; DEL-S
; DEL
; (PRES BILL CLINTON)
; (GIRL JILL)
; (DOG REX)
; (#S(LINK :KEY SPOT :SUBLINKS (#S(LINK :KEY NIL :SUBLINKS (DOG SPOT)))))
; NIL
; (GIRL JILL)
; (DOG SPOT)
; (PRES BILL CLINTON)
; T
; NIL