{$N+} unit GrGeom; interface uses graph, crt, Types, Transf; (*----------------------------------------------------------------*) type TGrOpt = (fit_big, fit_small, s_accel, s_polig, s_infas, s_rect, s_filrect); TGrSet = set of TGrOpt; (*----------------------------------------------------------------*) var MidX, MidY: integer; Ratio: Real; gr_set: TGrSet; (*----------------------------------------------------------------*) function InitGr(gm: integer): boolean; {Initialiseaza modul grafic} procedure CloseGr; {Inkide modul grafic} function PauseGr: boolean; {Restabileste modul textual, dar nu inkide modul grafic} function ResumeGr: boolean; {Restabileste modul grafic, daca a fost initializat} function GrInited: boolean; {Verifica daca modul grafic a fost initializat} procedure ChgPg; function GetMidX: integer; function GetMidY: integer; procedure AbsMaxCoord(var p: TabelPuncte; nr: TNrElem; var mx, my: TCoord); function detect_ratio(mx, my: TNumber): TNumber; procedure drow_punct(p: TPunct; color: integer); procedure drow_segment(p1, p2: TPunct); procedure drow_poligon(var p: TabelPuncte; nr: integer; color: integer); procedure drow_drept(l, h: TPunct; color: integer); procedure drow_cerc(p: TPunct; raz: integer); procedure drow_pol_segm(p: TPunct; color: integer); procedure drow_set_puncte(var p: TabelPuncte; nr: integer; color: integer); procedure drow_set_puncte_pol(var p: TabelPuncte; nr: integer; color: integer); procedure drow_poz(t: TPunct; alfa: TNumber); (*----------------------------------------------------------------*) { Controlul tastelor } function key_control(var dir: TPunct; var alfa: TNumber; delta: TCoord; k: Char): Char; { Afiseaza coordonatele punctului t } procedure print_poz(t: TPunct; x, y: integer; n: string); (*----------------------------------------------------------------*) function SwitchGrSet(o:TGrOpt): boolean; function GetGrSet(o:TGrOpt): boolean; (*----------------------------------------------------------------*) implementation uses IOGeom, Punct; var Page: boolean; (*----------------------------------------------------------------*) function isGrOk: boolean; begin isGrOk := graphresult = grOk; end; function InitGr(gm: integer): boolean; var gd: integer; begin InitGr := false; {Incerc sa initializez modulul grafic} gd := DETECT; InitGraph(gd, gm, ''); if( not isGrOk)then initgraph(gd, gm, 'BGI'); if( not isGrOk)then initgraph(gd, gm, '..\BGI'); if( not isGrOk)then exit; {Error} SetWriteMode( XORPut ); {Determinarea coordonatelor mijlocului ecranului} MidX := GetMidX; MidY := GetMidY; InitGr := true; {Success} end; (*----------------------------------------------------------------*) function GrInited: boolean; begin GrInited := (MidX or MidY)<>0; end; procedure CloseGr; begin CloseGraph; MidX := 0; MidY := 0; end; function PauseGr: boolean; begin PauseGr := true; if GrInited then RestoreCrtMode else PauseGr := false; end; function ResumeGr: boolean; begin ResumeGr := true; if GrInited then SetGraphMode(GetGraphMode or $100) else ResumeGr := false; end; (*----------------------------------------------------------------*) procedure ChgPg; begin if Page then begin SetActivePage(0);SetVisualPage(1{$ifdef __TMT__}, true{$endif}); Page:=false; end else begin SetActivePage(1);SetVisualPage(0{$ifdef __TMT__}, true{$endif}); Page:=true; end; {$ifdef __TMT__}ClearPage{$else}ClearViewPort{$endif}; end; (*----------------------------------------------------------------*) function GetMidX: integer; begin GetMidX := GetMaxX shr 1; end; function GetMidY: integer; begin GetMidY := GetMaxY shr 1; end; (*----------------------------------------------------------------*) procedure AbsMaxCoord(var p: TabelPuncte; nr: TNrElem; var mx, my: TCoord); var i: integer; begin mx := 0; my := 0; for i := nr-1 downto 0 do with p[i] do begin if abs(x) > mx then mx := abs(x); if abs(y) > my then my := abs(y); end; end; (*----------------------------------------------------------------*) function detect_ratio(mx, my: TNumber): TNumber; var i: integer; r: TNumber; begin if [fit_big, fit_small] * gr_set <> [] then begin if mx = 0 then mx := 1; if my = 0 then my := 1; if not GrInited then InitGr(0); mx := MidX / mx; my := MidY / my; if fit_big in gr_set then begin if mx < Ratio then Ratio := mx; if my < Ratio then Ratio := my; end; if fit_small in gr_set then begin if (mx > Ratio) and (mx < my) then Ratio := mx else if (my > Ratio) and (my < mx) then Ratio := my; end; end; detect_ratio := Ratio; end; (*----------------------------------------------------------------*) procedure drow_punct(p: TPunct; color: integer); begin putpixel(MidX + trunc(p.x*Ratio), MidY - trunc(p.y*Ratio), color); end; (*----------------------------------------------------------------*) procedure drow_cerc(p: TPunct; raz: integer); begin Circle(MidX + trunc(p.x*Ratio), MidY - trunc(p.y*Ratio), trunc(raz*Ratio)); end; (*----------------------------------------------------------------*) procedure drow_set_puncte(var p: TabelPuncte; nr: integer; color: integer); var i: integer; mx, my: TCoord; begin if not GrInited then InitGr(0); AbsMaxCoord(p, nr, mx, my); detect_ratio(mx, my); for i := 0 to nr-1 do drow_punct(p[i], color); end; (*----------------------------------------------------------------*) procedure drow_pol_segm(p: TPunct; color: integer); begin cartez_punct(p, p); setcolor(color); line(MidX, MidY, MidX + trunc(p.x*Ratio), MidY - trunc(p.y*Ratio)); end; (*----------------------------------------------------------------*) procedure drow_segment(p1, p2: TPunct); begin line(MidX + trunc(p1.x*Ratio), MidY - trunc(p1.y*Ratio), MidX + trunc(p2.x*Ratio), MidY - trunc(p2.y*Ratio)); end; (*----------------------------------------------------------------*) procedure drow_drept(l, h: TPunct; color: integer); begin SetColor(Color); Rectangle(MidX + trunc(l.x*Ratio), MidY - trunc(l.y*Ratio), MidX + trunc(h.x*Ratio), MidY - trunc(h.y*Ratio)); end; (*----------------------------------------------------------------*) procedure drow_poligon(var p: TabelPuncte; nr: integer; color: integer); var i: integer; mx, my: TCoord; begin SetColor(color); if not GrInited then InitGr(0); AbsMaxCoord(p, nr, mx, my); detect_ratio(mx, my); for i := 0 to nr-2 do drow_segment(p[i], p[i+1]); drow_segment(p[nr-1], p[0]); end; (*----------------------------------------------------------------*) procedure drow_set_puncte_pol(var p: TabelPuncte; nr: integer; color: integer); var i: integer; begin if not GrInited then InitGr(0); for i := 0 to nr-1 do drow_pol_segm(p[i], color); end; (*----------------------------------------------------------------*) function key_control(var dir: TPunct; var alfa: TNumber; delta: TCoord; k: Char): Char; begin dir := ZeroP; alfa := 0; k := UpCase(k); key_control := k; with dir do case k of {Directions} #77: x := delta * Ratio; #75: x := -delta * Ratio; #72: Y := delta * Ratio; #80: y := -delta * Ratio; '+': Ratio := Ratio * 1.1; '-': Ratio := Ratio * 0.9; '>', '.': alfa := alfa - delta * 0.2; '<', ',': alfa := alfa + delta * 0.2; {Switches} '1': SwitchGrSet(s_polig); '2': SwitchGrSet(s_infas); '3': SwitchGrSet(s_rect); '0': SwitchGrSet(s_accel); 'F': SwitchGrSet(s_filrect); 'B': SwitchGrSet(fit_big); 'S': SwitchGrSet(fit_small); else end; end; (*----------------------------------------------------------------*) function GetGrSet(o:TGrOpt): boolean; begin GetGrSet := o in gr_set; end; (*----------------------------------------------------------------*) function SwitchGrSet(o:TGrOpt): boolean; begin if o in gr_set then gr_set := gr_set - [o] else gr_set := gr_set + [o]; SwitchGrSet := GetGrSet(o); end; (*----------------------------------------------------------------*) procedure drow_poz(t: TPunct; alfa: TNumber); begin OutTextXY(0, 0, 'Alfa: ' + CoordToStr(alfa, 2)); print_poz(t, 0, TextHeight('H')*1, 'T'); if fit_big in gr_set then OutTextXY(0, TextHeight('H')*3, 'Adaptare micsorare'); if fit_small in gr_set then OutTextXY(0, TextHeight('H')*4, 'Adaptare marire'); drow_punct(t, WHITE); drow_cerc(t, 5); end; (*----------------------------------------------------------------*) procedure print_poz(t: TPunct; x, y: integer; n: string); begin if n <> '.' then n := n + '.'; OutTextXY(x, y, n+'x: ' + CoordToStr(t.x, 2)); OutTextXY(x, y+TextHeight('H'), n+'y: ' + CoordToStr(Round(t.y), 0)); end; (*----------------------------------------------------------------*) begin MidX := 0; MidY := 0; Ratio := 1; gr_set := [fit_big{, fit_small}]; Page := true; end.