Power-Programmierung/CD1.mdf/magazine/drdobbs/1989/07/floyd.lst

File List | 1989-06-01 | 13KB | 664 lines

_TURBO PASCAL WITH OBJECTS_
by Michael Floyd

[LISTING ONE]


program FDemo;

uses Crt, Forms, Sliders;

type

  Person = record
    Firstname: string[30];
    Lastname: string[30];
    Address: string[32];
    City: string[16];
    State: string[2];
    Zipcode: Longint;
    Counter: array[1..3] of Longint;
    Slider: array[1..2] of Integer;
  end;

const

  Frank: Person = (
    Firstname: 'Frank';
    Lastname: 'Borland';
    Address: '1800 Green Hills Road';
    City: 'Scotts Valley';
    State: 'CA';
    Zipcode: 95066;
    Counter: (10, 1000, 65536);
    Slider: (85, 25));

var
  F: Form;
  P: Person;

begin
  Color(BackColor);
  ClrScr;
  Color(ForeColor);
  GotoXY(1, 1); ClrEol;
  Write(' Turbo Pascal 5.5 Object Oriented Forms Editor');
  GotoXY(1, 25); ClrEol;
  Write(' F2-Save  Esc-Quit');
  F.Init(10, 5, 54, 16);
  F.Add(New(FStrPtr, Init(3, 2, ' Firstname ', 30)));
  F.Add(New(FStrPtr, Init(3, 3, ' Lastname  ', 30)));
  F.Add(New(FStrPtr, Init(3, 5, ' Address ', 32)));
  F.Add(New(FStrPtr, Init(3, 6, ' City ', 16)));
  F.Add(New(FStrPtr, Init(25, 6, ' State ', 2)));
  F.Add(New(FZipPtr, Init(34, 6, ' Zip ')));
  F.Add(New(FIntPtr, Init(3, 8, ' Counter 1 ', 0, 99999999)));
  F.Add(New(FIntPtr, Init(22, 8, ' 2 ', 0, 99999999)));
  F.Add(New(FIntPtr, Init(33, 8, ' 3 ', 0, 99999999)));
  F.Add(New(FSliderPtr, Init(3, 10, ' Slider One ', 0, 100, 5)));
  F.Add(New(FSliderPtr, Init(3, 11, ' Slider Two ', 0, 100, 5)));
  P := Frank;
  F.Put(P);
  F.Show;
  if F.Edit = CSave then F.Get(P);
  F.Done;
  NormVideo;
  ClrScr;
  WriteLn('Resulting Person record:');
  WriteLn;
  with P do
  begin
    WriteLn('Firstname: ', Firstname);
    WriteLn(' Lastname: ', Lastname);
    WriteLn('  Address: ', Address);
    WriteLn('     City: ', City);
    WriteLn('    State: ', State);
    WriteLn('  Zipcode: ', Zipcode);
    WriteLn(' Counters: ', Counter[1], ' ', Counter[2], ' ', Counter[3]);
    WriteLn('  Sliders: ', Slider[1], ' ', Slider[2]);
  end;
end.


[LISTING TWO]

unit Forms;

{$S-}

interface

uses Crt;

const

  CSkip  = ^@;
  CHome  = ^A;
  CRight = ^D;
  CPrev  = ^E;
  CEnd   = ^F;
  CDel   = ^G;
  CBack  = ^H;
  CSave  = ^J;
  CUndo  = ^R;
  CLeft  = ^S;
  CClear = ^Y;
  CNext  = ^X;
  CQuit  = ^[;

type

  FStringPtr = ^FString;
  FString = string[79];

  FieldPtr = ^Field;
  Field = object
    Next: FieldPtr;
    X, Y, Size: Integer;
    Title: FStringPtr;
    Value: Pointer;
    constructor Init(PX, PY, PSize: Integer; PTitle: FString);
    destructor Done; virtual;
    procedure Beep; virtual;
    function Edit: Char; virtual;
    function ReadChar: Char; virtual;
    procedure Show; virtual;
    function Prev: FieldPtr;
  end;

  FTextPtr = ^FText;
  FText = object(Field)
    Len: Integer;
    constructor Init(PX, PY, PSize: Integer; PTitle: FString;
      PLen: Integer);
    function Edit: Char; virtual;
    procedure GetStr(var S: FString); virtual;
    function PutStr(var S: FString): Boolean; virtual;
    procedure Show; virtual;
    procedure Display(var S: FString);
  end;

  FStrPtr = ^FStr;
  FStr = object(FText)
    constructor Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
    procedure GetStr(var S: FString); virtual;
    function PutStr(var S: FString): Boolean; virtual;
  end;

  FIntPtr = ^FInt;
  FInt = object(FText)
    Min, Max: Longint;
    constructor Init(PX, PY: Integer; PTitle: FString;
      PMin, PMax: Longint);
    procedure GetStr(var S: FString); virtual;
    function PutStr(var S: FString): Boolean; virtual;
  end;

  FZipPtr = ^FZip;
  FZip = object(FInt)
    constructor Init(PX, PY: Integer; PTitle: FString);
    procedure GetStr(var S: FString); virtual;
    function PutStr(var S: FString): Boolean; virtual;
  end;

  FormPtr = ^Form;
  Form = object
    X1, Y1, X2, Y2: Integer;
    Last: FieldPtr;
    constructor Init(PX1, PY1, PX2, PY2: Integer);
    destructor Done; virtual;
    function Edit: Char; virtual;
    procedure Show; virtual;
    procedure Add(P: FieldPtr);
    function First: FieldPtr;
    procedure Get(var FormBuf);
    procedure Put(var FormBuf);
  end;

  ColorIndex = (BackColor, ForeColor, TitleColor, ValueColor);

procedure Color(C: ColorIndex);

implementation

type

  Bytes = array[0..32767] of Byte;

procedure Abstract(Method: String);
begin
  WriteLn('Error: Call to abstract method ', Method);
  Halt(1);
end;

{ Field }

constructor Field.Init(PX, PY, PSize: Integer; PTitle: FString);
begin
  X := PX;
  Y := PY;
  Size := PSize;
  GetMem(Title, Length(PTitle) + 1);
  Title^ := PTitle;
  GetMem(Value, Size);
  FillChar(Value^, Size, 0);
end;

destructor Field.Done;
begin
  FreeMem(Value, Size);
  FreeMem(Title, Length(Title^) + 1);
end;

procedure Field.Beep;
begin
  Sound(500); Delay(25); NoSound;
end;

function Field.Edit: Char;
begin
  Abstract('Field.Edit');
end;

function Field.ReadChar: Char;
var
  Ch: Char;
begin
  Ch := ReadKey;
  case Ch of
    #0:
      case ReadKey of
        #15, #72: Ch := CPrev;    { Shift-Tab, Up }
        #60: Ch := CSave;         { F2 }
        #71: Ch := CHome;         { Home }
        #75: Ch := CLeft;         { Left }
        #77: Ch := CRight;        { Right }
        #79: Ch := CEnd;          { End }
        #80: Ch := CNext;         { Down }
        #83: Ch := CDel;          { Del }
      else
        Ch := CSkip;
      end;
    #9, #13: Ch := CNext;         { Tab, Enter }
  end;
  ReadChar := Ch;
end;

procedure Field.Show;
begin
  Abstract('Field.Show');
end;

function Field.Prev: FieldPtr;
var
  P: FieldPtr;
begin
  P := @Self;
  while P^.Next <> @Self do P := P^.Next;
  Prev := P;
end;

{ FText }

constructor FText.Init(PX, PY, PSize: Integer; PTitle: FString;
  PLen: Integer);
begin
  Field.Init(PX, PY, PSize, PTitle);
  Len := PLen;
end;

function FText.Edit: Char;
var
  P: Integer;
  Ch: Char;
  Start, Stop: Boolean;
  S: FString;
begin
  P := 0;
  Start := True;
  Stop := False;
  GetStr(S);
  repeat
    Display(S);
    GotoXY(X + Length(Title^) + P, Y);
    Ch := ReadChar;
    case Ch of
      #32..#255:
        begin
          if Start then S := '';
          if Length(S) < Len then
          begin
            Inc(P);
            Insert(Ch, S, P);
          end;
        end;
      CLeft: if P > 0 then Dec(P);
      CRight: if P < Length(S) then Inc(P) else;
      CHome: P := 0;
      CEnd: P := Length(S);
      CDel: Delete(S, P + 1, 1);
      CBack:
        if P > 0 then
        begin
          Delete(S, P, 1);
          Dec(P);
        end;
      CClear:
        begin
          S := '';
          P := 0;
        end;
      CUndo:
        begin
          GetStr(S);
          P := 0;
        end;
      CSave, CNext, CPrev:
        if PutStr(S) then
        begin
          Show;
          Stop := True;
        end else
        begin
          Beep;
          P := 0;
        end;
      CQuit: Stop := True;
    else
      Beep;
    end;
    Start := False;
  until Stop;
  Edit := Ch;
end;

procedure FText.GetStr(var S: FString);
begin
  Abstract('FText.GetStr');
end;

function FText.PutStr(var S: FString): Boolean;
begin
  Abstract('FText.PutStr');
end;

procedure FText.Show;
var
  S: FString;
begin
  GetStr(S);
  Display(S);
end;

procedure FText.Display(var S: FString);
begin
  GotoXY(X, Y);
  Color(TitleColor);
  Write(Title^);
  Color(ValueColor);
  Write(S, '': Len - Length(S));
end;

{ FStr }

constructor FStr.Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
begin
  FText.Init(PX, PY, PLen + 1, PTitle, PLen);
end;

procedure FStr.GetStr(var S: FString);
begin
  S := FString(Value^);
end;

function FStr.PutStr(var S: FString): Boolean;
begin
  FString(Value^) := S;
  PutStr := True;
end;

{ FInt }

constructor FInt.Init(PX, PY: Integer; PTitle: FString;
  PMin, PMax: Longint);
var
  L: Integer;
  S: string[15];
begin
  Str(PMin, S); L := Length(S);
  Str(PMax, S); if L < Length(S) then L := Length(S);
  FText.Init(PX, PY, 4, PTitle, L);
  Min := PMin;
  Max := PMax;
end;

procedure FInt.GetStr(var S: FString);
begin
  Str(Longint(Value^), S);
end;

function FInt.PutStr(var S: FString): Boolean;
var
  N: Longint;
  E: Integer;
begin
  Val(S, N, E);
  if (E = 0) and (N >= Min) and (N <= Max) then
  begin
    Longint(Value^) := N;
    PutStr := True;
  end else PutStr := False;
end;

{ FZip }

constructor FZip.Init(PX, PY: Integer; PTitle: FString);
begin
  FInt.Init(PX, PY, PTitle, 0, 99999);
end;

procedure FZip.GetStr(var S: FString);
begin
  FInt.GetStr(S);
  Insert(Copy('0000', 1, 5 - Length(S)), S, 1);
end;

function FZip.PutStr(var S: FString): Boolean;
begin
  PutStr := (Length(S) = 5) and FInt.PutStr(S);
end;

{ Form }

constructor Form.Init(PX1, PY1, PX2, PY2: Integer);
begin
  X1 := PX1;
  Y1 := PY1;
  X2 := PX2;
  Y2 := PY2;
  Last := nil;
end;

destructor Form.Done;
var
  P: FieldPtr;
begin
  while Last <> nil do
  begin
    P := Last^.Next;
    if Last = P then Last := nil else Last^.Next := P^.Next;
    Dispose(P, Done);
  end;
end;

function Form.Edit: Char;
var
  P: FieldPtr;
  Ch: Char;
begin
  Window(X1, Y1, X2, Y2);
  P := First;
  repeat
    Ch := P^.Edit;
    case Ch of
      CNext: P := P^.Next;
      CPrev: P := P^.Prev;
    end;
  until (Ch = CSave) or (Ch = CQuit);
  Edit := Ch;
  Window(1, 1, 80, 25);
end;

procedure Form.Show;
var
  P: FieldPtr;
begin
  Window(X1, Y1, X2, Y2);
  Color(ForeColor);
  ClrScr;
  P := First;
  repeat
    P^.Show;
    P := P^.Next;
  until P = First;
  Window(1, 1, 80, 25);
end;

procedure Form.Add(P: FieldPtr);
begin
  if Last = nil then Last := P else P^.Next := Last^.Next;
  Last^.Next := P;
  Last := P;
end;

function Form.First: FieldPtr;
begin
  First := Last^.Next;
end;

procedure Form.Get(var FormBuf);
var
  I: Integer;
  P: FieldPtr;
begin
  I := 0;
  P := First;
  repeat
    Move(P^.Value^, Bytes(FormBuf)[I], P^.Size);
    Inc(I, P^.Size);
    P := P^.Next;
  until P = First;
end;

procedure Form.Put(var FormBuf);
var
  I: Integer;
  P: FieldPtr;
begin
  I := 0;
  P := First;
  repeat
    Move(Bytes(FormBuf)[I], P^.Value^, P^.Size);
    Inc(I, P^.Size);
    P := P^.Next;
  until P = First;
end;

procedure Color(C: ColorIndex);
type
  Palette = array[ColorIndex] of Byte;
const
  CP: Palette = ($17, $70, $30, $5E);
  MP: Palette = ($07, $70, $70, $07);
begin
  if LastMode = CO80 then TextAttr := CP[C] else TextAttr := MP[C];
end;

end.


[LISTING THREE]

unit Sliders;

{$S-}

interface

uses Crt, Forms;

type

  FSliderPtr = ^FSlider;
  FSlider = object(Field)
    Min, Max, Delta: Integer;
    constructor Init(PX, PY: Integer; PTitle: FString;
      PMin, PMax, PDelta: Integer);
    function Edit: Char; virtual;
    procedure Show; virtual;
    procedure Display(I: Integer);
  end;

implementation

constructor FSlider.Init(PX, PY: Integer; PTitle: FString;
  PMin, PMax, PDelta: Integer);
begin
  Field.Init(PX, PY, 2, PTitle);
  Min := PMin;
  Max := PMax;
  Delta := PDelta;
end;

function FSlider.Edit: Char;
var
  I: Integer;
  Ch: Char;
  Stop: Boolean;
begin
  I := Integer(Value^);
  Stop := False;
  repeat
    Display(I);
    GotoXY(X + Length(Title^) + 1, Y);
    Ch := ReadChar;
    case Ch of
      CLeft: if I > Min then Dec(I, Delta);
      CRight: if I < Max then Inc(I, Delta);
      CHome: I := Min;
      CEnd: I := Max;
      CUndo: I := Integer(Value^);
      CSave, CQuit, CNext, CPrev: Stop := True;
    else
      Beep;
    end;
  until Stop;
  if Ch <> CQuit then Integer(Value^) := I;
  Edit := Ch;
end;

procedure FSlider.Show;
begin
  Display(Integer(Value^));
end;

procedure FSlider.Display(I: Integer);
var
  Steps: Integer;
  S: FString;
begin
  Steps := (Max - Min) div Delta + 1;
  S[0] := Chr(Steps);
  FillChar(S[1], Steps, #176);
  S[(I - Min) div Delta + 1] := #219;
  GotoXY(X, Y);
  Color(TitleColor);
  Write(Title^);
  Color(ValueColor);
  Write(' ', Min, ' ', S, ' ', Max, ' ');
end;

end.



Example 1. An object definition

type
   ObjectName = object(Ancestor)
      variable definitions;
      method definitions; {virtual}
   end;



Example 2. Code for a basic window

type

  Window = object
    WindowNo : Integer;

    procedure DrawWindow(RowX, ColY, WHeight, WLen : Integer);
    procedure RemoveWindow(WindoNo);
  end;



Example 3. Code to create specialized windows.

  MenuList = string;
  MenuBar = object(Window)

    procedureDrawWindow(RowX,ColY,WHeight,WLen:Integer;
                        List:MenuList);
     procedure Highlight(Item : Integer);
     procedure MenuSelect(Item : Integer);
     { etc... }
  end;

   Pulldown = object(Window)
     { pulldown methods }
   end;