home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SCREDIT2.ZIP / SCRED30.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-03-02  |  15.7 KB  |  603 lines
  1. {$U-,C-}
  2. Const
  3. S_LineSize     : Integer   = 160;
  4. S_Zeros        : String[8] = '00000000';
  5.  
  6. Type
  7. S_Cursors = (S_Bold,S_Off,S_Normal,S_GetCursor);
  8. S_RecType = (S_Index,S_Data,S_Fields,S_FieldRanges,S_Work);
  9. S_Str80   = String[80];
  10.  
  11. S_Rec =
  12.    Record
  13.    Case S_RecordType:S_RecType of
  14.        S_Index:  {Total Bytes 3457}
  15.            (S_Name         : Array[1..128] of String[16];
  16.             S_Number       : Array[1..128] of Byte;
  17.             S_RecordNumber : Array[1..128] of Integer;
  18.             S_FieldsRecNo  : Array[1..128] of Integer;
  19.             S_RangeRecNo   : Array[1..128] of Integer;
  20.             S_First        : Array[1..128] of Byte;
  21.             S_Count        : Array[1..128] of Byte;
  22.             S_CompiledInd  : Array[1..128] of Byte;
  23.             S_RangeRecNext : Integer;
  24.             S_RangeLineNext: Integer;
  25.             S_sFiled       : Integer);
  26.        S_Data:   {Total Bytes 3840 + 1}
  27.            (S_Video        : Array[1..3840]of Char;
  28.             S_WorkArray    : Array[1..80,1..2] of Char;);
  29.        S_Fields: {Total Bytes 4225}
  30.            (S_FieldName    : Array[1..128] of String[16];
  31.             S_Row          : Array[1..128] of Byte;
  32.             S_Col          : Array[1..128] of Byte;
  33.             S_Len          : Array[1..128] of Byte;
  34.             S_Type         : Array[1..128] of Byte;
  35.             S_Prev         : Array[1..128] of Byte;
  36.             S_Next         : Array[1..128] of Byte;
  37.             S_DataLen      : Array[1..128] of Byte;
  38.             S_NormalBG     : Array[1..128] of Byte;
  39.             S_NormalFG     : Array[1..128] of Byte;
  40.             S_PromptBG     : Array[1..128] of Byte;
  41.             S_PromptFG     : Array[1..128] of Byte;
  42.             S_DisplayBG    : Array[1..128] of Byte;
  43.             S_DisplayFG    : Array[1..128] of Byte;
  44.             S_RangeNextRec : Array[1..128] of Integer;
  45.             S_RangeNextLine: Array[1..128] of Byte);
  46.        S_FieldRanges: {Total Bytes 3608 + 1}
  47.            (S_RangeList    : Array[1..51] of String[78];
  48.             S_RangeRec     : Array[1..51] of Integer;
  49.             S_RangeLine    : Array[1..51] of Byte);
  50.        End;
  51.  
  52. S_RecPointer      = ^S_Rec;
  53. WorkAreaType      = Array[1..4096] of byte;
  54. WorkAreaPtr       = ^WorkAreaType;
  55. FieldPointerType  = Array[1..128] of integer;
  56. FieldPointer      = ^FieldPointerType;
  57. BufferPointerType = Array[1..128] of WorkAreaPtr;
  58. BufferPointer     = ^BufferPointerType;
  59.  
  60. Var
  61. S_File        : File of S_Rec;
  62. S_Indx        : S_RecPointer;
  63. S_Record      : S_RecPointer;
  64. S_Field       : S_RecPointer;
  65. S_WorkArea    : WorkAreaPtr;
  66. S_FieldPtr    : FieldPointer;
  67. S_BuffPtr     : BufferPointer;
  68. S_Cursor      : S_Cursors;
  69. S_CursorOld   : Integer;
  70. S_WorkStr,
  71. S_Msg,
  72. S_EditStr,
  73. S_NewStr,
  74. S_Blanks,
  75. S_Padding,
  76. S_EditAttrib,
  77. S_WorkAttrib,
  78. S_NormAttrib  : S_Str80;
  79. S_StatusLine,
  80. S_StatusAttrib :String[40];
  81. S_StAttrWork   :String[20];
  82. S_Cnt,
  83. S_RecNo,
  84. S_ValidateField,
  85. S_ValidateLine,
  86. S_Fg,
  87. S_Bg,
  88. S_Str_Pos,
  89. S_Attrib,
  90. S_MessBg,
  91. S_MessFg,
  92. S_NormBg,
  93. S_NormFg,
  94. S_Num,
  95. S_Count,
  96. S_FieldCounter,
  97. S_FirstField,
  98. S_Direction,
  99. S_Max_Dig,
  100. S_Max_Dec,
  101. S_PointHold,
  102. S_Point,
  103. S_RegCH,
  104. S_RegCL,
  105. S_Freq,
  106. S_Dur,
  107. S_Seg,
  108. S_Ofs  : Integer;
  109. S_BW,
  110. S_Sound,
  111. S_Sound_Hold,
  112. S_ChangeScreen,
  113. S_NumLock,
  114. S_Mono,
  115. S_Fkey,
  116. S_Shift,
  117. S_Alt,
  118. S_Ctrl,
  119. S_ESC,
  120. S_F1,
  121. S_F2,
  122. S_F3,
  123. S_F4,
  124. S_F5,
  125. S_F6,
  126. S_F7,
  127. S_F8,
  128. S_F9,
  129. S_F10,
  130. S_Enter,
  131. S_BkSp,
  132. S_Home,
  133. S_Up,
  134. S_PgUp,
  135. S_Left,
  136. S_Right,
  137. S_End,
  138. S_Down,
  139. S_PgDn,
  140. S_Ins,
  141. S_Del,
  142. S_Tab,
  143. S_Upcase,
  144. S_Validate_Finished,
  145. S_ScreenValid,
  146. S_Wait,
  147. S_ShowStatus,
  148. S_ScrollLock,
  149. S_Caps,
  150. S_LeftShift,
  151. S_RightShift,
  152. S_InsertMode,
  153. S_LeftArrow,
  154. S_RightArrow,
  155. S_InsertKey,
  156. S_DeleteKey,
  157. S_BackSpace   : Boolean;
  158. S_Ins_Str     : String[1];
  159. S_AttribHold,
  160. S_CharHold,
  161. S_Ch2,
  162. S_Ch          : Char;
  163. S_Ch_Num      : Byte Absolute S_Ch;
  164. S_Reverse     : Byte;
  165. S_NumLockBit  : Integer absolute $40:$17;
  166. S_VideoPort   : Integer absolute $40:$63;
  167.  
  168. {Variables used in validation procedures}
  169.  
  170. S_Skip,
  171. S_Matched,
  172. S_Done,
  173. S_EndLine,
  174. S_InIf : Boolean;
  175. S_CompMin,
  176. S_CompMax,
  177. S_CurStr  : S_Str80;
  178. S_NextRec,
  179. S_NextLine,
  180. S_Result,
  181. S_FieldNo,
  182. S_Str_Ptr  : Integer;
  183. S_Numeric,
  184. S_CompMin_Numeric,
  185. S_CompMax_Numeric  :Real;
  186.  
  187. Procedure S_Init; Forward;
  188. Procedure S_ResetKeyFlags; Forward;
  189. Procedure S_DisplayMessage(Var BackG,ForG : Integer; Message: S_Str80); Forward;
  190. Procedure S_Write(Row,Col,Lgth : Integer; Lines,attribs : S_Str80);Forward;
  191. Procedure S_PutScrMem(var Source, Dest; Len : integer);Forward;
  192. Procedure S_GetScrMem(var Source, Dest; Len : integer);Forward;
  193. Procedure S_Beep(Freq,Dur:Integer);Forward;
  194. Procedure S_CloseScreenFile;Forward;
  195. Procedure S_SetCursor(Switch:S_Cursors);
  196. Type
  197. S_RegDef = Record
  198.    S_Cpu_Al,S_Cpu_Ah,
  199.    S_Cpu_Bl,S_Cpu_Bh:Byte;
  200.              S_Cpu_Cx,
  201.              S_Cpu_Bp,
  202.              S_Cpu_Si,
  203.              S_Cpu_Di,
  204.              S_Cpu_Ds,
  205.              S_Cpu_Es,
  206.              S_Cpu_Flags:Integer;
  207.     End;
  208. Var
  209. S_Regs : S_RegDef;
  210.  
  211. Begin
  212. FillChar(S_Regs,SizeOf(S_Regs),00);
  213. S_Regs.S_Cpu_AH := 1;
  214. S_Regs.S_Cpu_Bh := 0;
  215.  
  216. Case Switch of
  217.     S_Normal    : S_Regs.S_Cpu_Cx := S_CursorOld;
  218.     S_Off       : S_Regs.S_Cpu_CX := 4096;
  219.     S_Bold      : S_Regs.S_Cpu_CX := 15;
  220.     S_GetCursor : S_Regs.S_Cpu_AH := 3;
  221. End;{Case}
  222.  
  223. Intr($10,S_Regs);
  224.  
  225. If  Switch = S_GetCursor Then
  226.     S_CursorOld := S_Regs.S_Cpu_Cx;
  227. End;
  228.  
  229.  
  230.  
  231. Procedure S_GetKey;
  232. Begin
  233. S_ResetKeyFlags;
  234.  
  235. If  S_Wait Then
  236.     S_DisplayMessage(S_MessBg,S_MessFg,S_Msg);
  237.  
  238. While Not KeyPressed Do
  239.     Begin
  240.     S_Cnt        := 0;
  241.     S_LeftShift  := False;
  242.     S_RightShift := False;
  243.     S_Shift      := False;
  244.     S_Ctrl       := False;
  245.     S_Alt        := False;
  246.     S_ScrollLock := False;
  247.     S_NumLock    := False;
  248.     S_Caps       := False;
  249.     S_InsertMode := False;
  250.     If  ((S_NumLockBit and 2)=2) Then
  251.         Begin
  252.         S_Cnt       := S_Cnt + 1;
  253.         S_LeftShift := True;
  254.         S_Shift     := True;
  255.         End;
  256.     If  ((S_NumLockBit and 1)=1) Then
  257.         Begin
  258.         S_Cnt        := S_Cnt + 1;
  259.         S_RightShift := True;
  260.         S_Shift      := True;
  261.         End;
  262.     If  ((S_NumLockBit And 4)=4) Then
  263.         Begin
  264.         S_Cnt  := S_Cnt + 1;
  265.         S_Ctrl := True;
  266.         End;
  267.     If  ((S_NumLockBit And 8)=8) Then
  268.         Begin
  269.         S_Cnt  := S_Cnt + 1;
  270.         S_Alt  := True;
  271.         End;
  272.     If  ((S_NumLockBit And 16)=16) Then
  273.         S_ScrollLock := True;
  274.     If  ((S_NumLockBit and 32)=32) then
  275.         S_NumLock := True;
  276.     If  ((S_NumLockBit And 64)=64) Then
  277.         S_Caps := True;
  278.     If  ((S_NumLockBit And 128)=128) Then
  279.         S_InsertMode := True;
  280.  
  281.     If  (S_ShowStatus)   And
  282.         (S_Wait = False) Then
  283.         Begin
  284.         FillChar(S_StatusAttrib,41,02);
  285.         S_StatusAttrib[0] := #40;
  286.         If  S_InsertMode Then
  287.             Move(S_StAttrWork[1],S_StatusAttrib[1],8);
  288.         If  S_Caps Then
  289.             Move(S_StAttrWork[1],S_StatusAttrib[10],6);
  290.         If  S_NumLock Then
  291.             Move(S_StAttrWork[1],S_StatusAttrib[17],10);
  292.         If  S_ScrollLock Then
  293.             Move(S_StAttrWork[1],S_StatusAttrib[28],13);
  294.         S_Write(25,21,40,S_StatusLine,S_StatusAttrib);
  295.         End;
  296.     If  S_Cnt > 1 Then
  297.         Begin
  298.         S_Fkey := True;
  299.         Exit;
  300.         End;
  301.     End;
  302.  
  303. S_Wait := False;
  304. Read(Kbd,S_Ch);
  305.  
  306. If  S_Msg > '' Then
  307.     Begin
  308.     S_Msg := '';
  309.     S_DisplayMessage(S_MessBg,S_MessFg,S_Msg);
  310.     End;
  311.  
  312. If  S_Shift = True Then
  313.     Begin
  314.     If  (S_Ch_Num = 27) And (KeyPressed) Then
  315.         Begin
  316.         Read(Kbd,S_Ch);
  317.         S_Fkey  := True;
  318.         Case S_Ch_Num of
  319.             84 : S_F1   := True;
  320.             85 : S_F2   := True;
  321.             86 : S_F3   := True;
  322.             87 : S_F4   := True;
  323.             88 : S_F5   := True;
  324.             89 : S_F6   := True;
  325.             90 : S_F7   := True;
  326.             91 : S_F8   := True;
  327.             92 : S_F9   := True;
  328.             93 : S_F10  := True;
  329.             15 : Begin
  330.                  S_Tab  := True;
  331.                  S_Fkey := False;
  332.                  End;
  333.             End;
  334.         S_Ch := #00;
  335.         Exit;
  336.         End
  337.     Else
  338.         Begin
  339.         Case S_Ch_Num of
  340.             8  : Begin S_BkSp := True; S_FKey := True;End;
  341.             13 : S_Enter:= True;
  342.             33,34,35,36,37,38,40,41,42,43,58,60,62,63,64,
  343.             65..90,94,95,123,124,125,126:Exit;
  344.             52 : Begin S_Left := True; S_Fkey := True;End;
  345.             54 : Begin S_Right:= True; S_Fkey := True;End;
  346.             56 : Begin S_Up   := True; S_Fkey := True;End;
  347.             50 : Begin S_Down := True; S_Fkey := True;End;
  348.             55 : Begin S_Home := True; S_Fkey := True;End;
  349.             49 : Begin S_End  := True; S_Fkey := True;End;
  350.             57 : Begin S_PgUp := True; S_Fkey := True;End;
  351.             51 : Begin S_PgDn := True; S_Fkey := True;End;
  352.             48 : Begin S_Ins  := True; S_Fkey := True;End;
  353.             46 : Begin S_Del  := True; S_Fkey := True;End;
  354.             27 : Begin S_Esc  := True; S_Fkey := True;End;
  355.             End;
  356.         S_Ch_Num := 0;
  357.         Exit
  358.         End;
  359.     End;
  360.  
  361. If  (S_Ctrl)         And
  362.     (Not KeyPressed) Then
  363.     Begin
  364.     S_Fkey := True;
  365.     Case S_Ch_Num of
  366.       1..26 : Begin
  367.               S_Ch_Num := S_Ch_Num + 64;
  368.               Exit;
  369.               End;
  370.       27.. 31: Begin
  371.                Case S_Ch_Num of
  372.                  27 : S_Ch := '[';
  373.                  28 : S_Ch := '\';
  374.                  29 : S_Ch := ']';
  375.                  30 : S_Ch := '6';
  376.                  31 : S_Ch := '-';
  377.                  End;{Case of}
  378.                Exit;
  379.                End;
  380.       127    : Begin
  381.                S_BkSp      := True;
  382.                S_Ch_Num    := 0;
  383.                Exit;
  384.                End;
  385.       End;{Case}
  386.     S_Fkey := False;
  387.     End;
  388.  
  389. If  S_Ch_Num = 27 Then
  390.     Begin
  391.     If  KeyPressed Then
  392.         Begin
  393.         Read(Kbd,S_Ch);
  394.         S_Fkey := True;
  395.  
  396.         Case S_Ch_Num of
  397.             59,84,94,104   : S_F1   := True;
  398.             60,85,95,105   : S_F2   := True;
  399.             61,86,96,106   : S_F3   := True;
  400.             62,87,97,107   : S_F4   := True;
  401.             63,88,98,108   : S_F5   := True;
  402.             64,89,99,109   : S_F6   := True;
  403.             65,90,100,110  : S_F7   := True;
  404.             66,91,101,111  : S_F8   := True;
  405.             67,92,102,112  : S_F9   := True;
  406.             68,93,103,113  : S_F10  := True;
  407.             115, 178       : S_Left  := True;
  408.             116, 180       : S_Right := True;
  409.             160, 175, 72   : S_Up    := True;
  410.             164, 183, 80   : S_Down  := True;
  411.             119, 174, 71   : S_Home  := True;
  412.             117, 182, 79   : S_End   := True;
  413.             132, 176, 73   : S_PgUp  := True;
  414.             118, 184, 81   : S_PgDn  := True;
  415.             165, 185       : S_Ins   := True;
  416.             166, 186       : S_Del   := True;
  417.                       82   : Begin
  418.                              S_Ins       := True;
  419.                              S_InsertKey := True;
  420.                              S_Fkey      := False;
  421.                              End;
  422.                       83   : Begin
  423.                              S_Del       := True;
  424.                              S_DeleteKey := True;
  425.                              S_Fkey      := False;
  426.                              End;
  427.                       75   : Begin
  428.                              S_Left       := True;
  429.                              S_LeftArrow  := True;
  430.                              S_Fkey       := False;
  431.                              End;
  432.                       77   : Begin
  433.                              S_Right      := True;
  434.                              S_RightArrow := True;
  435.                              S_Fkey       := False;
  436.                              End;
  437.         End;{Case of}
  438.         Case S_Ch_Num Of
  439.              3  : S_Ch    := '2';
  440.             30  : S_Ch    := 'A';
  441.             48  : S_Ch    := 'B';
  442.             46  : S_Ch    := 'C';
  443.             32  : S_Ch    := 'D';
  444.             18  : S_Ch    := 'E';
  445.             33  : S_Ch    := 'F';
  446.             34  : S_Ch    := 'G';
  447.             35  : S_Ch    := 'H';
  448.             23  : S_Ch    := 'I';
  449.             36  : S_Ch    := 'J';
  450.             37  : S_Ch    := 'K';
  451.             38  : S_Ch    := 'L';
  452.             50  : S_Ch    := 'M';
  453.             49  : S_Ch    := 'N';
  454.             24  : S_Ch    := 'O';
  455.             25  : S_Ch    := 'P';
  456.             16  : S_Ch    := 'Q';
  457.             19  : S_Ch    := 'R';
  458.             31  : S_Ch    := 'S';
  459.             20  : S_Ch    := 'T';
  460.             22  : S_Ch    := 'U';
  461.             47  : S_Ch    := 'V';
  462.             17  : S_Ch    := 'W';
  463.             45  : S_Ch    := 'X';
  464.             21  : S_Ch    := 'Y';
  465.             44  : S_Ch    := 'Z';
  466.             114 : S_Ch    := '*';
  467.             120 : S_Ch    := '1';
  468.             121 : S_Ch    := '2';
  469.             122 : S_Ch    := '3';
  470.             123 : S_Ch    := '4';
  471.             124 : S_Ch    := '5';
  472.             125 : S_Ch    := '6';
  473.             126 : S_Ch    := '7';
  474.             127 : S_Ch    := '8';
  475.             128 : S_Ch    := '9';
  476.             129 : S_Ch    := '0';
  477.             130 : S_Ch    := '-';
  478.             131 : S_Ch    := '=';
  479.         Else
  480.             S_Ch_Num := 0;
  481.         End;{Case of}
  482.         End
  483.     Else
  484.         Begin
  485.         S_Fkey := True;
  486.         S_Esc  := True;
  487.         End;
  488.     End;
  489.  
  490. Case S_Ch_Num of
  491.     8      : Begin
  492.              S_BackSpace := True;
  493.              S_BkSp      := True;
  494.              S_Ch_Num    := 0;
  495.              Exit;
  496.              End;
  497.     9      : Begin
  498.              S_Tab       := True;
  499.              S_Ch_Num    := 0;
  500.              Exit;
  501.              End;
  502.     13     : Begin
  503.              S_Enter     := True;
  504.              S_Ch_Num    := 0;
  505.              Exit;
  506.              End;
  507. End;{Case of};
  508. End;
  509.  
  510.  
  511.  
  512.  
  513.  
  514. Procedure S_Write;
  515. Var Pointer:integer;
  516. Begin
  517. For Pointer := 1 to lgth do
  518.     Begin
  519.     S_Record^.S_WorkArray[Pointer,1] := Chr(Ord(Lines[Pointer]));
  520.     S_Record^.S_WorkArray[Pointer,2] := Chr(Ord(Attribs[Pointer]));
  521.     End;
  522. S_PutScrMem(S_Record^.S_WorkArray[1,1],
  523.     Mem[S_Seg:S_Ofs + ((Row-1)*S_LineSize) + ((Col-1)*2)],Lgth * 2);
  524. End;
  525.  
  526.  
  527.  
  528. Procedure S_DisplayMessage;
  529. Begin
  530. FillChar(S_WorkAttrib,81,02);
  531. FillChar(S_Padding,81,32);
  532. S_WorkAttrib[0] := #80;
  533. S_Padding[0]    := #80;
  534. Move(Message[1],S_Padding[(80-Length(Message)) Div 2],Length(Message));
  535. FillChar(S_WorkAttrib[(80-Length(Message)) Div 2],Length(Message),(BackG * 16) + ForG);
  536. If  Message > '' Then
  537.     S_Beep(S_Freq,S_Dur);
  538. S_Write(25,1,80,S_Padding,S_WorkAttrib);
  539. End;
  540.  
  541.  
  542.  
  543.  
  544. Procedure S_PutScrMem;
  545. Begin
  546.   If  S_Mono Then
  547.       Move(Source,Dest,Len)
  548.   Else
  549.       Begin
  550.       Len := Len shr 1;
  551.       Inline($1E/$55/$BA/$DA/$03/$C5/$B6/Source/$C4/$BE/Dest/$8B/$8E/
  552.          Len/$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/$72/$FB/$FA/$EC/
  553.          $20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/$EA/$5D/$1F);
  554.       End;
  555. End;
  556.  
  557.  
  558.  
  559. Procedure S_GetScrMem;
  560. Begin
  561.   If  S_Mono Then
  562.       Move(Source,Dest,Len)
  563.   Else
  564.       Begin
  565.       Len := Len shr 1;
  566.       Inline($1E/$55/$BA/$DA/$03/$C5/$B6/Source/$C4/$BE/Dest/$8B/$8E/
  567.          Len/$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/$D8/$73/$FB/$AD/
  568.          $FB/$AB/$E2/$F0/$5D/$1F);
  569.       End;
  570. End;
  571.  
  572.  
  573.  
  574. Procedure S_Beep;
  575. Begin
  576. If  S_Sound = True Then
  577.     Begin
  578.     Sound(Freq);
  579.     Delay(Dur);
  580.     NoSound;
  581.     End;
  582. End;
  583.  
  584. Procedure S_AllocateMemory;
  585. Begin
  586. If  MaxAvail > 1250 Then
  587.     Begin
  588.     GetMem(S_Indx,SizeOf(S_Indx^));
  589.     GetMem(S_Record,SizeOf(S_Indx^));
  590.     GetMem(S_Field,SizeOf(S_Indx^));
  591.     GetMem(S_FieldPtr,SizeOf(S_FieldPtr^));
  592.     GetMem(S_BuffPtr,SizeOf(S_BuffPtr^));
  593.     End
  594. Else
  595.     Begin
  596.     S_Msg := 'Not enough free Memory!';
  597.     S_DisplayMessage(S_MessBg,S_MessFg,S_Msg);
  598.     Halt;
  599.     End;
  600. S_CursorOld    := 1543;
  601. S_SetCursor(S_GetCursor);
  602. End;
  603.