Notice

This notebook is from
http://xahlee.org/tree/tree.html
© Copyright 1998-2005 by Xah Lee.
Fair use under academic settings is permitted.

Version: 1, date 1998.
Version: 1.1, date 2011-02. Updated to Mathematica v7. Incomlete.

Tree Functions

Functions to write, ideas

Off[General::spell1]
Clear[last,dimensions,heads,depth,frest,rest,rational,complex,length,indent,Spaces]
On[General::spell1]

$HistoryLength=10;

write a faster ArrayLeavsIndexSet[...,Heads->False].

Needs to fix StructureForm[1], and write a version for mma v.2x.

TreeUnion
TreeIntersection

IndexSetLevel,Depth

CompleteIndexSetQ

RandomIndexSet

Clear[RandomIndexSet];

RandomIndexSet::"usage"="RandomIndexSet[] generates a random list of indexes. e.g. {{3,2,5},{0,3}}. RandomIndexSet[(minMax:{0,4}),(minMaxIndexLength:{1,4}),(minMaxTotalIndexes:{1,10})] generates a list of random indexes based on given parameters. Example: RandomIndexSet[{0,4},{1,5},{5,5}]";

RandomIndexSet[minMax_List:{0,4},minMaxIndexLength_List:{1,4},minMaxTotalIndexes_List:{1,10}]:=RandomInteger[minMax,{RandomInteger[minMaxTotalIndexes],RandomInteger[minMaxIndexLength]}];

LeavesIndexSet

Clear[LeavesIndexSet,LeavesIndexSet2,LeavesIndexSet3];
LeavesIndexSet::"usage"="LeavesIndexSet[{index1,index2,...}] returns a modified version of argument in which non-leaf indexes are deleted. Related: NonleavesIndexSet. Example: LeavesIndexSet[{{2},{4},{4,2},{4,3},{4,3,5}}]";

LeavesIndexSet[indexes_List]:=Cases[indexes,PatternTest[_,(FreeQ[indexes,Append[#,__],{1}]&)],{1}];

LeavesIndexSet2[indexes_List]:=DeleteCases[indexes,PatternTest[_,(MemberQ[indexes,Append[#,__],{1}]&)],{1}];

LeavesIndexSet3[indexes_List]:=DeleteCases[indexes,Alternatives@@Union@(Flatten[#,1]&)@((Table[Take[#,i],{i,0,Length@#-1}]&)/@indexes),{1}];

testing

Clear[li];
Do[li=RandomIndexSet[{0,4},{0,5},{0,20}];
	If[SameQ@@((#@li&)/@{LeavesIndexSet,LeavesIndexSet2,LeavesIndexSet3})//Not,Print["bad: ",li]],{100}];

Testing special cases. The index {} is the index for an expression consisting a single atom, such as 1. Special cases include arguments that is {}, contains {}, contains repeatitions, and single index.

Clear[li];
li={{},{{}},{{2},{4},{4,2},{4,3},{4,3,5},{}},{{2},{4},{4,2},{4,3},{4,3,5},{4,3,5},{}},{{4,3}}};

(SameQ@@#&)/@Transpose@Outer[Apply,{LeavesIndexSet,LeavesIndexSet2,LeavesIndexSet3},f/@li]

LeavesIndexSet/@li

NonleavesIndexSet

Clear[NonleavesIndexSet,NonleavesIndexSet2];
NonleavesIndexSet::"usage"="NonleavesIndexSet[{index1,index2,...}] returns a list by deleting indexes in the argument that are leaves. Related: LeavesIndexSet. Example: NonleavesIndexSet[{{2},{4},{4,2},{4,3},{4,3,5}}]";

NonleavesIndexSet[indexes_List]:=Cases[indexes,PatternTest[_,(MemberQ[indexes,Append[#,__],{1},Heads->False]&)],{1}];

NonleavesIndexSet2[indexes_List]:=DeleteCases[indexes,PatternTest[_,(FreeQ[indexes,Append[#,__],{1},Heads->False]&)],{1}];

testing

This test tests NonleavesIndexSet and NonleavesIndexSet2.

Clear[li];
Do[li=RandomIndexSet[{0,4},{0,4},{0,10}];
	If[SameQ@@((#@li&)/@{NonleavesIndexSet,NonleavesIndexSet2})//Not,Print["bad: ",li]],{100}];

Test using CompleteIndexSet.

Clear[li];
Do[li=CompleteIndexSet@RandomIndexSet[{0,4},{0,4},{0,10}];
	If[SameQ@@((#@li&)/@{NonleavesIndexSet,NonleavesIndexSet2})//Not,Print["bad: ",li]],{100}];

This test tests both NonleavesIndexSet and LeavesIndexSet together. The test include possible special cases where the index may contain {}, or duplicates.

Clear[li];
Do[li=If[RandomReal[]>0.7`,CompleteIndexSet,Identity][RandomIndexSet[{0,4},{0,4},{0,10}]];If[!Sort[Join[NonleavesIndexSet[li],LeavesIndexSet[li]]]===Sort[li],Print["bad: ",li]],{100}];

MinimumIndexSet

First approach: delete itself

MinimumIndexSet specification:

We are given a list of indexes. We go through each index and determine if it is redundant. If it is, then delete it. Suppose {a,b,c,d} is one index. It is redundant if MemberQ[givenIndexes,{a,b,c,x$_/;x$ > d}|{a,b,c,x$_/;x$ >= d,__}], and if the index is {}, then it is redundant if MemberQ[givenIndexes,{__}].

Clear[MinimumIndexSet];

MinimumIndexSet::"usage"="MinimumIndexSet[{index1,index2,...}] returns a modified version of argument in which indexes that can be inferred from other indexes are deleted. Related: CompleteIndexSet, ArrayIndexSet. Example: MinimumIndexSet[{{1},{2},{3},{2,3},{2,2},{2,3,7},{3,1}}]";

MinimumIndexSet[indexes_List]:=DeleteCases[indexes,PatternTest[_,(MemberQ[indexes,Replace[#,{{}->{__},{frest___,last_}->({frest,x_/;(x>last)}|{frest,x_/;(x>=last),__})}],{1}]&)],{1}];

alternative approach: delete others

Another approach is to delete other indexes that is implied by a current index. Suppose {a,b,c,d} is an index, then it implies any indexes that matches one of {{},{x$_/;x$≤a},{a,x$_/;x$≤b},{a,b,x$_/;x$≤c},{a,b,c,x$_/;x$<d}}.

Clear[MinimumIndexSet2];
MinimumIndexSet2[{{}}]:={{}};

MinimumIndexSet2[indexes_List]:=(DeleteCases[#,Alternatives@@Union@(Flatten[#,1]&)@Map[Function[(ReplacePart[#,Last@#/.LessEqual->Less,-1]&)@(Table[Replace[Take[#,i],{frest___,last_}->{frest,x_/;(x<=last)}],{i,Length@#}]&)@#],#],{1}]&)@DeleteCases[indexes,{}];

Clear[MinimumIndexSet3];
MinimumIndexSet3[{{}}]:={{}};

MinimumIndexSet3[indexes_List]:=(Fold[Function[{expr,index},(DeleteCases[expr,#,{1}]&)@(Alternatives@@(ReplacePart[#,Last@#/.LessEqual->Less,-1]&)@(Table[Replace[Take[#,i],{frest___,last_}->{frest,x_/;(x<=last)}],{i,Length@#}]&)@index)],#,Reverse@Sort@#]&)@DeleteCases[indexes,{}];

testing

Clear[li];
Do[li=RandomIndexSet[{0,4},{1,4},{1,20}];
	If[SameQ@@((#@li&)/@{MinimumIndexSet,MinimumIndexSet2,MinimumIndexSet3})//Not,Print["bad: ",li]],{100}]

Tesing with CompleteIndexSet, where argument contains {}.

Clear[li];
Do[li=CompleteIndexSet@RandomIndexSet[{0,3},{1,3},{1,10}];
	If[SameQ@@((#@li&)/@{MinimumIndexSet,MinimumIndexSet2,MinimumIndexSet3})//Not,Print["bad: ",li]],{100}]

Special case. MinimumIndexSet[{{}}]

((#[{{}}]&)/@{MinimumIndexSet,MinimumIndexSet2,MinimumIndexSet3})

Special case: dulpcates.
Question: Why duplicated are not deleted? Answer: may be a bug. Need to figure out what is the right thing.

((#[{{1,3},{1,3}}]&)/@{MinimumIndexSet,MinimumIndexSet2,MinimumIndexSet3})

CompleteIndexSet

Algorithm description:
Suppose one of the given index is {a,b,c,d}. If the last digit is not 0, then generate {a,b,c,d-1}. If the last digit is 0, then generate {a,b,c}. Add the new element into a result list. Now take new element as input and repeat the process until it becomes {}. Now do the above with every given index. Now eliminate duplicates and {} in the result list. The result is as desired.

Clear[CompleteIndexSet];
CompleteIndexSet::"usage"="CompleteIndexSet[{index1,index2,...}] returns a modified version of the argument in which indexes that are implied are inserted. The result is sorted by standard Sort and duplicates deleted. Related: MinimumIndexSet, ArrayIndexSet. Example: CompleteIndexSet[{{3,3},{1,1},{7}}]";

CompleteIndexSet[indexes_List]:=Union@(Flatten[#,1]&)@Map[(FixedPointList[Replace[#,{frest___,x_}:>If[x=!=0,{frest,x-1},{frest}]]&,#]&),indexes];

testing

To do: needs to find a test for CompleteIndexSet.

CompleteIndexSet[{{}}]
CompleteIndexSet[{{3,2,0}}]

ArrayLeavesIndexSet

ArrayLeavesIndexSet specification:

ArrayLeavesIndexSet[dimensions] is supposed to return the leaves of indexes in ArrayIndexSet[dimensions]. Specifically,

ArrayLeavesIndexSet[dimensions,Heads->True]==LeavesIndexSet@ArrayIndexSet[dimensions,Heads->True] && ArrayLeavesIndexSet[dimensions,Heads->False]==LeavesIndexSet@ArrayIndexSet[dimensions,Heads->False].

choosen implementation

Clear[ArrayLeavesIndexSet];
ArrayLeavesIndexSet::"usage"="ArrayLeavesIndexSet[{i1,i2,...},(Heads->True)] returns a complete leaves index set for an array of given dimensions {i1,i2,...}. The option Heads->True will consider Heads as parts of the array (and includes their indexes). Related: ArrayIndexSet, CompleteIndexSet. Example: ArrayLeavesIndexSet[{2,3}]";

Options[ArrayLeavesIndexSet]={Heads->True};

ArrayLeavesIndexSet[dimensions_List]:=ArrayLeavesIndexSet[dimensions,Heads->(Heads/.Options[ArrayLeavesIndexSet])];

ArrayLeavesIndexSet[dimensions_List,Heads->True]:=(Flatten[#,Length@dimensions-1]&)@Array[List,dimensions+1,0];

ArrayLeavesIndexSet[dimensions_List,Heads->False]/;(If[MemberQ[dimensions,0,{1,Infinity},Heads->False],Message[IndexSet::"0index",dimensions];False,True]):=LeavesIndexSet@ArrayIndexSet[dimensions,Heads->False];

primitive, recursive approach

Clear[ArrayLeavesIndexSet2];

Options[ArrayLeavesIndexSet2]={Heads->True};

ArrayLeavesIndexSet2[dimensions_List]:=ArrayLeavesIndexSet2[dimensions,Heads->(Heads/.Options[ArrayLeavesIndexSet2])];

ArrayLeavesIndexSet2[{},Heads->True]={};
ArrayLeavesIndexSet2[{0},Heads->True]={{0}};
ArrayLeavesIndexSet2[{i_Integer},Heads->True]:=Append[ArrayLeavesIndexSet2[{i-1},Heads->True],{i}];
ArrayLeavesIndexSet2[{frest__Integer,last_Integer},Heads->True]:=(Flatten[#,1]&)@Outer[Join,ArrayLeavesIndexSet2[{frest},Heads->True],ArrayLeavesIndexSet2[{last},Heads->True],1,1];

ArrayLeavesIndexSet2[dimensions_List,Heads->False]/;(If[MemberQ[dimensions,0,{1,Infinity},Heads->False],Message[IndexSet::"0index",dimensions];False,True]):=LeavesIndexSet@ArrayIndexSet[dimensions,Heads->False];

using ArrayExpressionGenerator

Clear[ArrayLeavesIndexSet3];

Options[ArrayLeavesIndexSet3]={Heads->True};

ArrayLeavesIndexSet3[dimensions_List]:=ArrayLeavesIndexSet3[dimensions,Heads->(Heads/.Options[ArrayLeavesIndexSet3])];

ArrayLeavesIndexSet3[dimensions_List,Heads->True]:=Sort@Position[ArrayExpressionGenerator[dimensions,Heads->True],_,{-1}];

ArrayLeavesIndexSet3[dimensions_List,Heads->False]/;(If[MemberQ[dimensions,0,{1,Infinity},Heads->False],Message[IndexSet::"0index",dimensions];False,True]):=Sort@Position[ArrayExpressionGenerator[dimensions,Heads->False],_,{-1}];

testing

testing for Heads->True cases.

Clear[li];
Do[li=RandomInteger[{0,5},RandomInteger[{1,5}]];If[!SameQ@@(#1[li,Heads->True]&)/@{ArrayLeavesIndexSet,ArrayLeavesIndexSet2,ArrayLeavesIndexSet3},Print["bad: ",li]],{100}];

testing for Heads->False cases. Note: When Heads->False, dimensions cannot have 0.

Clear[li];
Do[li=RandomInteger[{1,3},RandomInteger[{1,3}]];If[!SameQ@@(#1[li,Heads->False]&)/@{ArrayLeavesIndexSet,Global`ArrayLeavesIndexSet2,Global`ArrayLeavesIndexSet3},Print["bad: ",Global`li]],{100}];

Special cases: Heads->False and dimensions contains 0.

(#[{1,0},Heads->False]&)/@{ArrayLeavesIndexSet,ArrayLeavesIndexSet2,ArrayLeavesIndexSet3}

ArrayIndexSet

ArrayIndexSet Specification:

ArrayIndexSet[dimensions1,Heads->True] is supposed to return all the indexes of a tree having dimensions1. For example, suppose dimensions1={a,b,c}, then it should generate all the following indexes: {0,0,0}<=({i},{i,j},{i,j,k})<={a,b,c}.

For example, ArrayIndexSet[{2,2,2},Heads->True] should return
{{0},{1},{2},{0,0},{0,1},{0,2},{1,0},{1,1},{1,2},{2,0},{2,1},{2,2},{0,0,0},{0,
    0,1},{0,0,2},{0,1,0},{0,1,1},{0,1,2},{0,2,0},{0,2,1},{0,2,2},{1,0,0},{1,0,
    1},{1,0,2},{1,1,0},{1,1,1},{1,1,2},{1,2,0},{1,2,1},{1,2,2},{2,0,0},{2,0,
    1},{2,0,2},{2,1,0},{2,1,1},{2,1,2},{2,2,0},{2,2,1},{2,2,2}}

The order of the returned indexes is not important, but suppose it returns the same order by Sort.

The result of ArrayIndexSet[dimensions,Heads->False] can be specified in terms of ArrayIndexSet[dimensions,Heads->True] neatly by the definition:
ArrayIndexSet[dimensions_List,
    Heads->False]:=(DeleteCases[#,{___,0,__},{1}]&)@
    ArrayIndexSet[dimensions,Heads->True];

In particular this says that if an index matches {___,0,__}, then it is an index for a head of head.

The implementation is self-explainatory. The implementation for Heads->True cases calls ArrayLeavesIndexSet.

choosen implementation

Clear[ArrayIndexSet];
ArrayIndexSet::"usage"="ArrayIndexSet[{i1,i2,...},(Heads->True)] returns a complete index set for an array of given dimensions {i1,i2,...}. The option Heads->True will consider Heads as parts of the array (and includes their indexes). Related: ArrayLeavesIndexSet, CompleteIndexSet. Example: ArrayIndexSet[{2,3}]";

IndexSet::"0index"="The dimensions argument `` contains 0. This is not compatible with Heads->False. i.e. When Heads->False, dimensions should not contain 0.";

Options[ArrayIndexSet]={Heads->True};

ArrayIndexSet[dimensions_List]:=ArrayIndexSet[dimensions,Heads->(Heads/.Options[ArrayIndexSet])];

ArrayIndexSet[dimensions_List,Heads->True]:=(Flatten[#,1]&)@Table[ArrayLeavesIndexSet[Take[dimensions,i],Heads->True],{i,Length@dimensions}];

ArrayIndexSet[dimensions_List,Heads->False]/;(If[MemberQ[dimensions,0,{1,Infinity},Heads->False],Message[IndexSet::"0index",dimensions];False,True]):=(DeleteCases[#,{___,0,__},{1}]&)@ArrayIndexSet[dimensions,Heads->True];

alternative definition using ArrayExpressionGenerator

Clear[ArrayIndexSet2];

Options[ArrayIndexSet2]={Heads->True};

ArrayIndexSet2[dimensions_List]:=ArrayIndexSet2[dimensions,Heads->(Heads/.Options[ArrayIndexSet2])];

ArrayIndexSet2[dimensions_List,Heads->True]:=Sort@Position[ArrayExpressionGenerator[dimensions,Heads->True],_,{1,Infinity}];

ArrayIndexSet2[dimensions_List,Heads->False]/;(If[MemberQ[dimensions,0,{1,Infinity},Heads->False],Message[IndexSet::"0index",dimensions];False,True]):=Sort@Position[ArrayExpressionGenerator[dimensions,Heads->False],_,{1,Infinity}]

testing

Heads->True case

Do[li=RandomInteger[{0,4},RandomInteger[{1,4}]];If[!SameQ@@(#1[li,Heads->True]&)/@{ArrayIndexSet,ArrayIndexSet2},Print["bad: ",li]],{100}];

Heads->False case. Note: If Heads->False, then the given dimensions should not contain any 0.

Clear[li];
Do[li=RandomInteger[{1,4},RandomInteger[{1,4}]];If[!SameQ@@(#1[li,Heads->False]&)/@{ArrayIndexSet,ArrayIndexSet2},Print["bad: ",li]],{100}];

special cases. Heads->False and dimensions contain 0.

(#[{1,0},Heads->False]&)/@{ArrayIndexSet,ArrayIndexSet2}

ExpressionToIndexSet

Clear[ExpressionToIndexSet,ExpressionToIndexSet2,ExpressionToIndexSetInternal,ExpressionToIndexSet3];
ExpressionToIndexSet::"usage"="ExpressionToIndexSet[expr] returns a list of all atoms and their positions that represents expr completely.  The option NonAtomicComplexAndRational->True can be used so that Complex and Rational objects are not treated as atoms. ExpressionToIndexSet[expr,(levspec:{-1}),(Heads->True)] returns the indexes and corresponding subexpression at levspec. (it is analogous to the Level function on expression.) Related: IndexSetToExpression. Example: ExpressionToIndexSet[Array[f,{2,2}]]";

NonAtomicComplexAndRational::"usage"="NonAtomicComplexAndRational is an option for ExpressionToIndexSet. If set to True, then Complex and Rational objects are not treated as atom. For example, compare ExpressionToIndexSet[1/2] vs ExpressionToIndexSet[1/2,NonAtomicComplexAndRational->True]";

Off[General::spell1];

Options[ExpressionToIndexSet]={Heads->True,NonAtomicComplexAndRational->False};
ExpressionToIndexSet[expr_,opts___Rule]:=ExpressionToIndexSet[expr,{-1},opts];
ExpressionToIndexSet[expr_,levspec_,opts___Rule]:=Module[{heads,nonAtomicComplexAndRational},
		heads=Heads/.{opts}/.Options@ExpressionToIndexSet;
		nonAtomicComplexAndRational=NonAtomicComplexAndRational/.{opts}/.Options@ExpressionToIndexSet;
		(If[nonAtomicComplexAndRational,NonAtomicComplexAndRationalWrapper[#,expr],#@expr]&)@Function[{x},Cases[MapIndexed[(#2->#1)&,x,levspec,Heads->heads],_Rule,{0,-1},Heads->True]]
	];

On[General::spell1];

ExpressionToIndexSet2[expr_]:=Cases[ExpressionToIndexSetInternal[expr,{}],_Rule,{0,-1},Heads->True];

ExpressionToIndexSetInternal[expr_?AtomQ,index_]:=(index->expr);
ExpressionToIndexSetInternal[expr_,index_]:=MapIndexed[(ExpressionToIndexSetInternal[#1,Append[index,First@#2]]&),expr,{1},Heads->True];

ExpressionToIndexSet3=Function[{x},Map[(#->First@Extract[x,{#}])&,Position[x,_,{-1},Heads->True]]];

test

Only one argument form are tested here. The two or three argument form of ExpressionToIndexSet are reliable because it is defined using build-in function mechanism. ExpressionToIndexSet2 and ExpressionToIndexSet3 only accept one argument. I havn't decided whether ExpressionToIndexSet should have two or three argument form.

Also note, that ExpressionToIndexSet[1] works identically for all versions. They return {{}->1}.

Clear[li];
Do[li=ReplaceAtomWithIndex@RandomExpressionGenerator[Heads->True];If[SameQ@@((#[li]&)/@{ExpressionToIndexSet,ExpressionToIndexSet2,ExpressionToIndexSet3})//Not,Print["bad: ",li]],{100}];

Special case: when expr is an atom. ExpressionToIndexSet[1] should return {{}->atom}.

((#[1]&)/@{ExpressionToIndexSet,ExpressionToIndexSet2,ExpressionToIndexSet3})

OrderedIndexQFunction

Clear[OrderedIndexQFunction,DepthFirst];
OrderedIndexQFunction::"usage"="OrderedIndexQFunction[] returns a predicate function on indexes. Sort[{index1,index2,...},OrderedIndexQFunction[(DepthFirst->True)]] sorts the indexes properly as the indexes of an ordered tree. If DepthFirst->True, then the deeper of two indexes of equal order will be given first. e.g. {1,2} comes before {1}. Example 1: Sort[{{1},{2},{1,2},{2,2},{1,2,3}},OrderedIndexQFunction[DepthFirst->False]] Example 2: OrderedIndexQFunction[DepthFirst->True][{1,3},{1}]";

DepthFirst::"usage"="DepthFirst is an option for OrderedIndexQFunction. If DepthFirst->True, then the deeper of two indexes of equal order will be given first. e.g. {1,2} comes before {1}.";

Options[OrderedIndexQFunction]={DepthFirst->True};

OrderedIndexQFunction[]:=OrderedIndexQFunction[DepthFirst->(DepthFirst/.Options[OrderedIndexQFunction])];
OrderedIndexQFunction[DepthFirst->p_]=Function[{idx1,idx2},(If[UnsameQ@@#,OrderedQ@#,If[p,Length@idx1>Length@idx2,Length@idx1<Length@idx2]]&)@(Take[#,Min[Length@idx1,Length@idx2]]&/@{idx1,idx2})];

IndexSetSort

The code is self-explainatory.

Clear[IndexSetSort,IndexSetSort2,DepthFirst];
IndexSetSort::"usage"="IndexSetSort[{index1,index2,...},(DepthFirst->True)] sorts the indexes properly as the indexes of an ordered tree. If DepthFirst->True, then the deeper of two indexes of equal order will be given first. e.g. {1,2} comes before {1}. Example: IndexSetSort[{{1},{2},{1,2},{2,2},{1,2,3}},DepthFirst->False]";

DepthFirst::"usage"="DepthFirst is an option for IndexSetSort. If DepthFirst->True, then the deeper of two indexes of equal order will be given first. e.g. {1,2} comes before {1}.";

Options[IndexSetSort]={DepthFirst->True};

IndexSetSort[indexes_List]:=IndexSetSort[indexes,DepthFirst->(DepthFirst/.Options[IndexSetSort])];
IndexSetSort[indexes_List,Rule[DepthFirst,p_]]:=Sort[indexes,Function[{x,y},(If[UnsameQ@@#,OrderedQ@#,If[p,Length@x>Length@y,Length@x<Length@y]]&)@(Take[#,Min[Length@x,Length@y]]&/@{x,y})]];

Here's a version that is faster by using different codes for DepthFirst True or False. If DepthFirst->False, it's an order faster.

Clear[IndexSetSort2];
IndexSetSort2[indexes_List,DepthFirst->True]:=Sort[indexes,Function[{x,y},(If[UnsameQ@@#,OrderedQ@#,Length@x>Length@y]&)@(Take[#,Min[Length@x,Length@y]]&/@{x,y})]];

IndexSetSort2[indexes_List,DepthFirst->False]:=Module[{depth},depth=Max@(Length/@indexes);
Last@Transpose@(Sort@Transpose@{(Flatten@{#,Table[0,{depth-Length@#}]}&)/@indexes,indexes})];

test

DepthFirst->False cases.

Clear[li];
Do[li= RandomIndexSet[{0,7},{1,7},{1,50}];
If[Equal@@((#[DepthFirst->False]&)/@{IndexSetSort,IndexSetSort2})//Not,Print["bad: ",li]],{200}];

DepthFirst->True cases.

Clear[li];
Do[li=Position[RandomExpressionGenerator[Heads->True],_,{-1},Heads->True];
If[IndexSetSort[li,DepthFirst->True]===li//Not,Print["bad: ",li]],{10}];

NonAtomicComplexAndRationalWrapper

Clear[NonAtomicComplexAndRationalWrapper];

NonAtomicComplexAndRationalWrapper::"usage"="NonAtomicComplexAndRationalWrapper[f,arg1,arg2,...] will apply f to arguments but first replacing all Complex and Rational head to internal symbols, then replace them back after f is applied. The effect is that Complex and Rational are not treated as atoms in f.";

NonAtomicComplexAndRationalWrapper[f_,rest__]:=Module[{rational,complex},ReplaceAll[f@@({rest}//.{Rational[a_,b_]:>rational[a,b],Complex[a_,b_]:>complex[a,b]}),{rational->Rational,complex->Complex}]]

IndexSetToExpression

Algorithm used:
Use MinimumExpressionGenerator to build a tree specified by the given indexes, then use ReplaceMultiplePart to replace each atom in the tree by the given atom.

The drawback of this algorithm is that it won't work if input argument contain conflicting indexes. For example, IndexSetToExpression[{{1}->x,{1,1}->y}]. Think about it for a moment: it is impossible for an expression to have atom x at {1} and atom y at {1,1}. The existance of index {1,1} would imply that the subexpression at {1} is compound. When the input to IndexSetToExpression contain such conflicting specification such as this example, problems arise when IndexSetToExpression tries to use ReplaceMultiplePart because centain parts will no longer exist. For example, if {1} is replaced by x, then {1,1} no longer exists. One may fix it by using a depth first replacing order, but it would be a hack and the effect isn't very valuable.

The formal spec of bad input is this:
The input indexes must not contain any nonleaf. i.e. If {xSequence} is an index, then there shouldn't be any index of the form {xSequence,n,...}.

Coding explained:
The coding corresponding to its algorithm well.

Clear[IndexSetToExpression];
IndexSetToExpression::"usage"="IndexSetToExpression[indexSetWithAtom] returns an expression that is described by indexSetWithAtom. indexSetWithAtom has the form {index1->atom1,index2->atom2,...} where indexi has the form {i,j,k,...}. If an index is missing in the argument, then 0 is used as its atom. Related: MinimumExpressionGenerator, ExpressionToIndexSet. Example: IndexSetToExpression@ExpressionToIndexSet@Array[f,{2,2}]";

IndexSetToExpression[indexesWithAtom:{__Rule}]:=(ReplaceMultiplePart[MinimumExpressionGenerator@First@#,Last@#,First@#]&)@Transpose@(Sort@indexesWithAtom/.Rule->List);

alternative definition

In this approach, the expression is build gradually by going through each of the index and its atom. 

detail:
Generate a complete index set from the input. Sort them by the order of: length ascending then index numbers. Using this sorted complete index set to build the tree node by node by looping through the set. This approach is siginficantly more difficult.

Algorithm description:
Suppose we are given an index set with atoms {{0}->"0",{1,0}->"1-0",{1,1}->"1-1",{1,2}->"1-2",{2,0,0}->"2-0-0",{2,0,1}->"2-0-1",{2,0,2}->"2-0-2",{3}->"3",{4,0}->"4-0",{4,1}->"4-1",{4,2}->"4-2"}, which corresponds to the expression "0"["1-0"["1-1","1-2"],"2-0-0"["2-0-1","2-0-2"][],"3","4-0"["4-1","4-2"]]. Let's call the given index set indexesWithAtom.

The given index set contains leaves only.
The first thing we want is a complete index set that includes non-leaves. The complete index set is {{0},{1},{2},{3},{4},{1,0},{1,1},{1,2},{2,0},{4,0},{4,1},{4,2},{2,0,0},{2,0,1},{2,0,2}}. The building of a complete index is described in the description of CompleteIndexSet.

Notice now that indexes that represents non-leaf nodes of the tree does not have a corresponding atom. To grow the tree node by node, we'll encounter {1} before {1,0}, and at {1} we will NEED an atom. This means, that if we were to build the expression, then we need to use the atom at index {1,0} while we are building index {1}. Only later-on the atom at {1} will become {1,0}. This is natural because when we encounter an index ending at 0, we don't need an atom, we just need to add an [] to raise a level of previously built subexpression at a particular index. Therefore, for a complete indexes with atom to be useful, we'll need to move index/atom paring like {i,j,k,0,0,0...}->atomX to {i,j,k}->atomX. For those indexes ending with zero, we don't need an atom. The resulting list we want is {{}->"0",{0}->"",{1}->"1-0",{2}->"2-0-0",{3}->"3",{4}->"4-0",{1,0}->"",{1,1}->"1-1",{1,2}->"1-2",{2,0}->"",{4,0}->"",{4,1}->"4-1",{4,2}->"4-2",{2,0,0} ->"",{2,0,1}->"2-0-1",{2,0,2}->"2-0-2"}. The empty string are there to keep a consistant form.

Now we are ready to build the expression from the above list. Starting with the expression "0", then go through the list. Suppose the current index is indexCurrent. For convenience, let's call the index derived from indexCurrent by droping it's last entry is called indexCurrentFront, and the expression at indexCurrentFront is indexCurrentFrontExpr. For example, if indexCurrent is {0}, then indexCurrentFront is {}, and indexCurrentFrontExpr is "0". Now, if the last entry of indexCurrent is 0, then we change indexCurrentFrontExpr to indexCurrentFrontExpr[]. (i.e. apply #[]&) If the last digit of indexCurrent is not 0, then we append the atom associated with indexCurrent to indexCurrentFrontExpr. (i.e., apply Append[#,associatedAtom]&). For example, if indexCurrent is {0}, we will endup with "0"[]. By orderly going through every index in our complete index set with atoms, we'll have built our desired expression.

Code explained:
The code corresponds to its algorithm well. The outline of the definition body has the form of (Fold[]&)@(Fold[]&)@(Union[...]). The (Fold[]&)@(Union[...]) part generate the complete index set with atom, suitable for the building of expression. The first Fold goes through this indexes to build the expression.

More...

This code calls CompleteIndexSet.

Clear[IndexSetToExpression2];

IndexSetToExpression2[indexesWithAtom:{__Rule}]:=IndexSetToExpression2[indexesWithAtom,False];

IndexSetToExpression2[indexesWithAtom:{__Rule},tf_]:=((If[tf,FoldList,Fold])[Function[{expr,indexWithAtom},MapAt[If[indexWithAtom[[1,-1]]===0,(#[]&),(Append[#,Last@indexWithAtom]&)],expr,{Drop[First@indexWithAtom,-1]}]],#[[1,-1]],Rest@#]&)@(Fold[Function[{theSet,anIndexWithAtom},
		With[{anIndex=First@anIndexWithAtom,anAtom=Last@anIndexWithAtom,nonZeroFrontOfAnIndex=Replace[First@anIndexWithAtom,{nonZero___,Repeated[0]}:>{nonZero}]},If[anIndex===nonZeroFrontOfAnIndex,theSet,theSet/.Rule[nonZeroFrontOfAnIndex,_]->Rule[nonZeroFrontOfAnIndex,anAtom]]]],#,#]&)@Union[indexesWithAtom,(Rule[#,0]&)/@(CompleteIndexSet@First@Transpose@(indexesWithAtom/.Rule->List)),SameTest->(SameQ[First@#1,First@#2]&)];

Here's a development version of the code

Here's a development version of the code. Instead of piping functions, each result of a function is assigned to a variable for readibility and ease of debugging.

Clear[indexesWithAtom,completeIndexSetWithAtom1,completeIndexSetWithAtom2,completeIndexSetWithAtom3];

indexesWithAtom=ExpressionToIndexSet@ReplaceAtomWithIndex@MinimumExpressionGenerator@{{0,1}};
completeIndexSetWithAtom1=CompleteIndexSet@First@Transpose@(indexesWithAtom/.Rule->List);
completeIndexSetWithAtom2=Union[indexesWithAtom,(Rule[#,0]&)/@completeIndexSetWithAtom1,SameTest->(SameQ[First@#1,First@#2]&)];
completeIndexSetWithAtom3=Fold[Function[{theSet,anIndexWithAtom},
		With[{anIndex=First@anIndexWithAtom,anAtom=Last@anIndexWithAtom,nonZeroFrontOfAnIndex=Replace[First@anIndexWithAtom,{nonZero___,Repeated[0]}:>{nonZero}]},If[anIndex===nonZeroFrontOfAnIndex,theSet,theSet/.Rule[nonZeroFrontOfAnIndex,_]->Rule[nonZeroFrontOfAnIndex,anAtom]]]],completeIndexSetWithAtom2,completeIndexSetWithAtom2];
(Fold[Function[{expr,indexWithAtom},MapAt[If[indexWithAtom[[1,-1]]===0,(#[]&),(Append[#,Last@indexWithAtom]&)],expr,{Drop[First@indexWithAtom,-1]}]],#[[1,-1]],Rest@#]&)@completeIndexSetWithAtom3

testing

This test tests the correctness of IndexSetToExpression and IndexSetToExpression2 with well-given input. i.e. The input completely specify an expression, with no missing or redundant indexes.

Clear[index,index2,expr];
Do[index=RandomInteger[{0,4},{RandomInteger[{1,5}],RandomInteger[{1,4}]}];expr=ReplaceAtomWithIndex[MinimumExpressionGenerator[index]];index2=ExpressionToIndexSet[expr];If[!expr===IndexSetToExpression[Global`index2]===Global`IndexSetToExpression2[index2],Print[index]],{10}]

This test tests the correctness of IndexSetToExpression and IndexSetToExpression2 with improper inputs. i.e. The input is missing some indexes. For example, IndexSetToExpression[{{3,2}->a}]. In such cases, 0 is used for missing atom's indexes.

Clear[index,index2,expr];
Do[index=RandomInteger[{0,4},{RandomInteger[{1,10}],RandomInteger[{1,4}]}];Global`expr=Global`ReplaceAtomWithIndex[Global`MinimumExpressionGenerator[Global`index]];Global`index2=(DeleteCases[#1,"delete me",{1}]&)[(Table[If[RandomReal[]>0.5`,#1[[i]],"delete me"],{i,1,Length[#1]}]&)[ExpressionToIndexSet[expr]]];If[IndexSetToExpression[index2]=!=IndexSetToExpression2[index2]&&IndexSetToExpression[index2]=!={},Print["bad: ",index2]],{20}]

This test tests bad inputs. e.g. IndexSetToExpression[{{3,2}->a,{3}->b}]
IndexSetToExpression cannot handle most of such cases, and will generate errors ReplacePart::part errors because parts do not exist.

Clear[index,index2,expr];
Do[index=RandomInteger[{0,4},{RandomInteger[{1,20}],RandomInteger[{1,4}]}];index2=(#1->RandomInteger[{1,10000}]&)/@index;If[!IndexSetToExpression[index2]===IndexSetToExpression2[index2],Print["bad: ",index2]],{3}]

ExpressionHistory

Clear[ExpressionHistory];

ExpressionHistory::"usage"="ExpressionHistory[expr] returns a list showing the building history of expr. Example: ExpressionHistory@Array[f,{2,2}]";

ExpressionHistory[expr_]:=IndexSetToExpression2[ExpressionToIndexSet@expr,True];

MinimumExpressionGenerator

Code explained:
Start with a complete index set implied by the given indexes. Sort them in standard way so that shallow parts comes first. These steps are generated by Sort@CompleteIndexSet@indexes. For example, if input is {{2,0,3},{5}}, then the sorted full index set is: {{0},{1},{2},{3},{4},{5},{2,0},{2,0,0},{2,0,1},{2,0,2},{2,0,3}}. We then build a tree with these indexes starting from the first index. This is done by Fold, starting with the expression 0 and with subsequent indexes as 2nd argument. Now, given an index {a,b,c}, if its last digit is 0, then it means adding a new level at {a,b}. If the last digit is not 0, then it means append a new element at {a,b}. These steps are done with MapAt[If[Last@#2===0,(#[])&,Append[#,0]&],#1,{Drop[#2,-1]}]&.

Clear[MinimumExpressionGenerator];
MinimumExpressionGenerator::"usage"="MinimumExpressionGenerator[{index1,index2,...}] generates a minimum expression having given position indexes. 0 is used as the atoms of the expression generated. Related: ArrayExpressionGenerator, ReplaceAtomWithIndex. Example: MinimumExpressionGenerator[{{2,0,3},{5}}]";

MinimumExpressionGenerator[indexes_List]:=Fold[MapAt[If[Last@#2===0,(#[])&,Append[#,0]&],#1,{Drop[#2,-1]}]&,0,Rest@Sort@CompleteIndexSet@indexes];

testing

Clear[li];
Do[li=RandomInteger[{0,4},{RandomInteger[{1,5}],RandomInteger[{1,4}]}];If[!Position[MinimumExpressionGenerator[li],_,{0,∞}]===(IndexSetSort[#1,DepthFirst->True]&)[CompleteIndexSet[li]],Print["bad: ",li]],{10}]

ArrayExpressionGenerator

The algorithm of ArrayExpressionGenerator reflects on the idea that any Mathematica structure can be generated by a string system with two transformation rules. Start with f, then use the following transformations to generate expressions: (1) f->f[]. (2) f[..n]->f[...n+1]. (e.g. f[]->f[f]->f[f,f]->f[f,f,f...]) In this system one can get two types of nestings: The nesting of head f[][][]... and the nesting of body f[f[f[...]]]. Another feature is the repeatition f[f,f,f,...].

ArrayExpressionGenerator[positionIndex,Heads->True] returns an expression having all parts up to positionIndex. Suppose positionIndex={2,3,1}, then the result will contain parts having position index of {0,0,0}<={i,j,k}<={2,3,1}.

Iterative version

Clear[ArrayExpressionGenerator];
ArrayExpressionGenerator::"usage"="ArrayExpressionGenerator[dimensions1,(Heads->False)] generates an array with dimensions dimensions1 using 0 as atoms. If Heads->False, the heads are not nested. Related: ExpressionGenerator, ReplaceAtomWithIndex. Example: ArrayExpressionGenerator[{2,2},Heads->False]";

Options[ArrayExpressionGenerator]={Heads->False};

ArrayExpressionGenerator[d_List]:=ArrayExpressionGenerator[d,Heads->(Heads/.Options[ArrayExpressionGenerator])];

ArrayExpressionGenerator[d_List,Heads->True]:=Module[{i=Length@d,g},g=0;Do[pos=Abs@d[[i]];If[pos===0,g=g[],g=g@@Table[g,{pos}]];--i,{i}];g];

ArrayExpressionGenerator[d_List,Heads->False]/;(If[MemberQ[d,0,{1,Infinity},Heads->False],Message[IndexSet::"0index",d];False,True]):=Module[{i=Length@d,g},g=0;Do[pos=Abs@d[[i]];g=0@@Table[g,{pos}];--i,{i}];g];

Recursive version

Clear[ArrayExpressionGenerator2,ArrayExpressionGenerator2Internal];

Options[ArrayExpressionGenerator2]={Heads->False};

ArrayExpressionGenerator2[d_List]:=ArrayExpressionGenerator2[d,Heads->(Heads/.Options[ArrayExpressionGenerator2])];

ArrayExpressionGenerator2[{},Heads->True]:=0;
ArrayExpressionGenerator2[{0,rest___},Heads->True]:=ArrayExpressionGenerator2[{rest},Heads->True][];
ArrayExpressionGenerator2[{a_,rest___},Heads->True]:=ArrayExpressionGenerator2[{rest},Heads->True]@@Table[ArrayExpressionGenerator2[{rest},Heads->True],{a}];

ArrayExpressionGenerator2[d_List,Heads->False]/;(If[MemberQ[d,0,{1,Infinity},Heads->False],Message[IndexSet::"0index",d];False,True]):=ArrayExpressionGenerator2Internal[d];

ArrayExpressionGenerator2Internal[{}]=0;

ArrayExpressionGenerator2Internal[{a_,rest___}]:=0@@Table[ArrayExpressionGenerator2Internal[{rest}],{a}]

testing

Heads->True cases.

Clear[li];
Do[li=RandomInteger[{0,2},RandomInteger[{1,3}]];If[!SameQ@@(#1[li,Heads->True]&)/@{ArrayExpressionGenerator,ArrayExpressionGenerator2,MinimumExpressionGenerator[ArrayIndexSet[##1]]&},Print["bad: ",Global`li]],{100}]

Heads->False cases and dimensions does not contain 0.

Clear[li];
Do[li=RandomInteger[{1,2},RandomInteger[{1,3}]];If[!SameQ@@(#1[li,Heads->False]&)/@{ArrayExpressionGenerator,ArrayExpressionGenerator2,MinimumExpressionGenerator[ArrayIndexSet[##1]]&},Print["bad: ",li]],{100}]

Special case: Heads->False and dimensions contains 0.

Clear[li];
li={1,0};
Check[ArrayExpressionGenerator[li,Heads->False],"ok",IndexSet::"0index"]
ArrayExpressionGenerator2[li,Heads->False]
(ExpressionGenerator@ArrayIndexSet@##&)[li,Heads->False]

RandomExpressionGenerator

Clear[RandomExpressionGenerator];

RandomExpressionGenerator::"usage"="RandomExpressionGenerator[] generates a random expression using 0 as atoms. RandomExpressionGenerator[length,depth,size,(Heads->False)] generates a random expression based on given parameters. length and depth are positive integers that specify the maximum length and depth to generate. size should be an integer around length*depth*2; larger size possibly generates fuller expression. If Heads->False, then there will be no nested heads. Example: RandomExpressionGenerator[4,4]";

RandomExpressionGenerator[opt_Rule:(Heads->False)]:=RandomExpressionGenerator[4,4,32,opt];
RandomExpressionGenerator[length_Integer,depth_Integer,opt_Rule:(Heads->False)]:=RandomExpressionGenerator[length,depth,length depth 2,opt];
RandomExpressionGenerator[length_Integer,depth_Integer,size_Integer,opt_Rule:(Heads->False)]:=MinimumExpressionGenerator[RandomInteger[{If[Last[opt],0,1],length},{RandomInteger[{1,size}],RandomInteger[{1,depth-1}]}]];

ReplaceAtomWithIndex

Clear[ReplaceAtomWithIndex,listToSymbol];
ReplaceAtomWithIndex::"usage"="ReplaceAtomWithIndex[expr,(Heads->True)] returns expr with all atoms replaced by a string that indicates their position index. Example: ReplaceAtomWithIndex[Array[f,{2,2}]]";

Options[ReplaceAtomWithIndex]={Heads->True};

ReplaceAtomWithIndex[expr_]:=ReplaceAtomWithIndex[expr,Heads->True];

ReplaceAtomWithIndex[expr_,Heads->predicate_]:=MapIndexed[(StringReplace[ToString@#2,{"{"->"","}"->""," "->"",","->"-"}]&),expr,{-1},Heads->predicate];

ReplaceMultiplePart

ReplaceMultiplePart tries to mend the inadequacy of v.3's new feature ReplacePart[expr,new,pos,npos]. The algorithem uses ReplacePart[expr,new,pos] repeatedly with Fold. The new parts and positions are supplied in the last argument of Fold.

Clear[ReplaceMultiplePart];
ReplaceMultiplePart::"usage"="ReplaceMultiplePart[expr,newPartList,positionIndexList] replaces parts of expr corresponding positionIndexList with newPartList. Example: ReplaceMultiplePart[f[1,2,3],{hal,x},{{0},{2}}]";

ReplaceMultiplePart[expr_,newParts_List,posIndexes_List]:=Fold[ReplacePart[#1,Sequence@@#2]&,expr,Transpose[{newParts,posIndexes}]];

StructureForm

Documentation of StructureForm. Outline: StructureForm breaks all subexpressions into a list containing subexpressions and information about them. This list is sorted by an order so lower branches comes first then branches with smaller index comes first. Then the result is printed through various StyleForm. Parts are highlighted according whether it is a head, or whether it is a member of a specified level.
More detail: subExpInfo is a list of list. Each element corresponds to an subexpression of input expr and other info about it. In the first assignment of subExpInfo, semantic of each element is: {position index with zero's appended,position index length, position index, a sub expression}. The first item is there purely for sorting purpose. The second assignment of subExpInfo sorts the elements, then discard the first element leaving each element as {position index length, position index, a subexpression}. targetLevelExpr extract the subexpr in expr of levels specified by user. Finally, StyleForm[...]& is mapped to subExpInfo, extracting elements, and gives a special color or font face if the element is a head or is a member of targetLevelExpr.

Clear[StructureForm];
StructureForm::"usage"="StructureForm[expr] returns a form that shows the structure of expr. Position indexes of subexpressions are printed in red, and heads are printed in bold face. StructureForm[expr,(levspec:{-1}),(Heads->True),(TabSpacing->3)] will display only subexpressions at specified level. Related: LispForm, TreeForm. Example: StructureForm[Array[f,{2,2}]]";

Options[StructureForm]={TabSpacing->3,Heads->True};
StructureForm[expr_,levspec_:Automatic,opts___Rule]:=Module[{subExpInfo,targetLevelExpr,tabspacing,heads},tabspacing=TabSpacing/.{opts}/.Options[StructureForm];heads=Heads/.{opts}/.Options[StructureForm];If[levspec===Automatic,levspec2={-1},levspec2=levspec];subExpInfo=({Flatten[{#1,Table[0,{Depth[expr]-Length[#1]}]}],Length[#1],#1,Extract[expr,#1]}&)/@Position[expr,_,{1,-1}];subExpInfo=Transpose[Rest[Transpose[Sort[subExpInfo]]]];targetLevelExpr=Level[expr,levspec2,Heads->heads];Style[Column[(Row[{StringJoin@@Table[" ",{tabspacing First[#1]}],Style[StringReplace[ToString[#1[[-2]]],{" "->"","{"->" {"}],FontColor->Hue[0],FontWeight->If[#1[[-2,-1]]===0&&AtomQ[Last[#1]],"Bold","Plain"]]," ",Style[(If[MemberQ[targetLevelExpr,#1],ToString[#1],""]&)[Last[#1]]]}]&)/@subExpInfo],FontFamily->"Courier",FontSize->"12"]];

LispForm

The algorithm for LispForm is very simple. The two rules of lispFormInternal are the main code. The rule of LispForm[expr_] is an interface, and itself does a minor processing. It first replaces symbols Complex and Rational in expr to two temporary symbols, then passes the result to lispFormInternal, and finally replaces back the Complex and Rational heads in the result. The reason for this extra trip is because objects like Complex[1,2] is actually an atom in the sense AtomQ@Complex[1,2] returns True. Similarly for Rational. If this step is not taken, then expresions containing Complex or Rational objects will not be converted correctly because the line lispFormInternal[expr_?AtomQ]:=ToString@expr stops the conversion prematurely. For example, lispFormInternal[Rational[1,2]] will return the argument unchanged, but the correct result should be (Rational 1 2).

Clear[lispFormInternal,LispForm];

LispForm::"usage"="LispForm[expr] returns boxes that represents expr in the Lisp language form. Related: LispToMathematicaExpression. Example: ToString@LispForm@Array[f,{2,2}]";

lispFormInternal[expr_?AtomQ]:=ToString@expr;

lispFormInternal[expr_]:=RowBox[{"(",Sequence@@(lispFormInternal/@Level[expr,{1},Heads->True]),")"}];

LispForm[expr_]:=Module[{rational,complex},DisplayForm@StyleBox[lispFormInternal[expr//.{Rational[a_,b_]:>rational[a,b],Complex[a_,b_]:>complex[a,b]}]/.{ToString@rational->"Rational",ToString@complex->"Complex"},AutoSpacing->False]];

Testing

Clear[expr];
Do[expr=ReplaceAtomWithIndex@RandomExpressionGenerator[Heads->True];If[ToString@LispToMathematicaExpression@ToString@LispForm@expr=!=ToString@expr,Print["bad: ",expr]],{100}];

Special cases. Some of the following generate errors because the form
LispToMathematicaExpression@"1"
LispToMathematicaExpression is not supposed to get such argument.

(ToString@LispToMathematicaExpression@ToString@LispForm@#=!=ToString@#&)@1

(ToString@LispToMathematicaExpression@ToString@LispForm@#=!=ToString@#&)@{}

(ToString@LispToMathematicaExpression@ToString@LispForm@#=!=ToString@#&)@"1"

LispToMathematicaExpression

Description of algorithm used:

We are given a lisp expression in string form. e.g. "(define fact (lambda (n) (if (eq? n 1) 1 (* n (fact (- n 1))))))"

1. Replace all white spaces to a singe space, replace spaces to comma, replace parenthesis to brackets, replace spaces around parenthesis. e.g. ( + 1 2) becomes [+,1,2]. (string quotes are omitted in this description for clarity.)

2. Turn all atoms to string. e.g. [+,1,2] become ["+","1","2"]. This is done so that all atoms in the eventual expression does not contain atoms foreign to Mathematica. For example, +[1,2] is not a legal expression, but "+"[1,2] is.

3. To convert the whole string to a Mathematica expression, add a temporary head. e.g. ["+","1","2"] becomes tempHead["+","1","2"]. The latter is converted to an expression, no longer a string.

4. Delete the tempHead and use the first element as head. i.e. tempHead["+","1","2"] becomes "+"["1","2"].

5. Done.

Coding explained: The coding correspondes to its algorithm fairly well. tempSymb is a unique temporary symbol used for temporary head. The code is a one liner of the form a@b@c@...@arg. The steps corresponds to the functions from right to left.

Clear[LispToMathematicaExpression];

LispToMathematicaExpression::"usage"="LispToMathematicaExpression[LispExpressionString] returns the Mathematica form of the lisp expression. All symbols in lisp expr are turned into string. '() and () are turned into nil. The lisp expression is not expected to contain strings. Note: LispToMathematicaExpression returns a Mathematica structured expression, not a string. Related: LispForm. Example: LispToMathematicaExpression[\"(define fact (lambda (n) (if (eq? n 1) 1 (* n (fact (- n 1))))))\"]";

LispToMathematicaExpression[expr_String]:=Module[{tempSymb},(ReplaceRepeated[#,tempSymb[hh_,rest___]->hh[rest]]&)@ToExpression@(StringReplace[#,{"["->StringJoin[ToString@tempSymb,"["]}]&)@Function[{sexp},With[{atomPositionsInString=(DeleteCases[#,"delete me",{1}]&)@Map[If[First@#+1>Last@#-1,"delete me",#+{1,-1}]&,(Partition[#,2,1]&)@(First/@StringPosition[sexp,{"[","]",","}])]},(StringReplacePart[sexp,(StringJoin["\"",StringTake[sexp,#],"\""]&)/@atomPositionsInString,atomPositionsInString])]]@(StringReplace[#,{"( "->"("," )"->")","("->"[",")"->"]"," "->","}]&)@(FixedPoint[StringReplace[#,{"  "->" "}]&,#]&)@(StringReplace[#,{"\t"->" ","\n"->" ","'()"->"nil","()"->"nil"}]&)@expr];

Testing

Needs some sexp.
ToString@LispForm@LispToMathematicaExpression@sexpString===sexpString

Problem case

LispToMathematicaExpression@"1"

IndentForm

IndentForm is originally written by Robby Villegas at Wolfram Research Inc.

Clear[indent,IndentForm];
IndentForm::"usage"="IndentForm[expr,(TabSpacing->3)] prints expr in a format similar to C or Pascal. Usage Example: IndentForm[Array[f,{2,2}]]";

Options[IndentForm]={TabSpacing->3};
Spaces[k_]:=StringJoin@@Table[Space,{k}];
Global`indent[h_[elems___],k_,i_]:=Column[Join[{Row[{Spaces[k],h,"["}]},(Insert[#1,",",{1,-1,-1}]&)/@Drop[Thread[Unevaluated[indent[{elems},k+i,i]]],-1],{Last[Thread[Unevaluated[indent[{elems},k+i,i]]]]},{Row[{Spaces[k],"]"}]}]];
indent[atom_,k_,i_]:=Column[{Row[{Spaces[k],atom}]}];
IndentForm[expr_]:=IndentForm[expr,TabSpacing->3];
IndentForm[expr_,TabSpacing->i_]:=indent[expr,0,i];