/* -*- Macsyma -*- */
EVAL_WHEN(BATCH,TTYOFF:TRUE)$
/*ASB;DECLIN 6
12:28pm  Saturday, 13 March 1982
  Removed GETSYMBOL and PUTSYMBOL to GENUT.  Not recompiled.
7:42pm  Saturday, 29 May 1982
  Added a DIAGEVAL_VERSION for this file.
1:18pm  Saturday, 12 June 1982
  Changed loadflags to getversions, DEFINE_VARIABLE:'MODE.
*/

EVAL_WHEN(BATCH,
	  IF GET('DEBUG,'VERSION)=FALSE AND STATUS(FEATURE,ITS)=TRUE
	  THEN LOAD('[DEBUG,FASL,DSK,DGVAL]))$

/* can't be translated in DOE-MACSYMA without extra files
EVAL_WHEN([TRANSLATE],
	  IF GET('GRAPH,'VERSION)=FALSE AND INDEPENDENT#TRUE
	  THEN LOAD(graph),
	  TRANSCOMPILE:TRUE,
	  DEFINE_VARIABLE:'MODE,
	  MODEDECLARE(FUNCTION(NULLLISTP,ZEROLISTP,LCLINEARP1,LCLINEARP2,
			       LCPRED,ONEONLY),
		      BOOLEAN),
	  DECLARE([GNAUTOLOAD,OPDUM,LINPREDDUM,LINPOSNS],SPECIAL))$
*/
PUT('DECLIN,6,'VERSION)$
/* don't have this file in DOE-MACSYMA
EVAL_WHEN(LOADFILE,
	  IF GET('GNAUTO,'VERSION)=FALSE
	  THEN LOAD(['GNAUTO,'FASL,'DSK,'DGVAL]))$
*/
DEFINE_VARIABLE(MESSDECLIN1,
		"contains an undeclared operator--LINSIMP.",
		ANY)$

LCLINEARP(LIST,OPDUM):=BLOCK(
  [YESOPSDUM:LAST(PARTITION(LIST,OPDUM))],
  IS(NULLLISTP(YESOPSDUM) OR LCLINEARP1(APPLY("+",YESOPSDUM),OPDUM)))$

LCLINEARP1(EXP,OPDUM):=
  LCPRED(LAMBDA([DUM],LCLINEARP1(DUM,OPDUM)),
	 LAMBDA([DUM],IS(INPART(DUM,0)=OPDUM)),EXP)$

LINSIMP(EXP,OPDUM1,[OPDUMLIST]):=
  IF OPDUMLIST=[]
  THEN LINOPSUM0(EXP,OPDUM1)
  ELSE APPLY('LINSIMP,CONS(LINOPSUM0(EXP,OPDUM1),OPDUMLIST))$

LINOPSUM0(EXP,OPDUM):=BLOCK(
  [LINPOSNS,GETDUM,LINPREDDUM,LVARSDUM:LISTOFVARS(EXP),SUBSTFLAG:FALSE,NEWDUM,
   ANSDUM,PIECE,INFLAG:TRUE,PARTSWITCH:TRUE],
  DECLARE(ANSDUM,SPECIAL),
  MODEDECLARE(SUBSTFLAG,BOOLEAN),
  IF (GETDUM:GETSYMBOL(OPDUM,'LINEAR_OPERATOR))=FALSE
  THEN ERROR(OPDUM,MESSDECLIN1),
  IF MEMBER(OPDUM,LVARSDUM)
  THEN (SUBSTFLAG:TRUE,
	EXP:NOOPSUBST(NEWDUM:FINDASYMBOL(LVARSDUM),OPDUM,EXP)),
  SETLIST(GETDUM,'LINPOSNS,'LINPREDDUM),
  ANSDUM:LINOPPROD1(SUBST(LAMBDA([[SULIST]],
			      IF FREEOF(OPDUM,SULIST)
			      THEN APPLY("+",SULIST)
			      ELSE LINOPSUM1(SULIST,OPDUM)),"+",EXP),
		    OPDUM,LINPOSNS,LINPREDDUM),
  IF NOT SUBSTFLAG
  THEN ANSDUM
  ELSE SUBST(OPDUM,NEWDUM,ANSDUM))$

LINOPSUM1(LIST,OPDUM):=BLOCK(
  [ANSDUM,LINOPANSDUM],
  DECLARE([ANSDUM,LINOPANSDUM],SPECIAL),
  IF NOT LCLINEARP(LIST,OPDUM) THEN RETURN(APPLY("+",LIST)),
  SETLIST(PARTITION(LIST,OPDUM),'ANSDUM,'LINOPANSDUM),
  APPLY("+",ANSDUM)
  +IF LENGTH(LINOPANSDUM)<2
   THEN FIRST(LINOPANSDUM)
   ELSE LINOPSUM2([FIRST(LINOPANSDUM)],REST(LINOPANSDUM),OPDUM))$

LINOPSUM2(EXAMINEDDUM,UNEXAMINEDYETDUM,OPDUM):=BLOCK(
  [COFEXDUM,COFUNEXDUM,EXDUM,UNEXDUM,LEXDUM:1,EXFOUNDFLAG:FALSE,ARGSUNDUM,
   ARGSEXADUM,LUNEXDUM,ARGSUNDUM456,UNDUM,EXADUM,NEWARGSDUM,FNEWARGSDUM],
  MODEDECLARE([LUNEXDUM,LEXDUM],FIXNUM,EXFOUNDFLAG,BOOLEAN),
  DECLARE([COFEXDUM,EXDUM,COFUNEXDUM,UNEXDUM],SPECIAL),
  SETLIST(ORPARTITIONLIST(EXAMINEDDUM,"*",OPDUM),'COFEXDUM,'EXDUM),
  SETLIST(ORPARTITIONLIST(UNEXAMINEDYETDUM,"*",OPDUM),
	  'COFUNEXDUM,'UNEXDUM),
  LUNEXDUM:LENGTH(UNEXDUM),
  FOR IDUM THRU LUNEXDUM DO
     (ARGSUNDUM456:INPART(ARGSUNDUM:
			  ARGS(UNDUM:INPART(UNEXDUM,IDUM)),
			  APPLY('ALLBUT,LINPOSNS)),
      FOR JDUM THRU LEXDUM DO
	 (EXADUM:INPART(EXDUM,JDUM),
	  IF ARGSUNDUM456=INPART(ARGSEXADUM:ARGS(EXADUM),
				 APPLY('ALLBUT,LINPOSNS))
	  THEN (NEWARGSDUM:
		EXPLICITFACTOR(INPART(ARGSUNDUM,LINPOSNS)
				*INPART(COFUNEXDUM,IDUM)
				+INPART(ARGSEXADUM,LINPOSNS)
				*INPART(COFEXDUM,JDUM)),
		IF ZEROLISTP(LAST(NEWARGSDUM))
		THEN (EXDUM:INPART(EXDUM,ALLBUT(JDUM)),
		      COFEXDUM:INPART(COFEXDUM,ALLBUT(JDUM)),
		      LEXDUM:LEXDUM-1,
		      RETURN(EXFOUNDFLAG:TRUE)),
		FNEWARGSDUM:
		MAPLIST(LAMBDA([DUM],APPLY("*",DUM)),
			PREDPARTITION(RLOIEWL("*",FIRST(NEWARGSDUM)),
				      LINPREDDUM)),
		COFEXDUM:SUBSTINPART(FIRST(FNEWARGSDUM),COFEXDUM,JDUM),
		EXDUM:SUBSTINPART(APPLY(OPDUM,
					APPEND(LAST(NEWARGSDUM)
						*LAST(FNEWARGSDUM),
					       ARGSUNDUM456)),
				  EXDUM,JDUM),
		RETURN(EXFOUNDFLAG:TRUE))),
      IF NOT EXFOUNDFLAG
      THEN (EXDUM:ENDCONS(UNDUM,EXDUM),
	    COFEXDUM:ENDCONS(INPART(COFUNEXDUM,IDUM),COFEXDUM),
	    LEXDUM:LEXDUM+1)
      ELSE EXFOUNDFLAG:FALSE),
  APPLY("+",COFEXDUM*EXDUM))$

LINOPPROD(EXP,OPDUM1,[OPDUMLIST]):=
  IF OPDUMLIST=[]
  THEN LINOPPROD0(EXP,OPDUM1)
  ELSE LINOPPROD(LINOPPROD0(EXP,OPDUM1),FIRST(OPDUMLIST),REST(OPDUMLIST))$

LINOPPROD0(EXP,OPDUM):=BLOCK(
  [LINPOSNS,GETDUM,LINPREDDUM,NEWDUM,LVARSDUM:LISTOFVARS(EXP),
   PIECE,INFLAG:TRUE,PARTSWITCH:TRUE],
  IF (GETDUM:GETSYMBOL(OPDUM,'LINEAR_OPERATOR))=FALSE
  THEN ERROUT(OPDUM,MESSDECLIN1),
  SETLIST(GETDUM,'LINPOSNS,'LINPREDDUM),
  IF MEMBER(OPDUM,LVARSDUM)
  THEN SUBST(OPDUM,NEWDUM:FINDASYMBOL(LVARSDUM),
	     LINOPPROD1(NOOPSUBST(NEWDUM,OPDUM,EXP),OPDUM,LINPOSNS,LINPREDDUM))
  ELSE LINOPPROD1(EXP,OPDUM,LINPOSNS,LINPREDDUM))$

LINOPPROD1(EXP,OPDUM,LINPOSNS,LINPREDDUM):=
  SUBST(LAMBDA([[ARGLIST]],FACTORARGS(ARGLIST,OPDUM,LINPOSNS,LINPREDDUM)),
	       	OPDUM,EXP)$

FINDASYMBOL(LVARSDUM):=BLOCK(
  [NEWDUM:?GENSYM()],
  DECLARE(NEWDUM,SPECIAL),
  IF NOT MEMBER(NEWDUM,LVARSDUM)
  THEN NEWDUM
  ELSE FINDASYMBOL(LVARSDUM))$

NOOPSUBST(EXPDUM1,EXPDUM2,EXPDUM3):=BLOCK(
  [OPSUBST:FALSE],
  SUBST(EXPDUM1,EXPDUM2,EXPDUM3))$

FACTORARGS(ARGSDUM,OPDUM,LINPOSNS,LINPREDDUM):=BLOCK(
  [NEWARGSDUM:EXPLICITFACTOR(INPART(ARGSDUM,LINPOSNS)),LASTNEWARGSDUM,
   FNEWARGSDUM],
  IF ZEROLISTP(LASTNEWARGSDUM:LAST(NEWARGSDUM)) THEN RETURN(0),
  FNEWARGSDUM:MAPLIST('LISTTOPROD,
		      PREDPARTITION(RLOIEWL("*",FIRST(NEWARGSDUM)),
				    LINPREDDUM)),
  IF ORDERLESSP(LAST(FNEWARGSDUM),-LAST(FNEWARGSDUM))
  THEN FNEWARGSDUM:-FNEWARGSDUM,
  APPLY(OPDUM,UNSCRAMBLE(ARGSDUM,LASTNEWARGSDUM*LAST(FNEWARGSDUM),LINPOSNS))
	*FIRST(FNEWARGSDUM))$

UNSCRAMBLE(LIST,NEWLIST,LINPOSNS):=BLOCK(
  [LLIST:LENGTH(NEWLIST)],
  MODEDECLARE(LLIST,FIXNUM),
  FOR IDUM THRU LLIST DO
      LIST:SUBSTINPART(INPART(NEWLIST,IDUM),LIST,INPART(LINPOSNS,IDUM)),
  LIST)$

DECLARE_LINEAR_OPERATOR(OPDUM,LINPOSNS,PREDICATE):=BLOCK(
  [PIECE,INFLAG:TRUE,PARTSWITCH:TRUE],
  PUTSYMBOL(OPDUM,[LINPOSNS,PREDICATE],'LINEAR_OPERATOR))$

Sym&&

/* Symmetry Declarations */

DECLARE_SYMMETRY(OPDUM,SYMFCN,SYMSORTFCN,SYMTYPE):=BLOCK(
  [PIECE,INFLAG:TRUE,PARTSWITCH:TRUE],
  PUTSYMBOL(OPDUM,[SYMFCN,SYMSORTFCN],SYMTYPE))$

APPLYSYMMETRY(EXP,OPDUM,SYMTYPE):=BLOCK(
  [GETDUM:GETSYMBOL(OPDUM,SYMTYPE),PIECE,INFLAG:TRUE,PARTSWITCH:TRUE],
  IF GETDUM=FALSE THEN RETURN(EXP),
  SUBST(LAMBDA([[ARGLIST]],
	       APPLY('APLSYM1,APPEND(GETDUM,[ARGLIST,OPDUM]))),
	OPDUM,EXP))$

APLSYM1(SYMFCN,SYMSORTFCN,LIST,OPDUM):=BLOCK(
  [ALLSYMS:APPLY(SYMFCN,[APPLY(OPDUM,LIST)]),ALLSYMSDUM,EXITBLOCK:FALSE],
  MODEDECLARE(EXITBLOCK,BOOLEAN),
  ALLSYMSDUM:ALLSYMS,
  FOR IDUM IN ALLSYMS DO
      IF MEMBER(-IDUM,ALLSYMSDUM:REST(ALLSYMSDUM))
      THEN RETURN(EXITBLOCK:TRUE),
  IF EXITBLOCK
  THEN 0
  ELSE FIRST(SORT(ALLSYMS,SYMSORTFCN)))$

DECLARE_ZERO(OPDUM,PREDDUM,ZEROTYPE):=BLOCK(
  [PIECE,INFLAG:TRUE,PARTSWITCH:TRUE],
  PUTSYMBOL(OPDUM,PREDDUM,ZEROTYPE))$

APPLYZERO(EXP,OPDUM,ZEROTYPE):=BLOCK(
  [GETDUM:GETSYMBOL(OPDUM,ZEROTYPE),PIECE,INFLAG:TRUE,PARTSWITCH:TRUE],
  IF GETDUM=FALSE THEN RETURN(EXP),
  SUBST(LAMBDA([[ARGLIST]],IF MODE_IDENTITY(BOOLEAN,APPLY(GETDUM,[ARGLIST]))
			   THEN 0
			   ELSE APPLY(OPDUM,ARGLIST)),
	OPDUM,EXP))$

Dev&&
EVAL_WHEN(BATCH,
	  IF DEVELOPMENT=TRUE
	  THEN (DECLARE_LINEAR_OPERATOR(F,[1,2,3],KPRED),
	  	DECLARE_SYMMETRY(F,FSYM,SORT,ALL),
	  	FSYM(FESP):=[INPART(FESP,[2,3,1,5,6,4]),
		       	     INPART(FESP,[3,1,2,6,4,5]),
		       	     INPART(FESP,[1,2,3,4,5,6]),
		       	     -INPART(FESP,[3,2,1,6,5,4]),
		       	     -INPART(FESP,[2,1,3,5,4,6]),
		       	     -INPART(FESP,[1,3,2,4,6,5])],
	  	T1():=LINSIMP(F(A,B,C,D,E,H)-F(A,B,C,D,H,E),F),
	  	KPRED(EXP):=FREEOFL([K1,K2,K3,K4],EXP)))$

EVAL_WHEN(BATCH,TTYOFF:FALSE)$