Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OPBONUS.ZIP/CALIBRAT.LZH/CALIBRAT.PAS

Pascal/Delphi Source File | 1990-03-28 | 18.8 KB | 695 lines

{$V-,F+}
{$I OPDEFINE.INC}
program Calibrate;
  {-Define and edit BasePrinters}

uses
  Dos,
  OpInline,
  OpString,
  OpRoot,
  OpCrt,
  OpDos,
  OpColor,
  {$IFDEF UseMouse}
  OpMouse,
  {$ENDIF}
  OpAbsFld,
  OpFrame,
  OpCmd,
  OpField,
  OpWindow,
  OpSEdit,
  OpSelect,
  OpEntry,
  OpPrnLow;

  {$IFDEF UseMouse}
const
  MouseChar : Char = #04;
  {$ENDIF}

const
  EsColors : ColorSet = (
    TextColor       : YellowOnBlue;       TextMono        : WhiteOnBlack;
    CtrlColor       : YellowOnBlue;       CtrlMono        : WhiteOnBlack;
    FrameColor      : CyanOnBlue;         FrameMono       : LtGrayOnBlack;
    HeaderColor     : WhiteOnCyan;        HeaderMono      : BlackOnLtGray;
    ShadowColor     : DkGrayOnBlack;      ShadowMono      : WhiteOnBlack;
    HighlightColor  : WhiteOnRed;         HighlightMono   : BlackOnLtGray;
    PromptColor     : LtGrayOnBlue;       PromptMono      : LtGrayOnBlack;
    SelPromptColor  : LtGrayOnBlue;       SelPromptMono   : LtGrayOnBlack;
    ProPromptColor  : DkGrayOnBlue;       ProPromptMono   : BlackOnBlack;
    FieldColor      : YellowOnBlue;       FieldMono       : LtGrayOnBlack;
    SelFieldColor   : BlueOnCyan;         SelFieldMono    : WhiteOnBlack;
    ProFieldColor   : DkGrayOnBlue;       ProFieldMono    : BlackOnBlack;
    ScrollBarColor  : CyanOnBlue;         ScrollBarMono   : LtGrayOnBlack;
    SliderColor     : CyanOnBlue;         SliderMono      : WhiteOnBlack;
    HotSpotColor    : BlackOnCyan;        HotSpotMono     : BlackOnLtGray;
    BlockColor      : YellowOnCyan;       BlockMono       : WhiteOnBlack;
    MarkerColor     : WhiteOnCyan;        MarkerMono      : BlackOnLtGray;
    DelimColor      : YellowOnBlue;       DelimMono       : WhiteOnBlack;
    SelDelimColor   : BlueOnCyan;         SelDelimMono    : WhiteOnBlack;
    ProDelimColor   : YellowOnBlue;       ProDelimMono    : WhiteOnBlack;
    SelItemColor    : YellowOnCyan;       SelItemMono     : BlackOnLtGray;
    ProItemColor    : LtGrayOnBlue;       ProItemMono     : LtGrayOnBlack;
    HighItemColor   : WhiteOnBlue;        HighItemMono    : WhiteOnBlack;
    AltItemColor    : WhiteOnBlue;        AltItemMono     : WhiteOnBlack;
    AltSelItemColor : WhiteOnCyan;        AltSelItemMono  : BlackOnLtGray;
    FlexAHelpColor  : WhiteOnBlue;        FlexAHelpMono   : WhiteOnBlack;
    FlexBHelpColor  : WhiteOnBlue;        FlexBHelpMono   : WhiteOnBlack;
    FlexCHelpColor  : LtCyanOnBlue;       FlexCHelpMono   : BlackOnLtGray;
    UnselXrefColor  : YellowOnBlue;       UnselXrefMono   : LtBlueOnBlack;
    SelXrefColor    : WhiteOnCyan;        SelXrefMono     : BlackOnLtGray;
    MouseColor      : WhiteOnRed;         MouseMono       : BlackOnLtGray
  );

{Entry field constants}
const
  idUseBiosServices      = 0;
  idPrinterName          = 1;
  idLPTNumber            = 2;
  idPrinterTestNo        = 3;

{Help index constants}
const
  hiUseBiosServices      = 1;
  hiPrinterName          = 2;
  hiLPTNumber            = 3;
  hiPrinterTestNo        = 4;


var
  NormalAttr, HelpAttr, HelpLine     : Byte;
  ES     : EntryScreen;
  Status : Word;
  Mask, HighScore : Byte;
  UserRec     : record
             PrinterName          : string[32];
             UseBiosServices      : Boolean;
             LPTNumber            : Byte;
             PrinterTestNo        : Byte;
           end;

type
  Str80            = String[80];
  PrinterDesc      =
    record
      Name         : Str80;
      PType        : PrnType;
    end;
  TestType         = (Online, Offline, OutOfPaper, PoweredOff);
  ResultType       = Array[TestType] of Byte;

const
  TestPrompt       : Array[TestType] of Str80 =
    ('Insure the printer is online and ready with paper loaded',
     'Take the printer offline',
     'Remove the paper from the printer',
     'Turn the printer off');

  Title            =
'Calibrate - Creates BasePrinter Streams - by TurboPower Software';

  OnlineWeight     = 50;
  OfflineWeight    = 25;
  PaperWeight      = 20;
  OffWeight        = 5;

  PrX1             = 10;
  PrY1             = 20;
  PrX2             = 70;

  StreamFileName   : String[79] = '';

  function GetKey : Word;
  begin
    GetKey := OpCrt.ReadKeyWord;
  end;

  procedure DisplayErrorMsg(Msg : string);
    {-Display an error message}
  var
    W, CursorSL, CursorXY : Word;
    P : Pointer;
  begin
    {try to save screen}
    if not SaveWindow(1, HelpLine, ScreenWidth, HelpLine, True, P) then begin
      RingBell;
      Exit;
    end;

    {Store cursor position and shape, then make it a fat cursor}
    GetCursorState(CursorXY, CursorSL);
    FatCursor;

    {add to default message, if possible}
    if Length(Msg) < 60 then
      Msg := Msg+'. Press any key...';

    {display error message and ring bell}
    FastWrite(Center(Msg, ScreenWidth), HelpLine, 1, HelpAttr);
    RingBell;

    {flush keyboard buffer}
    while KeyPressed do
      W := GetKey;

    {wait for keypress}
    W := GetKey;

    {Restore cursor position and shape}
    RestoreCursorState(CursorXY, CursorSL);

    {restore screen}
    RestoreWindow(1, HelpLine, ScreenWidth, HelpLine, True, P);
  end;

procedure PreEdit(ESP : EntryScreenPtr);
  {-Called just before a field is edited}
var
  S : String[80];
  A : Byte;
begin
  with ESP^ do
    case GetCurrentID of
      idUseBiosServices      :
        S := 'T to use BIOS Services, F to use DOS Services';
      idPrinterName          :
        S := 'Enter the name of the file or device to send output to';
      idLPTNumber            :
        S := 'Enter LPT Number (1, 2, or 3)';
      idPrinterTestNo        :
        S := 'Enter printer test number (F10 for auto test selection)';
      else
        S := '';
    end;
  FastWrite(Center(S, ScreenWidth), HelpLine, 1, HelpAttr);
end;

procedure PostEdit(ESP : EntryScreenPtr);
  {-Called just after a field has been edited}
begin
  with ESP^, UserRec do
    case GetCurrentID of
      idUseBiosServices      : begin
                                 if UseBiosServices then begin
                                   ChangeProtection(idLPTNumber, False);
                                   ChangeProtection(idPrinterTestNo, False);
                                   ChangeProtection(idPrinterName, True);
                                 end
                                 else begin
                                   ChangeProtection(idLPTNumber, True);
                                   ChangeProtection(idPrinterTestNo, True);
                                   ChangeProtection(idPrinterName, False);
                                 end;
                                 DrawField(idPrinterName);
                                 DrawField(idLPTNumber);
                                 DrawField(idPrinterTestNo);
                               end;
      idPrinterName          : ;
      idLPTNumber            : ;
      idPrinterTestNo        : ;
    end;
end;

procedure DisplayHelp(UnitCode : Byte; IdPtr : Pointer; HelpIndex : Word);
  {-Display context sensitive help}
begin
end;

procedure IncChoice(var Value; ID : Word; Factor : Integer; var St : string);
  {-Increment a multiple choice field value and convert it to a string}
begin
end;

procedure ErrorHandler(UnitCode : Byte; var ErrCode : Word; Msg : string);
  {-Report errors}
begin
  DisplayErrorMsg(Msg);
end;

procedure ClearHelpLine;

begin
  FastWrite(CharStr(' ', ScreenWidth), HelpLine, 1, HelpAttr);
end;

procedure WriteHelpLine(S : String);

begin
  FastWrite(Center(S, ScreenWidth), HelpLine, 1, HelpAttr);
end;

procedure Abort(S : String);

begin
  GotoXY(1,25);
  WriteLn(S);
  RingBell;
  Halt;
end;

procedure DialogBox(S : String);

var
  Win : StackWindow;
  XY, SL : Word;

begin
  if not Win.InitCustom(PrX1, PrY1, PrX2, PrY1 + 2,
                        ESColors, wClear+wBordered(*+wSoundEffects*)) then
    Abort('Error initializing prompt window');
  with Win do begin
    EnableExplosions(5);
    GetCursorState(XY, SL);
    Draw;
    HiddenCursor;
    wFastCenter(S, 1, ESColors.TextColor);
    wFastCenter('Press any key when ready', 2, ESColors.TextColor);
    if ReadKey = #0 then ;
    Erase;
    RestoreCursorState(XY, SL);
    Done;
  end;
end;

function PromptUser(Prompt : String; MaxLen : Byte) : String;

var
  Win : StackWindow;
  XY, SL : Word;
  SLE : SimpleLineEditor;
  S   : String;
begin
  PromptUser := '';
  if not Win.InitCustom(PrX1, PrY1, PrX2, PrY1 + 2,
                        ESColors, wClear+wBordered(*+wSoundEffects*)) then
    Abort('Error initializing prompt window');
  with Win do begin
    EnableExplosions(5);
    Draw;
    if not SLE.Init(EsColors) then
      Exit;
    S := '';
    SLE.ReadString(Prompt, PrY1 + 1, PrX1 + 2, MaxLen,
                   (PrX2 - PrX1) - (Length(Prompt) + 2), S);
    if (SLE.GetLastCommand = ccQuit) then
      Exit;
    PromptUser := S;
    SLE.Done;
    Erase;
    Done;
  end;
end;

function YesOrNo(Prompt : String;
                 Row, Col : Byte;
                 Default : Char) : Boolean;
var
  P : Byte;
  C : Char;
begin
  Default := Upcase(Default);
  P := Length(Prompt) + 3;
  Prompt := Prompt + ' [' + Default + ']';
  GotoXYAbs(Col + (Length(Prompt) - 2), Row);
  FastWrite(Prompt, Row, Col, NormalAttr);
  repeat
    C := UpCase(Char(GetKey));
  until C in ['N','Y',^M, ^[];
  if C = ^M then
    C := Default
  else if C = ^[ then
    C := 'N';
  FastWrite(C, Row, Col + P - 1, NormalAttr);
  YesOrNo := C = 'Y';
end;

function PromptYesOrNo(Prompt : String; Default : Boolean) : Boolean;

var
  Win : StackWindow;
  XY, SL : Word;
  C   : Char;
  S   : String;
begin
  PromptYesOrNo := Default;
  if not Win.InitCustom(PrX1, PrY1, PrX2, PrY1 + 2,
                        ESColors, wClear+wBordered(*+wSoundEffects*)) then
    Abort('Error initializing prompt window');
  with Win do begin
    EnableExplosions(5);
    GetCursorState(XY, SL);
    Draw;
    NormalCursor;
    if Default then
      C := 'Y'
    else
      C := 'N';
    PromptYesOrNo := YesOrNo(Prompt, PrY1 + 1, PrX1 + 2, C);

    Erase;
    Done;
    RestoreCursorState(XY, SL);
  end;
end;

function BiosPrinterStatus(LPTNo : LPTType) : Byte;
  {-Call BIOS Printer Status function for specified LPT number}
var
  Regs : Registers;
begin
  with Regs do begin
    AH := 2;
    DX := Word(LPTNo);
    Intr($17, Regs);
    BiosPrinterStatus := AH;
  end;
end;

procedure TestSequence(LPTNo : LPTType; var Results : ResultType);
  {-Perform the BIOS Printer tests}
var
  Test : TestType;

begin
  for Test := Online to PoweredOff do begin
    DialogBox(TestPrompt[Test]);
    Results[Test] := BiosPrinterStatus(LPTNo);
  end;
end;

function FindAndScoreMask(Results : ResultType; var Mask : Byte) : Word;
  {-Find best mask value and score its effectiveness}
var
  Sc, M, I, HighSc, HighIndex : Byte;
const
  Masks : Array[1..3] of Byte = ($90, $10, $A0);

begin
  HighSc := 0;
  HighIndex := 1;
  for I := 1 to 3 do begin
    M  := Masks[I];
    Sc := 0;
    if M and Results[Online] = M then
      Sc := OnlineWeight;
    if M and Results[Offline] <> M then
      Sc := Sc + OfflineWeight;
    if M and Results[OutOfPaper] <> M then
      Sc := Sc + PaperWeight;
    if M and Results[PoweredOff] <> M then
      Sc := Sc + OffWeight;
    if Sc > HighSc then begin
      HighIndex := I;
      HighSc    := Sc;
    end;
  end;
  FindAndScoreMask := HighSc;
  Mask := Masks[HighIndex];
end;

function PickBiosTest(LPTNo : LPTType;
                      var Mask : Byte; var HighScore : Byte) : Byte;
  {-Perform test and analyze results}

var
  Score            : Array[1..4] of Byte;
  Results          : ResultType;
  Test             : TestType;
  Sc, TestNo, I    : Byte;
begin
  {perform the printer tests}
  TestSequence(LPTNo, Results);

  {calculate score for each type of printer test}
  Sc := 0;
  if PrnTest1Prim(Word(Results[Online])) then
    Sc := OnlineWeight;
  if not PrnTest1Prim(Word(Results[Offline])) then
    Sc := Sc + OfflineWeight;
  if not PrnTest1Prim(Word(Results[OutOfPaper])) then
    Sc := Sc + PaperWeight;
  if not PrnTest1Prim(Word(Results[PoweredOff])) then
    Sc := Sc + OffWeight;
  Score[1] := Sc;

  Sc := 0;
  if PrnTest2Prim(Word(Results[Online])) then
    Sc := OnlineWeight;
  if not PrnTest2Prim(Word(Results[Offline])) then
    Sc := Sc + OfflineWeight;
  if not PrnTest2Prim(Word(Results[OutOfPaper])) then
    Sc := Sc + PaperWeight;
  if not PrnTest2Prim(Word(Results[PoweredOff])) then
    Sc := Sc + OffWeight;
  Score[2] := Sc;

  Sc := 0;
  if PrnTest3Prim(Word(Results[Online])) then
    Sc := OnlineWeight;
  if not PrnTest3Prim(Word(Results[Offline])) then
    Sc := Sc + OfflineWeight;
  if not PrnTest3Prim(Word(Results[OutOfPaper])) then
    Sc := Sc + PaperWeight;
  if not PrnTest3Prim(Word(Results[PoweredOff])) then
    Sc := Sc + OffWeight;
  Score[3] := Sc;

  Score[4] := FindAndScoreMask(Results, Mask);

  {find HighScore score and record test number}
  HighScore := Score[1];
  TestNo  := 1;
  for I := 2 to 4 do
    if Score[I] > HighScore then begin
      HighScore := Score[I];
      TestNo  := I;
    end;

  {if our best score isn't better than a cutoff, then use no test}
  if HighScore < (OnlineWeight + 1) then
    TestNo := 0;

  PickBiosTest := TestNo;
end;

function InitEntryScreen : Word;
  {-Initialize entry screen generated by MAKESCRN}
const
  Frame1 = '╓╙╖╜──║║';
  WinOptions = wBordered+wClear+wUserContents(*+wSoundEffects*);
begin
  with EntryCommands do begin
    AddCommand(ccUser0, 1, $4400, 0);
    AddCommand(ccUser1, 1, $2D00, 0);
  end;
  with ES do begin
    if not InitCustom(5, 9, 75, 16, EsColors, WinOptions) then begin
      InitEntryScreen := InitStatus;
      Exit;
    end;
    wFrame.SetFrameType(Frame1);
    EnableExplosions(5);
    wFrame.AddShadow(shBR, shSeeThru);
    wFrame.AddHeader('Printer Information', heTC);
    SetWrapMode(WrapAtEdges);

    SetPreEditProc(PreEdit);
    SetPostEditProc(PostEdit);
    SetErrorProc(ErrorHandler);
    EntryCommands.SetHelpProc(DisplayHelp);


  {idUseBiosServices:}
    AddBooleanField(
      'Use BIOS Services :', 2, 2,
      'B', 2, 25,
      hiUseBiosServices, UserRec.UseBiosServices);

  {idPrinterName:}
    esFieldOptionsOn(efClearFirstChar);
    AddStringField(
      'Enter name        :', 3, 2,
      CharStr('X', 32), 3, 25, 32,
      hiPrinterName, UserRec.PrinterName);

  {idLPTNumber:}
    AddByteField(
      'Enter LPT Number  :', 4, 2,
      '9', 4, 25,
      hiLPTNumber, 1, 3, UserRec.LPTNumber);

  {idPrinterTestNo:}
    AddByteField(
      'Enter Printer Test:', 5, 2,
      '9', 5, 25,
      hiPrinterTestNo, 0, 4, UserRec.PrinterTestNo);

    InitEntryScreen := GetLastError;
  end;
end;

function DoAuto : Byte;
var
  TestNo : Byte;

begin
  TestNo := PickBiosTest(LPTType(UserRec.LPTNumber-1), Mask, HighScore);
  if TestNo = 0 then begin
    Sound(110);
    Delay(800);
    NoSound;
    DialogBox('No printer test is adequate! Using test number 0.');
  end;
  DoAuto := TestNo;
end;

procedure ProcessPrinter;
  {-Store the stream}

var
  Stm : BufIDStream;
  BP  : BasePrinterPtr;
  T   : PrnType;
  ErrorCode : Word;
begin
  with UserRec do
    if UseBiosServices then begin
      BP := New(BiosPrinterPtr, InitCustom(LPTType(LPTNumber-1),
                                           PrinterTestNo,
                                           Mask));
      if BP = NIL then begin
        DialogBox('Unable to create BiosPrinter object');
        Exit;
      end;
    end
    else begin
      if StUpCase(PrinterName) = 'PRN' then
        T := Prn
      else
        T := DiskFile;
      BP := New(DosPrinterPtr, Init(PrinterName, T));
      if BP = NIL then begin
        DialogBox('Unable to create DosPrinter object');
        Exit;
      end;
    end;
  if not Stm.Init(StreamFileName, SCreate, 1024) then begin
    DialogBox('Can not open stream file, aborting...');
    Exit;
  end;
  with Stm do begin
    RegisterHier(DosPrinterStream);
    RegisterHier(BiosPrinterStream);
    PutPtr(BP);
    ErrorCode := GetStatus;
    Done;
  end;
  if ErrorCode = 0 then
    DialogBox('Stream successfully written')
  else
    DialogBox('Error writing stream.  Aborting...');
end;

procedure DoEntryScreen;

var
  AllDone : Boolean;
  ExitCmd : Word;

begin
  {$IFDEF UseMouse}
  if MouseInstalled then
    with EsColors do begin
      {activate mouse cursor}
      SoftMouseCursor($0000, (ColorMono(MouseColor, MouseMono) shl 8)+
                             Byte(MouseChar));
      ShowMouse;
      {enable mouse support}
      EntryCommands.cpOptionsOn(cpEnableMouse);
    end;
  {$ENDIF}

  {initialize entry screen}
  Status := InitEntryScreen;
  if Status <> 0 then begin
    WriteLn('Error initializing entry screen: ', Status);
    Halt(1);
  end;

  {initialize user record}
  FillChar(UserRec, SizeOf(UserRec), 0);
  with UserRec do begin
    UseBiosServices := True;
    LPTNumber := 1;
    PrinterTestNo := 1;
  end;
  ES.ChangeProtection(idPrinterName, True);
  AllDone := False;
  {test entry screen}
  repeat
    ES.Process;
    ExitCmd := ES.GetLastCommand;
    case ExitCmd of
      ccQuit   : AllDone :=
                   PromptYesOrNo('Really exit without saving?', False);
      ccError  : begin
                   AllDone := True;
                   DialogBox('An error has occurred processing the entry screen');
                 end;
      ccUser1  : AllDone := True;
      ccDone   : begin
                   ProcessPrinter;
                   AllDone := True;
                 end;
      ccUser0  : if ES.GetCurrentID = idPrinterTestNo then begin
                   UserRec.PrinterTestNo := DoAuto;
                   ES.SetLastCommand(ccNextField);
                 end;
    end;
  until AllDone;

  ES.Erase;
  ES.Done;

  {$IFDEF UseMouse}
  HideMouse;
  {$ENDIF}
end;

function GetStreamName : Boolean;

begin
  GetStreamName := False;
  WriteHelpLine('Enter the name of the stream file to create');
  StreamFileName := PromptUser('File name: ', SizeOf(StreamFileName) - 1);
  if ExistFile(StreamFileName) then
    if not PromptYesOrNo('File exists, overwrite?', False) then
      Exit;
  GetStreamName := StreamFileName <> '';
end;

begin
  TextChar := '░';
  ClrScr;
  case CurrentMode of
    2, 7 : begin
             HelpAttr   := ESColors.FlexBHelpMono;
             NormalAttr := ESColors.TextMono;
           end;
    else begin
      HelpAttr   := ESColors.FlexBHelpColor;
      NormalAttr := ESColors.TextColor;
    end;
  end;
  FastWrite(Center(Title, ScreenWidth), 1, 1, HelpAttr);
  HelpLine := ScreenHeight;
  ClearHelpLine;
  if GetStreamName then
    DoEntryScreen;
  TextAttr := $07;
  ClrScr;
end.