home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SCRNPAGE.ZIP / SCRNPAGE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1985-12-22  |  10.7 KB  |  406 lines
  1. Program ScrnPage;
  2.  
  3. Const
  4.  Cp = 255;
  5.  
  6. Type
  7.  Reg = Record
  8.         AX,BX,CX,DX,DS,ES,FLAGS: Integer;
  9.        end;
  10.  AnyString = String[255];
  11.  BkColor   = Array[0..7] of Byte;
  12.  TxColor   = Array[0..7] of Byte;
  13.  
  14. Var
  15.  RegRec   :Reg;     (* GLOBAL RECORD OF 8088 REGISTERS *)
  16.  TxtBk    :BkColor; (* GLOBAL ARRAY OF SCREEN BACKGROUND COLORS *)
  17.  TxtClr   :TxColor; (* GLOBAL ARRAY OF SCREEN TEXT COLORS *)
  18.  
  19. (*----------------------------- SET VIDEO MODE ------------------------------
  20.  
  21.    SET VIDEO MODE: CODE   DESCRIPTION
  22.                      0    :40 X 25 MONO
  23.                      1    :40 X 25 COLOR
  24.                      2    :80 X 25 MONO
  25.                      3    :80 X 25 COLOR
  26.                      4    :320 X 200 PIXEL COLOR
  27.                      5    :320 X 200 PIXEL MONO
  28.                      6    :640 X 200 PIXEL MONO
  29.                      7    :80 X 25 MONO CARD ONLY
  30. *)
  31. Procedure SetVideoMod(M: Byte); (* SET VIDEO MODE 0-7.                      *)
  32. Type                            (* SETTING MODE TO MONO WITH A COLOR CARD   *)
  33.  Reg = Record                   (* MAY CAUSE YOUR COMPUTER TO LOCK UP.      *)
  34.         Ax,Bx,Cx,Dx,Bp,Si,Di,Ds,Es,Flags: Integer;
  35.        end;
  36.  
  37. Var
  38.  RegRec: Reg;
  39.  Ah,Al: Byte;
  40.  
  41.  begin
  42.   Ah:=0; Al:=M;
  43.   with RegRec do Ax:=Ah shl 8 + Al;
  44.   Intr($10,RegRec);
  45.  end;
  46.  
  47. (*====================== END OF SET VIDEO MODE =============================*)
  48.  
  49. (*------------------------- GET VIDEO MODE -----------------------------------
  50.  
  51.   TEST VIDEO MODE : CODE   DESCRIPTION
  52.                      0    :40 X 25 MONO
  53.                      1    :40 X 25 COLOR
  54.                      2    :80 X 25 MONO
  55.                      3    :80 X 25 COLOR
  56.                      4    :320 X 200 PIXEL COLOR
  57.                      5    :320 X 200 PIXEL MONO
  58.                      6    :640 X 200 PIXEL MONO
  59.                      7    :80 X 25 MONO
  60. *)
  61.  
  62. Function VideoMod: Byte;
  63. Type
  64.  Reg = Record
  65.         Ax,Bx,Cx,Dx,Bp,Si,Di,Ds,Es,Flags: Integer;
  66.        end;
  67.  
  68. Var
  69.  RegRec: Reg;
  70.  Ah,Al: Byte;
  71.  
  72.  begin
  73.   AH:=15; AL:=0;
  74.   with RegRec do Ax:=Ah shl 8 + Al;
  75.   Intr($10,RegRec);
  76.   with RegRec do VideoMod:=Lo(Ax);
  77.  end;
  78.  
  79. (*========================== END OF GET VIDEO MODE =========================*)
  80.  
  81. Procedure Vid(AH,AL,BH,BL,CH,CL,DH,DL: Byte; DSeg,ESeg: Integer);
  82. begin (* A GENERAL PURPOSE VIDEO BIOS CALLING ROUTINE *)
  83.  With RegRec do
  84.   begin
  85.    AX:=AH SHL 8 + AL;
  86.    BX:=BH SHL 8 + BL;
  87.    CX:=CH SHL 8 + CL;
  88.    DX:=DH SHL 8 + DL;
  89.    DS:=DSeg;
  90.    ES:=ESeg;
  91.   end;
  92.  Intr($10,RegRec);
  93. end;
  94.  
  95. Function Value(S: AnyString): integer; { RETURN THE INTEGER VALUE OF A STRING }
  96. var
  97.  E,V: integer;
  98. label TryAgain;
  99.  begin
  100.   if length(S) > 5 then S:=copy(S,1,5);
  101.   TryAgain: val(S,V,E);
  102.   if (E <> 0)and(S <> '') then
  103.    begin
  104.     delete(S,E,1);
  105.     goto TryAgain;
  106.    end;
  107.   Value:=V;
  108.  end;
  109.  
  110. Procedure TextBackGroundPg(Pg,Color: Byte);
  111.  begin
  112.   if (Color in[0..7])and(Pg in[0..7]) then TxtBk[Pg]:=Color;
  113.  end;
  114.  
  115. Procedure TextColorPg(Pg,Color: Byte);
  116.  begin
  117.   if (Color in[0..15])and(Pg in[0..7]) then TxtClr[Pg]:=Color;
  118.  end;
  119.  
  120. Function Att(Pg: Byte): Byte;
  121. Var
  122.  Temp: Byte;
  123.  begin
  124.   Temp:=0;
  125.   Temp:=Temp or TxtBk[Pg]; Temp:=Temp shl 4;
  126.   Temp:=Temp or TxtClr[Pg];
  127.   Att:=Temp;
  128.  end;
  129.  
  130. Function WhereYPg(Page: Byte): Byte; (* ROW *)
  131. begin
  132.  Vid(3,0,Page,0,0,0,0,0,0,0);
  133.  With RegRec do WhereYPg:=Hi(Dx)+1;
  134. end;
  135.  
  136. Function WhereXPg(Page: Byte): Byte; (* COLUMN *)
  137. begin
  138.  Vid(3,0,Page,0,0,0,0,0,0,0);
  139.  With RegRec do WhereXPg:=Lo(Dx)+1;
  140. end;
  141.  
  142. Procedure ScrollPg(UorD: Char; Ur,Uc,Lr,Lc,Page: Byte); (* SCROLL VIDEO PAGE *)
  143. Var                                 (* ALSO USED TO INSERT AND DELETE A LINE *)
  144.  AH,BH: Byte;
  145.  begin
  146.   BH:=Att(Page);
  147.   if UorD = 'U' then AH:=6;
  148.   if UorD = 'D' then AH:=7;
  149.   Vid(AH,1,BH,0,Ur,Uc,Lr,Lc,0,0);
  150.  end;
  151.  
  152. Procedure InsLinePg(Pg: Byte); (* INSERT A LINE ON VIDEO PAGE *)
  153. Var
  154.  R: Byte;
  155.  begin
  156.   R:=WhereYPg(Pg) - 1; (* SET TO CORRECT VALUE FOR SCROLL PAGE *)
  157.   Case VideoMod of
  158.    0..1 : ScrollPg('D',R,0,24,39,Pg);
  159.    2..3 : ScrollPg('D',R,0,24,79,Pg);
  160.   end; (* END CASE *)
  161.  end;
  162.  
  163. Procedure DelLinePg(Pg: Byte); (* DELETE A LINE ON VIDEO PAGE *)
  164. Var
  165.  R: Byte;
  166.  begin
  167.   R:=WhereYPg(Pg) - 1;
  168.   Case VideoMod of
  169.    0..1 : ScrollPg('U',R,0,24,39,Pg);
  170.    2..3 : ScrollPg('U',R,0,24,79,Pg);
  171.   end; (* END CASE *)
  172.  end;
  173.  
  174. Procedure GotoXyPg(Col,Row,Pg: Byte); (* LOCATE THE CURSOR ON SELECTED PAGE *)
  175. begin
  176.  Row:=Pred(Row); Col:=Pred(Col);
  177.  Vid(2,0,Pg,0,0,0,Row,Col,0,0);
  178. end;
  179.  
  180. Procedure ClrScrPg(Pg: Byte); (* CLEAR CURRENT ACTIVE A SCREEN PAGE *)
  181. Var
  182.  BH,DH,DL: Byte;
  183.  begin
  184.   Case VideoMod of
  185.    0..1: begin
  186.           DH:=24; DL:=39; (* CLEAR SCREEN IN FORTY COLUMN MODE *)
  187.          end;
  188.    2..3: begin
  189.           DH:=24; DL:=79; (* CLEAR SCREEN IN EIGHTY COLUMN MODE *)
  190.          end;
  191.   end; (* END CASE *)
  192.   BH:=Att(Pg); (* SET ATTRIBUTE *)
  193.   Vid(6,0,BH,0,0,0,DH,DL,0,0);
  194.   GotoXyPg(1,1,Pg);
  195.  end;
  196.  
  197. Procedure SetVideoPage(Page: Byte); (* USES INTERRUPT # $10 *)
  198. Var
  199.  AH,AL,BH,BL: Byte;
  200.  begin
  201.   if ((VideoMod in[0..1])and(Page in[0..7])) (* FORTY COLUMN MODE *)
  202.                     or
  203.   ((VideoMod in[2..3])and(Page in[0..3])) then  (* EIGHTY COLUMN MODE *)
  204.    begin
  205.     Vid(5,Page,0,0,0,0,0,0,0,0);
  206.    end;
  207.  end;
  208.  
  209. Function ActPage:Byte; (* RETURNS THE ACTIVE SCREEN PAGE NUMBER           *)
  210. Var                    (* SOME PROGRAMS SUCH AS SIDE-KICK (tm) CHANGE THE *)
  211.  Pg: Byte;             (* ACTIVE PAGE, USUALLY PAGE #0                    *)
  212.  begin
  213.   Vid(15,0,0,0,0,0,0,0,0,0);
  214.   With RegRec do Pg:=Hi(BX);
  215.   ActPage:=Pg;
  216.  end;
  217.  
  218. Procedure WritePage(Pg,Cnt: Byte;Ch: Char); (* USES INTERRUPT # $10 *)
  219. (* PAGE NUMBER, COUNT, ATTRIBUTE, AND CHARCTER *)
  220. Var
  221.  AL,BL: Byte;
  222.  Begin
  223.   AL:=ord(Ch); (* AL = ASCII VALUE OF Ch *)
  224.   BL:=Att(Pg); (* BL = SCREEN ATTRIBUTE *)
  225.   Vid(9,AL,Pg,BL,0,Cnt,0,0,0,0);
  226.  end;
  227.  
  228.  
  229. Procedure WritePg(Pg: Byte; AStr: AnyString); (* PRINT A STRING *)
  230. Var
  231.  I,R,C,MaxR,MaxC: Byte;
  232.  begin
  233.   MaxR:=25;
  234.   if VideoMod in[0..1] then MaxC:=40;
  235.   if VideoMod in[2..3] then MaxC:=80;
  236.   R:=WhereYPg(Pg); C:=WhereXPg(Pg);
  237.   For I:= 1 to Length(AStr) do
  238.    begin
  239.     WritePage(Pg,1,AStr[I]);
  240.     if C < MaxC then C:=Succ(C)
  241.      Else
  242.       begin
  243.        C:=1;
  244.        if R = MaxR then
  245.         begin
  246.          if VideoMod in[0..1] then ScrollPg('U',0,0,24,39,Pg);
  247.          if VideoMod in[2..3] then ScrollPg('U',0,0,24,79,Pg);
  248.         end;
  249.        if R < MaxR then R:=Succ(R);
  250.       end;
  251.     GotoXyPg(C,R,Pg);
  252.    end;
  253.  end;
  254.  
  255. Procedure WriteLnPg(Pg: Byte; AStr: AnyString); (* PRINT A STRING *)
  256. Var
  257.  I,R,C,Sz,MaxR,MaxC: Byte;
  258.  begin
  259.   MaxR:=25;
  260.   if VideoMod in[0..1] then MaxC:=40;
  261.   if VideoMod in[2..3] then MaxC:=80;
  262.   R:=WhereYPg(Pg); C:=WhereXPg(Pg);
  263.   For I:= 1 to Length(AStr) do
  264.   begin
  265.     WritePage(Pg,1,AStr[I]);
  266.     if C < MaxC then C:=Succ(C)
  267.      Else
  268.       begin
  269.        C:=1;
  270.        if R = MaxR then
  271.         begin
  272.          if VideoMod < 2 then Sz:=39;
  273.          if VideoMod in[2..3] then Sz:=79;
  274.          if VideoMod > 3 then Exit;
  275.          ScrollPg('U',0,0,24,Sz,Pg);
  276.         end;
  277.        if R < MaxR then R:=Succ(R);
  278.       end;
  279.     GotoXyPg(C,R,Pg);
  280.    end;
  281.   if R = MaxR then
  282.    begin
  283.     if VideoMod in[0..1] then Sz:=39;
  284.     if VideoMod in[2..3] then Sz:=79;
  285.     if VideoMod > 3 then Exit;
  286.     ScrollPg('U',0,0,24,Sz,Pg);
  287.    end;
  288.   if R < MaxR then R:=Succ(R);
  289.   C:=1;
  290.   GotoXyPg(C,R,Pg);
  291.  end;
  292.  
  293. Procedure ClrEolPg(Page: Byte); (* CLEAR TO END OF LINE *)
  294. Var
  295.  I,R,C: Byte;
  296.  begin
  297.   R:=WhereYPg(Page); C:=WhereXPg(Page);
  298.   Case VideoMod of
  299.    0..1 : WritePage(Page,(41-C),' ');
  300.    2..3 : WritePage(Page,(81-C),' ');
  301.   end; (* END CASE *)
  302.   GotoXyPg(C,R,Page);
  303.  end;
  304.  
  305. Function ReadString(Pg,Len,NS: Byte): AnyString; (* MAX 80 CHARACTERS *)
  306. Var
  307.  R,C: Byte;
  308.  Ch: Char;
  309.  TempStr: AnyString;
  310.  Begin
  311.   R:=WhereYPg(Pg); C:=WhereXPg(Pg); TempStr:=''; Ch:=Chr(0);
  312.   Repeat
  313.    Read(kbd,Ch);
  314.    Case NS of
  315.     1 : if (Ch in['0'..'9','.','+','-'])and(Length(TempStr)<Len)
  316.            then TempStr:=TempStr + Ch;
  317.     0 : if (Ch in[' '..'~'])and(Length(TempStr)<Len)
  318.            then TempStr:=TempStr + Ch;
  319.    end; (* END CASE *)
  320.    if (Ch=Chr(8))and(Length(TempStr)>0) then
  321.     begin
  322.      Delete(TempStr,Length(TempStr),1);
  323.      GotoXyPg(C,R,Pg);
  324.      ClrEolPg(Pg);
  325.     end;
  326.    if (Length(TempStr)=Len)and(Ch<>Chr(13)) then Write(^G);
  327.    GotoXyPg(C,R,Pg);
  328.    WritePg(Pg,TempStr);
  329.   Until (Ch = Chr(13));
  330.   ReadString:=TempStr;
  331.  end;
  332.  
  333. (*----------------------- BEGIN MAIN CALLING LOOP --------------------------*)
  334.  
  335. Var
  336.  AStr,TStr :String[255];
  337.  ScrnPage  :Byte;
  338.  I         :Byte;
  339.  Ch,Mh     :Char;
  340.  
  341. begin
  342.  ScrnPage:=0;
  343.  TStr:='';
  344.  Repeat
  345.   TextBackGroundPg(ScrnPage,7); TextColorPg(ScrnPage,0);
  346.   if ActPage <> ScrnPage then SetVideoPage(ScrnPage);
  347.   GotoXyPg(1,5,ScrnPage);
  348.   WriteLnPg(ScrnPage,'  Key     Function        ');
  349.   WriteLnPg(ScrnPage,' -----   ---------------- ');
  350.   WriteLnPg(ScrnPage,'   -      Previous Screen ');
  351.   WriteLnPg(ScrnPage,'   +      Next Screen     ');
  352.   WriteLnPg(ScrnPage,'   C      Clear Screen    ');
  353.   WriteLnPg(ScrnPage,'   D      Delete Line     ');
  354.   WriteLnPg(ScrnPage,'   E      Enter Text      ');
  355.   WriteLnPg(ScrnPage,'   I      Insert Line     ');
  356.   WriteLnPg(ScrnPage,'   V      Set Video Mode  ');
  357.   WriteLnPg(ScrnPage,' <ESC>    End Program     ');
  358.   Read(kbd,Ch); Ch:=UpCase(Ch);
  359.   if ActPage <> ScrnPage then SetVideoPage(ScrnPage);
  360.   Case VideoMod of
  361.    0..1: begin
  362.           Case Ch of
  363.            '-': if ScrnPage>0 then ScrnPage:=Pred(ScrnPage);
  364.            '+': if ScrnPage<7 then ScrnPage:=Succ(ScrnPage);
  365.           end;
  366.          end;
  367.    2..3: begin
  368.           Case Ch of
  369.            '-': if ScrnPage>0 then ScrnPage:=Pred(ScrnPage);
  370.            '+': if ScrnPage<3 then ScrnPage:=Succ(ScrnPage);
  371.           end;
  372.          end;
  373.   end; { CASE VIDEOMOD }
  374.   TextBackGroundPg(ScrnPage,0); TextColorPg(ScrnPage,15);
  375.   Case Ch of
  376.    'E': begin
  377.          WriteLnPg(ScrnPage,'Enter a string of text? ');
  378.          TStr:=ReadString(ScrnPage,20,0);
  379.          GotoXyPg(1,1,ScrnPage);
  380.          for I:= 1 to 100 do WritePg(ScrnPage,' <> '+TStr);
  381.         end;
  382.    'C': ClrScrPg(ScrnPage);
  383.    'V': begin
  384.          GotoXyPg(1,25,ScrnPage); ClrEolPg(ScrnPage);
  385.          WriteLnPg(ScrnPage,'F)orty or E)ighty column mode? ');
  386.          Repeat
  387.           Read(kbd,Mh); Mh:=UpCase(Mh);
  388.          Until Mh in['F','E'];
  389.          Case Mh of
  390.           'F' : SetVideoMod(1);
  391.           'E' : SetVideoMod(2);
  392.          end; (* END CASE *)
  393.         GotoXyPg(1,25,ScrnPage); ClrEolPg(ScrnPage);
  394.         end;
  395.    'I': InsLinePg(ScrnPage);
  396.    'D': DelLinePg(ScrnPage);
  397.   end;
  398.   GotoXyPg(1,25,ScrnPage); ClrEolPg(ScrnPage);
  399.   Str(ScrnPage:1,AStr);
  400.   WritePg(ScrnPage,AStr);
  401.   WritePg(ScrnPage,' <<< Page Number.');
  402.  Until Ch = Chr(27);
  403.  SetVideoMod(3);
  404.  SetVideoPage(0);
  405. end.
  406.