;-*- Mode:LISP; Package:CHANGETRANPACKAGE; Base:10; Readtable:INTERLISP -*-
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This program contains confidential information of Inference Corporation.  Use or copying   ;
; without express written authorization of Inference Corporation is strictly prohibited.     ;
; Copyright ownership rights hereby asserted by Inference Corporation.  Copyright 1984.      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;

(DEFCONST BogusSymbol (GENSYM))
(DEFCONST BogusSymbol2 (GENSYM))
(DEFCONST AccessorReevaluateThreshold 4)
(DEFVAR SimpleAccessors
	'(CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR
	      CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR
	      CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR
	      FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH
	      REST1 REST2 REST3 REST4
	      VALUE-CELL-LOCATION CAR-LOCATION))

(DEFUN ReevaluateAccessor? (AccessorForm &OPTIONAL (Level AccessorReevaluateThreshold))
  (COND ((PLUSP Level)
	 (AND (LISTP AccessorForm) (SETQ AccessorForm (MACROEXPAND AccessorForm)))
	 (OR (NLISTP AccessorForm)
	     (AND (MEMQ (CAR AccessorForm) SimpleAccessors)
		  (ReevaluateAccessor? (CADR AccessorForm) (1- Level)))
	     (SELECTQ (CAR AccessorForm)
	       (AREF (AND (for index in (CDDR AccessorForm) always
			       (OR (FIXP index) (SYMBOLP index)))
			  (ReevaluateAccessor? (CADR AccessorForm) (1- Level))))
	       ((NTH NTHCDR) (AND (FIXP (CADR AccessorForm))
				  (ReevaluateAccessor?
				    (THIRD AccessorForm)
				    (- Level 1 (// (CADR AccessorForm) 4)))))
	       (QUOTE T))))))

(DEFUN CONSify (Elements List)
  (bind (Expression _ List) for element in Elements do
	(SETQ Expression `(CONS ,element ,Expression))
	finally (RETURN Expression)))

(DEFMACRO DefineChangeMacro (Name ArgumentList ArgumentAccessor Level ReevaluateCode SafeCode
				  &REST FinalizingCode)
  `(DEFMACRO ,Name ,ArgumentList
     (LET (Result Reevaluate? (Accessor ,ArgumentAccessor))
       (SETQ Result (COND ((SETQ Reevaluate? (ReevaluateAccessor? Accessor ,Level))
			   ,ReevaluateCode)
			  (T ,SafeCode)))
       ,.(COPYLIST FinalizingCode))))

(DefineChangeMacro push (&REST ElementsThenStack)
  (CAR (LAST ElementsThenStack)) AccessorReevaluateThreshold
  `(SETF ,Accessor ,(CONSify (NREVERSE (BUTLAST ElementsThenStack)) Accessor))
  `(LET ((,BogusSymbol (LOCF ,Accessor)))
     (CAR (RPLACA ,BogusSymbol
		  ,(CONSIFY (NREVERSE (BUTLAST ElementsThenStack)) `(CAR ,BogusSymbol))))))

(DefineChangeMacro extend (List &REST Elements)
  List AccessorReevaluateThreshold
  `(SETF ,Accessor (NCONC ,Accessor (LIST ,.Elements)))
  `(LET ((,BogusSymbol (LOCF ,Accessor)))
     (CAR (RPLACA ,BogusSymbol (NCONC (CAR ,BogusSymbol) (LIST ,.Elements))))))

(DefineChangeMacro extend-variable (List &REST Elements)
  List AccessorReevaluateThreshold
  `(SETF ,Accessor (EXTEND-NEW-EQUAL ,Accessor ,.Elements))
  `(LET ((,BogusSymbol (LOCF ,Accessor)))
     (CAR (RPLACA ,BogusSymbol (EXTEND-NEW-EQUAL (CAR ,BogusSymbol) ,.Elements)))))

(DEFUN EXTEND-NEW-EQUAL (List &REST Elements)
  (NCONC List (for e in Elements unless (MEMBER e List) collect e)))

(SPECIAL ElementsThenStack NeedElementTemp?)
(DefineChangeMacro pushnew (&REST ElementsThenStack &AUX NeedElementTemp?)
  (CAR (LAST ElementsThenStack))
  (// AccessorReevaluateThreshold (1- (LENGTH ElementsThenStack)))
  `(PROGN ,.(ComputePushNew Accessor))
  `(LET ((,BogusSymbol (LOCF ,Accessor))) ,.(ComputePushNew `(CAR ,BogusSymbol)))
  (COND (NeedElementTemp?
	 (COND (Reevaluate? `(LET (,BogusSymbol2) ,Result))
	       (T (RPLACD (CADR Result) (NCONS BogusSymbol2))
		  Result)))
	(T Result)))

(SPECIAL ElementsThenStack NeedElementTemp?)
(DEFUN ComputePushNew (Accessor)
  (NREVERSE (for tail on ElementsThenStack while (CDR tail) collect
		 (COND ((ReevaluateAccessor? (CAR tail) (* AccessorReevaluateThreshold 2))
			`(OR (MEMQ ,(CAR tail) ,Accessor)
			     (SETF ,Accessor (CONS ,(CAR tail) ,Accessor))))
		       (T (SETQ NeedElementTemp? T)
			  `(OR (MEMQ (SETQ ,BogusSymbol2 ,(CAR tail)) ,Accessor)
			       (SETF ,Accessor (CONS ,BogusSymbol2 ,Accessor))))))))

(DefineChangeMacro pushlist (&REST ListsThenStack)
  (CAR (LAST ListsThenStack)) AccessorReevaluateThreshold
  `(SETF ,Accessor (APPEND ,.(BUTLAST ListsThenStack) ,Accessor))
  `(LET ((,BogusSymbol (LOCF ,Accessor)))
     (CAR (RPLACA ,BogusSymbol (APPEND ,.(BUTLAST ListsThenStack) (CAR ,BogusSymbol))))))

(DefineChangeMacro conclist (&REST ListsThenStack)
  (CAR (LAST ListsThenStack)) AccessorReevaluateThreshold
  `(SETF ,Accessor (NCONC ,.(BUTLAST ListsThenStack) ,Accessor))
  `(LET ((,BogusSymbol (LOCF ,Accessor)))
     (CAR (RPLACA ,BogusSymbol (NCONC ,.(BUTLAST ListsThenStack) (CAR ,BogusSymbol))))))

(DefineChangeMacro swap (Accessor1 Accessor2)
  Accessor1 AccessorReevaluateThreshold
  (COND ((ReevaluateAccessor? Accessor2)
	 `(SETF ,Accessor1 (PROG1 ,Accessor2 (SETF ,Accessor2 ,Accessor1))))
	(T `(LET ((,BogusSymbol (LOCF ,Accessor2)))
	      (RPLACA ,BogusSymbol (PROG1 ,Accessor1 (SETF ,Accessor1 (CAR ,BogusSymbol)))))))
  (COND ((ReevaluateAccessor? Accessor2)
	 `(LET ((,BogusSymbol (LOCF ,Accessor1)))
	    (RPLACA ,BogusSymbol (PROG1 ,Accessor2 (SETF ,Accessor2 (CAR ,BogusSymbol))))))
	(T `(LET ((,BogusSymbol (LOCF ,Accessor1)) (,BogusSymbol2 (LOCF ,Accessor2)))
	      (RPLACA ,BogusSymbol (PROG1 (CAR ,BogusSymbol2)
					  (RPLACA ,BogusSymbol2 (CAR ,BogusSymbol))))))))

(DefineChangeMacro add (Value Accessor)
  Accessor AccessorReevaluateThreshold
  `(SETF ,Accessor (+ ,Value ,Accessor))
  `(LET ((,BogusSymbol (LOCF ,Accessor)))
     (CAR (RPLACA ,BogusSymbol (+ ,Value (CAR ,BogusSymbol))))))


(DefineChangeMacro change (Accessor ChangeForm)
  Accessor (// AccessorReevaluateThreshold
	       (1+ (// (NumberOccurrencesOf 'DATUM ChangeForm) 2)))
  `(SETF ,Accessor ,(SUBST Accessor 'DATUM ChangeForm))
  `(LET ((,BogusSymbol (LOCF ,Accessor)))
     (CAR (RPLACA ,BogusSymbol ,(SUBST `(CAR ,BogusSymbol) 'DATUM ChangeForm)))))

(DEFUN NumberOccurrencesOf (Entity Structure)
 (COND ((EQ Entity Structure) 1)
       ((NLISTP Structure) 0)
       (T (for element inside Structure sum (NumberOccurrencesOf Entity element)))))