home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / modula2 / library / fst / qvideo / qvideo.mod < prev   
Text File  |  1987-11-20  |  27KB  |  840 lines
  1.  
  2. IMPLEMENTATION MODULE QVideo;
  3.  
  4. (*
  5.    Screen routines supporting windows for Fitted Software Tools Modula-2.
  6.    In the public domain - MS/PC-DOS CGA, mono, Hercules (TM) compat.
  7.  
  8.    For ease of use, everything's a CARDINAL (if it's not an ARRAY OF CHAR)
  9.    and no pointers need be used.
  10.  
  11.    All columns and rows in procedure calls are in 1-80, 1-25 format
  12.    in col, row order. Col and row are always the last parameters in a call
  13.    that includes them.
  14.  
  15.    A number of procedures have defaults which are employed when the
  16.    parameter(s) passed = 0.
  17. *)
  18.  
  19. FROM SYSTEM  IMPORT ASSEMBLER, OFS, SEG, ADDRESS, ADR;
  20. FROM Strings IMPORT Length;
  21.  
  22. (*
  23.                           C O N T E N T S
  24.                ClrScr, ClrEOL,  SetAttrib, GetAttrib
  25.                 GotoXY, GetXY, QWrite, QWriteString
  26.                 KeyScan,  ScreenBuffer, WriteBuffer
  27.                     CursorOn, CursorOff, Frame
  28.                         ScrollUp, ScrollDn
  29.            plus a prototype window at the end of the file
  30. *)
  31.  
  32. (****************************** ClrScr ********************************)
  33.  
  34. PROCEDURE ClrScr (attrib : CARDINAL);
  35. (* clear the whole screen, home cursor *)
  36. (* if attrib is 0, it uses normal white on black *)
  37. (* usage:
  38. ;
  39. ;       ClrScr (0);
  40. ;       WriteString ("I'm at the top left of a new, otherwise empty screen.");
  41. *)
  42. CONST norm = 7;
  43. VAR   atr  : CARDINAL;
  44.  
  45. BEGIN
  46.     IF (attrib = 0) THEN         (* if 0, use default attribute *)
  47.       attrib := norm;
  48.     END;
  49.     SetAttrib (attrib, 1, 1);    (* see procedure below *)
  50.  
  51.     ScrollUp (0, 80, 25, 1, 1);  (* see     "       "   *)
  52.     GotoXY (1, 1);               (* see     "       "   *)
  53. END ClrScr;
  54.  
  55. (****************************** ClrEOL *******************************)
  56.  
  57. PROCEDURE ClrEOL;
  58. (* clear line from cursor to end, using attribute at cursor x,y *)
  59. (* cursor stays at starting position                            *)
  60. (* usage:
  61. ;
  62. ;      GotoXY (1, 10);   (* 10 rows down the screen at left of screen *)
  63. ;      WriteString ("This is a sentence about frogs.");
  64. ;      GotoXY (26, 10);  (* same row at column 26 - the beginning of "frogs." *)
  65. ;      ClrEOL;           (* cursor is still at 26, 10 *)
  66. ;      WriteString ("bogs.");
  67. ;                        (* results in: This is a sentence about bogs. *)
  68. *)
  69. VAR
  70.   col, row, atr : CARDINAL;
  71.  
  72. BEGIN
  73.   GetXY (col, row);
  74.   GetAttrib (atr, col, row);
  75.  
  76.   DEC (col);
  77.   DEC (row);   (* adjust to 0-79, 0-24 format *)
  78.  
  79.   ASM (* BEGIN *)
  80.     MOV AL,32       (* put space char in AL *)
  81.     MOV BL,atr      (* put returned attribute into BL *)
  82.     MOV DL,col      (* put row and column in DX *)
  83.     MOV DH,row
  84.  
  85.     MOV CX,80       (* default number of columns *)
  86.     SUB CL,DL       (* adjust by subtracting columns up to cursor position *)
  87.  
  88.     MOV AH,9        (* func 9 = write at cursor for CX spaces *)
  89.     INT 10H         (* call video handler *)
  90.   END; (* ASM *)
  91.  
  92.   INC (col);  (* back to 1-80, 1-25 format *)
  93.   INC (row);
  94.   GotoXY (col, row);
  95. END ClrEOL;
  96.  
  97. (************************* SetAttrib *******************************)
  98.  
  99. PROCEDURE SetAttrib (attrib, col, row : CARDINAL);
  100. (* set the attribute for the character at specified column, row *)
  101. (* cursor will still be where it was before call *)
  102. (* usage:
  103. ;
  104. ;  CONST ReverseVideo = 112;
  105. ;        NormalVideo  =   7;
  106. ;
  107. ;     ClrScr (0); (* homes cursor *)
  108. ;     WriteString ("This x is in reverse video.");
  109. ;     SetAttrib (ReverseVideo, 6, 1);
  110. *)
  111. VAR CurrentCol, CurrentRow : CARDINAL;
  112.  
  113. BEGIN
  114.   GetXY (CurrentCol, CurrentRow);
  115.   GotoXY (col, row);
  116.  
  117.   ASM (* BEGIN *)
  118.     MOV AH,8      (* func 8 = get char, etc. at current position *)
  119.     MOV BH,0      (* page *)
  120.     INT 10H       (* call video handler *)
  121.  
  122.     MOV AH,9      (* func 9 = write char and attrib *)
  123.                   (* current char is already in AL *)
  124.     MOV BL,attrib
  125.     MOV BH,0      (* page *)
  126.     MOV CX,1      (* write CX times *)
  127.     INT 10H       (* call video handler *)
  128.   END; (* ASM *)
  129.  
  130.   GotoXY (CurrentCol, CurrentRow);
  131. END SetAttrib;
  132.  
  133. (************************* GetAttrib *******************************)
  134.  
  135. PROCEDURE GetAttrib (VAR attrib : CARDINAL; col, row : CARDINAL);
  136. (* get the attribute for the char at specified column, row *)
  137. (* cursor will still be where it was before call *)
  138. (* usage:
  139. ;
  140. ;  VAR attribute, row, column, I : CARDINAL;
  141. ;  BEGIN
  142. ;  ..... (* write to line 1 *)
  143. ;    row := 1;
  144. ;    FOR I := 1 TO 80 DO
  145. ;      GetAttrib (attribute, I, row);
  146. ;      IF attribute = 112 THEN        (* 112 is reverse video *)
  147. ;        SetAttrib (7, I, row)        (*   7 is normal  video *)
  148. ;      END;
  149. ;   END;
  150. ;   GotoXY (1, 2);
  151. ;   WriteString ("There are now no reverse characters on line one!");
  152. ;
  153. *)
  154. VAR LocalAttrib, CurrentCol, CurrentRow : CARDINAL;
  155.  
  156. BEGIN
  157.   GetXY (CurrentCol, CurrentRow);
  158.   GotoXY (col, row);
  159.  
  160.   ASM (* BEGIN *)
  161.     MOV BH,0     (* page *)
  162.     MOV AH,8     (* func 8 = get current attribute, etc. *)
  163.     INT 10H      (* call video handler *)
  164.  
  165.     XOR BX,BX    (* clear BX for byte to int conversion *)
  166.     MOV BL,AH    (* put returned attribute into attrib *)
  167.     MOV LocalAttrib,BX
  168.   END; (* ASM *)
  169.  
  170.   attrib := LocalAttrib;
  171.   GotoXY (CurrentCol, CurrentRow);
  172. END GetAttrib;
  173.  
  174. (**************************** GotoXY *********************************)
  175.  
  176. PROCEDURE GotoXY (col, row : CARDINAL);
  177. (* locate cursor - column and row start at 1, not 0 *)
  178. (* usage:
  179. ;
  180. ;   GotoXY (1, 1);
  181. ;   WriteString ("x marks column 1, row 1 - the top left of the screen.");
  182. ;   GotoXY (1, 12);
  183. ;   WriteString ("z marks column 1, row 12 - half way down the screen at left");
  184. *)
  185.  
  186. VAR
  187.   BEGIN
  188.     DEC (col);  (* adjust to 0-79, 0-24 format *)
  189.     DEC (row);
  190.  
  191.     ASM (* BEGIN *)
  192.       MOV AH,2    (* func 2 = set cursor position *)
  193.       MOV BH,0    (* page *)
  194.       MOV DH,row  (* put row and col in DX *)
  195.       MOV DL,col
  196.       INT 10H     (* call video handler *)
  197.    END; (* ASM *)
  198.  
  199. END GotoXY;
  200.  
  201. (******************************* GetXY *******************************)
  202.  
  203. PROCEDURE GetXY (VAR col, row : CARDINAL);
  204. (* get current cursor location *)
  205. (* usage:
  206. ;
  207. ;        VAR CurrentColumn, CurrentRow : CARDINAL;
  208. ;        BEGIN
  209. ;          ClrScr (0);
  210. ;          WriteString ("123456789");
  211. ;          GetXY (CurrentColumn, CurrentRow);
  212. ;          WriteLn;
  213. ;          WriteString ("After printing the numbers, the cursor was at column ");
  214. ;          WriteCard (CurrentColumn, 2);
  215. ;          WriteString (" and row ");
  216. ;          WriteCard (CurrentRow, 2);
  217. ;          GotoXY (CurrentColumn, CurrentRow);
  218. ;          WriteString ("x marks the spot.");
  219. ;          GotoXY (CurrentColumn, CurrentRow);
  220. ;          ....
  221. *)
  222. VAR LocalCol, LocalRow : CARDINAL;
  223.  
  224. BEGIN
  225.  
  226.     ASM (* BEGIN *)
  227.       MOV AH,3    (* func 3 = read cursor position *)
  228.       MOV BH,0    (* page *)
  229.       INT 10H     (* call video handler *)
  230.  
  231.       XOR AX,AX   (* clear HIGH bits *)
  232.       MOV AL,DL   (* put col byte in low part of AX *)
  233.       MOV LocalCol,AX
  234.                   (* now col is getting an integer *)
  235.       MOV AL,DH   (* do the same with the row byte *)
  236.       MOV LocalRow,AX
  237.                   (* row also gets an integer *)
  238.     END; (* ASM *)
  239.  
  240.   col := LocalCol + 1;   (* adjust to 1-80, 1-25 format *)
  241.   row := LocalRow + 1;
  242. END GetXY;
  243.  
  244. (****************************** QWrite *******************************)
  245.  
  246. PROCEDURE QWrite (ch : CHAR; attrib, col, row : CARDINAL);
  247. (* Write a CHAR - does NOT advance cursor *)
  248. (* if attrib is 0 it uses current attribute at cursor position *)
  249. (* attribute can be pre-set with SetAttrib using the same col,row *)
  250.  
  251. VAR atr : CARDINAL;
  252. BEGIN
  253.   DEC (col); (* convert to 0-79, 0-24 format *)
  254.   DEC (row);
  255.  
  256.   ASM (* BEGIN *)
  257.     MOV AH,2     (* func 2 = set cursor position *)
  258.     MOV BH,0     (* page *)
  259.     MOV DL,col   (* set to desired column *)
  260.     MOV DH,row   (* and desired row *)
  261.     INT 10H      (* call video handler *)
  262.  
  263.     MOV BH,0     (* page *)
  264.     MOV AH,8     (* func 8 = get current attribute, etc. *)
  265.     INT 10H
  266.     XOR BX,BX
  267.     MOV BL,AH
  268.     MOV atr,BX
  269.   END; (* ASM *)
  270.  
  271.   IF (attrib <> 0) THEN
  272.     atr := attrib;
  273.   END;
  274.  
  275.   ASM (* BEGIN *)
  276.     MOV BL,atr   (* returned or passed attribute *)
  277.     MOV AL,ch    (* char *)
  278.     MOV AH,9     (* func 9 = write at cursor position *)
  279.     MOV BH,0     (* page *)
  280.     MOV CX,1     (* write CX times *)
  281.     INT 10H      (* call video handler *)
  282.   END; (* ASM *)
  283.  
  284. END QWrite;
  285.  
  286. (************************* QWriteString ******************************)
  287.  
  288. PROCEDURE QWriteString(String : ARRAY OF CHAR);
  289. (* fast string writing (mono, CGA) does NOT move cursor *)
  290. (* position cursor with GotoXY or WriteLn to begin writing  *)
  291. (* uses attribute at cursor for the whole string *)
  292. (* usage:
  293. ;
  294. ;             VAR I : CARDINAL;
  295. ;             BEGIN
  296. ;                ClrScr (0);
  297. ;                FOR I := 2 TO 22 BY 2 DO
  298. ;                  GotoXY (I + 1, I);
  299. ;                  QWriteString ("All these lines in the blink of an eye!");
  300. ;                END;
  301. ;             ...
  302. *)
  303. VAR
  304.     row, col, offset     : CARDINAL;
  305.     Ofs, Seg, StringLen  : CARDINAL;
  306.     TextAdr              : ADDRESS;
  307.  
  308. BEGIN
  309.      (* do it this way as an example of using ADDRESS *)
  310.  
  311.      GetXY (col, row);
  312.  
  313.      StringLen := Length(String);
  314.      TextAdr   := ADR (String);   (* get whole address *)
  315.      Ofs       := TextAdr.OFS;    (* address's offset field for SI *)
  316.      Seg       := TextAdr.SEG;    (* and data segment for DS *)
  317.                                   (* can't use record fields in ASM *)
  318.  
  319.      DEC (col); DEC(row); (* adjust to 0-79, 0-24 format *)
  320.      offset := (row * 160) + (col * 2); (* total offset into screen memory *)
  321.  
  322.      ASM (* BEGIN *)
  323.         MOV AH,8          (* func 8 = get current attribute, etc. *)
  324.         MOV BH,0          (* page *)
  325.         INT 10H           (* call video handler *)
  326.         MOV CX,AX         (* save returned info in CX until needed *)
  327.  
  328.    MONO:
  329.         MOV   AH,15       (* func 15 = check video adapter *)
  330.         INT   10H         (* call video handler *)
  331.  
  332.         MOV   BX,0B000H   (* assume mono screen address *)
  333.         MOV   DX,03BAH    (* check here for skipping retrace (snow) check *)
  334.         CMP   AL,7        (* if mono, jump to SETUP *)
  335.         JZ    SETUP
  336.  
  337.    CGA:
  338.         MOV   BX,0B800H   (* CGA screen memory start *)
  339.         MOV   DX,03DAH    (* check here for retrace (snow) check *)
  340.  
  341.    SETUP:
  342.        MOV    AX,offset   (* offset for screen memory into DI via AX *)
  343.        MOV    DI,AX
  344.        MOV    ES,BX       (* mono or CGA base for screen memory *)
  345.        MOV    SI,Ofs      (* data offset for index *)
  346.        MOV    DS,Seg      (* data segment *)
  347.        MOV    AH,CH       (* we previously saved attribute in CX *)
  348.        MOV    CX,StringLen (* write CX times *)
  349.  
  350.        CLD                (* the string move direction is up *)
  351.  
  352.   CONTINUE:
  353.        CMP    DL,0    (* if not CGA, jump over retrace check *)
  354.        JZ     WRITE
  355.  
  356.   SNOW1:
  357.        IN     AL,DX   (* test CGA port for beginning of retrace *)
  358.        TEST   AL,1
  359.        JNZ    SNOW1
  360.        CLI            (* disable interrupts *)
  361.  
  362.   SNOW2:
  363.        IN     AL,DX   (* test for retrace ongoing *)
  364.        TEST   AL,1
  365.        JZ     SNOW2
  366.  
  367.   WRITE:
  368.        LODSB         (* only get a byte, we have attribute in AH *)
  369.        STOSW         (* stow char and attribute on the screen *)
  370.        STI           (* enable interrupts *)
  371.        LOOP   CONTINUE
  372.  
  373.      END; (* ASM *)
  374.  
  375. END QWriteString;
  376.  
  377. (**************************** KeyScan ********************************)
  378.  
  379. PROCEDURE KeyScan (VAR KeyValue : CARDINAL) : CARDINAL;
  380. (* get extended key code (F keys, arrow keys, etc.) or normal char *)
  381. (* usage:
  382. ;       VAR TestScanKey, Value : CARDINAL;
  383. ;            ....
  384. ;            TestScanKey := KeyScan (Value);
  385. ;            IF TestScanKey = 1 THEN
  386. ;              WriteString ("It's a scan key: ");
  387. ;              WriteCard (Value);
  388. ;            ELSE
  389. ;              WriteString ("It's a normal character key: ");
  390. ;              Write (CHR (Value));
  391. ;            END;
  392. ;
  393. *)
  394. VAR
  395.   LocalValue, ARegLow : CARDINAL;
  396.  
  397. BEGIN
  398.   ARegLow := 0;       (* clear HIGH bits *)
  399.  
  400.   ASM (* BEGIN *)
  401.  
  402. KEYPRESS:             (* loop until key pressed *)
  403.     MOV AH,1          (* try to get a keypress *)
  404.     INT 16H           (* call keyboard handler *)
  405.     JZ KEYPRESS       (* IF KEYPRESSED = 0 THEN GOTO KEYPRESS *)
  406.  
  407.     MOV AH,0          (* get the key value *)
  408.     INT 16H           (* call keyboard handler *)
  409.  
  410.     MOV ARegLow,AL    (* we need AL for RETURN *)
  411.     CMP AL,0          (* if 0, it's a scan key *)
  412.     JNE FINISHED      (* IF ARegLow <> 0 THEN GOTO FINISHED *)
  413.  
  414.     MOV AL,AH         (* since it's a scan key, get it into CARDINAL order *)
  415.  
  416. FINISHED:
  417.     MOV AH,0          (* we know it's only a byte *)
  418.     MOV LocalValue,AX (* get value from AL *)
  419.  
  420.   END; (* ASM *)
  421.  
  422.   KeyValue := LocalValue;
  423.  
  424.   IF ARegLow = 0 THEN
  425.     RETURN 1;
  426.   ELSE
  427.     RETURN 0;
  428.   END;
  429.  
  430. END KeyScan;
  431.  
  432. (************************** ScreenBuffer **************************)
  433.  
  434. PROCEDURE ScreenBuffer (VAR ScreenArray : ARRAY OF CHAR;
  435.                             direction : CARDINAL);
  436. (* save and restore a whole screen *)
  437. (* usage:
  438. ;
  439. ;  MODULE MyProg;
  440. ;
  441. ;  FROM QVideo IMPORT QWriteString, GotoXY, ScreenBuffer, ClrScr, KeyScan;
  442. ;
  443. ;  VAR  scan, val : CARDINAL;
  444. ;       FirstScreen, SecondScreen : ARRAY[0..4000] OF CHAR;
  445. ;
  446. ;  BEGIN
  447. ;    ClrScr (0);
  448. ;    GotoXY (2, 2);
  449. ;    QWriteString ("This happens so fast you hardly saw me before I came back!");
  450. ;    GotoXY (3, 3);
  451. ;    QWriteString (" Hit any key to see what you missed...");
  452. ;    ScreenBuffer (FirstScreen, 0); (* save the screen *)
  453. ;    ClrScr (0);
  454. ;    GotoXY (3, 3);
  455. ;    QWriteString (" You didn't see me, but I was here before!");
  456. ;    ScreenBuffer (SecondScreen, 0);
  457. ;    ScreenBuffer (FirstScreen, 1); (* restore the saved screen *)
  458. ;    scan := KeyScan (val);
  459. ;    ScreenBuffer (SecondScreen, 1);
  460. ;
  461. ;  END MyProg.
  462. *)
  463. (* direction = 1 if restoring, 0 if saving - think of 0 as empty array *)
  464. (* ScreenArray is a 4000 or > byte string since we need attributes AND chars *)
  465. VAR
  466.     Ofs, Seg, ScreenLen  : CARDINAL;
  467.     ScreenAdr            : ADDRESS;
  468.  
  469.  BEGIN
  470.      ScreenAdr := ADR (ScreenArray);
  471.      Ofs       := ScreenAdr.OFS;  (* address's offset field for SI or DI *)
  472.      Seg       := ScreenAdr.SEG;  (* and data segment for DS or ES *)
  473.      ScreenLen := 2000;           (* words (two bytes each) *)
  474.  
  475.      ASM (* BEGIN *)
  476.  
  477.    MONO:
  478.         MOV   AH,15       (* func 15 = check video adapter *)
  479.         INT   10H         (* call video handler *)
  480.  
  481.         MOV   BX,0B000H   (* assume mono screen address *)
  482.         MOV   DX,03BAH    (* check here for skipping retrace (snow) check *)
  483.         CMP   AL,7        (* if mono, jump to SETUP *)
  484.         JZ    SETUP
  485.  
  486.     CGA:
  487.         MOV   BX,0B800H   (* CGA screen memory start *)
  488.         MOV   DX,03DAH    (* check here for retrace (snow) check *)
  489.  
  490.   SETUP:
  491.        MOV    AX,direction
  492.        CMP    AX,1        (* if it's 1, then restore the array to screen *)
  493.        JNE    GETSCR      (* else put screen into the array *)
  494.  
  495. PUTSCR:
  496.        MOV    ES,BX       (* mono or CGA screen memory to fill with array *)
  497.        MOV    DI,0        (* no offset - start at top left *)
  498.        MOV    SI,Ofs      (* array's memory offset in data seg *)
  499.        MOV    DS,Seg      (* array's data seg *)
  500.  
  501.        JMP    READY
  502.  
  503. GETSCR:
  504.        MOV    DS,BX       (* mono or CGA base from which to load array *)
  505.        MOV    SI,0        (* no offset into screen *)
  506.        MOV    DI,Ofs      (* memory offset to beginning of array *)
  507.        MOV    ES,Seg      (* data seg where array lives *)
  508.  
  509.  READY:
  510.        MOV    CX,ScreenLen (* write CX times *)
  511.  
  512.   CONTINUE:
  513.        CMP    DL,0    (* if not CGA, jump over retrace check *)
  514.        JZ     WRITE
  515.  
  516.   SNOW1:
  517.        IN     AL,DX   (* test CGA port for beginning of retrace *)
  518.        TEST   AL,1
  519.        JNZ    SNOW1
  520.        CLI            (* disable interrupts *)
  521.  
  522.   SNOW2:
  523.        IN     AL,DX   (* test for retrace ongoing *)
  524.        TEST   AL,1
  525.        JZ     SNOW2
  526.  
  527.   WRITE:
  528.        MOVSW         (* move all the words ( attributes and chars ) *)
  529.        STI           (* enable interrupts *)
  530.        LOOP   CONTINUE
  531.  
  532.      END; (* ASM *)
  533.  
  534.  END ScreenBuffer;
  535.  
  536. (*************************** WriteBuffer ******************************)
  537.  
  538. PROCEDURE WriteBuffer (String : ARRAY OF CHAR;
  539.                    VAR Buffer : ARRAY OF CHAR;
  540.                      Col, Row : CARDINAL);
  541. (*
  542. Write to the array used in ScreenBuffer instead of the screen,so that when
  543. the array is placed on the screen by  ScreenBuffer (FirstScreen, Restore),
  544. the effect will be very nearly instantaneous.
  545. -
  546. Initialize the array by first calling  ClrScr with the  desired  attribute
  547. as in ClrScr (Reverse) and then saving it to the  array with ScreenBuffer:
  548. ScreenBuffer (FirstScreen, Save).  In other words, all the attributes will
  549. be in place and you need only add the chars with WriteBuffer. It is easier
  550. to code if you work it out on the screen first, then simply translate your
  551. calls from:
  552.            ClrScr (Normal);
  553.            GotoXY (10, 12);
  554.            QWriteString ("x is at column 10 on row 12.");
  555.            ...etc.
  556.         to:
  557.             ClrScr (Normal);
  558.             ScreenBuffer (FirstScreen, Save);
  559.             WriteBuffer ("x is at column 10 on row 12.", FirstScreen, 10, 12);
  560.             ...etc.
  561.             ScreenBuffer (FirstScreen, Restore);
  562. *)
  563. VAR I, J, Pos : CARDINAL;
  564. BEGIN
  565.   DEC (Col);         (* we start with BufferChar[0] = col 1, row 1 *)
  566.   DEC (Row);
  567.   Col := Col * 2;    (* we count the attributes too: atr, char, atr, char *)
  568.   Row := Row * 160;  (* a row = 80 chars + 80 attributes and is sequential *)
  569.   Pos := Col + Row;  (* buffer is straight line, just as screen RAM is ..*)
  570.                      (* .. instead of being made up of columns and rows  *)
  571.   J := 0;
  572.   FOR I := Pos TO (Pos + (2 * Length (String) - 2)) BY 2 DO (* skip over atr *)
  573.     Buffer[I] := String[J];  (* first buffer char is string[0] *)
  574.     INC (J);
  575.   END;
  576. END WriteBuffer;
  577.  
  578. (**************************** ScrollUp *******************************)
  579.  
  580. PROCEDURE ScrollUp (NumLines, Width, Height, ULC, ULR : CARDINAL);
  581. (* scroll up area defined by upper left corner and total width and height *)
  582. (* scrolls each line NumLines times - clears window if NumLines = 0 *)
  583.  
  584. VAR LRC, LRR : CARDINAL;       (* define lower right corner co-ordinates *)
  585. BEGIN
  586.      GotoXY (ULC, ULR);        (* we'll need to get the attribute *)
  587.  
  588.      DEC (ULC); DEC (ULR);     (* adjust to 0-79, 0-24 format *)
  589.      LRC := ULC + Width  - 1;
  590.      LRR := ULR + Height - 1;
  591.  
  592.   ASM (* BEGIN *)
  593.     MOV BH,0          (* page *)
  594.     MOV AH,8          (* func 8 = get attribute at cursor, etc. *)
  595.     INT 10H           (* call video handler *)
  596.  
  597.     MOV BH,AH         (* use returned attribute for the scroll *)
  598.     MOV AL,NumLines   (* scroll each line up or down NumLines *)
  599.     MOV AH,6          (* func 6 = scroll up *)
  600.     MOV CL,ULC        (* upper left col *)
  601.     MOV CH,ULR        (* upper left row *)
  602.     MOV DL,LRC        (* lower right col *)
  603.     MOV DH,LRR        (* lower right row *)
  604.     INT 10H           (* call video handler *)
  605.   END; (* ASM *)
  606.  
  607. END ScrollUp;
  608.  
  609. (**************************** ScrollDn *******************************)
  610.  
  611. PROCEDURE ScrollDn (NumLines, Width, Height, ULC, ULR : CARDINAL);
  612. (* scroll down area defined by upper left corner and total width and height *)
  613. (* scrolls each line NumLines times - clears window if NumLines = 0 *)
  614.  
  615. VAR LRC, LRR : CARDINAL;       (* define lower right corner co-ordinates *)
  616. BEGIN
  617.      GotoXY (ULC, ULR);        (* to get the attribute *)
  618.  
  619.      DEC (ULC); DEC (ULR);     (* adjust to 0-79, 0-24 format *)
  620.      LRC := ULC + Width  - 1;
  621.      LRR := ULR + Height - 1;
  622.  
  623.   ASM (* BEGIN *)
  624.     MOV BH,0          (* page *)
  625.     MOV AH,8          (* func 8 = get attribute at cursor, etc. *)
  626.     INT 10H           (* call video handler *)
  627.  
  628.     MOV BH,AH         (* use returned attribute for the scroll *)
  629.     MOV AL,NumLines   (* scroll each line up or down NumLines *)
  630.     MOV AH,7          (* func 7 = scroll down *)
  631.     MOV CL,ULC        (* upper left col *)
  632.     MOV CH,ULR        (* upper left row *)
  633.     MOV DL,LRC        (* lower right col *)
  634.     MOV DH,LRR        (* lower right row *)
  635.     INT 10H           (* call video handler *)
  636.   END; (* ASM *)
  637.  
  638. END ScrollDn;
  639.  
  640. (***************************** CursorOn ******************************)
  641.  
  642. PROCEDURE CursorOn (startline, endline : CARDINAL);
  643. (* turn cursor on and set the shape *)
  644. (* if you call with startline and endline as 0, the default shape
  645.    for video adapter is used *)
  646. (* usage:
  647. ;  ...
  648. ;  GotoXY (20, 12);
  649. ;  WriteString (" The cursor won't blink until you hit a key.");
  650. ;  CursorOff;
  651. ;  scan := KeyScan(val);
  652. ;  CursorOn (0, 0);  (* normal mono or CGA shape is used *)
  653. ;  WriteString (" But now it will!");
  654. ;
  655. *)
  656. CONST cga  = 1;
  657.       mono = 2;
  658.  
  659. VAR   mode : CARDINAL;
  660.  
  661. BEGIN
  662.  
  663.   ASM (* BEGIN *)
  664.     MOV AH,15     (* func 15 = get video adapter *)
  665.     INT 10H       (* call video handler *)
  666.  
  667.     CMP AL,7      (* if AL = 7, it's mono *)
  668.     JZ MONO       (* so go there *)
  669.  
  670. CGA:
  671.     MOV BX,cga    (* nope, it's CGA *)
  672.     MOV mode,BX
  673.  
  674.     JMP DONE
  675.  
  676. MONO:
  677.     MOV BX,mono   (* yep, it's mono *)
  678.     MOV mode,BX
  679.  
  680. DONE:
  681.  
  682.   END; (* ASM *)
  683.  
  684.   IF (startline = 0) AND (endline = 0) THEN
  685.     IF (mode = cga) THEN
  686.       startline := 6;
  687.       endline   := 7;
  688.     ELSE  (* mono *)
  689.        startline := 11;
  690.        endline   := 12;
  691.     END;
  692.   END;
  693.  
  694.   ASM (* BEGIN *)
  695.     MOV AH,1          (* func 1 = set cursor shape *)
  696.     MOV CL, endline
  697.     MOV CH, startline
  698.     INT 10H           (* call video handler *)
  699.   END; (* ASM *)
  700. END CursorOn;
  701.  
  702. (**************************** CursorOff *******************************)
  703.  
  704. PROCEDURE CursorOff;
  705. (* turn the cursor off (for Frame, etc. *)
  706. (* see CursorOn for usage *)
  707. BEGIN
  708.  
  709.   ASM (* BEGIN *)
  710.     MOV AH,1          (* func 1 = set cursor shape *)
  711.     MOV CH,32         (* set bit 5 *)
  712.     INT 10H           (* call video handler *)
  713.   END; (* ASM *)
  714.  
  715. END CursorOff;
  716.  
  717. (******************************* Frame *******************************)
  718.  
  719. PROCEDURE Frame (Method, Width, Height, ULC, ULR : CARDINAL);
  720. (* draw frame from upper left column,row - width across and height down *)
  721.  
  722. (* Method = 1  for single line frame - window not cleared
  723.           = 10 for single line frame - window cleared
  724.  
  725.           = 2  for double line frame - window not cleared
  726.           = 20 for double line frame - window cleared
  727.  
  728.           = 3  for featureless frame - window not cleared
  729.           = 30 for featureless frame - window cleared
  730.  
  731.  
  732.   Set the attribute for the window frame with SetAttrib at same x,y as Frame.
  733.   Set the attribute for inside the window (if cleared) with x+1,y+1.
  734.   Cursor will be at top left of window after call, so you can WriteString.
  735. *)
  736. (* usage:
  737. ;
  738. ;      CursorOff;               (* don't want to see moving cursor *)
  739. ;
  740. ;      SetAttrib (  7, 1, 2);   (* attribute 7 (normal) for frame sides *)
  741. ;      (* note the     ^  ^     column, row of each call *)
  742. ;
  743. ;      SetAttrib (112, 2, 3);   (* attribute 112 (reverse) for inside box *)
  744. ;      (*              ^  ^     *)
  745. ;
  746. ;    Frame(20, 80, 12, 1, 2);   (* window fills top half of screen *)
  747. ;      (*              ^  ^        except for the top line         *)
  748. ;
  749. ;      CursorOn (0, 0);   (* turn cursor on with default shape *)
  750. ;      GetXY (col, row);  (* returns col = 2, row = 3 *)
  751. ;      WriteString("I'm inside a double line, cleared, reverse video window.");
  752. ;      GotoXY (col, row + 1);
  753. ;      WriteString("It extends from column 1 on row 2 to column 80, row 12");
  754. ;
  755. *)
  756. VAR I, atr : CARDINAL;
  757.     ulCor, urCor, llCor, lrCor, vBar, hBar : CHAR;
  758.  
  759. BEGIN
  760.   IF (Method = 1) OR (Method = 10) THEN     (* if single line *)
  761.     ulCor := "┌"; urCor := "┐";
  762.     llCor := "└"; lrCor := "┘";
  763.     vBar  := "│"; hBar  := "─";
  764.  
  765.   ELSIF (Method = 2) OR (Method = 20) THEN  (* if double line *)
  766.     ulCor := "╔"; urCor := "╗";
  767.     llCor := "╚"; lrCor := "╝";
  768.     vBar  := "║"; hBar  := "═";
  769.  
  770.   ELSE                                      (* assume blank line *)
  771.     ulCor := " "; urCor := " ";
  772.     llCor := " "; lrCor := " ";
  773.     vBar  := " "; hBar  := " ";
  774.  
  775.   END;
  776.  
  777.   GetAttrib (atr, ULC, ULR); (* get attribute for frame *)
  778.  
  779.   IF (Method > 3) THEN
  780.     ScrollUp (0, Width - 2, Height - 2, ULC + 1, ULR + 1);  (* clear inside *)
  781.   END;
  782.  
  783.   DEC (Width);
  784.   DEC (Height);
  785.  
  786.   QWrite (ulCor, atr, ULC, ULR);
  787.   FOR I := (ULC + 1) TO (ULC + Width - 1) DO
  788.     QWrite (hBar, atr, I, ULR);
  789.   END;
  790.   QWrite (urCor, atr, ULC + Width, ULR);
  791.  
  792.   FOR I := (ULR + 1) TO (ULR + Height - 1) DO
  793.     QWrite (vBar, atr, ULC, I);
  794.     QWrite (vBar, atr, ULC + Width, I);
  795.   END;
  796.  
  797.   QWrite (llCor, atr, ULC, ULR + Height);
  798.   FOR I := (ULC + 1) TO (ULC + Width - 1) DO
  799.     QWrite (hBar, atr, I, ULR + Height);
  800.   END;
  801.   QWrite (lrCor, atr, ULC + Width, ULR + Height);
  802.  
  803.   GotoXY (ULC + 1, ULR + 1); (* position to top left inside *)
  804. END Frame;
  805.  
  806. (************ Window PROTOTYPE only - NOT implemented  **************)
  807. (*
  808. This simply sets the frame and window attributes and draws a window on top
  809. of the current screen, optionally clearing the window.  Row and Column are
  810. updated as VAR parameters so that column, row will be the top left inside.
  811. -
  812. Save screen first via  ScreenBuffer (Screen0, Save) so it can be restored.
  813. *)
  814.  
  815. (* PROCEDURE Window (Method, FrameAttrib, WindowAttrib : CARDINAL;
  816. *                                      Width, Height : CARDINAL;
  817. *                            VAR  StartCol, StartRow : CARDINAL);
  818. *BEGIN
  819. *  CursorOff;                          (* cursor would spoil effect of framing *)
  820. *                                                     (* set screen attributes *)
  821. *  SetAttrib (FrameAttrib, StartCol, StartRow);           (*  for outside      *)
  822. *  SetAttrib (WindowAttrib, StartCol + 1, StartRow + 1);  (*  for the inside   *)
  823. *
  824. *  Frame (Method, Width, Height, StartCol, StartRow);     (*     draw it,      *
  825. *                                                          *  maybe clear it   *)
  826. *  GetXY (StartCol, StartRow);                            (*   find position   *
  827. *                                                          *    for writing    *)
  828. *END Window;
  829. *)
  830.  
  831.  
  832. (*****************************************************************************
  833.  Placed in the public domain November, 1987 by  author : Alan Steed
  834.                                                          RD2, Safe Harbor Road
  835.                                                          Conestoga, PA 17516
  836. ******************************************************************************)
  837.  
  838. END QVideo.
  839. 
  840.