;-*- Mode:LISP; Package:INTERLISPUSERS; 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.      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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.      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;

(SPECIAL IndexPosition IndexReadTable READTABLE BASE *NOPOINT
	 File-System:*DEFAULT-PATHNAME-DEFAULTS*)

(DEFCONST CharactersToTranslate '((#/ . " #\LEFT-ARROW ")
				  (#/ . " #\RIGHT-ARROW ")
                                  (#/ . " #\NOT-EQUAL ")
				  (#/ . " #\AND-SIGN ")	       		  
				  (#/
 . " #\DOWN-ARROW ")
				  (#/ . " #\BETA ")
				  (#/ . " #\LAMBDA ")
				  (#/ . " #\PARTIAL-DELTA ")
				  (#/ . " #\RIGHT-HORSESHOE ")
				  (#/ . " #\UP-HORSESHOE ")
				  (#/ . " #\DOWN-HORSESHOE ")
				  (#/ . " #\EXISTENTIAL-QUANTIFIER ")
				  (#/ . " #\CIRCLE-X ")
				  (#/ . " #\DOUBLE-ARROW ")
				  (#/ . " #\LESS-OR-EQUAL ")))

(DEFCONST CharactersPerLine 130)
(DEFCONST LinesPerPage 56)
(DEFCONST LinesPerIndexPage (- LinesPerPage 3))

(DEFCONST MinimumLinesForNewCategory 15)
(DEFCONST NumberColumn 105)
(DEFCONST NumberColumnString (MAKE-ARRAY NumberColumn ':TYPE 'ART-STRING))
(DEFCONST IndexNumberMargin 5)
(DEFCONST IndexNumberStart 10)

(for i from 1 to (- NumberColumn 1) do (ASET #/. NumberColumnString i)
     finally (ASET #/; NumberColumnString 0))

(DEFCONST EnoughSpaces (MAKE-ARRAY 200 ':TYPE 'ART-STRING ':LEADER-LENGTH 1))
(DEFCONST EnoughPeriods (MAKE-ARRAY 200 ':TYPE 'ART-STRING ':LEADER-LENGTH 1))

(for i from 0 to 199 do (ASET #/  EnoughSpaces i))
(for i from 0 to 199 do (ASET #/. EnoughPeriods i))

(DEFCONST UninterestingExpressionTypes '(|bind| |for| PROGN))
(DEFCONST SpecialExpressionTypes '((LOCAL-DECLARE . IndexDeclaredForm)
				   (|DeclareTypes| . IndexDeclaredForm)
				   (SPECIAL . IndexSpecial)))
(DEFCONST ExpressionSynonyms '((DEFUNP . DEFUN)
			       (ACCESSFNS . RECORD)
			       (DATATYPE . RECORD)
			       (ATOMRECORD . RECORD)
			       (TYPERECORD . RECORD)
			       (MACRO . DEFMACRO)))

(DEFCONST UninterestingCharacters '(#/  #\CR #\PAGE))

(DEFCONST IndexDefaultFile (File-System:PARSE-PATHNAME "fs:jcw;foo.lisp#>"))

(DEFCONST ModifierSeparator " {")

(DEFCONST ModifierTerminator "}")

(DEFCONST UnknownEntityName '|**Unintelligible**|)

(SPECIAL Printer)
(DEFUN Index (FileName &OPTIONAL (Printer 'Tiger))
  (bind (File _ (LET ((File-System:*DEFAULT-PATHNAME-DEFAULTS* IndexDefaultFile))
		  (OPEN FileName ':IN)))
	(EndOfFile _ (CONSTANT (NCONS NIL))) FilePointer
	Expression FileEntities ExpressionStarts CategoryNames EntityNames
	OutputFile OutputFileName (READTABLE _ IndexReadTable) (IndexPosition _ 0)
	Category (BASE _ 10) (*NOPOINT _ T)
	
	for i from 1
	while
	(AND (NEQ EndOfFile (SkipCharacters UninterestingCharacters File EndOfFile))
	     (SETQ FilePointer (FUNCALL File ':READ-POINTER))
	     (NEQ EndOfFile (SETQ Expression (READ File EndOfFile))))
	when (AND (LISTP Expression) (NOT (MEMQ (TranslateCategoryName (CAR Expression))
						UninterestingExpressionTypes)))
	
	collect
	(MULTIPLE-VALUE (CategoryNames EntityNames) (CategorizeExpression Expression))
	(for catname in CategoryNames
	     as entityname in EntityNames
	     do
	     (SETQ entityname
		   (COND ((SYMBOLP EntityName) EntityName)
			 ((AND (LISTP EntityName)
			       (LISTP (CDR EntityName))
			       (NULL (CDDR EntityName))
			       (SYMBOLP (CAR EntityName))
			       (SYMBOLP (CADR EntityName)))
			  (PACK* (CAR EntityName)
				 ModifierSeparator (CADR EntityName) ModifierTerminator))
			 (T UnknownEntityName)))
	     (COND ((SETQ Category (ASSQ catname FileEntities))
		    (push (CONS entityname i) (CDR Category)))
		   (T (push (CONS catname (NCONS (CONS entityname i)))
			    FileEntities))))
	FilePointer
	
	finally
	(SETQ ExpressionStarts $$VAL)
	(FUNCALL File ':SET-POINTER 0)
	(SETQ FileEntities (SORTCAR FileEntities #'STRING-LESSP))
	(for category in FileEntities do (RPLACD category
						 (SORTCAR (CDR category) #'STRING-LESSP)))
	(SETQ OutputFile
	      (OPEN (SETQ OutputFileName
			  (ModifyFileName '(:TYPE "INDEX")
					  (SETQ IndexDefaultFile (FUNCALL File ':TRUENAME))))
		    ':OUT))
	(WriteIndex FileEntities OutputFile)
	(CopyAndNumberExpressions File OutputFile ExpressionStarts)
	(CLOSE File) (CLOSE OutputFile)
	(RETURN OutputFileName
		(SELECTQ Printer
		  (Tiger (tiger:TIGER-FILE OutputFileName)
			 "Sent to Tiger")
		  (OTHERWISE "Index built, but NOT printed.")))))

(DEFUN CategorizeExpression (Expression &AUX Category CategoryProcessor SubEntityNames)
  Category(TranslateCategoryName Expression
0)
  (COND (CategoryProcessor(ASSQ Category SpecialExpressionTypes)

1
	  (for subexpr in (FUNCALL CategoryProcessor Expression)
	    into CategoryNames join (MULTIPLE-VALUE (NIL SubEntityNames)
				      (CategorizeExpression subexpr))
	    into EntityNames join SubEntityNames))
    (T (VALUES (LIST Category) (LIST Expression
1)))))

(DEFUN CopyAndNumberExpressions (Input Output Points)
  (for number from 1 as point in points do
       (until ( (FUNCALL Input ':READ-POINTER) point) do
	      (FUNCALL Output ':LINE-OUT
		       (TranslateLine (FUNCALL Input ':LINE-IN))))
       (TERPRI Output)
       (PRINC NumberColumnString Output)
       (IndexBigPrint number Output)
       (TERPRI Output)
    finally
       (bind EndOfFile? until EndOfFile? do
	     (FUNCALL Output ':LINE-OUT
		      (TranslateLine (MULTIPLE-VALUE (NIL EndOfFile?)
				       (FUNCALL Input ':LINE-IN)))))))

(DEFUN TranslateLine (Line &AUX Copy? NewLine Translation)
  (for i from 0 to (1- (STRING-LENGTH Line))
    when Translation(ASSQ (AREF Line i) CharactersToTranslate)

1
    sum Copy?T
        (1- (STRING-LENGTH Translation))
    finally (RETURN (COND
		      (Copy?
		       NewLine(MAKE-ARRAY (+ (STRING-LENGTH Line) $$VAL) ':TYPE ':ART-STRING)
		       (bind j-1 for i from 0 to (1- (STRING-LENGTH Line)) do
			     (COND (Translation(ASSQ (AREF Line i) CharactersToTranslate)

1
				    (for k from 0 to (1- (STRING-LENGTH Translation)) do
					 (ASET (AREF Translation k) NewLine (add 1 j))))
				   (T (ASET (AREF Line i) NewLine (add 1 j)))))
		       NewLine)
		      (T Line)))))

(DEFUN WriteIndex (Categories File)
  (LET (Columns ColumnsPerPage ColumnWidth LastPosition)
    (MULTIPLE-VALUE (Columns ColumnsPerPage ColumnWidth)
      (Columnate Categories))
    (SETQ LastPosition (* ColumnWidth ColumnsPerPage))
    (for (PageColumns _ Columns) by (NTHCDR ColumnsPerPage PageColumns)
	 while PageColumns
	 do
	 (bind (ElementsRemaining? _ T)
	       for i from 1 while ElementsRemaining? do
	       (SETQ ElementsRemaining? NIL)
	       (bind col
		     for NextPosition from ColumnWidth by ColumnWidth to LastPosition
		     as tail on PageColumns
		     do
		     (COND
		       ((SETQ col (CAR tail))
			(COND
			  ((NLISTP (CAR col)) (IndexPRINC (pop (CAR tail)) File))
			  (T (IndexPRINC (CAAR col) File)
			     (COND ((> (\ (- i 1) 6) 2)
				    (IndexTab (- NextPosition IndexNumberStart) File T))
				   (T (IndexTab (- NextPosition IndexNumberStart) File)))
			     (IndexPRINC (CDR (pop (CAR tail))) File)))
			(OR ElementsRemaining? (SETQ ElementsRemaining? (CAR tail)))))
		     (OR (EQ NextPosition LastPosition) (IndexTab NextPosition File))
		     finally (IndexTERPRI File)))
	 (AND (NTHCDR ColumnsPerPage PageColumns) (FORMAT File "~%**MORE**~%"))
	 (TYO #\PAGE File))))

(DEFUN Columnate (Categories)
  (LET ((ColumnWidth 0) (MaximumNumberLength 0) LastCategoryName PrintString)
    (VALUES
      (bind Lines while Categories collect
	    (SETQ Lines 0)
	    (while Categories join
		   (COND
		     ((NOT (FIXP (CDAR Categories)))
		      (COND (( (- LinesPerIndexPage Lines) MinimumLinesForNewCategory)
			     (SETQ ColumnWidth
				   (MAX ColumnWidth (STRING-LENGTH (CAAR Categories))))
			     (SETQ LastCategoryName (CAAR Categories))
			     (SETQ PrintString
				   (COND ((EQ 'Continued (CDAR Categories))
					  (STRING-APPEND (CAR (pop Categories)) " Continued"))
					 (T (PROG1
					      (CAAR Categories)
					      (RPLACA Categories
						      (PROG1 (CADAR Categories)
							     (RPLACD (LAST (CAR Categories))
								     (CDR Categories))
							     (RPLACD Categories
								     (CDDAR Categories))))))))
			     (COND ((EQ Lines 0)
				    (add 2 Lines)
				    (LIST* PrintString (NCONS "")))
				   (T (add 3 Lines)
				      (LIST* "" PrintString (NCONS "")))))
			    (T (GO $$OUT))))
		     ((< Lines LinesPerIndexPage)
		      (add 1 Lines)
		      (SETQ ColumnWidth (MAX ColumnWidth (STRING-LENGTH (CAAR Categories))))
		      (SETQ MaximumNumberLength
			    (MAX MaximumNumberLength (IndexStringLength (CDAR Categories))))
		      (RPLACD Categories
			      (PROG1 NIL
				     (SETQ Categories (CDR Categories)))))
		     (T (push (CONS LastCategoryName 'Continued) Categories)
			(GO $$OUT))))
	    finally (SETQ ColumnWidth (+ IndexNumberMargin IndexNumberStart ColumnWidth)))
      (// (+ CharactersPerLine (- IndexNumberStart MaximumNumberLength))
	  ColumnWidth)
      ColumnWidth)))

(DEFUN ModifyFileName (Modifications FileName)
  (LEXPR-FUNCALL (fs:PARSE-PATHNAME FileName) ':NEW-PATHNAME Modifications))

(DEFUN IndexTERPRI (File)
  (SETQ IndexPosition 0)
  (TERPRI File))

(DEFUN IndexPRINC (String File)
  (SETQ IndexPosition (+ IndexPosition (IndexStringLength String)))
  (PRINC String File))

(SPECIAL Printer)
(DEFUN IndexBigPrint (String File)
  (SELECTQ Printer
    (Tiger (FUNCALL File ':TYO 0)
	   (FUNCALL File ':TYO 29)			;10 CPI
	   (FUNCALL File ':TYO 1)))			;Enhanced
  (PRINC String File)
  (SELECTQ Printer
    (Tiger (FUNCALL File ':TYO 30)			;12 CPI
	   (FUNCALL File ':TYO 2)			;Normal
	   (FUNCALL File ':TYO 0))))

(DEFUN IndexTab (GoalColumn File &OPTIONAL Periods?)
  (LET ((String (COND (Periods? EnoughPeriods)
		      (T EnoughSpaces))))
    (STORE-ARRAY-LEADER (- GoalColumn IndexPosition) String 0)
    (PRINC String File)
    (SETQ IndexPosition GoalColumn)))

(DEFUN CopyArray (Array)
  (LET (Result)
    (SETQ Result (MAKE-ARRAY (ARRAY-DIMENSIONS Array)
			     ':TYPE (ARRAY-TYPE Array)
			     ':LEADER-LENGTH (ARRAY-LEADER-LENGTH Array)
			     ':NAMED-STRUCTURE-SYMBOL (NAMED-STRUCTURE-P Array)))
    (COPY-ARRAY-CONTENTS-AND-LEADER Array Result)
    Result))

(DEFCONST IndexReadTable (CopyArray READTABLE))

(for i from #/a to #/z do (SETF (si:RDTBL-TRANS IndexReadTable i) i))

(DEFUN IndexDeclaredForm (DeclaredForm)
  DeclaredForm

2)

(DEFUN IndexSpecial (Special)
  (for variable in Special

1 scratchcollect `(|ExternalSpecialVariable| ,variable)))

(DEFUN IndexStringLength (Entity)
  (COND ((FIXP Entity)
	 (for i from 1 as (j _ 10) by (* j 10) thereis (MINUSP (- Entity j))))
	(T (STRING-LENGTH Entity))))

(DEFUN TranslateCategoryName (CategoryName)
  (OR (CDR (ASSQ CategoryName ExpressionSynonyms)) CategoryName))

(DEFUN SkipCharacters (Characters Stream EndOfFile)
  (bind Character
	do (COND ((SETQ Character (FUNCALL Stream ':TYI))
		  (COND ((MEMQ Character Characters))
			(T (FUNCALL Stream ':UNTYI Character)
			   (RETURN Character))))
		 (T (RETURN EndOfFile)))))