home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1988 / 04 / porter / porter.ls2 < prev    next >
Text File  |  1979-12-31  |  7KB  |  208 lines
  1.  
  2. STRUCTURED PROGRAMMING LISTING TWO APRIL ISSUE
  3.  
  4.  
  5.  
  6.  
  7. IMPLEMENTATION MODULE LineDwg;
  8.  
  9. (* Implements LineDrawing module defined by N. Wirth in *)
  10. (*   "Programming in Modula-2." This module assumes EGA *)
  11. (*   monitor in 640 x 350 color graphics mode.          *)
  12. (* Uses virtual coordinates, where origin is at lower   *)
  13. (*   left corner of screen area, size is 800 x 600.     *)
  14. (* Adapted by K. Porter for DDJ, April 1988 issue       *)
  15. (* ---------------------------------------------------- *)
  16.  
  17.   FROM SYSTEM IMPORT REGISTERS, INT;
  18.   FROM Strings IMPORT Length;
  19.  
  20.   CONST  VW  = 800.0;        (* virtual width of screen *)
  21.          VH  = 600.0;                 (* virtual height *)
  22.          RW  = 640.0;  (* real device width, EGA screen *)
  23.          RH  = 350.0;                  (* device height *)
  24.          EGA = 16;          (* EGA 640 x 350 color mode *)
  25.  
  26.   (* Variables local to this module *)
  27.   VAR   reg    : REGISTERS;
  28.         xf, yf : REAL;
  29.         color  : INTEGER;
  30.  
  31.   (* --------------LOCAL PROCEDURES ------------------------- *)
  32.  
  33.   PROCEDURE writePixel (c, x, y : INTEGER);
  34.                      (* write pixel of color c at device x, y *)
  35.  
  36.   BEGIN
  37.     reg.AH := 12;
  38.     CASE c OF           (* map color indicator to EGA palette *)
  39.       0 : reg.AL := 15|                              (* white *)
  40.       1 : reg.AL :=  7|                         (* light gray *)
  41.       2 : reg.AL :=  8|                          (* dark gray *)
  42.       3 : reg.AL :=  0                               (* black *)
  43.     END;  (* of CASE *)
  44.     reg.BX := 0;
  45.     reg.CX := x;
  46.     reg.DX := y;
  47.     INT (16, reg);
  48.     color := c;                       (* set prevailing color *)
  49.   END writePixel;
  50.   (* ------------------------ *)
  51.  
  52.   PROCEDURE devX (x : INTEGER) : INTEGER;
  53.                                    (* translate x to device x *)  
  54.  
  55.   BEGIN
  56.     RETURN TRUNC (xf * FLOAT (x)); 
  57.   END devX;
  58.   (* ------------------------ *)
  59.  
  60.   PROCEDURE devY (y : INTEGER) : INTEGER;
  61.                                    (* translate y to device y *)
  62.  
  63.   BEGIN
  64.     RETURN TRUNC (RH - (yf * FLOAT (y)));
  65.   END devY;
  66.  
  67.  
  68. (* ------------------ VISIBLE PROCEDURES -------------------- *)
  69.  
  70.   PROCEDURE dot (c : CARDINAL; x, y : INTEGER);
  71.  
  72.         (* Place a dot of color c at coordinate x, y *)
  73.  
  74.   BEGIN
  75.     writePixel (c, devX (x), devY (y));
  76.   END dot;
  77.   (* ------------------------ *)
  78.  
  79.   PROCEDURE line (d, n : CARDINAL);
  80.  
  81.         (* Draw a line of length n in direction d
  82.           (angle = 45 * d degrees) *)
  83.  
  84.   VAR  xdir, ydir : INTEGER;    (* x and y directions given d *)
  85.        distance   : CARDINAL;
  86.  
  87.   BEGIN
  88.     CASE d OF
  89.       0 : xdir :=  1; ydir :=  0|                    (* right *)
  90.       1 : xdir :=  1; ydir :=  1|
  91.       2 : xdir :=  0; ydir :=  1|                       (* up *)
  92.       3 : xdir := -1; ydir :=  1|
  93.       4 : xdir := -1; ydir :=  0|                     (* left *)
  94.       5 : xdir := -1; ydir := -1|
  95.       6 : xdir :=  0; ydir := -1|                     (* down *)
  96.       7 : xdir :=  1; ydir := -1
  97.     END;    (* of CASE *)
  98.     FOR distance := 1 TO n DO
  99.       Px := Px + xdir;                     (* advance the pen *)
  100.       Py := Py + ydir;
  101.       dot (color, Px, Py);        (* draw in prevailing color *)
  102.     END;
  103.   END line;
  104.   (* ------------------------ *)
  105.   PROCEDURE paint (c : CARDINAL; x, y, w, h : INTEGER);
  106.   
  107.   (* Paint the rectangular area at x, y of width w and 
  108.             height h in color c, where 0 = white, 
  109.             1 = light gray, 2 = dark gray, 3 = black *)
  110.   
  111.   VAR  cy, prevY, dy : INTEGER;
  112.  
  113.   BEGIN
  114.     prevY := 0;
  115.     color := c;                   (* set new prevailing color *)
  116.     FOR cy := y TO y+h DO
  117.       dy := devY (cy);                (* get current device y *)
  118.       IF dy <> prevY THEN           (* if new scan line, draw *)
  119.         Px := x; Py := cy;
  120.         line (0, w);
  121.         prevY := dy;        (* remember where last line drawn *)
  122.       END
  123.     END
  124.   END paint;
  125.   (* ------------------------ *)
  126.  
  127.   PROCEDURE copyArea (sx, sy, dx, dy, dw, dh : INTEGER);
  128.  
  129.         (* Copy rectangular area at sx, sy into rectangle 
  130.             at dx, dy of width dw and height dh *)
  131.  
  132.   VAR  c, x, y, ix, iy, nx, ny, tx, ty : INTEGER;
  133.  
  134.   BEGIN
  135.     ix := devX (sx);    iy := devY (sy); (* source dev coords *)
  136.     nx := devX (sx+dw); ny := devY (sy+dh);  (* ending coords *)
  137.     tx := devX (dx);    ty := devY (dy);     (* target coords *)
  138.     FOR y := ny TO iy DO                  (* go top to bottom *)
  139.       FOR x := ix TO nx DO
  140.         reg.AH := 13;                           (* read pixel *)
  141.         reg.BX := 0;
  142.         reg.CX := x;
  143.         reg.DX := y;
  144.         INT (16, reg);             (* get pixel color into al *)
  145.         reg.AH := 12;                  (* write pixel to dest *)
  146.         reg.CX := tx + x - ix;
  147.         reg.DX := ty + y - iy;
  148.         INT (16, reg);
  149.       END
  150.     END
  151.   END copyArea;
  152.   (* ------------------------ *)
  153.  
  154.   PROCEDURE clear;                        (* Clear the screen *)
  155.                 (* Also places display into EGA graphics mode *)
  156.  
  157.   BEGIN
  158.     reg.AH := 0;
  159.     reg.AL := EGA;                           (* EGA 640 x 350 *)
  160.     INT (16, reg);
  161.     color := 0;               (* reset default color to white *)
  162.   END clear;
  163.   (* ------------------------ *)
  164.  
  165.   PROCEDURE Write (ch : CHAR);  (* Write ch at pen's position *)
  166.  
  167.   VAR  cc, cr : INTEGER;                  (* Char col and row *)
  168.  
  169.   BEGIN
  170.     cc := devX (Px) DIV  8;       (* Derive char pos from pen *)
  171.     cr := devY (Py) DIV 14;
  172.     reg.AH := 2;                  (* Set text cursor position *)
  173.     reg.BX := 0;
  174.     reg.DX := (cr * 256) + cc;
  175.     INT (16, reg);
  176.     reg.AX := 2560 + ORD (ch);     (* Write char via ROM BIOS *)    
  177.     reg.BX := 7;                      (* Light gray text only *)
  178.     reg.CX := 1;
  179.     INT (16, reg);
  180.     Px := Px + CharWidth;    (* advance by char virtual width *)
  181.   END Write;
  182.   (* ------------------------ *)
  183.  
  184.   PROCEDURE WriteString (s : ARRAY OF CHAR);
  185.  
  186.   VAR  i : CARDINAL;
  187.  
  188.   BEGIN
  189.     FOR i := 0 TO Length (s) DO
  190.       Write (s[i]);
  191.     END
  192.   END WriteString;
  193.  
  194.   (* ---------------- INITIALIZATION ------------------------ *)
  195.  
  196. BEGIN
  197.   Px         := TRUNC (VW / 2.0);    (* Virtual screen center *)
  198.   Py         := TRUNC (VH / 2.0);
  199.   mode       := replace;
  200.   width      := TRUNC (VW);            (* Virtual screen size *)
  201.   height     := TRUNC (VH);
  202.   CharWidth  := 10;            (* Char sizes in virtual units *)
  203.   CharHeight := 24;
  204.   xf         := RW / VW;              (* x translation factor *)
  205.   yf         := RH / VH;              (* y translation factor *)
  206.   color      := 0;                  (* white is default color *)
  207. END LineDwg.
  208.