Eagles Nest BBS 8/Eagles_Nest_Mac_Collection_Disc_8.TOAST/Developer Environments/TurPasDBTlbx/TP-Database Toolbox/SetConst source/ConstUser.unit

Text File | 1987-12-11 | 18.4 KB | 765 lines | [TEXT/TPAS]

(*********************************************************************)
(*                  Turbo Pascal Database Toolbox                    *)
(*                       For the Macintosh                           *)
(*            Copyright (C) 1987 Borland International               *)
(*                     Toolbox version: 1.0                          *)
(*                                                                   *)
(*            SetConst User Interface and Calculation Unit.          *)
(*                                                                   *)
(*********************************************************************)
unit ConstUser(121);
interface
{$U-}
uses MemTypes, QuickDraw, OSIntf, ToolIntf, PackIntF, PasInOut;

var
  DefaultMaxRecSize,
  DefaultMaxKey : integer;
  MaxMemory : LongInt;

  AlwaysUseDefaults,
  ShowCompileInfo : boolean;

procedure InitSetConst;

function UseDefaults : boolean;

procedure InitWorkSheet;

procedure SetConstants;

procedure FinishUp;

implementation

procedure HighLiteButton(CurDialog : DialogPtr;
                       ButtonNum : integer;
                       UseBlack : boolean);
const
  Gap = 4;

var
  SavePort : GrafPtr;
  SavePen : PenState;
  IHandle  : Handle;
  Itype : integer;
  IRect : rect;

begin
  GetPort(SavePort);
  SetPort(CurDialog);
  GetPenState(SavePen);
  GetDItem(CurDialog, ButtonNum, IType, IHandle, IRect);
  if UseBlack then
    PenPat(Black)
  else
    PenPat(White);
  PenSize(3, 3);
  InsetRect(IRect, -Gap, -Gap);
  FrameRoundRect(IRect, 4 * Gap, 4 * Gap);
  SetPort(SavePort);
  SetPenState(SavePen);
end; { HighLiteButton }


type
  FileBuf = packed array[0..MaxInt] of char;
  FileBufferPtr = ^FileBuf;
  FileRec = record    { Internal format of a Turbo file variable }
              FInpFlag : boolean;
              FOutFlag : boolean;
              FRefNum : integer;  { Reference number is used for }
              FVRefNum : integer;       { Mac File Manager calls }
              FBufSize : integer;
              FBufPos : integer;
              FBufEnd : integer;
              FBuffer : FileBufferPtr;
              FInOutProc : ProcPtr;
            end;
var
  Str : String;
  StrVal : Text;

function StrKludge(var F : FileRec) : integer;
var
  P : integer;
begin
  StrKludge := 0;
  with F do
  begin
    if FOutFlag then
    begin
      Str := '';
      for P := 0 to FBufPos - 1 do
        Str := Str + FBuffer^[P];
      FBufPos := 0;
    end;
  end;
end; { StrKludge }


procedure InitStr;
begin
  Device('Str:', @StrKludge);
  Rewrite(StrVal,'Str:');
end;

const
  MaxRec = 4;
  PageStack = 6;
  DSearch = 12;
var
  ItemHandles : Array[MaxRec..DSearch] of handle;

type
  DBoxParameters = record
                     case integer of
                     0 : ( MaxRecs        : real;
                           PageSize       : real;
                           PageStackSize  : real;

                           DxSize         : real;
                           IxSize         : real;
                           StackMem       : real;

                           MaxSearch      : real;
                           MemSearch      : real;
                           DiskSearch     : real;

                           MaxDataRecSize : integer;
                           MaxKeyLen      : integer;
                           Order          : integer;
                           MaxHeight      : integer
                         );
                     1 : ( ItemIndex : array[MaxRec ..DSearch] of real;
                           MaxData        : integer;
                           MaxKey         : integer;
                           TOrder         : integer;
                           TMaxHeight     : integer
                         )
                   end;
var
  DBoxParams :  DBoxParameters;

const
  DefaultPageSize       =  24;
  DefaultPageStackSize  =  20;
  DefaultOrder          =  10;
  DefaultMaxHeight      =   5;
  DefaultMaxRecs        =  1000;

procedure StoreDefaults(var DBoxParams :  DBoxParameters);

function CheckResults(MaxKeyLen, PageSize, PageStackSize : real;
                      var StackMem : real) : real;
const
  Density        = 0.75;

var
  M    : real;
  Temp : Real;
  I    : Integer;
  NumRecs : real;

  PerPage,
  MaxSearch,
  MemSearch,
  IrSize,
  TotalPages : real;

begin
  CheckResults := 0;
  IrSize:=(MaxKeyLen+9) * PageSize + 6;
  StackMem := IrSize * PageStackSize;
  if StackMem > MaxMemory then
    Exit;
  PerPage:=PageSize*Density;
  NumRecs := 1000;
  MaxSearch := Ln(NumRecs)/Ln(PerPage);
  TotalPages:=Int(NumRecs/PerPage+1.0);
  Temp:=1.0;
  M:=PerPage;
  I:=1;
  while Temp+M<PageStackSize do
  begin
    Temp:=Temp + M;
    I:= succ(I);
    M:=Exp(Ln(PerPage) * I);
  End;
  If Temp + M > TotalPages
   then M:= TotalPages - Temp + 1;
  MemSearch:= I + (PageStackSize-Temp)/M;
  MemSearch := (MemSearch / MaxSearch);
  if MemSearch > 1 then
    MemSearch := 0.990;
  CheckResults := MemSearch / (MaxSearch * 100);
end;  { CheckResults }

procedure CalcDefaults(var DBoxParams : DBoxParameters);
const
  Density        = 0.75;

var
  BestResult,
  CurResult,
  CurPSize,
  CurPStack,
  CurStackMem : real;

begin
  with DBoxParams do
  begin
    CurPSize := 4;
    CurPStack := 3;
    CurStackMem := 0;
    BestResult := 0;
    while (CurStackMem <= MaxMemory) do
    begin
      CurResult := CheckResults(MaxKeyLen, CurPSize, CurPStack, CurStackMem);
      if CurResult > BestResult then
      begin
        BestResult := CurResult;
        PageSize := CurPSize;
        PageStackSize := CurPStack;
      end;
      CurPStack := CurPStack + 1;
      CurPSize := CurPSize + 2;
    end;
  end;
end; { CalcDefaults }

begin
  with DBoxParams do
  begin
    MaxDataRecSize := DefaultMaxRecSize;
    MaxKeyLen := DefaultMaxKey;
    PageSize := DefaultPageSize;
    PageStackSize := DefaultPageStackSize;
    Order := DefaultOrder;
    MaxHeight := DefaultMaxHeight;
    MaxRecs := DefaultMaxRecs;
  end;
  CalcDefaults(DBoxParams);
end; { StoreDefaults }


const
  ParamDialogId = 24135;
var
  ParamDialog : DialogPtr;

procedure SetParams(var ParamDialog : DialogPtr;
                        var DBoxParams : DBoxParameters);
var
  index : integer;

begin
  with DBoxParams do
    for index := MaxRec to PageStack do
    begin
      Write(StrVal, ItemIndex[Index]:1:0);
      SetIText(ItemHandles[Index], Str);
    end;
end;


procedure SetUpDefaults(var ParamDialog : DialogPtr;
                        var DBoxParams : DBoxParameters);
var
  MaxRecStr,
  MaxKeyStr : string;

begin
  with DBoxParams do
  begin
    Write(StrVal, MaxDataRecSize:4);     MaxRecStr := Str;
    Write(StrVal, MaxKeyLen:4);          MaxKeyStr := Str;
    ParamText(MaxRecStr, MaxKeyStr,'','');
    SetParams(ParamDialog, DBoxParams);
  end;
end; { SetUpDefaults }

procedure SetUpDialog(var ParamDialog : DialogPtr;
                      var DBoxParams : DBoxParameters);
const
  CalcButton = 1;
var
  Item : integer;
  ItemType : integer;
  box : rect;

begin
  ParamDialog := GetNewDialog(ParamDialogId,NIL,pointer(-1));
  for Item := MaxRec to DSearch do
    GetDItem(ParamDialog, Item, ItemType, ItemHandles[Item], box);
  SetUpDefaults(ParamDialog, DBoxParams);
  HighliteButton(ParamDialog, CalcButton, true);
  SelIText(ParamDialog, MaxRec, 0, MaxInt);
end; { SetUpDialog }


var
  PerPage        : real;
  TotalPages     : real;
  IrSize         : real;

procedure DoCalculations(var DBoxParams : DBoxParameters);
const
  Density        = 0.75;

var
  M    : real;
  Temp : Real;
  I    : Integer;

procedure SetMaxHeight;
var
  Quarters,
  MaxMaxHeight : integer;

begin
  MaxMaxHeight := 0;
  with DBoxParams do
  begin
    for Quarters := 2 to 4 do
    begin
      PerPage:= PageSize * (Quarters * 0.25);
      MaxSearch := Ln(MaxRecs)/Ln(PerPage);
      MaxHeight:=Trunc(MaxSearch+1.0);
      if MaxHeight > MaxMaxHeight then
        MaxMaxHeight := MaxHeight;
    end;
    MaxHeight := MaxMaxHeight;
  end;
end; { SetMaxHeight }

begin
  with DBoxParams do
  begin
    SetMaxHeight;
    PerPage:=PageSize * Density;
    MaxSearch := Ln(MaxRecs)/Ln(PerPage);
    Order:= Trunc(PageSize / 2.0);
    TotalPages:=Int(MaxRecs/PerPage+1.0);
    Temp:=1.0;
    M:=PerPage;
    I:=1;
    while Temp+M<PageStackSize do
    begin
      Temp:=Temp + M;
      I:=I + 1;
      M:=Exp(Ln(PerPage) * I);
    End;
    If Temp+M>TotalPages Then M:=TotalPages-Temp+1;
    MemSearch:=I+(PageStackSize-Temp)/M;
    DiskSearch:=MaxSearch-MemSearch;
    IrSize:=(MaxKeyLen+9) * PageSize + 6;
    IxSize:=IrSize*TotalPages;
    DxSize:=MaxDataRecSize*(MaxRecs+1);
    StackMem:= IrSize * PageStackSize;
    MemSearch := (MemSearch / MaxSearch) * 100.0;
    DiskSearch := (DiskSearch / MaxSearch)  * 100.0;
    if MemSearch > 100.0 then
     begin
       MemSearch := 99.00;
       DiskSearch := 1.00;
     end;
  end;
end;  { DoCalculations }


procedure ParamToDialog(var DBoxParams : DBoxParameters;
                        var ParamDialog : DialogPtr);
const
  DataFItem = 7;
  IndexFItem = 8;
  StackMemItem = 9;
  MaxSearchItem = 10;
  MemSearchItem = 11;
var
  Index : integer;

begin
  DoCalculations(DBoxParams);
  with DBoxParams do
    for Index := DataFItem to DSearch do
    begin
      case Index of
        DataFItem     : Write(StrVal, DxSize:14:0);
        IndexFItem    : Write(StrVal, IxSize:15:0);
        StackMemItem  : Write(StrVal, StackMem:10:0);
        MaxSearchItem : Write(StrVal, MaxSearch:4:2);
        MemSearchItem,
        DSearch       : begin
                          if Index = MemSearchItem then
                            Write(StrVal, MemSearch:5:2)
                          else
                            Write(StrVal, DiskSearch:5:2);
                          Str := Str + ' %'
                        end;
      end;
      SetItext(ItemHandles[Index], Str);
    end;
end; { ParamToDialog }


procedure DialogToParam(var ParamDialog : DialogPtr;
                        var DBoxParams : DBoxParameters);
var
  S : string;
  Index : integer;
  L : LongInt;

begin
  with DBoxParams do
    for index := MaxRec to PageStack do
    begin
      GetIText(ItemHandles[Index], S);
      StringToNum(S, L);
      ItemIndex[Index] := L;
    end;
end; { DialogToParam }

procedure SoundAlert(ResId : LongInt);
var
  Temp : integer;
begin
  HighliteButton(ParamDialog, 1, false);
  Temp := StopAlert(ResId, nil);
  HighliteButton(ParamDialog, 1, true);
end; { SoundAlert }

function OkStackMem(DBoxParams : DBoxParameters ) : boolean;
var
  Legal : boolean;
begin
  with DBoxParams do
  begin
    IrSize := (MaxKeyLen + 9) * PageSize+6;
    StackMem := IrSize * PageStackSize;
    Legal := StackMem <= MaxInt;
    if not Legal then
      SoundAlert(20147);
  end;
  OkStackMem := Legal;
end;

function LegalValues(DBoxParams : DBoxParameters;
                     ParamDialog : DialogPtr) : boolean;
const
  PageS = 5;
var
  Legal : boolean;
  Index, temp : integer;
begin
  Legal := true;
  DialogToParam(ParamDialog, DBoxParams);
  index := MaxRec;
  with DBoxParams do
    while (Index <= PageStack) and Legal do
    begin
      case Index of
        MaxRec : begin
                   Legal := ItemIndex[MaxRec] > 0;
                   if not Legal then
                     SoundAlert(10130);
                 end;
        PageS : begin
                  Legal :=  (ItemIndex[PageS] >= 4)
                            and (ItemIndex[PageS] <= 254)
                            and (not odd(trunc(ItemIndex[PageS])));
                  if not Legal then
                    SoundAlert(24839);
                end;
        PageStack : begin
                      Legal := (ItemIndex[PageStack] >= 3)
                               and (ItemIndex[PageStack] <= 254);
                      if not Legal then
                        SoundAlert(31164);
                    end;

      end;
      Index := succ(Index);
    end;
  if Legal then
    Legal := OkStackMem(DBoxParams);
  LegalValues := Legal;
end;

var
  ClockCursor:   CursHandle; {handle to the waiting watch cursor}

const
  OKButton = 1;
  DialogId = 11451;

procedure ClickButton(D : DialogPtr; ItemNo : integer);
var
  IType : integer;
  ButtonHandle : ControlHandle;
  Box : rect;
  L : LongInt;

begin
  ObscureCursor;
  GetDItem(D, ItemNo, IType, Handle(ButtonHandle), box);
  HiliteControl(ButtonHandle, 253);
  Delay(5, L);
  HiliteControl(ButtonHandle, 0);
end; { ClickButton }

function NumFilter(NumDialog : DialogPtr;
                   var Event : EventRecord;
                   var ItemHit : integer) : boolean;
const
  CR = #13;
  Enter = #03;
  BS = #8; { Backspace key }
  Tab = ^I; { Tab key }

var
  KeyCh : char;

begin
  NumFilter := false;
  if Event.what = KeyDown then
  begin
    KeyCh := Chr(Event.Message and charCodeMask);
    if (KeyCh = CR) or (KeyCh = Enter) then
    begin
      NumFilter := true;
      ItemHit := 1;
      ClickButton(NumDialog, 1);
    end
    else
    begin
      if not (KeyCh in ['0'..'9'])
         and not (KeyCh in [BS, Tab]) then
      begin
        Event.what := nullEvent;
        NumFilter := true;
        ItemHit := 0;
      end;
    end;
  end;
end; { NumFilter }

procedure SetConstants;
const
  CalcButton = 1;
  QuitButton = 2;
  DefaultsButton = 3;
var
  ItemHit,
  LastItem : integer;

begin
  SetUpDialog(ParamDialog, DBoxParams);
  LastItem := MaxRec;
  ParamToDialog(DBoxParams, ParamDialog);
  with DBoxParams do
  begin
    repeat
      ModalDialog(@NumFilter,ItemHit);
      case ItemHit of
        QuitButton : ;
        CalcButton,
        DefaultsButton : begin
                           if ItemHit = CalcButton then
                           begin
                             if LegalValues(DBoxParams,ParamDialog) then
                               DialogToParam(ParamDialog, DBoxParams);
                           end
                           else
                           begin
                             SetCursor(ClockCursor^^);
                             StoreDefaults(DBoxParams);
                             SetParams(ParamDialog, DBoxParams);
                             InitCursor;
                           end;
                           ParamToDialog(DBoxParams, ParamDialog);
                           SelIText(ParamDialog, LastItem, 0, MaxInt);
                           ItemHit := LastItem;
                         end;
        MaxRec..PageStack : if (ItemHit <> LastItem) and
                               (LastItem <> 0) then
                              SelIText(ParamDialog, ItemHit, 0, MaxInt);
      end; { case }
      LastItem := ItemHit;
    until ItemHit = QuitButton;
    DisposDialog(ParamDialog);
  end;
end; { SetConstants }

function CreateFile(var F : text;
                        var FN : string;
                        Prompt : String) : boolean;
var
  Ok : boolean;
  Start : point;
  reply : SFReply;

begin
  CreateFile := false;
  with Start Do
  begin
    v := 90;
    h := 80;
  end;
  SFPutFile(Start, Prompt, FN, NIL, reply);
  with Reply do
  begin
    Ok := good;
    if Ok then
      Ok := SetVol(nil, VRefNum) = NoErr;
    if Ok then
    begin
      {$I-}
      Rewrite(F, FName);
      {$I+}
      Ok := IOResult = 0;
      if Ok then
        FN := FName;
    end;
  end;
  CreateFile := Ok;
end; { CreateFile }

procedure SaveConstants(var Results : text;
                        DBoxParams : DBoxParameters);
const
  Tab = 2;
begin
  Writeln(Results, '{ Turbo Access constants }');
  Writeln(Results , 'const');
  with DBoxParams do
  begin
    Writeln(Results, ' ':Tab, 'MaxDataRecSize = ', MaxDataRecSize, ';');
    Writeln(Results, ' ':Tab, 'MaxKeyLen = ', MaxKeyLen, ';');
    Writeln(Results, ' ':Tab, 'PageSize = ', PageSize:1:0, ';');
    Writeln(Results, ' ':Tab, 'PageStackSize = ', PageStackSize:1:0, ';');
    Writeln(Results, ' ':Tab, 'Order = ', Order, ';');
    Writeln(Results, ' ':Tab, 'MaxHeight = ', MaxHeight, ';');
  end;
  Close(Results);
end; { SaveConstants }

function UseDefaults{ : boolean};
const
  Default = 1;
  Experiment = 2;

var
  DefaultDialog : DialogPtr;
  ItemHit : integer;
  IType : integer;
  IHandle : Handle;
  IRect : Rect;

begin
  DefaultDialog := GetNewDialog(16882,NIL,pointer(-1));
  HighliteButton(DefaultDialog, Default, true);
  repeat
    ModalDialog(nil,ItemHit);
  until ItemHit in [Default, Experiment];
  UseDefaults := ItemHit = Default;
  DisposDialog(DefaultDialog);
  DoCalculations(DBoxParams);
end;  { UseDefaults }

procedure CompileInfo(ResultFile : string);
const
  OkButton = 1;
var
  InfoDialog : DialogPtr;
  ItemHit : integer;

begin
  InfoDialog := GetNewDialog(27861, NIL,pointer(-1));
  ParamText(ResultFile, '','','');
  repeat
    ModalDialog(nil, ItemHit);
  until ItemHit = OkButton;
end; { CompileInfo }

procedure FinishUp;
const
  Prompt = 'Save constants to:';
var
  Results : text;
  NameHandle : Handle;
  FileName,
  TempName : String;
  S : StringHandle;
  M : MenuHandle;

begin
  ClearMenuBar;
  DrawMenuBar;
  NameHandle := GetResource('STR ', 1000);
  if NameHandle <> nil then
    FileName := StringHandle(NameHandle)^^
  else
     FileName := '';
  TempName := FileName;
  if CreateFile(Results, FileName, Prompt) then
  begin
    SaveConstants(Results, DBoxParams);
    if ShowCompileInfo then
      CompileInfo(FileName);
    if TempName <> FileName then
    begin
      LoadResource(NameHandle);
      HNoPurge(NameHandle);
      SetHandleSize(NameHandle, succ(Length(FileName)));
      StringHandle(NameHandle)^^ := FileName;
      ChangedResource(NameHandle);
      WriteResource(NameHandle);
      HPurge(NameHandle);
    end;
  end;
end; { FinishUp }


procedure InitSetConst;
var
  S : StringHandle;
  M : MenuHandle;

begin
  InitGraf(@thePort);
  MoreMasters;
  ClockCursor := GetCursor(watchCursor);
  HLock(Handle(ClockCursor));
    {show the watch while we wait for inits & setups to finish}
  SetCursor(ClockCursor^^);

  InitFonts;
  InitWindows;
  TEInit;
  InitDialogs(NIL);
  InitMenus;

  FlushEvents(EveryEvent, 0);
  S := GetString(1002);
  M := NewMenu(100, S^^);
  InsertMenu(M, 0);
  DrawMenuBar;
  StoreDefaults(DBoxParams);
  InitCursor;           {ready to go, so show the Arrow cursor}
end; { InitSetConst }

procedure InitWorkSheet;
var
  M : MenuHandle;
  S : StringHandle;
begin
  ClearMenuBar;
  S := GetString(1001);
  M := NewMenu(100, S^^);
  InsertMenu(M, 0);
  DrawMenuBar;
  InitStr;
end; { InitWorkSheet }

end.