Turbo Toolbox/Turbo_Toolbox.iso/spezial/04/quellen/draw4.inc

Text File | 1979-12-31 | 8.0 KB | 330 lines

(*****************************************************************************)
(*                            DRAW4.INC                                      *)
(*                                                                           *)
(*               Unterprogramm-Modul zum Zeichnen der Funktion               *)
(*                   Speziell fuer Apple II+/e mit SoftCard                  *)
(*****************************************************************************)

PROCEDURE plotfunction;

VAR xmin,xmax, ymin,ymax, dx,dy,x,d, s1,f1,f2   : REAL;
    s,grad,i,j : INTEGER;
    key        : CHAR;
    ok         : BOOLEAN;

   (* Hier beginnt der hardwareabhaengige Teil *)

CONST screenxmax = 279;  (* Anzahl Bildpunkte horizontal                 *)
      screenymax = 191;  (*                   vertikal                   *)
      left       =  5;   (* Abstand Zeichenflaeche-linker Bildschirmrand *)
      bottom     =  5;   (*                       -unterer               *)
      unit       = 4;    (* halbe Breite der Achsenunterteilungsstriche  *)
      hgrpage    = 2;    (* Grafikseite; fuer SoftCard immer 2 !         *)

VAR   conoutptr_bak : INTEGER;

{ 6502 - Interface fuer Turbo-Pascal unter SoftCard}

VAR  A_REG   : BYTE    ABSOLUTE $F045;
     X_REG   : BYTE    ABSOLUTE $F046;
     Y_REG   : BYTE    ABSOLUTE $F047;
     XY_REG  : INTEGER ABSOLUTE $F046;
     AX_REG  : INTEGER ABSOLUTE $F045;
     A_RES   : BYTE    ABSOLUTE $F045;
     X_RES   : BYTE    ABSOLUTE $F046;
     Y_RES   : BYTE    ABSOLUTE $F047;


FUNCTION CHADDR(ADR : INTEGER) : INTEGER;
BEGIN
  CASE HI(ADR) OF
    $00..$0F : CHADDR := ADR + $F000;
    $10..$BF : CHADDR := ADR - $1000;
    $C0..$CF : CHADDR := ADR + $2000;
    $D0..$FF : CHADDR := ADR - $2000;
  END
END;

FUNCTION R6502(ADR : INTEGER) : BYTE;
BEGIN
 R6502 := MEM[CHADDR(ADR)]
END;

PROCEDURE W6502(ADR : INTEGER; VAL : BYTE);
BEGIN
  MEM[CHADDR(ADR)] := VAL
END;

PROCEDURE S6502(ADR : INTEGER);
VAR DUMMY : BYTE;
BEGIN
  MEM[CHADDR(ADR)] := 0
END;

PROCEDURE CALL6502(ADR : INTEGER);
BEGIN
  INLINE ($2A/ADR/
          $22/$F3D0/
          $2A/$F3DE/
          $77)
END;

{ Ende des Interface-Blocks fuer SoftCard }
{====================================================================}

  PROCEDURE dummy( a : CHAR);  (* faengt Bildschirmausgabe ab *)
  BEGIN END;

  PROCEDURE color(cl : INTEGER);

  BEGIN
    x_reg := cl;
    call6502($f6f0);
  END;

  PROCEDURE initgraphic;     (* Voreinstellungen fuer Grafikbetrieb *)

  CONST gr = $c050;
        nomix = $c052;
        pageslct = $c053;
        hires = $c057;
        apple_io = $c000;
        screen_80 = $c00c;
        page = $e6;

  BEGIN
    Clrscr;
    w6502(page,hgrpage * $20);
    call6502($f3f2);
    color(3);
    w6502(screen_80,0);
    w6502(apple_io,0);
    s6502(gr);
    s6502(nomix);
    s6502(pageslct + hgrpage);
    s6502(hires);
    conoutptr_bak := conoutptr;
    conoutptr := addr(dummy);
  END;

  PROCEDURE leavegraphic;    (* Voreinstellungen fuer Textbetrieb *)

  CONST txt = $c051;
        pageslct = $c053;
        nohires = $c056;
        secoff = $c054;
        apple_io = $c001;
        screen_80 = $c00d;

  BEGIN
    s6502(nohires);
    s6502(secoff);
    s6502(pageslct);
    s6502(txt);
    w6502(apple_io,0);
    w6502(screen_80,0);
    conoutptr := conoutptr_bak;
    Clrscr;
  END;

  FUNCTION checkkoord(VAR x,y : INTEGER) : BOOLEAN;

  VAR ok : BOOLEAN;

  BEGIN
    ok := TRUE;
    IF x < 0
      THEN
        BEGIN
          x := 0 ;
          ok := FALSE
        END
      ELSE
        IF x > screenxmax
          THEN
            BEGIN
              x := screenxmax;
              ok := FALSE
            END;
    IF y < 0
      THEN
        BEGIN
          y := 0;
          ok := FALSE
        END
      ELSE
        IF y > screenymax
          THEN
            BEGIN
              y := screenymax;
              ok := FALSE
            END;
    checkkoord := ok
  END;

  PROCEDURE position (x,y : INTEGER);

  BEGIN
    a_reg := screenymax - y;
    xy_reg := x;
    call6502($f411);
  END;

  PROCEDURE plot (x,y :INTEGER);    (* Punkt bei (x,y) zeichnen *)

  BEGIN
    IF checkkoord(x,y)
      THEN
        BEGIN
          xy_reg := x;
          a_reg  := screenymax - y;
          call6502 ($f457)
        END
      ELSE
        position(x,y);
  END;

  PROCEDURE draw (x1,y1,x2,y2 :INTEGER);(* Linie von (x1,y1) nach (x2,y2) *)

  BEGIN
    plot(x1,y1);
    IF checkkoord(x2,y2)
      THEN
        BEGIN
          ax_reg := x2;
          y_reg  := screenymax - y2;
          call6502 ($f53a)
        END
      ELSE
        position(x2,y2)
  END;
   (* hier endet der hardwareabhaengige Teil *)

  PROCEDURE worldtoscreen (x,y :REAL; VAR xs,ys :INTEGER);

  VAR a,b : REAL;

  BEGIN
    a := (x - xmin)*(screenxmax-left)/(xmax-xmin);
    b := (y - ymin)*(screenymax-bottom)/(ymax-ymin);
    IF Abs(a) > 32000.0
      THEN
        a := sign(a)*32000.0;
    IF Abs(b) > 32000.0
      THEN
        b := sign(b)*32000.0;
    xs := Round(a) + left;
    ys := Round(b) + bottom
  END;

  PROCEDURE drawpoint (x,y :REAL);(* zeichnet Punkt in Weltkoordinaten *)

  VAR xp,yp : INTEGER;

  BEGIN
    worldtoscreen (x,y,xp,yp);
    plot (xp,yp)
  END;

  PROCEDURE drawline (x1,y1,x2,y2 :REAL);(* zeichnet Linie in Weltkoordinaten *)

  VAR xp1,yp1,xp2,yp2 : INTEGER;

  BEGIN
    worldtoscreen (x1,y1,xp1,yp1);
    worldtoscreen (x2,y2,xp2,yp2);
    draw (xp1,yp1,xp2,yp2)
  END;

  PROCEDURE drawaxis;   (* zeichnet das Achsenkreuz *)

  VAR x,y,dist : REAL;

  BEGIN
    draw (left,bottom,left,screenymax);
    draw (left,bottom,screenxmax,bottom);
    drawline (xmin,0,xmax,0);
    drawline (0,ymin,0,ymax);
    dist := dy*(screenymax-bottom)/(ymax-ymin);(* Abstand y-Unterteilung *)
    x := left;
    y := bottom;
    WHILE y<=screenymax DO
      BEGIN
        draw (Round(x-unit),Round(y),Round(x+unit),Round(y));
        y := y + dist
      END;
    dist := dx*(screenxmax-left)/(xmax-xmin);(* Abstand y-Unterteilung *)
    x := left;
    y := bottom;
    WHILE x<=screenxmax DO
      BEGIN
        draw (Round(x),Round(y-unit),Round(x),Round(y+unit));
        x := x + dist
      END;
  END;

BEGIN
  Clrscr;
  Writeln ('Funktion zeichnen');
  REPEAT
    Writeln;
    formulaln (xmin,'im Bereich von xmin = ');
    formulaln (xmax,'           bis xmax = ');
  UNTIL xmin < xmax;
  REPEAT
    formulaln (dx, 'mit Schrittweite dx = ');
  UNTIL dx > 0.0;
  REPEAT
    Writeln;
    formulaln (ymin,'           von ymin = ');
    formulaln (ymax,'           bis ymax = ');
  UNTIL ymin < ymax;
  REPEAT
    formulaln (dy, ' mit Schrittweite dy = ');
  UNTIL dy > 0.0;
  Writeln;
  REPEAT
    formulaln (s1,'Anzahl der zu berechnenden Stuetzstellen : ');
    s := Round(s1);
  UNTIL s >= 0;
  if s = 0 THEN s := screenxmax-left;
  Writeln;
  Writeln('Welche Funktion soll gezeichnet werden ?');
  Writeln;
  for i := 0 to maxgrad do
  BEGIN
    Write('         f');
    for j := 1 to i do Write('''');
    Write('':maxgrad-i, '  : ',i:3);
    WriteLn
  END;
  Writeln;
  Write('Bitte waehlen :   ');
  REPEAT
    Read(kbd,key);
  UNTIL key in ['0'..chr(maxgrad+ord('0'))];
  grad := ord(key) - ord('0');
  initgraphic;                               (* Grafik initialisieren *)
  drawaxis;                                  (* Achsenkreuz zeichnen  *)
  x := xmin;
  d := (xmax-xmin)/s;
  f1 := fn(x,grad);
  ok := calcresult;
  f2 := fn(x+d,grad);
  ok := ok AND calcresult;
  WHILE (x+d<=xmax) AND NOT Keypressed DO
    BEGIN
      IF ok
        THEN
          drawline (x,f1,x+d,f2);     (* Zeichnen der Funktion *)
      x := x + d;
      f1 := fn(x,grad);
      ok := calcresult;
      f2 := fn(x+d,grad);
      ok := ok AND calcresult;
    END;
  REPEAT UNTIL keypressed;
  leavegraphic
END;