home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ADC_TP3.ZIP / VDIDMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-03-01  |  15.1 KB  |  363 lines
  1.  
  2. (*****************************************************************)
  3. (**                                                             **)
  4. (**     File Name            : VDIDMO.DMO                       **)
  5. (**                                                             **)
  6. (**     Purpose                                                 **)
  7. (**        Sample application program to demonstrate the use of **)
  8. (**     the GEM Virtual Device Interface bindings from TURBO    **)
  9. (**     PASCAL.                                                 **)
  10. (**                                                             **)
  11. (**     Comments                                                **)
  12. (**        This program is designed to run as a VDI only        **)
  13. (**      application.  It assumes that the system is using      **)
  14. (**      a mouse.  Non-mouse systems will need to modify        **)
  15. (**      the procedure do_prompt.                               **)
  16. (**                                                             **)
  17. (**      All VDI interface ARRAYs are relative to 0 here        **)
  18. (**     so coords should match GEM VDI programmers manual       **)
  19. (**                                                             **)
  20. (**      Uses RC coordinate mapping (MODE 2 on open)            **)
  21. (**                                                             **)
  22. (**     To run               :  Load GEM VDI and execute        **)
  23. (**                             DMOVDI from DOS prompt          **)
  24. (**                                                             **)
  25. (**     Author               :  Athol M. Foden                  **)
  26. (**     History              :  Oct  1984                       **)
  27. (**     Modified by          :  James Taaffe and JoAnn Yang     **)
  28. (**                             of the Mass. General Hospital   **)
  29. (**                             in Jun 1985.                    **)
  30. (**                                                             **)
  31. (**                                                             **)
  32. (*****************************************************************)
  33. (*****************************************************************)
  34.  
  35. PROGRAM gemvdi;
  36.  
  37. {$IPasvdi.bnd}
  38.  
  39. VAR
  40.                         (* local variables for this program *)
  41.  
  42.         handle : INTEGER;               (* handle of the active driver *)
  43.         workin : intin_ARRAY;           (* initial values for open *)
  44.         workout : ARRAY_57;             (* functions of driver *)
  45.         pxy : ptsin_ARRAY;              (* general array of input coords *)
  46.         xyarray : ARRAY_4;              (* corner coords array typically *)
  47.         totalfonts : INTEGER;           (* total # fonts avail for WS *)
  48.         afont : ARRAY[1..20] OF INTEGER; (* font ids for all active ones *)
  49.         crt : BOOLEAN;                  (* true if a crt WS *)
  50.         done : BOOLEAN;                 (* main loop terminator *)
  51.         xmax, ymax : INTEGER;           (* max pixels in x,y direction for W-S*)
  52.         ret : INTEGER;                  (* dummy return param *)
  53.         x, y : ARRAY[1..20] OF INTEGER;  (* convenient ratios for coords *)
  54.         i,j,k,l : INTEGER;              (* work integers *)
  55.  
  56.  
  57. (******************************************)
  58. (** initialize requested graphics device **)
  59. (******************************************)
  60.  
  61. PROCEDURE init_gvdi;
  62.  
  63. VAR
  64.  
  65.      i : INTEGER;
  66.      inchar : CHAR;
  67.      name : STRING80;
  68. BEGIN
  69.  
  70.   FOR i:=0 TO intin_max DO workin[i]:=1;          (* Initial defaults used *)
  71.   FOR i:=0 TO intout_max DO workout[i]:=0;        (* make sure flushed first *)
  72.   REPEAT
  73.         WRITELN; WRITELN;
  74.         WRITELN(' PASCAL MT+ DEMO PROGRAM');
  75.         WRITELN;
  76.         WRITELN(' Select Graphics Output Device : ');
  77.         WRITELN('       1 = Screen (B&W)');
  78.         WRITELN('       2 = Screen (Color)');
  79.         WRITELN('       3 = Printer');
  80.         WRITELN('       4 = Plotter');
  81.         WRITELN('       5 = Camera');
  82.         WRITELN;
  83.         WRITE(' Selection ? : ');
  84.         READ(inchar);
  85. UNTIL inchar IN ['1'..'5'];             (* valid char ? *)
  86. crt:=FALSE;                             (* not a crt driver yet *)
  87. IF inchar = '1' THEN BEGIN
  88.                 workin[0]:=1;           (* device driver - B&W *)
  89.                 crt:=TRUE;
  90.                         END
  91. ELSE IF inchar = '2' THEN BEGIN
  92.                 workin[0]:=2;           (* color *)
  93.                 crt:=TRUE;
  94.                         END
  95. ELSE IF inchar = '3' THEN workin[0]:=21         (* printer *)
  96. ELSE IF inchar = '4' THEN workin[0]:=11         (* plotter *)
  97. ELSE workin[0]:=41;                             (* camera *)
  98.  
  99. workin[10]:=2;                                  (* use RC space system *)
  100. ret:=v_opnwk(workin,handle,workout);            (* pascal open workstation *)
  101. totalfonts:=workout[10];                (* total no. of font faces in driver *)
  102. xmax:=workout[0];                               (* max width in RC space *)
  103. ymax:=workout[1];                               (* max height *)
  104. FOR i:=1 TO 20 DO BEGIN                         (* handy ratios of sides *)
  105.         x[i]:=(xmax DIV 20) * i;                (* 1/20 increment in x drctn *)
  106.         y[i]:=(ymax DIV 20) * i;                (* 1/20 in y direction *)
  107.                 END;
  108.  
  109. totalfonts:=totalfonts + vst_load_fonts(handle,0);
  110.                                                 (* load extra fonts if any *)
  111. FOR i:=1 TO totalfonts DO BEGIN                 (* for all avail fonts *)
  112.         afont[i]:=vqt_name(handle,i,name);      (* find & save font ID  *)
  113.                         END;
  114. END;
  115.  
  116. (******************************************)
  117. (** general point fonts text routine     **)
  118. (******************************************)
  119.  
  120. PROCEDURE do_text(x, y, dface, psize, color, effects : INTEGER;
  121.                                              tstring : STRING80);
  122. BEGIN
  123. ret:=vst_font(handle,dface);            (* choose the face reqd *)
  124. ret:=vst_point(handle,psize,i,j,k,l);   (* set cell height points mode *)
  125.                 (* returned char and cell heights and widths ignored here *)
  126. ret:=vst_effects (handle, effects);             (* set graphic text effects *)
  127. ret:=vst_color(handle,color);                   (* set color *)
  128. ret:=v_gtext(handle,x,y,tstring);               (* text output *)
  129. END;
  130.  
  131. (*******************)
  132. (** draw dri logo **)
  133. (*******************)
  134.  
  135. PROCEDURE dri_logo;
  136. VAR
  137. xyarray : ARRAY_4;
  138. BEGIN
  139.         (* inside left solid  rectangle *)
  140. xyarray[0]:=x[3];
  141. xyarray[1]:=y[9];
  142. xyarray[2]:=x[4];
  143. xyarray[3]:=y[5];
  144. ret:=vsf_color(handle,red);             (* in black *)
  145. ret:=vsf_interior(handle,solid);        (* solid fill style ? *)
  146. ret:=vswr_mode(handle,replace);         (* draw in replace mode  *)
  147. ret:=v_rfbox(handle,xyarray);           (* filled rounded box *)
  148.  
  149. ret:=vsl_type(handle,solid);    (* solid lines please on open rectangles *)
  150.         (* outide rounded rectangle *)
  151. xyarray[0]:=x[2];                       (* lower left x coordinate *)
  152. xyarray[1]:=y[10];                      (* lower left y coordinate *)
  153. xyarray[2]:=x[7];                       (* top right x *)
  154. xyarray[3]:=y[4];                       (* top right y *)
  155. ret:=vsl_width(handle,6);               (* line width 6 *)
  156. ret:=vsl_color(handle, red);            (* color of lines *)
  157. ret:=v_rbox(handle,xyarray);            (* rounded open box line attr *)
  158.         (* inside little open rectangle *)
  159. xyarray[0]:=x[5];       
  160. xyarray[1]:=y[9];
  161. xyarray[2]:=x[6];
  162. xyarray[3]:=y[5];
  163. ret:=vsl_width(handle,3);               (* narrower lines now - same color *)
  164. ret:=v_rbox(handle,xyarray);            (* open rectangle *)
  165. END;
  166.  
  167. (***************************************************************)
  168. (** draw a border around the "artwork" - a polyline operation **)
  169. (***************************************************************)
  170.  
  171. PROCEDURE draw_border;
  172. BEGIN
  173. pxy[0]:=x[1];                           (* top left of WS - center of lne*)
  174. pxy[1]:=y[1];
  175. pxy[2]:=x[20];                          (* top right of ws *)
  176. pxy[3]:=y[1];
  177. pxy[4]:=x[20];                          (* bottom right *)
  178. pxy[5]:=y[20];
  179. pxy[6]:=x[1];                           (* bottom left *)
  180. pxy[7]:=y[20];
  181. pxy[8]:=x[1];                           (* back to square one *)
  182. pxy[9]:=y[1];
  183. ret:=vsl_type(handle,solid);            (* solid line style *)
  184. ret:=vsl_color(handle,cyan);            (* in cyan please *)
  185. ret:=vsl_width(handle,6);               (* fat line - 6 coords wide *)
  186. ret:=v_pline(handle,5,pxy);             (* draw the 5 coord polyline *)
  187. END;
  188.  
  189. (***************************)
  190. (** draw dri name with tm **)
  191. (***************************)
  192.  
  193. PROCEDURE draw_name;
  194. BEGIN
  195. do_text(x[9],y[4],afont[2],20,green,bold,'DIGITAL');    (* font 2 in bold *)
  196. do_text(x[9],y[7],afont[2],20,green,bold,'RESEARCH');
  197. do_text(x[16],y[5],afont[1],10,yellow,light,'TM');      (* light TM in small *)
  198. END;
  199.  
  200. (**************************************)
  201. (** Use new GDP function for ellipse **)
  202. (**************************************)
  203.  
  204. PROCEDURE draw_ellipse;
  205. BEGIN
  206. ret:=vsf_interior(handle,pattern);              (* patterned ellipse *)
  207. ret:=vsf_color(handle,yellow);                  (* in yellow *)
  208. ret:=v_ellipse(handle,x[17],y[17],x[2],y[1]);   (* draw ellipse *)
  209. END;
  210.  
  211. (*******************************************************)
  212. (** Bitblt - Use rastor ops to copy ellipse instantly **)
  213. (*******************************************************)
  214.  
  215. PROCEDURE copy_ellipse;
  216. VAR
  217. i : INTEGER;
  218. srcM, destM : MFDB;             (* source and destination MFDB's *)
  219. pxy8 : ARRAY_8;
  220. BEGIN
  221. srcM.mptr.hi:=$0000;            (* long addr zero for source MDFB *)
  222. srcM.mptr.lo:=$0000;            (* as it is physical device *)
  223. destM.mptr.hi:=$0000;                   (* long addr zero for source MDFB *)
  224. destM.mptr.lo:=$0000;
  225. pxy8[0]:=x[14];                 (* pick up rectangle with ellipse in *)
  226. pxy8[1]:=y[16];
  227. pxy8[2]:=x[19];
  228. pxy8[3]:=y[18];
  229. pxy8[4]:=x[14];                 (*  and put it down here *)
  230. pxy8[5]:=y[8];
  231. pxy8[6]:=x[19];
  232. pxy8[7]:=y[10];
  233. ret:=vro_cpyfm(handle,3,pxy8,srcM,destM);   (*copy rastor rectangle *)
  234.         (* 3 = replace mode *) (* N.B. Not same as C binding ! *)
  235. END;
  236.  
  237. (*************************************)
  238. (** triangle to demo filled polygon **)
  239. (*************************************)
  240.  
  241. PROCEDURE draw_triangle;
  242. BEGIN
  243. pxy[0]:=x[3];
  244. pxy[1]:=y[18];
  245. pxy[2]:=x[5];
  246. pxy[3]:=y[18];
  247. pxy[4]:=x[4];
  248. pxy[5]:=y[15];
  249. ret:=vsf_interior(handle,hatch);                (* hatch fill pattern *)
  250. ret:=vsf_style(handle,9);       (* narrow spaced horizontal lines for hatch *)
  251. ret:=vsf_color(handle,magenta);
  252. ret:=v_fillarea(handle,3,pxy);                  (* an area with 3 corners  *)
  253. END;
  254.  
  255. (**********************************************************)
  256. (** Draw a little trap (box) into which mouse can point  **)
  257. (**     Only execute if using CRT driver!                **)
  258. (** NOTE: This could be done more elegantly with GEMAES  **)
  259. (**********************************************************)
  260.  
  261. PROCEDURE draw_trap(tx,ty : INTEGER; tstring : STRING80);
  262. VAR
  263. ix,iy : INTEGER;
  264. xyarray : ARRAY_4;
  265. BEGIN
  266. xyarray[0]:=tx;                 (* bottom left x coord corner of rectangle *)
  267. xyarray[1]:=ty;                 (* bottom left y coord *)
  268. xyarray[2]:=tx + x[3];          (* top right x *)
  269. xyarray[3]:=ty - y[2];          (* top right y *)
  270. ret:=vsf_perimeter(handle,1);           (* set to visible perimiter *)
  271. ret:=vsf_color(handle,red);             (* a red box *)
  272. ret:=vsf_interior(handle,hollow);       (* hollow fill style *)
  273. ret:=vswr_mode(handle,1);               (* replace mode for the line drawing *)
  274. ret:=v_bar (handle,xyarray);            (* bar = rectangle *)
  275. ix:=tx + (x[1] DIV 2);
  276. iy:=ty - (y[1] DIV 2);
  277. do_text(ix,iy,afont[1],10,blue,normal,tstring); (*prompt - normal style*)
  278. END;
  279.  
  280. (************************************)
  281. (** Get mouse for those who have it *)
  282. (************************************)
  283.  
  284. PROCEDURE getmouse;
  285. VAR
  286. newx, newy : INTEGER;   
  287. termchar : CHAR;        
  288. BEGIN
  289. ret:=vrq_locator(handle,x[9],y[19],newx,newy,termchar);  
  290.                                                 (* place mouse & find *)
  291. IF ((newx > x[11]) AND (newx < x[14]))          (* mouse clicked but where? *)
  292.                                 AND ((newy > y[17]) AND (newy < y[18]))
  293.                         THEN done:=TRUE;        (* quit selected *)
  294. END;
  295.  
  296. (***************************)
  297. (** Get a single keystroke *)
  298. (***************************)
  299.  
  300. PROCEDURE getkeyin;
  301. VAR
  302. instring : STRING80;
  303. BEGIN
  304. ret:=vst_font(handle,afont[1]);         (* std font for echo *)
  305. ret:=vst_point(handle,20,i,j,k,l);      (* 20 point size echo char *)
  306. ret:=vrq_string(handle,1,1,x[10],y[18],instring); (* request 1 char, echo *)
  307. IF instring[1] IN ['q','Q'] THEN done:=TRUE;    (* yes, time to quit *)
  308. END;
  309.  
  310. (**************************************************************************)
  311. (*** Prompt on crt in case another flash of the picture is required     ***)
  312. (**  Note: GEMAES lets you check key-in or mouse-in much easier         ***)
  313. (**************************************************************************)
  314.  
  315. PROCEDURE do_prompt;
  316. BEGIN
  317. draw_trap(x[6],y[18],'R = Redo');       (* draw mouse trap for another go *)
  318. draw_trap(x[11],y[18],'Q = Quit');      (* or trap to say goodbye *)
  319. getmouse;                               (* mouse input required *)
  320. (*  getkeyin  *)   (*  activate this to use keyboard input instead  *)                     
  321. END;
  322.  
  323. (*********************************)
  324. (** Close all GEM VDI resources **)
  325. (*********************************)
  326.  
  327. PROCEDURE close_gvdi;
  328. BEGIN
  329. ret:=vst_unload_fonts(handle,0);        (* unload any fonts loaded *)
  330. ret:=v_clswk(handle);                   (* close that workstation *)
  331. END;
  332.  
  333.                    (*************************)
  334.                    (** mainline of program **)
  335.                    (*************************)
  336. BEGIN
  337.  
  338. init_gvdi;                      (* initialize right graphics device *)
  339. done:=FALSE;                    (* not done yet *)
  340. REPEAT
  341.         ret:=v_clrwk(handle);                   (* clear work station *)
  342.         draw_border;                            (* surround it *)
  343.         dri_logo;                               (* binary logo symbol *)
  344.         draw_ellipse;
  345.         draw_triangle;
  346.         draw_name;                              (* name with trade mark *)
  347.         do_text(x[9],y[12],afont[3],36,magenta,bold+skew+underline,'GEM VDI');
  348.                         (* in 36 point font 3 with many effects *)
  349.         do_text(x[2],y[18],afont[1],10,red,normal,'GEM');     (* in small *)
  350.         ret:=vst_rotation(handle,900);          (* rotate 90 degrees *)
  351.         do_text(x[2],y[19],afont[1],10,red,bold,'GEM');
  352.         ret:=vst_rotation(handle,1800);         (* upside down *)
  353.         do_text(x[2],y[17],afont[1],10,cyan,bold,'GEM');
  354.         ret:=vst_rotation(handle,0);    (* reset angle of text *)
  355.         IF crt THEN BEGIN               (* screen driver loaded ? *)
  356.                 copy_ellipse;           (* rastor ops only on crt's *)
  357.                 do_prompt;              (* & prompt for go around *)
  358.                         END
  359.                ELSE done:=TRUE;         (* no - cheers *)
  360. UNTIL done;
  361. close_gvdi;                             (* clear up *)
  362. END.
  363.