home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG017.ARC / GRAPHICS.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  12KB  |  300 lines
  1. program graphics;
  2. {This is my first attempt at graphics on a Microbee from TurboPascal.
  3.  What we have here is a set of procedures for lores graphics: LoRes, Dot,
  4.  Point, Line, Arc, and Box. For a description of each, read the comments
  5.  within the procedures. Included with them are: RestorePCG (which is pretty
  6.  well self-explanatory), Swap (which is used by the Line procedure), and
  7.  Rad (which is in there because I'm too lazy to reach for a calculator!).
  8.  Everything seems to work well, but the Arc procedure is pretty slow; any
  9.  speed improvements without any loss in flexibility (and without resorting to
  10.  machine code!) I really would like to see. The Line procedure could probably
  11.  be improved, but it performs quite well as it is.
  12.  
  13.  Eric Reaburn  6 November 1985  7:20 pm
  14. }
  15.  
  16. var
  17.   x,y:byte;
  18.   ans:char;
  19.  
  20. procedure RestorePCG;
  21. {Restore PCG characters by looking at the data for normal characters and
  22.  inverting this data. Data is hidden "under" screen RAM, so set the ROMREAD
  23.  latch to get at it.}
  24. const
  25.   chardat = $F000;
  26.   pcg = $F800;
  27. var
  28.   k:integer;
  29. begin
  30. port [11] := 1;      {set bit 0 (ROMREAD latch) to read character data}
  31. for k:=0 to $7FF do
  32.   mem [pcg+k] := mem [chardat+k] xor 255;
  33. port [11] := 0;      {reset ROMREAD latch to let screen be read if need be}
  34. end; {RestorePCG}
  35.  
  36. procedure LoRes;
  37. {Set up PCG characters for lores graphics use (only last 64 used). PCG
  38.  character is 2 lores pixels wide and 3 high, i.e. pcg character is split
  39.  into 6 blocks, top four being 4 bits wide and 4 hires pixels high each &
  40.  bottom two being 3 hires pixels high (character is 8 by 11 pixels;
  41.  4+4+3 = 11 high, 4+4 = 8 wide).}
  42. const
  43.   start_PCG = $FC00; {change this to use any 64 characters in PCG RAM}
  44.   needed = 64;       {number of programmable characters needed}
  45.   leftnybble = $F0;  {value of left nybble of byte            }
  46.   rightnybble = $0F; {  "   "  right  "    "   "              }
  47. var
  48.   chstart:integer;
  49.   k,used,part1,part2,part3,section,num:byte;
  50. {__________________________________}
  51.  procedure Fill (from:integer; amount,valu:byte);
  52.  {Fill an area of memory with "valu" starting from "from" and going for
  53.   "amount" bytes (ie "from" to "from" + "amount" - 1}
  54.  var
  55.    k:integer;
  56.  begin
  57.  for k := from to from + amount - 1 do
  58.    mem [k] := valu;
  59.  end; {Fill}
  60. {__________________________________}
  61.  function BiggestDivisor (var num:byte) :byte;
  62.  {Return largest value divisor for "num", reducing "num" by this value in the
  63.   process. Values tested for are 32, 16, 8, 4, 2, & 1.}
  64.  var
  65.    test,t,orgnum:byte;
  66.  begin
  67.  orgnum := num;
  68.  test := 64;
  69.  repeat
  70.    test := test div 2;
  71.    t := num div test;
  72.    if t <> 0 then begin
  73.                   BiggestDivisor := test;
  74.                   num := num - test;
  75.                   end;
  76.  until num <> orgnum;
  77.  end; {BiggestDivisor}
  78. {__________________________________}
  79. begin {LoRes}
  80. used := 0;
  81. repeat
  82.   chstart := start_PCG + used * 16;
  83.   if used = 0
  84.     then Fill(chstart,11,0)
  85.     else begin
  86.          num := used; part1 := 0; part2 := 0; part3 := 0;
  87.          repeat
  88.            section := BiggestDivisor(num);
  89.            case section of
  90.              1: part1 := part1 or leftnybble;
  91.              2: part1 := part1 or rightnybble;
  92.              4: part2 := part2 or leftnybble;
  93.              8: part2 := part2 or rightnybble;
  94.              16: part3 := part3 or leftnybble;
  95.              32: part3 := part3 or rightnybble;
  96.              end; {case}
  97.          until num=0;
  98.          Fill(chstart, 4, part1);   {fill first 4 bytes of character}
  99.          Fill(chstart+4, 4, part2); {...next 4 bytes...             }
  100.          Fill(chstart+8, 3, part3); {...last 3 bytes.               }
  101.          end;
  102.   used := used + 1;
  103. until used = needed;
  104. end; {LoRes}
  105. {____________________________________________________________________________}
  106. const
  107.   scrstart = $F000; {first location of screen memory}
  108.   firstlores = 192; {ASCII code of first lores character (which is a space)}
  109.                     {change this along with start_PCG above to use any 64  }
  110.                     {characters in PCG RAM                                 }
  111.  
  112. procedure Dot (on:boolean; x,y:byte);
  113. {If "on" is true then set a lores pixel at coordinates (x,y), else erase it.
  114.  X is 1 to 160, Y is 1 to 72.}
  115. var
  116.   scrpos:integer; {screen position}
  117.   charcode,scrx,scry,tx,ty,testbyte,nybble:byte;
  118. begin
  119. if (x in [1..160]) and (y in [1..72])
  120.   then begin
  121.        x := x - 1; y := y - 1;
  122.        scrx := x shr 1; scry := y div 3;       {scrx: 0-79, scry: 0-23}
  123.        scrpos := scrstart + scry * 80 + scrx;
  124.        charcode := mem [scrpos];
  125.        if charcode < firstlores then charcode := firstlores;
  126.        tx := x - scrx - scrx;        {tx: 0-1}
  127.        ty := y - scry - scry - scry; {ty: 0-2}
  128.        testbyte := mem [scrstart + charcode * 16 + (ty shl 2)]; {sample byte from lores pixel}
  129.        if tx = 0 then nybble := $F0  {look at left side}
  130.                  else nybble := $0F; {look at right side}
  131.        if on
  132.          then begin
  133.               if (testbyte and nybble) = 0 {turn pixel on if currently off}
  134.                 then mem [scrpos] := charcode + (1 shl (ty+ty+tx));
  135.               end
  136.          else begin
  137.               if (testbyte and nybble) <> 0 {turn pixel off if currently on}
  138.                 then mem [scrpos] := charcode - (1 shl (ty+ty+tx));
  139.               end;
  140.        end;
  141. end; {Dot}
  142. {____________________________________________________________________________}
  143. function Point (x,y:byte) :boolean;
  144. {Test to see whether a lores pixel is on at coordinates (x,y). True if it is.}
  145. var
  146.   scrx,scry,charcode,tx,ty,testbyte,nybble:byte;
  147. begin
  148. Point := false;
  149. if (x in [1..160]) and (y in [1..72])
  150.   then begin
  151.        x := x - 1; y := y - 1;
  152.        scrx := x shr 1; scry := y div 3;       {scrx: 0-79, scry: 0-23}
  153.        charcode := mem [scrstart + scry * 80 + scrx];
  154.        if charcode < firstlores then charcode := firstlores;
  155.        tx := x - scrx - scrx;        {tx: 0-1}
  156.        ty := y - scry - scry - scry; {ty: 0-2}
  157.        testbyte := mem [scrstart + charcode * 16 + (ty shl 2)]; {sample byte from lores pixel}
  158.        if tx = 0 then nybble := $F0  {look at left side}
  159.                  else nybble := $0F; {look at right side}
  160.        if (testbyte and nybble) <> 0
  161.          then Point := true;
  162.        end;
  163. end; {Point}
  164. {____________________________________________________________________________}
  165. procedure Swap (var a,b:byte);
  166. {Swap the values "a" and "b".}
  167. var
  168.   temp:byte;
  169. begin
  170. temp := a; a := b; b := temp;
  171. end; {Swap}
  172. {____________________________________________________________________________}
  173. procedure Line (draw:boolean; x1,y1,x2,y2:byte);
  174. {If "draw" is true, then draw a line from (x1,y1) to (x2,y2); else erase a
  175.  line from (x1,y1) to (x2,y2).}
  176. var
  177.   x,y:byte;
  178.   xreal,yreal,incx,incy:real;
  179.   lx,ly:integer;
  180.   equiv:boolean;
  181. begin
  182. lx := x2 - x1; ly := y2 - y1; {length horizontal; length vertical}
  183. if (lx <> 0) or (ly <> 0)
  184.   then begin                      {only if BOTH lx AND ly aren't zero}
  185.        if (lx <> 0) xor (ly <> 0)
  186.          then begin               {only if EITHER lx OR ly is zero}
  187.               if lx = 0
  188.                 then begin               {vertical line}
  189.                      if ly < 0
  190.                        then Swap(y1,y2);
  191.                      for y:=y1 to y2 do
  192.                        dot(draw,x1,y);
  193.                      end
  194.                 else begin               {horizontal line}
  195.                      if lx < 0
  196.                        then Swap(x1,x2);
  197.                      for x:=x1 to x2 do
  198.                        dot(draw,x,y1);
  199.                      end;
  200.               end
  201.          else begin                    {NEITHER ly NOR lx are zero}
  202.               if ((lx < 0) and (ly < 0)) or ((lx > 0) and (ly > 0))
  203.                 then equiv := true {if equivalent in sign, i.e. diagonal sloping from top left to bottom right}
  204.                 else equiv := false; {else it's a diagonal sloping from bottom left to top right}
  205.               if abs(lx) >= abs(ly)
  206.                 then begin {horizontal length => vertical length}
  207.                      incy := abs(ly / lx);
  208.                      if lx < 0
  209.                        then begin        {swap coordinates}
  210.                             Swap(x1,x2); Swap(y1,y2);
  211.                             end;
  212.                      yreal := y1;
  213.                      for x:=x1 to x2 do
  214.                        begin
  215.                        dot(draw,x,round(yreal));
  216.                        if equiv then yreal := yreal + incy
  217.                                 else yreal := yreal - incy;
  218.                        end;
  219.                      end
  220.                 else begin {vertical length > horizontal length}
  221.                      incx := abs(lx / ly);
  222.                      if ly < 0
  223.                        then begin
  224.                             Swap(x1,x2); Swap(y1,y2);
  225.                             end;
  226.                      xreal := x1;
  227.                      for y:=y1 to y2 do
  228.                        begin
  229.                        dot(draw,round(xreal),y);
  230.                        if equiv then xreal := xreal + incx
  231.                                 else xreal := xreal - incx;
  232.                        end;
  233.                      end;
  234.               end;
  235.        end
  236.   else dot(draw,x1,y1);
  237. end; {Line}
  238. {____________________________________________________________________________}
  239. procedure Arc (draw:boolean; centrex,centrey:integer; xradius,yradius:byte;
  240.                startangle,finishangle:real);
  241. {If "draw" is true an arc will be drawn, else it will be erased. "centrex" and
  242.  "centrey" are the coordinates of the focus of the arc. "xradius" is half
  243.  the horizontal distance from the focus, "yradius" is half the vertical
  244.  distance from the focus."startangle" is the angle from which the arc will
  245.  start, "finishangle" is the angle at which the arc ends. Angles are measured
  246.  from the positive x-axis, as in the Unit Circle.}
  247. var
  248.   theta,inc:real;
  249.   x,y:integer;
  250. begin
  251. if (startangle >= 0) and (finishangle > startangle)
  252.   then begin
  253.        inc := 1 / ((xradius shl 1) + yradius);
  254.        theta := startangle;
  255.        repeat
  256.          y := round(sin(theta) * yradius); x := round(cos(theta) * xradius);
  257.          dot(draw,centrex+x,centrey-y);
  258.          theta := theta + inc;
  259.        until theta > finishangle;
  260.        end;
  261. end; {Arc}
  262. {____________________________________________________________________________}
  263. procedure Box (draw:boolean; x,y,lx,ly:byte);
  264. {If "draw" is true draw a box, else erase it. (x,y) are coordinates of the
  265.  upper left corner of the box, "lx" is width of the box, "ly" is height of the
  266.  box.}
  267. begin
  268. line(draw,x,y,x+lx,y);
  269. line(draw,x,y,x,y+ly);
  270. line(draw,x+lx,y,x+lx,y+ly);
  271. line(draw,x,y+ly,x+lx,y+ly);
  272. end; {Box}
  273. {____________________________________________________________________________}
  274. function Rad (degrees:integer) :real;
  275. {Convert "degrees" to radians.}
  276. begin
  277. Rad := (degrees / 180) * pi;
  278. end; {Rad}
  279.  
  280. begin
  281. clrscr; lores;
  282. x := 1;
  283. repeat
  284.   line(true,x,1,161-x,72);
  285.   x := x + 2;
  286. until x > 160;
  287. y := 1;
  288. repeat
  289.   line(true,1,y,160,73-y);
  290.   y := y + 2;
  291. until y > 72;
  292. arc(false,80,36,20,13,0,2*pi);
  293. read(kbd,ans);
  294. restorepcg;
  295. end.
  296. until y > 72;
  297. arc(false,80,36,20,13,0,2*pi);
  298. read(kbd,ans);
  299. restorepcg;
  300. end.