home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / READSTR.ZIP / KBMISC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-08-27  |  21.4 KB  |  766 lines
  1. {  Global variables accessed by miscellaneous procedures and functions  }
  2.  
  3.  
  4. Type
  5.  String1  =String[1];
  6.  String2  =String[2];
  7.  String3  =String[3];
  8.  String4  =String[4];
  9.  String6  =String[6];
  10.  String8  =String[8];
  11.  String10 =String[10];
  12.  String11 =String[11];
  13.  String20 =String[20];
  14.  String30 =String[30];
  15.  String40 =String[40];
  16.  String66 =String[66];
  17.  String80 =String[80];
  18.  String255=String[255];
  19.  CharSetType=Set of char;
  20.  ByteSetType=Set of Byte;
  21.  HelpLineType=array [1..80] of integer;
  22.  RegsType=record
  23.              Case Integer of
  24.                 1:(ax,bx,cx,dx,bp,si,di,ds,es,flags:integer);
  25.                 2:(al,ah,bl,bh,cl,ch,dl,dh:byte);
  26.           End;  {record}
  27.  GregType=Record   {  4  }
  28.              Day,Month:Byte;
  29.              Year:Integer;
  30.           End;  {record}
  31.  JulType=Record   {  4  }
  32.             Day,Year:Integer;
  33.          End; {record}
  34.  ClockType=Record  {  3  }
  35.               Hour,Minute,Second:Byte;
  36.            End; {record}
  37.  MonthTableType=Record
  38.                    Days:Byte;
  39.                    Jul:Integer;
  40.                 End;
  41.  
  42.  
  43. Const
  44.  esckey        =  1;         BkSpkey    = 14;         tabkey     = 15;
  45.  enterkey      = 28;         f1key      = 59;         f2key      = 60;
  46.  f3key         = 61;         f4key      = 62;         f5key      = 63;
  47.  f6key         = 64;         f7key      = 65;         f8key      = 66;
  48.  f9key         = 67;         f10key     = 68;         homekey    = 71;
  49.  arrowupkey    = 72;         pageupkey  = 73;         arrowlfkey = 75;
  50.  arrowrtkey    = 77;         endkey     = 79;         arrowdnkey = 80;
  51.  pagednkey     = 81;         inskey     = 82;         delkey     = 83;
  52.  CtrlDelKey    =166;         ShiftEscKey=201;         CtrlEscKey =202;
  53.  ShiftBkSpKey  =203;         CtrlBkSpKey=204;         ShiftTabKey=205;
  54.  FullStringExit=206;         CtrlHomeKey=119;         CtrlEndKey =164;
  55.  CtrlArrowRtKey=116;      CtrlArrowLfKey=115;      CtrlArrowUpKey=160;
  56.  CtrlArrowDnKey=164;       CtrlPageUpKey=132;       CtrlPageDnKey=118;
  57.  
  58.  Alt_A_Key=30; Alt_B_Key=48; Alt_C_Key=46; Alt_D_Key=32; Alt_E_Key=18;
  59.  Alt_F_Key=33; Alt_G_Key=34; Alt_H_Key=35; Alt_I_Key=23; Alt_J_Key=36;
  60.  Alt_K_Key=37; Alt_L_Key=38; Alt_M_Key=50; Alt_N_Key=49; Alt_O_Key=24;
  61.  Alt_P_Key=25; Alt_Q_Key=16; Alt_R_Key=19; Alt_S_Key=31; Alt_T_Key=20;
  62.  Alt_U_Key=22; Alt_V_Key=47; Alt_W_Key=17; Alt_X_Key=45; Alt_Y_Key=21;
  63.  Alt_Z_Key=44;
  64.  
  65.  Ctrl_A_Key=#1;  Ctrl_B_Key=#2;  Ctrl_C_Key=#3;  Ctrl_D_Key=#4;
  66.  Ctrl_E_Key=#5;  Ctrl_F_Key=#6;  Ctrl_G_Key=#7;  Ctrl_H_Key=#8;
  67.  Ctrl_I_Key=#9;  Ctrl_J_Key=#10; Ctrl_K_Key=#11; Ctrl_L_Key=#12;
  68.  Ctrl_M_Key=#13; Ctrl_N_Key=#14; Ctrl_O_Key=#15; Ctrl_P_Key=#16;
  69.  Ctrl_Q_Key=#17; Ctrl_R_Key=#18; Ctrl_S_Key=#19; Ctrl_T_Key=#20;
  70.  Ctrl_U_Key=#21; Ctrl_V_Key=#22; Ctrl_W_Key=#23; Ctrl_X_Key=#24;
  71.  Ctrl_Y_Key=#25; Ctrl_Z_Key=#26;
  72.  
  73. Var
  74.  SCC,LFCC,NFCC,DFCC:Byte;
  75.  DateSep,EdateSep1,EdateSep2:char;
  76.  ValidMaskTokenSet:CharSetType;
  77.  On,Off:Boolean;
  78.  ToContinue:String[12];
  79.  ToChangeTo,ToTryAgain:String[13];
  80.  Regs:RegsType;
  81.  BlankString:String[80];
  82.  DayName:array [1..7] of String[9];
  83.  MonthName:array [1..12] of String[9];
  84.  MonthTable:array [1..12] of MonthTableType;
  85.  WindowXL,WindowXR,WindowYT,WindowYB:Integer;
  86.  OldWindow:Array [1..6,1..30] of Integer;
  87.  WPL:Byte;
  88.  WindowGarbage:Array[1..3000] of integer;
  89.  WindowGarbageTop:Integer;
  90.  PopUpArray:Array [0..16] of String[65];
  91.  PopUpKey:Array [1..10] of char;
  92.  BaseOfScreen:Integer;
  93.  WaitForRetrace,CursorStatus,ProcessingHelp:Boolean;
  94.  Maskey:Array [0..20] of CharSetType;
  95.  HelpLine:Array [1..20] of HelpLineType;
  96.  CurrentHelpStatus,OldKBStatus:Byte;
  97.  
  98.  
  99.  
  100. {   Miscellaneous procedures and functions    }
  101.  
  102.  
  103.  
  104. Procedure GotoXYA(X,Y:byte);
  105. Begin
  106.  Regs.ah:=2; Regs.bh:=0;
  107.  Regs.dl:=pred(X); Regs.dh:=pred(Y);
  108.  Intr($10,Regs);
  109. End;
  110.  
  111. Function WhereXA:Byte;
  112. Var WinX:Byte absolute DSeg:4;
  113. Begin
  114.  WhereXA:=WhereX+WinX;
  115. End;
  116.  
  117. Function WhereYA:Byte;
  118. Var WinY:Byte absolute DSeg:5;
  119. Begin
  120.  WhereYA:=WhereY+WinY;
  121. End;
  122.  
  123. Procedure QWriteA(St:String80;X,Y,Att,CursorCode:Byte);
  124. Var SLen:byte absolute St;
  125. Begin
  126.  If X=0 then X:=WhereXA;
  127.  If Y=0 then Y:=WhereYA;
  128.  Inline($1E/$8B/$7E/<Y/$4F/$B9/$04/$00/$D3/$E7/$89/$F8/$D1/$E7/$D1/$E7/$01/$C7/
  129.     $8B/$46/<X/$48/$01/$C7/$D1/$E7/$8D/$76/<ST/$8B/$16/>BASEOFSCREEN/$8E/$C2/
  130.     $A0/>WAITFORRETRACE/$8C/$D2/$8E/$DA/$8A/$0C/$E3/$59/$46/$8A/$66/<ATT/$FC/
  131.     $D0/$D8/$73/$3F/$BA/$DA/$03/$80/$FC/$00/$74/$1B/$AC/$89/$C3/$FA/$EC/$A8/$08/
  132.     $75/$09/$D0/$D8/$72/$F7/$EC/$D0/$D8/$73/$FB/$89/$D8/$AB/$FB/$E2/$E8/$E9/$2D/
  133.     $00/$AC/$88/$C3/$FA/$EC/$A8/$08/$75/$09/$D0/$D8/$72/$F7/$EC/$D0/$D8/$73/$FB/
  134.     $88/$D8/$AA/$FB/$47/$E2/$E7/$E9/$11/$00/$80/$FC/$00/$74/$07/$AC/$AB/$E2/$FC/
  135.     $E9/$05/$00/$AC/$AA/$47/$E2/$FB/$1F);
  136.          {Brian Foley's fastwrite, butchered by me}
  137.  Case CursorCode of
  138.     1:GotoXYA(X,Y);
  139.     2:GotoXYA(X+SLen,Y);
  140.  End; {case}
  141. End;
  142.  
  143. Procedure QWrite(St:String80;X,Y,Att,CursorCode:Byte);
  144. Var
  145.  WinX:Byte absolute DSeg:4;
  146.  WinY:Byte absolute DSeg:5;
  147. Begin
  148.  If X<>0 then X:=X+WinX;
  149.  If Y<>0 then Y:=Y+WinY;
  150.  QWriteA(St,X,Y,Att,CursorCode);
  151. End;
  152.  
  153. Procedure QWriteAttA(Len,X,Y,Att,CC:Byte);
  154. Begin
  155.  If X=0 then X:=WhereXA;
  156.  If Y=0 then Y:=WhereYA;
  157.  Inline($8B/$46/<Y/$48/$B9/$50/$00/$F7/$E1/$03/$46/<X/$48/$D1/$E0/$89/$C7/$47/
  158.         $8B/$16/>BASEOFSCREEN/$8E/$C2/$8B/$4E/<LEN/$E3/$2C/$8B/$46/<ATT/$FC/$8B/
  159.         $1E/>WAITFORRETRACE/$D0/$DB/$73/$1C/$BA/$DA/$03/$88/$C3/$B4/$09/$EC/$D0/
  160.         $D8/$72/$FB/$FA/$EC/$20/$E0/$74/$FB/$88/$D8/$AA/$FB/$47/$E2/$EE/$E9/$04/
  161.         $00/$AA/$47/$E2/$FC/$90); {Brian Foley's FastWriteAtt}
  162.  Case CC of
  163.     1:GotoXYA(X,Y);
  164.     2:GotoXYA(X+Len,Y);
  165.  End; {case}
  166. End;
  167.  
  168. Procedure QWriteAtt(Len,X,Y,Att,CC:Byte);
  169. Var
  170.  WinX:Byte absolute DSeg:4;
  171.  WinY:Byte absolute DSeg:5;
  172. Begin
  173.  If X<>0 then X:=X+WinX;
  174.  If Y<>0 then Y:=Y+WinY;
  175.  QWriteAttA(Len,X,Y,Att,CC);
  176. End;
  177.  
  178. Procedure MoveFromScreen(VAR Source, Dest; Length : Integer);
  179. Begin
  180.  Length:=Length shr 1;
  181.  Inline($8C/$DB/$A0/>WaitForRetrace/$C4/$7E/<Dest/$C5/$76/<Source/$8B/$4E/<Length
  182.  /$FC/$D0/$D8/$73/$19/$BA/$DA/$03/$FA/$EC/$A8/$08/$75/$09/$D0/$D8/$72/$F7/$EC
  183.  /$D0/$D8/$73/$FB/$AD/$FB/$AB/$E2/$EC/$EB/$02/$F2/$A5/$8E/$DB);
  184. END;
  185.  
  186. Procedure MoveToScreen(VAR Source, Dest; Length : Integer);
  187. Begin
  188.  Length:=Length shr 1;
  189.  Inline($1E/$A0/>WaitForRetrace/$C4/$7E/<Dest/$C5/$76/<Source/$8B/$4E/<Length/$FC
  190.  /$D0/$D8/$73/$1D/$BA/$DA/$03/$AD/$89/$C3/$FA/$EC/$A8/$08/$75/$09/$D0/$D8/$72/$F7
  191.  /$EC/$D0/$D8/$73/$FB/$89/$D8/$AB/$FB/$E2/$E8/$EB/$02/$F2/$A5/$1F);
  192. End;
  193.  
  194. Procedure BInc(var X:Byte);
  195. Begin
  196.  X:=succ(X);
  197. End;
  198.  
  199. Procedure BDec(var X:Byte);
  200. Begin
  201.  X:=pred(X);
  202. End;
  203.  
  204. Procedure IInc(var X:Integer);
  205. Begin
  206.  X:=succ(X);
  207. End;
  208.  
  209. Procedure IDec(var X:Integer);
  210. Begin
  211.  X:=pred(X);
  212. End;
  213.  
  214. Function BitCheck(BitNum,AnyByte:Byte):Boolean;
  215. Var BitVal:Byte;
  216. Begin
  217.  BitVal:=1 shl BitNum;
  218.  BitCheck:=((AnyByte and BitVal)=BitVal);
  219. End;
  220.  
  221. Function ByteVal(TempString:String8):Byte;
  222. Var TempInt,Dummy:Integer;
  223. Begin
  224.  Val(TempString,TempInt,Dummy);
  225.  If (TempInt<256) and (TempInt>=0) then ByteVal:=TempInt Else ByteVal:=0;
  226. End;
  227.  
  228. Procedure Cursor(Show:Boolean);
  229. Begin
  230.  Regs.ah:=1;
  231.  If Show then Regs.cx:=$0607 Else Regs.cx:=$2000;
  232.  Intr($10,Regs);
  233.  CursorStatus:=Show;
  234. End;
  235.  
  236. Procedure Beep;
  237. Begin
  238.  sound(1000); Delay(30);
  239.  sound(1500); Delay(30);
  240.  NoSound;
  241. End;
  242.  
  243. Function Spaces(x:byte):String80;
  244. Var BLen:byte absolute BlankString;
  245. Begin
  246.  if x>80 then x:=80;
  247.  BLen:=x; Spaces:=BlankString;
  248. End;
  249.  
  250. Function StringOf(HowMany:Byte;Chars:char):String80;
  251. Var
  252.  Temp:String255;
  253.  TLen:Byte absolute Temp;
  254. Begin
  255.  If HowMany>80 then HowMany:=80;
  256.  fillchar(Temp[1],HowMany,Chars);
  257.  TLen:=HowMany;
  258.  StringOf:=Temp;
  259. End;
  260.  
  261. Function StMask(X:Byte):String80;
  262. Begin
  263.  If X=1 then StMask:='}'
  264.  Else StMask:='}'+StringOf(Pred(X),'#');
  265. End;
  266.  
  267. Function LeftText(X:String80;FieldSize:Byte):String80;
  268. Var XLen:Byte absolute X;
  269. Begin
  270.  If XLen>FieldSize then XLen:=FieldSize;
  271.  LeftText:=X+Spaces(FieldSize-XLen);
  272. End;
  273.  
  274. Function RSpaceWhack(X:String80):String80;
  275. Var XLen:Byte absolute X;
  276. Begin
  277.  While (X[XLen]=' ') and (XLen>0) Do BDec(XLen);
  278.  RSpaceWhack:=x;
  279. End;
  280.  
  281. Function LSpaceWhack(X:String80):String80;
  282. Var XLen:Byte absolute X;
  283. Begin
  284.  While (X[1]=' ') and (XLen>0) Do Delete(x,1,1);
  285.  LSpaceWhack:=x;
  286. End;
  287.  
  288. Function SpaceWhack(x:String80):String80;
  289. Begin
  290.  SpaceWhack:=LSpaceWhack(RSpaceWhack(x));
  291. End;
  292.  
  293. Procedure SetHelp(HLine,HNum:Byte);
  294. Var ScreenLine:HelpLineType absolute $B8F0:0;
  295. Begin
  296.  If HNum<>0 then CurrentHelpStatus:=HNum;
  297.  If HLine<>0 then MoveToScreen(HelpLine[HLine],ScreenLine,160);
  298. End;
  299.  
  300. Procedure SetWindow(XL,YT,XR,YB:Byte);
  301. Begin
  302.  If YB-YT<1 then YB:=succ(YT);  If XR-XL<1 Then XR:=succ(XL);
  303.  BInc(WPL);
  304.  OldWindow[1,WPL]:=WindowXL;
  305.  OldWindow[2,WPL]:=WindowXR;
  306.  OldWindow[3,WPL]:=WindowYT;
  307.  OldWindow[4,WPL]:=WindowYB;
  308.  OldWindow[5,WPL]:=WhereX;
  309.  OldWindow[6,WPL]:=WhereY;
  310.  WindowXL:=XL;
  311.  WindowXR:=XR;
  312.  WindowYT:=YT;
  313.  WindowYB:=YB;
  314.  Window(WindowXL,WindowYT,WindowXR,WindowYB);
  315.  GotoXY(1,1);
  316. End;
  317.  
  318. Procedure RecallWindow;
  319. Begin
  320.  WindowXL:=OldWindow[1,WPL];
  321.  WindowXR:=OldWindow[2,WPL];
  322.  WindowYT:=OldWindow[3,WPL];
  323.  WindowYB:=OldWindow[4,WPL];
  324.  Window(WindowXL,WindowYT,WindowXR,WindowYB);
  325.  GotoXY(OldWindow[5,WPL],OldWindow[6,WPL]);
  326.  BDec(WPL);
  327. End;
  328.  
  329. Procedure TextBox(X,Y,Wide,High,Lines,att:Byte);
  330. Type Portion=(UL,UR,LL,LR,Vert,Horz);
  331. Const
  332.  Piece:array [0..2,Portion] of char = (( #32, #32, #32, #32, #32, #32),
  333.                                        (#218,#191,#192,#217,#179,#196),
  334.                                        (#201,#187,#200,#188,#186,#205));
  335. Var
  336.  I,Rcol:Byte;
  337.  TempString:String[80];
  338.  VertChar:char;
  339. Begin
  340.  TempString:=StringOf(Wide-2,Piece[Lines,Horz]);
  341.  QWriteA(Piece[Lines,UL]+TempString+Piece[Lines,UR],x,y,Att,0);
  342.  VertChar:=Piece[Lines,Vert]; Rcol:=pred(x+wide);
  343.  For I:=1 to High-2 do
  344.    Begin
  345.     QWriteA(VertChar,x,y+I,att,0); QWriteA(VertChar,Rcol,y+I,Att,0);
  346.    End;
  347.  QWriteA(Piece[Lines,LL]+TempString+Piece[Lines,LR],x,pred(y+high),att,0);
  348. End;
  349.  
  350. Procedure WTextBox(X,Y,Wide,High,NumLines,LineAtt,WinAtt:Byte);
  351. Begin
  352.  If High<4 then High:=4; If Wide<4 then Wide:=4;
  353.  TextBox(x,y,Wide,High,NumLines,LineAtt);
  354.  SetWindow(succ(X),succ(Y),X+Wide-2,Y+High-2);
  355.  TextColor(WinAtt and 15); TextBackground(WinAtt shr 4);
  356.  ClrScr;
  357.  TextColor(SCC and 15); TextBackGround(SCC shr 4);
  358. End;
  359.  
  360. Procedure LayWindow(x,y,wide,high,NumBordLines,BordAtt,WinAtt:Byte);
  361. Var
  362.  I:Byte;
  363.  Screen:array [1..25,1..80] of integer absolute $B800:0;
  364. Begin
  365.  If Wide<4 then Wide:=4; If High<4 then High:=4;
  366.  For I:=Y to pred(Y+High) do
  367.    Begin
  368.     MoveFromScreen(Screen[I,X],WindowGarbage[WindowGarbageTop],wide shl 1);
  369.     WindowGarbageTop:=WindowGarbageTop+Wide;
  370.    End;
  371.  WTextBox(X,Y,Wide,High,NumBordLines,BordAtt,WinAtt);
  372. End;
  373.  
  374. Procedure PeelWindow;
  375. Var
  376.  I,x,wide:Byte;
  377.  Screen:array [1..25,1..80] of integer absolute $B800:0;
  378. Begin
  379.  wide:=WindowXR-WindowXL+3;
  380.  X:=pred(WindowXL);
  381.  For I:=succ(WindowYB) downto pred(WindowYT) Do
  382.    Begin
  383.     WindowGarbageTop:=WindowGarbageTop-Wide;
  384.     MoveToScreen(WindowGarbage[WindowGarbageTop],Screen[I,X],Wide shl 1);
  385.    End;
  386.  RecallWindow;
  387. End;
  388.  
  389. Procedure ScreenClock; forward;
  390. Procedure HelpNeeded; forward;
  391.  
  392. Procedure GetKey(InsertStatusLine:Boolean; Var Scan:Byte; var Ascii:char);
  393. Var
  394.  KeyGiven,ShiftKey,CtrlKey:Boolean;
  395.  KBStatus:Byte absolute $40:$17 ;
  396.  
  397.    Procedure WriteInsertStatus;
  398.    Const InsStat:Array [False..True] of String[9]=('Overwrite','Insert   ');
  399.    Begin
  400.     QWriteA(InsStat[BitCheck(7,OldKBStatus)],71,1,7,0);
  401.    End;
  402.  
  403. Begin
  404.  If InsertStatusLine then WriteInsertStatus;
  405.  KeyGiven:=False;
  406.  Repeat
  407.     If KeyPressed Then
  408.       Begin
  409.        KeyGiven:=True;
  410.        Regs.ax:=0; Intr(22,Regs);
  411.        Ascii:=Char(Regs.al); Scan:=Regs.ah;
  412.        OldKBStatus:=KBStatus;
  413.        If (Scan=F1Key) and not ProcessingHelp then HelpNeeded;
  414.        If (Scan=InsKey) and InsertStatusLine and (ascii<>'0') then
  415.          Begin
  416.           WriteInsertStatus;
  417.           KeyGiven:=False;
  418.          End;
  419.       End
  420.     Else ScreenClock;
  421.  Until KeyGiven;
  422.  ShiftKey:= Bitcheck(0,OldKBStatus) or Bitcheck(1,OldKBStatus);
  423.  CtrlKey:=  Bitcheck(2,OldKBStatus);
  424.  Case Ascii of
  425.     #0:if Scan=15 then Scan:=ShiftTabKey;
  426.     #9:If Scan=15 then Ascii:=#0;
  427.     #27:If Scan in [1,34] then
  428.           Begin
  429.            Ascii:=#0;
  430.            If ShiftKey then Scan:=ShiftEscKey
  431.            Else If CtrlKey then Scan:=CtrlEscKey;
  432.           End;
  433.     #8,#127:If Scan=14 then
  434.               Begin
  435.                Ascii:=#0;
  436.                If ShiftKey then Scan:=ShiftBkSpKey
  437.                Else If CtrlKey then Scan:=CtrlBkSpKey;
  438.               End;
  439.     #13,#10:If Scan=28 then Ascii:=#0;
  440.  End; {case}
  441.  If Ascii>#0 then Scan:=0;
  442.  If InsertStatusLine then QWriteA(Spaces(9),71,1,7,0);
  443. End;
  444.  
  445. Function MaskIndex(Token:Char):Byte;
  446. Var X:Byte;
  447. Begin
  448.  Case Token of
  449.     '!'      : X:=1;
  450.     '#'      : X:=2;
  451.     '&'      : X:=3;
  452.     '*'..'+' : X:=ord(Token)-38;  {4..5}
  453.     '/'      : X:=6;
  454.     '<'..'@' : X:=ord(Token)-53;  {7..11}   {  <=>?@  }
  455.     '['..'^' : X:=ord(Token)-79;  {12..15}  {   [\]^  }
  456.     '{'..'~' : X:=ord(Token)-107; {16..19} (*   {|}~  *)
  457.     #255     : X:=20;
  458.     Else       X:=0;
  459.  End; {case}
  460.  MaskIndex:=X;
  461. End;
  462.  
  463. Procedure SetMask(Token:Char;M:String255);
  464. Var
  465.  I,MI:Byte;
  466.  MLen:Byte absolute M;
  467. Begin
  468.  MI:=MaskIndex(Token);
  469.  If MI in [1..19] then
  470.    Begin
  471.     Maskey[MI]:=[];
  472.     If MLen>0 then
  473.        For I:=1 to MLen Do
  474.           If (M[I]='.') and (I>1) and not((M[pred(I)]='.') or (M[succ(I)]='.')) and (I<MLen) then
  475.              Maskey[MI]:=Maskey[MI]+[M[pred(I)]..M[succ(I)]]
  476.           Else Maskey[MI]:=Maskey[MI]+[M[I]];
  477.    End;
  478. End;
  479.  
  480. Procedure ReadKey(InsertStatusLine:Boolean;
  481.                   ScanExitSet:ByteSetType;
  482.                   AsciiExitSet:CharSetType;
  483.                   MaskToken:char;
  484.                   Var Scan:Byte;
  485.                   Var Ascii:Char);
  486. Var Mask:CharSetType;
  487. Begin
  488.  Mask:=Maskey[MaskIndex(MaskToken)]+AsciiExitSet;
  489.  Repeat
  490.     GetKey(InsertStatusLine,Scan,Ascii);
  491.     If not(Ascii in Mask) and (ascii in Maskey[1]) then
  492.        If Ascii in [#65..#90] then Ascii:=char(ord(Ascii)+32)
  493.        Else Ascii:=char(ord(Ascii)-32);
  494.  Until (Scan in ScanExitSet) or (Ascii in Mask);
  495. End;
  496.  
  497. Procedure ClearKBBuffer;
  498. Var key:char;
  499. Begin
  500.  While Keypressed do read(kbd,key);
  501. End;
  502.  
  503. Function AutoX(Wide:Byte):Byte;
  504. Var X:Integer;
  505. Begin
  506.  X:=WhereXA-(wide div 4);
  507.  If X<1 then X:=1;
  508.  If X+wide>81 then X:=81-wide;
  509.  AutoX:=lo(X);
  510. End;
  511.  
  512. Function AutoY(High:Byte):Byte;
  513. Var Y:Integer;
  514. Begin
  515.  Y:=WhereYA;
  516.  If Y>13 then
  517.    Begin
  518.     Y:=Y-high-2;
  519.     If Y<3 then Y:=3;
  520.    End
  521.  Else
  522.    Begin
  523.     Y:=Y+2;
  524.     If Y+high>25 then Y:=25-high;
  525.    End;
  526.  AutoY:=lo(Y);
  527. End;
  528.  
  529. Procedure PopNote(Nlines,Nkeys:byte; var key:char);
  530. Var
  531.  OldCursorStatus:boolean;
  532.  x,y,I,wide,high,Dummy:byte;
  533.  AsciiExitSet:CharSetType;
  534.  HelpLine:byte absolute $B8F0:0;
  535.  TempHelpLine:array [1..160] of byte;
  536.  
  537.    Procedure CalcSize;
  538.    Begin
  539.     wide:=0;
  540.     For I:=1 to Nlines Do
  541.        If length(PopUpArray[I])+9>wide then wide:=length(PopUpArray[I])+9;
  542.     For I:=succ(Nlines) to Nlines+NKeys Do
  543.        If length(PopUpArray[I])+14>wide then wide:=length(PopUpArray[I])+14;
  544.     high:=Nlines+Nkeys+2;
  545.    End;
  546.  
  547.    Procedure CalcPos;
  548.    Begin
  549.     Y:=AutoY(High);
  550.     X:=AutoX(Wide);
  551.    End;
  552.  
  553. Begin
  554.  MoveFromScreen(HelpLine,TempHelpLine,160);
  555.  OldCursorStatus:=CursorStatus; Cursor(Off); SetHelp(19,1);
  556.  CalcSize; CalcPos;
  557.  LayWindow(x,y,wide,high,1,$70,$70);
  558.  QWrite('Note!:',1,1,0,0);
  559.  For I := 1 to Nlines Do QWrite(PopUpArray[I],8,I,0,0);
  560.  AsciiExitSet:=[];
  561.  For I := 1 to Nkeys Do
  562.    Begin
  563.     QWrite(PopUpArray[I+Nlines],13,NLines+I,0,0);
  564.     If I=1 then QWrite('ESC',8,NLines+I,$60,0)
  565.     Else
  566.       Begin
  567.        AsciiExitSet:=AsciiExitSet+[PopUpKey[I]];
  568.        QWrite(PopUpKey[I],9,NLines+I,$60,0);
  569.       End;
  570.    End;
  571.  QWrite('Press:',1,succ(NLines),0,0);
  572.  For I:=1 to 4 do Beep; Delay(300); ClearKBBuffer;
  573.  ReadKey(off,[esckey],AsciiExitSet,#0,Dummy,key);
  574.  PeelWindow; Cursor(OldCursorStatus);
  575.  MoveToScreen(TempHelpLine,HelpLine,160);
  576. End;
  577.  
  578.  
  579.  
  580.  
  581. { * * * * *     T I M E   F U N C T I O N S     * * * * * }
  582.  
  583.  
  584. Procedure DaypartToClock(DayPart:Integer; Var Clock:ClockType);
  585. Begin
  586.  Clock.Hour:=DayPart div 720;
  587.  Clock.Minute:=(DayPart mod 720) div 12;
  588.  Clock.Second:=(DayPart mod 12)*5;
  589. End;
  590.  
  591. Procedure ClockToDaypart(Clock:ClockType; Var DayPart:Integer);
  592. Begin
  593.  DayPart:=((Clock.Second+2) div 5)+Clock.Minute*12+Clock.Hour*720;
  594. End;
  595.  
  596. Procedure RawTime(Var Clock:ClockType);
  597. Begin
  598.  regs.ax:=$2C00; MSDOS(regs);
  599.  Clock.Hour:=regs.ch; Clock.Minute:=regs.cl; Clock.Second:=regs.dh;
  600. End;
  601.  
  602. Function TimeString(Clock:ClockType;MilitaryTime:Boolean):String10;
  603. Const
  604.  AmPm:Array[False..True,0..1] of String[2]=(('am','pm'),(' M',' N'));
  605. Var
  606.  H:Byte absolute Clock;
  607.  MinSec:String[5];
  608. Begin
  609.  MinSec:=form('@@',Clock.Minute)+':'+form('@@',Clock.Second);
  610.  If MilitaryTime Then TimeString:=form('@@',H)+':'+MinSec
  611.  Else TimeString:=form('##',succ((H+11)mod 12))+':'+MinSec+
  612.       AmPm[(Clock.Minute+Clock.Second+(H mod 12)=0),(H div 12)];
  613. End;
  614.  
  615.  
  616. { * * * * *     D A T E   F U N C T I O N S     * * * * * }
  617.  
  618.  
  619. Procedure GregToJul(Greg:GregType;Var Jul:JulType);
  620. Begin
  621.  Jul.Day:=MonthTable[Greg.Month].Jul+Greg.Day;
  622.  If (Greg.Year mod 4=0) and (Greg.Month>2) Then IInc(Jul.Day);
  623.  Jul.Year:=Greg.Year;
  624. End;
  625.  
  626. Procedure JulToGreg(Jul:Jultype;Var Greg:GregType);
  627. Var I:Byte;
  628. Begin
  629.  If (Jul.Year mod 4 = 0) and (Jul.Day > 59) Then
  630.     If Jul.Day=60 Then
  631.       Begin
  632.        Greg.Day:=29; Greg.Month:=2; Greg.Year:=Jul.Year; Exit;
  633.       End
  634.     Else IDec(Jul.Day);
  635.  I:=1; While Jul.Day>MonthTable[I].Jul do BInc(I);
  636.  BDec(I); Greg.Month:=I; Greg.Day:=Jul.Day-MonthTable[I].Jul;
  637.  Greg.Year:=Jul.Year;
  638. End; {Function}
  639.  
  640. Procedure RawDate(Var Greg:GregType);
  641. Begin
  642.  regs.ax:=$2A00; MSDOS(regs);
  643.  Greg.Day:=regs.dl; Greg.Month:=regs.dh; Greg.Year:=regs.cx;
  644. End;
  645.  
  646. Function Calendar(Greg:GregType;Style,Size:char):String30;
  647. Var
  648.  Day:String[2];
  649.  Month:String[9];
  650.  Year:String[4];
  651. Begin
  652.  Day:=form('@@',Greg.Day); Year:=form('####',Greg.Year);
  653.  If size = 'S' Then Year:=copy(Year,3,2);
  654.  Month:=MonthName[Greg.Month];
  655.  If size='S' Then Month:=copy(Month,1,3);
  656.  Case Style of
  657.     'N':Calendar:=form('@@',Greg.Month)+DateSep+Day+DateSep+Year;
  658.     'A':Calendar:=Month+' '+Day+', '+Year;
  659.     'E':Begin
  660.          If size='S' Then Calendar:=Day+EdateSep1+Month+EDateSep2+Year
  661.          Else Calendar:=Day+' '+Month+', '+Year;
  662.         End;
  663.  End; {Case}
  664. End; {Function}
  665.  
  666. Procedure ScreenClock;
  667. Var
  668.  Greg:GregType;
  669.  Clock:ClockType;
  670.  TempString:String[23];
  671.  DayString:String[3];
  672. Begin
  673.  RawDate(Greg);
  674.  If Regs.AL=0 then DayString:='Sun' Else DayString:=DayName[Regs.AL];
  675.  TempString:=DayString+' '+Calendar(Greg,'N','S');
  676.  RawTime(Clock);
  677.  QWriteA(TempString+' '+TimeString(Clock,off),1,1,7,0);
  678. End;
  679.  
  680. Procedure HelpNeeded;
  681. Var
  682.  dummy:char;
  683.  TempHelpLine:array [1..160] of byte;
  684.  HelpLine:byte absolute $B8F0:0;
  685. Begin
  686.  MoveFromScreen(HelpLine,TempHelpLine,160);
  687.  ProcessingHelp:=True;
  688.  PopUpArray[1]:='No help screens are available at this time.';
  689.  PopUpArray[2]:=ToContinue;
  690.  PopNote(1,1,dummy);
  691.  ProcessingHelp:=False;
  692.  MoveToScreen(TempHelpLine,HelpLine,160);
  693. End;
  694.  
  695.  
  696. Procedure initialize;
  697.  
  698.    Procedure Necessary;
  699.  
  700.       Procedure LoadHelp;
  701.       Type TwentyHelpLines=Array[1..20] of HelpLineType;
  702.       Var
  703.        X:TwentyHelpLines absolute HelpLine;
  704.        Diskfile:File of TwentyHelpLines;
  705.       Begin
  706.        Assign(DiskFile,'HELP.SCR'); Reset(DiskFile);
  707.        Read(DiskFile,X); Close(DiskFile);
  708.       End;
  709.  
  710.    Var
  711.     KBStatus : byte absolute $40:$17 ;
  712.     I:Byte;
  713.    Const
  714.     TempArray1:array [1..7] of String[9]=('Monday','Tuesday','Wednesday',
  715.                                   'Thursday','Friday','Saturday','Sunday');
  716.     TempArray2:array [1..12] of String[9]=('January','February','March','April',
  717.         'May','June','July','August','September','October','November','December');
  718.     TempArray3:array [1..36] of Byte=(31,0,0,28,31,0,31,59,0,30,90,0,31,120,0,
  719.                  30,151,0,31,181,0,31,212,0,30,243,0,31,17,1,30,48,1,31,78,1);
  720.    Begin
  721.     TextMode(C80); TextColor(7); TextBackGround(0);
  722.     On:=True; Off:=False;
  723.     WPL:=0; WindowGarbageTop:=1; setwindow(1,1,80,25); ClrScr; Cursor(on);
  724.     BaseOfScreen:=$B800; WaitForRetrace:=True;
  725.     BlankString:=StringOf(80,' ');
  726.     LoadHelp;
  727.     ValidMaskTokenSet:=['!','#','&','*','+','/','<'..'@','['..'^','{'..'~'];
  728.     LFCC:=$7F; {Live Field Composite Color}
  729.     NFCC:=$6E; {Neutral Field Composite Color}
  730.     DFCC:=$27; {Dead Field Composite Color}
  731.     SCC:=7;    {Standard composite color}
  732.     DateSep:='-';   { This is for AmericanNumeric only }
  733.     EdateSep1:='-'; { Goes Between the European date's Day and Month AND }
  734.     EdateSep2:='-'; { Month and Year respectively (Short version only)   }
  735.     ToContinue:='To continue.';
  736.     ToChangeTo:='To change to ';
  737.     ToTryAgain:='To try again.';
  738.     Move(TempArray1,DayName,SizeOf(DayName));
  739.     Move(TempArray2,MonthName,SizeOf(MonthName));
  740.     Move(TempArray3,MonthTable,SizeOf(MonthTable));
  741.     For I:=0 to 19 Do Maskey[I]:=[];
  742.     Maskey[20]:=[#1..#254];
  743.     OldKBStatus:=KBStatus;
  744.     ProcessingHelp:=False;
  745.    End;
  746.  
  747.    Procedure NotNecessary;
  748.    Begin
  749.     SetMask('#',' .~');
  750.     SetMask('<','a.z');
  751.     SetMask('>','A.Z');
  752.     SetMask('{',' .@[.~');
  753.     SetMask('}',' .`{.~');
  754.     SetMask('!','A.Za.z');
  755.     SetMask('&','0.9');
  756.     SetMask('?',' !#.%(.+-.]');
  757.     SetMask('@','A.Z0.9');
  758.    End;
  759.  
  760. Begin {procedure Initialize}
  761.  Necessary;
  762.  NotNecessary;
  763. End;
  764.  
  765.  
  766.