Umiestnenie súboru www.TrSek.com/pas/vrstev.pas

{ VRSTEV.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{ Program vykresli vrstevnice troch kopcov plus osy x,y.            }
{ Jednotlive vrstevnice su farebne odlisene.                        }
{                                                                   }
{ Datum:01.12.2004                             http://www.trsek.com }

program zobrazit_vrtevnice;
uses crt,dos,graph;

const pv=14;                    { pocet vrstiev }
      poc_vrs=7;                { pocet vrstevnic na jednu farbu }
      max_vys=pv*poc_vrs;       { maximalna zobrazena vyska }
      pozadie = Black;          { takto vypada pozadie }
      kriz    = White;          { takuto farbu ma osovy kriz }
      vrstvy:array[1..pv] of byte=(
          LightGray,
          Yellow,
          LightRed,
          Red,
          LightMagenta,
          Magenta,
          LightGreen,
          Green,
          LightCyan,
          Cyan,
          LightBlue,
          Blue,
          Brown,
          DarkGray);

var gd, gm: integer;
         i: integer;            { pocitadlo vrstevnic }
     kx,ky: real;               { mierka v osi x, y   }
     sx,sy: integer;            { posuv zaciatku v osi x,y }
      krok: integer;            { krok vrstevnice     }
        dlz_x, dlz_y: real;     { jednotlive maximalne suradnice }
      vrs_od, vrs_do: integer;  { odkial pokial zobrazit }
vrch1, vrch2, vrch3: integer;  { vysky vrcholov      }

procedure EGAVGA_dr; external;
{$L EGAVGA.OBJ }

{ urci farbu vrstevnice }
{ podeli hodnotu vrsta premennou poc_vrst          }
{ ak vyjde farba mimo rozsah zvoli farbu pozadia   }
function Farba(vrstva:integer):integer;
var fa:integer;
begin
  fa:=(vrstva div poc_vrs)+1;

  if(fa>pv) then
     Farba:=pozadie             { taku uz mepoznam }
  else
     Farba:=vrstvy[fa];
end;

{ prevedie cislo na text }
function ToNumber(numb:real):string;
var s:string;
begin
  if( Frac(numb)<>0)then
    str(numb:0:2,s)
  else
    str(numb:0:0,s);

  ToNumber:=s;
end;

{ vykresli osovy kriz }
procedure OsKriz(dlz_x,dlz_y,kx,ky:real);
var StredX, StredY:integer;  { suradnice stredu }
    i,x,y:integer;
    krok:real;          { krok cisel na osovom krizi }
    pkrok:integer;      { kolko pixelov ma krok    }
    numb:string;        { pre prevod cisla na text }
begin
  SetColor(kriz);
  { vypocitaj suradnice stredu }
  StredX := GetMaxX div 2;
  StredY := GetMaxY div 2;

  { zobrazime osoveho kriza }
  Line(0, StredY, GetMaxX, StredY);
  Line(StredX, 0, StredX, GetMaxY);

  { pre zobrazime ciselnika os x }
  krok:=dlz_x/8;

  for i:=-10 to 10 do
  begin
    x:=StredX+Round(i*kx*krok);
    numb:=ToNumber(i*krok);

    Line(x, StredY-5, x, StredY+5);
    OutTextXY(x-(TextWidth(numb) div 2), StredY+12, numb );
  end;

  { pre zobrazime ciselnika os y }
  krok:=dlz_y/8;

  for i:=-10 to 10 do
  begin
    y:=StredY+Round(i*ky*krok);
    numb:=ToNumber(-i*krok);

    Line(StredX-5, y, StredX+5, y);
    OutTextXY(StredX+12, y-(TextHeight(numb) div 2), numb );
  end;
end;

{ nakresli vrstvu - obycajna elipsa }
{ vstupne parametre x,y-pozicia stredu, s-sirka, v-vyska }
procedure KresliVrstvu(x,y,s,v:integer;kx,ky:real);
begin
  { upravime podla mierky }
  x:=round(x*kx);
  y:=round(y*ky);
  s:=round(s*kx);
  v:=round(v*ky);

  { vstupne podmienky }
  if( s<=0 ) then exit;
  if( v<=0 ) then exit;

  { tuto vykresli vrstvu }
  Ellipse(x, y, 0, 360, s, v );
end;

{ nakresli vrstvu - valec }
{ vstupne parametre x,y-pozicia stredu, s-sirka, v-vyska }
procedure KresliVrstvu2(x,y,s,v:integer;kx,ky:real);
var v2,s2:integer;
begin
  { upravime podla mierky }
  x:=round(x*kx);
  y:=round(y*ky);
  s:=round(s*kx);
  v:=round(v*ky);

  { vstupne podmienky }
  if( s<=0 ) then exit;
  if( v<=0 ) then exit;

  v2:=v div 2;
  s2:=s div 2;

  { tuto vykresli vrstvu }
  line( x-s2+v2, y-v2, x+s2-v2, y-v2);
  line( x-s2+v2, y+v2, x+s2-v2, y+v2);

  arc( x-s2+v2, y, 90,270, v2);
  arc( x+s2-v2, y, 270,90, v2);
end;

BEGIN
  { len pre potreby testovania }
  dlz_x:=320;
  dlz_y:=240;

  vrs_od:=1;
  vrs_do:=100;
  krok:=5;

  vrch1:=100;
  vrch2:=100;
  vrch3:=100;

  ClrScr;
  {
  WriteLn('Kreslenie vrstevnic podla vstupnych parametrov.');
  Write('Zadaj maximalnu hodnotu osi x [max 320]: ');
  ReadLn(dlz_x);

  Write('Zadaj maximalnu hodnotu osi y [max 240]: ');
  ReadLn(dlz_y);

  Write('Zadaj maximalnu vysku vrstevnic [1..',max_vys,']: ');
  ReadLn(vrs_do);

  Write('Zadaj minimalnu vysku vrstevnic [1..',max_vys,']: ');
  ReadLn(vrs_od);

  Write('          Zadaj krok vrstevnice [1..20]: ');
  ReadLn(krok);

  Write('            Zadaj vysku 1 kopca [1..',max_vys,']: ');  ReadLn(vrch1);
  Write('            Zadaj vysku 2 kopca [1..',max_vys,']: ');  ReadLn(vrch2);
  Write('            Zadaj vysku 3 kopca [1..',max_vys,']: ');  ReadLn(vrch3);
  }

  { trochu upravime premenne vrch }
  vrch1:=max_vys - vrch1;
  vrch2:=max_vys - vrch2;
  vrch3:=max_vys - vrch3;

  { inicializacia grafiky }
  Gd := Detect;
  RegisterBGIdriver(@egavga_dr);
  gd:=9;gm:=2;
  InitGraph(Gd, Gm,' ');
  if GraphResult <> grOk then Halt(1);

  { vypocitame konstanty pre mierku }
  kx:=(GetMaxX+1)/(2*dlz_x);
  ky:=(GetMaxY+1)/(2*dlz_y);

  sx:=Round((GetMaxX+1-(2*dlz_x))/2);
  sy:=Round((GetMaxY+1-(2*dlz_y))/2);

  for i:=vrs_od to vrs_do do
  begin
    if(i div krok = (i/krok)) then
    begin
      SetColor(Farba(i));

      { kopec vlavo hore }
      KresliVrstvu( 100-sx, 100+i-sy div 2, 1*(i-vrch1), 2*(i-vrch1), kx, ky);

      { kopec vpravo hore }
      KresliVrstvu( 300+i-sx, 100-sy, 2*(i-vrch2), 1*(i-vrch2), kx, ky);

      { kopec vstrede dole }
      KresliVrstvu2( 370+i-sx, 300+i-sy, 6*(i-vrch3), 4*(i-vrch3), kx, ky);
    end;
  end;

  { vykresli osovy kriz }
  OsKriz(dlz_x,dlz_y,kx,ky);

  { pocka na stlacenie klavesu Enter a zavrie grafiku }
  Readln;
  CloseGraph;
END.

Copyrigth by Zdeno Sekerak 2007, http://www.trsek.com