home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / MKMSG104 / MKWCRT.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-09  |  19KB  |  838 lines
  1. Unit MKWCrt;
  2. {$R Keys.Res}
  3.  
  4. Interface
  5.  
  6. {
  7.      MKWCRT - Copyright 1993 by Mark May - MK Software
  8.      You are free to use this code in your programs, however
  9.      it may not be included in Source/TPU function libraries
  10.      without my permission.
  11.  
  12.      Mythical Kingom Tech BBS (513)237-7737 HST/v32
  13.      FidoNet: 1:110/290
  14.      Rime: ->MYTHKING
  15.      You may also reach me at maym@dmapub.dma.org
  16. }
  17.  
  18.  
  19. Uses WinProcs, WinTypes, WinDos;
  20.  
  21. Const
  22.   Black = 0;
  23.   Blue = 1;
  24.   Green = 2;
  25.   Cyan = 3;
  26.   Red = 4;
  27.   Magenta = 5;
  28.   Brown = 6;
  29.   LightGray = 7;
  30.   DarkGray = 8;
  31.   LightBlue = 9;
  32.   LightGreen = 10;
  33.   LightCyan = 11;
  34.   LightRed = 12;
  35.   LightMagenta = 13;
  36.   Yellow = 14;
  37.   White = 15;
  38.   Blink = 128;
  39.  
  40.  
  41. Const
  42.   TextAttr: Byte = $07;
  43.   TextChar: Char = ' ';
  44.   CheckBreak: Boolean = True;
  45.   CheckEOF: Boolean = False;
  46.   CheckSnow: Boolean = False;
  47.   DirectVideo: Boolean = False;
  48.   LastMode: Word = 3;
  49.   WindMin: Word = $0;
  50.   WindMax: Word = $184f;
  51.   ScreenWidth = 80;
  52.   ScreenHeight = 25;
  53.   KeyBufferSize = 20;
  54.  
  55. Const
  56.   AppName = 'AppName Here';
  57.  
  58. Procedure AssignWinCrt(Var F: Text);
  59. Procedure Delay(DTime: LongInt);
  60. Procedure TextColor(CL: Byte);
  61. Procedure TextBackground(CL: Byte);
  62. Procedure PutStr(Str: String);
  63. Procedure PutChar(Ch: Char);
  64. Procedure GoToXy(X: Byte; Y: Byte);
  65. Function  WhereX: Byte;
  66. Function  WhereY: Byte;
  67. Procedure Window(X1, Y1, X2, Y2: Byte);
  68. Procedure ClrScr;
  69. Procedure ClrEol;
  70. Function  KeyPressed: Boolean;
  71. Function  ReadKey: Char;
  72. Function  SaveScrnRegion(xl,yl,xh,yh: Byte; Var Pt: Pointer):Boolean;
  73. Procedure RestoreScrnRegion(xl,yl,xh,yh: Byte; Pt: Pointer);
  74. Procedure ScrollScrnRegionUp(xl,yl,xh,yh, count: Byte);
  75. Procedure ScrollScrnRegionDown(xl,yl,xh,yh, count: Byte);
  76. Procedure PutScrnWord (SX: Byte; SY: Byte; CA: Word);
  77. Function  GetScrnWord(SX: Byte; SY: Byte): Word;
  78. Procedure DelCharInLine(Sx: Byte; Sy: Byte);
  79. Procedure InsCharInLine(Sx: Byte; Sy: Byte; Ch: Char);
  80. Procedure InitializeScrnRegion(xl,yl,xh,yh: Byte; Ch: Char);
  81. Function  WindowProc(HWindow: HWnd; Message, WParam: Word;
  82.   LParam: Longint): Longint; export;
  83. Procedure RedrawScrn;
  84.  
  85.  
  86. Type ScrnArrayType = Array[0..(ScreenWidth * ScreenHeight)] of Word;
  87.  
  88. Type WordArray = Array[0..9999] of Word;
  89.  
  90. Type WordArrayPtr = ^WordArray;
  91.  
  92.  
  93. Var
  94.   HWindow: HWnd;
  95.   Accels: THandle;
  96.   Message: TMsg;
  97.   TVert: Word;
  98.   THorz: Word;
  99.   ScrnArray: ^ScrnArrayType;
  100.   KeyBuffer: Array[1..KeyBufferSize] of Char;
  101.   KeyPut: Byte;
  102.   KeySend: Byte;
  103.   ScrnWidth: Byte;
  104.   ScrnHeight: Byte;
  105.  
  106.  
  107.  
  108. Const
  109.   WindowClass: TWndClass = (
  110.     style: 0;
  111.     lpfnWndProc: @WindowProc;
  112.     cbClsExtra: 0;
  113.     cbWndExtra: 0;
  114.     hInstance: 0;
  115.     hIcon: 0;
  116.     hCursor: 0;
  117.     hbrBackground: 0;
  118.     lpszMenuName: AppName;
  119.     lpszClassName: AppName);
  120.  
  121.  
  122. Const
  123.   CurrX: Byte = 1;
  124.   CurrY: Byte = 1;
  125.  
  126. Implementation
  127.  
  128.  
  129. Const ColorArray: Array[0..15] of LongInt = (0, 1141120, 43520, 11184640,
  130.   170, 11141290, 43690, 11184810, 5592405, 16733525, 5635925,
  131.   16777045, 5592575, 16733695, 5636095, 16777215);
  132.  
  133. Procedure Delay(DTime: LongInt);
  134.   Const
  135.     TimerId = 1989;
  136.   Var
  137.     DDone: Boolean;
  138.  
  139.   Begin
  140.   DDone := False;
  141.   If SetTimer(HWindow,TimerId, DTime, nil) <> 0 Then
  142.     Begin
  143.     While Not DDone Do
  144.       Begin
  145.       WaitMessage;
  146.       If PeekMessage(Message, HWindow, 0, 0, pm_Remove) Then
  147.         Begin
  148.         If Message.Message = wm_Timer Then
  149.           DDone := True
  150.         Else
  151.           If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
  152.             Begin
  153.             TranslateMessage(Message);
  154.             DispatchMessage(Message);
  155.             End;
  156.         End;
  157.       End;
  158.     KillTimer(HWindow, TimerId);
  159.     End;
  160.   End;
  161.  
  162. Procedure TextColor(CL: Byte);
  163.   Begin
  164.   TextAttr := TextAttr and $F0;
  165.   TextAttr := TextAttr or (CL and $0F);
  166.   End;
  167.  
  168.  
  169. Procedure TextBackground(CL: Byte);
  170.   Begin
  171.   TextAttr := TextAttr and $0F;
  172.   TextAttr := TextAttr or (CL shl 4);
  173.   End;
  174.  
  175.  
  176. Procedure GoToXy(X: Byte; Y: Byte);
  177.   Begin
  178.   CurrX := X + (WindMin and $ff);
  179.   CurrY := Y + (WindMin shr 8);
  180.   If (CurrX > ((WindMax and $ff) + 1)) Then
  181.     CurrX := (WindMax and $ff) + 1;
  182.   If (CurrY > ((WindMax shr 8) + 1)) Then
  183.     CurrY := (WindMax shr 8) + 1;
  184.   End;
  185.  
  186.  
  187. Procedure Window(X1, Y1, X2, Y2: Byte);
  188.   Begin
  189.   WindMin := (Y1 - 1);
  190.   WindMin := (WindMin Shl 8) + (X1 - 1);
  191.   WindMax := (Y2 - 1);
  192.   WindMax := (WindMax Shl 8) + (X2 - 1);
  193.   End;
  194.  
  195.  
  196. Procedure ClrScr;
  197.   Var
  198.     CX, CY: Byte;
  199.     TmpStr: String;
  200.     NumRows, NumCols: Byte;
  201.     DC: HDC;
  202.     Metrics: TTextMetric;
  203.  
  204.   Begin
  205.   DC := GetDC(HWindow);
  206.   SetTextColor(DC,ColorArray[TextAttr and $0f]);
  207.   SetBkColor(DC, ColorArray[TextAttr shr 4]);
  208.   SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  209.   TmpStr := '';
  210.   Cx := (WindMin and $ff);
  211.   While (Cx <= (WindMax and $ff)) Do
  212.     Begin
  213.     TmpStr := TmpStr + TextChar;
  214.     Inc(Cx);
  215.     End;
  216.   Cy := (WindMin shr 8) + 1;
  217.   While (Cy <= ((WindMax shr 8) + 1)) Do
  218.     Begin
  219.     Cx := WindMin and $ff;
  220.     While Cx <= (WindMax and $ff) Do
  221.       Begin
  222.       ScrnArray^[(Cy - 1) * ScreenWidth + (Cx)] := Ord(TextChar) + (TextAttr shl 8);
  223.       Inc(Cx);
  224.       End;
  225.     TextOut(DC, (WindMin and $ff) * THorz, (CY - 1) * TVert, PChar(@TmpStr[1]),
  226.       Length(TmpStr));
  227.     Inc(Cy);
  228.     End;
  229.   TextChar := ' ';
  230.   ReleaseDC(HWindow,DC);
  231.   GoToXY(1, 1);
  232.   End;
  233.  
  234.  
  235. Procedure ClrEol;
  236.   Var
  237.     CX: Byte;
  238.     TmpStr: String;
  239.     DC: HDC;
  240.     Metrics: TTextMetric;
  241.  
  242.   Begin
  243.   DC := GetDC(HWindow);
  244.   SetTextColor(DC,ColorArray[TextAttr and $0f]);
  245.   SetBkColor(DC, ColorArray[TextAttr shr 4]);
  246.   SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  247.   CX := CurrX;
  248.   TmpStr := '';
  249.   While (CX <= ((WindMax and $ff)+ 1)) Do
  250.     Begin
  251.     TmpStr := TmpStr + TextChar;
  252.     Inc(Cx);
  253.     End;
  254.   TextOut(DC, (CurrX - 1) * THorz, (CurrY - 1) * TVert, PChar(@TmpStr[1]),
  255.     Length(TmpStr));
  256.   ReleaseDC(HWindow,DC);
  257.   End;
  258.  
  259.  
  260. Function WhereX: Byte;
  261.   Begin
  262.   WhereX := CurrX - (WindMin and $ff);
  263.   End;
  264.  
  265.  
  266. Function WhereY: Byte;
  267.   Begin
  268.   WhereY := CurrY - (WindMin shr 8);
  269.   End;
  270.  
  271.  
  272. Function GetKeyChar: Char;
  273.   Begin
  274.   If KeyPut <> KeySend Then
  275.     Begin
  276.     GetKeyChar := KeyBuffer[KeySend];
  277.     Inc(KeySend);
  278.     If KeySend > KeyBufferSize Then
  279.       KeySend := 1;
  280.     End
  281.   Else
  282.     GetKeyChar := #0;
  283.   End;
  284.  
  285.  
  286. Procedure PutKeyChar(Ch: Char);
  287.   Var
  288.     Tmp: Byte;
  289.  
  290.   Begin
  291.   Tmp := KeyPut;
  292.   Inc(KeyPut);
  293.   If KeyPut > KeyBufferSize Then
  294.     KeyPut := 1;
  295.   If KeyPut <> KeySend Then
  296.     KeyBuffer[Tmp] := Ch
  297.   Else
  298.     KeyPut := Tmp;
  299.   End;
  300.  
  301.  
  302. Procedure CharMsg(Message: TMsg);
  303.   Var
  304.     Tmp: Byte;
  305.  
  306.   Begin
  307.   PutKeyChar(Char(Message.wParam));
  308.   End;
  309.  
  310.  
  311. Function WindowProc(HWindow: HWnd; Message, WParam: Word;
  312.   LParam: Longint): Longint;
  313.   Var
  314.     PassOn: Boolean;
  315.  
  316.   Begin
  317.   PassOn := True;
  318.   WindowProc := 0;
  319.   case Message of
  320.     wm_Char:
  321.       Begin
  322.       If (LParam and 256) <> 0 Then
  323.         Begin
  324.         PutKeyChar(#0);
  325.         PutKeyChar(Chr(LParam and 127));
  326.         End
  327.       Else
  328.         PutKeyChar(Chr(WParam));
  329.       PassOn := False;
  330.       End;
  331.     wm_Command:
  332.       Begin
  333.       PutKeyChar(#0);
  334.       PutKeyChar(Chr(Lo(WParam)));
  335.       PassOn := False;
  336.       End;
  337.     wm_Destroy:
  338.       Begin
  339.       PostQuitMessage(0);
  340.       Exit;
  341.       End;
  342.     wm_Paint: RedrawScrn;
  343.     End;
  344.   If PassOn Then
  345.     WindowProc := DefWindowProc(HWindow, Message, WParam, LParam)
  346.   Else
  347.     WindowProc := 1;
  348.   End;
  349.  
  350.  
  351. Procedure PutChar(Ch: Char);
  352.   Var
  353.     DC: HDC;
  354.  
  355.   Begin
  356.   Case Ch of
  357.     #07: ;
  358.     #08: If CurrX > ((WindMin and $ff) + 1) Then
  359.           Dec(CurrX);
  360.     #10: Begin
  361.          Inc(CurrY);
  362.          If CurrY > ((WindMax shr 8) + 1) Then
  363.            Begin
  364.            CurrY := ((WindMax shr 8) + 1);
  365.            ScrollScrnRegionUp(1, 1, ScreenWidth, ScreenHeight,1);
  366.            End;
  367.          End;
  368.     #13: CurrX := 1;
  369.     Else
  370.       Begin
  371.       DC := GetDC(HWindow);
  372.       SetTextColor(DC,ColorArray[TextAttr and $0f]);
  373.       SetBkColor(DC, ColorArray[TextAttr shr 4]);
  374.       SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  375.       ScrnArray^[(CurrX - 1) + (CurrY - 1) * ScreenWidth] := Ord(ch) + (TextAttr shl 8);
  376.       TextOut(DC, (CurrX - 1) * THorz, (CurrY - 1) * TVert, PChar(@Ch), 1);
  377.       ReleaseDC(HWindow,DC);
  378.       Inc(CurrX);
  379.       If CurrX > ((WindMax and $FF) + 1) Then
  380.         Begin
  381.         CurrX := (WindMin and $FF) + 1;
  382.         Inc(CurrY);
  383.          If CurrY >= ((WindMax shr 8) + 1) Then
  384.            Begin
  385.            CurrY := (WindMax shr 8) + 1;
  386.            ScrollScrnRegionUp(1, 1, ScreenWidth, ScreenHeight, 1);
  387.            End;
  388.         End;
  389.       End;
  390.     End;
  391.   End;
  392.  
  393.  
  394. Procedure PutStr(Str: String);
  395.   Var
  396.     i: Word;
  397.  
  398.   Begin
  399.   i := 1;
  400.   While i <= Length(Str) Do
  401.     Begin
  402.     PutChar(Str[i]);
  403.     Inc(i);
  404.     End;
  405.   End;
  406.  
  407.  
  408. Procedure ScrollScrnRegionUp(xl,yl,xh,yh, count: Byte);
  409.   Var
  410.     Ty: Byte;
  411.     Tx: Byte;
  412.     Wdth: Byte;
  413.     DC: HDC;
  414.     Rect: TRect;
  415.     TempStr: String;
  416.  
  417.  
  418.   Begin
  419.   xl := xl + (WindMin and $ff);
  420.   yl := yl + (WindMin shr 8);
  421.   xh := xh + (WindMin and $ff);
  422.   yh := yh + (WindMin shr 8);
  423.   If yh > ((WindMax shr 8) + 1) Then
  424.     yh := ((WindMax shr 8) + 1);
  425.   If xh > ((WindMax and $ff) + 1) Then
  426.     xh := ((WindMax and $ff) + 1);
  427.   Wdth := Xh + 1 - Xl;
  428.   If Wdth > 0 Then
  429.     Begin
  430.     Ty := yl;
  431.     While Ty < yh Do
  432.       Begin
  433.       Move(ScrnArray^[(Ty * ScreenWidth) + XL - 1],
  434.         ScrnArray^[((Ty - 1) * ScreenWidth) + XL - 1], Wdth);
  435.       Inc(Ty);
  436.       End;
  437.     For Tx := xl to xh Do
  438.       ScrnArray^[(Tx - 1) + (yh - 1) * ScreenWidth] :=  32 + (TextAttr shl 8);
  439.     Rect.Left := (xl - 1) * THorz;
  440.     Rect.Right := (xh) * THorz;
  441.     Rect.Top := (yl - 1) * TVert;
  442.     Rect.Bottom := (yh) * TVert;
  443.     ScrollWindow(HWindow, 0,  -TVert * Count, @Rect, @Rect);
  444.     DC := GetDC(HWindow);
  445.     SetTextColor(DC,ColorArray[TextAttr and $0f]);
  446.     SetBkColor(DC, ColorArray[TextAttr shr 4]);
  447.     SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  448.     TempStr := '';
  449.     For tx := xl to xh Do
  450.       TempStr := TempStr + ' ';
  451.     TextOut(DC, (Xl - 1) * THorz, (Yh - 1) * TVert, PChar(@TempStr[1]),
  452.       Length(TempStr));
  453.     ReleaseDC(HWindow,DC);
  454.     End;
  455.   End;
  456.  
  457.  
  458. Procedure ScrollScrnRegionDown(xl,yl,xh,yh, count: Byte);
  459.   Var
  460.     Ty: Byte;
  461.     Tx: Byte;
  462.     Wdth: Byte;
  463.     DC: HDC;
  464.     Rect: TRect;
  465.     TempStr: String;
  466.  
  467.   Begin
  468.   xl := xl + (WindMin and $ff);
  469.   yl := yl + (WindMin shr 8);
  470.   xh := xh + (WindMin and $ff);
  471.   yh := yh + (WindMin shr 8);
  472.   If yh > ((WindMax shr 8) + 1) Then
  473.     yh := ((WindMax shr 8) + 1);
  474.   If xh > ((WindMax and $ff) + 1) Then
  475.     xh := ((WindMax and $ff) + 1);
  476.   Wdth := Xh + 1 - Xl;
  477.   If Wdth > 0 Then
  478.     Begin
  479.     Ty := yh;
  480.     While Ty > yl Do
  481.       Begin
  482.       Move(ScrnArray^[((Ty - 2) * ScreenWidth) + XL - 1],
  483.         ScrnArray^[((Ty - 1) * ScreenWidth) + XL - 1], Wdth);
  484.       Dec(Ty);
  485.       End;
  486.     For Tx := xl to xh Do
  487.       ScrnArray^[(Tx - 1) + (yl - 1) * ScreenWidth] :=  32 + (TextAttr shl 8);
  488.     Rect.Left := (xl - 1) * THorz;
  489.     Rect.Right := (xh) * THorz;
  490.     Rect.Top := (yl - 1) * TVert;
  491.     Rect.Bottom := (yh) * TVert;
  492.     ScrollWindow(HWindow, 0, Count * TVert, @Rect, @Rect);
  493.     DC := GetDC(HWindow);
  494.     SetTextColor(DC,ColorArray[TextAttr and $0f]);
  495.     SetBkColor(DC, ColorArray[TextAttr shr 4]);
  496.     SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  497.     TempStr := '';
  498.     For tx := xl to xh Do
  499.       TempStr := TempStr + ' ';
  500.     TextOut(DC, (Xl - 1) * THorz, (Yl - 1) * TVert, PChar(@TempStr[1]),
  501.       Length(TempStr));
  502.     ReleaseDC(HWindow,DC);
  503.     End;
  504.   End;
  505.  
  506.  
  507. Procedure PutScrnWordDC(SX: Byte; SY: Byte; CA: Word; Var DC: HDC);
  508.   Var
  509.     Attr: Byte;
  510.     Ch: Char;
  511.  
  512.   Begin
  513.   ScrnArray^[((SY - 1) * ScreenWidth) + SX - 1] := CA;
  514.   Ch := Chr(Lo(CA));
  515.   Attr := CA shr 8;
  516.   SetTextColor(DC,ColorArray[Attr and $0f]);
  517.   SetBkColor(DC, ColorArray[Attr shr 4]);
  518.   SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  519.   TextOut(DC, (SX - 1) * THorz, (SY - 1) * TVert, PChar(@Ch), 1);
  520.   End;
  521.  
  522.  
  523. Procedure RedrawScrn;
  524.   Var
  525.     DC: HDC;
  526.     Paint: TPaintStruct;
  527.     Tx, Ty: Word;
  528.     Mx, My: Word;
  529.     Attr: Byte;
  530.     LA: Byte;
  531.     Ch: Char;
  532.  
  533.   Begin
  534.   If ((THorz > 0) and (TVert > 0)) Then
  535.     Begin
  536.     DC := BeginPaint(HWindow, Paint);
  537.     Tx := Paint.RcPaint.Left div THorz;
  538.     Ty := Paint.RcPaint.Top div TVert;
  539.     If ((Tx < (ScreenWidth - 1)) and (Ty < (ScreenHeight - 1))) Then
  540.       Begin
  541.       Mx := (Paint.RcPaint.Right div Thorz) + 1;
  542.       My := (Paint.RcPaint.Bottom div TVert) + 1;
  543.       If Mx > (ScreenWidth - 1) Then
  544.         Mx := ScreenWidth - 1;
  545.       If My > (ScreenHeight - 1) Then
  546.         My := ScreenHeight - 1;
  547.       Attr := ScrnArray^[Tx + (ScreenWidth * Ty)] Shr  8;
  548.       LA := Attr;
  549.       SetTextColor(DC,ColorArray[Attr and $0f]);
  550.       SetBkColor(DC, ColorArray[Attr shr 4]);
  551.       SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  552.       While Ty <= My Do
  553.         Begin
  554.         Tx := Paint.RcPaint.Left div THorz;
  555.         While Tx <= Mx Do
  556.           Begin
  557.           Attr := ScrnArray^[Tx + (TY * ScreenWidth)] shr 8;
  558.           If Attr <> LA Then
  559.             Begin
  560.             SetTextColor(DC,ColorArray[Attr and $0f]);
  561.             SetBkColor(DC, ColorArray[Attr shr 4]);
  562.             LA := Attr;
  563.             End;
  564.           Ch := Chr(ScrnArray^[Tx + (TY * ScreenWidth)] and $ff);
  565.           TextOut(DC, Tx * THorz, TY * TVert, PChar(@Ch), 1);
  566.           Inc(Tx);
  567.           End;
  568.         Inc(Ty);
  569.         End;
  570.       End;
  571.     EndPaint(HWindow, Paint);
  572.     End;
  573.   End;
  574.  
  575.  
  576. Procedure PutScrnWord (SX: Byte; SY: Byte; CA: Word);
  577.   Var
  578.     DC: HDC;
  579.  
  580.   Begin
  581.   DC := GetDC(HWindow);
  582.   PutScrnWordDC(SX, SY, CA, DC);
  583.   ReleaseDC(HWindow,DC);
  584.   End;
  585.  
  586.  
  587. Function  GetScrnWord(SX: Byte; SY: Byte): Word;
  588.   Begin
  589.   GetScrnWord := ScrnArray^[((SY - 1) * ScreenWidth) + SX - 1];
  590.   End;
  591.  
  592.  
  593. Function SaveScrnRegion(xl,yl,xh,yh: Byte; Var Pt: Pointer):Boolean;
  594.   Var
  595.     Tx: Byte;
  596.     Ty: Byte;
  597.     Ctr: Word;
  598.  
  599.   Begin
  600.   GetMem(Pt, ((xh + 1 - xl) * (yh +1 - yl) * 2));
  601.   If Pt = nil Then
  602.     SaveScrnRegion := False
  603.   Else
  604.     Begin
  605.     SaveScrnRegion := True;
  606.     Ctr := 0;
  607.     For Tx := xl to xh Do
  608.       Begin
  609.       For Ty := yl to yh Do
  610.         Begin
  611.         WordArrayPtr(PT)^[Ctr] := GetScrnWord(Tx, Ty);
  612.         Inc(Ctr);
  613.         End;
  614.       End;
  615.     End;
  616.   End;
  617.  
  618.  
  619. Procedure RestoreScrnRegion(xl,yl,xh,yh: Byte; Pt: Pointer);
  620.   Var
  621.     Tx: Byte;
  622.     Ty: Byte;
  623.     Ctr: Word;
  624.  
  625.   Begin
  626.   If Pt <> nil Then
  627.     Begin
  628.     Ctr := 0;
  629.     For Tx := xl to xh Do
  630.       Begin
  631.       For Ty := yl to yh Do
  632.         Begin
  633.         PutScrnWord(Tx, Ty, WordArrayPtr(PT)^[Ctr]);
  634.         Inc(Ctr);
  635.         End;
  636.       End;
  637.     FreeMem(Pt, ((xh + 1 - xl) * (yh +1 - yl) * 2));
  638.     End;
  639.   End;
  640.  
  641.  
  642.  
  643. Procedure DelCharInLine(Sx: Byte; Sy: Byte);
  644.   Var
  645.     Ex: Byte;
  646.     Cx: Byte;
  647.  
  648.   Begin
  649.   Ex := Lo(WindMax) + 1;
  650.   Cx := Sx;
  651.   While (Cx < Ex) Do
  652.     Begin
  653.     PutScrnWord(Cx, Sy, GetScrnWord(Cx + 1, Sy));
  654.     Inc(Cx);
  655.     End;
  656.   PutScrnWord(Ex, Sy, 32 + (TextAttr shl 8));
  657.   End;
  658.  
  659.  
  660. Procedure InsCharInLine(Sx: Byte; Sy: Byte; Ch: Char);
  661.   Var
  662.     Ex: Byte;
  663.     Cx: Byte;
  664.  
  665.   Begin
  666.   Ex := Lo(WindMax) + 1;
  667.   Cx := Ex;
  668.   While (Cx > Sx) Do
  669.     Begin
  670.     PutScrnWord(Cx, Sy, GetScrnWord(Cx - 1, Sy));
  671.     Dec(Cx);
  672.     End;
  673.   PutScrnWord(Sx, Sy, Ord(Ch) + (TextAttr shl 8));
  674.   End;
  675.  
  676.  
  677. Procedure InitializeScrnRegion(xl,yl,xh,yh: Byte; Ch: Char);
  678.   Var
  679.     Cx, Cy: Byte;
  680.  
  681.   Begin
  682.   xl := xl + (WindMin and $ff);
  683.   yl := yl + (WindMin shr 8);
  684.   xh := xh + (WindMin and $ff);
  685.   yh := yh + (WindMin shr 8);
  686.   If yh > ((WindMax shr 8) + 1) Then
  687.     yh := ((WindMax shr 8) + 1);
  688.   If xh > ((WindMax and $ff) + 1) Then
  689.     xh := ((WindMax and $ff) + 1);
  690.   Cx := xl;
  691.   Cy := yl;
  692.   While (cy <= yh) Do
  693.     Begin
  694.     While (Cx <= xh) Do
  695.       Begin
  696.       PutScrnWord(Cx, Cy, Ord(ch) + (TextAttr shl 8));
  697.       Inc(Cx);
  698.       End;
  699.     Inc(Cy);
  700.     End;
  701.   End;
  702.  
  703.  
  704.  
  705. Function  KeyPressed: Boolean;
  706.   Begin
  707.   If PeekMessage(Message, HWindow, 0, 0, pm_NoRemove) Then
  708.     Begin
  709.     GetMessage(Message, HWindow, wm_KeyFirst, wm_KeyLast);
  710.     If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
  711.       Begin
  712.       TranslateMessage(Message);
  713.       DispatchMessage(Message);
  714.       End;
  715.     End;
  716.   KeyPressed := (KeyPut <> KeySend);
  717.   End;
  718.  
  719.  
  720. Function  ReadKey: Char;
  721.   Begin
  722.   While KeySend = KeyPut Do
  723.     Begin
  724.     While PeekMessage(Message, HWindow, 0, 0, pm_NoRemove) Do
  725.       Begin
  726.       GetMessage(Message, HWindow, 0, 0);
  727.       If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
  728.         Begin
  729.         TranslateMessage(Message);
  730.         DispatchMessage(Message);
  731.         End;
  732.       End;
  733.     End;
  734.   ReadKey := GetKeyChar;
  735.   End;
  736.  
  737.  
  738. Procedure WinMain;
  739.   Var
  740.     DC: HDC;
  741.     Metrics: TTextMetric;
  742.  
  743.   Begin
  744.   if HPrevInst = 0 then
  745.     Begin
  746.     WindowClass.hInstance := HInstance;
  747.     WindowClass.hIcon := LoadIcon(0, idi_Application);
  748.     WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  749.     WindowClass.hbrBackground := GetStockObject(white_Brush);
  750.     if not RegisterClass(WindowClass) then Halt(255);
  751.     End;
  752.   HWindow := CreateWindow(
  753.   AppName,
  754.     'MKWCrt Application',
  755.     ws_OverlappedWindow,
  756.     cw_UseDefault,
  757.     cw_UseDefault,
  758.     cw_UseDefault,
  759.     cw_UseDefault,
  760.     0,
  761.     0,
  762.     HInstance,
  763.     nil);
  764.   ShowWindow(HWindow, CmdShow);
  765.   UpdateWindow(HWindow);
  766.   DC := GetDC(HWindow);
  767.   SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  768.   GetTextMetrics(DC, Metrics);
  769.   TVert := Metrics.tmHeight + Metrics.tmInternalLeading +
  770.     Metrics.tmExternalLeading;
  771.   THorz := Metrics.tmAveCharWidth;
  772.   ReleaseDC(HWindow,DC);
  773.   End;
  774.  
  775.  
  776. {$F+}
  777. Function WinWrite(Var F: TTextRec): Integer;
  778.   Var
  779.     i: Word;
  780.  
  781.   Begin
  782.   i := 0;
  783.   While i < F.BufPos Do
  784.     Begin
  785.     PutChar(F.BufPtr^[i]);
  786.     Inc(i);
  787.     End;
  788.   F.BufPos := 0;
  789.   WinWrite := 0;
  790.   End;
  791.  
  792.  
  793. {$F+}
  794. Function WinCrtClose(Var F: TTextRec): Integer;
  795.   Begin
  796.   F.Mode := fmClosed;
  797.   WinCrtClose := 0;
  798.   End;
  799.  
  800.  
  801. {$F+}
  802. Function WinCrtOpen(Var F: TTextRec): Integer;
  803.   Begin
  804.   If F.Mode = fmOutput Then
  805.     WinCrtOpen := 0
  806.   Else
  807.     WinCrtOpen := 5;
  808.   End;
  809.  
  810.  
  811. Procedure AssignWinCrt(Var F: Text);
  812.   Begin
  813.   TTextRec(F).Mode := fmClosed;
  814.   TTextRec(F).BufSize := SizeOf(TTextBuf);
  815.   TTextRec(F).BufPtr := @TTextRec(F).Buffer;
  816.   TTextRec(F).OpenFunc := @WinCrtOpen;
  817.   TTextRec(F).InOutFunc := @WinWrite;
  818.   TTextRec(F).FlushFunc := @WinWrite;
  819.   TTextRec(F).CloseFunc := @WinCrtClose;
  820.   TTextRec(F).Name[0] := #0;
  821.   End;
  822.  
  823.  
  824. Begin
  825. New(ScrnArray);
  826. ScrnHeight := ScreenHeight;
  827. ScrnWidth := ScreenWidth;
  828. WinMain;
  829. Accels :=LoadAccelerators(HInstance, 'A_RESOURCE');
  830. If Accels = 0 Then
  831.   MessageBeep(0);
  832. AssignWinCrt(Output);
  833. Rewrite(Output);
  834. KeyPut := 1;
  835. KeySend := 1;
  836. ClrScr;
  837. End.
  838.