home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 04 / quellen / draw3.inc < prev    next >
Encoding:
Text File  |  1979-12-31  |  7.8 KB  |  319 lines
  1. (*****************************************************************************)
  2. (*                            DRAW3.INC                                      *)
  3. (*                                                                           *)
  4. (*               Unterprogramm-Modul zum Zeichnen der Funktion               *)
  5. (*               Speziell fuer Apple II+/e mit IBS AP22-Karte                *)
  6. (*****************************************************************************)
  7.  
  8. PROCEDURE plotfunction;
  9.  
  10. VAR xmin,xmax, ymin,ymax, dx,dy,x,d, s1,f1,f2   : REAL;
  11.     s,grad,i,j : INTEGER;
  12.     key        : CHAR;
  13.     ok         : BOOLEAN;
  14.  
  15.    (* Hier beginnt der hardwareabhaengige Teil *)
  16.  
  17. CONST screenxmax = 279;  (* Anzahl Bildpunkte horizontal                 *)
  18.       screenymax = 191;  (*                   vertikal                   *)
  19.       left       =  5;   (* Abstand Zeichenflaeche-linker Bildschirmrand *)
  20.       bottom     =  5;   (*                       -unterer               *)
  21.       unit       = 4;    (* halbe Breite der Achsenunterteilungsstriche  *)
  22.       hgrpage    = 1;    (* Grafikseite                                  *)
  23.  
  24. var   conoutptr_bak : INTEGER;
  25.  
  26. { 6502 - Interface fuer Turbo-Pascal unter IBS AP22}
  27.  
  28. VAR a_reg   : BYTE ABSOLUTE $ffa5;
  29.     x_reg   : BYTE ABSOLUTE $ffa6;
  30.     y_reg   : BYTE ABSOLUTE $ffa7;
  31.     xy_reg  : INTEGER ABSOLUTE $ffa6;
  32.     ax_reg  : INTEGER ABSOLUTE $ffa5;
  33.     a_res   : BYTE ABSOLUTE $ff05;
  34.     x_res   : BYTE ABSOLUTE $ff06;
  35.     y_res   : BYTE ABSOLUTE $ff07;
  36.  
  37.   FUNCTION r6502(adr : INTEGER) : BYTE;
  38.  
  39.   BEGIN
  40.     INLINE ($2a/adr/$e7/$02/$6f/$26/$00/$c9)
  41.   END;
  42.  
  43.   PROCEDURE w6502(adr : INTEGER; Val : BYTE);
  44.  
  45.   BEGIN
  46.     INLINE ($2a/adr/$3a/Val/$e7/$3/$c9)
  47.   END;
  48.  
  49.   PROCEDURE s6502(adr : INTEGER);
  50.  
  51.   BEGIN
  52.     INLINE ($2a/adr/$e7/$02/$c9);
  53.   END;
  54.  
  55.   PROCEDURE call6502(adr : INTEGER);
  56.  
  57.   BEGIN
  58.     INLINE ($2a/adr/$e7/4/$c9)
  59.   END;
  60.  
  61. { Ende des Interface-Blocks }
  62. {====================================================================}
  63.  
  64.   PROCEDURE dummy(a : char); (* faengt Bildschirmausgabe ab *)
  65.   BEGIN END;
  66.  
  67.   PROCEDURE color(cl : INTEGER);
  68.  
  69.   BEGIN
  70.     x_reg := cl;
  71.     call6502($f6f0);
  72.   END;
  73.  
  74.   PROCEDURE initgraphic;     (* Voreinstellungen fuer Grafikbetrieb *)
  75.  
  76.   CONST gr = $c050;
  77.         nomix = $c052;
  78.         pageslct = $c053;
  79.         hires = $c057;
  80.         apple_io = $c000;
  81.         screen_80 = $c00c;
  82.         page = $e6;
  83.  
  84.   BEGIN
  85.     Clrscr;
  86.     w6502(page,hgrpage * $20);
  87.     call6502($f3f2);
  88.     color(3);
  89.     w6502(screen_80,0);
  90.     w6502(apple_io,0);
  91.     s6502(gr);
  92.     s6502(nomix);
  93.     s6502(pageslct + hgrpage);
  94.     s6502(hires);
  95.     conoutptr_bak := conoutptr;
  96.     conoutptr := addr(dummy)
  97.   END;
  98.  
  99.   PROCEDURE leavegraphic;    (* Voreinstellungen fuer Textbetrieb *)
  100.  
  101.   CONST txt = $c051;
  102.         pageslct = $c053;
  103.         nohires = $c056;
  104.         secoff = $c054;
  105.         apple_io = $c001;
  106.         screen_80 = $c00d;
  107.  
  108.   BEGIN
  109.     s6502(nohires);
  110.     s6502(secoff);
  111.     s6502(pageslct);
  112.     s6502(txt);
  113.     w6502(apple_io,0);
  114.     w6502(screen_80,0);
  115.     conoutptr := conoutptr_bak;
  116.     Clrscr;
  117.   END;
  118.  
  119.   FUNCTION checkkoord(VAR x,y : INTEGER) : BOOLEAN;
  120.  
  121.   VAR ok : BOOLEAN;
  122.  
  123.   BEGIN
  124.     ok := TRUE;
  125.     IF x < 0
  126.       THEN
  127.         BEGIN
  128.           x := 0 ;
  129.           ok := FALSE
  130.         END
  131.       ELSE
  132.         IF x > screenxmax
  133.           THEN
  134.             BEGIN
  135.               x := screenxmax;
  136.               ok := FALSE
  137.             END;
  138.     IF y < 0
  139.       THEN
  140.         BEGIN
  141.           y := 0;
  142.           ok := FALSE
  143.         END
  144.       ELSE
  145.         IF y > screenymax
  146.           THEN
  147.             BEGIN
  148.               y := screenymax;
  149.               ok := FALSE
  150.             END;
  151.     checkkoord := ok
  152.   END;
  153.  
  154.   PROCEDURE position (x,y : INTEGER);
  155.  
  156.   BEGIN
  157.     a_reg := screenymax - y;
  158.     xy_reg := x;
  159.     call6502($f411);
  160.   END;
  161.  
  162.   PROCEDURE plot (x,y :INTEGER);    (* Punkt bei (x,y) zeichnen *)
  163.  
  164.   BEGIN
  165.     IF checkkoord(x,y)
  166.       THEN
  167.         BEGIN
  168.           xy_reg := x;
  169.           a_reg  := screenymax - y;
  170.           call6502 ($f457)
  171.         END
  172.       ELSE
  173.         position(x,y);
  174.   END;
  175.  
  176.   PROCEDURE draw (x1,y1,x2,y2 :INTEGER);(* Linie von (x1,y1) nach (x2,y2) *)
  177.  
  178.   BEGIN
  179.     plot(x1,y1);
  180.     IF checkkoord(x2,y2)
  181.       THEN
  182.         BEGIN
  183.           ax_reg := x2;
  184.           y_reg  := screenymax - y2;
  185.           call6502 ($f53a)
  186.         END
  187.       ELSE
  188.         position(x2,y2)
  189.   END;
  190.    (* hier endet der hardwareabhaengige Teil *)
  191.  
  192.   PROCEDURE worldtoscreen (x,y :REAL; VAR xs,ys :INTEGER);
  193.  
  194.   VAR a,b : REAL;
  195.  
  196.   BEGIN
  197.     a := (x - xmin)*(screenxmax-left)/(xmax-xmin);
  198.     b := (y - ymin)*(screenymax-bottom)/(ymax-ymin);
  199.     IF Abs(a) > 32000.0
  200.       THEN
  201.         a := sign(a)*32000.0;
  202.     IF Abs(b) > 32000.0
  203.       THEN
  204.         b := sign(b)*32000.0;
  205.     xs := Round(a) + left;
  206.     ys := Round(b) + bottom
  207.   END;
  208.  
  209.   PROCEDURE drawpoint (x,y :REAL);(* zeichnet Punkt in Weltkoordinaten *)
  210.  
  211.   VAR xp,yp : INTEGER;
  212.  
  213.   BEGIN
  214.     worldtoscreen (x,y,xp,yp);
  215.     plot (xp,yp)
  216.   END;
  217.  
  218.   PROCEDURE drawline (x1,y1,x2,y2 :REAL);(* zeichnet Linie in Weltkoordinaten *)
  219.  
  220.   VAR xp1,yp1,xp2,yp2 : INTEGER;
  221.  
  222.   BEGIN
  223.     worldtoscreen (x1,y1,xp1,yp1);
  224.     worldtoscreen (x2,y2,xp2,yp2);
  225.     draw (xp1,yp1,xp2,yp2)
  226.   END;
  227.  
  228.   PROCEDURE drawaxis;   (* zeichnet das Achsenkreuz *)
  229.  
  230.   VAR x,y,dist : REAL;
  231.  
  232.   BEGIN
  233.     draw (left,bottom,left,screenymax);
  234.     draw (left,bottom,screenxmax,bottom);
  235.     drawline (xmin,0,xmax,0);
  236.     drawline (0,ymin,0,ymax);
  237.     dist := dy*(screenymax-bottom)/(ymax-ymin);(* Abstand y-Unterteilung *)
  238.     x := left;
  239.     y := bottom;
  240.     WHILE y<=screenymax DO
  241.       BEGIN
  242.         draw (Round(x-unit),Round(y),Round(x+unit),Round(y));
  243.         y := y + dist
  244.       END;
  245.     dist := dx*(screenxmax-left)/(xmax-xmin);(* Abstand y-Unterteilung *)
  246.     x := left;
  247.     y := bottom;
  248.     WHILE x<=screenxmax DO
  249.       BEGIN
  250.         draw (Round(x),Round(y-unit),Round(x),Round(y+unit));
  251.         x := x + dist
  252.       END;
  253.   END;
  254.  
  255. BEGIN
  256.   Clrscr;
  257.   Writeln ('Funktion zeichnen');
  258.   REPEAT
  259.     Writeln;
  260.     formulaln (xmin,'im Bereich von xmin = ');
  261.     formulaln (xmax,'           bis xmax = ');
  262.   UNTIL xmin < xmax;
  263.   REPEAT
  264.     formulaln (dx, 'mit Schrittweite dx = ');
  265.   UNTIL dx > 0.0;
  266.   REPEAT
  267.     Writeln;
  268.     formulaln (ymin,'           von ymin = ');
  269.     formulaln (ymax,'           bis ymax = ');
  270.   UNTIL ymin < ymax;
  271.   REPEAT
  272.     formulaln (dy, ' mit Schrittweite dy = ');
  273.   UNTIL dy > 0.0;
  274.   Writeln;
  275.   REPEAT
  276.     formulaln (s1,'Anzahl der zu berechnenden Stuetzstellen : ');
  277.     s := Round(s1);
  278.   UNTIL s >= 0;
  279.   if s = 0 THEN s := screenxmax-left;
  280.   Writeln;
  281.   Writeln('Welche Funktion soll gezeichnet werden ?');
  282.   Writeln;
  283.   for i := 0 to maxgrad do
  284.   BEGIN
  285.     Write('         f');
  286.     for j := 1 to i do Write('''');
  287.     Write('':maxgrad-i, '  : ',i:3);
  288.     WriteLn
  289.   END;
  290.   Writeln;
  291.   Write('Bitte waehlen :   ');
  292.   REPEAT
  293.     Read(kbd,key);
  294.   UNTIL key in ['0'..chr(maxgrad+ord('0'))];
  295.   grad := ord(key) - ord('0');
  296.   initgraphic;                               (* Grafik initialisieren *)
  297.   drawaxis;                                  (* Achsenkreuz zeichnen  *)
  298.   x := xmin;
  299.   d := (xmax-xmin)/s;
  300.   f1 := fn(x,grad);
  301.   ok := calcresult;
  302.   f2 := fn(x+d,grad);
  303.   ok := ok AND calcresult;
  304.   WHILE (x+d<=xmax) AND NOT Keypressed DO
  305.     BEGIN
  306.       IF ok
  307.         THEN
  308.           drawline (x,f1,x+d,f2);     (* Zeichnen der Funktion *)
  309.       x := x + d;
  310.       f1 := fn(x,grad);
  311.       ok := calcresult;
  312.       f2 := fn(x+d,grad);
  313.       ok := ok AND calcresult;
  314.     END;
  315.   REPEAT UNTIL keypressed;
  316.   leavegraphic
  317. END;
  318.  
  319.