home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 12 / praxis / graphx.mod < prev    next >
Encoding:
Modula Implementation  |  1989-09-14  |  19.7 KB  |  833 lines
  1. (* Copyright (C) 1987 Jensen & Partners International *)
  2.  
  3. (*$N,V-,I-,R-,A-,S-*)
  4. IMPLEMENTATION MODULE GraphX;
  5. IMPORT Lib, SYSTEM;
  6. FROM ASMGraph IMPORT ASMHires, ASMText, ASMPlot,
  7.                      ASMPoint, ASMLine;
  8.  
  9.  
  10. TYPE
  11.   tinyint      = [0..7];
  12.   bs           = SET OF tinyint;
  13.   bp           = POINTER TO bs;
  14.   HercMapType  = ARRAY[0..(HercDepth DIV 4)-1] OF
  15.                    ARRAY[0..(HercWidth DIV 8)-1] OF bs;
  16.   ATTMapType   = ARRAY[0..(ATTDepth DIV 4)-1] OF
  17.                    ARRAY[0..(ATTWidth DIV 8)-1] OF bs;
  18. VAR
  19.   HercBitMap   : ARRAY[0..3] OF POINTER TO HercMapType;
  20.   ATTBitMap    : ARRAY[0..3] OF POINTER TO ATTMapType;
  21.   EGAScreen [0A000H:0] : ARRAY[0..0] OF bs;
  22.  
  23.  
  24. (* == CGA specific routines == *)
  25.  
  26.  
  27. PROCEDURE CGAGraphMode;
  28. VAR r : SYSTEM.Registers;
  29. BEGIN
  30.   r.AX := 5;
  31.   Lib.Intr( r,10H );
  32. END CGAGraphMode;
  33.  
  34. PROCEDURE CGATextMode;
  35. VAR r : SYSTEM.Registers;
  36. BEGIN
  37.   r.AX := 3;
  38.   Lib.Intr( r,10H );
  39. END CGATextMode;
  40.  
  41. PROCEDURE CGAPlot(x,y:CARDINAL;c:CARDINAL);
  42. VAR
  43.   off : CARDINAL;
  44.   seg : CARDINAL;
  45.   tmp : CARDINAL;
  46. BEGIN
  47.   IF (x >= CGAWidth) OR (y >= CGADepth) THEN RETURN END;
  48.   off := x >> 2;
  49.   IF ODD(y) THEN INC( off, 2000H - 40 ) END;
  50.   INC( y, y << 2 );
  51.   INC( off, y << 3 );
  52.   x := 3 - CARDINAL( BITSET(x) * BITSET(3) );
  53.   x := x << 1;
  54.   tmp := 0B800H; seg := tmp;
  55.   [seg:off bp]^ := ( [seg:off bp]^ - bs(3<<x) ) + bs(c<<x);
  56. END CGAPlot;
  57.  
  58. PROCEDURE CGAPoint(x,y:CARDINAL) : CARDINAL;
  59. VAR
  60.   off : CARDINAL;
  61.   seg : CARDINAL;
  62.   tmp : CARDINAL;
  63. BEGIN
  64.   IF (x >= CGAWidth) OR (y >= CGADepth) THEN RETURN MAX(CARDINAL) END;
  65.   off := x >> 2;
  66.   IF ODD(y) THEN INC( off, 2000H - 40 ) END;
  67.   INC( y, y << 2 );
  68.   INC( off, y << 3 );
  69.   x := 3 - CARDINAL( BITSET(x) * BITSET(3) );
  70.   x := x << 1;
  71.   tmp := 0B800H; seg := tmp;
  72.   RETURN CARDINAL( [seg:off bp]^ * bs(3<<x) ) >> x;
  73. END CGAPoint;
  74.  
  75. PROCEDURE CGAHLine ( x,y,x2 : CARDINAL; c:CARDINAL );
  76. VAR
  77.   off  : CARDINAL;
  78.   seg  : CARDINAL;
  79.   tmp  : CARDINAL;
  80.   n    : CARDINAL;
  81.   w    : bs;
  82.   mask : bs;
  83.   fillc: SHORTCARD;
  84. BEGIN
  85.   IF y > CGADepth-1 THEN RETURN END;
  86.   IF INTEGER(x) >= INTEGER(CGAWidth) THEN RETURN END;
  87.   IF INTEGER(x) < 0 THEN x := 0; END;
  88.   IF x2 >= CGAWidth THEN x2 := CGAWidth-1 END;
  89.  
  90.   n := ( x2 - x ) + 1;
  91.   off := x >> 2;
  92.   IF ODD(y) THEN
  93.     INC( off, 2000H - 40 );
  94.     c := ( c >> 2 + c << 2 ) MOD 16;
  95.   END;
  96.   c := c + c * 16;
  97.   INC( y, y << 2 );
  98.   INC( off, y << 3 );
  99.   x := 3 - CARDINAL( BITSET(x) * BITSET(3) );
  100.   x := x << 1;
  101.   tmp := 0B800H; seg := tmp;
  102.  
  103.   w := [seg:off bp]^;
  104.   REPEAT
  105.     mask := bs(3 << x);
  106.     w := ( w - mask ) + bs(c)*mask;
  107.     DEC(n);
  108.     DEC(x,2);
  109.   UNTIL (n=0) OR (x=CARDINAL(-2));
  110.   [seg:off bp]^ := w;
  111.  
  112.   INC(off);
  113.   Lib.Fill( [seg:off], n >> 2, SHORTCARD(c) );
  114.   INC( off, n >> 2 );
  115.   n := n MOD 4;
  116.   x := 6;
  117.   w := [seg:off bp]^;
  118.   WHILE n <> 0 DO
  119.     mask := bs(3 << x);
  120.     w := ( w - mask ) + bs(c)*mask;
  121.     DEC(n);
  122.     DEC(x,2);
  123.   END;
  124.   [seg:off bp]^ := w;
  125. END CGAHLine;
  126.  
  127. PROCEDURE InitCGA ;
  128. BEGIN
  129.   Width := CGAWidth ;
  130.   Depth := CGADepth ;
  131.   NumColor := 4 ;
  132.   TextMode := CGATextMode ;
  133.   GraphMode := CGAGraphMode ;
  134.   Plot := CGAPlot ;
  135.   Point := CGAPoint ;
  136.   HLine := CGAHLine ;
  137. END InitCGA ;
  138.  
  139. (* == EGA/VGA specific routines == *)
  140.  
  141. PROCEDURE EGAGraphMode; (* Also VGA *)
  142. VAR r : SYSTEM.Registers;
  143. BEGIN
  144.   IF Depth=480 THEN r.AX := 12H ELSE r.AX := 10H END ;
  145.   Lib.Intr( r,10H );
  146. END EGAGraphMode;
  147.  
  148.  
  149. PROCEDURE EGAPlot( x,y,c : CARDINAL); (* Also VGA *)
  150. VAR
  151.   t:bs;
  152.   p,b,s:CARDINAL;
  153. BEGIN
  154.    IF (x < EGAWidth) AND (y < Depth) THEN
  155.       b := 1 << (7-(x MOD 8));
  156.       p := y*80+(x DIV 8);
  157.       SYSTEM.Out( 3CEH,8);SYSTEM.Out( 3CFH,SHORTCARD(b));
  158.       SYSTEM.Out( 3C4H,2);SYSTEM.Out( 3C5H,0FH);
  159.       s := 0A000H;
  160.       t := [s:p bp]^;
  161.       [s:p bp]^ := bs{};
  162.       SYSTEM.Out( 3C4H,2);SYSTEM.Out( 3C5H,SHORTCARD(c));
  163.       [s:p bp]^ := bs{0..7};
  164.       SYSTEM.Out( 3CEH,8);SYSTEM.Out( 3CFH,0FFH);
  165.       SYSTEM.Out( 3C4H,2);SYSTEM.Out( 3C5H,0FH);
  166.    END;
  167. END EGAPlot;
  168.  
  169. PROCEDURE EGAPoint(x,y:CARDINAL) : CARDINAL; (* Also VGA *)
  170. VAR
  171.   t:bs;
  172.   p,b,s:CARDINAL;
  173.   c:CARDINAL;
  174. BEGIN
  175.   IF (x < EGAWidth) AND (y < Depth) THEN
  176.     b := 1 << (7-(x MOD 8));
  177.     p := y*80+(x DIV 8  );
  178.  
  179.     s := 0A000H;
  180.  
  181.     SYSTEM.Out( 3CEH, 4 ); (* read map sel *)
  182.  
  183.     SYSTEM.Out( 3CFH, 3 );
  184.     t := [s:p bp]^;
  185.     t := t * bs(b);
  186.     c := CARDINAL( SHORTCARD(t) );
  187.  
  188.     SYSTEM.Out( 3CFH, 2 );
  189.     t := [s:p bp]^;
  190.     t := t * bs(b);
  191.     c := c * 2 + CARDINAL( SHORTCARD(t) );
  192.  
  193.     SYSTEM.Out( 3CFH, 1 );
  194.     t := [s:p bp]^;
  195.     t := t * bs(b);
  196.     c := c * 2 + CARDINAL( SHORTCARD(t) );
  197.  
  198.     SYSTEM.Out( 3CFH, 0 );
  199.     t := [s:p bp]^;
  200.     t := t * bs(b);
  201.     c := c * 2 + CARDINAL( SHORTCARD(t) );
  202.  
  203.     c := c >> ( 7 - ( x MOD 8 ) );
  204.  
  205.     RETURN c;
  206.   ELSE
  207.     RETURN 0;
  208.   END;
  209. END EGAPoint;
  210.  
  211. PROCEDURE EGAHLine ( x,y,x2 : CARDINAL; c:CARDINAL ); (* Also VGA *)
  212. VAR c1,c2 : CARDINAL;
  213. BEGIN
  214.   IF y > Depth-1 THEN RETURN END;
  215.   IF INTEGER(x) >= INTEGER(EGAWidth) THEN RETURN END;
  216.   IF INTEGER(x) < 0 THEN x := 0; END;
  217.   IF x2 >= EGAWidth THEN x2 := EGAWidth-1 END;
  218.   WHILE (x MOD 8 # 0)  AND (x <= x2) DO
  219.     EGAPlot( x  , y , c ); INC( x  );
  220.   END;
  221.   WHILE (x2 MOD 8 # 7) AND (x <= x2) DO
  222.     EGAPlot( x2 , y , c ); DEC( x2 );
  223.   END;
  224.   IF INTEGER(x) > INTEGER(x2) THEN RETURN; END;
  225.   SYSTEM.Out( 3CEH,8);SYSTEM.Out( 3CFH,0FFH);
  226.   SYSTEM.Out( 3C4H,2);SYSTEM.Out( 3C5H,0FH);
  227.   SYSTEM.Out( 3CEH,5);SYSTEM.Out( 3CFH,2);
  228.   y := y*80;
  229.   x := x DIV 8;
  230.   x2 := x2 DIV 8;
  231.   WHILE x <= x2 DO
  232.     EGAScreen[y+x] := bs(c);
  233.     INC( x );
  234.   END;
  235.   SYSTEM.Out( 3CEH,5);SYSTEM.Out( 3CFH,0);
  236. END EGAHLine;
  237.  
  238.  
  239. PROCEDURE InitEGA ;
  240. BEGIN
  241.   Width     := EGAWidth ;
  242.   Depth     := EGADepth ;
  243.   NumColor  := 16 ;
  244.   TextMode  := CGATextMode ;
  245.   GraphMode := EGAGraphMode ;
  246.   Plot      := EGAPlot ;
  247.   Point     := EGAPoint ;
  248.   HLine     := EGAHLine ;
  249. END InitEGA ;
  250.  
  251. PROCEDURE InitVGA ;
  252. BEGIN
  253.   InitEGA ;
  254.   Depth := VGADepth ; (* Width same as EGA *)
  255. END InitVGA ;
  256.  
  257.  
  258. (* == Hercules specific routines == *)
  259.  
  260.  
  261. PROCEDURE HercGraphMode;
  262. TYPE
  263.   DataType = ARRAY[0..11] OF SHORTCARD ;
  264. CONST
  265.   Data = DataType(35H,2DH,2EH,07H,5BH,02H,57H,57H,02H,03H,00H,00H);
  266. VAR
  267.   I: CARDINAL;
  268. BEGIN
  269.     SYSTEM.Out(3BFH,03H);    (* Remove this if do NOT want to override
  270.                                 the hercules text mode lock *)
  271.     Lib.Delay(10);
  272.     SYSTEM.Out(3B8H,02H);
  273.     FOR I:= 0 TO 11 DO
  274.         SYSTEM.Out(3B4H,SHORTCARD(I));
  275.         SYSTEM.Out(3B5H,Data[I])
  276.     END;
  277.     Lib.WordFill([0B000H:0],4000H,0);
  278.     Lib.Delay(500);
  279.     SYSTEM.Out(3B8H,0AH)
  280. END HercGraphMode;
  281.  
  282. PROCEDURE HercTextMode;
  283. TYPE
  284.   DataType = ARRAY[0..11] OF SHORTCARD ;
  285. CONST
  286.   Data = DataType(61H,50H,52H,0FH,19H,06H,19H,19H,02H,0DH,0BH,0CH);
  287. VAR
  288.   I: CARDINAL;
  289. BEGIN
  290.     SYSTEM.Out(3B8H,20H);
  291.     FOR I:= 0 TO 11 DO
  292.         SYSTEM.Out(3B4H,SHORTCARD(I));
  293.         SYSTEM.Out(3B5H,Data[I])
  294.     END;
  295.     Lib.WordFill([0B000H:0],2000,720H);
  296.     Lib.Delay(500);
  297.     SYSTEM.Out(3B8H,28H)
  298. END HercTextMode;
  299.  
  300. PROCEDURE HercPlot(x,y:CARDINAL;c:CARDINAL);
  301. BEGIN
  302.   IF (x >= HercWidth) OR (y >= HercDepth) THEN RETURN END;
  303.   IF c = 0 THEN
  304.      EXCL(HercBitMap[y MOD 4]^[y >> 2][x >> 3], 7-(x MOD 8))
  305.   ELSE
  306.      INCL(HercBitMap[y MOD 4]^[y >> 2][x >> 3], 7-(x MOD 8))
  307.   END
  308. END HercPlot;
  309.  
  310. PROCEDURE HercPoint(x,y:CARDINAL) : CARDINAL;
  311. BEGIN
  312.   IF (x >= HercWidth) OR (y >= HercDepth) THEN RETURN MAX(CARDINAL); END;
  313.   RETURN CARDINAL(7-(x MOD 8) IN HercBitMap[y MOD 4]^[y >> 2][x >> 3])
  314. END HercPoint;
  315.  
  316. PROCEDURE HercHLine ( x,y,x2 : CARDINAL; c:CARDINAL );
  317. VAR
  318.   I         : CARDINAL;
  319.   MapNum    : CARDINAL;
  320.   Byte1     : CARDINAL;
  321.   Byte2     : CARDINAL;
  322.   Bitx      : CARDINAL;
  323.   Bitx2     : CARDINAL;
  324.   Mask      : bs;
  325.   IMask     : bs;
  326. BEGIN
  327.   IF y > HercDepth-1 THEN RETURN END;
  328.   IF INTEGER(x) >= INTEGER(HercWidth) THEN RETURN END;
  329.   IF INTEGER(x) < 0 THEN x := 0; END;
  330.   IF x2 >= HercWidth THEN x2 := HercWidth-1 END;
  331.   IF c = 0 THEN
  332.      (* No Mask needed *)
  333.   ELSIF c MOD (HercNumColor+1) = 0 THEN
  334.      Mask:= bs{0..7}
  335.   ELSE
  336.      Mask:= bs(0AAH >> CARDINAL(ODD(y)));
  337.   END;
  338.  
  339.   MapNum    := y MOD 4;
  340.   y         := y >> 2;
  341.   Byte1     := x >> 3;
  342.   Byte2     := x2 >> 3;
  343.   Bitx      := 7-(x MOD 8);
  344.   Bitx2     := 7-(x2 MOD 8);
  345.  
  346.   IF c = 0 THEN
  347.      IF Byte2 = Byte1 THEN
  348.         HercBitMap[MapNum]^[y][Byte1]:=
  349.         (HercBitMap[MapNum]^[y][Byte1] - bs{Bitx2..Bitx});
  350.      ELSE
  351.         HercBitMap[MapNum]^[y][Byte1]:=
  352.         (HercBitMap[MapNum]^[y][Byte1] - bs{0..Bitx});
  353.  
  354.         IF Byte2-Byte1 > 1 THEN
  355.            Lib.Fill(ADR(HercBitMap[MapNum]^[y][Byte1+1]),Byte2-Byte1-1,0)
  356.         END;
  357.  
  358.         HercBitMap[MapNum]^[y][Byte2]:=
  359.         (HercBitMap[MapNum]^[y][Byte2] - bs{Bitx2..7});
  360.      END
  361.   ELSE
  362.      IF Byte2 = Byte1 THEN
  363.         HercBitMap[MapNum]^[y][Byte1]:=
  364.         ((HercBitMap[MapNum]^[y][Byte1]-bs{Bitx2..Bitx})
  365.         + (Mask * bs{Bitx2..Bitx}));
  366.      ELSE
  367.         HercBitMap[MapNum]^[y][Byte1]:=
  368.         ((HercBitMap[MapNum]^[y][Byte1]-bs{0..Bitx})
  369.         + (Mask * bs{0..Bitx}));
  370.  
  371.         IF Byte2-Byte1 > 1 THEN
  372.            Lib.Fill(ADR(HercBitMap[MapNum]^[y][Byte1+1]),Byte2-Byte1-1,
  373.                     Mask)
  374.         END;
  375.  
  376.         HercBitMap[MapNum]^[y][Byte2]:=
  377.         ((HercBitMap[MapNum]^[y][Byte2]-bs{Bitx2..7})
  378.         + (Mask * bs{Bitx2..7}));
  379.      END
  380.   END
  381. END HercHLine;
  382.  
  383. PROCEDURE InitHerc ;
  384. BEGIN
  385.   Width     := HercWidth ;
  386.   Depth     := HercDepth ;
  387.   NumColor  := 2 ;
  388.   TextMode  := HercTextMode ;
  389.   GraphMode := HercGraphMode ;
  390.   Plot      := HercPlot ;
  391.   Point     := HercPoint ;
  392.   HLine     := HercHLine ;
  393.   HercBitMap[0]:= [0B000H:0];      (* Initialise BitMap pointers *)
  394.   HercBitMap[1]:= [0B000H:02000H];
  395.   HercBitMap[2]:= [0B000H:04000H];
  396.   HercBitMap[3]:= [0B000H:06000H];
  397. END InitHerc ;
  398.  
  399. (* == AT&T 400 specific routines == *)
  400.  
  401.  
  402.  
  403. PROCEDURE ATTGraphMode;
  404. VAR r : SYSTEM.Registers;
  405. BEGIN
  406.   r.AX := 64;
  407.   Lib.Intr( r,10H );
  408. END ATTGraphMode;
  409.  
  410.  
  411. PROCEDURE ATTPlot(x,y:CARDINAL;c:CARDINAL);
  412. BEGIN
  413.   IF (x >= ATTWidth) OR (y >= ATTDepth) THEN RETURN END;
  414.   IF c = 0 THEN
  415.      EXCL(ATTBitMap[y MOD 4]^[y >> 2][x >> 3], 7-(x MOD 8))
  416.   ELSE
  417.      INCL(ATTBitMap[y MOD 4]^[y >> 2][x >> 3], 7-(x MOD 8))
  418.   END
  419. END ATTPlot;
  420.  
  421. PROCEDURE ATTPoint(x,y:CARDINAL) : CARDINAL;
  422. BEGIN
  423.   IF (x >= ATTWidth) OR (y >= ATTDepth) THEN RETURN MAX(CARDINAL); END;
  424.   RETURN CARDINAL(7-(x MOD 8) IN ATTBitMap[y MOD 4]^[y >> 2][x >> 3])
  425. END ATTPoint;
  426.  
  427. PROCEDURE ATTHLine ( x,y,x2 : CARDINAL; c:CARDINAL );
  428. VAR
  429.   I         : CARDINAL;
  430.   MapNum    : CARDINAL;
  431.   Byte1     : CARDINAL;
  432.   Byte2     : CARDINAL;
  433.   Bitx      : CARDINAL;
  434.   Bitx2     : CARDINAL;
  435.   Mask      : bs;
  436. BEGIN
  437.   IF y > ATTDepth-1 THEN RETURN END;
  438.   IF INTEGER(x) >= INTEGER(ATTWidth) THEN RETURN END;
  439.   IF INTEGER(x) < 0 THEN x := 0; END;
  440.   IF x2 >= ATTWidth THEN x2 := ATTWidth-1 END;
  441.  
  442.   IF c = 0 THEN
  443.      (* No Mask needed *)
  444.   ELSIF c MOD (ATTNumColor+1) = 0 THEN
  445.      Mask:= bs{0..7}
  446.   ELSE
  447.      Mask:= bs(0AAH >> CARDINAL(ODD(y)));
  448.   END;
  449.  
  450.   MapNum    := y MOD 4;
  451.   y         := y >> 2;
  452.   Byte1     := x >> 3;
  453.   Byte2     := x2 >> 3;
  454.   Bitx      := 7-(x MOD 8);
  455.   Bitx2     := 7-(x2 MOD 8);
  456.  
  457.   IF c = 0 THEN
  458.      IF Byte2 = Byte1 THEN
  459.         ATTBitMap[MapNum]^[y][Byte1]:=
  460.         (ATTBitMap[MapNum]^[y][Byte1] - bs{Bitx2..Bitx});
  461.      ELSE
  462.         ATTBitMap[MapNum]^[y][Byte1]:=
  463.         (ATTBitMap[MapNum]^[y][Byte1] - bs{0..Bitx});
  464.  
  465.         IF Byte2-Byte1 > 1 THEN
  466.            Lib.Fill(ADR(ATTBitMap[MapNum]^[y][Byte1+1]),Byte2-Byte1-1,0)
  467.         END;
  468.  
  469.         ATTBitMap[MapNum]^[y][Byte2]:=
  470.         (ATTBitMap[MapNum]^[y][Byte2] - bs{Bitx2..7});
  471.      END
  472.   ELSE
  473.      IF Byte2 = Byte1 THEN
  474.         ATTBitMap[MapNum]^[y][Byte1]:=
  475.         ((ATTBitMap[MapNum]^[y][Byte1]-bs{Bitx2..Bitx})
  476.         + (Mask * bs{Bitx2..Bitx}));
  477.      ELSE
  478.         ATTBitMap[MapNum]^[y][Byte1]:=
  479.         ((ATTBitMap[MapNum]^[y][Byte1]-bs{0..Bitx})
  480.         + (Mask * bs{0..Bitx}));
  481.  
  482.         IF Byte2-Byte1 > 1 THEN
  483.            Lib.Fill(ADR(ATTBitMap[MapNum]^[y][Byte1+1]),Byte2-Byte1-1,
  484.                     Mask)
  485.         END;
  486.  
  487.         ATTBitMap[MapNum]^[y][Byte2]:=
  488.         ((ATTBitMap[MapNum]^[y][Byte2]-bs{Bitx2..7})
  489.         + (Mask * bs{Bitx2..7}));
  490.      END
  491.   END
  492. END ATTHLine;
  493.  
  494. PROCEDURE InitATT ;
  495. BEGIN
  496.   Width     := ATTWidth ;
  497.   Depth     := ATTDepth ;
  498.   NumColor  := 2 ;
  499.   TextMode  := CGATextMode ;
  500.   GraphMode := ATTGraphMode ;
  501.   Plot      := ATTPlot ;
  502.   Point     := ATTPoint ;
  503.   HLine     := ATTHLine ;
  504.   ATTBitMap[0]:= [0B000H:8000H];  (* Initialise BitMap pointers *)
  505.   ATTBitMap[1]:= [0B000H:0A000H];
  506.   ATTBitMap[2]:= [0B000H:0C000H];
  507.   ATTBitMap[3]:= [0B000H:0E000H];
  508. END InitATT ;
  509.  
  510. (******* ------ Ab hier PC1512 ------- ********)
  511.  
  512. PROCEDURE MyHLine (x, y, x2 : CARDINAL; Color : CARDINAL);
  513. BEGIN
  514.   (* Für korrekte Koordinaten sorgen *)
  515.   IF y  >= Depth THEN RETURN END;
  516.   IF INTEGER (x) >= INTEGER (Width) THEN RETURN END;
  517.   IF INTEGER (x) < 0 THEN x := 0 END;
  518.   IF x2 >= Width THEN x2 := Width-1 END;
  519.   Line (x, y, x2, y, Color);
  520. END MyHLine;
  521.  
  522. PROCEDURE Init1512;
  523. BEGIN
  524.   GraphMode := ASMHires;
  525.   TextMode  := ASMText;
  526.   Clear     := ASMHires;
  527.   Plot      := ASMPlot;
  528.   Point     := ASMPoint;
  529.   HLine     := MyHLine;
  530.   Width     := 640;
  531.   Depth     := 200;
  532.   NumColor  := 16;
  533. END Init1512;
  534.  
  535. PROCEDURE Line1512(x1,y1,x2,y2,color : CARDINAL);
  536. BEGIN
  537.   ASMLine(x1,y1,x2,y2,color);
  538. END Line1512;
  539.  
  540.  
  541. (* ------  Device independant routines ------ *)
  542.  
  543.  
  544.  
  545.  
  546. PROCEDURE Line(x1,y1,x2,y2: CARDINAL; c: CARDINAL);
  547. VAR
  548.   dx,dy,e,tmp : INTEGER;
  549. BEGIN
  550.   IF x1 > x2 THEN (* ensure that x2 >= x1 *)
  551.     tmp := x1; x1 := x2; x2 := tmp;
  552.     tmp := y1; y1 := y2; y2 := tmp;
  553.   END;
  554.  
  555.   dx := x2-x1;
  556.   e  := 0;
  557.   IF y1 <= y2 THEN (* case where y increases *)
  558.     dy := (y2-y1);
  559.     IF dx >= dy THEN
  560.       LOOP
  561.         Plot( x1,y1,c );
  562.         IF x1 = x2 THEN EXIT END;
  563.         INC(x1);
  564.         INC(e,dy);
  565.         INC(e,dy);
  566.         IF e > dx THEN
  567.           DEC(e,dx);
  568.           DEC(e,dx);
  569.           INC(y1);
  570.         END;
  571.       END;
  572.     ELSE
  573.       LOOP
  574.         Plot( x1,y1,c );
  575.         IF y1 = y2 THEN EXIT END;
  576.         INC(y1);
  577.         INC(e,dx);
  578.         INC(e,dx);
  579.         IF e > dy THEN
  580.           DEC(e,dy);
  581.           DEC(e,dy);
  582.           INC(x1);
  583.         END;
  584.       END;
  585.     END;
  586.   ELSE
  587.     (* case where y decreases *)
  588.     dy := (y1-y2);
  589.     IF dx >= dy THEN
  590.       LOOP
  591.         Plot( x1,y1,c );
  592.         IF x1 = x2 THEN EXIT END;
  593.         INC(x1);
  594.         INC(e,dy);
  595.         INC(e,dy);
  596.         IF e > dx THEN
  597.           DEC(e,dx);
  598.           DEC(e,dx);
  599.           DEC(y1);
  600.         END;
  601.       END;
  602.     ELSE
  603.       LOOP
  604.         Plot( x1,y1,c );
  605.         IF y1 = y2 THEN EXIT END;
  606.         DEC(y1);
  607.         INC(e,dx);
  608.         INC(e,dx);
  609.         IF e > dy THEN
  610.           DEC(e,dy);
  611.           DEC(e,dy);
  612.           INC(x1);
  613.         END;
  614.       END;
  615.     END;
  616.   END;
  617. END Line;
  618.  
  619.  
  620. CONST
  621.   dx = 2;
  622.   dy = 2;
  623.  
  624. PROCEDURE Disc(x0,y0,r: CARDINAL; c: CARDINAL);
  625. VAR
  626.   e   : INTEGER;
  627.   x,y : CARDINAL;
  628. BEGIN
  629.   x := r; y := 0; e := 0;
  630.   WHILE INTEGER(y) <= INTEGER(x) DO
  631.     HLine(x0-x,y0+y,x0+x,c);
  632.     HLine(x0-x,y0-y,x0+x,c);
  633.     INC(y);
  634.     INC(e,y*dy-1);
  635.     IF e > INTEGER(x) THEN
  636.       DEC(x);
  637.       DEC(e,x*dx+1);
  638.       HLine(x0-y,y0+x,x0+y,c);
  639.       HLine(x0-y,y0-x,x0+y,c);
  640.     END;
  641.   END;
  642. END Disc;
  643.  
  644. PROCEDURE Circle(x0,y0,r: CARDINAL; c: CARDINAL);
  645. VAR
  646.   e   : INTEGER;
  647.   x,y : CARDINAL;
  648. BEGIN
  649.   x := r; y := 0; e := 0;
  650.   WHILE INTEGER(y) <= INTEGER(x) DO
  651.     Plot(x0+x,y0+y,c);
  652.     Plot(x0-x,y0+y,c);
  653.     Plot(x0+x,y0-y,c);
  654.     Plot(x0-x,y0-y,c);
  655.     Plot(x0+y,y0+x,c);
  656.     Plot(x0-y,y0+x,c);
  657.     Plot(x0+y,y0-x,c);
  658.     Plot(x0-y,y0-x,c);
  659.     INC(y);
  660.     INC(e,y*dy-1);
  661.     IF e > INTEGER(x) THEN
  662.       DEC(x);
  663.       DEC(e,x*dx+1);
  664.     END;
  665.   END;
  666. END Circle;
  667.  
  668. PROCEDURE Ellipse ( x0,y0 : CARDINAL ;  (* center *)
  669.                     a0,b0 : CARDINAL ;  (* semi-axes *)
  670.                     c     : CARDINAL ;  (* color *)
  671.                     fill  : BOOLEAN ) ; (* wether filled *)
  672. VAR
  673.   x,y : CARDINAL ;
  674.   a,b : LONGINT ;
  675.   asq,asq2,bsq,bsq2 : LONGINT ;
  676.   d,dx,dy           : LONGINT ;
  677. BEGIN
  678.   x := 0 ;
  679.   y := b0 ;
  680.   a := LONGINT(a0) ;
  681.   b := LONGINT(b0) ;
  682.   asq := a*a ;
  683.   asq2 := asq*2 ;
  684.   bsq := b*b ;
  685.   bsq2 := bsq*2 ;
  686.   d := bsq-(asq*b)+(asq DIV 4) ;
  687.   dx := 0 ;
  688.   dy := asq2*b ;
  689.   WHILE dx<dy DO
  690.     IF fill THEN
  691.       HLine(x0-x,y0+y,x0+x,c);
  692.       HLine(x0-x,y0-y,x0+x,c);
  693.     ELSE
  694.       Plot(x0+x,y0+y,c) ;
  695.       Plot(x0-x,y0+y,c) ;
  696.       Plot(x0+x,y0-y,c) ;
  697.       Plot(x0-x,y0-y,c) ;
  698.     END ;
  699.     IF d>0 THEN
  700.       DEC(y) ;
  701.       DEC(dy,asq2) ;
  702.       DEC(d,dy) ;
  703.     END ;
  704.     INC(x) ;
  705.     INC(dx,bsq2) ;
  706.     INC(d,bsq+dx) ;
  707.   END ;
  708.   INC(d,(3*(asq-bsq)DIV 2-(dx+dy))DIV 2) ;
  709.   WHILE INTEGER(y)>=0 DO
  710.     IF fill THEN
  711.       HLine(x0-x,y0+y,x0+x,c);
  712.       HLine(x0-x,y0-y,x0+x,c);
  713.     ELSE
  714.       Plot(x0+x,y0+y,c) ;
  715.       Plot(x0-x,y0+y,c) ;
  716.       Plot(x0+x,y0-y,c) ;
  717.       Plot(x0-x,y0-y,c) ;
  718.     END ;
  719.     IF d<0 THEN
  720.       INC(x) ;
  721.       INC(dx,bsq2) ;
  722.       INC(d,dx) ;
  723.     END ;
  724.     DEC(y) ;
  725.     DEC(dy,asq2) ;
  726.     INC(d,asq-dy) ;
  727.   END ;
  728. END Ellipse ;
  729.  
  730.  
  731. PROCEDURE Polygon(n: CARDINAL; px,py: ARRAY OF CARDINAL; c: CARDINAL);
  732. CONST
  733.   MaxPts = 20;
  734. VAR
  735.   y,miny,maxy,x0,y0,x1,y1,temp,i,edge,next_edge,active : INTEGER;
  736.   xord : ARRAY [0..MaxPts] OF INTEGER;
  737.   x    : ARRAY [0..MaxPts] OF CARDINAL;
  738.   e    : ARRAY [0..MaxPts] OF INTEGER;
  739.  
  740. PROCEDURE quicksort(l,r: INTEGER);
  741. VAR
  742.   i,j,temp : INTEGER;
  743.   key : CARDINAL;
  744. BEGIN
  745.   WHILE ( l < r ) DO
  746.     i := l; j := r; key := x[xord[j]];
  747.     REPEAT
  748.       WHILE ( i < j ) AND ( x[xord[i]] <= key ) DO i := i + 1 END;
  749.       WHILE ( i < j ) AND ( key <= x[xord[j]] ) DO j := j - 1 END;
  750.       IF i < j THEN
  751.         temp := xord[i]; xord[i] := xord[j]; xord[j] := temp;
  752.       END;
  753.     UNTIL ( i >= j );
  754.     temp := xord[i]; xord[i] := xord[r]; xord[r] := temp;
  755.     IF (i-l < r-i) THEN
  756.       quicksort( l, i-1 ); l := i+1;
  757.     ELSE
  758.       quicksort( i+1, r ); r := i-1;
  759.     END;
  760.   END;
  761. END quicksort;
  762.  
  763. BEGIN
  764.   IF n > MaxPts THEN n := MaxPts END;
  765.  
  766.   (* find extremal y points *)
  767.   miny := py[0]; maxy := miny;
  768.   FOR i := 0 TO n-1 DO
  769.     IF INTEGER(py[i]) < miny THEN miny := py[i]; END;
  770.     IF INTEGER(py[i]) > maxy THEN maxy := py[i]; END;
  771.   END;
  772.  
  773.   FOR y := miny TO maxy DO
  774.     active := -1;
  775.     FOR edge := 0 TO n-1 DO
  776.       IF edge = INTEGER(n-1) THEN next_edge := 0
  777.                              ELSE next_edge := edge + 1;
  778.       END;
  779.       x0 := px[edge]; y0 := py[edge];
  780.       x1 := px[next_edge]; y1 := py[next_edge];
  781.       IF y0 > y1 THEN temp := x0; x0 := x1; x1 := temp;
  782.                       temp := y0; y0 := y1; y1 := temp END;
  783.       IF y = y0 THEN e[edge] :=  0; x[edge] := x0
  784.       ELSIF ( y0 <= y ) AND ( y <= y1 ) THEN
  785.         IF x1 >= x0 THEN (* x increases with y *)
  786.           INC( e[edge], 2*(x1-x0) );
  787.           WHILE e[edge] > INTEGER(y1-y0) DO
  788.             DEC( e[edge], 2*(y1-y0) ); INC(x[edge]);
  789.           END;
  790.         ELSE (* x decreases with y *)
  791.           INC( e[edge], 2*(x0-x1) );
  792.           WHILE e[edge] > INTEGER(y1-y0) DO
  793.             DEC( e[edge], 2*(y1-y0) ); DEC(x[edge]);
  794.           END;
  795.         END;
  796.         active := active + 1;
  797.         xord[active] := edge;
  798.       END;
  799.     END;
  800.     quicksort(0,active);
  801.     i := 0;
  802.     WHILE i < active DO
  803.       HLine( x[xord[i]], y, x[xord[i+1]], c );
  804.       i := i + 2;
  805.     END;
  806.   END; (* for y := .. *)
  807. END Polygon;
  808.  
  809.  
  810.  
  811.  
  812. (* - Auto reset to text mode
  813.  
  814. VAR Continue:PROC;
  815. PROCEDURE Finish;
  816. BEGIN
  817.   TextMode;
  818.   Continue;
  819. END Finish;
  820.  
  821. BEGIN
  822.   Lib.Terminate( Finish, Continue );
  823.   InitCGA ;
  824. END Gr.
  825.  
  826. *)
  827.  
  828. BEGIN
  829.   InitCGA ; (* Change this for other adaptors *)
  830. END GraphX.
  831.  
  832.  
  833.