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