Analytická geometria v rovine
Delphi & Pascal (česká wiki)
Kategorija: Zadaňa zos Pascalu
Program: Angeom02.pas
Program: Angeom02.pas
Programová jednotka (unit) AnGeom02 - algebraická geometria obsahuje funkcie pre zobrazenie a vypocet roznych grafických primitív ako bod, úsečka, priamka.
(* Prerábky na školský rok 2003/2004 * 1. Do TPolygon dat usecky namiesto bodov a vektorov (pokryva!) * 2. Adekvátne prerobit PointSet, fCheck, ... * 3. Dat Print ako (virtualnu) metodu do kazdeho objektu * 4. Dorobit hlasenie chyb, rezim bDialog, ... *) UNIT AnGeom02; { Analytická geometria v rovine - } { zápočtový projekt z Programovania II } { Borsuk So 2003/06/28 14:41 V001 } INTERFACE USES Crt, UnInOut, Graph; {----- Pomocné funkcie pre debug -----} FUNCTION sRn( r: Real ): String; { Výpis reálneho čísla vo formáte :5:4 } FUNCTION sNn( n: Integer ): String; { Výpis celého čísla vo formáte :4 } FUNCTION sAn( g: Real ): String; { Výpis uhla -prevod z Rad do Deg } FUNCTION sBn( b: Boolean): String; { Výpis Booleovskej hodnoty } {--------------------- Základný objekt TBaseObj ---------------------} TYPE TString16 = String[16]; PBaseObj = ^TBaseObj; TBaseObj = OBJECT {PRIVATE} bYnit: Boolean; InstName: TString16; PUBLIC FUNCTION fYnit: Boolean; FUNCTION fInstName: TString16; CONSTRUCTOR Fail( name: TString16 ); END; { TBaseObj } PError = ^TError; TError = OBJECT { Chybové hlásenie } ErrPred, ErrSucc: PError; ErrNum: Integer; { 0=OK, inak číslo chyby } ErrTxt: String; { Text chybovej hlášky } ErrTime: LongInt; { Packed Time podania chybovej hlášky } ErrTypeN: TString16; { Meno typu objektu } ErrInstN: TString16; { Meno inštancie objektu, ktorá poslala správu } END; { TError } PMessage = ^TMessage; TMessage = OBJECT { Oznam o zvláštnej situácii } MsgPred, MsgSucc: PMessage; MsgNum: Integer; { 0=OK, inak číslo chyby } MsgTxt: String; { Text chybovej hlášky } MsgTime: LongInt; { Packed Time podania chybovej hlášky } MsgTypeN: TString16; { Meno typu objektu } MsgInstN: TString16; { Meno inštancie objektu, ktorá poslala správu } END; { TMessage } PROCEDURE Error( vErrNum: Integer; vErrTxt: String; vErrTypeN, vErrInstN: TString16 ); PROCEDURE Message( vMsgNum: Integer; vMsgTxt: String; vMsgTypeN, vMsgInstN: TString16 ); FUNCTION ArcCos(x: Real): Real; FUNCTION ArcSin(x: Real): Real; (* * * * * * * * * * * V e c i p r e G r a p h * * * * * * * * * * *) VAR GraphDriver, GraphMode: Integer; { Kreslíme akoze v prvom kvadrante, trosicku posunutom } { Napriklad pre rozlisenie 640 * 480 by bola } { os X vzdialena od laveho kraja obrazovky 64 pixelov } { Podobne aj pre os Y, ale svojim Pappenheimskym to aj otocime } { ako su zvyknuti. } GrOffsetX, GrOffsetY: Integer; { Skutocne rozlisenie, zistene pri InitGraph } GrMaxX, GrMaxY: Integer; { Prevod Reálnych súradníc do grafickych Integerov } FUNCTION GrX( x: Real ): Integer; FUNCTION GrY( y: Real ): Integer; PROCEDURE GrAxis; { Vykreslenie kvázi osí } (* * * * * * * * V e c i p r e G e o m e t r i u * * * * * * * * * *) CONST Pi2 = Pi/2.0; Pi3 = Pi/3.0; Pi4 = Pi/4.0; DvaPi = Pi + Pi; FUNCTION fStrR( vr: Real ): String; FUNCTION fStrI( vi: Integer ): String; TYPE PPoint = ^TPoint; { Bod } TPoint = OBJECT (TBaseObj) {PRIVATE} { Aby sa nám tam user nedostal unfair spôsobom } ox, oy: Real; { Súradnice bodu v rovine } PUBLIC { Sem sa dostať môže, ba priam musí } CONSTRUCTOR Init( vx, vy: Real; vInstName: TString16 ); FUNCTION fx: Real; FUNCTION fy: Real; PROCEDURE Draw( color: Word; pict: Char ); END; { TPoint } { Kvôli dynamickému prideľovaniu miesta pre vektor vrcholov polygónu } DPoint = ^APoint; APoint = ARRAY [ Byte ] OF TPoint; { Vektor ako predchodca usecky a priamky } PVector = ^TVector; TVector = OBJECT (TBaseObj) wx, wy: Real; { "Koncové" súradnice vektora } PUBLIC CONSTRUCTOR Init( vx, vy: Real; vInstName: TString16 ); FUNCTION Size: Real; PROCEDURE Unify; { Prerobi svoj vektor (Self) na jednotkovy } PROCEDURE Draw( color: Word; vpb: TPoint ); END; { TVector } PLine = ^TLine; { Priamka } TLine = OBJECT (TVector) {PRIVATE} ob: TPoint; { Začiatočný bod priamky a najmä úsečky } a, b, c: Real; PUBLIC CONSTRUCTOR Init_kq( vk, vq: Real; vInstName: TString16 ); CONSTRUCTOR Init_x0( x0: Real; vInstName: TString16 ); CONSTRUCTOR Init_PV( vo: TPoint; vw: TVector; vInstName: TString16 ); CONSTRUCTOR Init_PP( vb, ve: TPoint; vInstName: TString16 ); FUNCTION fa: Real; FUNCTION fb: Real; FUNCTION fc: Real; PROCEDURE Draw( color: Word ); END; { TLine } PAbscissa = ^TAbscissa; { Úsečka } TAbscissa = OBJECT (TLine) {PRIVATE} {ob, } oe: TPoint; { (Začiatočný a ) koncový bod úsečky } PUBLIC { Vytvorenie úsečky z koncových bodov } CONSTRUCTOR Init_pp( vpb, vpe: TPoint; vInstName: TString16 ); { Vytvorenie úsečky zo začiatočného bodu a vektora } CONSTRUCTOR Init_pv( vpb: TPoint; vv: TVector; vInstName: TString16 ); { Os usecky } PROCEDURE Axis( VAR pLyne: PLine; vInstName: TString16 ); PROCEDURE Draw( color: Word ); END; { TAbscissa } DVector = ^AVector; AVector = ARRAY [ Byte ] OF TVector; { Kvôli dynamickému prideľovaniu miesta pre vektor vrcholov polygónu } PArAbscissa = ^ArAbscissa; ArAbscissa = ARRAY [ Byte ] OF TAbscissa; PCircle = ^TCircle; { Kružňyca } TCircle = OBJECT (TBaseObj) {PRIVATE} o: TPoint; { Stred } r: Real; { Polomer } PUBLIC CONSTRUCTOR Init_pr( vp: TPoint; vr: Real; vInstName: TString16 ); PROCEDURE Draw( color: Word ); END; { TCircle } PPolygon = ^TPolygon; { Mnohouholník } TPolygon = OBJECT (TBaseObj) {PRIVATE} n: Byte; { Počet vrcholov, očíslovaných 1..n } { a ešte nultý vrchol, zhodný s n-tým vrcholom } IsConvex: Boolean; { Je mnohouholník konvexný? } ClockWise: Boolean; { Ako je orientovaná krivka? } PUBLIC a: PArAbscissa; CONSTRUCTOR Init( vn: Byte; vInstName: TString16 ); DESTRUCTOR Done; FUNCTION fn: Byte; FUNCTION fCheck: Boolean; PROCEDURE PointSet ( vi: Byte; vx, vy: Real ); PROCEDURE GetPoint ( vi: Byte; VAR rp: TPoint ); PROCEDURE GetAbscissa( vi: Byte; VAR ra: TAbscissa ); PROCEDURE Draw ( color: Word ); virtual; { bezne vykreslenie } PROCEDURE DrawL( colorA, colorL: Word ); virtual; END; { TPolygon } { Priesecník dvoch priamok (if any) } PROCEDURE InterSection_LL( lyne1, lyne2: TLine; var pCross: PPoint; name: TString16 ); { Vzdialenosti } FUNCTION Distance_PP( pb, pe: TPoint ): Real; FUNCTION Distance_LP( Lyne: TLine; Point: TPoint ): Real; FUNCTION Distance_LL( Line1, Line2: TLine ): Real; FUNCTION Distance_AA( a1, a2: TAbscissa ): Real; FUNCTION Distance_AP( a: TAbscissa; Point: TPoint ): Real; { Uhly a ich osi } PROCEDURE Rotate( vSrc: TVector; vAngle: Real; var pDst: PVector; vInstName: TString16 ); FUNCTION Angle_VV( vector1, vector2: TVector ): Real; PROCEDURE AngleAxis_VV( vector1, vector2: TVector; point: TPoint; var pAxis: PLine; vInstName: TString16 ); { Debugovacie funkcie } procedure PrVe( w: TVector; cUsm: String; color: Word ); { Print Vector } procedure PrLn( L: Tline; cUsm: String; color: Word ); { Print Line } procedure PrPn( B: TPoint; cUsm: String; color: Word ); { Draw Point } procedure PrCi( c: TCircle; cUsm: String; color: Word ); { Print Circle } procedure PrAb( A: TAbscissa; cUsm: String; color: Word ); { Print Abscissa } procedure PrPl( M: TPolygon; cUsm: String; color: Word ); { Print Polygon } VAR aAxisX, aAxisY: TAbscissa; { Mohli by to byt konstanty, keby ... } oOrigin: TPoint; IMPLEMENTATION FUNCTION ArcSin(x: Real): Real; BEGIN IF ( Abs(Abs(x) - 1.0) > 1.0E-12 ) THEN ArcSin := ArcTan ( x/sqrt(1-sqr(x)) ) ELSE IF (x > 0.0) THEN ArcSin := Pi/2.0 ELSE ArcSin := -Pi/2.0; END; { ArcSin } FUNCTION ArcCos(x: Real): Real; VAR c: Real; BEGIN IF ( Abs(x) < 1.0E-9 ) THEN c := Pi/2.0 ELSE BEGIN IF ( x < (1.0E-9 - 1.0) ) THEN c := Pi ELSE BEGIN c := ArcTan (sqrt (1-sqr (x)) /x); IF (c < 0.0) THEN c := Pi + c; END; END; ArcCos := c; END; { ArcCos } {---------------------- Base, Error, Message -------------------------} FUNCTION TBaseObj.fYnit: Boolean; BEGIN fYnit := bYnit; END; { TBaseObj.fYnit } FUNCTION TBaseObj.fInstName: TString16; BEGIN fInstName := InstName; END; { TBaseObj.fInstName } CONSTRUCTOR TBaseObj.Fail( name: TString16 ); BEGIN bYnit := False; InstName := name; END; { TBaseObj.Fail } PROCEDURE Error( vErrNum: Integer; vErrTxt: String; vErrTypeN, vErrInstN: TString16 ); BEGIN END; { Error } PROCEDURE Message( vMsgNum: Integer; vMsgTxt: String; vMsgTypeN, vMsgInstN: TString16 ); BEGIN END; { Messsage } FUNCTION fStrR( vr: Real ): String; VAR s: String; BEGIN Str( vr, s ); fStrR := s; END; { fStrR } FUNCTION fStrI( vi: Integer ): String; VAR s: String; BEGIN Str( vi, s ); fStrI := s; END; { fStrI } {----------------------- Veci pre grafiku ---------------------------} FUNCTION GrX( x: Real ): Integer; BEGIN GrX := Trunc(x) + GrOffsetX; END; { GrX } FUNCTION GrY( y: Real ): Integer; BEGIN GrY := GrMAxY - GrOffsetY - Trunc(y); END; { GrY } PROCEDURE GrAxis; { Vykreslenie kvázi osí } CONST Krok = 50; VAR farba: Word; x, y: Word; BEGIN { Vykreslíme pravítko "pod osu X" } MoveTo( 0, GrMaxY-1 ); { Začiatok "študentovej súradnicovej sústavy" } SetColor( EgaBlue ); { Záporná cast osi X } LineTo( GrOffsetX, GrMaxY-1 ); farba := EgaRed; x := GrOffsetX; WHILE (x < GrMaxX) DO BEGIN IF (farba = EgaRed) THEN farba := EgaWhite ELSE farba := EgaRed; x := x + Krok; SetColor(farba); LineTo( x, GrMaxY - 1 ); END; { WHILE } { Vykreslíme pravítko "vlavo od osi Y" } MoveTo( 0, GrMaxY-1 ); { Začiatok "študentovej súradnicovej sústavy" } SetColor( EgaBlue ); { Záporná cast osi Y } LineTo( 0, GrMaxY-GrOffsetY ); farba := EgaRed; y := GrMaxY - GrOffsetY; WHILE (y < GrMaxY) DO BEGIN IF (farba = EgaRed) THEN farba := EgaWhite ELSE farba := EgaRed; y := y - Krok; SetColor(farba); LineTo( 0, y ); END; { WHILE } { Vykreslíme os X } SetColor( EgaBlue ); Line( 0, GrMaxY - GrOffsetY, GrMaxX, GrMaxY - GrOffsetY ); { Vykreslíme os Y } Line( GrOffsetX, 0, GrOffsetX, GrMaxY ); END; { GrAxis } { DEBUG: Formatovane vypisy realnych a celych cisel } FUNCTION sRn( r: Real ): String; CONST MaxW = 5; MaxD = 4; VAR sR: String; BEGIN Str( r:MaxW:MaxD, sR ); IF ( Length(sR) > MaxW+MaxD ) THEN sR := '*' + sR; WHILE ( Length(sR) < MaxW+MaxD ) DO sR := ' ' + sR; sRn := sR END; { sRn } FUNCTION sNn( n: Integer ): String; CONST MaxLen = 4; VAR sN: String; BEGIN Str( n:4, sN ); IF ( Length(sN) > MaxLen ) THEN sN := '*' + sN; WHILE ( Length(sN) < MaxLen ) DO sN := ' ' + sN; sNn := sN; END; { sNn } FUNCTION sAn( g: Real ): String; { Vypis uhla -prevod z Rad do Deg } BEGIN sAn := sNn( Trunc(g * 180.0/Pi) ); END; { sAn } FUNCTION sBn( b: Boolean): String; { Vypis Booleovskej hodnoty } BEGIN IF (b) THEN sBn := 'True ' ELSE sBn := 'False'; END; { sBn } { Všeobecné procedúry, ktoré nemôžu byť metódami, } { jelikož divoko referencujú "krížom-krážom forward" } { Sú dva vektory kolineárne (rovnobežné)? } FUNCTION bColin_vv( vwA, vwB: TVector ): Boolean; BEGIN END; { bColin_vv } {------------------------ TPoint ---------------------------------} CONSTRUCTOR TPoint.Init( vx, vy: Real; vInstName: TString16 ); BEGIN bYnit := True; InstName := vInstName; ox := vx; oy := vy; END; { TPoint.Init } FUNCTION TPoint.fx: Real; BEGIN fx := ox; { Takto zabezpečíme, že to pre usera bude ReadOnly } END; { TPoint.fx } FUNCTION TPoint.fy: Real; BEGIN fy := oy; END; { TPoint.fy } PROCEDURE TPoint.Draw( color: Word; pict: Char ); PROCEDURE Plus; BEGIN PutPixel( GrX(ox), GrY(oy), color ); PutPixel( GrX(ox-1), GrY(oy), color ); PutPixel( GrX(ox+1), GrY(oy), color ); PutPixel( GrX(ox), GrY(oy-1), color ); PutPixel( GrX(ox), GrY(oy+1), color ); END; { Plus } PROCEDURE Krat; BEGIN PutPixel( GrX(ox), GrY(oy), color ); PutPixel( GrX(ox-1), GrY(oy-1), color ); PutPixel( GrX(ox+1), GrY(oy+1), color ); PutPixel( GrX(ox+1), GrY(oy-1), color ); PutPixel( GrX(ox-1), GrY(oy+1), color ); END; { Krat } BEGIN { TPoint.Draw } CASE pict OF '+': Plus; 'x', 'X': Krat; '*': BEGIN Plus; Krat; END; { BREAK } ELSE PutPixel( GrX(ox), GrY(oy), color ); END; { CASE } END; { TPoint.Draw } {--------------------------- TLine ------------------------------} CONSTRUCTOR TLine.Init_kq( vk, vq: Real; vInstName: TString16 ); BEGIN bYnit := True; InstName := vInstName; a := vk; b := -1.0; c := vq; wx := 0.0; wy := vq; END; { TLine.Init_kq } CONSTRUCTOR TLine.Init_PP( vb, ve: TPoint; vInstName: TString16 ); BEGIN bYnit := True; InstName := vInstName; wx := ve.ox - vb.ox; wy := ve.oy - vb.oy; ob.ox := vb.ox; ob.oy := vb.oy; IF (wx <> 0.0) THEN BEGIN a := wy/wx; b := -1.0; c := ob.oy - a*ob.ox; END ELSE BEGIN a := -1.0; b := 0.0; c := ob.ox; END; END; { TLine.Init_PP } CONSTRUCTOR TLine.Init_PV( vo: TPoint; vw: TVector; vInstName: TString16 ); BEGIN Self.InstName := vInstName; Self.wx := vw.wx; Self.wy := vw.wy; Self.ob.ox := vo.ox; Self.ob.oy := vo.oy; IF (Self.wx <> 0.0) THEN { priamka nie je rovnobezna s osou Y } BEGIN Self.a := Self.wy / Self.wx; Self.b := -1.0; Self.c := vo.oy - Self.a * vo.ox; END ELSE { priamka je rovnobezna s osou Y } BEGIN Self.a := -1.0; Self.b := 0.0; Self.c := vo.ox; END; { IF } END; { TLine.Init_PV } CONSTRUCTOR TLine.Init_x0( x0: Real; vInstName: TString16 ); BEGIN bYnit := True; InstName := vInstName; a := -1.0; b := 0.0; c := x0; wx := x0; wy := 1.0; END; { TLine.Init_x0 } FUNCTION TLine.fa: Real; BEGIN fa := a; END; { TLine.fa } FUNCTION TLine.fb: Real; BEGIN fb := b; END; { TLine.fb } FUNCTION TLine.fc: Real; BEGIN fc := c; END; { TLine.fc } PROCEDURE TLine.Draw( color: Word ); VAR y0: Integer; BEGIN IF bYnit THEN BEGIN SetColor( color ); IF (b = -1.0) THEN { bežná priamka k, q } BEGIN y0 := GrMaxY - GrOffsetY + Trunc(a*GrOffsetX - c); Line( 0, y0, GrMaxX, y0 - Trunc(a*GrMaxX) ); END ELSE { rovnobežka s osou y } Line( GrX(c), 0, GrX(c), GrMaxY ); END ELSE ; END; { TLine.Draw } {--------------------------- TAbscissa ------------------------------} { Vytvorenie úsečky z koncových bodov } CONSTRUCTOR TAbscissa.Init_PP( vpb, vpe: TPoint; vInstName: TString16 ); BEGIN Instname := vInstName; bYnit := (vpb.ox <> vpe.ox) OR (vpb.oy <> vpe.oy); IF bYnit THEN BEGIN ob.ox := vpb.ox; ob.oy := vpb.oy; oe.ox := vpe.ox; oe.oy := vpe.oy; wx := oe.ox - ob.ox; wy := oe.oy - ob.oy; IF (wx <> 0.0) THEN BEGIN a := wy / wx; b := -1.0; c := ob.oy - a * ob.ox; END ELSE BEGIN a := -1.0; b := 0.0; c := ob.ox; END END ELSE Error( 1, 'Body zadávajúce úsečku sú totožné', 'TAbscissa', InstName ); END; { TAbscissa.Init_pp } { Vytvorenie úsečky zo začiatočného bodu a vektora } CONSTRUCTOR TAbscissa.Init_pv( vpb: TPoint; vv: TVector; vInstName: TString16 ); BEGIN Instname := vInstName; bYnit := vpb.bYnit AND vv.bYnit AND (vv.Size > 0.0); IF bYnit THEN BEGIN ob.ox := vpb.ox; ob.oy := vpb.oy; oe.oy := vpb.oy + vv.wx; oe.oy := vpb.oy + vv.wy; wx := vv.wx; wy := vv.wy; IF (wx <> 0.0) THEN BEGIN a := wy / wx; b := -1.0; c := ob.oy - a * ob.ox; END ELSE BEGIN a := -1.0; b := 0.0; c := ob.ox; END END ELSE BEGIN Error( -1, '', 'TAbscissa', vInstName ) END; END; { TAbscissa.Init_pv } PROCEDURE TAbscissa.Draw( color: Word ); BEGIN SetColor( color ); Line( GrX(ob.ox), GrY(ob.oy), GrX(oe.ox), GrY(oe.oy) ); END; { TAbscissa.Draw } PROCEDURE TAbscissa.Axis( VAR pLyne: PLine; vInstName: TString16 ); VAR vBx, vBy, vVx, vVy: Real; BEGIN IF bYnit THEN { úsečka je OK } BEGIN { Súradnice stredového bodu úsecky: } vBx := (ob.ox + oe.ox) / 2.0; vBy := (ob.oy + oe.oy) / 2.0; { Vektor osi: } vVy := oe.ox - ob.ox; vVx := ob.oy - oe.oy; IF (vVx = 0.0) THEN New( pLyne, Init_x0( vBx, vInstName ) ) ELSE New( pLyne, Init_kq( vVy/vVx, vBy - (vVy/vVx)*vBx, vInstName ) ); END ELSE New( pLyne, Fail( vInstName ) ); END; { TAbscissa.Axis } { Priamka, na ktorej lezi usecka } (* PROCEDURE TAbscissa.Line_A( VAR pLyne: PLine; name: TString16 ); BEGIN END; { TAbscissa.Line } *) {------------------------ TVector ---------------------------------} CONSTRUCTOR TVector.Init( vx, vy: Real; vInstName: TString16 ); BEGIN bYnit := True; Instname := vInstName; Self.wx := vx; Self.wy := vy; END; { TVector.Init } FUNCTION TVector.Size: Real; BEGIN Size := Sqrt( Sqr(wx) +Sqr(wy) ); END; { TVector.Size } PROCEDURE TVector.Unify; { Prerobi svoj vektor (Self) na jednotkovy } VAR syze: Real; BEGIN syze := Size; IF (syze > 0.0) THEN BEGIN wx := wx/syze; wy := wy/syze; END; END; { TVector.Unify } PROCEDURE TVector.Draw( color: Word; vpb: TPoint ); BEGIN SetColor( color ); Line( GrX(vpb.ox), GrY(vpb.oy), GrX(vpb.ox + wx), GrY(vpb.oy + wy) ); END; { TVector.Draw } PROCEDURE Rotate( vSrc: TVector; vAngle: Real; var pDst: PVector; vInstName: TString16 ); BEGIN New( pDst, Init( vSrc.wx*Cos(vAngle) + vSrc.wy*Sin(vAngle), vSrc.wx*Sin(vAngle) - vSrc.wy*Cos(vAngle), vInstName) ); END; { Rotate } {------------------------ TCircle ---------------------------------} CONSTRUCTOR TCircle.Init_pr( vp: TPoint; vr: Real; vInstName: TString16 ); BEGIN bYnit := (vr > 0.0); InstName := vInstName; IF bYnit THEN BEGIN o.ox := vp.ox; o.oy := vp.oy; r := vr; END ELSE Error( 1, 'Polomer kružnice je nekladny: ' + fStrR( vr ), 'TCircle', InstName ); END; { TCircle.Init_pr } PROCEDURE TCircle.Draw( color: Word ); BEGIN SetColor( color ); o.Draw( color, '+' ); Circle( Trunc(o.ox + GrOffsetX), Trunc(GrMaxY - GrOffsetY - o.oy), Trunc(r) ); END; { TCircle.Draw } {-------------------------- TPolygon -----------------------------} CONSTRUCTOR TPolygon.Init( vn: Byte; vInstName: TString16 ); BEGIN bYnit := (vn >= 3); Self.n := vn; Self.InstName := vInstName; GetMem( a, (n+1)*SizeOf( TAbscissa ) ); END; { TPolygon.Init } DESTRUCTOR TPolygon.Done; BEGIN FreeMem( a, (n+1)*SizeOf( TAbscissa ) ); END; { TPolygon.Done } FUNCTION TPolygon.fn: Byte; BEGIN fn := n; END; { TPolygon.fn } PROCEDURE TPolygon.GetAbscissa( vi: Byte; VAR ra: TAbscissa ); BEGIN END; { TPolygon.GetAbscissa } FUNCTION TPolygon.fCheck: Boolean; VAR i, j: Byte; Ok: Boolean; sPoints: TString16; BEGIN { Doplnime do bodu 0 bod n } a^[0].ob.ox := a^[n].ob.ox; a^[0].ob.oy := a^[n].ob.oy; { Úvodný test: Opakujú sa body? Alebo sú vzájomne rôzne? } bYnit := True; { Optimistický predpoklad } i := 0; WHILE bYnit AND (i < n-1) DO BEGIN i := i + 1; j := i; WHILE bYnit AND (j < n) DO BEGIN j:= j + 1; bYnit := ( a^[i].ob.ox <> a^[j].ob.ox ) OR ( a^[i].ob.oy <> a^[j].ob.oy ); END; { while j } bYnit := bYnit AND (j >= n); END; { while i } IF NOT bYnit THEN Error( 1, 'Body nie sú vzájomne rôzne, napríklad ' + fStrI(i) + ', ' + fStrI(j), 'TPolygon', InstName ) ELSE { vpred do ďalších testov } BEGIN { Vyrobíme vektor strán a doplnime koncove body useciek } FOR i := 0 TO n - 1 DO BEGIN a^[i].oe.ox := a^[i+1].ob.ox; a^[i].oe.oy := a^[i+1].ob.oy; a^[i].wx := a^[i].oe.ox - a^[i].ob.ox; a^[i].wy := a^[i].oe.oy - a^[i].ob.oy; END; { FOR i } a^[n].wx := a^[0].wx; a^[n].wy := a^[0].wy; a^[n].oe.ox := a^[0].oe.ox; a^[n].oe.oy := a^[0].oe.oy; { Slávnostne vyrobime usecky pomocou metod OOP } FOR i := 0 TO n DO BEGIN sPoints := sNn( i ) + '_'; IF (i = n) THEN sPoints := sPoints + sNn( i+1 ) ELSE sPoints := sPoints + sNn( 1 ); a^[i].Init_PP( a^[i].ob, a^[i].oe, 'usecka ' + sPoints ); END; { FOR i } { Sú všetky susedné (spojené vrcholom) strany nekolineárne? } i := 0; WHILE bYnit AND (i < n-1) DO BEGIN i := i + 1; bYnit := NOT bColin_vv( a^[i], a^[i+1] ); END; { WHILE } bYnit := bYnit AND (i >= n-1); IF NOT bYnit THEN Error( 2, 'Vrchol ' + fStrI(i+1) + 'je "falošný", ' + 'strany s ním incidujúce sú na jednej priamke', 'TPolygon', InstName ) ELSE BEGIN { Sú strany disjunktné? Alebo sa nesusedné strany pretínajú? } END; { IF kolineárne } END; { IF body vzájomne rôzne } END; { TPolygon.fCheck } PROCEDURE TPolygon.PointSet( vi: Byte; vx, vy: Real ); BEGIN bYnit := (vi > 0) AND (vi <= n); IF (vi > 0) AND (vi <= n) THEN BEGIN a^[vi].ob.ox := vx; a^[vi].ob.oy := vy; END ELSE { Vynadáme userovi do errorov } BEGIN END; { IF } END; { PROC TPolygon.PointSet } PROCEDURE TPolygon.GetPoint( vi: Byte; VAR rp: TPoint ); BEGIN END; { TPolygon.GetPoint } PROCEDURE TPolygon.Draw( color: Word ); VAR i: Byte; BEGIN SetColor( color ); MoveTo( GrX(a^[n].ob.ox), GrY(a^[n].ob.oy) ); FOR i := 1 TO n DO LineTo( GrX(a^[i].ob.ox), GrY(a^[i].ob.oy) ); a^[1].ob.Draw( color, '*' ); a^[2].ob.Draw( color, 'x' ); a^[3].ob.Draw( color, '+' ); END; { TPolygon.Draw } PROCEDURE TPolygon.DrawL( colorA, colorL: Word ); VAR i: Byte; Lyne: TLine; BEGIN { Vykreslime priamky, na ktorych lezia strany } FOR i := 1 TO n DO BEGIN Lyne.Init_PP( a^[i].ob, a^[i].oe, '' ); Lyne.Draw( colorL ); END; { FOR i } { Vykreslime usecky aj so zvyraznenymi prvymi troma bodmi } SetColor( colorA ); MoveTo( GrX(a^[n].ob.ox), GrY(a^[n].ob.oy) ); FOR i := 1 TO n DO LineTo( GrX(a^[i].ob.ox), GrY(a^[i].ob.oy) ); a^[1].ob.Draw( colorA, '*' ); a^[2].ob.Draw( colorA, 'x' ); a^[3].ob.Draw( colorA, '+' ); END; { TPolygon.DrawL } { Priesecník dvoch priamok (if any) } PROCEDURE InterSection_LL( lyne1, lyne2: TLine; var pCross: PPoint; name: TString16 ); VAR det, x, y: Real; bY: Boolean; BEGIN det := lyne1.a * lyne2.b - lyne2.a * lyne1.b; bY := (det <> 0.0); IF bY THEN BEGIN x := (lyne1.b * lyne2.c - lyne2.b * lyne1.c) / det; y := (lyne2.a * lyne1.c - lyne1.a * lyne2.c) / det; New( pCross, Init( x, y, name ) ); END ELSE New( pCross, Fail( name ) ); END; { InterSection_LL } FUNCTION Distance_PP( pb, pe: TPoint ): Real; BEGIN Distance_PP := Sqrt( Sqr(pe.ox - pb.ox) + Sqr(pe.oy - pb.oy) ); END; { Distance_PP } FUNCTION Distance_LP( Lyne: TLine; Point: TPoint ): Real; BEGIN IF Lyne.bYnit THEN Distance_LP := Abs(Lyne.a * Point.ox + Lyne.b * Point.oy + Lyne.c) / Sqrt( Sqr(Lyne.a) + Sqr(Lyne.b) ) ELSE Distance_LP := -1.0; END; { Distance_LP } FUNCTION Distance_LL( Line1, Line2: TLine ): Real; BEGIN END; { Distance_LL } FUNCTION Distance_AA( a1, a2: TAbscissa ): Real; BEGIN END; { Distance_AA } FUNCTION Distance_AP( a: TAbscissa; Point: TPoint ): Real; BEGIN END; { Distance_LP } FUNCTION Angle_VV( vector1, vector2: TVector ): Real; VAR a, g, c, s: Real; { a = sucin abs. hodnot vektorov, g = uhol, c = skalarny, s = "vektorovy" sucin } BEGIN a := Sqrt( (Sqr(vector1.wx) + Sqr(vector1.wy)) * (Sqr(vector2.wx) + Sqr(vector2.wy)) ); c := vector1.wx * vector2.wx + vector1.wy * vector2.wy; s := vector1.wx * vector2.wy - vector1.wy * vector2.wx; IF (a = 0.0) THEN g := 0.0 ELSE g := ArcCos( c/a ); { TextColor(Yellow); Write( 'Pred G = ', g:12:7, ' Po G = ' ); } IF (c < 0.0) THEN { 2nd or 3rd Quadrant } BEGIN IF (s < 0.0) THEN g := DvaPi - g { 3rd Quadrant } END ELSE { 1st or 4th Quadrant } IF (s < 0.0) THEN g := DvaPi - g; { 4th Quadrant } { WriteLn( g:12:7 ); TextColor( White ); } Angle_VV := g; END; { Angle_VV } PROCEDURE AngleAxis_VV( vector1, vector2: TVector; point: TPoint; var pAxis: PLine; vInstName: TString16 ); (* VAR angle: Real; pW: PVector; BEGIN angle := Angle_VV( vector1, vector2 ); Rotate( vector1, angle/2.0, pW, 'Otoceny' ); TextColor( Blue ); WriteLn( 'AngleAxis_VV vypocítala uhol ', Trunc(angle*180/pi):5, ' vektor (', pW^.wx:8:5, ', ', pW^.wy:8:5, ')', #13#10, 'a dostala point [', point.ox:8:5, ', ', point.oy:8:5, '] a vInstName ', vInstName, '' ); TextColor( White ); New( pAxis, Init_PV( point, pW^, vInstName ) ); PrLn( pAxis^, 'DEBUG AngleAxis vyrátala', Red ); *) VAR jv1, jv2, jvS: TVector; { Jednotkové vektory } d1, d2, dS: Real; { Absolútne hodnoty pôvodnych vektorov } BEGIN d1 := Sqrt( Sqr(vector1.wx) + Sqr(vector1.wy) ); jv1.wx := vector1.wx/d1; jv1.wy := vector1.wy/d1; d2 := Sqrt( Sqr(vector2.wx) + Sqr(vector2.wy) ); jv2.wx := vector2.wx/d2; jv2.wy := vector2.wy/d2; jvS.wx := jv1.wx + jv2.wx; jvS.wy := jv1.wy + jv2.wy; New( pAxis, Init_PV( point, jvS, vInstName ) ); pAxis^.bYnit := (d1 > 0.0) AND (d2 > 0.0); END; { AngleAxis_VV } { DEBUG: Print Vector } procedure PrVe( w: TVector; cUsm: String; color: Word ); begin TextColor( color ); WriteLn( 'Vector ', w.InstName, ' v = (', sRn(w.wx), ', ', sRn(w.wy), ') "', cUsm, '"' ); TextColor( White ); end; { PrVe } { DEBUG: PrintLine } procedure PrLn( L: Tline; cUsm: String; color: Word ); begin TextColor( color ); WriteLn( 'Line ', L.InstName, ' a b c = ', L.a:5:5, ' ', L.b:5:5, ' ',L.c:5:5, ' ', cUsm, #13#10, 'v= (', L.wx :5:5, ', ', L.wy: 5:5, ') o= [', L.ob.ox:5:5, ', ', L.ob.oy:5:5, ']' ); TextColor( White ); end; { PrLn } procedure PrAb( A: TAbscissa; cUsm: String; color: Word ); { Print Abscissa } begin TextColor( color ); WriteLn( 'Abscissa ', A.InstName, ' ob= [', A.ob.ox:5:5, ', ', A.ob.oy:5:5, '] oe= [', A.oe.ox:5:5, ', ', A.oe.oy:5:5, ']', #13#10, ' a b c = ', A.a:5:5, ' ', A.b:5:5, ' ',A.c:5:5, ' "', cUsm, '"', #13#10, ' v= (', A.wx:5:5, ', ', A.wy:5:5, ')' ); TextColor( White ); end; { prAb } procedure PrCi( c: TCircle; cUsm: String; color: Word ); { Draw Circle } begin TextColor( color ); WriteLn( 'Circle ', c.InstName, ' o= [', c.o.ox:5:5, ', ', c.o.oy:5:5, '] r= ', c.r:5:5, ' ', cUsm ); TextColor( White ); end; { PrCi } { DEBUG: Print Polygon } procedure PrPl( M: TPolygon; cUsm: String; color: Word ); { Print Polygon } var i: Byte; begin TextColor( color ); Write( 'Polygon ', M.InstName, ' (' ); IF (M.bYnit) THEN Write( 'True ' ) ELSE Write( 'False ' ); WriteLn( ') # vrcholov = ', M.n, ' "' + cUsm + '"' ); for i := 0 to M.n do WriteLn( '{', i:2, '} w= (', sRn(M.a^[i].wx), ', ', sRn(M.a^[i].wy), ') o= [', sRn(M.a^[i].ob.ox), ', ', sRn(M.a^[i].ob.oy), ']' ); TextColor( White ); end; { PrPl } { DEBUG: Print Point } procedure PrPn( B: TPoint; cUsm: String; color: Word ); { Print Point } begin TextColor( color ); WriteLn( 'Point ', B.InstName, ' o = [', sRn( B.ox ), ', ', sRn( B.oy ), ']' ); TextColor( White ); end; { PrPn } BEGIN { AnGeom2 } oOrigin.Init( 0.0, 0.0, 'Origin' ); aAxisX.Init_PP( oOrigin, oOrigin, 'aAxisX' ); { To bol podraz! } aAxisX.oe.ox := 1.0; aAxisX.oe.oy := 0.0; { Teraz je to naozaj! } aAxisX.wx := 1.0; aAxisX.wy := 0.0; { Teraz je to naozaj! } aAxisX.a := 0.0; aAxisX.b := -1.0; aAxisX.c := 0.0; aAxisY.Init_PP( oOrigin, oOrigin, 'aAxisY' ); { To bol podraz! } aAxisY.oe.ox := 0.0; aAxisY.oe.oy := 1.0; { Teraz je to naozaj! } aAxisY.wx := 0.0; aAxisY.wy := 1.0; { Teraz je to naozaj! } aAxisY.a := -1.0; aAxisY.b := 0.0; aAxisY.c := 0.0; DetectGraph( GraphDriver, GraphMode ); GraphDriver := Detect; InitGraph( GraphDriver, GraphMode, '' ); GrAxis; GrMaxX := GetMaxX; GrMaxY := GetMaxY; GrOffsetX := 50; GrOffsetY := 50; RestoreCrtMode; { SetGraphMode( GraphMode ); GrAxis; } END. { AnGeom02 } (* CONSTRUCTOR TVector.Init_PP( pb, pe: TPoint; vInstName: TString16 ); BEGIN bYnit := True; Instname := vInstName; Self.x := pe.x - pb.x; Self.y := pe.y - pb.y; END; { TVector.Init_PP } *)