
(DEFPROP SHAREPAIR
 (LAMBDA (SORT PR) (SHARECONS' SORT (CAR PR) (CDR PR) PR))
EXPR)

(DEFPROP FORCESHARE
 (LAMBDA(SORT PR)
  ((LAMBDA(XREC)
    (COND
     (XREC
      ((LAMBDA(Z)
	(COND (Z (COND ((EQ Z PR)) ((ERR (QUOTE FORCESHARE)))))
	      ((RPLACD XREC (CONS (CONS (CDR PR) PR) (CDR XREC))))))
       (ASSOC1 (CDR PR) (CDR XREC))))
     ((ADDPROP SORT
	       (LIST (CAR PR) (CONS (CDR PR) PR))
	       (QUOTE SHARECONS)))))
   (ASSOC (CAR PR) (GET SORT (QUOTE SHARECONS)))))
EXPR)

(DEFPROP SHARECONS
 (LAMBDA (SORT X Y) (SHARECONS' SORT X Y (CONS X Y)))
EXPR)

(DEFPROP SHARECONS'
 (LAMBDA(SORT X Y CELL)
  (PROG	(XREC Z)
	(SETQ XREC (ASSOC X (GET SORT (QUOTE SHARECONS))))
	(COND
	 (XREC
	  (RETURN
	   (COND ((ASSOC1 Y (CDR XREC)))
		 ((SETQ Z (CONS' X Y CELL))
		  (RPLACD XREC (CONS (CONS Y Z) (CDR XREC)))
		  Z)))))
	(SETQ Z (CONS' X Y CELL))
	(ADDPROP SORT (LIST X (CONS Y Z)) (QUOTE SHARECONS))
	(RETURN Z)))
EXPR)

(DEFPROP CONS'
 (LAMBDA(X Y CELL)
  (COND	((AND (EQ X (CAR CELL)) (EQ Y (CDR CELL))) CELL)
	(T (CONS X Y))))
EXPR)

(DEFPROP CONDSHAREOB
 (LAMBDA(SORT OB)
  (COND ((GET SORT (QUOTE SHARE)) (SHAREOB SORT OB)) (OB)))
EXPR)

(DEFPROP SHAREOB
 (LAMBDA(SORT OB)
  (COND	((DONTSHAREPRED OB) OB)
	((SHAREPRED OB) (SHAREOB1 SORT OB))
	(T
	 (CONS' (SHAREOB SORT (CAR OB)) (SHAREOB SORT (CDR OB)) OB))))
EXPR)

(DEFPROP SHAREOB1
 (LAMBDA(SORT OB)
  (COND	((DONTSHAREPRED OB) OB)
	(T
	 (SHARECONS' SORT
		     (SHAREOB1 SORT (CAR OB))
		     (SHAREOB1 SORT (CDR OB))
		     OB))))
EXPR)

(DEFPROP SHAREPRED
 (LAMBDA (OB) (DEPTHCHK OB 0 SHAREDEPTH))
EXPR)

(DEFPROP DONTSHAREPRED
 (LAMBDA (OB) (OR (ATOM OB) (EQ (CAR OB) (QUOTE QUOTE))))
EXPR)

(DEFPROP SHARETRIPLE
 (LAMBDA(SORT X Y)
  (PROG	(XREC Z)
	(SETQ XREC (ASSOC X (GET SORT (QUOTE SHARETRIPLE))))
	(COND
	 (XREC
	  (RETURN
	   (COND ((ASSOC1 Y (CDR XREC)))
		 ((SETQ Z (TRIPLE SORT X Y))
		  (RPLACD XREC (CONS (CONS Y Z) (CDR XREC)))
		  Z)))))
	(SETQ Z (TRIPLE SORT X Y))
	(ADDPROP SORT (LIST X (CONS Y Z)) (QUOTE SHARETRIPLE))
	(RETURN Z)))
EXPR)

(DEFPROP DEPTHCHK
 (LAMBDA(OB N1 N2)
  (COND	((NOT (LESSP N1 N2)) NIL)
	((ATOM OB) N1)
	(((LAMBDA (X) (COND (X (DEPTHCHK (CDR OB) (ADD1 X) N2))))
	  (DEPTHCHK (CAR OB) N1 N2)))))
EXPR)
