Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Graphics and Visualization sorted by active[WSC18] Relativistic Star Field Demonstration
http://community.wolfram.com/groups/-/m/t/1387351
##Introduction##
The purpose of this project was to demonstrate the effects of Special Relativity when one travels at a velocity close to that of the speed of light (around 995%). Using mathematics such as the Lorentz transformations and vector calculus, an accurate depiction was developed of time dilation and length contraction in a three dimensional star field. An equation was also developed to express the Doppler effect which represents the change in frequency of of lightwaves as seen by the viewer, and also exhibits the specific effects of time dilation and length contraction.
##Visualizing the Demonstration##
Several sources, such as Einstein's On the Electrodynamics of Moving Bodies, were required in order to retrieve the amount of information required to correctly represent Special Relativity. Though the research was never fully complete, a sufficient basis was developed to being coding the first steps of the project. Beginning with a simple star field, this initial code allowed for a base on which to build the final demonstration.
![enter image description here][1]
After coding the first star field, a simple proportionality was developed that proved useful in programming the later demonstrations.
![enter image description here][2]
After, a function was developed which coded for the Doppler effect which was used in a manipulate of a sphere situated on an x, y, and z axis, with two sliders for change in y position and change in velocity, and it allowed for the sphere to shift from red to blue by using the equation for the Doppler effect.
![Initial equation for the Doppler effect][3]
![enter image description here][4]
With a function for the Doppler shift written, it was adjusted in order to program it to function for multiple points, in this case, multiple stars, and was then applied to an adapted code from the original star field. Though it was not the final product, the change of color, when initially applied, did not follow the initial proportionality developed, and therefore the velocity and time were not relative.
![enter image description here][5]
![enter image description here][6]
For the final demonstration, the shift of the Doppler effect was modified so that as the stars began blue-shifted, but after passing the viewer (represented by a cuboid), redshifted. The same rule applied for stars traveling laterally. Three buttons were creating representing the front, back, and side, and an example of the result is shown below:
![enter image description here][7]
##Conclusion##
When finished, this demonstration successfully illustrated the effects of Special Relativity when traveling at .995% the speed of light through the Lorentz Transformation, time dilation, and length contraction. Thus, it allows us to view Special Relativity in action if, one day, we could travel through a star field at a velocity close to that of the speed of light. In the future, the "Searchlight Effect", otherwise known as "Relativistic Aberration", would be added to improve accuracy and further explore the realms and impacts of Special Relativity.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-13at11.29.18AM.png&userId=1381443
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-13at1.12.04PM.png&userId=1381443
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-13at1.22.30PM.png&userId=1381443
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-13at1.22.37PM.png&userId=1381443
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-13at1.23.22PM.png&userId=1381443
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-13at1.23.16PM.png&userId=1381443
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-19at9.24.25AM.png&userId=1381443Macy Maurer Levin2018-07-19T13:26:42ZAny suggestions for displaying text Grid with Overlay plot?
http://community.wolfram.com/groups/-/m/t/1388426
I want to present a text Grid and an Overlay Plot on the same line (Row) with useful scaling. I am stuck with an Overlay because I am displaying a 2-axes TimeSeries. The "My Goal" image was created by editing 2 JPEGs. How can I create the equivalent presentation directly in Mathematica? I am using Version 11.1, without the new presentation features of 11.3. My goal:
![My Goal][1]
The closest I have gotten with the following demo data:
(* as a test case, create 2 fake time series *)
d1 = {1, 2, 3, 4, 5};
d2 = {10, 20, 20, 30, 40};
dateList = Table[DateList[{2014 + x, 1}], {x, 0, 4}];
yearList =
MapThread[DateString, {dateList, Table["Year", Length[dateList]]}];
ts1 = TimeSeries[d1, {dateList}];
ts2 = TimeSeries[d2, {dateList}];
was initially presentable table (show above) and a NON-useful plot using:
(* on my first try at a presentation, I did the following: *)
labeledTable =
Grid[{Text@Style[#, "TableHeader"] & /@ {"\nYear", "Size of\n D1",
"Size of\n D2"}, {Column[yearList], Column[d1], Column[d2]}},
Alignment -> {Center}, Frame -> All]
DateListPlot[{ts1, ts2}]
![HiddenDetails][2]
The plot needed 2 axes. I believe the TimeSeries forced use of an Overlay:
(* to make a 2 axes DateListPlot, it seems one must use an Overlay... *)
plot1 =
DateListPlot[ts1, PlotStyle -> Red,
Frame -> {True, True, False, False},
ImagePadding -> 25, FrameTicks -> {None, All, None, None},
FrameStyle -> {{Directive[Red], None}, {None}}];
plot2 = DateListPlot[ts2, PlotStyle -> Blue,
Frame -> {False, False, False, True}, ImagePadding -> 25,
FrameTicks -> {{None, All}, {None, None}},
FrameStyle -> {{None, Directive[Blue]}, {None}}];
overPlot = Overlay[{plot1, plot2}]
This was nice, but I can't get the desired presentation format, combining the plot with the table. The problem seems to be that an Overlay is not a scalable Graphic, and neither Row[labeledTable,overPlot] nor Grid[labeledTable,overPlot] is very pretty.
![YUK!!][3]
I would appreciate any suggestions, even if you only have a better way to generate or display the test data grid (like how to center a 2-line column header over decimal data).
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5581MyGoal.jpg&userId=1387797
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3674HiddenDetails.jpg&userId=1387797
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7707NotGraphic,NotScaleable.jpg&userId=1387797diller ryan2018-07-20T18:14:05ZGraphics3d: how to make object glow inside semitransparent cylinder?
http://community.wolfram.com/groups/-/m/t/1385468
I would like to reproduce the left image (created by Blender) using Mathematica and Graphics3D (code attached). Somehow I was not able to make the little sphere inside the central cylinder as shiny as in the blender image (see my Mathematica images on the right), even though I used Glow for the colour of the sphere. Does anyone know how I could make the sphere much shinier so that it actually glows and does not look so dull as it is now? Is there anything possibility with Overlay? Thanks.![enter image description here][1]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=comparison.png&userId=439307Markus Schmidt2018-07-16T20:35:05Z[WSC18] Predicting the Halting Problem with Machine Learning
http://community.wolfram.com/groups/-/m/t/1384403
# A Machine Learning Analysis of the Halting Problem over the SKI Combinator Calculus
![A rasterised SK combinator with length 50, evaluated to 5 steps][16]
## Abstract
Much of machine learning is driven by the question: can we learn what we cannot compute? The learnability of the halting problem, the canonical undecidable problem, to an arbitrarily high accuracy for Turing machines was proven by Lathrop. The SKI combinator calculus can be seen as a reduced form of the untyped lambda calculus, which is Turing-complete; hence, the SKI combinator calculus forms a universal model of computation. In this vein, the growth and halting times of SKI combinator expressions is analysed and the feasibility of a machine learning approach to predicting whether a given SKI combinator expression is likely to halt is investigated.
## 1. SK Combinators
What we will refer to as 'SK Combinators' are expressions in the SKI combinator calculus, a simple Turing-complete language introduced by Schönfinkel (1924) and Curry (1930). In the same way that NAND gates can be used to construct any expression in Boolean logic, SK combinators were posed as a way to construct any expression in predicate logic, and being a reduced form of the untyped lambda calculus, any functional programming language can be implemented by a machine that implements SK combinators. While implementations of this language exist, these serve little functional purpose - instead, this language, a simple idealisation of transformations on symbolic expressions, provides a useful tool for studying complex computational systems.
### 1.1 Rules and Expressions
Formally, SK combinator expressions are binary trees whose leaves are labelled either '*S*', '*K*' or '*I*': each tree *(x y)* represents a function *x* applied to an argument *y*. When the expression is evaluated (i.e. when the function is applied to the argument), the tree is transformed into another tree, the 'value'. The basic 'rules' for evaluating combinator expressions are given below:
*k[x][y] := x*
The K combinator or 'constant function': when applied to *x*, returns the function *k[x]*, which when applied to some *y* will return *x*.
*s[x][y][z] := x[z][y[z]]*
The S combinator or 'fusion function': when applied to *x, y, z*, returns *x* applied to *z*, which is in turn applied to the result of *y* applied to *z*.
*i[x] := x*
The I combinator or 'identity function': when applied to *x*, returns *x*.
Note that the I combinator *I[x]* is equivalent to the function *S[K][a][x]*, as the latter will evaluate to the former in two steps:
*S[K][a][x]*
*= K[x][a[x]]*
*= x*
Thus the I combinator is redundant as it is simply 'syntactic sugar' - for the purposes of this exploration it will be ignored.
These rules can be expressed in the Wolfram Language as follows:
SKRules={k[x_][y_]:> x,s[x_][y_][z_]:> x[z][y[z]]}
### 1.2 Evaluation
The result of applying these rules to a given expression is given by the following functions:
SKNext[expr_]:=expr/.SKRules;
Returns the next 'step' of evaluation of the expression *expr* - evaluating all functions in *expr* according to the rules above without evaluating any 'new'/transformed functions.
SKEvaluate[expr_,n_]:=NestList[#1/.SKRules&,expr,n];
Returns the next *n* steps of evaluation of the expression *expr*
SKEvaluateUntilHalt[expr_,n_] := FixedPointList[SKNext,expr,n+1];
Returns the steps of evaluation of *expr* until either it reaches a fixed point or it has been evaluated for n steps, whichever comes first.
Note that, due to the Church-Rosser theorem (Church and Rosser, 2018), the order in which the rules are applied does not affect the final result, as long as the combinator evaluates to a fixed point / 'halts'. For combinators with no fixed point, which do not halt, the behaviour demonstrated as they evaluate could change based on the order of application of the rules - this is not explored here and is a topic for potential future investigation.
### 1.3 Examples
The functions above can be used to evaluate a number of interesting SK combinator expressions:
Column[SKEvaluateUntilHalt[s[k][a][x],10][[1;;-2]]]
[//]: # (No rules defined for Output)
The *I* combinator
Column[SKEvaluateUntilHalt[s[k[s[i]]][k][a][b],10][[1;;-2]]]
[//]: # (No rules defined for Output)
The reversal expression - *s[k][s[i]][k][a][b]* takes two terms, *a* and *b*, and returns *b[a]*.
## 2. Growth and Halting
### 2.1 Halting and Related Works
We will define a combinator expression to have halted if it has reached a fixed point - i.e. if no combinators in the expression can be evaluated, or if evaluating any of the combinators in the expression returns the original expression. As SK combinators are Turing-complete and so computationally universal, it is evident that the halting problem - determining whether or not a given SK combinator expression will halt - is undecidable for SK combinators. There are, however, patterns and trends in the growth of SK combinators, and it is arguably possible to speak of the probability of a given SK combinator expression halting.
Some investigations (Lathrop 1996) and (Calude and M. Dumitrescu 2018) have been made into probabilistically determining the halting time of Turing machines, with [2] proving that it is possible to compute some value K where for some arbitrary predetermined confidence *(1-\[Delta])* and accuracy *(1-\[Epsilon]),* a program that does
A. Input a Turing machine M and program I.
B. Simulate M on I for K steps.
C. If M has halted then print 1, else print 0.
D. Halt.
has a probability greater than *(1-δ)* of having an accuracy (when predicting whether or not a program will halt) greater than *(1-ε).* The key result of this is that, in some cases 'we can learn what we cannot compute' - 'learning' referring to Valiant's formal analysis as 'the phenomenon of knowledge acquisition in the absence of specific programming' (Valiant 1984).
### 2.2 Definitions and Functions
The size of a combinator expression can either be measured by its length (total number of characters including brackets) or by its leaf size (number of 's' and 'k' characters). We use the former in most cases, and the latter when randomly generating combinator expressions.
The number of possible combinator expressions with leaf size *n* is given by
SKPossibleExpressions[n_]:=(2^n)*Binomial[2*(n-2),n-1]/n
(Wolfram, 2002), which grows exponentially.
#### 2.2.1 Visualisation
We define a function to visualise the growth of a combinator, *SKRasterize*:
SKArray[expr_,n_]:=Characters/@ToString/@SKEvaluate[expr,n];
SKArray[expr_]:=SKArray[expr,10];
Generates a list of the steps in the growth of a combinator, where each expression is itself a list of characters ('s', 'k', '[', ']')
SKGrid[exp_,n_]:=ArrayPlot[SKArray[exp,n],{ColorRules->{"s"->RGBColor[1,0,0],"k"->RGBColor[0,1,0],"["->RGBColor[0,0,1],"]"->RGBColor[0,0,0]},PixelConstrained->True,Frame->False,ImageSize->1000}];
SKGrid[exp_]:=SKGrid[exp,10];
Generates an ArrayPlot of a list given by SKArray, representing the growth of a combinator in a similar manner to that of cellular automata up to step n. The y axis represents time - each row is the next expression in the evaluation of an SK combinator. Red squares indicate 'S', green squares indicate 'K', blue squares indicate '[' and black squares indicate ']'.
SKRasterize[func_,n_]:=Image[SKGrid[func,n][[1]]];
SKRasterize[func_]:=SKRasterize[func,10];
Generates a rasterized version of the ArrayPlot.
A visualisation of a given combinator can easily be produced, as follows:
SKRasterize[s[s[s]][s][s][s][k],15]
[//]: # (No rules defined for Output)
![The longest running halting expression with leaf size 7, halting in 12 steps (Wolfram, 2002)][1]
The longest running halting expression with leaf size 7, halting in 12 steps (Wolfram, 2002)
#### 2.2.2 Halting graphs
We can create a table of the length (string length) of successive combinator expressions as they evaluate as follows:
SKLengths[exp_,n_]:=StringLength/@ToString/@SKEvaluate[exp,n];
Returns a list of the lengths of successive expressions until step *n*
These can be plotted as a graph (x axis number of steps, y axis length of expression):
SKPlot[expr_,limit_]:=ListLinePlot[SKLengths[expr,limit],AxesOrigin->{1,0},AxesLabel->{"Number of steps","Length of expression"}];
Thus, a graph of the above combinator can be produced:
SKPlot[s[s[s]][s][s][s][k],15]
[//]: # (No rules defined for Output)
![A graph of the above combinator][2]
It is evident from the graph that this combinator halts at 12 steps.
#### 2.2.3 Random SK combinators
To empirically study SK combinators, we need a function to randomly generate them. Two methods to do this were found:
RecursiveRandomSKExpr[0,current_]:=current;
RecursiveRandomSKExpr[depth_,current_]:=
RecursiveRandomSKExpr[depth-1,
RandomChoice[{
RandomChoice[{s,k}][current],
current[RecursiveRandomSKExpr[depth-1,RandomChoice[{s,k}]]]
}]
];
RecursiveRandomSKExpr[depth_Integer]:=RecursiveRandomSKExpr[depth,RandomChoice[{s,k}]];
A recursive method, repeatedly appending either a combinator to the 'head' of the expression or a randomly generated combinator expression to the 'tail' of the expression. (Hennigan)
replaceWithList[expr_,pattern_,replaceWith_]:=ReplacePart[expr,Thread[Position[expr,pattern]->replaceWith]];
treeToFunctions[tree_]:=ReplaceRepeated[tree,{x_,y_}:>x[y]];
randomTree[leafCount_]:=Nest[ReplacePart[#,RandomChoice[Position[#,x]]->{x,x}]&,{x,x},leafCount-2];
RandomSKExpr[leafCount_]:=treeToFunctions[replaceWithList[randomTree[leafCount],x,RandomChoice[{s,k},leafCount]]];
Random combinator generation based on generation of binary trees - each combinator can be expressed as a binary tree with leaves 'S' or 'K'. (Parfitt, 2017)
While the first method gives a large spread of combinators with a variety of lengths, and is potentially more efficient, for the purposes of this exploration the second is more useful, as it limits the combinators generated to a smaller, more controllable sample space (for a given leaf size).
### 2.3 Halting Graphs
All combinators of leaf sizes up to size 6 evolve to fixed points (NKS):
exprs = Table[RandomSKExpr[6],10];
ImageCollage[Table[ListLinePlot[SKLengths[exprs[[n]],40]],{n,10}],Background->White]
[//]: # (No rules defined for Output)
![10 randomly generated combinators of size 6, with their lengths plotted until n=40.][3]
10 randomly generated combinators of size 6, with their lengths plotted until n=40.
As the leaf size increases, combinators take longer to halt, and some show exponential growth:
exprs = Table[RandomSKExpr[10],10];
ImageCollage[Table[ListLinePlot[SKLengths[exprs[[n]],40]],{n,10}],Background->White]
[//]: # (No rules defined for Output)
![10 randomly generated combinators of size 10, with their lengths plotted until n=20.][4]
10 randomly generated combinators of size 10, with their lengths plotted until n=20.
exprs = Table[RandomSKExpr[30],10];
ImageCollage[Table[ListLinePlot[SKLengths[exprs[[n]],40]],{n,10}],Background->White]
[//]: # (No rules defined for Output)
![10 randomly generated combinators of size 30, with their lengths plotted until n=40.][5]
10 randomly generated combinators of size 30, with their lengths plotted until n=40.
CloudEvaluate[exprs = Table[RandomSKExpr[50],10];
ImageCollage[Table[ListLinePlot[SKLengths[exprs[[n]],40]],{n,10}],Background->White]]
[//]: # (No rules defined for Output)
![10 randomly generated combinators of size 50, with their lengths plotted until n=40.][6]
10 randomly generated combinators of size 50, with their lengths plotted until n=40.
After evaluating a number of these combinators, it appears that they tend to either halt or grow exponentially - some sources (Parfitt, 2017) reference linear growth combinators, however none of these have been encountered as yet.
### 2.4 Halting Times
With a random sample of combinators, we can plot a cumulative frequency graph of the number of combinators that have halted at a given number of steps:
SKHaltLength[expr_,n_]:=Module[{x},
x=Length[SKEvaluateUntilHalt[expr,n+1]];
If[x>n,False,x]
]
Returns the number of steps it takes the combinator *expr* to halt; if *expr* does not halt within n steps, returns *False*.
GenerateHaltByTable[depth_,iterations_,number_]:=Module[{exprs,lengths},
exprs = Monitor[Table[RandomSKExpr[depth],{n,number}],n];
lengths = Monitor[Table[SKHaltLength[exprs[[n]],iterations],{n,number}],n];
Return[lengths]
]
Generates a table of the halt lengths of *number* random combinator expressions (*False* if they do not halt within *iterations* steps) with leaf size *depth*.
GenerateHaltData[depth_,iterations_,number_]:=Module[{haltbytable,vals},
haltbytable = GenerateHaltByTable[depth,iterations,number];
vals = BinCounts[Sort[haltbytable],{1,iterations+1,1}];
Table[Total[vals[[1;;n]]],{n,1,Length[vals]}]
]
Generates a table of the number of *number* random combinator expressions (*False* if they do not halt within *iterations* steps) with leaf size *depth* that have halted after a given number of steps
GenerateHaltGraph[depth_,iterations_,number_]:=Module[{cumulative,f},
cumulative=GenerateHaltData[depth,iterations,number];
f=Interpolation[cumulative];
{ListLinePlot[cumulative,PlotRange->{Automatic,{0,number}},GridLines->{{},{number}},Epilog-> {Red,Dashed,Line[{{0,cumulative[[-1]]},{number,cumulative[[-1]]}}]},AxesOrigin->{1,0},AxesLabel->{"Number of steps","Number of combinators halted"}],cumulative[[-1]]}
]
Plots a graph of the above data.
#### 2.4.1 Halting Graphs
We analyse halt graphs of random samples of 1000 combinators (to leaf size 30):
CloudEvaluate[GenerateHaltGraph[10,30,1000]]
[//]: # (No rules defined for Output)
![Leaf size 10: almost all combinators in the sample (997) have halted (99.7%).][7]
Leaf size 10: almost all combinators in the sample (997) have halted (99.7%).
CloudEvaluate[GenerateHaltGraph[20,30,1000]]
[//]: # (No rules defined for Output)
![Leaf size 20: 979 combinators in the sample have halted (97.9%).][8]
Leaf size 20: 979 combinators in the sample have halted (97.9%).
CloudEvaluate[GenerateHaltGraph[30,30,1000]]
[//]: # (No rules defined for Output)
![Leaf size 30: 962 combinators in the sample have halted (96.2%).][9]
Leaf size 30: 962 combinators in the sample have halted (96.2%).
CloudEvaluate[GenerateHaltGraph[40,30,1000]]
[//]: # (No rules defined for Output)
![Leaf size 40: 944 combinators in the sample have halted (94.4%).][10]
Leaf size 40: 944 combinators in the sample have halted (94.4%).
CloudEvaluate[GenerateHaltGraph[50,30,1000]]
[//]: # (No rules defined for Output)
![Leaf size 50: 889 combinators in the sample have halted (88.9%).][11]
Leaf size 50: 889 combinators in the sample have halted (88.9%).
Evidently, the rate of halting of combinators in the sample decreases as number of steps increases - the gradient of the graph is decreasing. As the graph levels out at around 30 steps, we will assume that the number of halting combinators will not increase significantly beyond this point.
As the leaf size increases, fewer combinators in the sample have halted by 30 steps - however, the graph still levels out, suggesting most of the combinators which have not halted by this point will never halt.
#### 2.4.2 Halting Times and Leaf Size
We can plot a graph of the number of halted combinators against leaf size:
CloudEvaluate[ListLinePlot[Table[{n,GenerateHaltGraph[n,30,1000][[2]]},{n,5,50,1}]]]
![A graph to show the number of combinators which halt within 30 steps in each of 45 random samples of 1000 combinators, with leaf size varying from 5 to 50.][12]
A graph to show the number of combinators which halt within 30 steps in each of 45 random samples of 1000 combinators, with leaf size varying from 5 to 50.
This graph shows that, despite random variation, the number of halted combinators decreases as the leaf size increases: curve fitting suggests that this follows a negative quadratic function.
FitData[data_,func_]:=Module[{fitd},fitd={Fit[data[[1,2,3,4,1]],func,x]};{fitd,Show[ListPlot[data[[1,2,3,4,1]],PlotStyle->Red],Plot[fitd,{x,5,50}]]}]
A curve-fitting function: plots the curve of best fit for *data* with some combination of functions *func*.
FitData[%,{1,x,x^2}]
[//]: # (No rules defined for Output)
![Curve-fitting on the data with a quadratic function][13]
{1012.07 - 1.18915 x - 0.0209805 x^2}
Curve-fitting on the data with a quadratic function yields a reasonably accurate curve of best fit.
## 3. Machine Learning Analysis of SK Combinators
The graphs above suggest that the majority of halting SK combinators with leaf size <=50 will halt before ~30 steps. Thus we can state that, for a randomly chosen combinator, it is likely that if it does not halt before 40 steps, it will never halt. Unfortunately a lack of time prohibited a formal analysis of this, in the vein of Lathrop's work - this is an area for future research.
We attempt to use modern machine learning methods to predict the likelihood of a given SK combinator expression halting before 40 steps:
### 3.1 Dataset Generation
We implement a function *GenerateTable* to produce tables of random SK expressions:
SKHaltLength[expr_,n_]:=Module[{x},
x=Length[SKEvaluateUntilHalt[expr,n+1]];
If[x>n,False,x]
]
Returns the number of steps *expr* takes to halt if the given expression *expr* halts within the limit given (*limit*), otherwise returns *False*
GenerateTable[depth_,iterations_,number_]:=Module[{exprs,lengths},
exprs = Monitor[Table[RandomSKExpr[depth],{n,number}],n];
lengths = Monitor[Table[exprs[[n]]-> SKHaltLength[exprs[[n]],iterations],{n,number}],n];
lengths = DeleteDuplicates[lengths];
Return[lengths]
]
Returns a list of *number* expressions with leaf size *depth* whose elements are associations with key *expression* and value *number of steps taken to halt* if the expression halts within *iterations* steps, otherwise *False*.
*GenerateTable* simply returns tables random SK expressions - as seen earlier, these tend to be heavily skewed datasets as around 90% of random expressions generated will halt. Thus we must process this dataset to create a balanced training dataset: this is done with the function *CreateTrainingData*:
CreateTrainingData[var_]:=Module[{NoHalt,Halt,HaltTrain,Train},
NoHalt = Select[var,#[[2]]==False&];
Halt = Select[var,#[[2]]==True&];
HaltTrain = RandomSample[Halt,Length[NoHalt]];
Train = Join[HaltTrain,NoHalt];
Return[Train]
];
Counts the number of non-halting combinators in *var* (assumption is this is less than number of halting combinators), selects a random sample of halting combinators of this length and concatenates the lists.
ConvertSKTableToString[sktable_]:=Table[ToString[sktable[[n,1]]]-> sktable[[n,2]],{n,1,Length[sktable]}];
Converts SK expressions in a table generated with *GenerateTable* to strings
We also implement a function to create rasterised training data (where instead of an individual SK combinator associated with either True or False, an image of the first 5 steps of evaluation of the combinator is associated with either True or False):
CreateRasterizedTrainingData[var_]:=Module[{NoHalt,Halt,HaltTrain,HaltTrainRaster,NoHaltTrainRaster,RasterTrain},
NoHalt = Select[var,#[[2]]==False&];
Halt = Select[var,#[[2]]==True&];
HaltTrain = RandomSample[Halt,Length[NoHalt]];
HaltTrainRaster=Monitor[Table[SKRasterize[HaltTrain[[x,1]],5]-> HaltTrain[[x,2]],{x,1,Length[HaltTrain]}],x];
NoHaltTrainRaster=Monitor[Table[SKRasterize[NoHalt[[x,1]],5]-> NoHalt[[x,2]],{x,1,Length[NoHalt]}],x];
RasterTrain = Join[HaltTrainRaster,NoHaltTrainRaster];
Return[RasterTrain]
];
Counts the number of non-halting combinators in *var* (assumption is this is less than number of halting combinators), selects a random sample of halting combinators of this length, evaluates and generates images of both halting and non-halting combinators and processes them into training data (image->True/False).
### 3.2 Markov Classification
#### 3.2.1 Training
As a first attempt, we generate 2000 random SK expressions with leaf size 5, 2000 expressions with leaf size 10 ... 2000 expressions with leaf size 50, evaluated up to 40 steps:
lengths = Flatten[Table[GenerateTable[n,40,2000],{n,5,50,5}]]
We convert all non-False halt lengths to 'True':
lengths = lengths/.(a_->b_)/;!(b===False):> (a->True);
We process the data and train a classifier using the Markov method:
TrainingData = CreateTrainingData[lengths];
TrainingData2 = ConvertSKTableToString[TrainingData];
HaltClassifier1 = Classify[TrainingData2,Method->"Markov"]
[//]: # (No rules defined for Output)
#### 3.2.2 Testing
We must now generate test data, using the same parameters for generating random combinators:
testlengths = Flatten[Table[GenerateTable[n,40,2000],{n,5,50,5}]]
testlengths = testlengths/.(a_->b_)/;!(b===False):> (a->True);
TestData = CreateTrainingData[testlengths];
TestData2 = ConvertSKTableToString[TestData];
The classifier can now be assessed for accuracy using this data:
TestClassifier1 = ClassifierMeasurements[HaltClassifier1,TestData2]
[//]: # (No rules defined for Output)
#### 3.2.3 Evaluation
A machine learning solution to this problem is only useful if the accuracy is greater than 0.5 (i.e. more accurate than a random coin flip). We test the accuracy of the classifier:
TestClassifier1["Accuracy"]
0.755158
This, while not outstanding, is passable for a first attempt. We find the training accuracy:
ClassifierInformation[HaltClassifier1]
![Classifier Information][14]
The training accuracy (71.3%) is slightly lower than the testing accuracy (75.5%) - this is surprising, and is probably due to a 'lucky' testing dataset chosen.
We calculate some statistics from a confusion matrix plot:
TestClassifier1["ConfusionMatrixPlot"]
![Confusion Matrix Plot][15]
Accuracy: 0.76
Misclassification rate: 0.24
Precision (halt): 0.722 (when 'halt' is predicted, how often is it correct?)
True Positive Rate: 0.83 (when the combinator halts, how often is it classified as halting?)
False Positive Rate: 0.32 (when the combinator doesn't halt, how often is it classified as halting?)
Precision (non-halt): 0.799 (when 'non halt' is predicted, how often is it correct?)
True Negative Rate: 0.68 (when the combinator doesn't halt, how often is it classified as not halting?)
False Negative Rate: 0.17 (when the combinator halts, how often is it classified as not halting?)
A confusion matrix plot shows that the true positive rate is larger than the true negative rate - this would suggest that it is easier for the model to tell when an expression halts than when an expression does not halt. This could be due to the model detecting features suggesting very short run time in the initial string - for instance, a combinator k[k][<expression>] would evaluate immediately to k and halt - however, these 'obvious' features are very rare.
### 3.3 Random Forest Classification on Rasterised Expression Images
Analysing strings alone, without any information about how they are actually structured or how they might evaluate, could well be a flawed method - one might argue that, in order to predict halting, one would need more information about how the program runs. Hence, another possible method is to generate a dataset of visualisations of the first 5 steps of a combinator's evaluation as follows:
SKRasterize[RandomSKExpr[50],5]
![A rasterised SK combinator with length 50, evaluated to 5 steps][16]
and feed these into a machine learning model. Although it might seem that this method is pointless - we are already evaluating the combinators to 5 steps, and we are training a model on a database of combinators evaluated to 40 steps to predict if a combinator will halt in <=40 steps, the point of the exercise is less to create a useful resource than to investigate the feasibility of applying machine learning to this type of problem. If more computational power was available, a dataset of combinators evaluated to 100 steps (when even more combinators will have halted) could be created: in such a case a machine learning model to predict whether or not a combinator will halt in <=100 steps would be a practical approach as the time taken to evaluate a combinator to 100 steps is exponentially longer than that taken to evaluate a combinator to 5 steps.
3.3.1 Training
We generate a dataset of 2000 random SK expressions with leaf size 5, 2000 expressions with leaf size 10 ... 2000 expressions with leaf size 50, evaluated up to 40 steps:
rasterizedlengths = Flatten[Table[GenerateTable[n,40,2000],{n,5,50,5}]];
In order to train a model on rasterised images, we must evaluate all SK expressions in the dataset to 5 steps and generate rasterised images of these:
RasterizedTrainingData = CreateRasterizedTrainingData[rasterizedlengths];
We then train a classifier on this data:
RasterizeClassifier=Classify[RasterizedTrainingData,Method->"RandomForest"]
#### 3.3.2 Testing
We must now generate test data, using the same parameters for generating random training data:
testrasterizedlengths = Flatten[Table[GenerateTable[n,40,2000],{n,5,50,5}]];
testrasterizedlengths = testrasterizedlengths/.(a_->b_)/;!(b===False):> (a->True);
TestRasterizedData = CreateRasterizedTrainingData[testrasterizedlengths];
The classifier can now be assessed for accuracy using this data:
TestRasterizeClassifier=ClassifierMeasurements[RasterizeClassifier,TestRasterizedData]
[//]: # (No rules defined for Output)
#### 3.3.3 Evaluation
A machine learning solution to this problem is only useful if the accuracy is greater than 0.5 (i.e. more accurate than a random coin flip). We test the accuracy of the classifier:
TestRasterizeClassifier["Accuracy"]
0.876891
This is significantly better than the Markov approach (75.5%). We find the training accuracy:
ClassifierInformation[RasterizeClassifier]
![enter image description here][17]
Again, the training accuracy (85.5%) is slightly lower than the testing accuracy (87.7%).
We calculate some statistics from a confusion matrix plot:
TestRasterizeClassifier["ConfusionMatrixPlot"]
![Confusion Matrix Plot][18]
Accuracy: 0.88
Misclassification rate: 0.12
Precision (halt): 0.911 (when 'halt' is predicted, how often is it correct?)
True Positive Rate: 0.83 (when the combinator halts, how often is it classified as halting?)
False Positive Rate: 0.08 (when the combinator doesn't halt, how often is it classified as halting?)
Precision (non-halt): 0.848 (when 'non halt' is predicted, how often is it correct?)
True Negative Rate: 0.92 (when the combinator doesn't halt, how often is it classified as not halting?)
False Negative Rate: 0.17 (when the combinator halts, how often is it classified as not halting?)
A confusion matrix plot shows that the false negative rate is larger than the false positive rate - this would suggest that it is easier for the model to tell when an expression halts than when an expression does not halt. The precision for halting is much higher than the precision for non-halting, indicating that if the model suggests a program will halt, this is much more likely to be correct than if it suggested that the program would not halt. An (oversimplified) way to look at this intuitively is to examine some graphs of lengths of random combinators:
![Random combinator length graphs][19]
Looking at combinators that halt (combinators for which the graph flattens out), some combinators 'definitely halt' - their length decreases until the graph flattens out:
!['definitely halts'][20]
'definitely halts' (1)
Some combinators have length that increases exponentially :
![exponentially increasing combinator length graph][21]
'possibly non-halting' (2)
And some combinators appear to have increasing length but suddenly decrease:
![increasing then decreasing combinator length graph][22]
'possibly non-halting' (3)
We do not know which features of the rasterised graphic the machine learning model extracts to make its prediction, but if, say, it was classifying based purely on length of the graphic, it would identify combinators like (1) as ' definitely halting', but would not necessarily be able to distinguish between combinators like (2) and combinators like (3), which both appear to be non - halting initially.
On a similar note, some functional programming languages (e.g. Agda - [7]) have the ability to classify a function as 'definitely halting' or 'possibly non-halting', just like our classifier, whose dataset is trained on functions that either 'definitely halt' (halt in <= 40 steps) or are 'possibly non-halting' (do not halt in <= 40 steps - might halt later).
### 3.4 Table of Comparison
![A table comparing statistics for Markov and Random Forest models][23]
### 4. Conclusions and Further Work
#### 4.1 Conclusions
The results of this exploration were somewhat surprising, in that a machine learning approach to determining whether or not a program will terminate appears to some extent viable - out of all the methods attempted, the random forest classifier applied to a rasterised image of the first five steps of the evaluation of a combinator achieved the highest accuracy of 0.88 on a test dataset of 1454 random SK combinator expressions. Note, though, that what is actually being determined here is whether or not a combinator will halt before some n steps (here, n=40) - we are classifying between combinators that 'definitely halt' and combinators which are 'possibly non-halting'.
### 4.2 Microsite
As an extension to this project, a Wolfram microsite was created and is accessible at [https://www.wolframcloud.com/objects/euan.l.y.ong/SKCombinators](https://www.wolframcloud.com/objects/euan.l.y.ong/SKCombinators) - within this microsite, a user can view a rasterised image of a combinator, a graph of the length of the combinator as it is evaluated, a statistical analysis of halting time relative to other combinators with the same leaf size and a machine learning prediction of whether or not the combinator will halt within 40 steps.
![Microsite Screenshot][24]
A screenshot of the microsite evaluating a random SK combinator expression
### 4.3 Implications, Limitations and Further Work
Although the halting problem is undecidable, the field of termination analysis - attempting to determine whether or not a given program will eventually terminate - has a variety of applications, for instance in program verification. Machine learning approaches to this problem would not only help explore this field in new ways but could also be implemented in, for instance, software debuggers.
The principal limitations of this method are that we are only predicting whether or not a combinator will halt in a finite number *k* of steps - while this could be a sensible idea if k is large, at present this system is very impractical due to small datasets and a small value of *k* used to train the classifier (*k *= 40). Another issue with the machine learning technique used is that the visualisations have different dimensions (longer combinators will generate longer images), and when the images are preprocessed and resized before being fed into the random forest model, downsampling/upsampling can lead to loss of data decreasing the accuracy of the model.
From a machine learning perspective, attempts at analysis of the rasterised images with a neural network could well prove fruitful, as would an implementation of a vector representation of syntax trees to allow the structure of SK combinators (nesting combinators) to be accurately extracted by a machine learning model.
Future theoretical research could include a deeper exploration of Lathrop's probabilistic method of determining *k*, an investigation of the 'halting' features the machine learning model is looking for within the rasterised images, a more general analysis of SK combinators (proofs of halting / non-halting for certain expressions, for instance) to uncover deeper patterns, or even an extension of the analysis carried out in the microsite to lambda calculus expressions (which can be transformed to an 'equivalent' SK combinator expression).
## Acknowledgements
We thank the mentors at the 2018 Wolfram High School Summer Camp - Andrea Griffin, Chip Hurst, Rick Hennigan, Michael Kaminsky, Robert Morris, Katie Orenstein, Christian Pasquel, Dariia Porechna and Douglas Smith - for their help and support writing this paper.
## References
A. Church and J. B. Rosser: Some properties of conversion. Transactions of the American Mathematical Society, 39 (3): 472\[Dash]482, 2018
R. H. Lathrop: On the learnability of the uncomputable. ICML 1996: 302-309.
C. S. Calude and M. Dumitrescu: A probabilistic anytime algorithm for the halting problem. Computability 7(2-3): 259-271, 2018.
L. G. Valiant: A theory of the learnable. Communications of the Association for Computing Machinery 27, (11): 1134-1142, 1984.
S. Wolfram: A New Kind of Science. 1121-1122, 2002.
E. Parfitt: Ways that combinators evaluate from the Wolfram Community\[LongDash]A Wolfram Web Resource. (2017)
http://community.wolfram.com/groups/-/m/t/965400
S-C Mu: Agda.Termination.Termination http://www.iis.sinica.edu.tw/~scm/Agda/Agda-Termination-Termination.html
Attached is a Wolfram Notebook (.nb) version of this computational essay.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1.png&userId=1371970
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2.png&userId=1371970
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3.png&userId=1371970
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4.png&userId=1371970
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5.png&userId=1371970
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6.png&userId=1371970
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7.png&userId=1371970
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=8.png&userId=1371970
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9.png&userId=1371970
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=10.png&userId=1371970
[11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=11.png&userId=1371970
[12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=12.png&userId=1371970
[13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=13.png&userId=1371970
[14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Classify1.png&userId=1371970
[15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=15.png&userId=1371970
[16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=16.png&userId=1371970
[17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=17.png&userId=1371970
[18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=18.png&userId=1371970
[19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=19.png&userId=1371970
[20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=20.png&userId=1371970
[21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=21.png&userId=1371970
[22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=22.png&userId=1371970
[23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=23.png&userId=1371970
[24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=24.png&userId=1371970Euan Ong2018-07-14T23:56:25Z[WSC18] Implementation of Common Axiom Systems and Proof Generation
http://community.wolfram.com/groups/-/m/t/1382544
# Exploration of Fundamental Mathematics, via Implementation of Common Axiom Systems and Proof Generation
Utilizing the function FindEquationalProof introduced in version 11.3 of Mathematica, I implemented and proved common algebraic and logical conjectures as well as hypothetical, but plausible combinations of axioms and conjectures, as introduced in Chapter 12, Section 9 of Stephen Wolfram's book, *A New Kind of Science*. **The Full Computational Essay is attached at the bottom.**
This post is divided into the following 4 sections:
1. **Implementation of Modern Axiom Systems**
2. **Proof Generation**
3. **Alternative Axiom Systems**
4. **Implications**
## Implementation of Modern Axiom Systems
### Axioms, Conjectures, Theorems and Proofs
Most common math curriculums prioritize the introduction of theorems, but not many take the time to properly prove each of them. A mathematical proof is a logical argument for the validity of a particular statement. A statement without proof is called a conjecture. A statement that has been proved is a theorem.
Such mathematical system of proofs build upon each other. A proof might require another theorem, which might require another theorem for its proof. When we continue this trace of proofs and theorems, we reach a point in which a statement is so obviously true that it needs no proof. This is the informally defined axiom.
An example of an axiom may be `a + b == b + a`, or `Not[True] == False`. Despite the simplicity of these statements, without a consistent set of enough axioms, it is impossible to build up a viable system of mathematics.
A more complete definition, as well as the history of the investigation of proofs, can be found in the following Wikipedia article:
[Wikipedia - Proof Theory](https://en.wikipedia.org/wiki/Proof_theory)
### The FindEquationalProof Function
This newly-implemented function, though rather lacking in practicality, is conceptually an interesting product, as it introduces a method of computationally generating human-readable (but possibly lengthy) proofs. It is also interesting in that a system of axioms can be specified, rather than implied, which allows for the possibility of limiting the range of axioms a proof can use, or providing a completely new system of axioms, separate from that of our mathematics.
The function, in essence, generates such proofs by simple substitution—it replaces a part of an expression by the rules of the axiom, or lemmas (also generated via the same method). The following diagram excerpted from Wolfram's book visualizes the algorithm:
![nks-extract][1]
[1]
Axioms listed in the bottom left are used in the proofs of theorems. The validity of a particular statement is therefore proved by investigating if a certain set of substitutions to one expression can be transformed into another.
This process is equivalent to the proofs of conjectures of mathematics. Every proof is merely a series of substitution of parts of statements with axioms (or lemmas derived from axioms). Given enough computational power, and more importantly, a required set of consistent axioms, a theorem can be proved.
### Providing definitions and axioms
The only statements the FindEquationalProof function can understand, according to the documentation, are:
- lhs==rhs — equational logic
- ForAll[vars,lhs==rhs] — universal quantifiers over equational logic identities
Implementing even the simplest axioms were, therefore, a notoriously time-consuming task.
```
definitions = {
ForAll[{a, b}, ex[a, b] == not[ForAll[{a}, not[b]]]],
ForAll[{a, b}, im[a, b] == or[not[a], b]],
ForAll[{a}, ueq[a, a] == not[eq[a, a]]],
ForAll[{a, b}, eqv[a, b] == and[im[a, b], im[b, a]]],
ForAll[{a, b}, nand[a, b] == not[and[a, b]]],
ForAll[{a, b}, xor[a, b] == and[or[a, not[b]], or[not[a], b]]],
ForAll[{a, b}, or[or[a, b], not[b]] == "T"],
not["T"] == "F",
ForAll[{a}, eq[a, a] == "T"],
ForAll[{a, b}, im[a, b] == or[not[a], b]]
};
```
```
booleanLogic = {
ForAll[{a, b}, and[a, b] == and[b, a]],
ForAll[{a, b}, or[a, b] == or[b, a]],
ForAll[{a, b}, and[a, or[b, not[b]]] == a],
ForAll[{a, b}, or[a, and[b, not[b]]] == a],
ForAll[{a, b, c}, and[a, or[b, c]] == or[and[a, b], and[a, c]]],
ForAll[{a, b}, or[a, and[b, c]] == and[or[a, b], or[a, c]]]
};
```
Simple Boolean algebra axioms are specified, providing the system to compute `And`, `Or`, and `Not` operations. Definitions not provided, like `Exists`, `Implies`, !=, or <-> must be defined using only these logical operators. Notable implementations include:
```
ForAll[{a,b},ex[a,b]==b]] (*Definition of Existance*)
ForAll[{a, b}, im[a, b] == or[not[a],b] (*Definition of Implication*)
ForAll[{a, b}, or[ or[a,b], not[b] ] == "T"] (*Definition of Truth*)
ForAll[{a, b}, eq[a, b] == "T"] (*Functional Definition of Equality*)
```
More complicated operations such as NAND or XOR are defined as combinations of these operations.
Using these definitions and axioms, we can prove simple logical theorems, such as De Morgan's law, or the Modus Ponens. The output Proof Graphs show the Axioms in Green, and Lemmas in Red and Orange, revealing the order and steps of the proof:
```
modusP = ForAll[{p, q}, im[and[im[p, q], p], q] == "T"];
deMorgan = ForAll[{a, b}, not[and[a, b]] == or[not[a], not[b]]];
axioms = Join[definitions, booleanLogic];
FindEquationalProof[modusP, axioms]["ProofGraph"]
FindEquationalProof[deMorgan, axioms]["ProofGraph"]
```
![modusP][2]
![demorgan][3]
Note the fact that even such simple proofs can take over 200 steps to prove from the systems of axioms. More complicated expressions, such as the Wolfram Axiom, can be shown to follow from these axioms:
```
wolframLogic =
ForAll[{a, b, c},
nand[nand[nand[a, b], c], nand[a, nand[nand[a, c], a]]] == c];
FindEquationalProof[wolframLogic, axioms]["ProofGraph"]
```
![wolframLogic][4]
Another notable fact is that despite the length of the Wolfram Axiom compared to De Morgan's law, it takes a similar number of steps to reach the proof. A possible justification may be related to the Principle of Computational Equivalence.
### Implementing Arithmetic
The first attempted implementation of arithmetic was using a modified version of Peano's axioms. His system is simple to implement, but is slightly harder to express. 0 is defined, and all natural numbers are defined using a successor function s[x], which is equivalent to adding 1 to x, e.g. 1==s[0],2==s[s[0]], and so on. Addition is defined as a recursive function of s, and multiplication is defined as a recursive function of addition. Note that the distributive and commutative properties of addition and multiplication is not defined originally in Peano's axioms.
```
arithmetic = {
(*Addition*)
ForAll[{x, y}, add[x, s[y]] == s[add[x, y]]],
ForAll[{x}, add[0, x] == x],
ForAll[{x, y}, add[x, y] == add[y, x]],
ForAll[{x, y, z}, add[x, add[y, z]] == add[add[x, y], z]],
(*Multiplication*)
ForAll[{x, y}, times[x, s[y]] == add[times[x, y], x]],
ForAll[{x}, times[0, x] == 0],
ForAll[{x}, times[x, s[0]] == x],
ForAll[{x, y}, times[x, y] == times[y, x]],
ForAll[{x, y}, times[x, times[y, z]] == times[times[x, y], z]],
ForAll[{x, y, z},
add[times[x, z], times[y, z]] == times[add[x, y], z]]
};
```
With these in hand, many simple algebraic properties can be proved:
1+2x+x*x == (1+x)(1+x)
```
distribution =
ForAll[{x},
add[s[0], add[times[s[s[0]], x], times[x, x]]] ==
times[add[s[0], x], add[s[0], x]]];
FindEquationalProof[distribution, arithmetic]["ProofGraph"]
```
![distribution][5]
We can further extend this system by defining powers.
```
powers = {
ForAll[{x}, pow[x, s[0]] == x],
ForAll[{x}, pow[x, 0] == 1],(*Note: 0^0 is undef*)
ForAll[{x, y}, pow[x, s[y]] == times[pow[x, y], x]],
ForAll[{x, y, z}, pow[pow[x, y], z] == pow[x, times[y, z]]
]};
arithmetic = Join[arithmetic, powers];
```
However, if we introduce negative numbers, the system generates an impossible proof:
```
negatives = {
ForAll[{x}, add[x, neg[x]] == 0],
ForAll[{x}, y, sub[x, y] == add[x, neg[y]]]
};
arithmetic = Join[arithmetic, negatives];
zeroEqualsOne = FindEquationalProof[0 == s[0], arithmetic]
zeroEqualsOne["ProofNotebook"];
(*Remove semicolon and evaluate to view proof notebook*)
```
Inspection of the Proof Notebook reveals that the problem is due to the undefined power of 0^0. As x^0 is defined as 1, but 0^x is defined as 0, the inevitable conclusion is that 0 is equal to 1.
This problem showcases the importance of defining a sturdy set of axioms. Although this problem can be eliminated by the use of the "\[Implies]" operator defined in Boolean logic, it would be more wise to follow the steps of previous mathematicians, rather than to continue building a new set of axioms, as unpredictable inconsistencies and contradictions may occur.
### Real Algebra and Tarski Axioms
To implement real algebra, a more robust set of axioms need to be defined. Tarski's axioms of real arithmetic are what many consider to be the basis of current algebra:
![tarski][6]
[1]
Before we do so, however, axioms from predicate logic, such as implication or equivalence, are also required.
```
predicateLogic = {
im[ForAll[{a}, im[b, c]], im[ForAll[{a}, b], ForAll[{b}, c]]] ==
"T",
im[fq[a, b], im[a, ForAll[{b}, a]]] == "T",
im[fq[b, a], ex[a, eq[a, b]]] == "T"
};
tarskiAxioms = {
ForAll[{x, y, z}, add[x, add[y, z]] == add[add[x, y], z]],
ForAll[{a}, add[a, 0] == a],
ForAll[{a}, add[a, neg[a]] == 0],
ForAll[{a, b}, add[a, b] == add[b, a]],
ForAll[{x, y, z}, times[x, times[y, z]] == times[times[x, y], z]],
ForAll[{x, y, z},
add[times[x, z], times[y, z]] == times[add[x, y], z]],
ForAll[{x, y}, times[x, y] == times[y, x]],
ForAll[{a}, times[a, 1] == a],
ForAll[{a}, im[ueq[a, 0], eq[times[a, rec[a]], 1]] == "T"],
ForAll[{a, b, c}, im[and[gt[a, b], gr[b, c]], gr[a, c]] == "T"],
ForAll[{a, b}, im[gr[a, b], ueq[a, b]] == "T"],
ForAll[{a, b}, or[gr[a, b], a] == or[b, gr[b, a]]],
ForAll[{a, b, c}, im[gr[a, b], gr[add[a, c], add[b, c]]] == "T"],
ForAll[{a, b, c},
im[and[gr[a, b], gr[c, 0]], gr[times[a, c], times[b, c]]] ==
"T"],
gr[1, 0] == "T"
};
axioms = Join[definitions, booleanLogic, predicateLogic,
tarskiAxioms];
```
With these, we can compute with the set of all real numbers. Proving again the distribution law, and investigating the Proof Notebook, reveals the use of reciprocals, negative numbers, and even fractions in the proof.
```
distribution =
ForAll[{a, b, x, y},
times[add[x, y], add[x, b]] ==
add[add[times[x, x], times[b, x]], add[times[x, y], times[b, y]]]];
FindEquationalProof[distribution, axioms]["ProofNotebook"];
(*remove semicolon and evaluate to inspect ProofNotebook*)
```
It is surreal to see that the whole of algebra can be defined in these few axioms. Stephen Wolfram, in his book, remarks on this fact as well, stating after the two-page list of mathematical axioms that "It is from these axiom systems [...] that most of the millions of theorems in the literature of mathematics have ultimately been derived."
## Proof Generation
### Elimination of Axioms
A natural extension of such an investigation would be to computationally determine how many axioms could be eliminated from a particular proof. A grid would be ideal to view such data, therefore a wrapper function was written in order to automate this process.
generateProof accepts a list of theorems and axioms, and returns a 2-D array of its proofObjects. generateGrid accepts a list of theorems and axioms, as well as a few options about its display, and outputs a grid, revealing the number of steps of each proof.
```
generateProof[thms_?ListQ, axms_?ListQ, perTimeConstraint_?IntegerQ] :=
Module[{},
Table[Table[
FindEquationalProof[ForAll[{a, b, c}, thm], axm,
TimeConstraint -> perTimeConstraint], {thm, thms}], {axm, axms}]]
```
```
generateGrid[thms_?ListQ, axms_?ListQ, AxiomLength_?IntegerQ,
TimeConstraint_?IntegerQ, scheme_?StringQ, SimpleLabels_?BooleanQ] :=
Module[{proofs, steps, labels, viewThems, viewSteps, colorRules},
proofs = generateProof[thms, axms, TimeConstraint];
steps =
Table[StringCount[ToString@#["ProofFunction"], ";"] & /@
proofs[[n]], {n, Length[proofs]}];
labels = (Rest@Subsets@Range[AxiomLength]);
viewThems = {"Theorems"}~Join~thms;
viewSteps =
Table[{If[SimpleLabels, labels[[n]], axms[[n]]]}~Join~
steps[[n]], {n, Length[proofs]}];
{Rotate[#, \[Pi]/2, Baseline, {1, 1}] & /@ viewThems}~Join~steps;
colorRules = {None, None}~
Join~{Flatten@
Table[Table[{y, x} ->
ColorData[scheme,
Rescale[steps[[y - 1]][[x - 1]], {0,
Max@Flatten@steps}]], {x, 2, Length[steps[[1]]] + 1}], {y,
2, Length[steps] + 1}]};
Grid[{Rotate[#, \[Pi]/2] & /@ viewThems}~Join~viewSteps,
ItemSize -> {{Automatic, Table[1, Length[steps] - 1]}, {Automatic,
Table[1, Length[axms] - 1]}}, Spacings -> Automatic,
Frame -> All, Alignment -> Left, Background -> colorRules]]
```
For example, a set of randomly-generated axioms proving a set of equally randomly-generated theorems might look like the following grid—the top row are the theorems, and the leftmost column are the axioms. Each square is numbered and colored according to the length of its proof:
![exampleGrid][7]
In the our case, the intent is to investigate how many axioms from Boolean logic we can remove to prove particular theorems. Therefore, we can provide the generateGrid function a list of subsets of the Boolean logic. Each subset still requires definitions for things such as implication or equals, so it is prepended to each list.
```
subsets = Rest@Subsets@booleanLogic;
Short[subsets, 5]
```
`Out:`
$$\left\{\left\{\forall _{\{a,b\}}\text{and}(a,b)=\text{and}(b,a)\right\},\left\{\forall _{\{a,b\}}\text{or}(a,b)=\text{or}(b,a)\right\},\langle\langle 60\rangle\rangle ,\left\{\forall _{\{a,b\}}\text{and}(a,b)=\text{and}(b,a),\forall _{\{a,b\}}\text{or}(a,b)=\text{or}(b,a),\forall _{\{a,b\}}\text{and}(a,\text{or}(b,\text{not}(b)))=a,\forall _{\{a,b\}}\text{or}(a,\text{and}(b,\text{not}(b)))=a,\forall _{\{a,b,c\}}\text{and}(a,\text{or}(b,c))=\text{or}(\text{and}(a,b),\text{and}(a,c)),\forall _{\{a,b,c\}}\text{or}(a,\text{and}(b,c))=\text{and}(\text{or}(a,b),\text{or}(a,c))\right\}\right\}$$
```
subsetAxioms = Join[definitions, #] & /@ (Rest@Subsets@booleanLogic);
Short[subsetAxioms, 6]
```
$$\left\{\left\{\forall _{\{a,b\}}\text{ex}(a,b)=\text{not}(\text{not}(b)),\forall _{\{a,b\}}\text{im}(a,b)=\text{or}(\text{not}(a),b),\forall _a\text{ueq}(a,a)=\text{not}(\text{eq}(a,a)),\forall _{\{a,b\}}\text{eqv}(a,b)=\text{and}(\text{im}(a,b),\text{im}(b,a)),\forall _{\{a,b\}}\text{nand}(a,b)=\text{not}(\text{and}(a,b)),\forall _{\{a,b\}}\text{xor}(a,b)=\text{and}(\text{or}(a,\text{not}(b)),\text{or}(\text{not}(a),b)),\forall _{\{a,b\}}\text{or}(\text{or}(a,b),\text{not}(b))=\text{T},\text{not}(\text{T})=\text{F},\forall _a\text{eq}(a,a)=\text{T},\forall _{\{a,b\}}\text{im}(a,b)=\text{or}(\text{not}(a),b),\forall _{\{a,b\}}\text{and}(a,b)=\text{and}(b,a)\right\},\langle\langle 61\rangle\rangle ,\left\{\forall _{\{a,b\}}\text{ex}(a,b)=\text{not}(\text{not}(b)),\langle\langle 14\rangle\rangle ,\forall _{\{a,b,c\}}\text{or}(a,\text{and}(b,c))=\text{and}(\text{or}(a,b),\text{or}(a,c))\right\}\right\}$$
After such formatting, the list subsetAxioms contains every combination of axioms, each with the list of definitions. As displaying such long expressions on the grid is infeasible, we can number each axiom of Boolean logic, and only show its index on the grid. In the following example we investigate the provability and the number of steps required for proving De Morgan's theorem, using subsets of Boolean logic. The output grid is edited for easy viewing.
```
booleanLogic = {
(*1*) ForAll[{a, b}, and[a, b] == and[b, a]],
(*2*) ForAll[{a, b}, or[a, b] == or[b, a]],
(*3*) ForAll[{a, b}, and[a, or[b, not[b]]] == a],
(*4*) ForAll[{a, b}, or[a, and[b, not[b]]] == a],
(*5*) ForAll[{a, b, c}, and[a, or[b, c]] == or[and[a, b], and[a, c]]],
(*6*) ForAll[{a, b}, or[a, and[b, c]] == and[or[a, b], or[a, c]]]
};
generateGrid[{deMorgan}, subsetAxioms, 6, 10, "Rainbow", True]
```
![gridA][8]
### Generation of Random Boolean Expressions and Proofs
In order to see what proofs are required for particular theorems, we need to be able generate these theorems repetitively. The first function, replacer, translates the Wolfram Language's native Heads (e.g. Or, And, Nand, True), with ones defined within the axiom set (e.g. or, and, nand, "T"). The second function, randomBoolExp, generates a single logical statement in the axiom set's language.
```
replacer[expr_, reverse_?BooleanQ] :=
Module[{dictionary, reverseDictionary},
dictionary = {"and" -> "And", "or" -> "Or", "not" -> "Not",
"ex" -> "Exists", "im" -> "Implies", "ueq" -> "Unequal",
"eq" -> "Equal", "eqv" -> "Equivalent", "nand" -> "Nand",
"T" -> "True", "F" -> "False", "x" -> "X", "add" -> "Plus",
"times" -> "Times"};
Needs["GeneralUtilities`"];
reverseDictionary =
Association[dictionary] // AssociationInvert // Normal;
ToExpression@
StringReplace[ToString@expr,
If[reverse, reverseDictionary, dictionary]]]
```
```
randomBoolExp[numb_?IntegerQ, form_?StringQ] :=
Module[{tripleDictionary, replBoolExp, shortBoolExp},
tripleDictionary = {or[x_, y_, z_] -> or[x, or[y, z]],
and[x_, y_, z_] -> and[x, and[y, z]],
nand[x_, y_, z_] -> not[and[x, and[y, z]]],
xor[x_, y_, z_] -> and[and[a, b, c], not[and[a, b, c]]]};
replBoolExp =
replacer[
FullForm@(randBoolExp =
BooleanFunction[RandomInteger[1, 2^numb],
ToExpression /@ Alphabet[][[;; numb]]]), True] //.
tripleDictionary;
shortBoolExp =
replacer[FullForm@BooleanMinimize[randBoolExp, form], True] //.
tripleDictionary;
replBoolExp == shortBoolExp]
```
```
randomBoolExp[3, "NAND"](*Repeatedly evaluate for different output*)
```
`Out:`
```
or[and[a,and[not[b],c]],and[not[a],and[not[b],not[c]]]]==nand[not[and[a,and[not[b],c]]],not[and[not[a],and[not[b],not[c]]]]]
```
The function generates the expression via a random integer generator which is used as a truth table for the built-in BooleanFunction function. Each variable in the expression is an alphabet, and the number of variables are adjusted with the variable numb, which defaults to {a,b,c}. The expression is then simplified using a specific form, e.g. "NAND", "ANF", etc., and equated with the original equation. Finally, the expression is translated into the axiom's language set.
```
expressions = {ForAll[{a, b, c},
or[and[not[a], not[b]], or[and[not[a], c], and[not[b], not[c]]]] ==
or[and[not[a], c], and[not[b], not[c]]]],
ForAll[{a, b, c},
or[and[a, not[b]], or[and[not[a], b], and[b, not[c]]]] ==
or[and[a, not[b]], or[and[a, not[c]], and[not[a], b]]]],
ForAll[{a, b, c},
or[and[a, b], or[and[not[a], not[b]], and[b, c]]] ==
or[and[a, b], or[and[not[a], not[b]], and[not[a], c]]]],
ForAll[{a, b, c},
or[and[not[a], not[b]], or[and[b, c], and[not[b], not[c]]]] ==
or[and[not[a], c], or[and[b, c], and[not[b], not[c]]]]]
};
expressions = {ForAll[{a, b, c},
or[and[not[a], not[b]], or[and[not[a], c], and[not[b], not[c]]]] ==
or[and[not[a], c], and[not[b], not[c]]]],
ForAll[{a, b, c},
or[and[a, not[b]], or[and[not[a], b], and[b, not[c]]]] ==
or[and[a, not[b]], or[and[a, not[c]], and[not[a], b]]]],
ForAll[{a, b, c},
or[and[a, b], or[and[not[a], not[b]], and[b, c]]] ==
or[and[a, b], or[and[not[a], not[b]], and[not[a], c]]]],
ForAll[{a, b, c},
or[and[not[a], not[b]], or[and[b, c], and[not[b], not[c]]]] ==
or[and[not[a], c], or[and[b, c], and[not[b], not[c]]]]]
};
defAxioms = Join[definitions, #] & /@ (Rest@Subsets@booleanLogic);
grid = generateGrid[expressions, defAxioms, 6, 20, "Rainbow", True]
```
![gridB][9]
The empty columns for the 7th theorem is believed to be an issue of computing; limited computed power necessitated the time constraint of 20 seconds per proof.
An interesting fact to denote is that most of the generated expressions were provable without the full set of axioms. One would normally expect only a complete axiom system to be able to prove or falsify a statement. Despite the simplicity of these theorems compared to the complex mathematical problems researched in the real world, we can see that it is very plausible to generate proofs without a complete axiom system. It is actually the case that there can be no complete set of axioms, as an arbitrary number of axioms with arbitrary operators can be generated (as explored in the following section). It would also be possible to draw a relation with Gödel's Incompleteness theorem, which suggests that no consistent, complete set of axioms exist that can prove all possible truths describable within the system. A civilization which only considers the {1,2,3,5,6} without the 4th axiom, might be able to express the 3rd theorem, but would not be able to prove it without expanding its axiom system.
## Alternative Axiom Systems
### A new operator
Our common sense tells us that our system of axioms, i.e., logic, is the only possible system of axioms that exists. However, this is not necessarily the case. An expression can be created with an arbitrary operator, and those expressions can be tried as axioms or theorems, despite not being representable with our system.
Let us imagine a new operator, "$\cdot$", the CenterDot. We can then introduce variables, a and b, to build up expressions like the following:
$$((b\cdot (a\cdot a))\cdot a)\cdot b=a$$
This is impossible to make sense of within our system of logic, but still is a valid expression that describes an equation. Whether it is understandable or not is an unrequited issue; a more interesting question would be if these systems are viable, which we will explore by using them to prove other theorems.
The following list defines some of these arbitrary equalities that constitute as valid expressions:
$$\text{imaginaryAxioms}=\{\\a=a,b=a,a\cdot a=a,a\cdot b=a,\\b\cdot a=a,b\cdot b=a,a\cdot b=b\cdot a,a\cdot (a\cdot a)=a,\\(a\cdot a)\cdot a=a,a\cdot (a\cdot b)=a,a\cdot (b\cdot b)=a,b\cdot (a\cdot a)=a,\\b\cdot (a\cdot b)=a,b\cdot (b\cdot a)=a,(a\cdot a)\cdot b=a,(a\cdot b)\cdot a=a,\\(a\cdot b)\cdot b=a,(b\cdot a)\cdot a=a,(b\cdot a)\cdot b=a,(b\cdot b)\cdot a=a,\\b\cdot (b\cdot b)=a,(b\cdot b)\cdot b=a,(a\cdot a)\cdot (a\cdot a)=a,a\cdot ((a\cdot a)\cdot b)=a,\\(a\cdot a)\cdot (a\cdot b)=a,(a\cdot b)\cdot (b\cdot c)=a,(a\cdot b)\cdot c=a\cdot (b\cdot c),((b\cdot b)\cdot a)\cdot (a\cdot b)=a,\\((b\cdot (a\cdot a))\cdot a)\cdot b=a,b\cdot (c\cdot (a\cdot (b\cdot c)))=a,(a\cdot b)\cdot (a\cdot (b\cdot c))=a,(((b\cdot a)\cdot c)\cdot a)\cdot (a\cdot c)=a,(((b\cdot c)\cdot d)\cdot a)\cdot (a\cdot d)=a,\\\{(a\cdot b)\cdot a=a,a\cdot a=b\cdot b\},\{(a\cdot a)\cdot (a\cdot a)=a,a\cdot b=b\cdot a\},\\(b\cdot (b\cdot (a\cdot a)))\cdot (a\cdot (b\cdot c))=a\};$$
Similarly, as we did in the previous section with Boolean algebra, we can generate theorems to evaluate what these axioms can prove. The task is done with the following function randThms, and its related functions:
[2]
```
canonicalize[list_] :=
DeleteDuplicates[
DeleteDuplicates[Sort /@ list, #1 === (#2 /. {1 -> 0, 0 -> 1}) &]]
canonicalize[list_, vars_] :=
DeleteDuplicates[
DeleteDuplicates[Sort /@ list,
Function[{x, y},
MatchQ[x,
Alternatives @@ ((y /. (Rule @@@
Partition[Append[#, First[#]], 2, 1])) & /@
Permutations[vars])]]]]
revariable[expr_] := (expr /. {0 -> a, 1 -> b, 2 -> c})
```
```
randThms[length_?IntegerQ] :=
Module[{thms, axms, newthms, newaxms, ns},
thms = Cases[
Apply[Equal, #] & /@
Flatten[Groupings[#, CenterDot -> 2] & /@
Table[Rest[IntegerDigits[ns, 2]], {ns, length}]], _Equal];
newthms =
Select[revariable[canonicalize[thms]],
TautologyQ[Equivalent @@ (# /. CenterDot -> Nand)] &]
]
```
For example,
```
randThms[50] // Column
```
`Out:`
$$\begin{array}{l}
a\cdot b=b\cdot a \\
a=(a\cdot a)\cdot (a\cdot a) \\
a=(a\cdot a)\cdot (a\cdot b) \\
a=(a\cdot a)\cdot (b\cdot a) \\
a=(a\cdot b)\cdot (a\cdot a) \\
a=(b\cdot a)\cdot (a\cdot a) \\
\end{array}$$
### Arbitrary Proofs
Using the above mentioned proofGrid function, we can visualize which axioms yield which theorems. As in the previous run, the axioms and theorems are numbered for visual clarity. Again, despite the fact that it is always impossible to determine if a certain theorem holds, the simplicity of the ones used allow for an acceptable level of confidence.
$$\text{imaginaryTheorems}=\{a\cdot b=b\cdot a,a=(a\cdot a)\cdot (a\cdot a),a=(a\cdot a)\cdot (a\cdot b),a=(a\cdot a)\cdot (b\cdot a),a=(a\cdot b)\cdot (a\cdot a),a=(b\cdot a)\cdot (a\cdot a),a=((a\cdot a)\cdot a)\cdot (a\cdot a),a=(a\cdot a)\cdot ((a\cdot a)\cdot a),a=(a\cdot (a\cdot a))\cdot (a\cdot a),a=(a\cdot a)\cdot (a\cdot (a\cdot a)),a\cdot a=((a\cdot a)\cdot a)\cdot a,a\cdot a=a\cdot ((a\cdot a)\cdot a),a\cdot a=(a\cdot (a\cdot a))\cdot a,a\cdot a=a\cdot (a\cdot (a\cdot a)),a\cdot (a\cdot a)=(a\cdot a)\cdot a,a=(a\cdot a)\cdot (a\cdot (a\cdot b)),a\cdot a=a\cdot ((a\cdot a)\cdot b),a=(a\cdot a)\cdot ((a\cdot b)\cdot a),a=(a\cdot a)\cdot (a\cdot (b\cdot a)),a\cdot a=((a\cdot a)\cdot b)\cdot a,a=(a\cdot a)\cdot (a\cdot (b\cdot b)),a\cdot a=a\cdot ((a\cdot b)\cdot b),a=(a\cdot a)\cdot ((b\cdot a)\cdot a),a=(a\cdot (a\cdot b))\cdot (a\cdot a),a\cdot a=a\cdot (b\cdot (a\cdot a)),a=(a\cdot (a\cdot b))\cdot (a\cdot b),a\cdot a=a\cdot ((b\cdot a)\cdot b),a\cdot b=a\cdot (a\cdot (a\cdot b)),a\cdot a=a\cdot (b\cdot (a\cdot b)),a=(a\cdot a)\cdot ((b\cdot b)\cdot a),a=(a\cdot (a\cdot b))\cdot (b\cdot a),a\cdot a=((a\cdot b)\cdot b)\cdot a,a\cdot (a\cdot (a\cdot b))=b\cdot a,a\cdot a=a\cdot (b\cdot (b\cdot a)),b=((a\cdot a)\cdot a)\cdot (b\cdot b),a=(a\cdot a)\cdot ((b\cdot b)\cdot b),b=(a\cdot (a\cdot a))\cdot (b\cdot b),a=(a\cdot a)\cdot (b\cdot (b\cdot b)),b\cdot b=((a\cdot a)\cdot a)\cdot b,a\cdot a=a\cdot ((b\cdot b)\cdot b),b\cdot b=(a\cdot (a\cdot a))\cdot b,a\cdot a=a\cdot (b\cdot (b\cdot b)),(a\cdot a)\cdot a=(b\cdot b)\cdot b,b\cdot (b\cdot b)=(a\cdot a)\cdot a,a\cdot (a\cdot a)=b\cdot (b\cdot b),a=((a\cdot b)\cdot a)\cdot (a\cdot a),a=(a\cdot (b\cdot a))\cdot (a\cdot a),a\cdot a=(b\cdot (a\cdot a))\cdot a,a=((a\cdot b)\cdot a)\cdot (a\cdot b),a=(a\cdot (b\cdot a))\cdot (a\cdot b),a=(a\cdot b)\cdot (a\cdot (a\cdot b)),a\cdot b=a\cdot ((a\cdot b)\cdot a),a\cdot b=(a\cdot (a\cdot b))\cdot a,a\cdot b=a\cdot (a\cdot (b\cdot a)),a=((a\cdot b)\cdot a)\cdot (b\cdot a),a=(a\cdot b)\cdot ((a\cdot b)\cdot a),a=(a\cdot (b\cdot a))\cdot (b\cdot a),a=(a\cdot b)\cdot (a\cdot (b\cdot a)),a\cdot a=((b\cdot a)\cdot b)\cdot a,a\cdot ((a\cdot b)\cdot a)=b\cdot a,b\cdot a=(a\cdot (a\cdot b))\cdot a,a\cdot a=(b\cdot (a\cdot b))\cdot a,a\cdot (a\cdot (b\cdot a))=b\cdot a,a\cdot (a\cdot b)=(a\cdot b)\cdot a,a\cdot (a\cdot b)=a\cdot (b\cdot a),b=((a\cdot a)\cdot b)\cdot (a\cdot b),a=(a\cdot b)\cdot (a\cdot (b\cdot b)),(a\cdot a)\cdot b=(a\cdot b)\cdot b,a\cdot (a\cdot b)=a\cdot (b\cdot b),a=(a\cdot b)\cdot ((b\cdot a)\cdot a),a=(a\cdot (b\cdot b))\cdot (a\cdot a),a\cdot a=(b\cdot (b\cdot a))\cdot a,b\cdot (a\cdot a)=(a\cdot a)\cdot b,a\cdot (a\cdot b)=(b\cdot a)\cdot a,b=((a\cdot a)\cdot b)\cdot (b\cdot a),a=(a\cdot (b\cdot b))\cdot (a\cdot b),a\cdot b=((a\cdot a)\cdot b)\cdot b,a\cdot b=a\cdot (a\cdot (b\cdot b)),(a\cdot a)\cdot b=(b\cdot a)\cdot b,b\cdot (a\cdot b)=(a\cdot a)\cdot b,a=(a\cdot b)\cdot ((b\cdot b)\cdot a),a=(a\cdot (b\cdot b))\cdot (b\cdot a),b\cdot a=((a\cdot a)\cdot b)\cdot b,a\cdot (a\cdot (b\cdot b))=b\cdot a,b\cdot (b\cdot a)=(a\cdot a)\cdot b,b=((a\cdot a)\cdot b)\cdot (b\cdot b),a=((b\cdot a)\cdot a)\cdot (a\cdot a),a=((b\cdot a)\cdot a)\cdot (a\cdot b),a=(b\cdot a)\cdot (a\cdot (a\cdot b)),a\cdot b=((a\cdot b)\cdot a)\cdot a,a\cdot b=a\cdot ((b\cdot a)\cdot a),a\cdot b=(a\cdot (b\cdot a))\cdot a,a=((b\cdot a)\cdot a)\cdot (b\cdot a),a=(b\cdot a)\cdot ((a\cdot b)\cdot a),a=(b\cdot a)\cdot (a\cdot (b\cdot a)),b\cdot a=((a\cdot b)\cdot a)\cdot a,a\cdot ((b\cdot a)\cdot a)=b\cdot a,b\cdot a=(a\cdot (b\cdot a))\cdot a,a\cdot (b\cdot a)=(a\cdot b)\cdot a,b=(a\cdot b)\cdot ((a\cdot a)\cdot b),a=(b\cdot a)\cdot (a\cdot (b\cdot b)),a\cdot (b\cdot b)=(a\cdot b)\cdot a,a\cdot (b\cdot a)=a\cdot (b\cdot b),a=(b\cdot a)\cdot ((b\cdot a)\cdot a),(a\cdot b)\cdot a=(b\cdot a)\cdot a,a\cdot (b\cdot a)=(b\cdot a)\cdot a,a\cdot b=a\cdot ((b\cdot b)\cdot a),a\cdot b=(a\cdot (b\cdot b))\cdot a,(a\cdot b)\cdot a=(b\cdot b)\cdot a,a\cdot b=((a\cdot b)\cdot b)\cdot b,a\cdot b=((b\cdot a)\cdot a)\cdot a,a\cdot b=b\cdot ((a\cdot a)\cdot b),a\cdot b=(b\cdot (a\cdot a))\cdot b,a\cdot ((b\cdot b)\cdot a)=b\cdot a,a\cdot b=b\cdot ((a\cdot b)\cdot b),a\cdot b=b\cdot (b\cdot (a\cdot a)),b\cdot (a\cdot a)=(a\cdot b)\cdot b,a\cdot b=b\cdot ((b\cdot a)\cdot b),a\cdot b=b\cdot (b\cdot (a\cdot b)),(a\cdot b)\cdot b=(b\cdot a)\cdot b,a\cdot b=b\cdot (b\cdot (b\cdot a))\};$$
```
generateGrid[imaginaryTheorems, imaginaryAxioms, 6, 20, "Rainbow", \
True]
```
![gridD][10]
Note that axiom number 27, $(a\cdot b)\cdot c=a\cdot (b\cdot c)$, is a part of our axiom system (group theory). The significant factor here is that this axiom does not particularly stand out; the implication being that there is nothing special about our choice of the axiom system. Theoretically, if another axiom was chosen, and such a system was universal, it would not particularly be interesting or different. Rather, it would be plausible. The concept of computational universality implies these alternative systems are translatable to our system, but may possibly hold keys to solving problems that can be expressed, but cannot be solved with our current set of axioms.
## Implications
This project was neither a mathematically sound, nor a practical exploration. Rather, the results simply point to some simple, but fundamental implications about how our mathematics is conducted. Axioms are the foundations of math, and to an arguable extent, of our universe. Therefore, the exploration of the significance, or rather the insignificance of our choice of theorems, is an important step in augmenting our view of mathematics—not just a manipulation based on a certain system of logic, but the system of implication with a specific set of simple rules, that may differ from what we would expect.
### Footnote
[1] Wolfram, Stephen. A New Kind of Science. 2018.
[2] Partially developed with code written by Jonathan Gorard, Wolfram Research
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1-2-1.nks_multiway_diagram.png&userId=1371718
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1-3-1.modusP.png&userId=1371718
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1-3-2.deMorgan.png&userId=1371718
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1-3-3.wolframLogic.png&userId=1371718
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1-4-4.distribution.png&userId=1371718
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1-5-1.tarskiAxioms.png&userId=1371718
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2-1-1.exampleGrid.png&userId=1371718
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=grid4.png&userId=1371718
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=grid1.png&userId=1371718
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=grid3.png&userId=1371718Pyokyeong Son2018-07-13T15:06:33Z[WSC18] Analyzing and visualizing chord sequences in music
http://community.wolfram.com/groups/-/m/t/1383630
During this year's Wolfram Summer Camp, being mentored by Christian Pasquel, I developed a tool that identifies chord sequences in music (from MIDI files) and generates a corresponding graph. The graph represents all [unique] chords as vertices, and connects every pair of chronologically subsequent chords with a directed edge. Here is an example of a graph I generated:
![Graph genehrated from Bach's prelude no.1 of the Well Tempered Klavier (Book I)][1]
Below is a detailed account on the development and current state of the project, plus some background on the corresponding musical theory notions.
#Introduction
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;**GOAL** | The aim of this project is to develop a utility that identifies chords (e.g. C Major, A minor, G7, etc.) from MIDI files, in chronological order, and then generates a graph for visualizing that chord sequence. In the graph, each vertex would represent a unique chord, and each pair chronologically adjacent chords would be connected by a directed edge (i.e. an arrow). So, for example, if at some point in the music that is being analyzed there is a transition from a major G chord to a major C chord, there would be an arrow that goes from the G Major chord to the C Major chord. Therefore, the graph would describe a [Markov chain][2] for the chords. The purpose of the graph is to visualize frequent chord sequences and progressions within a certain piece of music.
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;**MOTIVATION** | While brainstorming for project ideas, I don't know why, I had a desire to do something with graphs. Then I asked myself, "What are graphs good at modelling?". I mentally browsed through my areas of interest, searching for any that matched that requirement. One of my main interests is music; I am somewhat of a musician myself. And, in fact, [musical] harmony *is* a good subject to be modelled by graphs. Harmony, one of the fundamental pillars of music (and perhaps the most important), not only involves the chords themselves, but, more significantly, the *transitions* between those, which is what gives character to music. And directed graphs, and, specifically, Markov models, are a perfect match for transitions between states.
----------
#Some background
*Skip this if you aren't interested in the musical theory part or if you already have a background in music theory!*
##What is a chord?
A chord is basically a group of notes played together (contemporarily). Chords are the quanta of musical "feeling"; the typical—but somewhat naïve—example is the sensation of major chords sounding "happy" and minor chords sounding "sad" or melancholic (more on types of chords later).
Types of chords are defined by the [intervals][3] (distance in pitch) between the notes. The *root* of a chord is the "most important" or fundamental note of the cord, in the sense that it is the "base" from which the aforementioned intervals are measured. In other words, the archetype of chord defines the "feel" and the general harmonic properties of the chord, while the root defines the pitch of the chord. So a "C Major" chord is a chord with archetype "major triad" (more on that later) built on the note C; i.e., its root is C.
The *sequence* of chords in a piece constitutes its **harmony**, and it can convey much more complex musical messages or feelings than a single chord, just as in language: a single word does have meaning, but a sentence can have a much more complex meaning than any single word.
##Patterns in chord sequences
The main difference that between language and music is that language, in general, has a much stricter structure (i.e. the order of words, a.k.a. syntax) than music: the latter is an art, and there are no predetermined rules to follow. But humans \[have a tendency to\] like patterns, and music wouldn't be so universally beloved if it didn't contain any patterns. This also explains the unpopularity of [atonal music][4] (example [here][5]). But even atonal music has patterns: it may do its best to avoid harmonic patterns, but it still contains some level of rythmic, textural or other kinds of patterns.
This is why using graphs to visualize chord sequences is interesting: it is a semidirect way of identifying the harmonic patterns that distinguish different genres, styles, forms, pieces or even fragments of music. In my project, I have mainly focused on the "western" conception of tonal music, an particularly in its "classical" version (what I mean by "classical" is, in lack of a better definition, a classification that encompasses all music where the composer is, culturally, the most important artist). That doesn't mean this tool isn't apt for other types of music; it just means it will analyze it from this specific standpoint.
In tonal music, the harmonic patterns are all related to a certain notion of "center of gravity": the [*tonic*][6], which is, in some way the music's harmonic "home". Classical (as in pre-XX-century) tonal music usually ends (and often starts) with the tonic chord. In fact, we can further extend the analogy with gravity by saying that music consists in a game of tension, in which the closer you are to the center of gravity (the tonic), the greater the "pull". In an oversimplified manner, the musical equivalent of the [Schwarzschild radius][7] is the [dominant chord][8]: it tends towards the tonic. Well, not really, because you *can* turn back from it—and in fact a lot of interesting harmonical sequences consist in doing just that.
##Some types of chords
In "classical" music (see definition above), there are mainly these kinds of chords (based on the amount of unique notes they contain): triad chords (i.e. three-note chords), seventh chords (i.e. four-note chords; we'll see why they're called *seventh* in a bit), and ninth chords (five-note chords). There is another main distinction: major and minor chords (i.e. the cliché "happy" vs "sad" distinction).
###Triad chords
Probably the most simple and frequent chord is the triad chord (either major or minor). Here is a picture of a major and a minor triad C chord (left to right):
![Major and minor triad C chords (ltr)][9]
###Seventh chords
[Seventh chords][10] are called so because they contain a seventh [interval][11]. Their main significance is in dominant chords, where they usually appear in the major-triad-minor-seventh (a.k.a ["dominant"][12]) form. Another important seventh chord form is the fully diminished seventh chord (these will be relevant for the code later), which also tends to resolve ("resolve" is music jargon for "transition to a chord with less tension") to tonic.
![Seventh chords][13]
###Ninth chords
Although not extremely frequent, they do appear in classical music. The most "popular" is the dominant ninth chord (an extension of the dominant 7th). An alternative for this chord is the minor ninth dominant chord (built from the same dominant 7th chord, but with a minor ninth instead).
<br>
----------
#Algorithms and Code
In this section I'm going to walk through my code in order of execution. Four main parts can be distinguished in my project: importing and preprocessing, splitting the note sequence into "chunks" to be analyzed as chords, identifying the chord in each of those chunks, and visualizing the whole sequence as a graph.
##First phase: importing and preprocessing the MIDI file
The first operation that needs to be done is importing the MIDI file and preprocessing it. This includes selecting which elements to import from the file, converting them to a given simplified form, and performing any sorting, deletion of superfluous elements, or other modification that needs to be done.
For this purpose I defined the function `importMIDI`:
importMIDI[filename_String] := MapAt[Flatten[#, 1] &, MapAt[flattenAndSortSoundNotes,
Import[(dir <> filename <> ".mid"), {{"SoundNotes", "Metadata"}}],
1], 2]
Here `dir` stands for the directory where I saved all my MIDIs (to avoid having to type in the whole directory every time). Notice that we're importing the music as SoundNotes *and* the file's metadata—we will need it for determining the boundaries of measures (see below). The function `flattenAndSortNotes` does what it sound like: it converts the list of `SoundNote`s that `Import` returned into a flattened list of notes (i.e. a single track), sorted by their starting time. It also gets rid of anything that isn't necessary for chord identification (i.e. rhythmic sounds or effects). Consult the attached notebook for the explicit definition.
Here is the format the sequence of notes is returned in (i.e. `importMIDI[...][[1]]`):
{{"C4", {0., 1.4625}}, {"E4", {0.18125, 1.4625}}, {"G4", {0.36875, 0.525}}, <<562>>, {"G2", {105., 107.963}}, {"G4", {105., 107.963}}}
Each sub-list represents a note. Its first element is the actual pitch; the second is a list that represents the timespan (i.e. start and end time in seconds).
<br>
##Second phase: splitting the note sequence into chunks
The challenge in this part of the project is knowing how to determine which notes form a single chord; i.e., where to put the boundary between one chord and the next.
The solution I came up with is not optimal, but, until now, nothing better has occurred to me (suggestions are welcome!). It involves determining where each measure start/end lies in time from the metadata and splitting each of those into a certain amount of sub-parts; then the notes are grouped by the specific sub-part of the specific measure they pertain to. The rationale behind this is that chords in classical music tend to be well-contained within measures or rational fractions of these.
This procedure is contained in the function `chordSequenceAnalyzeUsingMeasures`. I'm going to go over it quickly:
chordSequenceUsingMeasures[midiData_List /; Length@midiData == 2,
measureSplit_: 2, analyzer_String: "Heuristic"] :=
Block[{noteSequence, metadata, chunkKeyframes, chunkedSequence,
result},
(*Separate notes from metadata*)
noteSequence = midiData[[1]];
metadata = midiData[[2]];
Until here it's pretty self evident.
(*Get measure keyframes*)
chunkKeyframes =
divideByN[
measureKeyframesFromMetadata[
metadata, (Last@noteSequence)[[2, 2]]], measureSplit];
Here the function `measureKeyframesFromMetadata` is called. It fetches all of the `TimeSignature` and `SetTempo` tags in the metadata and identifies the position of each measure from them. `divideByN` subdivides each measure by `measureSplit` (an optional argument with default value `2`).
(*Chunk sequence*)
chunkedSequence = {};
Module[{i = 1},
Do[
With[{k0 = chunkKeyframes[[j]], k1 = chunkKeyframes[[j + 1]]},
Module[{chunk = {}},
While[
i <= Length@noteSequence && (
k0 <= noteSequence[[i, 2, 1]] < k1 ||
k0 < noteSequence[[i, 2, 2]] <= k1 ),
AppendTo[chunk, noteSequence[[i]]] i++;];
AppendTo[chunkedSequence, chunk]
]
],
{j, Length@chunkKeyframes - 1}]];
chunkedSequence =
DeleteCases[chunkedSequence, l_List /; Length@l == 0];
Once the measures' timespan has been determined, a list of "chunks" (lists of notes grouped by measure part) is generated.
(*Call analyzer*)
Switch[analyzer,
"Deterministic", result = chordChunkAnalyze /@ chunkedSequence,
"Heuristic",
result = heuristicChordAnalyze /@ justPitch /@ chunkedSequence
];
result = resolveDiminished7th[Split[result][[All, 1]]]
]
Finally, each chunk is sent to the chord analyzer function `heuristicChordAnalyze`, which I'll talk about in the next section, along with the currently mysterious `resolveDiminished7th`.
Since this algorithm for "chunking" a note sequence doesn't work for everything, I also developed an alternative, more naïve approach:
chordSequenceNaïve[midiData_List /; Length@midiData == 2,
analyzer_String: "Heuristic", n1_Integer: 6, n2_Integer: 1] :=
Module[{noteSequence, chunkedSequence, result},
(*Separate notes from metadata*)
noteSequence = midiData[[1]];
(*Chunk sequence*)
chunkedSequence = Partition[noteSequence, n1, n2];
(*Call analyzer*)
result = heuristicChordAnalyze /@ justPitch@chunkedSequence;
result = resolveDiminished7th[Split[result][[All, 1]]]
]
<br>
##Phase 3: identifying the chord from a group of notes
This has been the main conceptual challenge in the whole project. After some unsucsessful ideas, with some suggestions from Rob Morris (one of the mentors), whom I thank, I ended up developing the following algorithm. It iterates through each note and assigns it a score that represents the likeliness of that note being the root of the chord based on the presence of certain indicators (i.e. notes the presence of which define a chord, to some degree), each of which with a different weight: having a fifth, having a third, a minor seventh... Then the note with the highest chord is assumed to be the root of the chord.
In code:
heuristicChordAnalyze[notes_List] :=
Block[{chordNotes, scores, root},
(*Calls to helper functions*)
chordNotes = octaveReduce /@ convertToSemitones /@ notes // DeleteDuplicates;
(*Scoring*)
scores = Table[Total@
Pick[
(*Score points*)
{24, 16, 16, 8, 2, 3, 1, 1,
10, 15, 15, 18},
(*Conditions*)
SubsetQ[chordNotes, #] & /@octaveReduce /@
{{nt + 7}, {nt + 4}, {nt + 3}, {nt + 10}, {nt + 11}, {nt + 2}, {nt + 5}, {nt + 9},
{nt + 4, nt + 10}, {nt + 3, nt + 6, nt + 10}, {nt + 3, nt + 6, nt + 9}, {nt + 1, nt + 4, nt + 10}}
]
(*Substract outliers*)
- 18*Length@Complement[chordNotes, octaveReduce /@ {nt, 7 + nt, 4 + nt, 3 + nt, 10 + nt, 11 + nt,
2 + nt, 5 + nt, 9 + nt, 6 + nt}],
{nt, chordNotes}];
(*Return*)
root = Part[chordNotes, Position[scores, Max @@ scores][[1, 1]]];
{root, Which[
SubsetQ[chordNotes, octaveReduce /@ {root + 10 , root + 2, root + 5, root + 9}], "13",
SubsetQ[chordNotes, octaveReduce /@ {root + 10, root + 2, root + 5}], "11",
SubsetQ[chordNotes, octaveReduce /@ {root + 4, root + 10, root + 2}], "Dom9",
SubsetQ[chordNotes, octaveReduce /@ {root + 4, root + 10, root + 1}], "Dom9m",
SubsetQ[chordNotes, octaveReduce /@ {root + 11, root + 7, root + 3}], "m7M",
SubsetQ[chordNotes, {octaveReduce[root + 11], octaveReduce[root + 4]}], "7M",
SubsetQ[chordNotes, {octaveReduce[root + 10], octaveReduce[root + 4]}], "Dom7",
SubsetQ[chordNotes, {octaveReduce[root + 10], octaveReduce[root + 7]}], "Dom7",
SubsetQ[chordNotes, {octaveReduce[root + 10], octaveReduce[root + 6]}], "d7",
SubsetQ[ chordNotes, {octaveReduce[root + 9], octaveReduce[root + 6]}], "d7d",
SubsetQ[chordNotes, {octaveReduce[root + 10], octaveReduce[root + 3]}], "m7",
MemberQ[chordNotes, octaveReduce[root + 4]], "M",
MemberQ[chordNotes, octaveReduce[root + 3]], "m",
MemberQ[chordNotes, octaveReduce[root + 7]], "5",
True, "undef"]}
]
###A note on notation
In this project I use the following abbreviations for chord notation (they're not in the standard format). "X" represents the root of the chord.
- *X-**5*** = undefined triad chord (just the root and the fifth)
- *X-**M*** = Major
- *X-**m*** = minor
- *X-**m7*** = minor triad with minor (a.k.a dominant) seventh
- *X-**d7d*** = fully diminished 7thchord
- *X-**d7*** = half diminished 7thchord
- *X-**Dom7*** = Dominant 7th chord
- *X-**7M*** = Major triad with Major 7th
- *X-**m7M*** = minor triad with Major 7th
- *X-**Dom9*** = Dominant 9th chord
- *X-**Dom9m*** = Dominant 7th chord with a minor 9th
- *X-**11*** = 11th chord
- *X-**13*** = 13th chord
###Dealing with diminished 7th chords
Now, on to `resolveDiminished7th`. What is this function on about?
Well, recall the fully diminished seventh chords I mentioned in the Background section. Here's the problem: they're completely symmetrical! What I mean by that is that the intervals between subsequent notes are identical, even if you [invert][14] the chord. In other words, the distance in semitones between notes is constant (it's 3) and is a factor of 12 (distance of 12 semitones = octave). So, given one of these chords, there is no way to determine which note is the root just by analyzing the chord itself. In the context of our algorithm, every note would have the same score!
At this point I thought: "How do humans deal with this?". And I concluded that the only way to resolve this issue is to have some contextual vision (looking at the next chord, particularly), which is how humans do it. So what `resolveDiminished7th` does is it brushes through the chord sequence stored in `result`, looking for fully diminished chords (marked with the string "d7d"), and re-assigns each of those a root by looking at the next chord:
resolveDiminished7th[chordSequence_List] :=
Module[{result},
result = Partition[chordSequence, 2, 1] /. {{nt_, "d7d"}, c2_List} :> Which[
MemberQ[octaveReduce /@ {nt, nt + 3, nt + 6, nt + 9}, octaveReduce[c2[[1]] - 1]], {{c2[[1]] - 1, "d7d"}, c2},
MemberQ[octaveReduce /@ {nt, nt + 3, nt + 6, nt + 9}, octaveReduce[c2[[1]] + 4]], {{c2[[1]] + 4, "d7d"}, c2},
MemberQ[octaveReduce /@ {nt, nt + 3, nt + 6, nt + 9}, octaveReduce[c2[[1]] + 6]], {{c2[[1]] + 6, "d7d"}, c2},
True, {{nt, "d7d"}, c2}];
result = Append[result[[All, 1]], Last[result][[2]]]
]
##Phase 4: Visualization
Basically, my visualization function (`visualizeChordSequence`) is fundamentally a highly customized call of the `Graph` function; so I'll just paste the code below and then explain what some parameters do:
visualizeChords[chordSequence_List, layoutSpec_String: "Unspecified", version_String: "Full", mVSize_: "Auto", simplicitySpec_Integer: 0, normalizationSpec_String: "Softmax"] :=
Module[{purgedChordSequence, chordList, transitionRules, weights, graphicalWeights, nOfCases, edgeStyle, vertexLabels, vertexSize, vertexStyle, vertexShapeFunction, clip},
(*Preprocess*)
Switch[version,
"Full",
purgedChordSequence =
StringJoin[toNoteName[#1], "-", #2] & @@@ chordSequence,
"Basic",
purgedChordSequence =
Split[toNoteName /@ chordSequence[[All, 1]]][[All, 1]]];
(*Amount of each chord*)
chordList = DeleteDuplicates[purgedChordSequence];
nOfCases = Table[{c, Count[purgedChordSequence, c]}, {c, chordList}];
(*Transition rules between chords*)
Switch[version,
"Full",
transitionRules =
Gather[Rule @@@ Partition[purgedChordSequence, 2, 1]],
"Basic",
transitionRules =(*DeleteCases[*)
Gather[Rule @@@ Partition[purgedChordSequence, 2, 1]](*, t_/;
Length@t\[LessEqual]2]*) ];
(*Get processed weight for each transition*)
weights = Length /@ transitionRules;
If[normalizationSpec == "Softmax", graphicalWeights = SoftmaxLayer[][weights]];;
graphicalWeights =
If[Min@graphicalWeights != Max@graphicalWeights,
Rescale[graphicalWeights,
MinMax@graphicalWeights, {0.003, 0.04}],
graphicalWeights /. _?NumericQ :> 0.03 ];
(*Final transition list*)
transitionRules = transitionRules[[All, 1]];
(*Graph display specs*)
clip = RankedMax[weights, 4];
edgeStyle =
Table[(transitionRules[[i]]) ->
Directive[Thickness[graphicalWeights[[i]]],
Arrowheads[2.5 graphicalWeights[[i]] + 0.015],
Opacity[Which[
weights[[i]] <= Clip[simplicitySpec - 2, {0, clip - 2}], 0,
weights[[i]] <= Clip[simplicitySpec, {0, clip}], 0.2,
True, 0.6]],
RandomColor[Hue[_, 0.75, 0.7]],
Sequence @@ If[weights[[i]] <= Clip[simplicitySpec - 1, {0, clip - 1}], {
Dotted}, {}] ], {i, Length@transitionRules}];
vertexLabels =
Thread[nOfCases[[All,
1]] -> (Placed[#,
Center] & /@ (Style[#[[1]], Bold,
Rescale[#[[2]], MinMax[nOfCases[[All, 2]]],
Switch[mVSize, "Auto", {6, 20}, _List,
10*mVSize[[1]]/0.3*{1, mVSize[[2]]/mVSize[[1]]}]]] & /@
nOfCases))];
vertexSize =
Thread[nOfCases[[All, 1]] ->
Rescale[nOfCases[[All, 2]], MinMax[nOfCases[[All, 2]]],
Switch[mVSize,
"Auto", (Floor[Length@chordList/10] + 1)*{0.1, 0.3}, _List,
mVSize]]];
vertexStyle =
Thread[nOfCases[[All, 1]] ->
Directive[Hue[0.53, 0.27, 1, 0.6], EdgeForm[Blue]]];
vertexShapeFunction =
Switch[version, "Full", Ellipsoid[#1, {3.5, 1} #3] &, "Basic",
Ellipsoid[#1, {2, 1} #3] &];
Graph[transitionRules,
GraphLayout ->
Switch[layoutSpec, "Unspecified", Automatic, _, layoutSpec],
EdgeStyle -> edgeStyle,
EdgeWeight -> weights,
VertexLabels -> vertexLabels,
VertexSize -> vertexSize,
VertexStyle -> vertexStyle,
VertexShapeFunction -> vertexShapeFunction,
PerformanceGoal -> "Quality"]
]
There are five main things to focus on in the above definition: the graph layout (passed as the argument `layoutSpec`), the edge thickness (defined in `edgeStyle`), the vertex size (defined in `vertexSize`), the version (passed as argument `version`) and the simplicity specification (`simplicitySpec`).
The graph layout is a `Graph` option that can be specified in the argument `layoutSpec`. If `"Unspecified"` is passed, an automatic layout will be used. I find that the best layouts tend to be, in order of preference, "BalloonEmbedding" and "RadialEmbedding"; nevertheless, neither are a perfect fit for every piece. In the future I would like to to implement custom (i.e. pre-defined) positioning, so that I can design it in a way that best fits this project.
The edge thickness is a function of the amount of times a certain transition between two chords has occurred in the chord sequence. There is an option (namely the `normalizationSpec` argument) to enable or disable using a Softmax function for assigning thicknesses to edges. This is due to the fact that for simple/short chord sequences, Softmax is actually counterproductive because it suppresses secondary but still top-ranked transitions; i.e., it assigns a very high thickness to the most frequent transition and a low thickness to all other transitions (even those that come in second or third in frequency ranking). But for large or complex sequences it is actually useful, because it "gets rid of" a lot of the \[relatively\] insignificant instances, thus making the output actually understandable (and not just a [jumbled mess of thick lines][15]).
The vertex size is proportional to the number of occurrences of each particular chord (that is, without taking into account the transitions). It can also be specified manually by passing `vSize` as a list `{a,b}` such that `a` is the minimum size an `b` is the maximum.
The `version` can be either `"Full"` or `"Basic"`; the default is `"Full"`. The `"Basic"` version consists of a simplified chord set in which only the root note of the chord is taken into account, and not the archetype. For example, all C chords (M, Dom7, m...) would be represented by a single `"C"` vertex.
Finally, the simplicity specification (`simplicitySpec`) is a number that can be thought of, in some way, as a "noise" threshold: as it gets larger, fewer edges "stand out"—that is, more of the lower-significance ones are rendered with reduced opacity or are shown as dotted lines. This is useful for large or complex sequences.
<br>
----------
#Some examples
Here I will show some specific examples generated with this tool. I tried to use different styles of music for comparison.
- **Bach**'s [prelude no.1][16] from the Well Tempered Clavier:
![Visualization of Bach's prelude no.1 ][17]
- **Debussy**'s [*Passepied*][18] from the *Suite Bergamasque*:
![Visualization of Debussy's *Passepied*][19]
- A "template" blues progression:
![Blues template][20]
- **Beethoven**'s second movement from the *Pathétique* sonata (no.8):
![Beethoven][21]
- Any "reggaeton" song (e.g. Despacito):
![Reggaeton][22]
#Microsite
Check out the form page (a.k.a. microsite) of this project [here][23]:
https://www.wolframcloud.com/objects/lammenspaolo/Chord%20sequence%20visualization
[![enter image description here][24]][23]
Briefly, here is what each option does (see the section **Algorithms and code** for a more detailed explanation):
- **Chunkifier functon**: choose between splitting notes by measures
- **Measure split factor**: choose into how many pieces you want to divide measures (each piece will be analyzed as a separate chord)
- **Graph layout**: choose the layout option for the `Graph` call
- **Normalization function**: choose whether to apply a Softmax function to the weights of edges (to make results clearer in case of complex sequences).
- **Version**: choose "Full" for complete chord info (e.g. "C-M", "D-Dom7", "C-7M"...) or "Basic" for just the root of the chord (e.g. "C", "D"...)
- **Vertex size**: specify vertex size as a list `{a,b}` where `a` is the minimum and `b` is the maximum size
- **Simplicity parameter**: visual simplification of the graph (a value of 0 means no simplification is applied)
<br>
#Conclusions
I have developed a functional tool to visualize chord sequences as graphs. It is far from perfect, though. In the future, I would like improving the positioning of vertices, being able to eliminate insignificant transitions from the graph altogether, and making other visual adjustments. Furthermore, I plan to refine and optimize the chord analyzer, as right now it is just an experimental version that isn't too accurate. A better "chunkifier" function could be developed too.
Finally, I'd like to thank my mentor Christian Pasquel and all of the other WSC staff for this amazing opportunity. I'd also like to thank my music theory teacher, Raimon Romaní, for making me, over the years, sufficiently less terrible at musical analysis to be able to undertake this project.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Prelude.png&userId=1372342
[2]: https://en.wikipedia.org/wiki/Markov_chain "Wikipedia: Markov chain"
[3]: https://en.wikipedia.org/wiki/Interval_(music) "Wikipedia: Interval"
[4]: https://en.wikipedia.org/wiki/Atonality "Wikipedia: Atonality"
[5]: https://youtu.be/L85XTLr5eBE "Schönberg's 4th string quartet on YouTube"
[6]: https://en.wikipedia.org/wiki/Tonic_%28music%29 "Wikipedia: Tonic"
[7]: http://astronomy.swin.edu.au/cosmos/S/Schwarzschild+Radius "Basic info on Schwartzschild radius"
[8]: https://en.wikipedia.org/wiki/Dominant_(music) "Dominant chord"
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2548Macro_analysis_chords_on_C.jpg&userId=1372342
[10]: https://en.wikipedia.org/wiki/Seventh_chord "Wikipedia: Seventh chord"
[11]: https://en.wikipedia.org/wiki/Interval_(music) "Wikipedia: Interval"
[12]: https://en.wikipedia.org/wiki/Dominant_seventh_chord "Wikipedia: Dominant seventh"
[13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=images.png&userId=1372342
[14]: https://en.wikipedia.org/wiki/Inversion_(music)#Chords "Wikipedia: Inversion#Chords"
[15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Passepied.png&userId=1372342 "Jumbled mess!"
[16]: https://www.youtube.com/watch?v=aengbLEFnM8
[17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Prelude.png&userId=1372342
[18]: https://www.youtube.com/watch?v=hDWbVP-5DSA "Passepied"
[19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=deb_pass2.png&userId=1372342
[20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Blues.png&userId=1372342
[21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=pathetique.png&userId=1372342
[22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Reggaeton.png&userId=1372342
[23]: https://www.wolframcloud.com/objects/lammenspaolo/Chord%20sequence%20visualization "Microsite"
[24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-19at1.53.02PM.png&userId=11733Paolo Lammens2018-07-14T05:10:03Z[WSS18] Analysis of Axon Expression Intensity from Images
http://community.wolfram.com/groups/-/m/t/1386698
Axon, also known as the nerve fiber, is a long, slender projection of a nerve cell, or neuron, that conducts electrical impulses known as action potentials, away from the nerve cell body. Although the connectivity of axons are crucial in signal transfer between neurons, its structural assembly and trend across the cortex is yet not widely investigated. By utilizing image processing techniques, we look at the structural trend and are able to quantify axon expressions, providing valuable data for further investigation of neuronal activity.
Background: What are Axons?
---------------------------
The neocortex, also called the neopallium and isocortex, is the part of the mammalian brain involved in higher-order brain functions such as sensory perception, cognition, generation of motor commands, spatial reasoning and language. The neocortex is the largest part of the cerebral cortex - outer layer of the cerebrum - in human brain.
![enter image description here][1]
The neocortex is made up of six layers, labelled from the outermost inwards, I to VI. Since different layers specialize in different activities, analysis of changing trend in axon density across the layers is crucial to understanding brain activity. Plasticity over longer distances means that a larger number of neural circuits can be achieved and implies a larger memory capacity per synapse (Fawcett and Geller, 1998, Chen et al., 2002, Papadopoulos, 2002).
Axons span many millimeters of cortical territory, and individual axons target diverse areas (Zhang and Deschenes, 1998). Thus, understanding the repertoire of axonal structural changes is fundamental to evaluating mechanisms of functional rewiring in the brain.
Images acquired from distinct axon arbors in adult barrel cortex of GFP transgenic mice were used in this project. Two-photon microscopy techniques were used along with SBEM(Serial Block-face scanning Electron Microscopy) techniques. Images were obtained after a series of surface scanning throughout the entire sample, then stacked for segmentation and quantification. Due to the size of the data, only the first section of layer 1 was analyzed in this project.
## Import Images ##
In order to carry out an image analysis with electron-microscope images, image data (real-value pixel sizes corresponding to each pixels) is needed.
First we want to assign pixel sizes corresponding to real image sizes:
xpixelsize = 512Quantity[1,"Micrometers"];
ypixelsize = 512 Quantity[1,"Micrometers"];
zstepsize = 293Quantity[1,"Micrometers"];
Then we import the TIF dataset from directory.
pic=Import@URLDownload["https://github.com/JihyeonJe/JJ-WSS18/raw/master/axon.tif"];
## Image Processing ##
After images are imported, 3D mesh is created for visualization of general structural trend throughout the entire stack. Maximum intensity projection is also generated from the stacks to aid the understanding of overall axon distribution.
To carry out density and volume calculations, images were binarized with given thresholds.
To get a general idea of the structure, we create a 3D mesh with the dataset:
image3D=Image3D[image,ColorFunction->"GrayLevelOpacity",BoxRatios->{1,1,1/3}];
resize = ImageResize[image3D, 170]
![enter image description here][2]
Then we binarize all the images with a set threshold:
binarized = Map[MorphologicalBinarize[#, {0.10, 0.4}]&,ImageAdjust/@image];
Now let's create maximum intensity projection from the previously created binarized images:
MIP = Image3DProjection[Image3D[binarized]]
![enter image description here][3]
Display mesh and temporal interpolation side by side for convenient analysis:
{Labeled[image3D,Text@"3D mesh"],Labeled[MIP,Text@"Maximum Intensity Projection"]}
![enter image description here][4]
## Calculate volume and density ##
With processed images, we are now able to calculate volume and density of the axons expressed in the images. This step is crucial in analyzing the volumetric intensity of axon expression in the sample.
Volume of total axons expressed were calculated by counting all non-zero elements in the binarized images and multiplying them by pixel sizes.
expressedvol = Count[Flatten[ImageData /@ binarized],1]*xpixelsize*ypixelsize*zstepsize
Then we get the value of 12353445560320 um^3.
Now calculate the volume of the entire image stack by counting image dimensions and multiplying it with pixel sizes:
totalvol = First[ImageDimensions[First[image]]]*xpixelsize*Last[ImageDimensions[First[image]]]*ypixelsize*Length[image]*zstepsize
This results in another volumetric quantity of 1208088401018880 um^3.
Using these two values, calculate the average axon volume:
denstiy = N[expressedvol/totalvol]Quantity[1,"Micrometers"]
Then we can get the output of average axon volume, 0.0102256 um^3.
By casting a sliding window across the entire image stack from top to bottom, the general trend of axon density was observed. Since connectivity between axons is a crucial in understanding brain activity, sliding window allows an analysis of the amount of shared data between axons across the brain.
slidingwindow[x_] := Count[Flatten[ImageData[x]],1]
SetAttributes[slidingwindow,Listable];
window = Total /@ MovingMap[slidingwindow, binarized, 2];
Now plot the graph:
Show[ListPlot[window/(First[ImageDimensions[First[image]]]* Last[ImageDimensions[First[image]]]*3), Joined -> True, PlotStyle->Thick, PlotLabel-> "Axon Density Across Z",LabelStyle->Directive[Bold], AxesLabel->"Axon Density (\!\(\*TemplateBox[{InterpretationBox[\"\[InvisibleSpace]\", 1],RowBox[{SuperscriptBox[\"\\\"\[Micro]m\\\"\", \"3\"]}],\"micrometers cubed\",SuperscriptBox[\"\\\"Micrometers\\\"\", \"3\"]},\n\"Quantity\"]\))" ]]
![enter image description here][5]
From the plotted graph we can see the general trend of axon density across the brain. For example, a local maxima(peak) at the region corresponding to the line of Gennari would indicate that the specific area is responsible for active neuronal signal transfer. When analyzed across the entire brain, such data can provide a novel understanding of axon expression and structures.
## References ##
Image data acquired from Diadem Challenge - Neocortical Layer Axon 1 : http://www.diademchallenge.org/neocortical_layer_ 1_axons _readme.html
De Paola V1 et al. (2006) Cell type-specific structural plasticity of axonal branches and boutons in the adult neocortex. Cold Spring Harbor Symp. Quant. Neruon. 49, 861-875. DOI: 10.1016/j.neuron.2006.02.017
Author Information:
Jihyeon Je (Western Reserve Academy, jej19@wra.net)
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-18at4.41.29PM.png&userId=1352003
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-18at4.44.56PM.png&userId=1352003
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-18at4.47.25PM.png&userId=1352003
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-18at4.48.15PM.png&userId=1352003
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-18at4.52.59PM.png&userId=1352003Jihyeon Je2018-07-18T07:55:40ZCan GeoHistogram deal with large data sets?
http://community.wolfram.com/groups/-/m/t/1350329
I have been trying to run GeoHistogram on a data set of around 1.3 million coordinate pairs, but I keep getting errors (different ones depending on the Mathematica version; tried 11.1 and 11.3 on Mac and Win). The "geos" data set consists of a list of pairs like this:
{37.4404,-121.87}
with some pairs repeated more or less often within the data set. The GeoHistogram call is simply this:
GeoHistogram[geos, PlotTheme -> "Scientific", ImageSize -> Full]
Has anybody else been having problems with this?
Thanks,
JohanJohan Lammens2018-06-01T15:44:29Z[WSC18] Modeling the growth or reduction of crime from 2016-2018 in Chicago
http://community.wolfram.com/groups/-/m/t/1382866
![Title Picture][1]
Introduction
============
Crime problems in the city of Chicago have gotten much exposure in media circles. Many online resources such as local newspapers (The Chicago Tribune), government agencies (Chicago Police), and academic institutions (University of Chicago Crime Lab) have attempted to use data stories and visualizations of the problems. We do not know, however of any attempts to use Wolfram Mathematica’s powerful tools to visualize crime in Chicago.
Abstract
========
Crime rates remain an important issue in the national dialogue, and many communities are looking for new approaches to understand the problem and best use their resources to address crime. Therefore, there is much opportunity to use advances in big data technology to give policy makers and citizens more insight into crime patterns so that they can focus resources on the areas with the highest pockets of crime. The
city of Chicago is at the forefront of the national consciousness regarding crime. In my project, a user will input a date and receive an output of all the crimes that occurred on that date in Chicago in chronological order. Markers will appear on the map when a crime occurs in a time lapse with different colors according to zip code.
Data Collection
=======
I started my project by obtaining very accurate crime data from the city of Chicago, showing types of crimes, when they were reported, and where they happened.
![enter image description here][2]
I then inputted this information into Mathematica. I then split the crimes in to Property Crime, Crime on a Person, and Violations and used the TogglerBar function in order to select a number of crimes you want to put in.
{propertycrime, {"ARSON", "BURGLARY", "THEFT", "ROBBERY", "MOTOR VEHICLE THEFT", "CRIMINAL DAMAGE", "CRIMINAL TRESPASS", "HOMICIDE"}, ControlType -> TogglerBar, ControlPlacement -> Top},
{personcrime, {"ASSAULT", "BATTERY", "HUMAN TRAFFICKING", "CRIM SEXUAL\ ASSAULT", "DECEPTIVE PRACTICE", "SEX OFFENSE", "STALKING", "PROSTITUTION", "KIDNAPPING", "INTIMIDATION", "OFFENSE INVOLVING CHILDREN"}, ControlType -> TogglerBar,
ControlPlacement -> Top},
{violations, {"WEAPONS VIOLATION", "OTHER NARCOTIC \ VIOLATION", "LIQUOR LAW VIOLATION"}, ControlType -> TogglerBar,
ControlPlacement -> Top},
Manipulate
=======
Manipulate[
Module[{crimetype},
crimetype = Join[propertycrime, personcrime, violations];
Quiet@GeoGraphics[
GeoMarker[
Select[data,
MemberQ[crimetype, #[[-1]]] && (#[[1]] == {year, month, day,
hour}) &][[All, {2, 3}]], "Color" -> Blue],
GeoCenter ->
Entity["City", {"Chicago", "Illinois", "UnitedStates"}],
GeoRange -> Quantity[20, "Miles"],
PlotLabel -> DateString[DateObject[{year, month, day, hour}]
]
]
],
Delimiter,
{propertycrime, {"ARSON", "BURGLARY", "THEFT", "ROBBERY",
"MOTOR VEHICLE THEFT", "CRIMINAL DAMAGE", "CRIMINAL TRESPASS",
"HOMICIDE"}, ControlType -> TogglerBar, ControlPlacement -> Top},
{personcrime, {"ASSAULT", "BATTERY", "HUMAN TRAFFICKING",
"CRIM SEXUAL\ ASSAULT", "DECEPTIVE PRACTICE", "SEX OFFENSE",
"STALKING", "PROSTITUTION", "KIDNAPPING", "INTIMIDATION",
"OFFENSE INVOLVING CHILDREN"}, ControlType -> TogglerBar,
ControlPlacement -> Top},
{violations, {"WEAPONS VIOLATION", "OTHER NARCOTIC \ VIOLATION",
"LIQUOR LAW VIOLATION"}, ControlType -> TogglerBar,
ControlPlacement -> Top},
Delimiter,
{{month, 6}, If[year == 2016, 6, 1], If[year == 2018, 6, 12], 1,
Appearance -> "Labeled", ControlPlacement -> Left},
{{day, If[year == 2016 && month == 6, 29,
If[year == 2017, 5, If[year == 2018 && month == 6, 5]]]},
If[month == 6 && year == 2016, 29, 1],
If [month == 1 || month == 3 || month == 5 || month == 7 ||
month == 8 || month == 10 || month == 12, 31,
If[month == 9 || month == 4 || month == 6 || month == 11,
If[month == 6 && year == 2018, 26, 30], 28]], 1,
Appearance -> "Labeled", ControlPlacement -> Left},
{{year, 2016}, 2016, 2018, 1, Appearance -> "Labeled",
ControlPlacement -> Left},
{{hour, 1}, 1, 23, 1, Appearance -> "Labeled",
ControlType -> Trigger, AnimationRate -> .5,
ControlPlacement -> Left},
Button["Include all crimes?", (propertycrime = {"ARSON", "BURGLARY",
"THEFT", "ROBBERY", "MOTOR VEHICLE THEFT", "CRIMINAL DAMAGE",
"CRIMINAL TRESPASS", "HOMICIDE"};
personcrime = {"ASSAULT", "BATTERY", "HUMAN TRAFFICKING",
"CRIM SEXUAL\ ASSAULT", "DECEPTIVE PRACTICE", "SEX OFFENSE",
"STALKING", "PROSTITUTION", "KIDNAPPING", "INTIMIDATION",
"OFFENSE INVOLVING CHILDREN"};
violations = {"WEAPONS VIOLATION", "OTHER NARCOTIC \ VIOLATION",
"LIQUOR LAW VIOLATION"};)],
Button["Remove all crimes?", (propertycrime = {}; personcrime = {};
violations = {};)],
ControlPlacement -> Left]
Results
=======
The results show selected crimes and times when the crimes were reported correlated with the Chicago location where the crime occurred. The map can show the seasonality and geographic pattern of certain crimes in certain neighborhoods and test assumptions regarding how crime occurs in the city. For example, we can test the assumption that crimes like assault primarily happen during the summer because in the cold Chicago winter many people do not go outside and meet other people. The map also can be used to test assumptions about safety in certain parts of the city versus others, and if there are any seasonal or time variations that correlate.
![enter image description here][3]
Future Work
===========
In the future I would like to expand out my project to vary colors on the map like a heat map, where I could set a time period and have areas of the city where crimes happen the most be dark red, but in areas where there are few crimes to be a cooler color. I would also like to build in probability to enable the user to choose a part of the city and perhaps a season or time and see the probability of crime happening in the location. If demographic data regarding criminals and victims is available, I would like to add functionality where a user could chose a certain demographic profile and see when and where it is most likely where they would commit a crime or be a victim of crime. Police could use data like this to know where to deploy patrol units and social services providers could use it to learn where and when they should focus their resources to prevent crime. I would also like to expand the data set to other cities. However, there is a challenge that not all police agencies collect or format their data in the same way. Looking at crime in border areas (ex: the Illinois/Indiana border at the very south end of Chicago) would be quite interesting, but the data challenges would be difficult.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture.PNG&userId=1371928
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture2.PNG&userId=1371928
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture3.PNG&userId=1371928Sachi Figliolini2018-07-13T19:12:23ZFindFit for a specific line from a ContourPlot?
http://community.wolfram.com/groups/-/m/t/1374074
Hi!
I have been trying to find an expression u(r) for a specific line of a contourplot (the one that looks like ln(x) on the last image of the nb)
Is there a way to :
Extract data from a ContourPlot that is not one to one line (meaning for 1 x , there are at least 2 y satisfying the equation)?
FindFit for a contour plot?
Have been trying so hard and looking everything on Google with no success. Any help is appreciated since im on timetableVASILEIOS MPISKETZIS2018-07-10T19:23:45Z