UNIT PascalCrt;

{$Projekt Windows

  Implementierung des Standard-Units "Crt" in Pascal

  Jens Gelhar 07/90

}

INTERFACE

CONST
  { IDCMP-Flags }
  NEWSIZE=$00000002;
  REFRESHWINDOW=$00000004;
  MOUSEBUTTONS=$00000008;
  MOUSEMOVE=$00000010;
  GADGETDOWN=$00000020;
  GADGETUP=$00000040;
  REQSET=$00000080;
  MENUPICK=$00000100;
  _CLOSEWINDOW=$00000200;
  RAWKEY=$00000400;
  REQVERIFY=$00000800;
  REQCLEAR=$00001000;
  MENUVERIFY=$00002000;
  NEWPREFS=$00004000;
  DISKINSERTED=$00008000;
  DISKREMOVED=$00010000;
  WBENCHMESSAGE=$00020000;
  ACTIVEWINDOW=$00040000;
  INACTIVEWINDOW=$00080000;
  DELTAMOVE=$00100000;
  VANILLAKEY=$00200000;
  INTUITICKS=$00400000;


PROCEDURE WaitForKey    ;
FUNCTION  KeyPressed    : Boolean;
FUNCTION  WindowClosed  : Boolean;
FUNCTION  ReadKey       : Char;
FUNCTION  CrtRastPort   : Ptr;
FUNCTION  CrtUserPort   : Ptr;
FUNCTION  CrtWindow     : Ptr;
FUNCTION  CrtMessage    : Ptr;
FUNCTION  CrtConsole    : Ptr;
FUNCTION  NameOfProgram : Str;
FUNCTION  MessageReceived (Class:LongInt): Boolean;
PROCEDURE SetIDCMP (Class: LongInt);
PROCEDURE AddIDCMP (Class: LongInt);
PROCEDURE SubIDCMP (Class: LongInt);
FUNCTION  TextLines     : integer;
FUNCTION  TextColms     : integer;
FUNCTION  WhereX        : integer;
FUNCTION  WhereY        : integer;
PROCEDURE WindowTitles (window, screen: Str);

IMPLEMENTATION

{$opt q ;
  include "exec/tasks.h",
          "libraries/dosextens.h",
          "workbench/startup.h" }


TYPE

p_Window = ^Window;

p_Screen = ^Screen;

p_IntuiMessage = ^IntuiMessage;

p_TextFont = ^TextFont;

IntuiMessage = Record
 ExecMessage    : Message;
 Class          : Long;
 Code,Qualifier : Word;
 IAddress       : Ptr;
 MouseX,MouseY  : integer;
 Seconds,Micros : Long;
 IDCMPWindow    : p_Window;
 SpecialLink    : p_IntuiMessage
End;

p_RastPort=^RastPort;
RastPort=Record
 Layer : Ptr;
 BitMap : Ptr
 AreaPtrn : Ptr;
 TmpRas : Ptr
 AreaInfo : Ptr
 GelsInfo : Ptr
 Mask : Byte;
 FgPen, BgPen, AOlPen, DrawMode, AreaPtSz, linpatcnt, dummy : Short;
 Flags, LinePtrn : Word;
 cp_x, cp_y : integer;
 minterms : Array[0..7]of Byte;
 PenWidth,PenHeight : integer;
 Font : Ptr;
 AlgoStyle,TxFlags : Byte;
 TxHeight,TxWidth,TxBaseline : Word;
 TxSpacing : integer;
 RP_User : Ptr;
End;

Screen = RECORD
  NextScreen:p_Screen;
  FirstWindow:p_Window;
  LeftEdge,TopEdge,Width,Height,MouseY,MouseX:integer;
  Flags:Word;
  Title,DefaultTitle:Str;
END;

Window = RECORD
  NextWindow:p_Window;
  LeftEdge,TopEdge,Width,Height:integer;
  MouseY,MouseX,MinWidth,MinHeight:integer;
  MaxWidth,MaxHeight:Word;
  Flags : Long;
  MenuStrip : Ptr;
  Title : Str;
  FirstRequest,DMRequest : Ptr;
  ReqCount : integer;
  WScreen : p_Screen;
  RPort : p_RastPort;
  BorderLeft,BorderTop,BorderRight,BorderBottom : Short;
  BorderRPort : Ptr;
  FirstGadget : Ptr;
  Parent, Descendant : p_Window;
  Pointer : Ptr;
  PtrHeight,PtrWidth,XOffset,YOffset : Short;
  IDCMPFlags : Long;
  UserPort,WindowPort : Ptr;
  MessageKey : p_IntuiMessage;
  DetailPen, BlockPen : Byte;
  CheckMark : Ptr;
  ScreenTitle : Str;
  GZZMouseX, GZZMouseY, GZZWidth, GZZHeight : integer;
  ExtData : Ptr;
  UserData : Ptr;
  WLayer : Ptr;
  IFont : p_TextFont
END;

TextFont=Record
 tf_Message:Message;
 tf_YSize:Word;
 tf_Style,tf_Flags:Byte;
 tf_XSize,tf_Baseline,tf_BoldSmear,tf_Accessors:Word;
 tf_LoChar,tf_HiChar:Byte;
 tf_CharData:Ptr;
 tf_Modulo:Word;
 tf_CharLoc,tf_CharSpace,tf_CharKern:Ptr
End;


VAR Win      : p_Window;
    Con      : Ptr;
    MsgClass : LongInt;
    IntBase  : ^RECORD { reduced Form of IntuitionBase-Structure }
                  Pad: ARRAY[1..60] OF BYTE;
                  FirstScr:p_Screen
                END;
    IDCMP    : LongInt;
    ReceivedMessage: p_IntuiMessage;

LIBRARY IntBase:
  -150: PROCEDURE ModifyIDCMP (a0:p_Window; d0:LongInt);
  -276: PROCEDURE SetWindowTitles (a0:p_Window; a1,a2:Str);
  -342: PROCEDURE WBenchToFront;
END;


PROCEDURE SetIDCMP;
  BEGIN
    IDCMP := Class;
    ModifyIDCMP (Win, Class);
  END;


PROCEDURE AddIDCMP;
  BEGIN
    SetIDCMP (IDCMP Or Class)
  END;


PROCEDURE SubIDCMP;
  BEGIN
    SetIDCMP (IDCMP And Not Class)
  END;


PROCEDURE ForgetMessage;
  BEGIN
    MsgClass := 0;
    IF ReceivedMessage<>Nil THEN
      BEGIN
        Reply_Msg( ReceivedMessage );
        ReceivedMessage := Nil
      END;
  END;


FUNCTION KeyPressed;
  LIBRARY SysBase:
   -468: FUNCTION CheckIO(a1:LongInt):Ptr
  END;
 BEGIN
   IF MsgClass <> 0 THEN
     KeyPressed := True
   ELSE
     BEGIN
       ReceivedMessage := Get_Msg(Win^.UserPort);
       IF ReceivedMessage=Nil THEN
         KeyPressed := CheckIO( Long(Con)+16 )<>Nil
       ELSE
         BEGIN
           MsgClass := ReceivedMessage^.Class;
           KeyPressed := True
         END
     END;
 END;


FUNCTION MessageReceived;
  BEGIN
    MessageReceived := MsgClass And Class <> 0
  END;


FUNCTION WindowClosed;
  BEGIN
    WindowClosed := MessageReceived(_CLOSEWINDOW)
  END;


PROCEDURE WaitForKey;
  VAR Sig: LongInt;
  BEGIN
    ForgetMessage;
    REPEAT
      IF NOT KeyPressed THEN Sig := Wait(-1)
    UNTIL KeyPressed;
  END;


FUNCTION ReadKey;
  BEGIN
    WaitForKey;
    ReadKey := ReadCon(Con);
  END;


FUNCTION CrtRastPort;
  BEGIN
    CrtRastPort := Win^.RPort
  END;


FUNCTION CrtUserPort;
  BEGIN
    CrtUserPort := Win^.UserPort
  END;


FUNCTION CrtWindow;
  BEGIN
    CrtWindow := Win
  END;


FUNCTION CrtConsole;
  BEGIN
    CrtConsole := Con
  END;


FUNCTION CrtMessage;
  BEGIN
    CrtMessage := ReceivedMessage
  END;


FUNCTION  TextLines;
  BEGIN
    TextLines := Win^.GZZHeight DIV Win^.IFont^.tf_YSize
  END;


FUNCTION  TextColms;
  BEGIN
    TextColms := Win^.GZZWidth DIV Win^.IFont^.tf_XSize
  END;


PROCEDURE ReceiveWindowStatus(VAR x,y:integer);
  Var c:Char;
  BEGIN
    While KeyPressed Do c:=ReadKey;
    Write(#$9b$36$6e);
    Repeat c:=ReadKey Until c=#$9b;
    y := 0;
    c := ReadKey;
    While c In ['0'..'9'] Do
      Begin
        y := 10*y+ord(c)-ord('0');
        c := ReadKey
      End;
    x := 0;
    c := ReadKey;
    While c In ['0'..'9'] Do
      Begin
        x := 10*x+ord(c)-ord('0');
        c := ReadKey
      End;
  END;


FUNCTION  WhereX;
  Var x,y: integer;
  BEGIN
    ReceiveWindowStatus(x,y);
    WhereX := x;
  END;


FUNCTION  WhereY;
  Var x,y: integer;
  BEGIN
    ReceiveWindowStatus(x,y);
    WhereY := y
  END;


FUNCTION NameOfProgram;
  TYPE BCPLStrPtr = ^BCPLStr;
       BCPLStr = ARRAY [ 0.. MaxByte ] OF Char;
  VAR ThisTask: p_Task;
      ThisProc: p_Process;
      ThisCLI : p_CommandLineInterface;
      ThisName: BCPLStrPtr;
      ProgrammName: STRING;
      sm: ^WBStartup;

  PROCEDURE UnpackStr( VAR BCPL: BCPLStr; VAR Name: STRING );
    { BCPL verwaltet Strings mit Längenbyte am Anfang, Pascal mit
      Nullbyte am Ende. Diese Procedure wandelt einen BCPL-String in
      einen Pascal-String. Der BCPL-String wird lediglich aus
      Geschwindigkeitsgründen als VAR-Parameter übergeben, ein Value-
      Parameter wäre ebenfalls möglich. }
    VAR s: Str;
    BEGIN
      s := Str( ^BCPL[1] );   { Zeiger auf erstes "echtes" Zeichen des Strings }
      Name := s;              { Zeichen des Strings übertragen }
      Name[ ord( BCPL[0] ) + 1 ] := chr( 0 )  { Nullbyte ans Ende setzen }
    END;

  BEGIN
    ThisTask := FindTask(Nil);
    ThisProc := p_Process(ThisTask);
    IF ThisProc^.pr_CLI <> 0 THEN
      BEGIN
        ThisCLI  := Ptr( 4*ThisProc^.pr_CLI );
        ThisName := BCPLStrPtr( 4*ThisCli^.cli_CommandName );
        UnpackStr( ThisName^, ProgrammName );
      END
    ELSE
      BEGIN
        sm := StartupMessage;
        IF (sm = NIL) OR (sm^.sm_ArgList = NIL) OR Not FromWB THEN
          ProgrammName := 'Kickpascal'
        ELSE
          ProgrammName := sm^.sm_Arglist^[1].wa_Name
      END;
    NameOfProgram := ProgrammName
  END;


PROCEDURE WindowTitles;
  BEGIN
    SetWindowTitles(Win, window, screen)
  END;


{ ***************   Exit-Part   *************** }

PROCEDURE CloseCrt;
  BEGIN
    SetStdIO (Nil);
    ForgetMessage;
    CloseConsole (Con);
    Close_Window (Win);
    CloseLib (IntBase);
  END;

{ ***************   Init-Part   *************** }

VAR Name: STRING;  STATIC;

BEGIN
  Name := NameOfProgram;
  IDCMP := _CLOSEWINDOW;
  OpenLib (IntBase, 'intuition.library', 0);
  WBenchToFront;
  Win := Open_Window(0, 0, IntBase^.FirstScr^.Width, IntBase^.FirstScr^.Height,
                     $0201, IDCMP, $140f, Name, Nil,
                     200, 40, $FFFF, $FFFF);
  Con := OpenConsole (Win);
  SetStdIO (Con);
  AddExitServer(CloseCrt);
  MsgClass := 0;
  ReceivedMessage := Nil

END.