;; The following macro's are data extraction mechanisms.

(defmacro holes (disk)
  `(cdadr ,disk))

(defmacro rods-in-disk (disk)
  `(length (holes ,disk)))

(defmacro disks (object)
  `(cdar ,object))

(defmacro rods (object)
  `(cdadr ,object))

(defmacro crds (disk)
  `(cdaddr ,disk))

(defmacro ident-num (ident)
  `(implode (cdr (explode ,ident))))

(defmacro middle-disk (object)
  `(aux-middle-disk (disks ,object) nil))

(setq |0| 0)  ; This stuff has to be done so I can extract the number info
(setq |1| 1)  ; from things like 'h7 nad have the |7| be treated as a number
(setq |2| 2)  ; when I "eval" it.
(setq |3| 3)
(setq |4| 4)
(setq |5| 5)
(setq |6| 6)
(setq |7| 7)
(setq |8| 8)
(setq |9| 9)
(setq out 'out)
(setq in 'in)

;; "disk-feature-match" extracts the diskdata out of both inputs and
;; sends them over to "aux-df-match."

(defun disk-feature-match (object template)
  (aux-df-match (disks object) (disks template)))

;; "aux-df-match" runs recursively through "tdisks."  For each disk in
;; "tdisks" it counts how many rods are in that disk and then sees if
;; there is a disk in "odisks" that has the same number of rods.  If
;; so it recurses on the cdr of "tdisks" and the new "odisks" is the
;; old "odisks" with the disk that had the same number of rods
;; removed.  If it can't find a disk in "odisks" with the right number
;; of rods "nil" is returned.  When both lists are empty that means
;; each disk in "tdisks" has a disk in "odisks" with the same number
;; of rods so "t" is returned.

(defun aux-df-match (odisks tdisks)
  (cond ((and (null odisks) (null tdisks)) t)
	(t (let* ((tdisk (car tdisks))
		  (disk (aux-check-disks (rods-in-disk tdisk) odisks)))
	     (cond ((null disk) nil) ;there was no disk in odisks with the right # of rods
		   (t (aux-df-match (remove disk odisks) (cdr tdisks))))))))

;; "check-disks-for-rods" extracts the disk data from "object" and
;; calls "aux-check-disks" with "rnum" and the disk data..

(defun check-disks-for-rods (rnum object)
  (aux-check-disks rnum (disks object)))

;; "aux-check-disks" recursively goes through the disk data checking to
;; see if there are "rnum" rods in any of the disks.  If so it returns
;; that disk entry (needed for "aux-df-match") otherwise "nil."

(defun aux-check-disks (rnum disks)
  (cond ((null disks) nil)
	((eq (rods-in-disk (car disks)) rnum) (car disks))
	(t (aux-check-disks rnum (cdr disks)))))
    
;; "aux-middle-disk" finds the middle disk by a complete kludge.  It turns
;; out that all three of our possible objects have their most complicated
;; disks (the ones with the most rods) in the middle, except for the dog,
;; but he has a unique rod orientation from the other disks in his body.
;; This routine cdr's through "disks" and keeps the disk with the highest
;; number of rods in "hairiest."  If, however we come across a disk
;; that has an equal number of rods as "hairiest" and it doesn't have
;; rods in both "hin" and "hout" then IT becomes the "hairiest."  This
;; is a ugly kludge to take care of the dog.  The "hairiest" disk translates
;; into the "middle" disk for all our concerns.  When "disks" is empty
;; the "hairiest" disk is returned.

(defun aux-middle-disk (disks hairiest)
  (let ((disk (car disks)))
    (cond ((null disk) hairiest)
	  ((lessp (rods-in-disk hairiest) (rods-in-disk disk))
	   (aux-middle-disk (cdr disks) disk))
	  ((and (eq (rods-in-disk hairiest) (rods-in-disk disk))
		(not (in-outp disk))) ;kludge for dog
	   (aux-middle-disk (cdr disks) disk))
	  (t (aux-middle-disk (cdr disks) hairiest)))))

;; "in-outp" checks to see if both the "in" hole and the "out" hole
;; of "disk" is filled.

(defun in-outp (disk)
  (and (find-rod 'in (holes disk)) (find-rod 'out (holes disk))))

;; "find-rod" outputs the rod name associated with "hole-ident" in the
;; list "holes."  It cdr's down "holes" checking to see if the hole is
;; the hole in question, if so it outputs the associated rod.

(defun find-rod (hole-ident holes)
  (cond ((null holes) nil)
	((eq (eval (ident-num (caar holes))) hole-ident) ; The "eval"
	 (eval (ident-num (nth 1 (car holes))))) ; makes a |7| -> 7
	(t (find-rod hole-ident (cdr holes)))))

;; "check-angles-lengths-ends" takes a template and object disk (each
;; will always be the middle disk of its object) and the template and
;; the object.  It returns the list described in the comment to "aux-matcher."
;; It calls "line-up" with an angle list of the template and objects disks.
;; "rm-in-out" is used to get rid of the in and out holes so get-angs doesn't
;; get confused.  "line-up" does the real work.

(defun check-angles-lengths-ends (tdisk odisk template object)
  (line-up (get-angs (rm-in-out (holes tdisk))) (get-angs (rm-in-out (holes odisk)))
	   tdisk odisk template object))

;; "check-angles-lengths-crds" is analogous to the above procedure except
;; it is designed to work on end disks.  First it checks to make sure
;; that the translation is the same as it is for the middle disk.
;; (See note in the program run on Franz Lisp's problem with respect
;; to coordinate checking.) It gets all the possible
;; hole to hole mappings using just angles as criteria, then it checks
;; to make sure the associated rods are the same lengths.

(defun check-angles-lengths-crds (dsk1 dsk2 rods1 rods2 delta-crds)
  (cond ((not (check-crds (crds dsk1) (crds dsk2) delta-crds)) nil)
	(t (check-many-lengths (hole-to-rod (get-mappings
					       (get-angs (rm-in-out (holes dsk1)))
					       (get-angs (rm-in-out (holes dsk2)))
					       (hole-nums (holes dsk1))
					       (hole-nums (holes dsk2)))
					      (holes dsk1) (holes dsk2))
				 rods1 rods2))))

;; "check-crds" runs "delta-crds" on the coordinates of the two disks
;; which are end disks and see's if it matches the translation of
;; the middle disk.  (See note in program run as to why this doesn't
;; work right because of a MAJOR BUG IN FRANZ LISP!!!!!)

(defun check-crds (crd1 crd2 dcrd)
  (equal (delta-crds crd1 crd2) dcrd))

;; "check-many-lengths"  checks lengths of mapped rods for equality.
;; It calls "check-lenths" on particular disk mappings so see its
;; comment for more details.

(defun check-many-lengths (mappings rods1 rods2)
  (cond ((null mappings) nil)
	((not (check-lengths (car mappings) rods1 rods2))
	 (check-many-lengths (cdr mappings) rods1 rods2))
	(t t)))

;; "rm-in-out" builds up a list which is identical to "holes" except that
;; a hole entry (hin *) or (hout *) will be removed.

(defun rm-in-out (holes)
  (cond ((null holes) nil)
	((or (eq (caar holes) 'hin) (eq (caar holes) 'hout))
	 (rm-in-out (cdr holes)))
	(t (cons (car holes) (rm-in-out (cdr holes))))))

;; "rm-in-out2" is simmillar to the above except it removes in's and out's
;; from lists like (5 6 out 7).

(defun rm-in-out2 (holes)
  (cond ((null holes) nil)
	((or (eq (car holes) 'in) (eq (car holes) 'out))
	 (rm-in-out2 (cdr holes)))
	(t (cons (car holes) (rm-in-out2 (cdr holes))))))

;; "get-angs" is given a list of holes free of ins and outs.  It outputs
;; a list that is the differences between the holes (with rods of course).
;; So ((h5 *) (h7 *) (h2 *)) -> (2 3).  As you see it's not really the
;; differences but as long as we use this system consistantly it doesn't
;; matter.  "eval" has to be called because what is returned by "ident-num"
;; is the hole-number of a hole say (h5 r3) which is the last character
;; of "h5" which is |5| not 5.  The setq's a t the beging fix this so an
;; eval will give the right value.  "neg-fix" makes the above mentioned
;; hole list not come out as (2 -5).

(defun get-angs (holes)
  (cond ((null (cdr holes)) nil)
	(t (cons (neg-fix
		  (- (eval (ident-num (caadr holes))) (eval (ident-num (caar holes)))))
		 (get-angs (cdr holes))))))

;; "neg-fix" adds 8 to negative numbers to take care of the disk wrap
;; problem.

(defun neg-fix (num)
  (cond ((not (minusp num)) num)
	(t (+ num 8))))

;; "line-up" returns a list like (1 4 2 5) which means that rod 1
;; off the middle disk of the template object is analogous to rod
;; 4 off the middle disk of the unknown object.  The same for 2 and 5.
;; These rods are guaranteed to have the same lengths and also to have
;; disks at both ends.  It does similar things as
;; "check-angles-lengths-crds."  It gets the hole-to-hole mappings,
;; converts them to rod-to-rod mappings and sends them to
;; "consistant" that checks to see that the lengths of analogous
;; rods are the same and that analogous rods have the same thing at
;; each end (disks or no disks).  Remember that the output of this
;; is going to be used to test those end disks.

(defun line-up (tang oang tdisk odisk template object)
  (consistant (hole-to-rod (get-mappings tang oang
					 (hole-nums (holes tdisk))
					 (hole-nums (holes odisk)))
			   (holes tdisk) (holes odisk))
	       template object))

;; "hole-to-rod" takes a list in the form (((2 3) (6 7)) ((6 5) (8 7)))
;; and with the propper hole data it transforms it to a mapping list
;; of corresponding rod data.

(defun hole-to-rod (mappings tholes oholes)
  (cond ((null mappings) nil)
	(t (cons (mapcar (function (lambda (pair)
				     (list (find-rod (car pair) tholes) ; find the rod in this hole on template disk
					   (find-rod (nth 1 pair) oholes)))) ; find the rod in this hole on object disk
			 (car mappings))
		 (hole-to-rod (cdr mappings) tholes oholes)))))

;; "consistant" takes mapping lists and checks each mapping list to see
;; that the analogous rods are the same length and also that they
;; have the same things at their ends.  When it finds a mapping where there
;; are two analagous rods that have disks at each end it outputs a 4
;; element list as decribed in the comment for "line-up."

(defun consistant (mappings template object)
  (cond ((null mappings) nil)
	((not (check-lengths (car mappings) (rods template) (rods object)))
	 (consistant (cdr mappings) template object)) ;try another mapping
	(t (let ((r-w-end (check-ends (car mappings) (rods template) (rods object))))
	     (cond ((not (eq (length r-w-end) 4)) (consistant (cdr mappings) template object))
		   (t r-w-end))))))

;; "check-lengths" takes a mapping list ((1 3) (2 4) (3 5) ...) and
;; rod data for each object and checks to see if potentialy analogous
;; rods have the same length.

(defun check-lengths (mapping trods orods)
  (cond ((null mapping) t)
	((not (eq (rod-length (caar mapping) trods)
		  (rod-length (nth 1 (car mapping)) orods))) nil)
	(t (check-lengths (cdr mapping) trods orods))))

;; "check-ends" takes a mapping list as above and rod data as above
;; and checks to see if the potentialy analogous rods have a disk
;; at each end.  If they do it will output a list like the one
;; decribed in "line-up."  Any other time it will return nil, but
;; this does not mean that the rods can't be analogous, it is not
;; usues expressly for that purpose.

(defun check-ends (mapping trods orods)
  (cond ((null mapping) nil)
	((and (has-two-disks (caar mapping) trods)
	      (has-two-disks (nth 1 (car mapping)) orods))
	 (append (car mapping) (check-ends (cdr mapping) trods orods)))
	(t (check-ends (cdr mapping) trods orods))))

;; "rod-length" goes through the "rods" data looking for the rod numbered
;; "num."  When it finds it it returns its length.

(defun rod-length (num rods)
  (cond ((null rods) -1)
	((eq num (eval (ident-num (caar rods)))) (cadaddar rods))
	(t (rod-length num (cdr rods)))))

;; "has-two-disks" goes through the "rods" data looking for the rod numbered
;; "num."  It returns t if the rod has two disks on it, nil otherwise.

(defun has-two-disks (num rods)
  (cond ((null rods) nil)
	((eq num (eval (ident-num (caar rods)))) (eq 2 (length (cdadar rods))))
	(t (has-two-disks num (cdr rods)))))

;; "in-out" takes a list like (5 7 out 3 in) and turns it into
;; (out in).  This is used to separate (in "get-mappings") the in-out
;; holes from the other axis holes in doing the rotations of disks to
;; get mappings.

(defun in-out (holes)
  (cond ((null holes) nil)
	((or (eq (car holes) 'in) (eq (car holes) 'out))
	 (cons (car holes) (in-out (cdr holes))))
	(t (in-out (cdr holes)))))

;; "get-mappings" calls "rotate-to-match" on the differences list, which
;; returns a list of the number of rotations that of the diffs that
;; make them match.  For example with difference lists (1 5 1 5) and (5 1 5 1)
;; the last disk can be rotate 1 and 3 times for a match so "rotate-to-match"
;; would return (1 3).  This is then given to "rotate-and-map" along with
;; the holes of the disks without in-out and the in-out's.  This returns
;; a list of possible mappings.

(defun get-mappings (tang oang tholes oholes)
  (cond ((null tang) (list (map-holes tholes oholes)))
	(t (rotate-and-map (rotate-to-match tang oang) (rm-in-out2 tholes)
			   (rm-in-out2 oholes) (in-out tholes) (in-out oholes)))))

;; "rotate-to-match" takes two difference and calls "aux-...." with
;; these lists and the length of one list (they are both the same length)
;; minus one, which is how many times maximum that a list should be
;; rotated, and it's also given 0 which is used be "aux-..." to
;; keep track of how many times it has rotated a list.

(defun rotate-to-match (ang1 ang2)
  (cond ((or (null ang1) (null ang2)) nil)
	(t (aux-rotate-to-match ang1 ang2 (- (length ang2) 1) 0))))

;; "aux-rotate-to-match" compares ang1 and ang2 for equality.  If they
;; are equal it returns a list containing how many times it was
;; rotated so far.  Then, if it hasn't been rotated the maximum # of
;; times it calls itself recursively with the same first list, a
;; rotated second list, times - 1, and times-done+1.  So if it
;; matches more than once the net result will be a list with more
;; than one element.

(defun aux-rotate-to-match (ang1 ang2 times times-done)
  (cond ((eq times 0)
	 (cond ((equal ang1 ang2) (list times-done))
	       (t nil)))
	((equal ang1 ang2) (cons times-done
				 (aux-rotate-to-match ang1 (rotate 1 ang2)
						      (sub1 times) (add1 times-done))))
	(t (aux-rotate-to-match ang1 (rotate 1 ang2) (sub1 times) (add1 times-done)))))

;; "rotate-and-map" creates a list of mappings.  "times" is a list of
;; numbers representing how many times the second list should be rotated.
;; "tio" and "oio" are excluded from rotations because they are on
;; a different axis.  After the rotations are done the are joined
;; with their respective holes-list and everything is mapped together
;; using "map-holes."

(defun rotate-and-map (times tholes oholes tio oio)
  (cond ((null times) nil)
	(t (cons (map-holes (append tio tholes)
			    (append oio (rotate (car times) oholes)))
		 (rotate-and-map (cdr times) tholes oholes tio oio)))))

;; "map-holes" takes two equal length lists and outputs a list of lists
;; mapping the respective elements of the original lists. Ex:
;; (1 2 3 4) and (a b c d) -> ((1 a) (2 b) (3 c) (4 d))

(defun map-holes (lst1 lst2)
  (cond ((null lst1) nil)
	(t (cons (list (car lst1) (car lst2)) (map-holes (cdr lst1) (cdr lst2))))))

;; "rotate" rotates a list "lst" "counter-clockwise" "times" times.
;; It simply puts the car of the list on the end each time.

(defun rotate (times lst)
  (cond ((or (lessp times 0) (eq times 0)) lst)
	(t (rotate (sub1 times) (append (cdr lst) (list (car lst)))))))

;; "hole-nums" is given a list of holes say ((h5 *) (h2 *) (h7 *)) and
;; outputs a list consisting of the hole numbers (5 2 7).  It simply
;; cdr's down the "holes" list making a new list of the
;; "ident-num" (a macro that given say "h5" extracts the 5)
;; of the first element of the list and the "hole-nums" of the rest of
;; the list.

(defun hole-nums (holes)
  (cond ((null holes) nil)
	(t (cons (eval (ident-num (caar holes))) (hole-nums (cdr holes))))))

;; "disk-on" returns the actual disk (not the name) of the disk on the
;; oposite end of the "rod" from "from" (a disk name).  (car ........) gets
;; the disk name by locating the disks associated with "rod" in the
;; rods field of "object".  It then removes "from" from
;; this list and passes it to "get-disk" also with the disks information
;; of object.  "get-disk" finds the named disk.

(defun disk-on (rod from object)
  (get-disk (car (remove (car from) (find-disk rod (rods object))))
	    (disks object)))

;; "find-disk" is given a rod name and rod data.  It cdr's down "rods"
;; until it finds a rod who's name is the same.  It then outputs the
;; disk name of this rod (cdadar rods).

(defun find-disk (rod-number rods)
  (cond ((null rods) nil)
	((eq (eval (ident-num (caar rods))) rod-number) (cdadar rods))
	(t (find-disk rod-number (cdr rods)))))

;; "get-disk"  is given a disk name and a list of disks.  It cdr's
;; through "disks" until it finds a disk who's name is the same.  It
;; then outputs that disk.

(defun get-disk (disk-number disks)
  (cond ((null disks) nil)
	((eq disk-number (caar disks)) (car disks))
	(t (get-disk disk-number (cdr disks)))))

;; "delta-crds" outputs a list ((x <num>) (y <num>) (z <num>)) which
;; is the difference in coordinates of the two input coords.

(defun delta-crds (crd1 crd2)
  (list (difference (nth 1 (car crd1)) (nth 1 (car crd2)))
	(difference (nth 1 (nth 1 crd1)) (nth 1 (nth 1 crd2)))
	(difference (nth 1 (nth 2 crd1)) (nth 1 (nth 2 crd2)))))