Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OPSPRD.ZIP/TSPREAD2.PAS

Pascal/Delphi Source File | 1992-01-16 | 11.2 KB | 411 lines

{$R-,S-,I-}
{$I OPDEFINE.INC}

{$IFDEF UseMouse}
  {$IFDEF UseDrag}
    {$DEFINE UsingDrag}
  {$ELSE}
    {$DEFINE UseDragAnyway} {<--- define this to force use of OPDRAG}
    {$IFDEF UseDragAnyway}
      {$DEFINE UsingDrag}
    {$ENDIF}
  {$ENDIF}
{$ENDIF}

program TSpread2;
  {-Implement a simple SpreadSheet object using the SpreadList}
uses
  OpCrt,
  OpString,
  OpRoot,
  OpCmd,
  {$IFDEF UseMouse}
  OpMouse,
  {$ENDIF}
  {$IFDEF UsingDrag}
  OpDrag,
  {$ENDIF}
  OpFrame,
  OpWindow,
  OpPick,
  OpSpread;

const
  SpreadSize = 50;    {Elements on a side of this spreadsheet}
  ItemWidth = 8;      {Each item uses ItemWidth screen columns}
  DataWidth = ItemWidth-2; {Two characters are used for padding and dividers}
  BackChar = #177;    {Character used to fill background}

type
  ItemArray = array[1..SpreadSize, 1..SpreadSize] of String[DataWidth];

  SpreadSheet =
    object(SpreadList)
      TLRow : Word;      {Last known Row and col in top left of sheet}
      TLCol : Word;
      SSWid : Byte;      {Last known Width and Height of window}
      SSHgt : Byte;
      Items : ItemArray; {Data for the spreadsheet}

      constructor Init;
        {-Constructor specific to this spread sheet}

      {---- PickList virtual methods we override ----}
      procedure UpdateContents; virtual;
        {-Used to force scrolling header updates}
      procedure ProcessSelf; virtual;
        {-Add a few commands to the default ProcessSelf handling}
      procedure ItemString(Item : Word; Mode : pkMode; var IType : pkItemType;
                           var IString : String); virtual;
        {-Our item string function for the pick list}
      procedure PreMove; virtual;
        {-Used to draw scrolling row and column headers}
      function ItemSearch : Boolean; virtual;
        {-Used to force Process to exit whenever an alphanumeric character
          is entered}
      function OKToChangeChoice : Boolean; virtual;
        {-Routine that validates cells before leaving them}
      procedure PositionCursor(Item : Word; ACol, ARow : Byte); virtual;
        {-Routine that positions hardware cursor within cell}

      {---- Routines added by SpreadSheet object ----}
      procedure WarnInvalidItem(Item : Word); virtual;
        {-Display a warning when specified item is invalid}
      function ValidItem(Item : Word) : Boolean; virtual;
        {-Determine whether specified item is valid}
      procedure AddChar;
        {-Add new character to the contents of current cell}
      procedure DelChar;
        {-Delete last character in current cell}
    end;

var
  SL : SpreadSheet;
  {$IFDEF UseDragAnyway}
  PickCommands : DragProcessor;
  {$ENDIF}
  {$IFDEF UsingDrag}
  ZoomHeaderNum : byte;
  HotCode : byte;
  {$ENDIF}

procedure Warn(Msg : String);
var
  KW : Word;
  Attr : Byte;
begin
  {Put up a message}
  Attr := ColorMono(DefaultColorSet.HighlightColor, DefaultColorSet.HighlightMono);
  FastWrite(Pad(Msg+'. Press a key...', ScreenWidth), ScreenHeight, 1, Attr);
  RingBell;

  {Clear keyboard and wait for a keypress}
  {$IFDEF UseMouse}
  while KeyOrButtonPressed do
    KW := ReadKeyOrButton;
  KW := ReadKeyOrButton;
  {$ELSE}
  while KeyPressed do
    KW := ReadKeyWord;
  KW := ReadKeyWord;
  {$ENDIF}
  {$IFDEF UsingDrag}
  {Get rid of any mouse}
  ClearMouseEvents;
  {$ENDIF}

  {Restore the screen}
  FastWrite(CharStr(BackChar, ScreenWidth), ScreenHeight, 1, NormalAttr);
end;

constructor SpreadSheet.Init;
var
  Row : Word;
  Col : Word;
begin
  {Initialize the SpreadList}
  if not SpreadList.InitAbstractDeluxe(19, 5, 50, 20,
                                       DefaultColorSet,
                                       DefWindowOptions or wBordered,
                                       ItemWidth, SpreadSize, SpreadSize,
                                       SingleChoice,
                                       DefPickOptions) then
    Fail;

{$IFDEF UseDragAnyway}
  {Attach the DragProcessor to the PickList}
  SetCommandProcessor(PickCommands);
{$ENDIF}

  {Use vertical dividers}
  EnableDividers(NoFrameChar, #179, NoFrameChar);
  ResizeWindow(-1, 0);

  {Adjust the frame to allow room for row and col headers}
  AdjustFrameCoords(15, 3, 50, 21);

  {Add horizontal and vertical scroll bars}
  wFrame.AddScrollBar(frBB, 0, 0, DefaultColorSet);
  wFrame.AddScrollBar(frRR, 0, 0, DefaultColorSet);

  {Add a title}
  wFrame.AddHeader(' SpreadSheet Demo ', heTC);

{$IFDEF UsingDrag}
  {Add hot spot for zoom}
  wFrame.AddCustomHeader(#24, frtr, -1, 0,
                         DefaultColorSet.HeaderColor,
                         DefaultColorSet.HeaderMono);
  wFrame.AddHotRegion(frTR, ZoomHotCode, -1, 0, 1, 1);
  ZoomHeaderNum := wFrame.GetLastHeaderIndex;

  {Add hot spots for mouse dragging}
  wFrame.AddHotBar(frTT, MoveHotCode);
  wFrame.AddCustomHeader(#240, frbr, 0, 0,
                         DefaultColorSet.FrameColor,
                         DefaultColorSet.FrameMono);
  wFrame.AddHotRegion(frBR, ResizeHotCode, 0, 0, 1, 1);
{$ELSE}
  {Scrolling by line is too slow without dragging}
  pkOptionsOn(pkMousePage);
{$ENDIF}

  {Limit the sizeability for demo purposes}
  SetSizeLimits(23, 4, ScreenWidth, ScreenHeight);
  SetPosLimits(1, 1, ScreenWidth, ScreenHeight-1);

  {Make the cursor visible within the spreadsheet}
  SetCursor(cuNormal);

  {Add a little cosmetic padding}
  SetPadSize(1, 0);

  {Initialize the data associated with the list}
  for Row := 1 to SpreadSize do
    for Col := 1 to SpreadSize do
      Items[Row, Col] := Long2Str(Row*Col);

  {This will force the headers to be written the first time}
  TLRow := 0;
  TLCol := 0;
  SSWid := 0;
  SSHgt := 0;
end;

procedure SpreadSheet.UpdateContents;
begin
  {Call ancestor's UpdateContents first}
  SpreadList.UpdateContents;

  {Update scrolling headers}
  PreMove;
end;

procedure SpreadSheet.ProcessSelf;
var
  Cmd : Word;
begin
  {Handle a few more commands than the default ProcessSelf}
  repeat
    SpreadList.ProcessSelf;
    Cmd := GetLastCommand;
    case Cmd of
      {$IFDEF UsingDrag}
      ccMouseDown : if HandleMousePress(SL) = ZoomHotCode then
                      if SL.IsZoomed then
                        SL.ChangeHeader(ZoomHeaderNum, #18)
                      else
                        SL.ChangeHeader(ZoomHeaderNum, #24);
      {$ENDIF}
      ccChar :   {Add a character to the current cell}
        AddChar;
      ccUser0 :  {Delete last character in current cell}
        DelChar;
      ccQuit, ccUser1..255 :
        {Validate cell before exiting}
        if not ValidItem(GetLastChoice) then begin
          WarnInvalidItem(GetLastChoice);
          {Don't exit loop}
          Cmd := ccNone;
        end;
    end;
    {We don't exit on ccSelect here}
  until Cmd in [ccQuit, ccError, ccUser1..255];
end;

procedure SpreadSheet.ItemString(Item : Word; Mode : pkMode;
                                  var IType : pkItemType;
                                  var IString : String);
begin
  {Just return the item from the data array}
  IString := Items[GetItemRow(Item), GetItemCol(Item)];
end;

procedure SpreadSheet.PreMove;
var
  Row : Word;
  Col : Word;
  Wid : Byte;
  Hgt : Byte;
  Attr : Byte;
  S : String;
begin
  {Call ancestor's PreMove first just in case}
  SpreadList.PreMove;

  {Determine whether scrolling headers need updating}
  TopLeftRowCol(Row, Col);
  Wid := Width;
  Hgt := Height;

  if (Row <> TLRow) or (Hgt <> SSHgt) then begin
    {Need a new set of row headers}
    TLRow := Row;
    SSHgt := Hgt;
    Attr := ColorMono(DefaultColorSet.FrameColor, DefaultColorSet.FrameMono);
    for Row := 1 to Hgt do begin
      S := Long2Str(Row+TLRow-1);
      fFastWrite(LeftPad(S, 2)+' ', Row+1, 1, Attr);
    end;
  end;

  if (Col <> TLCol) or (Wid <> SSWid) then begin
    {Need a new set of column headers}
    TLCol := Col;
    SSWid := Wid;
    Attr := ColorMono(DefaultColorSet.FrameColor, DefaultColorSet.FrameMono);
    S := '';
    for Col := 1 to GetItemCols do begin
      S := S+Pad(' '+Long2Str(TLCol+Col-1), ItemWidth-1);
      {Add a divider bar}
      if Col <> GetItemCols then
        S := S+#179;
    end;
    S := Pad(S, Wid);
    fFastWrite(S, 1, 4, Attr);
  end;
end;

function SpreadSheet.ItemSearch : Boolean;
begin
  {Exit Process if last key entered is not a control character}
  ItemSearch := (Char(GetLastKey) >= ' ');
end;

procedure SpreadSheet.WarnInvalidItem(Item : Word);
begin
  Warn('Empty cells are not acceptable');
end;

function SpreadSheet.ValidItem(Item : Word) : Boolean;
begin
  {Don't accept an empty cell}
  ValidItem := (Length(GetItemString(Item)) > 0);
end;

function SpreadSheet.OKToChangeChoice : Boolean;
var
  Cmd : Word;
  NextChoice : Word;
  NextFirst : Word;
begin
  {Assume it's ok to change choice}
  OKToChangeChoice := True;

  {Determine whether the current choice will actually be changed}
  Cmd := GetLastCommand;
  EvaluateCmd(Cmd, NextChoice, NextFirst);
  if NextChoice = GetLastChoice then
    Exit;

  {Validate item and display a warning if needed}
  if ValidItem(GetLastChoice) then
    OKToChangeChoice := True
  else begin
    WarnInvalidItem(GetLastChoice);
    OKToChangeChoice := False;
  end;
end;

procedure SpreadSheet.PositionCursor(Item : Word; ACol, ARow : Byte);
begin
  {Position the cursor after the last character of the cell's string}
  GotoXYAbs(ACol+Length(Items[GetItemRow(Item), GetItemCol(Item)])+1, ARow);
  {The +1 is because we added 1 column of left padding via SetPadSize}
end;

procedure SpreadSheet.AddChar;
var
  Row : Word;
  Col : Word;
  Ch : Char;
begin
  Ch := Char(Byte(GetLastKey));
  if (Ch < '0') or (Ch > '9') then
    {Accept only numbers}
    Warn('Only numbers are acceptable')
  else begin
    Row := GetItemRow(GetLastChoice);
    Col := GetItemCol(GetLastChoice);
    if Length(Items[Row, Col]) < DataWidth then
      Items[Row, Col] := Items[Row, Col]+Ch;
  end;
end;

procedure SpreadSheet.DelChar;
var
  Row : Word;
  Col : Word;
begin
  Row := GetItemRow(GetLastChoice);
  Col := GetItemCol(GetLastChoice);
  if Length(Items[Row, Col]) > 0 then
    dec(Items[Row, Col][0]);
end;

procedure InitCommands;
begin
{$IFDEF UseMouse}
  if MouseInstalled then begin
    {$IFDEF UsingDrag}
      {$IFDEF UseDragAnyway}
      {Initialize the new DragProcessor}
      if not PickCommands.Init(@PickKeySet, PickKeyMax) then
        Halt;
      {$ENDIF}
      {See-through mouse cursor}
      PickCommands.SetScreenMask($FFFF);
      PickCommands.SetMouseCursor($7700, $7700, $7700);
    {$ELSE}
      {Enable the mouse with a see-through cursor}
      PickCommands.cpOptionsOn(cpEnableMouse);
      SoftMouseCursor($FFFF, $7700);
    {$ENDIF}
  end;
{$ENDIF}

  {Add backspace as an exit command}
  PickCommands.AddCommand(ccUser0, 1, Byte(^H), 0);
end;

begin
  {Initialize the screen}
  TextChar := BackChar;
  ClrScr;

  {Customize the PickList command processor}
  InitCommands;

  {Initialize the SpreadSheet object}
  SL.Init;
  if InitStatus <> 0 then begin
    WriteLn('Error initializing SpreadSheet');
    Halt;
  end;

  {Process it}
  SL.Process;
  SL.Erase;
  SL.Done;
end.