home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / sibdemo3.zip / SOURCE.DAT / SOURCE / RTL / CRT.PAS < prev    next >
Pascal/Delphi Source File  |  1996-11-23  |  15KB  |  593 lines
  1. UNIT CRT;
  2.  
  3. {***************************************************************************
  4.  *  Speed-Pascal/2 V 2.0                                                   *
  5.  *                                                                         *
  6.  *  CRT Standard Unit                                                      *
  7.  *                                                                         *
  8.  *  (C) 1995 SpeedSoft. All rights reserved.                               *
  9.  *                                                                         *
  10.  *  Note: Some constants/variables moved to SYSTEM                         *
  11.  *                                                                         *
  12.  ***************************************************************************}
  13.  
  14. INTERFACE
  15.  
  16. CONST
  17.   {Foreground and background color constants}
  18.   Black         = 0;
  19.   Blue          = 1;
  20.   Green         = 2;
  21.   Cyan          = 3;
  22.   Red           = 4;
  23.   Magenta       = 5;
  24.   Brown         = 6;
  25.   LightGray     = 7;
  26.  
  27.   {Foreground color constants}
  28.   DarkGray      = 8;
  29.   LightBlue     = 9;
  30.   LightGreen    = 10;
  31.   LightCyan     = 11;
  32.   LightRed      = 12;
  33.   LightMagenta  = 13;
  34.   Yellow        = 14;
  35.   White         = 15;
  36.  
  37.   {Add-in for blinking}
  38.   Blink         = 128;
  39.  
  40. VAR
  41.   CheckBreak: BOOLEAN;          { Ctrl-Break check }
  42.   CheckEOF: BOOLEAN;            { Ctrl-Z for EOF?  }
  43.   NormAttr:WORD;                { Normal text attribute}
  44.  
  45. PROCEDURE ClrScr;
  46. PROCEDURE GotoXY(X,Y:BYTE);
  47. PROCEDURE Window(X1,Y1,X2,Y2:BYTE);
  48. PROCEDURE TextColor(Color:BYTE);
  49. PROCEDURE TextBackground(Color:BYTE);
  50. FUNCTION WhereX: Byte;
  51. FUNCTION WhereY: WORD;
  52. PROCEDURE ClrEol;
  53. PROCEDURE InsLine;
  54. PROCEDURE DelLine;
  55. PROCEDURE LowVideo;
  56. PROCEDURE NormVideo;
  57. PROCEDURE HighVideo;
  58. FUNCTION KeyPressed: BOOLEAN;
  59. FUNCTION ReadKey: CHAR;
  60. PROCEDURE TextMode(Mode: Integer);
  61. PROCEDURE Delay(ms:LONGWORD);
  62. {Sound/NoSound are not implemented, they are replaced by beep in SYSTEM}
  63.  
  64. IMPLEMENTATION
  65.  
  66. {$IFDEF OS2}
  67. USES PmWin;
  68. {$ENDIF}
  69.  
  70. {$IFDEF Win95}
  71. USES WinCon,WinBase,WinUser;
  72. {$ENDIF}
  73.  
  74. PROCEDURE CrtError;
  75. VAR
  76.    cs:CSTRING;
  77.    cTitle:CSTRING;
  78. BEGIN
  79.      ctitle:='Wrong linker target';
  80.      cs:='PM Linker mode does not support text screen IO.'+#13+
  81.          'Use the unit WinCrt if you wish to use text'+#13+
  82.          'screen IO inside PM applications.';
  83.      {$IFDEF OS2}
  84.      WinMessageBox(1,1,cs,ctitle,0,$4000 OR $0010);
  85.      {$ENDIF}
  86.      {$IFDEF Win95}
  87.      MessageBox(0,cs,ctitle,0);
  88.      {$ENDIF}
  89.      Halt(0);
  90. END;
  91.  
  92.  
  93. {$IFDEF OS2}
  94. {Internal structures from BSESUB}
  95. TYPE
  96.     VIOMODEINFO=RECORD {pack 1}
  97.                      cb:WORD;
  98.                      fbType:BYTE;
  99.                      color:BYTE;
  100.                      col:WORD;
  101.                      row:WORD;
  102.                      hres:WORD;
  103.                      vres:WORD;
  104.                      fmt_ID:BYTE;
  105.                      attrib:BYTE;
  106.                      buf_addr:LONGWORD;
  107.                      buf_length:LONGWORD;
  108.                      full_length:LONGWORD;
  109.                      partial_length:LONGWORD;
  110.                      ext_data_addr:POINTER;
  111.                 END;
  112.  
  113.     VIOCONFIGINFO=RECORD {pack 2}
  114.                       cb:WORD;
  115.                       adapter:WORD;
  116.                       display:WORD;
  117.                       cbMemory:LONGWORD;
  118.                       Configuration:WORD;
  119.                       VDHVersion:WORD;
  120.                       Flags:WORD;
  121.                       HWBufferSize:LONGWORD;
  122.                       FullSaveSize:LONGWORD;
  123.                       PartSaveSize:LONGWORD;
  124.                       EMAdaptersOFF:WORD;
  125.                       EMDisplaysOFF:WORD;
  126.                  END;
  127. {$ENDIF}
  128.  
  129. {Define a text window}
  130. PROCEDURE Window(X1,Y1,X2,Y2: BYTE);
  131. VAR MWindMax:WORD;
  132. begin
  133.   ASM
  134.      MOV AX,SYSTEM.MaxWindMax
  135.      MOV MWindMax,AX
  136.   END;
  137.   IF X1<=X2 THEN IF Y1<=Y2 THEN
  138.   BEGIN
  139.       Dec(X1);
  140.       Dec(Y1);
  141.       IF X1>=0 THEN IF Y1>=0 THEN
  142.       BEGIN
  143.            Dec(Y2);
  144.            Dec(X2);
  145.            IF X2<lo(MWindMax)+1 THEN IF Y2<Hi(MWindMax)+1 THEN
  146.            BEGIN
  147.                WindMin := X1 + WORD(Y1) SHL 8;
  148.                WindMax := X2 + WORD(Y2) SHL 8;
  149.                GotoXY(1,1);
  150.            END;
  151.       END;
  152.   END;
  153. END;
  154.  
  155. {Set cursor location}
  156. PROCEDURE GotoXY(X,Y: BYTE);
  157. BEGIN
  158.      ScreenInOut.GotoXY(X,Y);
  159. END;
  160.  
  161. {internal ANSI color set routine}
  162. PROCEDURE SetColors;
  163. VAR ColorString:STRING;
  164.     Tmp:BYTE;
  165.     Actual:LONGWORD;
  166.     Handle:LONGWORD;
  167.     ff:^FileRec;
  168.     redirected:BOOLEAN;
  169. BEGIN
  170.      ASM
  171.         MOV AL,SYSTEM.Redirect
  172.         MOV redirected,AL
  173.      END;
  174.  
  175.      IF Redirected THEN exit;
  176.  
  177.      ff:=@Output;
  178.      Handle:=ff^.Handle;
  179.  
  180.      Colorstring:=#27+'[0';    {Reset colors and attributes to black/white}
  181.      IF TextAttr>127 THEN      {IF bit 7 set (blink}
  182.          Colorstring:=ColorString+';5'; {blink}
  183.  
  184.      {Set background colors}
  185.      Tmp:=TextAttr AND 112 ;   {Clear bits 7,0 to 3 }
  186.      Tmp:=Tmp SHR 4;           {Adjust position to reflect bgcolor}
  187.      Tmp:=Tmp AND 7;
  188.      CASE Tmp OF
  189.         Black    : Tmp:=40;       {Values differ from CLR_ constants!}
  190.         Blue     : Tmp:=44;
  191.         Green    : Tmp:=42;
  192.         Cyan     : Tmp:=46;
  193.         Red      : Tmp:=41;
  194.         Magenta  : Tmp:=45;
  195.         Brown    : Tmp:=43;       {Yellow with in lower set!}
  196.         Lightgray: Tmp:=47;
  197.      END;
  198.      Colorstring:=Colorstring+';'+tostr(Tmp);
  199.  
  200.      {Now set forefround...}
  201.      Tmp:=TextAttr AND 15 ;    {Clear bits 4 to 7 }
  202.      IF Tmp>7 THEN             {Is bold character}
  203.      BEGIN
  204.           Colorstring:=Colorstring+';1';  {High colors}
  205.           DEC(Tmp,8);
  206.      END;
  207.  
  208.      Tmp:=Tmp AND 7;
  209.      CASE Tmp OF
  210.          Black    : Tmp:=30;
  211.          Blue     : Tmp:=34;
  212.          Green    : Tmp:=32;
  213.          Cyan     : Tmp:=36;
  214.          Red      : Tmp:=31;
  215.          Magenta  : Tmp:=35;
  216.          Brown    : Tmp:=33; {yellow with in lower set!}
  217.          Lightgray: Tmp:=37;
  218.      END;
  219.  
  220.      Colorstring:=Colorstring+';'+tostr(Tmp)+'m';
  221.  
  222.      {$IFDEF OS2}
  223.      ASM
  224.         LEA EAX,Actual
  225.         PUSH EAX                //pcbActual
  226.         LEA EDI,ColorString
  227.         MOVZXB EAX,[EDI]
  228.         PUSH EAX               //cbWrite
  229.         INC EDI
  230.         PUSH EDI               //pBuffer
  231.         PUSH DWORD PTR Handle  //FileHandle
  232.         MOV AL,4
  233.         CALLDLL DosCalls,282   //DosWrite
  234.         ADD ESP,16
  235.      END;
  236.      {$ENDIF}
  237.      {$IFDEF Win95}
  238.      WriteFile(ff^.Handle,ColorString[1],length(ColorString),actual,NIL);
  239.      {$ENDIF}
  240. END;
  241.  
  242. {Set foreground color}
  243. PROCEDURE TextColor(Color:BYTE);
  244. BEGIN
  245.   IF ApplicationType=1 THEN CrtError;
  246.  
  247.   IF Color > White THEN Color := (Color AND 15) OR 128; {Blink}
  248.   TextAttr := (TextAttr AND 112) OR Color;
  249.   SetColors;
  250. END;
  251.  
  252. {Set background color}
  253. PROCEDURE TextBackground(Color:BYTE);
  254. BEGIN
  255.   IF ApplicationType=1 THEN CrtError;
  256.   TextAttr := (TextAttr AND $8F) OR ((Color AND $07) SHL 4);
  257.   SetColors;
  258. END;
  259.  
  260. {Clear screen or window}
  261. PROCEDURE ClrScr;
  262. VAR
  263.   Fill: Word;
  264.   {$IFDEF Win95}
  265.   ff:^FileRec;
  266.   co:COORD;
  267.   Actual:LONGWORD;
  268.   {$ENDIF}
  269. BEGIN
  270.   IF ApplicationType=1 THEN CrtError;
  271.   {$IFDEF OS2}
  272.   Fill:= 32 + WORD(TextAttr) SHL 8;
  273.   VioScrollUpProc(Hi(WindMin),Lo(WindMin),
  274.                   Hi(WindMax),Lo(WindMax),
  275.                   Hi(WindMax)-Hi(WindMin)+1,Fill,0);
  276.   {$ENDIF}
  277.   {$IFDEF Win95}
  278.   Fill:= TextAttr;
  279.   ff:=@Output;
  280.   co.x:=Lo(WindMin);
  281.   co.y:=Hi(WindMin);
  282.   FillConsoleOutputAttribute(ff^.Handle,Fill,
  283.                              (Hi(WindMax)-Hi(WindMin))*(Lo(WindMax)-Lo(WindMin)),
  284.                              LONGWORD(co),Actual);
  285.   FillConsoleOutputCharacter(ff^.Handle,' ',
  286.                              (Hi(WindMax)-Hi(WindMin))*(Lo(WindMax)-Lo(WindMin)),
  287.                              LONGWORD(co),Actual);
  288.   {$ENDIF}
  289.   GotoXY(1,1);
  290. END;
  291.  
  292. {returns current cursor X position}
  293. FUNCTION WhereX: Byte;
  294. {$IFDEF Win95}
  295. VAR csbi:CONSOLE_SCREEN_BUFFER_INFO;
  296.     ff:^FileRec;
  297. {$ENDIF}
  298. BEGIN
  299.   IF ApplicationType=1 THEN CrtError;
  300.   {$IFDEF OS2}
  301.   WhereX := VioWhereXProc - Lo(WindMin);
  302.   {$ENDIF}
  303.   {$IFDEF Win95}
  304.   ff:=@Output;
  305.   GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  306.   WhereX:=csbi.dwCursorPosition.X+1-Lo(WindMin);
  307.   {$ENDIF}
  308. END;
  309.  
  310. {returns current cursor Y position}
  311. FUNCTION WhereY: WORD;
  312. {$IFDEF Win95}
  313. VAR csbi:CONSOLE_SCREEN_BUFFER_INFO;
  314.     ff:^FileRec;
  315. {$ENDIF}
  316. BEGIN
  317.   IF ApplicationType=1 THEN CrtError;
  318.   {$IFDEF OS2}
  319.   WhereY:= VioWhereYProc - Hi(WindMin);
  320.   {$ENDIF}
  321.   {$IFDEF Win95}
  322.   ff:=@Output;
  323.   GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  324.   WhereY:=csbi.dwCursorPosition.Y+1-Hi(WindMin);
  325.   {$ENDIF}
  326. END;
  327.  
  328. {Deletes til end of line}
  329. PROCEDURE ClrEol;
  330. VAR
  331.   Value:WORD;
  332.   Y: BYTE;
  333. BEGIN
  334.   IF ApplicationType=1 THEN CrtError;
  335.   Value := Ord(' ') + WORD(TextAttr) SHL 8;
  336.   {$IFDEF OS2}
  337.   Y:=VioWhereYProc-1;
  338.   VioScrollUpProc(Y,VioWhereXProc-1,Y,Lo(WindMax),1,Value,0);
  339.   {$ENDIF}
  340. END;
  341.  
  342. {Insert empty line}
  343. PROCEDURE InsLine;
  344. VAR
  345.    value:WORD;
  346. BEGIN
  347.   IF ApplicationType=1 THEN CrtError;
  348.   value := Ord(' ') + WORD(TextAttr) SHL 8;
  349.   {$IFDEF OS2}
  350.   VioScrollDnProc(VioWhereYProc-1,Lo(WindMin),Hi(WindMax),Lo(WindMax),1,Value,0);
  351.   {$ENDIF}
  352. END;
  353.  
  354. {Delete the current line}
  355. PROCEDURE DelLine;
  356. VAR
  357.    value:WORD;
  358. BEGIN
  359.   IF ApplicationType=1 THEN CrtError;
  360.   Value := Ord(' ') + WORD(TextAttr) SHL 8;
  361.   {$IFDEF OS2}
  362.   VioScrollUpProc(VioWhereYProc-1,Lo(WindMin),Hi(WindMax),Lo(WindMax),1,Value,0);
  363.   {$ENDIF}
  364. END;
  365.  
  366. {sets low intensity}
  367. PROCEDURE LowVideo;
  368. BEGIN
  369.   IF ApplicationType=1 THEN CrtError;
  370.   TextAttr := TextAttr AND $F7;
  371.   SetColors;
  372. END;
  373.  
  374. {sets normal intensity}
  375. PROCEDURE NormVideo;
  376. BEGIN
  377.   IF ApplicationType=1 THEN CrtError;
  378.   TextAttr := NormAttr;
  379.   SetColors;
  380. END;
  381.  
  382. {sets high intensity}
  383. PROCEDURE HighVideo;
  384. BEGIN
  385.   IF ApplicationType=1 THEN CrtError;
  386.   TextAttr := TextAttr OR $08;
  387.   SetColors;
  388. END;
  389.  
  390.  
  391. PROCEDURE InitCrt;
  392. VAR Size:WORD;
  393.     Value:WORD;
  394.     {$IFDEF Win95}
  395.     co:COORD;
  396.     ff:^FileRec;
  397.     Actual:LONGWORD;
  398.     {$ENDIF}
  399. BEGIN
  400.      Size := 2;
  401.      {$IFDEF OS2}
  402.      VioReadCellStrProc(Value, Size, WhereY-1, WhereX-1, 0);
  403.      {$ENDIF}
  404.      {$IFDEF Win95}
  405.      co.X:=1;
  406.      co.Y:=1;
  407.      ff:=@Output;
  408.      ReadConsoleOutputAttribute(ff^.Handle,Value,2,LONGWORD(co),Actual);
  409.      {$ENDIF}
  410.      NormAttr := Hi(Value) AND $7F;
  411.      TextAttr:=NormAttr;
  412.      {NormVideo;}
  413.      CheckBreak:=TRUE;
  414.      CheckEOF:=TRUE;
  415. END;
  416.  
  417. {checks if a key was pressed}
  418. FUNCTION KeyPressed: BOOLEAN;
  419. {$IFDEF Win95}
  420. VAR ff:^FileRec;
  421.     ir:INPUT_RECORD;
  422.     Actual:LONGWORD;
  423. {$ENDIF}
  424. BEGIN
  425.      IF ApplicationType=1 THEN CrtError;
  426.      {$IFDEF OS2}
  427.      KeyPressed:=KeyPressedProc;
  428.      {$ENDIF}
  429.      {$IFDEF Win95}
  430.      ff:=@Input;
  431.  
  432.      SetConsoleMode(ff^.Handle,ENABLE_WINDOW_INPUT);
  433.  
  434.      result:=FALSE;
  435.      PeekConsoleInput(ff^.Handle,ir,1,Actual);
  436.      IF ir.EventType=KEY_EVENT THEN
  437.         IF ir.Event.KeyEvent.bKeyDown THEN result:=TRUE;
  438.  
  439.      SetConsoleMode(ff^.Handle,ENABLE_PROCESSED_INPUT OR ENABLE_LINE_INPUT OR
  440.        ENABLE_ECHO_INPUT OR ENABLE_WINDOW_INPUT OR ENABLE_MOUSE_INPUT OR
  441.        ENABLE_PROCESSED_OUTPUT OR ENABLE_WRAP_AT_EOL_OUTPUT);
  442.      {$ENDIF}
  443. END;
  444.  
  445. {Reads a character}
  446. FUNCTION ReadKey: CHAR;
  447. {$IFDEF Win95}
  448. VAR ff:^FileRec;
  449.     ir:INPUT_RECORD;
  450.     Actual:LONGWORD;
  451. LABEL l;
  452. {$ENDIF}
  453. BEGIN
  454.      IF ApplicationType=1 THEN CrtError;
  455.      {$IFDEF OS2}
  456.      ReadKey:=ReadKeyProc;
  457.      {$ENDIF}
  458.      {$IFDEF Win95}
  459.      ff:=@Input;
  460.  
  461.      SetConsoleMode(ff^.Handle,ENABLE_WINDOW_INPUT);
  462.  
  463.      REPEAT
  464.            ReadConsoleInput(ff^.Handle,ir,1,Actual);
  465.            IF ir.EventType=KEY_EVENT THEN
  466.              IF ir.Event.KeyEvent.bKeyDown THEN goto l;
  467.      UNTIL FALSE;
  468. l:
  469.      ReadKey:=ir.Event.KeyEvent.uChar.AsciiChar;
  470.      SetConsoleMode(ff^.Handle,ENABLE_PROCESSED_INPUT OR ENABLE_LINE_INPUT OR
  471.        ENABLE_ECHO_INPUT OR ENABLE_WINDOW_INPUT OR ENABLE_MOUSE_INPUT OR
  472.        ENABLE_PROCESSED_OUTPUT OR ENABLE_WRAP_AT_EOL_OUTPUT);
  473.      {$ENDIF}
  474. END;
  475.  
  476. { Set a text mode. (BW40,CO40,BW80,CO80,Mono,Font8x8}
  477. PROCEDURE TextMode(Mode: Integer);
  478. VAR
  479.    Bios: BYTE;
  480.    Value: Word;
  481.    {$IFDEF OS2}
  482.    VioMode:VIOMODEINFO;
  483.    VioConfig:VIOCONFIGINFO;
  484.    {$ENDIF}
  485. BEGIN
  486.   IF ApplicationType=1 THEN CrtError;
  487.   {$IFDEF OS2}
  488.   {Get current video mode}
  489.   VioMode.cb := SizeOf(VioModeInfo);
  490.   VioGetModeProc(VioMode, 0);
  491.  
  492.   {update LastMode}
  493.   WITH VioMode DO
  494.   BEGIN
  495.        IF Col = 40 THEN LastMode := BW40
  496.        ELSE LastMode := BW80;
  497.        IF (fbType AND 4) = 0 THEN
  498.           IF LastMode = BW40 THEN LastMode := CO40
  499.        ELSE LastMode := CO80;
  500.        IF Color = 0 THEN LastMode := Mono;
  501.        IF Row > 25 THEN Inc(LastMode,Font8x8);
  502.   END;
  503.  
  504.   TextAttr := LightGray;
  505.   Bios := Lo(Mode);
  506.   VioConfig.cb := SizeOf(VioConfigInfo);
  507.  
  508.   {Get adapter info}
  509.   VioGetConfigProc(0, VioConfig, 0);
  510.  
  511.   WITH VioMode DO
  512.   BEGIN
  513.       VRes := 400;
  514.       HRes := 720;
  515.       cb := SizeOf(VioModeInfo);
  516.       Row := 25;
  517.       Col := 80;
  518.       fbType := 1;
  519.       Color := 4;      { 16 Colors }
  520.  
  521.       IF ((Bios=BW40)OR(Bios=CO40)) THEN
  522.       BEGIN
  523.            Col := 40;
  524.            HRes := 360;
  525.       END;
  526.   END;
  527.  
  528.   IF (Mode AND Font8x8) <> 0 THEN
  529.   BEGIN
  530.        IF VioConfig.Adapter<3 THEN {Mono, CGA, EGA}
  531.        BEGIN
  532.             VioMode.VRes := 350;
  533.             VioMode.HRes := 640;
  534.             VioMode.Row := 43;
  535.        END
  536.        ELSE
  537.        BEGIN
  538.             VioMode.VRes := 400;
  539.             VioMode.HRes := 720;
  540.             VioMode.Row := 50;
  541.        END;
  542.   END;
  543.  
  544.   CASE Bios of
  545.       BW40,BW80: VioMode.fbType := 5;
  546.       MONO:
  547.       BEGIN
  548.            VioMode.HRes := 720;
  549.            VioMode.VRes := 350;
  550.            VioMode.Color := 0;
  551.            VioMode.fbType := 0;  {no colors}
  552.       END;
  553.   END; {case}
  554.  
  555.   {try to set mode}
  556.   VioSetModeProc(VioMode, 0);
  557.   {See what mode is set}
  558.   VioGetModeProc(VioMode, 0);
  559.   NormVideo;
  560.  
  561.   {Set window dimensions}
  562.   WindMin := 0;
  563.   WindMax := VioMode.Col - 1 + (VioMode.Row - 1) SHL 8;
  564.  
  565.   {Clear screen}
  566.   Value := 32 + WORD(TextAttr) SHL 8;    { Clear screen }
  567.   VioScrollUpProc(0,0,65535,65535,65535,Value,0);
  568.   {$ENDIF}
  569. END;
  570.  
  571. PROCEDURE Delay(ms:LONGWORD);
  572. BEGIN
  573.      {$IFDEF OS2}
  574.      IF ApplicationType<>1 THEN
  575.      ASM
  576.         PUSH DWORD PTR ms
  577.         MOV AL,1
  578.         CALLDLL DosCalls,229  //DosSleep
  579.         ADD ESP,4
  580.      END;
  581.      {$ENDIF}
  582.      {$IFDEF Win95}
  583.      ASM
  584.         PUSH DWORD PTR ms
  585.         CALLDLL Kernel32,'Sleep'
  586.      END;
  587.      {$ENDIF}
  588. END;
  589.  
  590. BEGIN
  591.      IF ApplicationType<>1 THEN InitCrt;
  592. END.
  593.