DataMuseum.dk

top - metrics - download

    Length: 8016 (0x1f50)
    Types: TextFile
    Names: »MCDISPLY.PAS«

└─⟦505fbc898⟧ Bits:30002732 Turbo Pascal 5.0 for C-DOS Partner
    └─⟦this⟧ »MCALC\MCDISPLY.PAS« 

TextFile

æ Copyright (c) 1985, 88 by Borland International, Inc. å

unit MCDISPLY;

interface

uses Crt, Dos, MCVars, MCUtil;

var
  InsCursor, ULCursor, NoCursor, OldCursor : Word;

procedure MoveToScreen(var Source, Dest; Len : Word);
æ Moves memory to screen memory å

procedure MoveFromScreen(var Source, Dest; Len : Word);
æ Moves memory from screen memory å

procedure WriteXY(S : String; Col, Row : Word);
æ Writes text in a particular location å

procedure MoveText(OldX1, OldY1, OldX2, OldY2, NewX1, NewY1 : Word);
æ Moves text from one location to another å

procedure Scroll(Direction, Lines, X1, Y1, X2, Y2, Attrib : Word);
æ Scrolls an area of the screen å

function GetCursor : Word;
æ Returns the current cursor å

procedure SetCursor(NewCursor : Word);
æ Sets a new cursor å

function GetSetCursor(NewCursor : Word) : Word;
æ Sets a new cursor and returns the current one å

procedure SetColor(Color : Word);
æ Sets the foreground and background color based on a single color å

procedure PrintCol;
æ Prints the column headings å

procedure PrintRow;
æ Prints the row headings å

procedure ClearInput;
æ Clears the input line å

procedure ChangeCursor(InsMode : Boolean);
æ Changes the cursor shape based on the current insert mode å

procedure ShowCellType;
æ Prints the type of cell and what is in it å

procedure PrintFreeMem;
æ Prints the amount of free memory å

procedure ErrorMsg(S : String);
æ Prints an error message at the bottom of the screen å

procedure WritePrompt(Prompt : String);
æ Prints a prompt on the screen å

function EGAInstalled : Boolean;
æ Tests for the presence of an EGA å

implementation

const
  MaxLines = 43;

type
  ScreenType = arrayÆ1..MaxLines, 1..80Å of Word;
  ScreenPtr = ^ScreenType;

var
  DisplayPtr : ScreenPtr;

procedure MoveToScreen; external;

procedure MoveFromScreen; external;

æ$L MCMVSMEM.OBJå

procedure WriteXY;
begin
  GotoXY(Col, Row);
  Write(S);
end; æ WriteXY å

procedure MoveText;
var
  Counter, Len : Word;
begin
  Len := Succ(OldX2 - OldX1) shl 1;
  if NewY1 < OldY1 then
  begin
    for Counter := 0 to OldY2 - OldY1 do
      MoveFromScreen(DisplayPtr^ÆOldY1 + Counter, OldX1Å,
                     DisplayPtr^ÆNewY1 + Counter, NewX1Å, Len)
  end
  else begin
    for Counter := OldY2 - OldY1 downto 0 do
      MoveFromScreen(DisplayPtr^ÆOldY1 + Counter, OldX1Å,
                     DisplayPtr^ÆNewY1 + Counter, NewX1Å, Len)
  end;
end; æ MoveText å

procedure Scroll;
begin
  if Lines = 0 then
    Window(X1, Y1, X2, Y2)
  else begin
    case Direction of
      UP : begin
        MoveText(X1, Y1 + Lines, X2, Y2, X1, Y1);
        Window(X1, Succ(Y2 - Lines), X2, Y2);
      end;
      DOWN : begin
        MoveText(X1, Y1, X2, Y2 - Lines, X1, Y1 + Lines);
        Window(X1, Y1, X2, Pred(Y1 + Lines));
      end;
      LEFT : begin
        MoveText(X1 + Lines, Y1, X2, Y2, X1, Y1);
        Window(Succ(X2 - Lines), Y1, X2, Y2);
      end;
      RIGHT : begin
        MoveText(X1, Y1, X2 - Lines, Y2, X1 + Lines, Y1);
        Window(X1, Y1, Pred(X1 + Lines), Y2);
      end;
    end; æ case å
  end;
  SetColor(Attrib);
  ClrScr;
  Window(1, 1, 80, ScreenRows + 5);
end; æ Scroll å

function GetCursor;
var
  Reg : Registers;
begin
  with Reg do
  begin
    AH := 3;
    BH := 0;
    Intr($10, Reg);
    GetCursor := CX;
  end; æ Reg å
end; æ GetCursor å

procedure SetCursor;
var
  Reg : Registers;
begin
  with Reg do
  begin
    AH := 1;
    BH := 0;
    CX := NewCursor;
    Intr($10, Reg);
  end; æ with å
end; æ SetCursor å

function GetSetCursor;
begin
  GetSetCursor := GetCursor;
  SetCursor(NewCursor);
end; æ GetSetCursor å

procedure SetColor;
begin
  TextAttr := ColorTableÆColorÅ;
end; æ SetColor å

procedure InitColorTable(BlackWhite : Boolean);
æ Sets up the color table å
var
  Color, FG, BG, FColor, BColor : Word;
begin
  if not BlackWhite then
  begin
    for Color := 0 to 255 do
      ColorTableÆColorÅ := Color;
  end
  else begin
    for FG := Black to White do
    begin
      case FG of
        Black : FColor := Black;
        Blue..LightGray : FColor := LightGray;
        DarkGray..White : FColor := White;
      end; æ case å
      for BG := Black to LightGray do
      begin
        if BG = Black then
          BColor := Black
        else begin
          if FColor = White then
            FColor := Black;
          BColor := LightGray;
        end;
        ColorTableÆFG + (BG shl 4)Å := FColor + (BColor shl 4);
      end;
    end;
    for FG := 128 to 255 do
      ColorTableÆFGÅ := ColorTableÆFG - 128Å or $80;
  end;
end; æ InitColorTable å

procedure PrintCol;
var
  Col : Word;
begin
  Scroll(UP, 0, 1, 2, 80, 2, HEADERCOLOR);
  for Col := LeftCol to RightCol do
    WriteXY(CenterColString(Col), ColStartÆSucc(Col - LeftCol)Å, 2);
end; æ PrintCol å

procedure PrintRow;
var
  Row : Word;
begin
  SetColor(HEADERCOLOR);
  for Row := 0 to Pred(ScreenRows) do
    WriteXY(Pad(WordToString(Row + TopRow, 1), LEFTMARGIN), 1, Row + 3);
end; æ PrintRow å

procedure ClearInput;
begin
  SetColor(TXTCOLOR);
  GotoXY(1, ScreenRows + 5);
  ClrEol;
end; æ ClearInput å

procedure ChangeCursor;
begin
  if InsMode then
    SetCursor(InsCursor)
  else
    SetCursor(ULCursor);
end; æ ChangeCursor å

procedure ShowCellType;
var
  ColStr : StringÆ2Å;
  S : IString;
  Color : Word;
begin
  FormDisplay := not FormDisplay;
  S := CellString(CurCol, CurRow, Color, NOFORMAT);
  ColStr := ColString(CurCol);
  SetColor(CELLTYPECOLOR);
  GotoXY(1, ScreenRows + 3);
  if CurCell = Nil then
    Write(ColStr, CurRow, ' ', MSGEMPTY, ' ':10)
  else begin
    case CurCell^.Attrib of
    TXT :
      Write(ColStr, CurRow, ' ', MSGTEXT, ' ':10);
    VALUE :
      Write(ColStr, CurRow, ' ', MSGVALUE, ' ':10);
    FORMULA :
      Write(ColStr, CurRow, ' ', MSGFORMULA, ' ':10);
    end; æ case å
  end;
  SetColor(CELLCONTENTSCOLOR);
  WriteXY(Pad(S, 80), 1, ScreenRows + 4);
  FormDisplay := not FormDisplay;
end; æ ShowCellType å

procedure PrintFreeMem;
begin
  SetColor(MEMORYCOLOR);
  GotoXY(Length(MSGMEMORY) + 2, 1);
  Write(MemAvail:6);
end; æ PrintFreeMem å

procedure ErrorMsg;
var
  Ch : Char;
begin
  Sound(1000);    æ Beeps the speaker å
  Delay(500);
  NoSound;
  SetColor(ERRORCOLOR);
  WriteXY(S + '  ' + MSGKEYPRESS, 1, ScreenRows + 5);
  GotoXY(Length(S) + Length(MSGKEYPRESS) + 3, ScreenRows + 5);
  Ch := ReadKey;
  ClearInput;
end; æ ErrorMsg å

procedure WritePrompt;
begin
  SetColor(PROMPTCOLOR);
  GotoXY(1, ScreenRows + 4);
  ClrEol;
  Write(Prompt);
end; æ WritePrompt å

procedure InitDisplay;
æ Initializes various global variables - must be called before using the
  above procedures and functions.
å
var
  Reg : Registers;
begin
  Reg.AH := 15;
  Intr($10, Reg);
  ColorCard := Reg.AL <> 7;
  if ColorCard then
    DisplayPtr := Ptr($B800, 0)
  else
    DisplayPtr := Ptr($B000, 0);
  InitColorTable((not ColorCard) or (Reg.AL = 0) or (Reg.AL = 2));
end; æ InitDisplay å

function EGAInstalled;
var
  Reg : Registers;
begin
  Reg.AX := $1200;
  Reg.BX := $0010;
  Reg.CX := $FFFF;
  Intr($10, Reg);
  EGAInstalled := Reg.CX <> $FFFF;
end; æ EGAInstalled å

begin
  InitDisplay;
  NoCursor := $2000;
  OldCursor := GetSetCursor(NoCursor);
  OldMode := LastMode;
  if (LastMode and Font8x8) <> 0 then
    ScreenRows := 38
  else
    ScreenRows := 20;
  Window(1, 1, 80, ScreenRows + 5);
  if ColorCard then
  begin
    ULCursor := $0607;
    InsCursor := $0507;
  end
  else begin
    ULCursor := $0B0C;
    InsCursor := $090C;
  end;
  if EGAInstalled then
  begin
    UCommandString := UCOMMAND;
    UMenuString := UMNU;
  end
  else begin
    UCommandString := Copy(UCOMMAND, 1, 2);
    UMenuString := Copy(UMNU, 1, 23);
  end;
end.
«eof»