home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / turbo55 / tp55 / forms.pas < prev    next >
Pascal/Delphi Source File  |  1989-05-02  |  11KB  |  571 lines
  1.  
  2. { Turbo Forms }
  3. { Copyright (c) 1989 by Borland International, Inc. }
  4.  
  5. unit Forms;
  6. { Turbo Pascal 5.5 object-oriented example.
  7.   This unit defines field- and form-editing object types.
  8.   Refer to OOPDEMOS.DOC for an overview of this unit.
  9. }
  10.  
  11. {$S-}
  12.  
  13. interface
  14.  
  15. uses Objects;
  16.  
  17. const
  18.  
  19.   CSkip  = ^@;
  20.   CHome  = ^A;
  21.   CRight = ^D;
  22.   CPrev  = ^E;
  23.   CEnd   = ^F;
  24.   CDel   = ^G;
  25.   CBack  = ^H;
  26.   CSave  = ^J;
  27.   CEnter = ^M;
  28.   CUndo  = ^R;
  29.   CLeft  = ^S;
  30.   CIns   = ^V;
  31.   CNext  = ^X;
  32.   CClear = ^Y;
  33.   CEsc   = ^[;
  34.  
  35. type
  36.  
  37.   FStringPtr = ^FString;
  38.   FString = string[79];
  39.  
  40.   FieldPtr = ^Field;
  41.   Field = object(Node)
  42.     X, Y, Size: Integer;
  43.     Title: FStringPtr;
  44.     Value: Pointer;
  45.     Extra: record end;
  46.     constructor Init(PX, PY, PSize: Integer; PTitle: FString);
  47.     constructor Load(var S: Stream);
  48.     destructor Done; virtual;
  49.     procedure Clear; virtual;
  50.     function Edit: Char; virtual;
  51.     procedure Show; virtual;
  52.     procedure Store(var S: Stream);
  53.   end;
  54.  
  55.   FTextPtr = ^FText;
  56.   FText = object(Field)
  57.     Len: Integer;
  58.     constructor Init(PX, PY, PSize: Integer; PTitle: FString;
  59.       PLen: Integer);
  60.     function Edit: Char; virtual;
  61.     procedure GetStr(var S: FString); virtual;
  62.     function PutStr(var S: FString): Boolean; virtual;
  63.     procedure Show; virtual;
  64.   end;
  65.  
  66.   FStrPtr = ^FStr;
  67.   FStr = object(FText)
  68.     constructor Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
  69.     procedure GetStr(var S: FString); virtual;
  70.     function PutStr(var S: FString): Boolean; virtual;
  71.   end;
  72.  
  73.   FNumPtr = ^FNum;
  74.   FNum = object(FText)
  75.     procedure Show; virtual;
  76.   end;
  77.  
  78.   FIntPtr = ^FInt;
  79.   FInt = object(FNum)
  80.     Min, Max: Longint;
  81.     constructor Init(PX, PY: Integer; PTitle: FString;
  82.       PMin, PMax: Longint);
  83.     procedure GetStr(var S: FString); virtual;
  84.     function PutStr(var S: FString): Boolean; virtual;
  85.   end;
  86.  
  87.   FZipPtr = ^FZip;
  88.   FZip = object(FInt)
  89.     constructor Init(PX, PY: Integer; PTitle: FString);
  90.     procedure GetStr(var S: FString); virtual;
  91.     function PutStr(var S: FString): Boolean; virtual;
  92.   end;
  93.  
  94.   FRealPtr = ^FReal;
  95.   FReal = object(FNum)
  96.     Decimals: Integer;
  97.     constructor Init(PX, PY: Integer; PTitle: FString;
  98.       PLen, PDecimals: Integer);
  99.     procedure GetStr(var S: FString); virtual;
  100.     function PutStr(var S: FString): Boolean; virtual;
  101.   end;
  102.  
  103.   FormPtr = ^Form;
  104.   Form = object(Base)
  105.     X1, Y1, X2, Y2, Size: Integer;
  106.     Fields: List;
  107.     constructor Init(PX1, PY1, PX2, PY2: Integer);
  108.     constructor Load(var S: Stream);
  109.     destructor Done; virtual;
  110.     function Edit: Char;
  111.     procedure Show(Erase: Boolean);
  112.     procedure Add(P: FieldPtr);
  113.     procedure Clear;
  114.     procedure Get(var FormBuf);
  115.     procedure Put(var FormBuf);
  116.     procedure Store(var S: Stream);
  117.   end;
  118.  
  119.   FStream = object(BufStream)
  120.     procedure RegisterTypes; virtual;
  121.   end;
  122.  
  123.   ColorIndex = (BackColor, ForeColor, TitleColor, ValueColor);
  124.  
  125. procedure Beep;
  126. procedure Color(C: ColorIndex);
  127. function ReadChar: Char;
  128.  
  129. implementation
  130.  
  131. uses Crt;
  132.  
  133. type
  134.   Bytes = array[0..32767] of Byte;
  135.  
  136. { Field }
  137.  
  138. constructor Field.Init(PX, PY, PSize: Integer; PTitle: FString);
  139. begin
  140.   X := PX;
  141.   Y := PY;
  142.   Size := PSize;
  143.   GetMem(Title, Length(PTitle) + 1);
  144.   Title^ := PTitle;
  145.   GetMem(Value, Size);
  146. end;
  147.  
  148. constructor Field.Load(var S: Stream);
  149. var
  150.   L: Byte;
  151. begin
  152.   S.Read(X, SizeOf(Integer) * 3);
  153.   S.Read(L, SizeOf(Byte));
  154.   GetMem(Title, L + 1);
  155.   Title^[0] := Chr(L);
  156.   S.Read(Title^[1], L);
  157.   GetMem(Value, Size);
  158.   S.Read(Extra, SizeOf(Self) - SizeOf(Field));
  159. end;
  160.  
  161. destructor Field.Done;
  162. begin
  163.   FreeMem(Value, Size);
  164.   FreeMem(Title, Length(Title^) + 1);
  165. end;
  166.  
  167. procedure Field.Clear;
  168. begin
  169.   FillChar(Value^, Size, 0);
  170. end;
  171.  
  172. function Field.Edit: Char;
  173. begin
  174.   Abstract;
  175. end;
  176.  
  177. procedure Field.Show;
  178. begin
  179.   Abstract;
  180. end;
  181.  
  182. procedure Field.Store(var S: Stream);
  183. begin
  184.   S.Write(X, SizeOf(Integer) * 3);
  185.   S.Write(Title^, Length(Title^) + 1);
  186.   S.Write(Extra, SizeOf(Self) - SizeOf(Field));
  187. end;
  188.  
  189. { FText }
  190.  
  191. constructor FText.Init(PX, PY, PSize: Integer; PTitle: FString;
  192.   PLen: Integer);
  193. begin
  194.   Field.Init(PX, PY, PSize, PTitle);
  195.   Len := PLen;
  196. end;
  197.  
  198. function FText.Edit: Char;
  199. var
  200.   P: Integer;
  201.   Ch: Char;
  202.   Start, Stop: Boolean;
  203.   S: FString;
  204. begin
  205.   P := 0;
  206.   Start := True;
  207.   Stop := False;
  208.   GetStr(S);
  209.   repeat
  210.     GotoXY(X, Y);
  211.     Color(TitleColor);
  212.     Write(Title^);
  213.     Color(ValueColor);
  214.     Write(S, '': Len - Length(S));
  215.     GotoXY(X + Length(Title^) + P, Y);
  216.     Ch := ReadChar;
  217.     case Ch of
  218.       #32..#255:
  219.         begin
  220.           if Start then S := '';
  221.           if Length(S) < Len then
  222.           begin
  223.             Inc(P);
  224.             Insert(Ch, S, P);
  225.           end;
  226.         end;
  227.       CLeft: if P > 0 then Dec(P);
  228.       CRight: if P < Length(S) then Inc(P) else;
  229.       CHome: P := 0;
  230.       CEnd: P := Length(S);
  231.       CDel: Delete(S, P + 1, 1);
  232.       CBack:
  233.         if P > 0 then
  234.         begin
  235.           Delete(S, P, 1);
  236.           Dec(P);
  237.         end;
  238.       CClear:
  239.         begin
  240.           S := '';
  241.           P := 0;
  242.         end;
  243.       CUndo:
  244.         begin
  245.           GetStr(S);
  246.           P := 0;
  247.         end;
  248.       CEnter, CNext, CPrev, CSave:
  249.         if PutStr(S) then
  250.         begin
  251.           Show;
  252.           Stop := True;
  253.         end else
  254.         begin
  255.           Beep;
  256.           P := 0;
  257.         end;
  258.       CEsc: Stop := True;
  259.     else
  260.       Beep;
  261.     end;
  262.     Start := False;
  263.   until Stop;
  264.   Edit := Ch;
  265. end;
  266.  
  267. procedure FText.GetStr(var S: FString);
  268. begin
  269.   Abstract;
  270. end;
  271.  
  272. function FText.PutStr(var S: FString): Boolean;
  273. begin
  274.   Abstract;
  275. end;
  276.  
  277. procedure FText.Show;
  278. var
  279.   S: FString;
  280. begin
  281.   GetStr(S);
  282.   GotoXY(X, Y);
  283.   Color(TitleColor);
  284.   Write(Title^);
  285.   Color(ValueColor);
  286.   Write(S, '': Len - Length(S));
  287. end;
  288.  
  289. { FStr }
  290.  
  291. constructor FStr.Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
  292. begin
  293.   FText.Init(PX, PY, PLen + 1, PTitle, PLen);
  294. end;
  295.  
  296. procedure FStr.GetStr(var S: FString);
  297. begin
  298.   S := FString(Value^);
  299. end;
  300.  
  301. function FStr.PutStr(var S: FString): Boolean;
  302. begin
  303.   FString(Value^) := S;
  304.   PutStr := True;
  305. end;
  306.  
  307. { FNum }
  308.  
  309. procedure FNum.Show;
  310. var
  311.   S: FString;
  312. begin
  313.   GetStr(S);
  314.   GotoXY(X, Y);
  315.   Color(TitleColor);
  316.   Write(Title^);
  317.   Color(ValueColor);
  318.   Write(S: Len);
  319. end;
  320.  
  321. { FInt }
  322.  
  323. constructor FInt.Init(PX, PY: Integer; PTitle: FString;
  324.   PMin, PMax: Longint);
  325. var
  326.   L: Integer;
  327.   S: string[15];
  328. begin
  329.   Str(PMin, S); L := Length(S);
  330.   Str(PMax, S); if L < Length(S) then L := Length(S);
  331.   FNum.Init(PX, PY, SizeOf(Longint), PTitle, L);
  332.   Min := PMin;
  333.   Max := PMax;
  334. end;
  335.  
  336. procedure FInt.GetStr(var S: FString);
  337. begin
  338.   Str(Longint(Value^), S);
  339. end;
  340.  
  341. function FInt.PutStr(var S: FString): Boolean;
  342. var
  343.   N: Longint;
  344.   E: Integer;
  345. begin
  346.   Val(S, N, E);
  347.   if (E = 0) and (N >= Min) and (N <= Max) then
  348.   begin
  349.     Longint(Value^) := N;
  350.     PutStr := True;
  351.   end else PutStr := False;
  352. end;
  353.  
  354. { FZip }
  355.  
  356. constructor FZip.Init(PX, PY: Integer; PTitle: FString);
  357. begin
  358.   FInt.Init(PX, PY, PTitle, 0, 99999);
  359. end;
  360.  
  361. procedure FZip.GetStr(var S: FString);
  362. begin
  363.   FInt.GetStr(S);
  364.   Insert(Copy('0000', 1, 5 - Length(S)), S, 1);
  365. end;
  366.  
  367. function FZip.PutStr(var S: FString): Boolean;
  368. begin
  369.   PutStr := (Length(S) = 5) and FInt.PutStr(S);
  370. end;
  371.  
  372. { FReal }
  373.  
  374. constructor FReal.Init(PX, PY: Integer; PTitle: FString;
  375.   PLen, PDecimals: Integer);
  376. begin
  377.   FNum.Init(PX, PY, SizeOf(Real), PTitle, PLen);
  378.   Decimals := PDecimals;
  379. end;
  380.  
  381. procedure FReal.GetStr(var S: FString);
  382. begin
  383.   Str(Real(Value^): 0: Decimals, S);
  384. end;
  385.  
  386. function FReal.PutStr(var S: FString): Boolean;
  387. var
  388.   R: Real;
  389.   E: Integer;
  390.   T: FString;
  391. begin
  392.   Val(S, R, E);
  393.   PutStr := False;
  394.   if E = 0 then
  395.   begin
  396.     Str(R: 0: Decimals, T);
  397.     if Length(T) <= Len then
  398.     begin
  399.       Real(Value^) := R;
  400.       PutStr := True;
  401.     end;
  402.   end;
  403. end;
  404.  
  405. { Form }
  406.  
  407. constructor Form.Init(PX1, PY1, PX2, PY2: Integer);
  408. begin
  409.   X1 := PX1;
  410.   Y1 := PY1;
  411.   X2 := PX2;
  412.   Y2 := PY2;
  413.   Size := 0;
  414.   Fields.Clear;
  415. end;
  416.  
  417. constructor Form.Load(var S: Stream);
  418. begin
  419.   S.Read(X1, SizeOf(Integer) * 5);
  420.   Fields.Load(S);
  421. end;
  422.  
  423. destructor Form.Done;
  424. begin
  425.   Fields.Delete;
  426. end;
  427.  
  428. function Form.Edit: Char;
  429. var
  430.   P: FieldPtr;
  431.   Ch: Char;
  432. begin
  433.   Window(X1, Y1, X2, Y2);
  434.   P := FieldPtr(Fields.First);
  435.   repeat
  436.     Ch := P^.Edit;
  437.     case Ch of
  438.       CEnter, CNext: P := FieldPtr(P^.Next);
  439.       CPrev: P := FieldPtr(P^.Prev);
  440.     end;
  441.   until (Ch = CSave) or (Ch = CEsc);
  442.   Edit := Ch;
  443.   Window(1, 1, 80, 25);
  444. end;
  445.  
  446. procedure Form.Show(Erase: Boolean);
  447. var
  448.   P: FieldPtr;
  449. begin
  450.   Window(X1, Y1, X2, Y2);
  451.   if Erase then
  452.   begin
  453.     Color(ForeColor);
  454.     ClrScr;
  455.   end;
  456.   P := FieldPtr(Fields.First);
  457.   while P <> nil do
  458.   begin
  459.     P^.Show;
  460.     P := FieldPtr(Fields.Next(P));
  461.   end;
  462.   Window(1, 1, 80, 25);
  463. end;
  464.  
  465. procedure Form.Add(P: FieldPtr);
  466. begin
  467.   Inc(Size, P^.Size);
  468.   Fields.Append(P);
  469. end;
  470.  
  471. procedure Form.Clear;
  472. var
  473.   P: FieldPtr;
  474. begin
  475.   P := FieldPtr(Fields.First);
  476.   while P <> nil do
  477.   begin
  478.     P^.Clear;
  479.     P := FieldPtr(Fields.Next(P));
  480.   end;
  481. end;
  482.  
  483. procedure Form.Get(var FormBuf);
  484. var
  485.   I: Integer;
  486.   P: FieldPtr;
  487. begin
  488.   I := 0;
  489.   P := FieldPtr(Fields.First);
  490.   while P <> nil do
  491.   begin
  492.     Move(P^.Value^, Bytes(FormBuf)[I], P^.Size);
  493.     Inc(I, P^.Size);
  494.     P := FieldPtr(Fields.Next(P));
  495.   end;
  496. end;
  497.  
  498. procedure Form.Put(var FormBuf);
  499. var
  500.   I: Integer;
  501.   P: FieldPtr;
  502. begin
  503.   I := 0;
  504.   P := FieldPtr(Fields.First);
  505.   while P <> nil do
  506.   begin
  507.     Move(Bytes(FormBuf)[I], P^.Value^, P^.Size);
  508.     Inc(I, P^.Size);
  509.     P := FieldPtr(Fields.Next(P));
  510.   end;
  511. end;
  512.  
  513. procedure Form.Store(var S: Stream);
  514. begin
  515.   S.Write(X1, SizeOf(Integer) * 5);
  516.   Fields.Store(S);
  517. end;
  518.  
  519. { FStream }
  520.  
  521. procedure FStream.RegisterTypes;
  522. begin
  523.   BufStream.RegisterTypes;
  524.   Register(TypeOf(FStr), @FStr.Store, @FStr.Load);
  525.   Register(TypeOf(FInt), @FInt.Store, @FInt.Load);
  526.   Register(TypeOf(FZip), @FZip.Store, @FZip.Load);
  527.   Register(TypeOf(FReal), @FReal.Store, @FReal.Load);
  528. end;
  529.  
  530. { Global routines }
  531.  
  532. procedure Beep;
  533. begin
  534.   Sound(500); Delay(25); NoSound;
  535. end;
  536.  
  537. procedure Color(C: ColorIndex);
  538. type
  539.   Palette = array[ColorIndex] of Byte;
  540. const
  541.   CP: Palette = ($17, $70, $30, $5E);
  542.   MP: Palette = ($07, $70, $70, $07);
  543. begin
  544.   if LastMode = CO80 then TextAttr := CP[C] else TextAttr := MP[C];
  545. end;
  546.  
  547. function ReadChar: Char;
  548. var
  549.   Ch: Char;
  550. begin
  551.   Ch := ReadKey;
  552.   case Ch of
  553.     #0:
  554.       case ReadKey of
  555.         #15, #72: Ch := CPrev;    { Shift-Tab, Up }
  556.         #60: Ch := CSave;         { F2 }
  557.         #71: Ch := CHome;         { Home }
  558.         #75: Ch := CLeft;         { Left }
  559.         #77: Ch := CRight;        { Right }
  560.         #79: Ch := CEnd;          { End }
  561.         #80: Ch := CNext;         { Down }
  562.         #82: Ch := CIns;          { Ins }
  563.         #83: Ch := CDel;          { Del }
  564.       end;
  565.     #9: Ch := CNext;              { Tab }
  566.   end;
  567.   ReadChar := Ch;
  568. end;
  569.  
  570. end.
  571.