swCHIP 1991 January/swCHIP_95-1.bin/chip/tvgenpas/demo3pas.exe/SUPPLY3.PAS

Pascal/Delphi Source File | 1994-12-01 | 16KB | 638 lines

{**************************************************************************}
{            Unit for use with TVGen 3.0 source code generator             }
{                     (c) 1992,94 BOCIAN Software                          }
{**************************************************************************}
{$X+}

unit Supply3;

interface
uses Drivers, Menus, Objects, Views, Dialogs;

const
      MaxStars = 20;

type
      TChars = set of Char;

      PCharacterLine = ^TCharacterLine;
      TCharacterLine = object(TInputLine)
                 LineCharSet : TChars;
                 constructor Init(var Bounds: TRect; AMaxLen: Integer; ASet : TChars);
                 procedure HandleEvent(var Event: TEvent); virtual;
                 constructor Load(var S : TStream);
                 procedure Store(var S: TStream);
               end;

      PFramedView = ^TFramedView;
      TFramedView = object(TView)
                 constructor Init(Bounds : TRect);
               end;

      PComboBox = ^TComboBox;
      TComboBox = object(TView)
                    Strings : PStringCollection;
                    Value   : Word;
                    constructor Load(var S : TStream);
                    procedure Store(var S : TStream);
                    constructor Init(var Bounds : TRect; AStrings : PSItem);
                    destructor Done; virtual;
                    procedure Draw; virtual;
                    procedure HandleEvent(var Event : TEvent); virtual;
                    function GetPalette : PPalette; virtual;
                    procedure SetState(AState : Word; Enable : Boolean); virtual;
                    procedure GetData(var Rec); virtual;
                    procedure SetData(var Rec); virtual;
                    function DataSize : Word; virtual;
                  end;

      PComboViewer = ^TComboViewer;
      TComboViewer = object(TListViewer)
                    List : PStringCollection;
                    constructor Init(var Bounds: TRect;AHScrollBar,AVScrollBar: PScrollBar; AList: PStringCollection);
                    procedure HandleEvent(var Event : TEvent); virtual;
                    function GetPalette : PPalette; virtual;
                    function GetText(Item,MaxLen : integer): string; virtual;
                    function GetWidth : integer;
                  end;

      PComboWindow = ^TComboWindow;
      TComboWindow = object(TWindow)
                       Viewer   : PComboViewer;
                       ComboBox : PComboBox;
                       constructor Init(var Bounds : TRect; ACombo : PComboBox);
                       function GetPalette : PPalette; virtual;
                       function GetNumber : integer; virtual;
                     end;


      PHintStatusLine = ^THintStatusLine;
      THintStatusLine = object(TStatusLine)
                 Hints : PStringList;
                 constructor Load(var S : TStream);
                 procedure Store(var S : TStream);
                 procedure NewHintList(AList : PStringList);
                 function Hint(AHelpCtx : Word): string; virtual;
               end;

      PLongint = ^Longint;

      TStar = record
                 XPos,YPos : Byte;
                 XDir,YDir : ShortInt;
                 Color     : Byte;
              end;

      PScreenSaver = ^TScreenSaver;
      TScreenSaver = object(TView)
                       LastTick      : Longint;
                       LastEventTick : Longint;
                       Delay         : Word;
                       Active        : Boolean;
                       Tick          : PLongint;
                       Stars         : array[1..MaxStars] of TStar;
                       constructor Init(var Bounds : TRect; ADelay : Word);
                       procedure Update; virtual;
                       procedure Draw; virtual;
                       procedure Setup; virtual;
                       procedure ShutDown; virtual;
                       procedure CheckEvent(var Event : TEvent); virtual;
                     end;

const

     RHintStatusLine : TStreamRec = (
      ObjType : 58000;
      VmtLink : Ofs(TypeOf(THintStatusLine)^);
      Load    : @THintStatusLine.Load;
      Store   : @THintStatusLine.Store);

     RCharacterLine : TStreamRec = (
      ObjType : 58001;
      VmtLink : Ofs(TypeOf(TCharacterLine)^);
      Load    : @TCharacterLine.Load;
      Store   : @TCharacterLine.Store);

     RFramedView : TStreamRec = (
      ObjType : 58002;
      VmtLink : Ofs(TypeOf(TFramedView)^);
      Load    : @TFramedView.Load;
      Store   : @TFramedView.Store);

     RComboBox : TStreamRec = (
      ObjType : 58003;
      VmtLink : Ofs(TypeOf(TComboBox)^);
      Load    : @TComboBox.Load;
      Store   : @TComboBox.Store);

      CComboBox    = #16#17#22#23;
      CComboWindow = #16#17#17#4#5#16#27;
      CComboViewer = #6#6#7#6#6;

      hcHelpWindowActive = $FEFF;               { Help Window is open }


function  OpenFile(Wild,Title : string): string;
procedure ChangeDir;
function  MakeStringList(AFileName : string): PStrListMaker;
function  GetRscString(ANumber : Word): string;
function  Min(X, Y: Integer): Integer;
function  Max(X, Y: Integer): Integer;
procedure RegisterSupply3;

var RscStringList : PStringList;

implementation
uses StdDlg, Dos, App;

{****************** TScreenSaver *******************}

constructor TScreenSaver.Init;
var i : Byte;
begin
  TView.Init(Bounds);
  Delay:=Round(ADelay*18.2);
  Active:=False;
{$IFDEF VER70}
  Tick:=Ptr(Seg0040,$6C);
{$ELSE}
  Tick:=Ptr($40,$6C);
{$ENDIF}
  LastEventTick:=Tick^;
  Hide;
  for i:=1 to MaxStars do
   with Stars[i] do
     begin
       XPos:=Random(ScreenWidth);
       YPos:=Random(ScreenHeight);
       XDir:=Random(2); if XDir=0 then XDir:=-1;
       YDir:=Random(2); if YDir=0 then YDir:=-1;
       Color:=Random(15)+1;
     end;
end;

procedure TScreenSaver.Draw;
var i : Byte;
    B,S : Word;
begin
 if Active then
  if Tick^-LastTick>1 then
    begin
      MoveChar(B,' ',1,1);
      LastTick:=Tick^;
      for i:=1 to MaxStars do
         with Stars[i] do
           begin
             MoveChar(S,'*',Color,1);
             WriteBuf(Xpos,YPos,1,1,B);
             if XPos in [0,ScreenWidth-1] then XDir:=-XDir;
             if YPos in [0,ScreenHeight-1] then YDir:=-YDir;
             Inc(XPos,XDir);
             Inc(YPos,YDir);
             WriteBuf(Xpos,YPos,1,1,S);
           end;
    end;
end;

procedure TScreenSaver.Update;
begin
  if Active then DrawView else
    begin
      if Tick^-LastEventTick>Delay then Setup;
    end;
end;

procedure TScreenSaver.CheckEvent(var Event : TEvent);
begin
  if Event.What<>evNothing then
    begin
      if Active then ShutDown;
      LastEventTick:=Tick^;
    end;
end;

procedure TScreenSaver.Setup;
begin
  Active:=True;
  LastTick:=0;
  MakeFirst;
  HideMouse;
  ClearScreen;
  Show;
  Draw;
end;

procedure TScreenSaver.ShutDown;
begin
  Active:=False;
  Hide;
  ShowMouse;
  Owner^.Redraw;
end;

{**************** THintStatusLine ******************}

procedure THintStatusLine.NewHintList;
begin
  if Hints<>NIL then Dispose(Hints,Done);
  Hints:=AList;
end;

function THintStatusLine.Hint;
begin
  if Hints<>NIL then Hint:=Hints^.Get(AHelpCtx)
                else Hint:='';
end;

constructor THintStatusLine.Load;
begin
  TStatusLine.Load(S);
  S.Read(Hints,SizeOf(Hints));
end;

procedure THintStatusLine.Store;
begin
  TStatusLine.Store(S);
  S.Write(Hints,SizeOf(Hints));
end;

{**************************************************}

constructor TComboBox.Init;
var X,Y : PSItem;
    i   : Byte;
begin
  TView.Init(Bounds);
  Options:=Options or ofSelectable or ofPostProcess or ofFirstClick;
  Value:=0;
  i:=0;
  X:=AStrings;
  while X<>nil do
    begin
      X:=X^.Next;
      Inc(i);
    end;
  New(Strings,Init(i,0));
  X:=AStrings;
  while X<>nil do
    begin
      Y:=X^.Next;
      Strings^.AtInsert(Strings^.Count,X^.Value);
      Dispose(X);
      X:=Y;
    end;
end;

destructor TComboBox.Done;
begin
  Dispose(Strings,Done);
  TView.Done;
end;

constructor TComboBox.Load;
begin
  TView.Load(S);
  Strings:=New(PStringCollection,Load(S));
  S.Read(Value,SizeOf(Value));
end;

procedure TComboBox.Store;
begin
  TView.Store(S);
  Strings^.Store(S);
  S.Write(Value,SizeOf(Value));
end;

function TComboBox.GetPalette;
const P : string[Length(CComboBox)] = CComboBox;
begin
  GetPalette:=@P;
end;

procedure TComboBox.Draw;
var B : TDrawBuffer;
    C : Byte;
begin
  if State and sfFocused <> 0 then C:=GetColor(2) else C:=GetColor(1);
  MoveChar(B,' ',C,Size.X);
  MoveStr(B[1],PString(Strings^.At(Value))^,C);
  MoveCStr(B[Size.X-3], #222'~'#25'~'#221, GetColor($0304));
  WriteLine(0, 0, Size.X, Size.Y, B);
end;

procedure TComboBox.SetState;
begin
  TView.SetState(AState,Enable);
  if AState and sfFocused <> 0 then DrawView;
end;

procedure TComboBox.HandleEvent;
var R,P : TRect;
    W   : PComboWindow;
    C   : Word;

  function LocalX(P : TPoint): Byte;
  var LP : TPoint;
  begin
    MakeLocal(P,LP);
    LocalX:=LP.X;
  end;

begin
  TView.HandleEvent(Event);
  if (Event.What = evMouseDown) and (LocalX(Event.Where)>=(Size.X-3)) or
     ((Event.What = evKeyDown) and (CtrlToArrow(Event.KeyCode) = kbDown) and
      (State and sfFocused <> 0)) then
  begin
{$IFDEF VER70}
    if not Focus then
{$ELSE}
    Select;
    if State and sfSelected <> 0 then
{$ENDIF}
      begin
        ClearEvent(Event);
        Exit;
      end;
    GetBounds(R);
    Dec(R.A.X); Inc(R.B.Y,Min(7,Strings^.Count+1)); Dec(R.A.Y,1);
    Owner^.GetExtent(P);
    R.Intersect(P);
    Dec(R.B.Y,1);
    New(W,Init(R,@Self));
    if W <> nil then
    begin
      W^.HelpCTX:=HelpCtx;
      C := Owner^.ExecView(W);
      if C = cmOk then
      begin
        Value := W^.GetNumber;
        DrawView;
      end;
      Dispose(W, Done);
    end;
    ClearEvent(Event);
  end;
end;

procedure TComboBox.GetData;
begin
  Word(Rec):=Value;
end;

procedure TComboBox.SetData;
begin
  Value:=Word(Rec);
  if Value>=Strings^.Count then Value:=0;
  DrawView;
end;

function TComboBox.DataSize;
begin
  DataSize:=SizeOf(Word);
end;

{***************** TComboWindow *******************}

constructor TComboWindow.Init;
var R : TRect;
begin
  TWindow.Init(Bounds,'',wnNoNumber);
  Flags:=wfClose;
  ComboBox:=ACombo;
  GetExtent(R);
  R.Grow(-1,-1);
  Viewer := New(PComboViewer, Init(R,
    StandardScrollBar(sbHorizontal + sbHandleKeyboard),
    StandardScrollBar(sbVertical + sbHandleKeyboard),ComboBox^.Strings));
  Insert(Viewer);
  Viewer^.FocusItem(ComboBox^.Value);
end;

function TComboWindow.GetPalette;
const P : string[Length(CComboWindow)] = CComboWindow;
begin
  GetPalette:=@P;
end;

function TComboWindow.GetNumber;
begin
  GetNumber:=Viewer^.Focused;
end;

{****************** TComboViewer *****************}

constructor TComboViewer.Init;
begin
  TListViewer.Init(Bounds, 1, AHScrollBar, AVScrollBar);
  List:=AList;
  SetRange(List^.Count);
  HScrollBar^.SetRange(1, GetWidth-Size.X + 3);
end;

function TComboViewer.GetPalette;
const
  P: String[Length(CComboViewer)] = CComboViewer;
begin
  GetPalette := @P;
end;

function TComboViewer.GetText;
begin
  GetText := PString(List^.At(Item))^;
end;

procedure TComboViewer.HandleEvent;
begin
  if ((Event.What = evMouseDown) and (Event.Double)) or
     ((Event.What = evKeyDown) and (Event.KeyCode = kbEnter)) then
  begin
    EndModal(cmOk);
    ClearEvent(Event);
  end else if ((Event.What = evKeyDown) and (Event.KeyCode = kbEsc)) or
    ((Event.What = evCommand) and (Event.Command = cmCancel)) then
  begin
    EndModal(cmCancel);
    ClearEvent(Event);
  end else TListViewer.HandleEvent(Event);
end;

function TComboViewer.GetWidth;
var L : integer;

  procedure GetLength(X : PString); far;
  begin
    if L<Length(X^) then L:=Length(X^);
  end;

begin
  L:=0;
  List^.ForEach(@GetLength);
  GetWidth:=L;
end;

{**************** TCharacterLine ******************}

constructor TCharacterLine.Init;
begin
  TInputLine.Init(Bounds,AMaxLen);
  LineCharSet:=ASet;
end;

procedure TCharacterLine.HandleEvent;
begin
   if Event.What = evKeyDown then
        if ord(Event.CharCode)>31 then
              begin
                if not (Event.CharCode in LineCharSet) then ClearEvent(Event);
              end;
   TInputLine.HandleEvent(Event);
end;

constructor TCharacterLine.Load;
begin
  TInputLine.Load(S);
  S.Read(LineCharSet,SizeOf(LineCharSet));
end;

procedure TCharacterLine.Store;
begin
  TInputLine.Store(S);
  S.Write(LineCharSet,SizeOf(LineCharSet));
end;

{**************** TFramedView ******************}

constructor TFramedView.Init;
begin
  TView.Init(Bounds);
  Options:=Options or ofFramed;
end;

{********** OpenFile and ChangeDir ************}

{$IFDEF VER70}

function OpenFile(Wild,Title : string): string;
var
  D: PFileDialog;
  FN: PathStr;
  FileName : Pointer;
begin
  FN:='';
  FileName:=@FN;
  D := New(PFileDialog,Init(Wild,Title,'~N~ame', fdOkButton, cmOpen));
  Application^.ExecuteDialog(D,FileName);
  OpenFile:=FN;
end;

procedure ChangeDir;
var
  D: PChDirDialog;
begin
  D := New(PChDirDialog, Init(cdNormal,cmChangeDir));
  Application^.ExecuteDialog(D,NIL);
end;

{$ELSE}

function OpenFile(Wild,Title : string): string;
var
  D: PFileDialog;
  FileName: PathStr;
begin
  FileName:='';
  D := PFileDialog(Application^.ValidView(New(PFileDialog,
        Init(Wild,Title,'~N~ame', fdOkButton, 100))));
  if D <> nil then
   begin
      if Desktop^.ExecView(D) <> cmCancel then D^.GetData(FileName);
      Dispose(D, Done);
   end;
  OpenFile:=FileName;
end;

procedure ChangeDir;
var
  D: PChDirDialog;
begin
  D := PChDirDialog(Application^.ValidView(New(PChDirDialog, Init(0,cmChangeDir))));
  if D <> nil then
  begin
    DeskTop^.ExecView(D);
    Dispose(D, Done);
  end;
end;
{$ENDIF}

function MakeStringList;
var f    : text;
    i    : word;
    Size : word;
    S    : string;
    X : PStrListMaker;
begin
  i:=0;
  Assign(f,AFileName);
  {$I-}
  Reset(f);
  {$I+}
  if IOResult=0 then
    begin
      while not Eof(f) do
        begin
          Readln(f,S);
          Size:=Size+Length(S);
          Inc(i);
        end;
    end
      else Size:=0;
  New(X,Init(Size,i));
  i:=1;
  if Size<>0 then
    begin
      Reset(f);
      while not Eof(f) do
        begin
          Readln(f,S);
          X^.Put(i,S);
          Inc(i);
        end;
      Close(f);
    end;
  MakeStringList:=X;
end;

function GetRscString;
begin
  GetRscString:=RscStringList^.Get(ANumber);
end;

function Min(X, Y: Integer): Integer; assembler;
asm
        MOV     AX,X
        CMP     AX,Y
        JLE     @@1
        MOV     AX,Y
@@1:
end;

function Max(X, Y: Integer): Integer; assembler;
asm
        MOV     AX,X
        CMP     AX,Y
        JNLE    @@1
        MOV     AX,Y
@@1:
end;

procedure RegisterSupply3;
begin
  RegisterType(RComboBox);
  RegisterType(RFramedView);
  RegisterType(RCharacterLine);
end;

begin
  Randomize;
end.