Ausschaltung einiger Fehlermeldungen :

Off[General::"spell"]
Off[General::"spell1"]
Off[Solve::"ifun"]

Definition der Prozesse und des Startparameters zur Erzeugung der Cyclen

pp = {p, T, V, Q};
ppm = {#} & /@ pp

Funktion zur Erzeugung der Cyclen. f1 ruft sich selbst auf bis die gewünschte Zahl an Prozessen erreicht ist. Die Elemente von ppm werden an die Variable angehängt und dann erlaubte Cyclen selektiert.

Clear[f1];
f1[a_, n_] := 
      Module[{x}, 
x = 
          Length[a[[1]]]; 
If[x == n, 
          a, 
f1[
Select[
Flatten[Table[Join[#, ppm[[i]]], {i, 1, 4}] & /@ 
                  a, 1], If[
                  x == 
                    n - 1, #[[1]] =!= #[[x + 
                            1]] && #[[x]] =!= #[[x + 
                            1]], #[[x]] =!= #[[x + 
                          1]]] &]
, 
            n]
]
]

Funktion zur Beseitung rotationsäquivalenter Cyclen

Clear[purge]
purge[arg_] := 
      Module[{t1, x, res}, 
res = 
          arg; 
Do[
t1 = 
            res[[i]]; 
Do[
t1 = 
              RotateLeft[t1]; 
x = 
              Position[res, t1]; 
If[FreeQ[x, i], 
              res = ReplacePart[res, {0}, x]], {Length[t1] - 
                1}
], 
{i, 1, 
            Length[res] - 1}
]; 
res = 
          Select[res, # =!= {0} &]
]

Funktionen zur Erzeugung des nächsten Punktes { p, V, T } durch die ausgewählten Prozesse

ffp[{p_, v_, t_}] := {p, v2, 
        v2 t/v}
fft[{p_, v_, t_}] := {p v/v2, v2, t}
ffv[{p_, v_, t_}] := {p2, v, p2 t/p}
ffq[{p_, v_, t_}] := {p (v/v2)^k, v2, 
        t (v/v2)^(k - 1)}

Berechnung der Arbeit zwischen zwei Punkten

workp[{{p1_, v1_, t1_}, {p2_, v2_, 
            t2_}}] := -p1 (v2 - 
            v1) 
workv[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := 
      0
workt[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := - R t1 Log[
          v2/v1]
workq[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := (p1 v1  - 
            p2 v2)/(1 - k)

Berechnung der ausgetauschten Wärme  zwischen zwei Punkten

heatp[{{p1_, v1_, t1_}, {p2_, v2_, 
            t2_}}] := (cv  +  R) 
        t1 (v2 - v1)/v1
heatv[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := 
      cv (t2 - t1)
heatt[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := 
      R t1 Log[v2/v1]
heatq[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := 0

Berechnung der Entropiedifferenz zwischen zwei Punkten

entropyp[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := 
      cv  Log[t2/t1] + R Log[v2/v1]
entropyv[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] :=  
      cv  Log[t2/t1]
entropyt[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := 
      R Log[v2/v1]
entropyq[{{p1_, v1_, t1_}, {p2_, v2_, t2_}}] := 0

Funktion zum Plotten eines Cyclus. Muss auf die zu  plottenden Daten eingerichtet werden.

{ux, ox} = {2, 6};
{uy, oy} = {0, 10};
pfp[{{a_, b_, c_}, {x_, y_, z_}}] := 
      Plot[a, {v, b, y}, DisplayFunction -> Identity, 
        PlotRange -> {{ux, ox}, {uy, oy}}]
pfv[{{a_, b_, c_}, {x_, y_, z_}}] := 
      Graphics[Line[{{b, a}, {y, x}}], 
        PlotRange -> {{ux, ox}, {uy, oy}}, 
        Axes -> True]
pft[{{a_, b_, c_}, {x_, y_, z_}}] := 
      Plot[x y/v, {v, b, y}, DisplayFunction -> Identity, 
        PlotRange -> {{ux, ox}, {uy, oy}}]
pfq[{{a_, b_, c_}, {x_, y_, z_}}] := 
      Plot[Evaluate[x (y/v)^k  /. werte], {v, b, y}, 
        DisplayFunction -> Identity, 
        PlotRange -> {{ux, ox}, {uy, oy}}]

Diese Funktion erzeugt ein Graphic-Object zur Darstellung eins Cyclus durch Aufruf der angemessen Plot-Funktionen. Die Variable b enthält die Eckpunkte des Weges.

\(\(\(
\)\(gg[proc_, b_] := 
      Module[{x, g, pg}, 
pg = 
          Table[0, {4}]; 
g = 
          Table[Take[b, {j, j + 1}], {j, 1, 
              4}]; 
Do[
x = 
            proc[\([i]\)]; 
Which[
x === 
              p, pg = ReplacePart[pg, pfp[g[\([i]\)]], 
                i], 
x === V, 
            pg = ReplacePart[pg, pfv[g[\([i]\)]], i], 
x === 
              T, pg = ReplacePart[pg, pft[g[\([i]\)]], 
                i], 
x === Q, 
            pg = ReplacePart[pg, pfq[g[\([i]\)]], 
                i], 
True, 
            Print[" No approriate plot-function for ", 
              x, " available"]
], 
{i, 1, 
            Length[proc]}]; 
pg]\)\)\)

Hilfsfunktion für den variablen Aufruf von Funktionen. u verkettet die Variablen func und ext zum neuen Funktionsnamen funcext .

Clear[uu]
uu[func_, ext_, 
        arg_] := ToExpression[ToString[SequenceForm[func, ext]]][
        arg]

Die Funktion weg erzeugt im p-V-Raum die Eckpunkte des Weges, der durch die in proc gegebenen Prozesse definiert wird unter anwendung der prozessgleichungen func.

\(\(\(
\)\(weg[proc_, start_, func_] := 
      Module[{x, c}, 
c = 
          Join[{start}, 
            Table[0, {Length[
                  proc]}]]; 
Do[
x = 
            proc[\([i]\)]; 
Which[
x === 
              p, c = ReplacePart[c, uu[func, p, c[\([i]\)]], 
                  i + 1] /. {v2 -> v[i + 1], 
                  p2 -> p[i + 1]}, 
x === V, 
            c = ReplacePart[c, uu[func, v, c[\([i]\)]], 
                  i + 1] /. {v2 -> v[i + 1], 
                  p2 -> p[i + 1]}, 
x === T, 
            c = ReplacePart[c, uu[func, t, c[\([i]\)]], 
                  i + 1] /. {v2 -> v[i + 1], 
                  p2 -> p[i + 1]}, 
x === Q, 
            c = ReplacePart[c, uu[func, q, c[\([i]\)]], 
                  i + 1] /. {v2 -> v[i + 1], 
                  p2 -> p[i + 1]}, 
True, 
            Print[" No approriate state-function for ", 
              x, " available"]
], 
{i, 1, 
            Length[proc]}]; 
c
]\)\)\)

Hier werden die Variablen konkretisiert und aus den Punkten des Weges eingesetzt.

endweg[
        w_ ]:=Module[{r, w0}, 
r = 
          Flatten[Table[{p[i] -> w[[i, 1]], 
                v[i] -> w[[i, 2]], t[i] -> w[[i, 3]]}, {i, 
                1, Length[w] - 1}]]; 
w0 = 
          w /. r
]

Hilfsfunktion zur Berechnung der Gleichungen zur Bestimmung des vorletzten Punktes, von dem aus ja der erste wieder erreicht werden soll.

Clear[gltyp]
\(gltyp[a_, n_] := 
      Module[{x}, 
x = {n - 1, 
            1}; 
Table[
Which[
a[\([i]\)] === p, 
            p[x[\([i]\)]] == p[n], 
a[\([i]\)] === T, 
            p[x[\([i]\)]] v[x[\([i]\)]] == 
              p[n] v[n], 
a[\([i]\)] === V, 
            v[x[\([i]\)]] == v[n], 
a[\([i]\)] === Q, 
            p[x[\([i]\)]] v[x[\([i]\)]]^k == 
              p[n] v[n]^k, 
True, 
            Print[" No approriate expression for ", 
              x, " available"]
], 
{i, 1, 2}]
]\)

ausw soll eine möglichst einfache Gleichung für die Schliessungsbedingung finden

ausw[{a_, b_}, 
        n_]:=If[
MemberQ[a, p[n], 5] && 
          FreeQ[a, k], a, 
        If[MemberQ[b, p[n], 5], b, 
          a]]

closing bestimmt die Koordinaten des vorletzten Punktes, so dass der Startpunkt wieder erreicht wird. closing gibt die ausgewählte Gleichung sowie Druck und Volumen des vorletzten Punktes in der Liste { gl, p, V } zurück.

Clear[closing]
closing[proc_] := 
      Module[{n, x, g}, 
n = 
          Length[proc]; 
x = 
          Take[proc, -2]; 
g = 
          gltyp[x, n]; 
vn = 
          v[n] /. Solve[Eliminate[g, p[n]], 
                v[n]][[1]]; 
pn = (p[
                  n] /. Solve[ausw[g, n], p[n]][[1]]) /. 
            v[n] -> vn; 
{g, pn, 
          vn}
]

Zur Berechnung der interessierenden Grössen

Clear[calc];
\(calc[func_, proc_, arg_] := 
      Module[{g, pg, x}, 
pg = 
          Table[0, {Length[proc]}]; 
g = 
          Table[Take[arg, {j, j + 1}], {j, 1, 
              Length[arg] - 1}]; 
Do[
x = 
            proc[\([i]\)]; 
Which[
x === 
              p, pg = ReplacePart[pg, uu[func, p, g[\([i]\)]], 
                i], 
x === V, 
            pg = ReplacePart[pg, uu[func, v, g[\([i]\)]], 
                i], 
x === T, 
            pg = ReplacePart[pg, uu[func, t, g[\([i]\)]], 
                i], 
x === Q, 
            pg = ReplacePart[pg, uu[func, q, g[\([i]\)]], 
                i], 
True, 
            Print[" No approriate equation for ", 
              x, " available"]
], 
{i, 1, Length[proc]}]; 
pg]\)

way[
        proc_]:=Module[{},

]

rrr = {k > 0 && p[1] > 0 && p[2] > 0 && p[3] > 0 && v[1] > 0 && 
          v[2] > 0 && v[3] > 0}

Die Prozesse mit drei Schritten

r1 = f1[ppm, 3]

und nach Beseitigung der Rotationsäquivalenzen

r2 = purge[r1]

test = r2[[1]]

Ein Beispiel zur Erzeugung eines Weges mit der Funktion "smile" ausgehend von { p1, V1, T1 }

weg[test, {p1, v1, t1}, smile]

Zur Demo wird Test erweitert

test = Join[test, {Q}]

Hier wird der Weg mit den Prozessgleichungen ffp etc erzeugt.

ww = weg[test, {p[1], v[1], t[1]}, ff]

Nun müssen p4 und V4 so bestimmt werden, dass im letzten Schritt der Ausgangspunkt wieder erreicht wird. Aber erst eine Demo von closing:

closing[{p, T, V, p, Q, T}]

cc = closing[test]

Die mit closing ermittelten Werte werden eingesetzt und p5 und V5 auf p1 und V1 gesetzt

w1 = 
      ww /. {p[Length[test]] -> cc[[2]], 
          v[Length[test]] -> cc[[3]], 
          p[Length[test] + 1] -> p[1], 
          v[Length[test] + 1] -> v[1]}

Ausdrücke in w1 sollen vereinfacht werden. Dazu wird eine Vereinfachungsfunktion auf die einzelnen Elemente angewendet. Wie das funktioniert, zeigt ein Beispiel mit fff:

w2 = Map[fff, w1, {2}]

w2 = Map[FullSimplify[PowerExpand[#]] &, w1, {2}]

w3 = endweg[w2]

s = calc[entropy, test, w3]
st = FullSimplify[PowerExpand[Plus @@ s]]
st /. {k -> (cv + R)/cv} // FullSimplify

Und das Ganze zusammen auf einmal

nn = 8;
test = r2[[nn]]
test = {T, Q, T, Q}
ww = weg[test, {p[1], v[1], t[1]}, ff];
cc = closing[test];
w1 = 
        ww /. {p[Length[test]] -> cc[[2]], 
            v[Length[test]] -> cc[[3]], 
            p[Length[test] + 1] -> p[1], 
            v[Length[test] + 1] -> v[1]};
w2 = 
        Map[FullSimplify[PowerExpand[#]] &, 
          w1, {2}];
w3 = endweg[w2];
Print["Points of Cycle"]
Do[Print[" ", i, ")  ", w3[[i]]], {i, 1, 
        Length[w3]}]
Print["Entropy"]
s = calc[entropy, test, w3]
s = FullSimplify[PowerExpand[#]] & /@ 
        calc[entropy, test, w3]
st = FullSimplify[PowerExpand[Plus @@ s]]
st /. {k -> (cv + R)/
              cv}//FullSimplify

Zur konkreten Darstellung eines Kreisprozesses müssen alle Grössen konkretisiert werden. Dies geschieht über die Variable werte.

werte = {p[1] -> 8. , v[1] -> 3. , t[1] -> 10. , 
        v[2] -> 3.5, v[3] -> 5.5, 
        k -> 4.6}
w4 = w3 /. werte
gr = gg[{T, Q, T, Q}, w4]
Show[gr, DisplayFunction -> $DisplayFunction]