Power-Programmierung/CD1.mdf/pascal/library/dos/strings/qwrite/qwriter.pas

Pascal/Delphi Source File | 1992-03-10 | 18.1 KB | 525 lines

 {$A+,B-,D-,E-,F-,I+,N-,O-,R+,S-,V+}

(****************************************************************************)
(* QWRITER.PAS - Quick screen writing unit.                                 *)
(* version 1.1 (March 10, 1992)                                             *)
(* TP required: 6.0                                                         *)
(* by Guy McLoughlin                                                        *)
(* Released to the public domain.                                           *)
(****************************************************************************)

unit Qwriter;      (* Unit to write Strings directly to the Video-buffer.   *)

(****************************************************************************)
 interface
(****************************************************************************)

const              (* Set these constants according to the text-screen size *)
                   (* you are using.                                        *)
  Rows      = 25;
  Columns   = 80;
  ClearSize = (Rows shl 8) + Columns;

                   (* ReadKeyWord constants.                                *)

  AnyKey        = 0;

  BackSpaceKey  =  3592;
  TabKey        =  3849;
  EnterKey      =  7181;
  EscapeKey     =   283;
  SpaceBarKey   = 14624;

  F1Key         = 15104;
  F2Key         = 15360;
  F3Key         = 15616;
  F4Key         = 15872;
  F5Key         = 16128;
  F6Key         = 16384;
  F7Key         = 16640;
  F8Key         = 16896;
  F9Key         = 17152;
  F10Key        = 17408;

  HomeKey       = 18176;
  EndKey        = 20224;
  PageUpKey     = 18688;
  PageDownKey   = 20736;

  UpArrowKey    = 18432;
  DownArrowKey  = 20480;
  RightArrowKey = 19712;
  LeftArrowKey  = 19200;

  InsertKey     = 20992;
  DeleteKey     = 21248;


                   (* Boolean constants.                                    *)
  On  = true;
  Off = false;


type               (* Maximum length of display string.                     *)
  VidString = string[Columns];


var                (* Boolean use to check Video-Mode.                      *)
  ColorMode : boolean;

  NormAttr,        (* Normal text-attribute variable.                       *)
  RevAttr : word;  (* Reversed text-attribute variable.                     *)


(****************************************************************************)
(*  Unit Routines                                                           *)
(****************************************************************************)

                   (* Read a key-press.                                     *)
  function ReadKeyChar : char;

                   (* Read key and scan-code at once.                       *)
  function ReadKeyWord : word;


                   (* Clear the keyboard-buffer.                            *)
  procedure ClearKeyBuff;


                   (* Wait for specific key to be pressed.                  *)
  procedure Pause(Key : word);


                   (* Standard PC beep.                                     *)
  procedure Beep;


                   (* Convert an integer-type to a string-type.             *)
  function Int2Str(Number : longint; Width : byte) : VidString;


                   (* Convert a real-type to a string-type.                 *)
  function Real2Str(Number : real;
                    Width, Decimals : byte) : VidString;


                   (* Hide or show cursor.                                  *)
  procedure HideCursor(Switch : boolean);


                   (* Clear screen using a specific color attribute.        *)
  procedure ClearScr(Attr : byte);


                   (* Turn the "blink-bit" off to allow 16 different        *)
                   (* background colors. WORKS FOR EGA+ VIDEO MODES ONLY!   *)
  procedure BlinkBit(Switch : boolean);


                   (* Procedure to write directly to the video-buffer at    *)
                   (* Xaxis, Yaxis, using Cattr color-attribute.            *)
  procedure Qwrite(InString : VidString;
                   Xaxis, Yaxis : byte;
                   Cattr : word);


                   (* Procedure to vertically write directly to the video-  *)
                   (* buffer at Xaxis, Yaxis, using Cattr color-attribute.  *)
  procedure VQwrite(InString : VidString;
                    Xaxis, Yaxis : byte;
                    Cattr : word);


                   (* Procedure to change video-buffer color attributes,    *)
                   (* at Xaxis, Yaxis, using Cattr color-attribute.         *)
  procedure ChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);


                   (* Procedure to vertically change video-buffer color     *)
                   (* attributes, at Xaxis, Yaxis, using Cattr color-       *)
                   (* attribute.                                            *)
  procedure VChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);


                   (* Function to create a hi-light bar "pick-list" menu.   *)
  function PickIt(TopY,                          (* Top Y axis position.    *)
                  BotY,                          (* Bottom Y axis position. *)
                  Xaxis,                         (* X axis position.        *)
                  HiLightBarSize : byte;         (* Length of hi-light bar. *)
                  NormalAttr,                    (* Normal attribute.       *)
                  HiLightBarAttr : word) : word; (* Hi-light bar attribute. *)


(****************************************************************************)
 implementation
(****************************************************************************)

var
  VidAddr : word;  (* Video-buffer address variable.                        *)

                   (* Set the Video-buffer address.                         *)
  procedure SetVideoAddress;
  begin
    if ((Mem[$0000:$0410] and $30) <> $30) then
      begin
        VidAddr := $B800;   (* Color video mode.                            *)
        ColorMode := true;
        NormAttr := $17;    (* Lightgray text on a blue background.         *)
        RevAttr := $71      (* Blue text on a lightgray background.         *)
      end
    else
      begin
        VidAddr := $B000;   (* Monochrome video mode.                       *)
        ColorMode := false;
        NormAttr := $07;    (* Lightgray text on a black background.        *)
        RevAttr := $70      (* Black text on a lightgray background.        *)
      end
  end;


                   (* Read a key-press.                                     *)
  function ReadKeyChar : char; assembler;
  asm
    mov ah, 0
    int 16h
  end;


                   (* Read standard and extended key codes at once.         *)
  function ReadKeyWord : word; assembler;
  asm
    mov ah, 0
    int 16h
  end;


                   (* Clear the keyboard-buffer.                            *)
  procedure ClearKeyBuff; assembler;
  asm
    @1: mov ah, 1
        int 16h
        jz  @2
        mov ah, 0
        int 16h
        jmp @1
    @2:
  end;


                   (* Function to indicate if a key is in the keyboard      *)
                   (* buffer.                                               *)
  function KeyPressed : boolean; assembler;
  asm
    mov ah, 1
    int 16h
    mov ax, 0
    jz @1
    inc ax
    @1:
  end;


                   (* Wait for specific key to be pressed.                  *)
  procedure Pause(Key : word);
  begin
    ClearKeyBuff;
    if (Key = AnyKey) then
      repeat until(Keypressed)
    else
      repeat until(ReadKeyWord = Key)
  end;


                   (* Standard PC beep.                                     *)
  procedure Beep;
  begin
    write(#7)
  end;


                   (* Convert an integer-type to a string-type.             *)
  function Int2Str(Number : longint; Width : byte) : VidString;
  var
    TempString : VidString;
  begin
    Str(Number:Width, TempString);
    Int2Str := TempString
  end;


                   (* Convert a real-type to a string-type.                 *)
  function Real2Str(Number : real;
                    Width, Decimals : byte) : VidString;
  var
    TempString : VidString;
  begin
    Str(Number:Width:Decimals, TempString);
    Real2Str := TempString
  end;


                   (* Hide or show cursor.                                  *)
  procedure HideCursor(Switch : boolean);
  begin
    if (Switch = true) then
      asm mov CX, 2000h end
    else
      if ColorMode then
        asm mov CX, 0607h end
      else
        asm mov CX, 0C0Dh end;
    asm
      mov AX, 0100h
      int 10h
    end
  end;


                   (* Clear screen using a specific color.                  *)
  procedure ClearScr(Attr : byte); assembler;
  asm
    mov bh, Attr
    xor cx, cx
    mov dx, ClearSize
    mov ah, 7
    mov al, 25
    int 10h
    mov ah, 2
    mov bh, 0
    xor dx, dx
    int 10h
  end;


                   (* Turn the "blink-bit" off to allow 16 different        *)
                   (* background colors. WORKS FOR EGA+ VIDEO MODES ONLY!   *)
  procedure BlinkBit(Switch : boolean); assembler;
  asm
    mov AX, 1003h
    mov Bl, Switch
    int 10h
  end;


                   (* Procedure to write directly to the video-buffer at    *)
                   (* Xaxis, Yaxis, using Cattr color-attribute.            *)
  procedure Qwrite(InString : VidString;
                   Xaxis, Yaxis : byte;
                   Cattr : word);
  var
    IsIndex   : byte;        (* InString position index.                    *)
    VidOffset : word;        (* Video-address offset position.              *)
  begin
                   (* If InString is empty then exit procedure.             *)
    if InString = '' then
      exit;
                   (* Stop any illeagal Xaxis, Yaxis positions.             *)
    if Columns < (Xaxis + length(InString)) then
      Xaxis := Columns - length(InString);
    if Rows < Yaxis then
      Yaxis := Rows;

                   (* Calculate the offset into the video-buffer array.     *)
    VidOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2);

                   (* Make sure string is not too long!                     *)
    if ((length(InString) + Xaxis) > Columns) then
      InString[0] := chr((Columns + 1) - Xaxis);

                   (* Write string to video-buffer.                         *)
    for IsIndex := 0 to (length(InString) - 1) do
      MemW[VidAddr : (VidOffset + (IsIndex * 2))] :=
          (Cattr shl 8) + byte(InString[IsIndex + 1]);
  end;

                   (* Procedure to vertically write directly to the video-  *)
                   (* buffer at Xaxis, Yaxis, using Cattr color-attribute.  *)
  procedure VQwrite(InString : VidString;
                    Xaxis, Yaxis : byte;
                    Cattr : word);
  var
    IsIndex   : byte; (* InString position index.                           *)
    VidOffset : word; (* Video-address offset position.                     *)
  begin
                   (* If InString is empty then exit procedure.             *)
    if InString = '' then
      exit;
                   (* Stop any illeagal Xaxis, Yaxis positions.             *)
    if Columns < Xaxis then
      Xaxis := Columns;
    if Rows < Yaxis then
      Yaxis := Rows;

                   (* Calculate the offset into the video-buffer array.     *)
    VidOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2);

                   (* Make sure string is not too long!                     *)
    if ((length(InString) + Yaxis) > Rows) then
      InString[0] := chr((Rows + 1) - Yaxis);

                   (* Write string to screen.                               *)
    for IsIndex := 0 to (length(InString) - 1) do
      MemW[VidAddr : (VidOffset + (IsIndex * Columns * 2))] :=
          (Cattr shl 8) + byte(InString[IsIndex + 1]);
  end;


                   (* Procedure to change video-buffer color attributes,    *)
                   (* at Xaxis, Yaxis, using Cattr color-attribute.         *)
  procedure ChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
  var
    AttrIndex,
    AttrOffset  : word;
  begin
                   (* Stop any illeagal Xaxis, Yaxis positions.             *)
    if (Yaxis > Rows) then
      Yaxis := Rows;
    if (Xaxis > Columns) then
      Xaxis := Columns;

                   (* Calculate the offset into the video-buffer array.     *)
    AttrOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2) + 1;

                   (* Make sure the number of attributes to change is not   *)
                   (* too many.                                             *)
    if (AttrsToChange > (Columns - Xaxis)) then
      AttrsToChange := (Columns - Xaxis) + 1;

                   (* Change color attributes in the video-buffer array.    *)
    for AttrIndex := 0 to (AttrsToChange - 1) do
      Mem[VidAddr : (AttrOffset + (AttrIndex * 2))] := Cattr
  end;


                   (* Procedure to vertically change video-buffer color     *)
                   (* attributes, at Xaxis, Yaxis, using Cattr color-       *)
                   (* attribute.                                            *)
  procedure VChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
  var
    AttrIndex,
    AttrOffset  : word;
  begin
                   (* Stop any illeagal Xaxis, Yaxis positions.             *)
    if (Yaxis > Rows) then
      Yaxis := Rows;
    if (Xaxis > Columns) then
      Xaxis := Columns;

                   (* Calculate the offset into the video-buffer array.     *)
    AttrOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2) + 1;

                   (* Make sure the number of attributes to change is not   *)
                   (* too many.                                             *)
    if (AttrsToChange > (Rows - Yaxis)) then
      AttrsToChange := (Rows - Yaxis) + 1;

                   (* Change color attributes in the video-buffer array.    *)
    for AttrIndex := 0 to (AttrsToChange - 1) do
      Mem[VidAddr : (AttrOffset + (AttrIndex * Columns * 2))] := Cattr
  end;


                   (* Function to create a hi-light bar "pick-list" menu.   *)
  function PickIt(TopY,                          (* Top Y axis position.    *)
                  BotY,                          (* Bottom Y axis position. *)
                  Xaxis,                         (* X axis position.        *)
                  HiLightBarSize : byte;         (* Length of hi-light bar. *)
                  NormalAttr,                    (* Normal attribute.       *)
                  HiLightBarAttr : word) : word; (* Hi-light bar attribute. *)
  var
    Quit,
    EscapeQuit,
    MoveHiLightBar : boolean;
    BarOffset      : byte;
    DUD            : char;
  begin
                   (* Initialize PickIt variables.                          *)
    Quit := false;
    EscapeQuit := false;
    BarOffset := 0;
    MoveHiLightBar := true;

                   (* Repeat..Until it's time to quit.                      *)
    repeat

                   (* Clear key-buffer.                                     *)
      ClearKeyBuff;

                   (* Display / re-display the hi-light bar.                *)
      if MoveHiLightBar then
        ChangeAttr(HiLightBarSize, Xaxis, (TopY + BarOffset), HiLightBarAttr);

                   (* Get User key choice.                                  *)
      case ReadKeyWord of

        UpArrowKey,
        LeftArrowKey  : begin
                   (* Hide hi-light bar.                                    *)
                          ChangeAttr(HiLightBarSize,
                                     Xaxis, (TopY + BarOffset), NormalAttr);

                   (* Set "MoveHiLightBar" boolean.                         *)
                          MoveHiLightBar := true;

                   (* If hi-light bar is NOT in the starting position, then *)
                   (* decrement it's position by one.                       *)
                          if (BarOffset > 0) then
                            dec(BarOffset, 1)

                   (* Else, if hi-light bar IS in the starting position,    *)
                   (* then move it to the LAST position.                    *)
                          else
                            BarOffset := (BotY - TopY)
                        end;

        DownArrowKey,
        RightArrowKey : begin
                   (* Hide hi-light bar.                                    *)
                          ChangeAttr(HiLightBarSize,
                                     Xaxis, (TopY + BarOffset), NormalAttr);

                   (* Set "MoveHiLightBar" boolean.                         *)
                          MoveHiLightBar := true;

                   (* If hi-light bar is NOT in the LAST position, then     *)
                   (* increment it's position by one.                       *)
                          if (BarOffset < (BotY - TopY)) then
                            inc(BarOffset, 1)

                   (* Else, if hi-light bar IS in the LAST position, then   *)
                   (* move it to the starting position.                     *)
                          else
                            BarOffset := 0
                        end;

                   (* <ENTER> key pressed, quit-pick loop.                  *)
        EnterKey   : Quit := true;

                   (* <ESC> key pressed, quit pick-loop.                    *)
        EscapeKey  : EscapeQuit := true

                   (* Else, discard User's key choice.                      *)
        else
          MoveHiLightBar := false
      end

                   (* Repeat..Until it's time to quit.                      *)
    until (Quit or EscapeQuit);

                   (* If the User pressed the <ESC> key, then return 0.     *)
    if EscapeQuit then
      PickIt := 0

                   (* Else, return the hi-light bar position.               *)
    else
      PickIt := BarOffset + 1
  end;


BEGIN
  SetVideoAddress
END.