;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Matthew Reeves - family_tree.lsp
;
;Resources Used:
;	Online version of book Practical Common Lisp
;		Link - http://gigamonkeys.com/book/
;	The Common Lisp Cookbook
;		Link - http://cl-cookbook.sourceforge.net/index.html
;	Common Lisp's Loop Examples for beginners
;		Link - http://www.unixuser.org/~euske/doc/cl/loop.html
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Initializes list "family" with test values
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq family '((Dora Ed
                     (Frank Gloria (Hannah)
                                   (Ingrid James)
                                   (Karen Lou (Matt) (Nathan)))
                     (Olive)
                     (Patrick Quady (Renee)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Turns lists with sub-lists into one long list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun flatten (lst)
    (cond ((null lst) nil)
        ((atom lst)
         (list lst))
        (t (append (flatten (car lst)) (flatten (cdr lst))))
        ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Fuction called to find children belonging to a given name
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun children (name)
    (setq result ())
    (cond ((NULL name) NIL)
          ((atom name)(recurse name family) (reverse result))
           (T NIL)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Handles bulk of work for finding offspring using recursion and filters out
; unwanted entries in the 'results' list as appropriate
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun recurse (name family)
    (cond ((NULL family) NIL)
          ((atom family) family)
           (T (cond ((equal name (recurse name (car family)))
                     (cond ((atom (cadr family))
                                (setq offspring (cddr family)) 
                                (LOOP for x in offspring
                                    do (cond ((NULL x) NIL)
                                              (T (setq result (cons (car x) 
                                                                result))))))
                            (T  (setq offspring (cdr family))
                     	        (LOOP for x in offspring
                                    do (cond ((NULL x) NIL)
                                              (T (setq result (cons (car x) 
                                                                result))))))))
                     (T (recurse name (cdr family)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Function called to identify g-children of name fed to function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun g-children (name)
    (setq lst ())
    (LOOP for x in (children name) 
	    do (cond ((NULL x) lst)
                 ((atom x)(setq lst (cons (children x) lst)) lst)
                  (T NIL)))
    (flatten lst))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Function called to identify g-g-children of name fed to function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun g-g-children (name)
    (setq lstgg ())
    (LOOP for x in (g-children name) 
    	do (cond ((NULL x) lstgg)
                 ((atom x)(setq lstgg (cons (children x) lstgg)) lstgg)
                  (T NIL)))
    (flatten lstgg))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Function called to identify parents of name fed to function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun parents (name)
    (setq lst ())
    (LOOP for x in (flatten family) 
	    do (cond ((member name (children x) :test 'equal)
	         	      (setq lst (cons x lst)) lst)
		          (T NIL)))
    (flatten lst))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Function called to identify g-parents of name fed to function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun g-parents (name)
    (setq lstg ())
    (LOOP for x in (flatten family) 
	    do (cond ((member name (g-children x) :test 'equal)
	         	      (setq lstg (cons x lstg)) lstg)
		          (T NIL)))
    (flatten lstg))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Function called to identify g-g-parents of name fed to function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun g-g-parents (name)
    (setq lstg ())
    (LOOP for x in (flatten family) 
	    do (cond ((member name (g-g-children x) :test 'equal)
	         	      (setq lstg (cons x lstg)) lstg)
		          (T NIL)))
    (flatten lstg))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Function called to identify sibling(s) of name fed to function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun sibling (name)
    (setq lsts ())
    (LOOP for x in (children (car (parents name))) 
	    do (cond ((eq x name) T)   
                  (T (setq lsts (cons x lsts)))))
    (flatten lsts))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Function called to identify cousin(s) of name fed to function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun cousin (name)
    (setq lstc ())
    (LOOP for x in (g-children (car (g-parents name))) 
	    do (cond ((equal x name) T)   
                  (T (if (member x (sibling name) :test 'equal)
                      (setq lstc (cons NIL lstc))(setq lstc (cons x lstc))))))
    (flatten lstc))