diff options
author | Erich Eckner <git@eckner.net> | 2022-01-13 21:01:06 +0100 |
---|---|---|
committer | Erich Eckner <git@eckner.net> | 2022-01-13 21:01:06 +0100 |
commit | fe55b7d37bcd7027dc77d03fd51f51d443db54ba (patch) | |
tree | 05766fbc07d84e7b5bd0b46c789641cf73df6660 | |
download | weihnachtsstern-fe55b7d37bcd7027dc77d03fd51f51d443db54ba.tar.xz |
-rw-r--r-- | .gitignore | 7 | ||||
-rw-r--r-- | unit1.lfm | 165 | ||||
-rw-r--r-- | unit1.pas | 1125 | ||||
-rw-r--r-- | unit2.lfm | 18 | ||||
-rw-r--r-- | unit2.pas | 38 | ||||
-rw-r--r-- | vecmath.pas | 538 | ||||
-rw-r--r-- | weihnachtsstern.ico | bin | 0 -> 137040 bytes | |||
-rw-r--r-- | weihnachtsstern.lpi | 91 | ||||
-rw-r--r-- | weihnachtsstern.lpr | 23 | ||||
-rw-r--r-- | weihnachtsstern.lps | 176 | ||||
-rw-r--r-- | weihnachtsstern.res | bin | 0 -> 139052 bytes |
11 files changed, 2181 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3baa84a --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +*.bak +*.ppu +*.o +*.tar.gz +*~ +weihnachtsstern +lib diff --git a/unit1.lfm b/unit1.lfm new file mode 100644 index 0000000..a5e7184 --- /dev/null +++ b/unit1.lfm @@ -0,0 +1,165 @@ +object Form1: TForm1 + Left = 93 + Height = 551 + Top = 315 + Width = 1225 + Caption = 'Form1' + ClientHeight = 551 + ClientWidth = 1225 + Color = clBtnFace + DesignTimePPI = 107 + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + OnActivate = FormActivate + OnCreate = FormCreate + OnDestroy = FormDestroy + OnResize = FormResize + LCLVersion = '2.0.12.0' + object Image1: TImage + Left = 276 + Height = 438 + Top = 45 + Width = 465 + end + object Image2: TImage + Left = 740 + Height = 438 + Top = 45 + Width = 465 + end + object Label1: TLabel + Left = 9 + Height = 13 + Top = 7 + Width = 48 + Caption = 'Drehen:' + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + ParentColor = False + ParentFont = False + end + object Image3: TImage + Tag = -1 + Left = 0 + Height = 331 + Top = 152 + Width = 278 + OnMouseDown = Image3MouseDown + OnMouseMove = Image3MouseMove + OnMouseUp = Image3MouseUp + end + object RadioGroup1: TRadioGroup + Left = 0 + Height = 55 + Top = 36 + Width = 206 + AutoFill = True + Caption = 'Körper' + ChildSizing.LeftRightSpacing = 6 + ChildSizing.EnlargeHorizontal = crsHomogenousChildResize + ChildSizing.EnlargeVertical = crsHomogenousChildResize + ChildSizing.ShrinkHorizontal = crsScaleChilds + ChildSizing.ShrinkVertical = crsScaleChilds + ChildSizing.Layout = cclLeftToRightThenTopToBottom + ChildSizing.ControlsPerLine = 1 + ClientHeight = 38 + ClientWidth = 202 + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + ItemIndex = 0 + Items.Strings = ( + 'Deltoidalhexakontaederstern' + 'Pentagonhexakontaederstern' + ) + OnClick = RadioGroup1Click + ParentFont = False + TabOrder = 0 + end + object CheckBox1: TCheckBox + Left = 62 + Height = 21 + Top = 6 + Width = 98 + Caption = 'automatisch' + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + OnClick = CheckBox1Click + ParentFont = False + TabOrder = 1 + end + object Button1: TButton + Left = 9 + Height = 28 + Top = 107 + Width = 84 + Caption = 'Spitze' + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + OnClick = Button1Click + ParentFont = False + TabOrder = 2 + end + object Button2: TButton + Left = 98 + Height = 28 + Top = 107 + Width = 99 + Caption = 'Determinante' + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + OnClick = Button2Click + ParentFont = False + TabOrder = 3 + end + object Button3: TButton + Left = 169 + Height = 28 + Top = 0 + Width = 126 + Caption = 'Spitzen entfernen' + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + OnClick = Button3Click + ParentFont = False + TabOrder = 4 + end + object ProgressBar1: TProgressBar + Left = 303 + Height = 18 + Top = 4 + Width = 233 + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + ParentFont = False + Smooth = True + TabOrder = 5 + Visible = False + end + object Button4: TButton + Left = 205 + Height = 28 + Top = 107 + Width = 64 + Caption = 'Test' + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'MS Sans Serif' + OnClick = Button4Click + ParentFont = False + TabOrder = 6 + end + object ZeichenTimer: TTimer + Enabled = False + Interval = 50 + OnTimer = ZeichenTimerTimer + Top = 27 + end +end diff --git a/unit1.pas b/unit1.pas new file mode 100644 index 0000000..f098124 --- /dev/null +++ b/unit1.pas @@ -0,0 +1,1125 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, + ComCtrls, vecMath, Math; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Button3: TButton; + Button4: TButton; + CheckBox1: TCheckBox; + Image1: TImage; + Image2: TImage; + Image3: TImage; + Label1: TLabel; + ProgressBar1: TProgressBar; + RadioGroup1: TRadioGroup; + ZeichenTimer: TTimer; + procedure FormActivate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure ZeichenTimerTimer(Sender: TObject); + procedure CheckBox1Click(Sender: TObject); + procedure CheckBox2Click(Sender: TObject); + procedure Image3MouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Image3MouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Image3MouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure FormResize(Sender: TObject); + procedure RadioGroup1Click(Sender: TObject); + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + private + + public + Dim,Koerp: Integer; + Kanten: array of TPoint; + Ecken: array of TMatrix; + ProjektionL, + ProjektionR, + Rotation, + Beschl,Rot: TMatrix; + Zoom: extended; + + procedure Drehen; + procedure BeschlBelegen; + procedure RotationInitialisieren; + procedure ProjektionenBelegen; + procedure KoerperErzeugen; + procedure Zeichnen; + procedure KantenZeichnen(Pte: array of TPoint; PZ: array of extended; drawZ: boolean; drawTo: TCanvas); + procedure drawColoredLine(wo: TCanvas; X1,Y1: Integer; Z1: extended; X2,Y2: Integer; Z2: Extended); + function farbVerlauf(x: Extended): TColor; + procedure SetZoom; + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +uses + unit2; + +procedure TForm1.FormActivate(Sender: TObject); +begin + Dim:=3; + Koerp:=-1; + RadioGroup1.OnClick(Sender); +end; + +procedure TForm1.FormDestroy(Sender: TObject); +var i: integer; +begin + for i:=0 to length(Ecken)-1 do + Ecken[i].destroy; + ProjektionL.destroy; + ProjektionR.destroy; + Rotation.destroy; + Rot.destroy; + Beschl.destroy; +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + setlength(Ecken,0); + ProjektionL:=TMatrix.create; + ProjektionR:=TMatrix.create; + Rotation:=TMatrix.create; + Rot:=TMatrix.create; + Beschl:=TMatrix.create; +end; + +procedure TForm1.ZeichenTimerTimer(Sender: TObject); +var i: integer; +begin + Zeichnen; + for i:=0 to ZeichenTimer.Interval div 10 do + begin + Drehen; + BeschlBelegen; + end; +end; + +procedure TForm1.ProjektionenBelegen; +var z,s: integer; + tmp: TMatrix; +const alpha = 2*pi/360 * 10; +begin + ProjektionL.destroy; + ProjektionL:=TMatrix.create; + ProjektionL.xdim:=4; + ProjektionL.ydim:=3; + for z:=0 to 2 do + for s:=0 to 3 do + ProjektionL.a[z,s]:=byte(z=s); + + ProjektionR.destroy; + ProjektionR:=TMatrix.create; + ProjektionR.xdim:=4; + ProjektionR.ydim:=4; + ProjektionR.assign0; + ProjektionR.a[0,0]:=cos(alpha); + ProjektionR.a[0,2]:=sin(alpha); + ProjektionR.a[3,0]:=-sin(alpha); + ProjektionR.a[3,2]:=cos(alpha); + ProjektionR.a[1,1]:=1; + ProjektionR.a[2,3]:=1; + + ProjektionR._times(ProjektionL); + + tmp:=TMatrix.create; + tmp.xdim:=dim; + tmp.ydim:=4; + for s:=0 to dim-1 do + for z:=0 to 3 do + tmp.a[z,s]:=byte(z=s); + + ProjektionR.times_(tmp); + ProjektionL.times_(tmp); +end; + +procedure TForm1.KoerperErzeugen; +function spiegleKante(Knr,Enr: integer; N: TMatrix): integer; +var Es: array[boolean] of integer; + i: integer; + M,O: TMatrix; + bol,nk: boolean; + tmp: extended; +begin + M:=TMatrix.create; + O:=TMatrix.create; + Es[false]:=Kanten[Knr].x; + Es[true]:=Kanten[Knr].y; + for bol:=false to true do begin + M.assign(Ecken[Enr]); + M.minus(Ecken[Es[bol]]); + M.transp; + M.times_(N); + tmp:=M.a[0,0]; + M.assign(N); + M.times(2*tmp); + M.plus(Ecken[Es[bol]]); + tmp:=1; + for i:=0 to length(Ecken)-1 do begin + O.assign(M); + O.minus(Ecken[i]); + tmp:=min(tmp,O.len); + end; + if tmp>1e-6 then begin + Es[bol]:=length(Ecken); + setlength(Ecken,length(Ecken)+1); + Ecken[Es[bol]]:=TMatrix.create; + Ecken[Es[bol]].assign(M); + end + else begin + for i:=0 to length(Ecken)-1 do begin + O.assign(M); + O.minus(Ecken[i]); + if O.len <=1.1e-6 then begin + Es[bol]:=i; + break; + end; + end; + end; + end; + result:=-1; + nk:=true; + for i:=0 to length(kanten)-1 do + nk:=nk and ((Kanten[i].x<>Es[false]) or (Kanten[i].y<>Es[true])) + and ((Kanten[i].y<>Es[false]) or (Kanten[i].x<>Es[true])); + if nk then begin + setlength(Kanten,length(Kanten)+1); + Kanten[length(Kanten)-1].x:=Es[false]; + Kanten[length(Kanten)-1].y:=Es[true]; + result:=length(Kanten)-1; + end + else + for i:=0 to length(kanten)-1 do begin + if (Kanten[i].x=Es[false]) and (Kanten[i].y=Es[true]) then result:=i; + if (Kanten[i].y=Es[false]) and (Kanten[i].x=Es[true]) then result:=i; + end; + M.destroy; + O.destroy; +end; + +var ral: array of array[boolean] of TMatrix; + +procedure rotierePunkt(Quelle: TMatrix; Achse: integer; umNull: boolean; var Ziel: TMatrix); +var tang,otang: TMatrix; + tmp: extended; +begin + Ziel.assign(Quelle); + if ral[Achse,true].len<1e-6 then exit; + if not umNull then Ziel.minus(ral[Achse,false]); + tang:=TMatrix.create; + otang:=TMatrix.create; + tang.assign(Ziel); + Ziel.transp; + Ziel.times_(ral[Achse,true]); + tmp:=Ziel.a[0,0]; + Ziel.assign(ral[Achse,true]); + Ziel.times(tmp/sqr(ral[Achse,true].len)); + tang.minus(Ziel); + if tang.len<1e-6 then begin + if not umNull then Ziel.plus(ral[Achse,false]); + tang.destroy; + otang.destroy; + exit; + end; + otang.assign(ral[Achse,true]); + otang.cross(tang); + otang.times(tang.len/otang.len*sin(ral[Achse,true].len)); + tang.times(cos(ral[Achse,true].len)); + Ziel.plus(tang); + Ziel.plus(otang); + if not umNull then Ziel.plus(ral[Achse,false]); + tang.destroy; + otang.destroy; +end; + +procedure rotiereKante(Kante,Achse: integer); +var M,N: TMatrix; + Es: array[boolean] of integer; + bol,gef: boolean; + i: integer; +begin + M:=TMatrix.create; + N:=TMatrix.create; + Es[false]:=Kanten[Kante].x; + Es[true]:=Kanten[Kante].y; + for bol:=false to true do begin + rotierePunkt(Ecken[Es[bol]],Achse,false,M); + gef:=false; + for i:=0 to length(Ecken)-1 do begin + N.assign(M); + N.minus(Ecken[i]); + if N.len<1e-6 then begin + gef:=true; + Es[bol]:=i; + break; + end; + end; + if not gef then begin + setlength(Ecken,length(Ecken)+1); + Ecken[length(Ecken)-1]:=TMatrix.create; + Ecken[length(Ecken)-1].assign(M); + Es[bol]:=length(Ecken)-1; + end; + end; + gef:=false; + for i:=0 to length(Kanten)-1 do + gef:=gef or ((Kanten[i].x=Es[false]) and (Kanten[i].y=Es[true])) or + ((Kanten[i].y=Es[false]) and (Kanten[i].x=Es[true])); + if not gef then begin + setlength(Kanten,length(Kanten)+1); + Kanten[length(Kanten)-1].x:=Es[false]; + Kanten[length(Kanten)-1].y:=Es[true]; + end; + + M.destroy; + N.destroy; +end; + +var skl: array of TPoint; + i,j,k: integer; + M,N: TMatrix; + nsa,bol: boolean; + b,d,f,t,phi,tmp: extended; +begin + case Koerp of + 0: + begin + if dim<>3 then exit; +// b:=3/22*(7-sqrt(5)); // kurze Seite (lange Seite=1) + d:=3*sqrt((5-sqrt(5))/20); // kurze Diagonale + f:=1/11*sqrt((470+156*sqrt(5))/5); // lange Diagonale + + Setlength(Ecken,16); + for i:=0 to length(Ecken)-1 do begin + Ecken[i]:=TMatrix.create; + Ecken[i].xdim:=1; + Ecken[i].ydim:=dim; + end; + Setlength(Kanten,35); + for i:=0 to length(Kanten)-1 do + Kanten[i].x:=-1; + Ecken[0].a[0,0]:=0; + Ecken[0].a[1,0]:=0; + Ecken[0].a[2,0]:=sqrt(1-sqr(d*cos(pi/5)/sin(2*pi/5))); // die berechnete Höhe + for i:=0 to 4 do begin + Ecken[i+1].a[0,0]:=cos(2*pi/5*i)*d*cos(pi/5)/sin(2*pi/5); + Ecken[i+1].a[1,0]:=sin(2*pi/5*i)*d*cos(pi/5)/sin(2*pi/5); + Ecken[i+1].a[2,0]:=0; + end; + M:=TMatrix.create; + M.xdim:=1; + M.ydim:=dim; + N:=TMatrix.create; + N.xdim:=1; + N.ydim:=dim; + for i:=0 to 4 do begin + Ecken[i+6].assign(Ecken[i+1]); + Ecken[i+6].plus(Ecken[(i+1) mod 5 +1]); + Ecken[i+6].times(-1/2); + Ecken[i+6].plus(Ecken[0]); + Ecken[i+6].times(-f/Ecken[i+6].len); + Ecken[i+6].plus(Ecken[0]); + Ecken[i+11].assign(Ecken[0]); + M.assign(Ecken[i+6]); + Ecken[i+11].times(0.5); + M.times(0.5); + Ecken[i+11].plus(M); + M.assign(Ecken[i+1]); + M.minus(Ecken[0]); + N.assign(Ecken[(i+1) mod 5+1]); + N.minus(Ecken[0]); + M.cross(N); + M.times(3/M.len); + Ecken[i+11].plus(M); + end; + for i:=0 to 4 do begin + Kanten[i].x:=0; + Kanten[i].y:=i+1; + Kanten[i+5].x:=i+1; + Kanten[i+5].y:=i+6; + Kanten[i+10].x:=i+6; + Kanten[i+10].y:=(i+1) mod 5 +1; + Kanten[i+15].x:=i+11; + Kanten[i+15].y:=0; + Kanten[i+20].x:=i+11; + Kanten[i+20].y:=i+1; + Kanten[i+25].x:=i+11; + Kanten[i+25].y:=i+6; + Kanten[i+30].x:=i+11; + Kanten[i+30].y:=(i+1) mod 5 +1; + end; + + setlength(skl,5); + for i:=0 to 4 do begin + skl[i].x:=i+5; + skl[i].y:=(i+4) mod 5+10; + end; + + repeat + nsa:=false; + i:=length(skl)-1; + while i>=0 do begin + M.assign(Ecken[Kanten[skl[i].x].x]); + M.minus(Ecken[Kanten[skl[i].x].y]); + N.assign(Ecken[Kanten[skl[i].y].x]); + N.minus(Ecken[Kanten[skl[i].y].y]); + N.cross(M); + N.times(1/N.len); + j:=length(skl)-1; + while j>=0 do begin + setlength(skl,length(skl)+1); + skl[length(skl)-1].x:=spiegleKante(skl[j].x,Kanten[skl[i].x].x,N); + skl[length(skl)-1].y:=spiegleKante(skl[j].y,Kanten[skl[i].x].x,N); + bol:=false; + for k:=0 to length(skl)-2 do + bol:=bol or ((skl[length(skl)-1].x=skl[k].x) and + (skl[length(skl)-1].y=skl[k].y)) or + ((skl[length(skl)-1].y=skl[k].x) and + (skl[length(skl)-1].x=skl[k].y)); + if bol then setlength(skl,length(skl)-1) + else nsa:=true; + dec(j); + end; + dec(i); + end; + until not nsa; + + for i:=0 to length(skl)-1 do begin + M.assign(Ecken[Kanten[skl[i].x].x]); + M.minus(Ecken[Kanten[skl[i].x].y]); + N.assign(Ecken[Kanten[skl[i].y].x]); + N.minus(Ecken[Kanten[skl[i].y].y]); + N.cross(M); + N.times(1/N.len); + j:=length(Kanten)-1; + while j>=0 do begin + spiegleKante(j,Kanten[skl[i].x].x,N); + dec(j); + end; + end; + M.destroy; + N.destroy; + end; + 1: + begin + if dim<>3 then exit; + phi:=(sqrt(5)+1)/2; + t:=1/12*(power(44+12*phi*(9+sqrt(81*phi-15)),1/3)+power(44+12*phi*(9-sqrt(81*phi-15)),1/3)-4); + b:=2*(1-2*sqr(t))/(1+2*t); // kurze Seite (lange Seite=1) + d:=2*(1-2*sqr(t)); // Diagonale + f:=sqrt(b*(b+d)); // (ganz) kurze Diagonale + + Setlength(Ecken,21); + for i:=0 to length(Ecken)-1 do begin + Ecken[i]:=TMatrix.create; + Ecken[i].xdim:=1; + Ecken[i].ydim:=dim; + end; + Setlength(Kanten,45); + for i:=0 to length(Kanten)-1 do + Kanten[i].x:=-1; + Ecken[0].a[0,0]:=0; + Ecken[0].a[1,0]:=0; + Ecken[0].a[2,0]:=sqrt(1-sqr(d*cos(pi/5)/sin(2*pi/5))); // die berechnete Höhe + for i:=0 to 4 do begin + Ecken[i+1].a[0,0]:=cos(2*pi/5*i)*d*cos(pi/5)/sin(2*pi/5); + Ecken[i+1].a[1,0]:=sin(2*pi/5*i)*d*cos(pi/5)/sin(2*pi/5); + Ecken[i+1].a[2,0]:=0; + end; + M:=TMatrix.create; + M.xdim:=1; + M.ydim:=dim; + N:=TMatrix.create; + N.xdim:=1; + N.ydim:=dim; + for i:=0 to 4 do begin + Ecken[i+6].assign(Ecken[i+1]); + Ecken[i+6].plus(Ecken[(i+1) mod 5 +1]); + Ecken[i+6].times(1/2); + Ecken[i+6].minus(Ecken[0]); + Ecken[i+6].times(sqrt(sqr(b)-sqr((d-b)/2))/Ecken[i+6].len); + N.assign(Ecken[(i+1) mod 5 +1]); + N.minus(Ecken[i+1]); + N.times((d-b)/2/N.len); + Ecken[i+6].plus(N); + Ecken[i+6].plus(Ecken[i+1]); + N.times(b/N.len); + Ecken[i+11].assign(Ecken[i+6]); + Ecken[i+11].plus(N); + M.assign(Ecken[i+6]); + M.plus(Ecken[i+11]); + M.times(0.3); + Ecken[i+16].assign(Ecken[0]); + Ecken[i+16].times(0.7); + Ecken[i+16].plus(M); + M.assign(Ecken[i+1]); + M.minus(Ecken[0]); + N.assign(Ecken[(i+1) mod 5 +1]); + N.minus(Ecken[0]); + M.cross(N); + M.times(3/M.len); + Ecken[i+16].Plus(M); + end; + for i:=0 to 4 do begin + Kanten[i].x:=0; + Kanten[i].y:=i+1; + Kanten[i+5].x:=i+1; + Kanten[i+5].y:=i+6; + Kanten[i+10].x:=i+6; + Kanten[i+10].y:=i+11; + Kanten[i+15].x:=i+11; + Kanten[i+15].y:=(i+1) mod 5 +1; + Kanten[i+20].x:=0; + Kanten[i+20].y:=i+16; + Kanten[i+25].x:=i+1; + Kanten[i+25].y:=i+16; + Kanten[i+30].x:=i+6; + Kanten[i+30].y:=i+16; + Kanten[i+35].x:=i+11; + Kanten[i+35].y:=i+16; + Kanten[i+40].x:=(i+1) mod 5 +6; + Kanten[i+40].y:=i+16; + end; + + setlength(ral,2); + for i:=0 to 3 do + ral[i div 2,odd(i)]:=TMatrix.create; + ral[0,false].assign(Ecken[0]); // die 5er-Symmetrieachse + ral[0,true].assign(Ecken[0]); + ral[0,true].times(2*pi/5/ral[0,true].len); + + ral[1,false].assign(Ecken[6]); // die 3er-Symmetrieachse + tmp:=arccos((sqrt(3)/6*f)/sqrt(sqr(b)-sqr(f/2))); // Kippwinkel der Rotationsachse gegenüber Flächennormale + ral[1,true].assign(Ecken[1]); + ral[1,true].plus(Ecken[11]); + ral[1,true].times(-1/2); + ral[1,true].plus(Ecken[6]); + ral[1,true].times(1/ral[1,true].len); + N.assign(Ecken[1]); + N.minus(Ecken[11]); + N.cross(ral[1,true]); + N.times(1/N.len); + ral[1,true].times(sin(tmp)); + N.times(cos(tmp)); + ral[1,true].plus(N); + ral[1,true].times(2*pi/3/ral[1,true].len); + + repeat + nsa:=false; + i:=length(ral)-1; + while i>=0 do begin + j:=length(ral)-1; + while j>=0 do begin + setlength(ral,length(ral)+1); + for bol:=false to true do begin + ral[length(ral)-1,bol]:=TMatrix.create; + rotierePunkt(ral[j,bol],i,bol,ral[length(ral)-1,bol]); + end; + bol:=false; + for k:=0 to length(ral)-2 do begin + M.assign(ral[k,false]); + M.minus(ral[length(ral)-1,false]); + if M.len<1e-6 then begin + M.assign(ral[k,true]); + M.minus(ral[length(ral)-1,true]); + if M.len<1e-6 then begin + bol:=true; + break; + end; + end; + end; + if bol then begin + ral[length(ral)-1,false].destroy; + ral[length(ral)-1,true].destroy; + setlength(ral,length(ral)-1); + end + else nsa:=true; + dec(j); + end; + dec(i); + end; + until not nsa; + + for i:=0 to length(ral)-1 do begin + j:=length(Kanten)-1; + while j>=0 do begin + rotiereKante(j,i); + dec(j); + end; + end; + + for i:=0 to 2*length(ral)-1 do + ral[i div 2,odd(i)].destroy; + setlength(ral,0); + + + M.destroy; + N.destroy; + end; + end{of Case}; + M:=TMatrix.create; + M.assign0; + for i:=0 to length(Ecken)-1 do + M.plus(Ecken[i]); + M.times(-1/length(Ecken)); + for i:=0 to length(Ecken)-1 do + Ecken[i].plus(M); + b:=0; + for i:=0 to length(Ecken)-1 do + b:=max(b,Ecken[i].len); + for i:=0 to length(Ecken)-1 do + Ecken[i].times(1/2/b); + M.Destroy; + + for i:=0 to length(Kanten)-1 do + if Kanten[i].x>Kanten[i].y then begin + j:=Kanten[i].x; + Kanten[i].x:=Kanten[i].y; + Kanten[i].y:=j; + end; + + for i:=0 to length(Kanten)-2 do begin + j:=i; + for k:=i+1 to length(Kanten)-1 do + if (Kanten[k].x<Kanten[j].x) or + ((Kanten[k].x=Kanten[j].x) and + (Kanten[k].y<Kanten[j].y)) then + j:=k; + if j>i then begin + k:=Kanten[j].x; + Kanten[j].x:=Kanten[i].x; + Kanten[i].x:=k; + k:=Kanten[j].y; + Kanten[j].y:=Kanten[i].y; + Kanten[i].y:=k; + end; + end; + + SetZoom; +end; + +procedure TForm1.CheckBox1Click(Sender: TObject); +begin + ZeichenTimer.Enabled:=Checkbox1.Checked; + Image3.Visible:=not Checkbox1.Checked; +end; + +procedure TForm1.CheckBox2Click(Sender: TObject); +begin + ZeichenTimer.Interval:=30; +end; + +procedure TForm1.KantenZeichnen(Pte: array of TPoint; PZ: array of extended; drawZ: boolean; drawTo: TCanvas); +var i: integer; +begin + if drawZ then + begin + for i:=0 to length(Kanten)-1 do + drawColoredLine(drawto,Pte[Kanten[i].X].X,Pte[Kanten[i].X].Y,PZ[Kanten[i].X], + Pte[Kanten[i].Y].X,Pte[Kanten[i].Y].Y,PZ[Kanten[i].Y]); + end + else + begin + for i:=0 to length(Kanten)-1 do + begin + drawto.MoveTo(Pte[Kanten[i].X].X,Pte[Kanten[i].X].Y); + drawto.LineTo(Pte[Kanten[i].Y].X,Pte[Kanten[i].Y].Y); + end; + end; +end; + +procedure TForm1.drawColoredLine(wo: TCanvas; X1,Y1: Integer; Z1: extended; X2,Y2: Integer; Z2: Extended); +var i: integer; + a,b,az,bz: extended; +begin + if abs(X2-X1)>abs(Y1-Y2) then + begin + a:=(Y1-Y2)/(X1-X2); + b:=Y1-X1*a; + az:=(Z1-Z2)/(X1-X2); + bz:=Z1-X1*az; + if X1<X2 then + begin + for I:=X1 to X2 do + wo.Pixels[I,round(I*a + b)]:=farbVerlauf(I*az + bz); + end + else + begin + for I:=X2 to X1 do + wo.Pixels[I,round(I*a + b)]:=farbVerlauf(I*az + bz); + end; + end + else + begin + if Y1=Y2 then exit; + a:=(X1-X2)/(Y1-Y2); + b:=X1-Y1*a; + az:=(Z1-Z2)/(Y1-Y2); + bz:=Z1-Y1*az; + if Y1<Y2 then + begin + for I:=Y1 to Y2 do + wo.Pixels[round(I*a + b),I]:=farbVerlauf(I*az + bz); + end + else + begin + for I:=Y2 to Y1 do + wo.Pixels[round(I*a + b),I]:=farbVerlauf(I*az + bz); + end + end; +end; + +function TForm1.farbVerlauf(x: Extended): TColor; +begin + x:=5*x; + if x<1 then + begin + result:=min($FF,max($0,round($FF*x))) shl 16; + exit; + end; + x:=x-1; + if x<1 then + begin + result:=(min($FF,max($0,round($FF*(1-x)))) shl 16) or + (min($FF,max($0,round($FF*x))) shl 8); + exit; + end; + x:=x-1; + if x<1 then + begin + result:=$00FF00 or + min($FF,max($0,round($FF*x))); + exit; + end; + x:=x-1; + if x<1 then + begin + result:=$0000FF or + (min($FF,max($0,round($FF*(1-x)))) shl 8); + exit; + end; + x:=x-1; + result:=$0000FF or + (min($FF,max($0,round($FF*x))) shl 16); +end; + +procedure TForm1.RotationInitialisieren; +var z,s: integer; +begin + Rot.xdim:=dim; + Rot.ydim:=dim; + repeat + for z:=0 to dim-1 do + for s:=0 to dim-1 do + Rot.a[z,s]:=0.01*random; + Rotation.assignId(dim); + Rotation.plus(Rot); + until Rotation.det>0; +end; + +procedure TForm1.BeschlBelegen; +var z,s: integer; + M: TMatrix; +begin + M:=TMatrix.create; + M.xdim:=dim; + M.ydim:=dim; + repeat + for z:=0 to dim-1 do + for s:=0 to dim-1 do + M.a[z,s]:=0.02*random; + Beschl.assignId(dim); + Beschl.plus(M); + until Beschl.det>0; + Beschl.orthogonalize(true); + M.destroy; +end; + +procedure TForm1.Drehen; +begin + Rotation.assignId(dim); + Rotation.plus(Rot); + Rotation.orthogonalize(true); + Rot.times_(Beschl); + ProjektionL.times_(Rotation); + ProjektionR.times_(Rotation); +end; + +procedure TForm1.Image3MouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + Image3.Tag:=floor(Y*dim*(dim-1)/2/Image3.Height)+ + X*((dim*(dim-1)) div 2); +end; + +procedure TForm1.Image3MouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + Image3.Tag:=-1; +end; + +procedure TForm1.Image3MouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +var M: TMatrix; + a1,a2: integer; +const alpha = 2*pi/360 * 1; +begin + if not(ssLeft in Shift) then exit; + Y:=Image3.Tag mod ((dim*(dim-1)) div 2); + X:=X - (Image3.Tag div ((dim*(dim-1)) div 2)); + Image3.Tag:=Image3.Tag + X*((dim*(dim-1)) div 2); + M:=TMatrix.create; + M.assignId(dim); + a1:=0; + while Y>=0 do + begin + inc(a1); + Y:=Y-dim+a1; + end; + a2:=Y+dim; + dec(a1); + M.a[a1,a1]:=cos(alpha*X); + M.a[a1,a2]:=sin(alpha*X); + M.a[a2,a1]:=-sin(alpha*X); + M.a[a2,a2]:=cos(alpha*X); + ProjektionR.times_(M); + ProjektionL.times_(M); + M.destroy; + Zeichnen; +end; + +procedure TForm1.Zeichnen; +var Pkt: TMatrix; + Pkte: array[boolean] of array of TPoint; + PZ: array of extended; + i: integer; + b: boolean; + mi,ma: extended; +begin + if length(Ecken)=0 then + exit; + setlength(Pkte[false],length(Ecken)); + setlength(Pkte[true],length(Ecken)); + setlength(PZ,length(Ecken)); + for i:=0 to length(Pkte[false])-1 do + for b:=false to true do + begin + Pkt:=Ecken[i].duplicate; + if B then Pkt._times(ProjektionR) + else Pkt._times(ProjektionL); + PZ[i]:=Pkt.a[2,0]; + Pkte[b,i]:=Pkt.asPoint(Zoom); + Pkte[b,i].x:=Pkte[b,i].x + Image1.Width div 2; + Pkte[b,i].y:=Pkte[b,i].y + Image1.Height div 2; + Pkt.destroy; + end; + mi:=PZ[0]; + ma:=PZ[0]; + for i:=0 to length(PZ)-1 do + begin + mi:=min(mi,PZ[i]); + ma:=max(ma,PZ[i]); + end; + ma:=max(ma,mi+0.00001); + for i:=0 to length(PZ)-1 do + PZ[i]:=(PZ[i]-mi)/(ma-mi); + Image1.Canvas.Rectangle(-10,-10,Image1.Width+10,Image1.Height+10); + KantenZeichnen(Pkte[true],PZ,false,Image1.Canvas); + Image2.Canvas.Rectangle(-10,-10,Image2.Width+10,Image2.Height+10); + KantenZeichnen(Pkte[false],PZ,false,Image2.Canvas); +end; + +procedure TForm1.FormResize(Sender: TObject); +var L,T: integer; +begin + L:=Image1.Left; + T:=Image1.Top; + Image1.Free; + Image2.Free; + Image1:=TImage.Create(Form1); + Image2:=TImage.Create(Form1); + Image1.Parent:=Form1; + Image2.Parent:=Form1; + Image1.Left:=L; + Image1.Top:=T; + Image2.Top:=T; + Image1.Width:=min(Form1.ClientHeight-Image1.Top,(Form1.ClientWidth-Image1.Left) div 2); + Image1.Height:=Image1.Width; + Image2.Width:=Image1.Width; + Image2.Height:=Image2.Width; + Image2.Left:=Image1.Left+Image1.Width; + Progressbar1.Width:=Form1.Clientwidth-Progressbar1.Left; + SetZoom; + Zeichnen; +end; + +procedure TForm1.SetZoom; +begin + case Koerp of + 0: Zoom:=min(Image1.Width,Image1.Height)*0.9; + 1: Zoom:=min(Image1.Width,Image1.Height)*0.9; + end{of Case}; +end; + +procedure TForm1.RadioGroup1Click(Sender: TObject); +var i: integer; +begin + if Koerp = Radiogroup1.ItemIndex then exit; + Koerp:=RadioGroup1.ItemIndex; + + for i:=0 to length(Ecken)-1 do + Ecken[i].destroy; + ProjektionenBelegen; + RotationInitialisieren; + BeschlBelegen; + KoerperErzeugen; + Image3.Canvas.Brush.Color:=Form1.Color; + Image3.Canvas.Rectangle(-10,-10,Image3.Width+10,Image3.Height+10); + For i:=1 to (dim*(dim-1)) div 2 do + begin + Image3.Canvas.MoveTo(10,round((I-0.5)*(Image3.Height*2/(dim*(dim-1))))); + Image3.Canvas.LineTo(Image3.Width-10,round((I-0.5)*(Image3.Height*2/(dim*(dim-1))))); + end; +// Drehen; +// BeschlBelegen; + Zeichnen; +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + Form2.Showmodal; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var M: TMatrix; + I,J,K,L,N: Longint; + B: Boolean; + Memo1: TMemo; + s: String; + x: extended; + fcs: array of Longint; +begin + M:=TMatrix.create; + M.xdim:=length(Kanten)-3; + for I:=0 to length(Kanten)-1 do begin + B:=Kanten[I].x=Kanten[I].y; + for J:=0 to I-1 do + B:=B or ((Kanten[I].X=Kanten[J].X) and (Kanten[I].Y=Kanten[J].Y)) + or ((Kanten[I].X=Kanten[J].Y) and (Kanten[I].Y=Kanten[J].X)); + if B then M.xdim:=M.xdim-1; + end; + M.ydim:=3*length(Ecken)-9; + if M.xdim<>M.ydim then begin + if MessageDlg( + 'Die Anzahl der Randbedingungen (' + +inttostr(M.xdim)+ + ') unterscheidet sich von der Anzahl der Freiheitsgrade (' + +inttostr(M.ydim)+ + ')! Genauere Erklärung gewünscht?',mterror,[mbYes,mbNo],0) = mrYes then begin + Memo1:=TMemo.Create(Form1); + Memo1.Parent:=Form1; + Memo1.Left:=Image1.Left; + Memo1.Top:=Image1.Top; + Memo1.Width:=Form1.ClientWidth-Memo1.Left; + Memo1.Height:=Form1.ClientHeight-Memo1.Top; + Memo1.Lines.Clear; + x:=0; + for I:=0 to length(Ecken)-1 do + x:=max(x,Ecken[I].len); + s:=''; + for I:=0 to length(Kanten)-1 do + s:=s+' '+inttostr(Kanten[I].x)+'-'+inttostr(Kanten[I].y); + delete(s,1,1); + Memo1.Lines.Add(s); + Memo1.Lines.Add(''); + s:=''; + for I:=0 to length(Ecken)-1 do + if Ecken[I].len>=0.98*x then + s:=s+' '+inttostr(I); + delete(s,1,1); + Memo1.Lines.Add(s); + Memo1.Lines.Add(''); + s:=''; + for I:=0 to length(Kanten)-1 do + if (Ecken[Kanten[I].x].len>=0.98*x) or + (Ecken[Kanten[I].y].len>=0.98*x) then + s:=s+' '+inttostr(Kanten[I].x)+'-'+inttostr(Kanten[I].y); + delete(s,1,1); + Memo1.Lines.Add(s); + Memo1.Lines.Add(''); + s:=''; + for i:=0 to length(Ecken)-1 do + if Ecken[I].len>=0.98*x then begin + s:=s+' '+inttostr(i)+':'; + for j:=0 to length(Kanten)-1 do + if (Kanten[j].x=i) or (Kanten[j].y=i) then + s:=s+inttostr(Kanten[j].x+Kanten[j].y-i)+','; + delete(s,length(s),1); + end; + delete(s,1,1); + Memo1.Lines.Add(s); + Application.ProcessMessages; + MessageDlg('Memo schließen.',mtInformation,[mbOk],0); + Memo1.Free; + end; + exit; + end; + M.assign0; + + case Radiogroup1.ItemIndex of + 0: begin + // Ecken 1,6,11 + setlength(fcs,3); + fcs[0]:=1; + fcs[1]:=6; + fcs[2]:=11; + end; + 1: begin + // Ecken 0,1,16 + setlength(fcs,3); + fcs[0]:=0; + fcs[1]:=1; + fcs[2]:=16; + end; + end{of case}; + + j:=0; + for i:=0 to length(Kanten)-1 do begin + K:=Kanten[i].x; + L:=Kanten[i].y; + for N:=length(fcs)-1 downto 0 do begin + if fcs[N]=K then K:=-1; + if fcs[N]=L then L:=-1; + if K>=fcs[N] then dec(K); + if L>=fcs[N] then dec(L); + end; + if K<>-1 then + for N:=0 to 2 do + M.a[j,3*K+N]:= + M.a[j,3*K+N] + + Ecken[Kanten[i].x].a[N,0] + - Ecken[Kanten[i].y].a[N,0]; + if L<>-1 then + for N:=0 to 2 do + M.a[j,3*L+N]:= + M.a[j,3*L+N] + + Ecken[Kanten[i].y].a[N,0] + - Ecken[Kanten[i].x].a[N,0]; + if (K<>-1) or (L<>-1) then inc(j); + end; + + M.Progressbar:=Progressbar1; + Messagedlg('det M = '+floattostr(M.det(dmGauss)),mtInformation,[mbOk],0); + M.Free; +end; + +procedure TForm1.Button3Click(Sender: TObject); +var I,J,K,L: Longint; + x: extended; +begin + x:=0; + for I:=0 to length(Ecken)-1 do + x:=max(x,Ecken[I].len); + I:=length(Ecken)-1; + while I>=0 do begin + if Ecken[I].len>=0.98*x then begin + for J:=I+1 to length(Ecken)-1 do + Ecken[J-1].assign(Ecken[J]); + Ecken[length(Ecken)-1].Free; + setlength(Ecken,length(Ecken)-1); + J:=length(Kanten)-1; + L:=0; + while J>=0 do begin + if (Kanten[J].x=I) or (Kanten[J].y=I) then begin + inc(L); + for K:=J+1 to length(Kanten)-1 do + Kanten[K-1]:=Kanten[K]; + setlength(Kanten,length(Kanten)-1); + end + else begin + if Kanten[J].x>I then dec(Kanten[J].x); + if Kanten[J].y>I then dec(Kanten[J].y); + end; + dec(J); + end; + if L<>4 then Form1.Caption:=Form1.Caption+' '+inttostr(L); + end; + dec(I); + end; + x:=0; + for I:=0 to length(Ecken)-1 do + x:=max(x,Ecken[I].len); + for i:=0 to length(Ecken)-1 do + Ecken[i].times(1/2/x); + Zeichnen; +end; + +procedure TForm1.Button4Click(Sender: TObject); +const mindim = 4; + maxdim = 9; +var M: TMatrix; + dm: TDetMethode; + I,J,K,L: Longint; + ts,errs: array[mindim..maxdim,TDetMethode] of extended; + t1,t2: extended; + s: string; +begin + M:=TMatrix.create; + t2:=0; + for I:=mindim to maxdim do begin + for dm:=low(dm) to high(dm) do begin + ts[I,dm]:=0; + errs[I,dm]:=0; + end; + for J:=1 to 50 do begin + M.assignId(I); + for K:=0 to I-1 do + for L:=0 to I-1 do + if random*50<=J then + M.a[K,L]:=M.a[K,L]+random-0.5; + for dm:=low(dm) to high(dm) do begin + ts[I,dm]:=ts[I,dm]-now; + t1:=M.det(dm); + ts[I,dm]:=ts[I,dm]+now; + if dm=low(dm) then t2:=t1; + errs[I,dm]:=sqr(t1-t2); + end; + end; + end; + M.Free; + s:=''; + for i:=mindim to maxdim do begin + s:=s+inttostr(i)+': '; + for dm:=low(dm) to high(dm) do + s:=s+floattostr(errs[i,dm])+' '+floattostr(ts[i,dm]*24*60*60)+';'; + delete(s,length(s),1); + s:=s+#13; + end; + delete(s,length(s),1); + Messagedlg(s,mtinformation,[mbOk],0); +end; + +end. + diff --git a/unit2.lfm b/unit2.lfm new file mode 100644 index 0000000..18cdc54 --- /dev/null +++ b/unit2.lfm @@ -0,0 +1,18 @@ +object Form2: TForm2 + Left = 390 + Height = 533 + Top = 355 + Width = 779 + Caption = 'Form2' + ClientHeight = 533 + ClientWidth = 779 + DesignTimePPI = 107 + OnActivate = FormActivate + LCLVersion = '2.0.12.0' + object Image1: TImage + Left = 8 + Height = 472 + Top = 48 + Width = 757 + end +end diff --git a/unit2.pas b/unit2.pas new file mode 100644 index 0000000..a870b32 --- /dev/null +++ b/unit2.pas @@ -0,0 +1,38 @@ +unit Unit2; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls; + +type + + { TForm2 } + + TForm2 = class(TForm) + Image1: TImage; + procedure FormActivate(Sender: TObject); + private + + public + + end; + +var + Form2: TForm2; + +implementation + +{$R *.lfm} + +{ TForm2 } + +procedure TForm2.FormActivate(Sender: TObject); +begin + // +end; + +end. + diff --git a/vecmath.pas b/vecmath.pas new file mode 100644 index 0000000..5e374dd --- /dev/null +++ b/vecmath.pas @@ -0,0 +1,538 @@ +unit vecMath; + +interface + +uses math, Types, SysUtils, ComCtrls; + +Type TDetMethode = (dmLaPlace,dmLaPlace0,dmGauss); + TMatrix = class + private + _zanz,_sanz: integer; + Komps: array of array of extended; // [zeile,spalte] + procedure wsanz(sanz: integer); + procedure wzanz(zanz: integer); + function ra(z,s: integer): extended; + procedure wa(z,s: integer; _a: extended); + function rPart(l,t,r,b: integer): TMatrix; + public + Progressbar: TProgressbar; + property xdim: integer read _sanz + write wsanz; + property ydim: integer read _zanz + write wzanz; + property a[z,s: integer]: extended read ra + write wa; + property part[l,t,r,b: integer]: TMatrix read rPart; + constructor create; + destructor destroy; override; + function asPoint: TPoint; overload; + function asPoint(scale: extended): TPoint; overload; + procedure assign(M: TMatrix); + procedure assignId(dim: integer); + procedure assign0; + function duplicate: TMatrix; + procedure plus(M: TMatrix); + procedure minus(M: TMatrix); + procedure times(x: extended); + procedure times_(R: TMatrix); + procedure _times(L: TMatrix); + procedure cross(M: TMatrix); + function det: extended; overload; + function det(methode: TDetMethode): extended; overload; + function det_laPlace(spare_optimize: boolean): extended; + function det_gauss: extended; + procedure transp; + procedure orthogonalize; overload; + procedure orthogonalize(normalize: boolean); overload; + function len: extended; // only for vectors! + function zlen(z: integer): extended; + function slen(s: integer): extended; + function toStr: string; + function fromString(str: string): boolean; + end; + +implementation + +function istZahl(str: string): boolean; +var hK: boolean; +begin + result:=false; + if length(str)=0 then exit; + hK:=false; + if str[1]='-' then delete(str,1,1); + if length(str)=0 then exit; + if not (str[1] in ['0'..'9']) then exit; + while (length(str)>0) and ((str[1] in ['0'..'9']) or + ((str[1] = ',') and not hK)) do + begin + hK:=hK or (str[1]=','); + delete(str,1,1); + end; + result:=length(str)=0; +end; + +procedure TMatrix.wsanz(sanz: integer); +var i: integer; +begin + if sanz>=0 then _sanz:=sanz; + setlength(Komps,_zanz); + for i:=0 to _zanz-1 do + setlength(Komps[i],_sanz); +end; + +procedure TMatrix.wzanz(zanz: integer); +var i: integer; +begin + if zanz>=0 then _zanz:=zanz; + setlength(Komps,_zanz); + for i:=0 to _zanz-1 do + setlength(Komps[i],_sanz); +end; + +function TMatrix.ra(z,s: integer): extended; +begin + if (z>=0) and (z<_zanz) and + (s>=0) and (s<_sanz) then result:=Komps[z,s] + else result:=0; +end; + +procedure TMatrix.wa(z,s: integer; _a: extended); +begin + if (z>=0) and (z<_zanz) and + (s>=0) and (s<_sanz) then Komps[z,s]:=_a; +end; + +function TMatrix.rPart(l,t,r,b: integer): TMatrix; +var z,s: integer; +begin + l:=max(l,0); + t:=max(t,0); + r:=max(l,r); + b:=max(t,b); + r:=min(r,xdim-1); + b:=min(b,ydim-1); + result:=TMatrix.create; + result.ydim:=b-t+1; + result.xdim:=r-l+1; + for z:=t to b do + for s:=l to r do + result.a[z-t,s-l]:=a[z,s]; +end; + +constructor TMatrix.create; +begin + inherited create; + _zanz:=3; + xdim:=1; + Progressbar:=nil; +end; + +destructor TMatrix.destroy; +begin + inherited destroy; +end; + +function TMatrix.asPoint: TPoint; +begin + result:=asPoint(1); +end; + +function TMatrix.asPoint(scale: extended): TPoint; +begin + if xdim>ydim then result:=Point(round(a[0,0]*scale), + round(a[0,1]*scale)) + else result:=Point(round(a[0,0]*scale), + round(a[1,0]*scale)); +end; + +procedure TMatrix.assign(M: TMatrix); +var z,s: Integer; +begin + ydim:=M.ydim; + xdim:=M.xdim; + for z:=0 to ydim-1 do + for s:=0 to xdim-1 do + a[z,s]:=M.a[z,s]; +end; + +function TMatrix.duplicate: TMatrix; +begin + Result:=TMatrix.create; + Result.assign(self); +end; + +procedure TMatrix.plus(M: TMatrix); +var z,s: Integer; +begin + if (M.xdim = xdim) and + (M.ydim = ydim) then + for z:=0 to ydim-1 do + for s:=0 to xdim-1 do + a[z,s]:=a[z,s]+M.a[z,s]; +end; + +procedure TMatrix.minus(M: TMatrix); +var z,s: Integer; +begin + if (M.xdim = xdim) and + (M.ydim = ydim) then + for z:=0 to ydim-1 do + for s:=0 to xdim-1 do + a[z,s]:=a[z,s]-M.a[z,s]; +end; + +procedure TMatrix.times(x: extended); +var z,s: Integer; +begin + for z:=0 to ydim-1 do + for s:=0 to xdim-1 do + a[z,s]:=x*a[z,s]; +end; + +function TMatrix.det: extended; +begin + result:=det_laPlace(true); +end; + +function TMatrix.det(methode: TDetMethode): extended; +begin + case methode of + dmLaPlace: result:=det_laPlace(false); + dmLaPlace0: result:=det_laPlace(true); + dmGauss: result:=det_gauss; + else result:=-1; + end{of case}; +end; + +function TMatrix.det_laPlace(spare_optimize: boolean): extended; +var p: array of Integer; + i,j,k, + tiefe: Integer; + tmp: extended; + UT: boolean; +begin + result:=0; + if xdim<>ydim then exit; + setlength(p,xdim); + for i:=0 to xdim-1 do + p[i]:=i; + if assigned(Progressbar) then begin + Progressbar.Position:=0; + Progressbar.Min:=0; + Progressbar.Max:=1; + tiefe:=-1; + repeat + inc(tiefe); + i:=0; + for j:=0 to xdim-1 do + if a[tiefe,j]<>0 then inc(i); + Progressbar.Max:= + Progressbar.Max*i; + until (Progressbar.Max>=100) or (tiefe>=xdim-1); + Progressbar.Step:=1; + Progressbar.Visible:=true; + end + else tiefe:=-2; + repeat + tmp:=1; + for i:=0 to xdim-1 do + begin + for j:=i+1 to xdim-1 do + if p[i]>p[j] then tmp:=-tmp; + tmp:=tmp*a[i,p[i]]; + end; + result:=result+tmp; + if spare_optimize then begin + i:=0; + while (i<xdim-1) and (a[i,p[i]]<>0) do + inc(i); + for j:=i+1 to xdim-1 do + p[j]:=-1; + end + else + i:=xdim-1; + UT:=true; + while UT and (i>=0) do + begin + repeat + inc(p[i]); + UT:=spare_optimize and (p[i]<xdim) and (a[i,p[i]]=0); + for j:=0 to i-1 do + UT:=UT or (p[i]=p[j]); + until not UT; + if p[i]>=xdim then + begin + for j:=i to xdim-1 do + p[i]:=-1; + dec(i); + UT:=true; + end; + end; + if i<=tiefe then + Progressbar.StepIt; + if i>=0 then + for j:=i+1 to xdim-1 do + repeat + inc(p[j]); + UT:=false; + for k:=0 to j-1 do + UT:=UT or (p[j]=p[k]); + until not UT; + until UT and (i<0); + if assigned(Progressbar) then + Progressbar.Visible:=false; +end; + +function TMatrix.det_gauss: extended; +var M: TMatrix; + I,J,K: Longint; + tmp,fak: extended; + vz: Longint; +begin + result:=0; + if xdim<>ydim then exit; + M:=TMatrix.create; + M.assign(self); + vz:=1; + for I:=xdim-1 downto 0 do begin + J:=I; + while (J>=0) and (M.a[I,J]=0) do + dec(J); + if J<0 then begin + result:=0; + M.free; + exit; + end; + if J<>I then + for K:=0 to xdim-1 do begin + tmp:=M.a[K,I]; + M.a[K,I]:=M.a[K,J]; + M.a[K,J]:=tmp; + vz:=-vz; + end; + for J:=I-1 downto 0 do begin + fak:=M.a[J,I]/M.a[I,I]; + for K:=0 to xdim-1 do + M.a[J,K]:=M.a[J,K] - fak * M.a[I,K]; + end; + end; + result:=vz; + for I:=0 to xdim-1 do + result:=result*M.a[I,I]; + M.free; +end; + +procedure TMatrix.transp; +var xd,yd,z,s: integer; + tmp: extended; +begin + xd:=ydim; + yd:=xdim; + xdim:=max(xd,yd); + ydim:=max(xd,yd); + for z:=0 to ydim-1 do + for s:=z+1 to xdim-1 do + begin + tmp:=a[z,s]; + a[z,s]:=a[s,z]; + a[s,z]:=tmp; + end; + xdim:=xd; + ydim:=yd; +end; + +function TMatrix.toStr: string; +var z,s: integer; +begin + result:=''; + for z:=0 to ydim-1 do + begin + result:=result+#$0D#$0A; + for s:=0 to xdim-1 do + result:=result+floattostr(a[z,s])+' '; + delete(result,length(result),1); + end; + delete(result,1,2); +end; + +function TMatrix.fromString(str: string): boolean; +var str2: string; + z,s,i: integer; +begin + result:=false; + if length(str)=0 then exit; + i:=length(str); + if str[length(str)]<>#13 then str:=str+#13; + while pos(#$0A,str)>0 do + delete(str,pos(#$0A,str),1); + while (i>0) do + begin + if str[i]=#13 then str:=copy(str,1,i-1)+' '+copy(str,i,length(str)+1-i); + dec(i); + end; + str2:=str; + for z:=0 to ydim-1 do + begin + for s:=0 to xdim-1 do + begin + while (length(str)>0) and (str[1]=' ') do + delete(str,1,1); + if pos(' ',str)=0 then exit; + if not istZahl(copy(str,1,pos(' ',str)-1)) then exit; + delete(str,1,pos(' ',str)); + while (length(str)>0) and (str[1]=' ') do + delete(str,1,1); + end; + if (length(str)=0) or not (str[1]=#$0D) then exit; + delete(str,1,1); + end; + result:=true; + for z:=0 to ydim-1 do + begin + for s:=0 to xdim-1 do + begin + while (length(str2)>0) and (str2[1]=' ') do + delete(str2,1,1); + if pos(' ',str2)=0 then exit; + a[z,s]:=strtofloat(copy(str2,1,pos(' ',str2)-1)); + delete(str2,1,pos(' ',str2)); + while (length(str2)>0) and (str2[1]=' ') do + delete(str2,1,1); + end; + if (length(str2)=0) or not (str2[1]=#$0D) then exit; + delete(str2,1,1); + end; +end; + +procedure TMatrix.times_(R: TMatrix); +var L: TMatrix; + z,s,i: integer; +begin + if R.ydim<>xdim then exit; + L:=duplicate; + xdim:=R.xdim; + for z:=0 to ydim-1 do + for s:=0 to xdim-1 do + begin + a[z,s]:=0; + for i:=0 to R.ydim-1 do + a[z,s]:=a[z,s] + L.a[z,i]*R.a[i,s]; + end; +end; + +procedure TMatrix._times(L: TMatrix); +var R: TMatrix; + z,s,i: integer; +begin + if ydim<>L.xdim then exit; + R:=duplicate; + ydim:=L.ydim; + for z:=0 to ydim-1 do + for s:=0 to xdim-1 do + begin + a[z,s]:=0; + for i:=0 to R.ydim-1 do + a[z,s]:=a[z,s] + L.a[z,i]*R.a[i,s]; + end; +end; + +procedure TMatrix.cross(M: TMatrix); +var x,y,z: extended; +begin + if (xdim<>1) or (M.xdim<>1) or (ydim<>3) or (M.ydim<>3) then exit; // ziemlich speziell ... + x:=a[1,0]*M.a[2,0]-a[2,0]*M.a[1,0]; + y:=a[2,0]*M.a[0,0]-a[0,0]*M.a[2,0]; + z:=a[0,0]*M.a[1,0]-a[1,0]*M.a[0,0]; + a[0,0]:=x; + a[1,0]:=y; + a[2,0]:=z; +end; + +procedure TMatrix.orthogonalize; +begin + orthogonalize(false); +end; + +procedure TMatrix.orthogonalize(normalize: boolean); +var zT,z,s: integer; + diff,me,opp: TMatrix; + l: extended; +begin + if det=0 then exit; + + diff:=TMatrix.create; + diff.xdim:=xdim; + diff.ydim:=1; + for zT:=0 to ydim-1 do + begin + diff.assign0; + for z:=0 to zT-1 do + begin + me:=part[0,zT,xdim-1,zT]; + l:=me.len; + me.transp; + opp:=part[0,z,xdim-1,z]; + me._times(opp); + l:=me.a[0,0]/l; + me.destroy; + opp.times(l); + diff.plus(opp); + opp.destroy; + end; + for s:=0 to xdim-1 do + a[zT,s]:=a[zT,s]-diff.a[0,s]; + if normalize then + begin + me:=part[0,zT,xdim-1,zT]; + l:=me.len; + me.destroy; + for s:=0 to xdim-1 do + a[zT,s]:=a[zT,s]/l; + end; + end; +end; + +procedure TMatrix.assignId(dim: integer); +var z,s: integer; +begin + if dim<1 then exit; + xdim:=dim; + ydim:=dim; + for z:=0 to dim-1 do + for s:=0 to dim-1 do + a[z,s]:=byte(z=s); +end; + +procedure TMatrix.assign0; +var z,s: integer; +begin + for z:=0 to ydim-1 do + for s:=0 to xdim-1 do + a[z,s]:=0; +end; + +function TMatrix.len: extended; +begin + if xdim=1 then result:=slen(0) + else result:=zlen(0); +end; + +function TMatrix.zlen(z: integer): extended; +var s: integer; +begin + result:=0; + for s:=0 to xdim-1 do + result:=result + sqr(a[z,s]); + result:=sqrt(result); +end; + +function TMatrix.slen(s: integer): extended; +var z: integer; +begin + result:=0; + for z:=0 to ydim-1 do + result:=result + sqr(a[z,s]); + result:=sqrt(result); +end; + +end. diff --git a/weihnachtsstern.ico b/weihnachtsstern.ico Binary files differnew file mode 100644 index 0000000..0341321 --- /dev/null +++ b/weihnachtsstern.ico diff --git a/weihnachtsstern.lpi b/weihnachtsstern.lpi new file mode 100644 index 0000000..4f33e80 --- /dev/null +++ b/weihnachtsstern.lpi @@ -0,0 +1,91 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="11"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="weihnachtsstern"/> + <Scaled Value="True"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> + <Icon Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="4"> + <Unit0> + <Filename Value="weihnachtsstern.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + <Unit2> + <Filename Value="vecmath.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="vecMath"/> + </Unit2> + <Unit3> + <Filename Value="unit2.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form2"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit2"/> + </Unit3> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="weihnachtsstern"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/weihnachtsstern.lpr b/weihnachtsstern.lpr new file mode 100644 index 0000000..f96dbfe --- /dev/null +++ b/weihnachtsstern.lpr @@ -0,0 +1,23 @@ +program weihnachtsstern; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1, vecMath, Unit2 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource:=True; + Application.Scaled:=True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.CreateForm(TForm2, Form2); + Application.Run; +end. + diff --git a/weihnachtsstern.lps b/weihnachtsstern.lps new file mode 100644 index 0000000..c9772ec --- /dev/null +++ b/weihnachtsstern.lps @@ -0,0 +1,176 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectSession> + <Version Value="11"/> + <BuildModes Active="Default"/> + <Units Count="4"> + <Unit0> + <Filename Value="weihnachtsstern.lpr"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="-1"/> + <TopLine Value="-1"/> + <CursorPos X="-1" Y="-1"/> + <UsageCount Value="21"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <TopLine Value="666"/> + <CursorPos X="47" Y="882"/> + <UsageCount Value="21"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit1> + <Unit2> + <Filename Value="vecmath.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="vecMath"/> + <EditorIndex Value="2"/> + <TopLine Value="23"/> + <CursorPos X="30" Y="36"/> + <UsageCount Value="21"/> + <Loaded Value="True"/> + </Unit2> + <Unit3> + <Filename Value="unit2.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form2"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit2"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="1"/> + <TopLine Value="6"/> + <CursorPos X="4" Y="34"/> + <UsageCount Value="21"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit3> + </Units> + <JumpHistory Count="29" HistoryIndex="28"> + <Position1> + <Filename Value="unit1.pas"/> + <Caret Line="807" Column="10" TopLine="782"/> + </Position1> + <Position2> + <Filename Value="unit1.pas"/> + <Caret Line="819" Column="8" TopLine="788"/> + </Position2> + <Position3> + <Filename Value="unit1.pas"/> + <Caret Line="909" Column="2" TopLine="907"/> + </Position3> + <Position4> + <Filename Value="unit2.pas"/> + </Position4> + <Position5> + <Filename Value="unit2.pas"/> + <Caret Line="35" Column="3" TopLine="7"/> + </Position5> + <Position6> + <Filename Value="unit1.pas"/> + <Caret Line="90" Column="25" TopLine="73"/> + </Position6> + <Position7> + <Filename Value="unit1.pas"/> + <Caret Line="51" Column="10" TopLine="36"/> + </Position7> + <Position8> + <Filename Value="unit1.pas"/> + <Caret Line="90" Column="26" TopLine="64"/> + </Position8> + <Position9> + <Filename Value="unit1.pas"/> + <Caret Line="91" Column="8" TopLine="65"/> + </Position9> + <Position10> + <Filename Value="unit1.pas"/> + <Caret Line="101" Column="17" TopLine="75"/> + </Position10> + <Position11> + <Filename Value="unit1.pas"/> + <Caret Line="171" Column="19" TopLine="154"/> + </Position11> + <Position12> + <Filename Value="unit1.pas"/> + <Caret Line="172" Column="18" TopLine="154"/> + </Position12> + <Position13> + <Filename Value="unit1.pas"/> + <Caret Line="178" Column="17" TopLine="154"/> + </Position13> + <Position14> + <Filename Value="unit1.pas"/> + <Caret Line="180" Column="29" TopLine="154"/> + </Position14> + <Position15> + <Filename Value="unit1.pas"/> + <Caret Line="182" Column="20" TopLine="182"/> + </Position15> + <Position16> + <Filename Value="unit1.pas"/> + <Caret Line="186" Column="28" TopLine="180"/> + </Position16> + <Position17> + <Filename Value="unit1.pas"/> + <Caret Line="187" Column="35" TopLine="180"/> + </Position17> + <Position18> + <Filename Value="unit1.pas"/> + <Caret Line="188" Column="12" TopLine="180"/> + </Position18> + <Position19> + <Filename Value="unit1.pas"/> + <Caret Line="189" Column="12" TopLine="180"/> + </Position19> + <Position20> + <Filename Value="unit1.pas"/> + <Caret Line="192" Column="31" TopLine="180"/> + </Position20> + <Position21> + <Filename Value="unit1.pas"/> + <Caret Line="593" Column="15" TopLine="572"/> + </Position21> + <Position22> + <Filename Value="unit1.pas"/> + <Caret Line="640" Column="9" TopLine="622"/> + </Position22> + <Position23> + <Filename Value="unit1.pas"/> + </Position23> + <Position24> + <Filename Value="unit1.pas"/> + <Caret Line="63" Column="17" TopLine="38"/> + </Position24> + <Position25> + <Filename Value="unit1.pas"/> + <Caret Line="112" Column="10" TopLine="86"/> + </Position25> + <Position26> + <Filename Value="unit1.pas"/> + <Caret Line="810" Column="10" TopLine="785"/> + </Position26> + <Position27> + <Filename Value="unit1.pas"/> + <Caret Line="833" Column="31" TopLine="808"/> + </Position27> + <Position28> + <Filename Value="unit1.pas"/> + <Caret Line="56" Column="9" TopLine="41"/> + </Position28> + <Position29> + <Filename Value="unit1.pas"/> + <Caret Line="833" Column="32" TopLine="807"/> + </Position29> + </JumpHistory> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0" ActiveMode=""/> + </RunParams> + </ProjectSession> +</CONFIG> diff --git a/weihnachtsstern.res b/weihnachtsstern.res Binary files differnew file mode 100644 index 0000000..1adb040 --- /dev/null +++ b/weihnachtsstern.res |