I am trying to create a program that handles a operators algebra, where the operators don't have a explicit representation.
This implies that I have to define a lot of symbols and parametric functions to keep track of what has been done.
I have two kinds of operators: V^+ and V^-.
The algebra reads:
[V^+(a),V^+(b)]=I X[a,b] V^+(a+b)
[V^-(a),V^-(b)]=I Xbar[a,b] V^-(a+b)
Note:("a+b" is not a sum. It's the union of two sets of legs in a Feynman diagram)
Then we have: V^+(a)V^+(b)=I X[a,b]V^+(a|b)
with, of course, V^+(a|b)+V^+(b|a)=V^+(a+b).
X and Xbar are the structure constants and are antisymmetric in the two arguments.
Then we have to define:
V^+(a|b)*V^+/-(c|d)=I X[b,c+d]V^+/-(a+b+c|d)
V^-(a|b)*V^+/-(c|d)=I Xbar[b,c+d]V^+/-(a+b+c|d)
where it's important to define also: V^+/-(a)=V^+/-(0|a).
So, in mathematica I defined up to now the commutator and the product of V's containing things like a|b.
The main problem appears when I want to calculate structures where I have commutators of commutators.
Here is the relevant part of the code:
Structure constants:
XX[A_, B_] := If[A < B, X[A, B], -X[B, A]]
XXb[A_, B_] := If[A < B, Xb[A, B], -Xb[B, A]]
This is done to implement the antisymmetry and facilitate simplification.
Product with vertical bar objects
PB[V[VB[A_,B_],K_],V[VB[C_,D_],PD_]] :=If[K == 1,I*XX[B,piu[C,D]]V[VB[piu[A,B,C],D],PD],I*XXb[B,piu[C,D]]V[VB[piu[A,B,C],D],PD]]
where I used the function "piu" which stands just for the union of legs as in "a+b"(=piu[a,b]).
piu[A_, B_] := If[A != 0, If[B != 0, pi[A, B], A], If[B != 0, B, 0]]
piu[A_, B_, C_] := If[A != 0,If[B != 0, If[C != 0, pi[A, B, C], pi[A, B]],If[C != 0,pi[A, C], A]], If[B != 0, If[C != 0, pi[B, C], B], If[C != 0, C, 0]]]
The second argument in V can be 0 or 1 and stands just for the "+"(1) or "-"(0).
Then the commutators:
Comm[V[vb[A_, B_], K_], V[vb[C_, D_], M_]] := PB[V[VB[A, B], K], V[VB[C, D], M]]-PB[V[VB[C, D], M], V[VB[A, B], K]]
Comm[V[vb[A_, B_], K_], V[[piu[C_, D_], E_], M_]] :=PB[V[VB[A, B], K], V[VB[C, D], M]]-PB[V[VB[C, D], M], V[VB[A, B], K]]
where I directly used the "0|a" way of writing "a" to avoid ambiguities and where I defined also the special case where one of the arguments is the sum of other two.
Finally, I created a set of rules to simplify stuff and give me the correct results:
Rules
RC = {
VB[A_, B_] :> vb[A, B],
vb[A_, pi[B_, C_]] :> If[A != 0, vb[A, pi[B, C]], vb[0, pi[B, C]]],
vb[A_, B_] :> If[A != 0, If[B != 0, vb[A, B], vb[A]], If[B != 0, vb[B], 0]],
VB[Null, A_] :> vb[A],
(V[vb[A_, B_], K_] + V[vb[B_, A_], K_]) :> V[vb[0, piu[A, B]], K]
}
I apply the rules using:
SimplifyRC[expr_]:=Simplify[expr]//.RC
To give you an example of what happens, this is the result for a simple commutator:
SimplifyRC[Comm[V[VB[0, 1], 1], V[VB[0, 2], 1]]]
Out= I V[vb[0, pi[1, 2]], 1] X[1, 2]
Up to now everything is fine.
However the goal of the program is to calculate more complex structures with commutators of commutators.
My question is: how do I handle the factors (I, X[a,b], Xbar[a,b]) coming out of commutators, inside the new commutators?
I tried defining some rules to say that the function should be bilinear in the two arguments, but this works just once and as soon as I call the function more than once inside itself, the problem reappears.
Example:
SimplifyRC[Comm[V[VB[0, 1], 1], Comm[V[VB[0, 2], 1], V[VB[0, 3], 1]]]]
Out= Comm[V[vb[1], 1], I V[vb[0, pi[2, 3]], 1] X[2, 3]]
This can be handled easily by setting a rule of substitution.
However as soon as I would go to
SimplifyRC[Comm[V[VB[0, 1], 1],Comm[V[VB[0, 1], 2], Comm[V[VB[0, 3], 1], V[VB[0, 4], 1]]]]]
the problem would pop up again cause inside the new commutator I would have something like "X[a,b]X[c,d]" and the rule wouldn't work anymore.
Is there a smart way to implement a rule that takes care of that and brings out of the commutator whatever it's not a V operator?
I hope this is clear enough. The code is messy, but due to the lack of a explicit representation for the operators, one has to define all those functions and symbols to keep track of operations.
Thanks in advance.
Related
Is it possible with DCGs to extract some 2D list, such that it can be represented by a context free grammar
S -> [ A , B ]
A -> [0,0,0,0,0]
A -> NULL
B -> [1,1,1,1,1]
B -> NULL
for example:
[[0,0,0,0,0], [1,1,1,1,1]] is valid
[[1,1,1,1,1]] is valid, where A is NULL.
[[0,0,0,0,0]] is valid, where B is NULL.
I tried something like this
zeros --> [].
zeros --> [0,0,0,0,0].
ones --> [].
ones --> [1,1,1,1,1]
matrix --> [A, B],
{phrase(zeros, A)},
{phrase(ones, B)}.
But this is not going to work the way I wanted it to, because in this case, the "compiler" thought I want an empty list '[]' instead of NULL.
so [[], [1,1,1,1,1]] will work while [[1,1,1,1,1]] is not.
How do I approach this?
The problem is that once you write matrix --> [A, B], that rule will definitely generate a two-element list, no matter what A and B are.
So you want to alternatively generate one-element lists [A] or [B]. You could do this explicitly:
a --> [0, 0, 0, 0, 0].
b --> [1, 1, 1, 1, 1].
matrix -->
[A],
{ phrase(a, A) }.
matrix -->
[B],
{ phrase(b, B) }.
matrix -->
[A, B],
{ phrase(a, A) },
{ phrase(b, B) }.
This works:
?- phrase(matrix, Matrix).
Matrix = [[0, 0, 0, 0, 0]] ;
Matrix = [[1, 1, 1, 1, 1]] ;
Matrix = [[0, 0, 0, 0, 0], [1, 1, 1, 1, 1]].
But this is a lot of typing, and it's not very flexible if you want to extend it.
So let's try to generalize the fixed [A, B] bit. As a first step, we can use a list//1 DCG that just describes its own argument list:
list([]) -->
[].
list([X|Xs]) -->
[X],
list(Xs).
We can use this as follows:
?- phrase(list([a, b, c]), Xs).
Xs = [a, b, c].
And use it to define a matrix:
matrix_with_list -->
list([A, B]),
{ phrase(a, A) },
{ phrase(b, B) }.
This looks like we haven't made progress yet:
?- phrase(matrix_with_list, Matrix).
Matrix = [[0, 0, 0, 0, 0], [1, 1, 1, 1, 1]].
But now we can change list//1 a bit to only describe a sublist of its argument list:
optional_list([]) -->
[].
optional_list([_X|Xs]) -->
% skip this X!
optional_list(Xs).
optional_list([X|Xs]) -->
% keep this X
[X],
optional_list(Xs).
This behaves as follows:
?- phrase(optional_list([a, b, c]), Xs).
Xs = [] ;
Xs = [c] ;
Xs = [b] ;
Xs = [b, c] ;
Xs = [a] ;
Xs = [a, c] ;
Xs = [a, b] ;
Xs = [a, b, c].
Now we can adapt the previous definition:
matrix_with_optional_list -->
optional_list([A, B]),
{ phrase(a, A) },
{ phrase(b, B) }.
And we get:
?- phrase(matrix_with_optional_list, Matrix).
Matrix = [] ;
Matrix = [[1, 1, 1, 1, 1]] ;
Matrix = [[0, 0, 0, 0, 0]] ;
Matrix = [[0, 0, 0, 0, 0], [1, 1, 1, 1, 1]].
Pretty good! But it's not great to have all those phrase/2 calls even if they refer to elements that do not end up in the matrix.
So let's generalize some more, to a DCG whose argument is a list of DCGs, and that describes a sublist of the list of lists described by those DCGs:
optional_phrase([]) -->
[].
optional_phrase([_Rule|Rules]) -->
% skip this rule
optional_phrase(Rules).
optional_phrase([Rule|Rules]) -->
% apply this rule
[List],
{ phrase(Rule, List) },
optional_phrase(Rules).
The main insight here was that you can use phrase/2 in a "higher-order" manner, where its first argument is not a literal atom (or functor term) naming a DCG, but a variable bound to such an atom or term. However, you must ensure that these variables are really bound when you apply this rule.
With this the final definition of the matrix is just:
matrix_with_optional_phrase -->
optional_phrase([a, b]).
This now enumerates matrices as before, but it only ever executes phrase/2 for elements that are actually part of the matrix:
?- phrase(matrix_with_optional_phrase, Matrix).
Matrix = [] ;
Matrix = [[1, 1, 1, 1, 1]] ;
Matrix = [[0, 0, 0, 0, 0]] ;
Matrix = [[0, 0, 0, 0, 0], [1, 1, 1, 1, 1]].
DCG notation reserves lists in production to represent sequences of 'tokens'.
Then, your production zeros - for instance - will match a sequence of five zeroes, not a list of five zeroes. There is some confusion here, just because your target language (a sequence of lists) uses the metalanguage notation (Prolog lists indicate sequences of terminals in DCG productions).
I think you could write it simply
zeros --> [ [0,0,0,0,0] ].
ones --> [ [1,1,1,1,1] ].
matrix --> (zeros ; ones), matrix ; [].
test :- phrase(matrix, [ [1,1,1,1,1],[0,0,0,0,0] ]).
I`ve seen several answers for quite similar topics with usage of ?NumericQ explained and still can not quite understand what is wrong with my implementation and could my example be evaluated at all the way I want it.
I have solution of differential equation in form of ParametricNDSolve (I believe that exact form of equation is irrelevant):
sol = ParametricNDSolve[{n'[t] == g/(1/(y - f*y) + b*t + g*t)^2 - a*n[t] - c*n[t]^2, n[0] == y*f}, {n}, {t, 0, 10}, {a, b, c, g, f, y}]
After that I am trying to construct a function for FindFit or similar procedure, Nintegrating over function n[a,b,c,g,f,y,t] I have got above with some multiplier (I have chosen Log[z] as multiplier for simplicity)
Func[z_, a_, b_, c_, g_, f_] :=
NIntegrate[
Log[z]*(n[a, b, c, g, f, y][t] /. sol), {t, 0, 10}, {y, 0, Log[z]}]
So I have NIntegrate over my function n[params,t] derived from ParametricNDSolve with multiplier introducing new variable (z) wich also present in the limits of integration (in the same form as in multiplier for simplicity of example)
I am able to evaluate the values of my function Func at any point (z) with given values of parameters (a,b,c,g,f): Func(0,1,2,3,4,5) could be evaluated.
But for some reasons I cannot use FindFit like that:
FindFit[data, Func[z, a, b, c, g, f], {a, b, c, g, f}, z]
The error is: NIntegrate::nlim: y = Log[z] is not a valid limit of integration.
I`ve tried a lot of different combinations of ?NumericQ usage and all seems to lead nowhere. Any help would be appreciated!
Thanks in advance and sorry for pure english in the problem explanation.
Here is a way to define your function:
sol = n /.
ParametricNDSolve[{n'[t] ==
g/(1/(y - f*y) + b*t + g*t)^2 - a*n[t] - c*n[t]^2,
n[0] == y*f}, {n}, {t, 0, 10}, {a, b, c, g, f, y}]
Func[z_?NumericQ, a_?NumericQ, b_?NumericQ, c_?NumericQ, g_?NumericQ,
f_?NumericQ] :=
NIntegrate[Log[z]*sol[a, b, c, g, f, y][t],
{t, 0, 10}, {y, 0, Log[z]}]
test: Func[2, .45, .5, .13, .12, .2] -> 0.106107
I'm not optimistic you will get good results from FindFit with a function with so many parameters and which is so computationally expensive.
I have an assignment that seems out of scope of my class (I say this because they barely taught us anything about prolog), I have to write a prolog program to solve the game "Flow Free" on android. In the assignment it is called Numberlink. I could solve this in C++ in a hour but because I'm not too familiar with prolog it is giving me trouble. Here's what I would like to do:
Make a list that holds a boolean to indicate whether it has been visited or used.
Recursively search all possible paths from a given starting point to
the end point using a breadth first search to find the shortest
paths.
Go from there I guess.
My attempt included searching the web on how to make a list. Of course prolog is not documented well at all anywhere so I came up blank and gave up. A friend told me to use maplist which I don't understand how I would use it to make a list including what I need.
Thanks in advance.
EDIT:
Thanks for the link, but I was looking to make a 2D list to represent the board being played on. Function would look like this:
makeList(size, list):-
Where size is an integer representing the size of one dimension in the square list ex. (7x7).
Here's an implementation of #CapelliC's solution. The code is self-explanatory. 2 blocks are connected if they are adjacent and have the same color, or adjacent to another connected block of the same color. (I used X and Y instead of row and column, it made writing the conditions at the end a little confusing.)
Solving in SWI-Prolog
https://flowfreesolutions.com/solution/?game=flow&pack=green&set=5&level=1
connected(P1, P2, M, Visited) :-
adjacent(P1, P2),
maplist(dif(P2), Visited),
color(P1, C, M),
color(P2, C, M).
connected(P1, P2, M, Visited) :-
adjacent(P1, P3),
maplist(dif(P3), Visited),
color(P1, C, M),
color(P3, C, M),
connected(P3, P2, M, [P3|Visited]).
adjacent(p(X,Y1), p(X,Y2)) :- Y2 is Y1+1.
adjacent(p(X,Y1), p(X,Y2)) :- Y2 is Y1-1.
adjacent(p(X1,Y), p(X2,Y)) :- X2 is X1+1.
adjacent(p(X1,Y), p(X2,Y)) :- X2 is X1-1.
color(p(X,Y), C, M) :-
nth1(Y, M, R),
nth1(X, R, C).
sol(M) :-
M = [[1,_,_,_,1],
[2,_,_,_,_],
[3,4,_,4,_],
[_,_,_,_,_],
[3,2,5,_,5]],
connected(p(1,1), p(5,1), M, [p(1,1)]),
connected(p(1,2), p(2,5), M, [p(1,2)]),
connected(p(1,3), p(1,5), M, [p(1,3)]),
connected(p(2,3), p(4,3), M, [p(2,3)]),
connected(p(3,5), p(5,5), M, [p(3,5)]).
Sample query:
?- sol(M).
M = [[1, 1, 1, 1, 1],
[2, 2, 2, 2, 2],
[3, 4, 4, 4, 2],
[3, 2, 2, 2, 2],
[3, 2, 5, 5, 5]].
The declarative Prolog 'modus operandi' is based on non determinism, implemented by depth first search. Let's apply to this puzzle: M is the playground, a list of lists of free cells (variables) or integers (colors)
one_step(M) :-
cell(M, X,Y, C),
integer(C), % the selected cell is a color
delta(X,Y,X1,Y1),
cell(M, X1,Y1, C). % bind adjacent to same color - must be free
cell(M, X,Y, C) :- nth1(Y,M,R), nth1(X,R,C).
% moves
delta(X,Y,X1,Y) :- X1 is X+1. % right
delta(X,Y,X1,Y) :- X1 is X-1. % left
delta(X,Y,X,Y1) :- Y1 is Y-1. % up
delta(X,Y,X,Y1) :- Y1 is Y+1. % down
what this does ? let's try on a 3x3 playground
?- M=[[_,9,_],[_,0,_],[_,_,9]],one_step(M).
M = [[_G1824, 9, 9], [_G1836, 0, _G1842], [_G1848, _G1851, 9]] ;
M = [[9, 9, _G1830], [_G1836, 0, _G1842], [_G1848, _G1851, 9]] ;
M = [[_G1824, 9, _G1830], [_G1836, 0, 0], [_G1848, _G1851, 9]] ;
M = [[_G1824, 9, _G1830], [0, 0, _G1842], [_G1848, _G1851, 9]] ;
M = [[_G1824, 9, _G1830], [_G1836, 0, _G1842], [_G1848, 0, 9]] ;
M = [[_G1824, 9, _G1830], [_G1836, 0, _G1842], [_G1848, 9, 9]] ;
M = [[_G1824, 9, _G1830], [_G1836, 0, 9], [_G1848, _G1851, 9]] ;
false.
No need to declare grid size, check index boundaries, etc... when one_step/1 succeeds it has instantiated a free cell to an adjacent same color...
Applying Orthogonalize[] once:
v1 = PolyhedronData["Dodecahedron", "VertexCoordinates"][[1]];
Graphics3D[Line[{{0, 0, 0}, #}] & /#
Orthogonalize[{a, b, c} /.
FindInstance[{a, b, c}.v1 == 0 && (Chop#a != 0.||Chop#b != 0.||Chop#c != 0.),
{a, b, c}, Reals, 4]], Boxed -> False]
And now twice:
Graphics3D[Line[{{0, 0, 0}, #}] & /#
Orthogonalize#Orthogonalize[{a, b, c} /.
FindInstance[{a, b, c}.v1 == 0 && (Chop#a != 0.||Chop#b != 0.||Chop#c != 0.),
{a, b, c}, Reals, 4]], Boxed -> False]
Errr ... Why?
I think the first result is due to numerical error, taking
sys = {a,b,c}/.FindInstance[
{a, b, c}.v1 == 0 && (Chop#a != 0. || Chop#b != 0. || Chop#c !=0.),
{a, b, c}, Reals, 4];
then MatrixRank#sys returns 2, therefor the system itself is only two dimensional. To me, this implies that the first instance of Orthogonalize is generating a numerical error, and the second instance is using the out of plane error to give you your three vectors. Removing the Chop conditions fixes this,
Orthogonalize[{a, b, c} /.
N#FindInstance[{a, b, c}.v1 == 0,{a, b, c}, Reals, 4]]
where N is necessary to get rid of the Root terms that appear. This gives you a two-dimensional system, but you can get a third by taking the cross product.
Edit: Here's further evidence that its numerical error due to Chop.
With Chop, FindInstance gives me
{{64., 3.6, 335.108}, {-67., -4.3, -350.817}, {0, 176., 0},
{-2., -4.3, -10.4721}}
Without Chop, I get
{{-16.8, 3.9, -87.9659}, {6.6, -1.7, 34.558}, {13.4, -4.3, 70.1633},
{19.9, -4.3, 104.198}}
which is a significant difference between the two.
I also assumed it would be a numerical error, but didn't quite understand why, so I tried to implement Gram-Schmidt orthogonalization myself, hoping to understand the problem on the way:
(* projects onto a unit vector *)
proj[u_][v_] := (u.v) u
Clear[gm, gramSchmidt]
gm[finished_, {next_, rest___}] :=
With[{v = next - Plus ## Through[(proj /# finished)[next]]},
gm[Append[finished, Normalize#Chop[v]], {rest}]
]
gm[finished_, {}] := finished
gramSchmidt[vectors_] := gm[{}, vectors]
(Included for illustration only, I simply couldn't quite figure out what's going on before I reimplemented it myself.)
A critical step here, which I didn't realize before, is deciding whether a vector we get is zero or not before the normalization step (see Chop in my code). Otherwise we might get something tiny, possibly a mere numerical error, which is then normalized back into a large value.
This seems to be controlled by the Tolerance option of Orthogonalize, and indeed, raising the tolerance, and forcing it to discard tiny vectors fixes the problem you describe. Orthogonalize[ ... , Tolerance -> 1*^-10] works in a single step.
Perhaps it is a characteristic of the default GramSchmidt method?
Try: Method -> "Reorthogonalization" or Method -> "Householder".
I'd like to extract arguments from instances of Inequality. Following doesn't work, any idea why and how to fix it?
Inequality[1, Less, x, Less, 2] /. Inequality[a_, _, c_, _, e_] -> {a, c, e}
Inequality[1,Less,x,Less,2] /. HoldPattern[Inequality[a_,_,b_,_,c_]] -> {a, b, c}
Out: {1, x, 2}
Also, you can do this:
Inequality[1, Less, x, Less, 2] /.
Literal # Inequality[ a_ , _ , c_ , _ , e_ ] -> {a, c, e}
ADL
Why don't you use standard access to subexpression?
expr = Inequality[1, Less, x, Less, 2];
{a,c,e} = {expr[[1]], expr[[3]], expr[[5]]};