home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / paspaint / paspaint.pas
Encoding:
Pascal/Delphi Source File  |  1990-03-26  |  17.5 KB  |  597 lines
  1. {--------------------------------------------------}
  2. {  David A. SInclair                               }
  3. {  COS 55b                                         }
  4. {  Assignment #6, Part 2: Paint program            }
  5. {  90.03.26                                        }
  6. {  Release notes: File system now works fine, as   }
  7. {                 does Fill menu selection.        }
  8. {  Forthcoming:   Printer driver for IBM/Epson     }
  9. {--------------------------------------------------}
  10.  
  11.  
  12.  
  13. program PasPaint;
  14. uses GRAPH, CRT;
  15.  
  16. const
  17.   minpx = 67;                  (* Picture area coordinates.  *)
  18.   minpy = 21;
  19.   maxpx = 500;
  20.   maxpy = 300;
  21.  
  22. var  loopcnt : integer;
  23.      ximage  : pointer;
  24.      clearmsg : pointer;
  25.      curx, cury : integer;
  26.      oldx, oldy : integer;
  27.      done : boolean;
  28.      CurTS  : textsettingstype;
  29.      MenuTS : textsettingstype;
  30.      PENFLAG : boolean;
  31.  
  32. (*********************************************************)
  33. procedure moveit; FORWARD;             (* Forward so we can use during subs*)
  34. (*********************************************************)
  35. procedure prepit;
  36. var  driver,
  37.      mode  : integer;                (* Init graphics.....*)
  38. begin
  39.      driver := DETECT;
  40.      initgraph(driver, mode, '');
  41. end;
  42. (*********************************************************)
  43. procedure startscr;
  44. const cop = 'Copryright (C) 1990';
  45.       pname = 'PasPaint 1.0';
  46.       author = 'by: David A. Sinclair';
  47.       continue = '|  Press any key to continue. |';
  48. var
  49.       xstart : integer;
  50. begin
  51.      setcolor(yellow);
  52.      line(5,5,635,5);
  53.      line(5,5,5,330);
  54.      line(635,5,635,330);
  55.      setcolor(white);
  56.      Settextstyle(3, 0, 6);
  57.      xstart := round((640-(textwidth(pname)))/2);
  58.      Outtextxy(xstart, 70, pname);
  59.      SetTextStyle(3, 0, 3);
  60.      xstart := round((640-(textwidth(cop)))/2);
  61.      Outtextxy(xstart, 140, cop);
  62.      Settextstyle(1, 0, 4);
  63.      xstart := round((640-(textwidth(author)))/2);
  64.      Outtextxy(xstart, 220, author);
  65.      settextstyle(0, 0, 1);
  66.      setcolor(red);
  67.      xstart := round((640 - (textwidth(continue)))/2);
  68.      outtextxy(xstart, 330, continue);
  69.      setcolor(yellow);
  70.      line(5, 330, xstart, 330);
  71.      line(xstart + textwidth(continue), 330, 635, 330);
  72.      repeat
  73.       delay(1);                  (* Intro screen..... *)
  74.      until KEYPRESSED
  75. end;
  76. (*********************************************************)
  77. procedure setupscr;
  78. const  statusl = ' Message Line: ';
  79.        menu = ' MENU';
  80.        mfile = ' File';
  81.        mfont = ' Font';         (* Do menu bar ...  *)
  82.        mfill = ' Fill';
  83.        mabout = ' Info.';
  84.        mttool = ' A';
  85.  
  86. var x,
  87.     y : integer;
  88.  
  89. begin
  90. Cleardevice;
  91. setbkcolor(white);
  92. setcolor(blue);
  93. PENFLAG := false;
  94. Rectangle(66,1,635,20); outtextxy(70,8,statusl);
  95. rectangle(2,20,66,330); outtextxy(8, 25, menu);
  96. rectangle(minpx, minpy, maxpx, maxpy);
  97. line(2, 30+(textheight(menu)), 66, 30+(textheight(menu)));
  98. line(2, 60, 66, 60); circle(33, 50, 10);
  99. line(2, 85, 66, 85); rectangle(8, 65, 28, 80);
  100. line(34, 60, 34, 85);  line(40, 65, 60, 80);
  101. line(2, 110, 66, 110); outtextxy(8, 95, mfile);
  102. line(2, 135, 66, 135); outtextxy(8, 120, mfont);
  103. line(2, 160, 66, 160); line(34, 135, 34, 160);
  104.     line(12, 140, 20, 140); line(12, 150, 20, 150);
  105.     line(12, 140, 12, 150); line(20, 140, 20, 150);
  106.     line(12, 143, 20, 143);
  107.     line(12, 150, 16, 156);  line(20, 150, 16, 156);
  108.     outtextxy(40, 145, mttool);
  109.     settextstyle(0,0,1);
  110. for loopcnt := 1 to 8 do
  111.     begin
  112.     line(2, 160 + 12*loopcnt, 66, 160 + 12*loopcnt);
  113.     line(34, 135 + 12*loopcnt, 34, 160 + 12*loopcnt);
  114.     setfillstyle(solidfill, loopcnt - 1);
  115.     floodfill(4, 150 + 12*loopcnt, blue);
  116.     setfillstyle(solidfill, loopcnt + 7);
  117.     floodfill(40, 150 + 12*loopcnt, blue);
  118.     end;
  119. line(2, 280, 66, 280); outtextxy(8, 265, mfill);
  120. outtextxy(8, 298,  mabout);
  121. end;
  122. (*********************************************************)
  123. procedure xhair(x, y : integer);
  124. begin                                  (* How you show the cursor. *)
  125.      oldx := curx;  oldy := cury;
  126.      putimage(oldx, oldy, ximage^, xorput);
  127.      curx := x;     cury := y;
  128.      putimage(curx, cury, ximage^, xorput);
  129. end;
  130. (*********************************************************)
  131. procedure init_xhair;
  132. var  size : integer;
  133.  
  134. begin                                  (* Initialize crosshair cursor...*)
  135.      curx := 200; cury := 200;
  136.      line (curx-4, cury, curx+4, cury);
  137.      line (curx, cury-4, curx, cury+4);
  138.      size := imagesize(curx-4, cury-4, curx+4, cury+4);
  139.      getmem(ximage, size);
  140.      getimage(curx-4, cury-4, curx+4, cury+4, ximage^);
  141.      setcolor(white);
  142.      line (curx-4, cury, curx+4, cury);
  143.      line(curx, cury-4, curx, cury+4);
  144.      setcolor(black);
  145.      putimage(curx, cury, ximage^, xorput);
  146.      xhair(250, 250);
  147. end;
  148. (*********************************************************)
  149. procedure Init_Msg;
  150. const  msx = 185;
  151.        msy = 3;              (* Initialize message line. *)
  152.        mex = 625;            (* Save clear space to clear line later. *)
  153.        mey = 19;
  154. var  size : integer;
  155.  
  156. begin
  157.   size := imagesize(msx, msy, mex, mey);
  158.   getmem(clearmsg, size);
  159.   getimage(msx, msy, mex, mey, clearmsg^);
  160. end;
  161. (*********************************************************)
  162. procedure Message( newmsg : string);
  163. var curcol : integer;
  164. begin
  165.    curcol := getcolor;       (* Takes string to output in message line. *)
  166.    setcolor(red);
  167.    putimage(185, 3, clearmsg^, 3);
  168.    outtextxy(185, 8, newmsg);
  169.    setcolor(curcol);
  170. end;
  171. (*********************************************************)
  172. procedure Mcolor(x, y:integer);
  173. var newcol : integer;                  (* Set curcol to menu selection. *)
  174. begin
  175.   newcol := getpixel(x, y);
  176.   setcolor(newcol);
  177. end;
  178. (*********************************************************)
  179. procedure Trim_XY(var x, y: integer);
  180.  
  181. begin                                    (* Keep within picture coords. *)
  182.   if (x<minpx) then x:= minpx
  183.    else if (x>maxpx) then x:= maxpx;
  184.   if (y<minpy) then y:= minpy
  185.    else if (y>maxpy) then y:= maxpy;
  186. end;
  187. (*********************************************************)
  188. procedure Do_circ;
  189. var  dist: integer;
  190.      dx, dy: integer;                   (* Make circle in cur color. *)
  191.      centx, centy : integer;
  192.  
  193. begin
  194.   Message(' Place cursor on center point, then hit F5.');
  195.   Moveit;
  196.   centx := curx; centy := cury;
  197.   Message(' Now place cursor on circle and hit F5 again.');
  198.   moveit;
  199.   dx := curx;  dy := cury;
  200.   Trim_XY(centx, centy);
  201.   Trim_XY(dx, dy);
  202.   dist := round(sqrt(((centx-dx)*(centx-dx) + (centy-dy)*(centy-dy))));
  203.   circle(centx, centy, dist);
  204.   message(' ');
  205. end;
  206. (*********************************************************)
  207. procedure Do_rect;
  208. var  x1, y1: integer;           (* User-determined rectangle.. *)
  209.      x2, y2: integer;
  210.  
  211. begin
  212.   message(' Place cursor at upper left corner, then hit F5.');
  213.   moveit;
  214.   x1 := curx; y1:= cury;
  215.   message(' Now go to lower right, and hit F5.');
  216.   moveit;
  217.   x2:= curx;  y2:= cury;
  218.   Trim_XY(x1, y1);  Trim_XY(x2, y2);
  219.   rectangle(x1, y1, x2, y2);
  220.   message(' ');
  221. end;
  222. (*********************************************************)
  223. procedure Do_File;
  224. const mfile=' S(ave)  L(oad)  N(ew)  or  Q(uit)';
  225. var choice : char;                                (* File submenu...*)
  226.     subch : char;
  227. {------------------------------------------}
  228. procedure Clearpic;
  229. begin
  230.   message(' Clear picture?   Y(es)  or  N(o)');
  231.   subch := upcase(readkey);
  232.   if subch = 'Y' then                 (* Clear picture window. *)
  233.    begin
  234.         putimage(curx, cury, ximage^, xorput);
  235.         setviewport(minpx, minpy, maxpx, maxpy, clipon);
  236.         clearviewport;
  237.         setviewport(0, 0, 640, 345, true);
  238.    end
  239.   else message(' ')
  240. end;
  241. {------------------------------------------}
  242. procedure Leave;
  243. begin
  244.   Message(' Exit PasPaint?   Y(es)  or  N(o)');
  245.   subch := upcase(readkey);
  246.   case subch of                         (* Quit PasPaint   *)
  247.   'Y' : DONE:=TRUE;
  248.   end;
  249.   Message(' ')
  250. end;
  251. {------------------------------------------}
  252. procedure save;
  253. var fchar : char;                         (* Save file to disk!!  *)
  254.     writ, tell, sfile : string;
  255.     outf : file;
  256.     index, totwrit, size : integer;
  257.     pic : pointer;
  258.     result : word;
  259.  
  260. begin
  261. message(' File to save? (include pathname) ');
  262. fchar:= readkey;
  263. message(' ');
  264. sfile:= fchar;
  265. moveto(185, 8);
  266. outtext(fchar);
  267. while ord(fchar) <> 13 do
  268.  begin
  269.   fchar := readkey;
  270.   sfile := sfile + fchar;
  271.   outtext(fchar);
  272.  end;
  273. index := length(sfile);
  274. delete(sfile, index, 1);
  275. size := imagesize(minpx, minpy, maxpx, maxpy);
  276. getmem(pic, size);
  277. getimage(minpx, minpy, maxpx, maxpy, pic^);
  278. assign(outf, sfile);
  279. message(sfile);
  280. readln;
  281. rewrite(outf, 1);
  282.  blockwrite(outf, pic^, size, result);
  283. totwrit := filesize(outf);
  284. close(outf);
  285. freemem(pic, size);
  286. str(totwrit, writ);
  287. tell := writ + ' bytes written to file ' + sfile + '.';
  288. message(tell);
  289. end;
  290. {------------------------------------------}
  291. procedure load;
  292. var fsize, lfile : string;
  293.     inpf : file;                   (* Load saved picture!!   *)
  294.     index, size : integer;
  295.     lpic : pointer;
  296.     fchar : char;
  297.     result : word;
  298.  
  299. begin
  300. message(' File to load? (include pathname) ');
  301. fchar:= readkey;
  302. message(' ');
  303. lfile:= fchar;
  304. moveto(185, 8);
  305. outtext(fchar);
  306. while ord(fchar) <> 13 do
  307.  begin
  308.   fchar := readkey;
  309.   lfile := lfile + fchar;
  310.   outtext(fchar);
  311.  end;
  312. index := length(lfile);
  313. delete(lfile, index, 1);
  314. message(lfile);
  315. readln;
  316. assign(inpf, lfile);
  317. reset(inpf, 1);
  318. size := imagesize(minpx, minpy, maxpx, maxpy);
  319. getmem(lpic, size);
  320. blockread(inpf, lpic^, size, result);
  321. close(inpf);
  322. putimage(minpx, minpy, lpic^, 0);
  323. freemem(lpic, size);
  324. str(result, fsize);
  325. fsize := fsize + ' bytes read from file ' + lfile + '.';
  326. message(fsize);
  327. end;
  328. {------------------------------------------}
  329. begin
  330.   Message(mfile);
  331.   choice := upcase(readkey);
  332.   case choice of
  333.   'S' : save;
  334.   'L' : load;
  335.   'N' : Clearpic;
  336.   'Q' : Leave;
  337.   else message(' ')
  338.   end
  339. end;
  340. (*********************************************************)
  341. procedure Do_font;
  342. const chfont=' Which?  0 (System)  1 (Triplex)  2 (Small)  3 (Gothic)';
  343. var  fontch : char;
  344. begin
  345.   message(chfont);
  346.   fontch := readkey;        (* Change text style for picture. *)
  347.   case fontch of
  348.   '0' : MenuTS.font:= 0;
  349.   '1' : MenuTS.font:= 1;
  350.   '2' : MenuTS.font:= 2;
  351.   '3' : MenuTS.font:= 3;
  352.   else MenuTS.font := CurTS.font;
  353.   end;
  354.   message(' Size?   1(pix)  4(pix)  8(pix)');
  355.   fontch := readkey;
  356.   case fontch of
  357.   '1' : MenuTS.charsize:= 1;
  358.   '4' : MenuTS.charsize:= 4;
  359.   '8' : MenuTS.charsize:= 8;
  360.   else MenuTS.charsize:= CurTS.Charsize;
  361.   end;
  362.   message(' H(orizontal) or V(ertical) Orientation?');
  363.   fontch := upcase(readkey);
  364.   case fontch of
  365.   'H' : MenuTS.direction:= 0;
  366.   'V' : MenuTS.direction:= 1;
  367.   else MenuTS.direction:= CurTS.direction;
  368.   end;
  369.   message(' ');
  370. end;
  371. (*********************************************************)
  372. procedure DoUse;
  373. var  tchar : char;
  374.      tempx, tempy : integer;
  375.                                 (* Put text in picture. *)
  376. begin
  377.  Message(' Position cursor, then hit F5 and start typing.');
  378.  Moveit;
  379.  message(' Hit ENTER when done typing.');
  380.  moveto(curx, cury);
  381.  Settextstyle(MenuTS.font, MenuTS.direction, MenuTS.charsize);
  382.  repeat
  383.    tchar := readkey;
  384.    outtext(tchar);
  385.  until ord(tchar) = 13;
  386.  Settextstyle(CurTS.font, Horizdir, CurTS.charsize);
  387.  message(' ');
  388. end;
  389. (*********************************************************)
  390. procedure do_draw;
  391. var x, y :integer;
  392. begin
  393.   message(' Position cursor, then hit F5 to start drawing.');
  394.   moveit;
  395.   PENFLAG := TRUE;
  396.   message(' Hit F5 again to stop drawing.');
  397.   moveto(curx, cury);
  398.   moveit;
  399.   PENFLAG := FALSE;           (* Use pencil icon to draw. *)
  400.   message(' ');
  401. end;
  402. (*********************************************************)
  403. procedure Do_line;
  404. var x1, y1: integer;
  405.     x2, y2: integer;
  406.     CurLN : linesettingstype;
  407.     choice : char;
  408.     width, style : word;       (* Select line style; make line. *)
  409.  
  410. begin
  411.   getlinesettings(CurLN);
  412.   Message(' Position cursor at first point, then hit F5.');
  413.   moveit;
  414.   x1 := curx; y1 := cury;
  415.   Message(' Now position cursor on point two, and hit F5.');
  416.   moveit;
  417.   x2 := curx;  y2 := cury;
  418.   Message(' Line width?   1 (Normal)  or  2 (Thick)');
  419.   choice := readkey;
  420.   case choice of
  421.   '1' : width := Normwidth;
  422.   '2' : width := ThickWidth;
  423.   else width := CurLN.thickness;
  424.   end;
  425.   Message(' Type?   1 (Solid)   or  2 (Dotted)');
  426.   choice := readkey;
  427.   case choice of
  428.   '1' : style:= solidln;
  429.   '2' : style:= dottedln;
  430.   else style:= CurLN.linestyle;
  431.   end;
  432.   Setlinestyle(style, CurLN.pattern, width);
  433.   Trim_XY(x1, y1);  Trim_XY(x2, y2);
  434.   line(x1, y1, x2, y2);
  435.   Setlinestyle(CurLN.linestyle, CurLN.pattern, CurLN.thickness);
  436.   message(' ');
  437. end;
  438. (*********************************************************)
  439. procedure Do_fill;
  440. var fillx, filly: integer;
  441.     bordcol, fillcol, curcol: integer;
  442.     oldpat: fillpatterntype;
  443.     showcol: string;
  444.     waitchar : char;
  445.                                (* Fill selected area with selected color. *)
  446. begin
  447.   getfillpattern(oldpat);
  448.   message(' Position cursor in area to be filled, then press F5.');
  449.   moveit;
  450.   fillx := curx;  filly:= cury;
  451.   curcol := getcolor;
  452.   message(' Select fill color from palette (F5 to select).');
  453.   moveit;
  454.   fillcol := getpixel(curx, cury);
  455.   message(' Select boundary color by moving to palette.');
  456.   waitchar := readkey;
  457.   message(' Hit F5 when cursor is on proper boundary color.');
  458.   moveit;
  459.   bordcol:= getpixel(curx, cury);
  460.   setfillpattern(oldpat, fillcol);
  461.   floodfill(fillx, filly, bordcol);
  462.   message(' '); setcolor(curcol);
  463. end;
  464. (*********************************************************)
  465. procedure Do_about(curcol: integer);
  466. const exitm = 'Press any key to exit Help';
  467. var   helpsp : pointer;
  468.       size : integer;
  469.                          (*   POP-UP HELP WINDOW!! NEAT!!     *)
  470. begin
  471.   message(' HELP SCREEN ACTIVE.');
  472.   size := imagesize(100, 80, 600, 300);
  473.   getmem(helpsp, size);
  474.   getimage(100, 80, 600, 300, helpsp^);
  475.   setviewport(100, 80, 600, 300, true);
  476.   clearviewport;
  477.   setcolor(red);
  478.   rectangle(10, 10, 490, 210);
  479.   setcolor(blue);
  480.   settextstyle(3,0,4);
  481.   outtextxy(round(((490-10) - textwidth('About PasPaint'))/2), 15, 'About PasPaint');
  482.   settextstyle(0,0,1);
  483.   outtextxy(20, 55, ' David A. Sinclair, COSI 55b       18 March 1990');
  484.   outtextxy(20, 70, ' Cursor Movement Keys:');
  485.   outtextxy(50, 85, '"j" : Horizontal Left        "l" : Horizontal Right');
  486.   outtextxy(50, 98, '"i" : Vertical Up            "m" : Vertical Down');
  487.   outtextxy(50, 111, '"o" : Up and Right           "u" : Up and Left');
  488.   outtextxy(50, 124, '"m" : Down and Left          "," : Down and Right');
  489.   outtextxy(20, 140, ' Other Command Keys:');
  490.   outtextxy(50, 155, '"f" : Speed Up (Fast)        "s" : Slow Down');
  491.   outtextxy(50, 168, ' F1 : Select Menu Option or Position Cursor');
  492.   outtextxy(round(((490-10)-textwidth(exitm))/2), 195, exitm);
  493.   repeat
  494.    delay(1);
  495.   UNTIL keypressed;
  496.   setviewport(0, 0, getmaxx, getmaxy, true);
  497.   setcolor(curcol);
  498.   putimage(100, 80, helpsp^, normalput);
  499.   release(helpsp);
  500.   message(' ');
  501. end;
  502. (*********************************************************)
  503. procedure find_func(x, y:integer);
  504. begin
  505.   if (2<x) and (x<66) then             (* Get function based on coords. *)
  506.     if (y>160) and (y<245) then
  507.      Mcolor(x, y)
  508.     else if (y>35) and (y<60) then Do_circ
  509.     else if (y>60) and (y<85) then begin
  510.       if (x<34) then Do_rect
  511.       else Do_Line
  512.       end
  513.     else if (y>85) and (y<110) then Do_file
  514.     else if (y>110) and (y<135) then Do_font
  515.     else if (y>135) and (y<160) then begin
  516.       if (x<34) then Do_Draw
  517.       else DoUse
  518.       end
  519.     else if (y>245) and (y<280) then Do_Fill
  520.     else if (y>280) and (y<320) then Do_About(blue)
  521. end;
  522. (*********************************************************)
  523. procedure moveit;
  524. var   which : char;
  525.       newx, newy : integer;
  526.       incr : integer;
  527.                                  (* General cursor driver.. *)
  528. begin
  529.   done := FALSE;
  530.   incr := 5;
  531.   repeat
  532.    which := upcase(readkey);
  533.    case which of
  534.    'N' : begin
  535.          newx := curx-incr;
  536.          newy := cury+incr;
  537.          xhair(newx, newy);
  538.         end;
  539.    'M' : begin
  540.          newx := curx;
  541.          newy := cury+incr;
  542.          xhair(newx, newy);
  543.         end;
  544.    ',' : begin
  545.          newx := curx+incr;
  546.          newy := cury+incr;
  547.          xhair(newx, newy);
  548.          end;
  549.    'J' : begin
  550.          newx := curx-incr;
  551.          newy := cury;
  552.          xhair(newx, newy);
  553.          end;
  554.    'L' : begin
  555.          newx := curx+incr;
  556.          newy := cury;
  557.          xhair(newx, newy);
  558.          end;
  559.    'O' : begin
  560.          newx := curx+incr;
  561.          newy := cury-incr;
  562.          xhair(newx, newy);
  563.          end;
  564.    'I' : begin
  565.          newx := curx;
  566.          newy := cury-incr;
  567.          xhair(newx, newy);
  568.          end;
  569.    'U' : begin
  570.          newx := curx-incr;
  571.          newy := cury-incr;
  572.          xhair(newx, newy);
  573.          end;
  574.    'F' : incr := 5;
  575.    'S' : incr := 1;
  576.    #0  : begin
  577.          which := readkey;
  578.          if ord(which) = 59 then
  579.           find_func(curx+2, cury)
  580.          else if ord(which) = 63 then EXIT
  581.          end;
  582.    end;
  583.    if PENFLAG then if (curx<maxpx) and (curx>minpx) and (cury<maxpy) and (cury>minpy)
  584.      then lineto(curx, cury);
  585.    until DONE
  586.    end;
  587. (*********************************************************)
  588. begin
  589. prepit;
  590. startscr;
  591. setupscr;
  592. init_xhair;
  593. init_msg;
  594. moveit;
  595. closegraph;
  596. end.
  597.