{***************************************************************}
{***               FVision Unit Version1.0                   ***}
{***                    蓝蚂蚁工作室                         ***}
{***************************************************************}
{***                    事件处理单元                         ***}
{***************************************************************}
{$F+,X+,I-,S-}
Unit FEvent;
Interface
Uses
  Dos,Crt,FMouse,FTool,FGraph;

{ ******** EVENT MANAGER ******** }

const

{ Safe Memory }

  SafeMem=50000;

{ Event codes }

  evMouseDown = $0001;
  evMouseUp   = $0002;
  evMouseMove = $0004;
  evMouseAuto = $0008;
  evKeyDown   = $0010;
  evCommand   = $0100;
  evBroadcast = $0200;

{ Event masks }

  evNothing   = $0000;
  evMouse     = $000F;
  evKeyboard  = $0010;
  evMessage   = $FF00;

{ Extended key codes }
  kbSpace     = $3920; {57 32}
  kbEsc       = $011B;  kbAltSpace  = $0200;  kbCtrlIns   = $0400;
  kbShiftIns  = $0500;  kbCtrlDel   = $0600;  kbShiftDel  = $0700;
  kbBack      = $0E08;  kbCtrlBack  = $0E7F;  kbShiftTab  = $0F00;
  kbTab       = $0F09;  kbAltQ      = $1000;  kbAltW      = $1100;
  kbAltE      = $1200;  kbAltR      = $1300;  kbAltT      = $1400;
  kbAltY      = $1500;  kbAltU      = $1600;  kbAltI      = $1700;
  kbAltO      = $1800;  kbAltP      = $1900;  kbCtrlEnter = $1C0A;
  kbEnter     = $1C0D;  kbAltA      = $1E00;  kbAltS      = $1F00;
  kbAltD      = $2000;  kbAltF      = $2100;  kbAltG      = $2200;
  kbAltH      = $2300;  kbAltJ      = $2400;  kbAltK      = $2500;
  kbAltL      = $2600;  kbAltZ      = $2C00;  kbAltX      = $2D00;
  kbAltC      = $2E00;  kbAltV      = $2F00;  kbAltB      = $3000;
  kbAltN      = $3100;  kbAltM      = $3200;  kbF1        = $3B00;
  kbF2        = $3C00;  kbF3        = $3D00;  kbF4        = $3E00;
  kbF5        = $3F00;  kbF6        = $4000;  kbF7        = $4100;
  kbF8        = $4200;  kbF9        = $4300;  kbF10       = $4400;
  kbHome      = $4700;  kbUp        = $4800;  kbPgUp      = $4900;
  kbGrayMinus = $4A2D;  kbLeft      = $4B00;  kbRight     = $4D00;
  kbGrayPlus  = $4E2B;  kbEnd       = $4F00;  kbDown      = $5000;
  kbPgDn      = $5100;  kbIns       = $5200;  kbDel       = $5300;
  kbShiftF1   = $5400;  kbShiftF2   = $5500;  kbShiftF3   = $5600;
  kbShiftF4   = $5700;  kbShiftF5   = $5800;  kbShiftF6   = $5900;
  kbShiftF7   = $5A00;  kbShiftF8   = $5B00;  kbShiftF9   = $5C00;
  kbShiftF10  = $5D00;  kbCtrlF1    = $5E00;  kbCtrlF2    = $5F00;
  kbCtrlF3    = $6000;  kbCtrlF4    = $6100;  kbCtrlF5    = $6200;
  kbCtrlF6    = $6300;  kbCtrlF7    = $6400;  kbCtrlF8    = $6500;
  kbCtrlF9    = $6600;  kbCtrlF10   = $6700;  kbAltF1     = $6800;
  kbAltF2     = $6900;  kbAltF3     = $6A00;  kbAltF4     = $6B00;
  kbAltF5     = $6C00;  kbAltF6     = $6D00;  kbAltF7     = $6E00;
  kbAltF8     = $6F00;  kbAltF9     = $7000;  kbAltF10    = $7100;
  kbCtrlPrtSc = $7200;  kbCtrlLeft  = $7300;  kbCtrlRight = $7400;
  kbCtrlEnd   = $7500;  kbCtrlPgDn  = $7600;  kbCtrlHome  = $7700;
  kbAlt1      = $7800;  kbAlt2      = $7900;  kbAlt3      = $7A00;
  kbAlt4      = $7B00;  kbAlt5      = $7C00;  kbAlt6      = $7D00;
  kbAlt7      = $7E00;  kbAlt8      = $7F00;  kbAlt9      = $8000;
  kbAlt0      = $8100;  kbAltMinus  = $8200;  kbAltEqual  = $8300;
  kbCtrlPgUp  = $8400;  kbAltBack   = $0800;  kbNoKey     = $0000;

  kbCtrlA     = $1E01;  kbCtrlB     = $3002;  kbCtrlC     = $2E03;
  kbCtrlD     = $2004;  kbCtrlE     = $1205;  kbCtrlF     = $2106;
  kbCtrlG     = $2207;  kbCtrlH     = $2308;  kbCtrlI     = $1709;
  kbCtrlJ     = $240A;  kbCtrlK     = $250B;  kbCtrlL     = $260C;
  kbCtrlM     = $320D;  kbCtrlN     = $310E;  kbCtrlO     = $180F;
  kbCtrlP     = $1910;  kbCtrlQ     = $1011;  kbCtrlR     = $1312;
  kbCtrlS     = $1F13;  kbCtrlT     = $1414;  kbCtrlU     = $1615;
  kbCtrlV     = $2F16;  kbCtrlW     = $1117;  kbCtrlX     = $2018;
  kbCtrlY     = $1519;  kbCtrlZ     = $2C1A;


{ Keyboard state and shift masks }

  kbRightShift  = $0001;
  kbLeftShift   = $0002;
  kbCtrlShift   = $0004;
  kbAltShift    = $0008;
  kbScrollState = $0010;
  kbNumState    = $0020;
  kbCapsState   = $0040;
  kbInsState    = $0080;
  kbDoubleShift = $0003;

{ Mouse button state masks }

  mbLeftButton  = $01;
  mbRightButton = $02;

  btNormal      = $10;
  btHelp        = $20;

{ Const Command }
  cmValid   = 0;
  cmQuit    = 1;
  cmError   = 2;
  cmMenu    = 3;
  cmClose   = 4;
  cmZoom    = 5;
  cmResize  = 6;
  cmNext    = 7;
  cmPrev    = 8;
  cmHelp    = 9;

{ TDialog standard commands }

  cmOK      = 10;
  cmCancel  = 11;
  cmYes     = 12;
  cmNo      = 13;
  cmRetry   = 14;
  cmAbort   = 15;
  cmIgnore  = 16;
  cmReset   = 17;
  cmInsert  = 18;
  cmDelete  = 19;

{ Application command codes }

  cmCut     = 20;
  cmCopy    = 21;
  cmPaste   = 22;
  cmUndo    = 23;
  cmClear   = 24;
  cmTile    = 25;
  cmCascade = 26;
  cmTimer   = 27;
  cmInputS  = 28;
  cmChange  = 29;

{ Standard application commands }

  cmNew       = 30;
  cmOpen      = 31;
  cmSave      = 32;
  cmSaveAs    = 33;
  cmSaveAll   = 34;
  cmChangeDir = 35;
  cmDosShell  = 36;
  cmCloseAll  = 37;
  cmStop      = 38;
  cmTest      = 39;

{ Edit Code }

  cmLeft        = 40;
  cmRight       = 41;
  cmUp          = 42;
  cmDown        = 43;
  cmInterHor    = 44;
  cmInterVer    = 45;
  cmHome        = 46;
  cmEnd         = 47;
  cmPgUp        = 48;
  cmPgDn        = 49;
  cmCtrlHome    = 50;
  cmCtrlEnd     = 51;
  cmCtrlPgUp    = 52;
  cmCtrlPgDn    = 53;
  cmInterDouble = 54;
  cmInterHit    = 55;
  cmMove        = 56;
  cmSearch      = 57;
  cmReplace     = 58;
  cmSearchAgain = 59;

{ View Code }
  cmCloseWin    = 60;
  cmOkDown      = 61;
  cmPrevWin     = 62;
  cmNextWin     = 63;
  cmButtonDown  = 64;
  cmRButtonDown = 65;
  cmEditLeft    = 66;
  cmEditRight   = 67;
  cmEditUp      = 68;
  cmEditDown    = 69;

{ Dialog Code }
  cmOpenFile    = 70;
  cmMemory      = 71;
  cmPaintAll    = 72;
  cmAbout       = 73;
  cmSaveFile    = 74;
  cmSelectFile  = 75;
  cmChkSelect   = 76;
  cmNewDirectory= 77;
  cmDriver      = 78;
  cmInformation = 79;

{ Menu Code }
  cmIndex       = 80;
  cmTopicSearch = 81;
  cmPrevTopic   = 82;
  cmLeftMenu    = 83;
  cmRightMenu   = 84;

{ Stand Error Code }
  cmRunTimeError= 90;
  cmOutOfMemory = 91;

  cmChangeStatu   = 100;
  cmChangeIndex   = 101;

  cmCopyToClip    = 110;
  cmPasteFromClip = 111;
  cmShowClip      = 112;
  cmSearchStr     = 113;
  cmSelect        = 114;
  cmGotoLine      = 115;
  cmEnterPress    = 116;

  cmPlay          = 120;
  cmHead          = 121;
  cmTail          = 122;

Type
  String30=string[30];

{ Event record }
  TPoint=record
   X,Y:Integer;
  end;
  TRect=object
   A,B:TPoint;
  end;

  PEvent = ^TEvent;
  TEvent = record
    What: Word;
    case Word of
      evNothing: ();
      evMouse: (
        Buttons: Byte;
        Double: Boolean;
        Where: TPoint);
      evKeyDown: (
        CMark: Boolean;
        case Integer of
      0: (KeyCode: Word);
          1: (CharCode: Char;
              ScanCode: Byte);
          2: (HiCode,LoCode:Char));
      evMessage: (
        Index :Pointer;
        Command: Word;
        case Word of
          0: (InfoPtr  : Pointer);
          1: (InfoLong : Longint);
          2: (InfoWord : Word);
          3: (InfoInt  : Integer);
          4: (InfoByte : Byte);
          5: (InfoChar : Char);
          6: (InfoReal : Real);
          7: (InfoPoint: TPoint));
  end;

const

{ Initialized variables }

  ButtonCount: Byte = 0;
  MouseEvents: Boolean = False;
  MouseReverse: Boolean = False;
  DoubleDelay: Word = 30;
  RepeatDelay: Word = 30;
  CtrlBreakHit: Boolean = False;
  CritErrorFlag:Boolean = False;

var

{ Uninitialized variables }

  MouseIntFlag: Byte;
  MouseButtons: Byte;
  MouseWhere: TPoint;

  Event:TEvent;

{ Event manager routines }
Procedure InitEvent;
Procedure DoneEvent;
Procedure AssignRect(Var R:TRect; X1,Y1,X2,Y2:Integer);
Function IsIn(A:TPoint;P:TRect):Boolean;
Function MouIn(P:TRect):Boolean;
Function IsPosIn(Pos,Pa,Pb:TPoint):Boolean;
Function GetShiftState: Byte;
Function ShiftPush: Boolean;
Procedure GetEvent(var Event:TEvent);
Function GetcLen(S:string):Integer;
{ Keyboard support routines }

function GetAltChar(KeyCode: Word): Char;
function GetAltCode(Ch: Char): Word;
function GetCtrlChar(KeyCode: Word): Char;
function GetCtrlCode(Ch: Char): Word;

Implementation
Uses
  FMenu;
var
{ Event manager variables }

  LastButtons: Byte;
  DownButtons: Byte;
  LastDouble: Boolean;
  Mx,My:Integer;
  LastWhere: TPoint;
  DownWhere: TPoint;
  DownTicks: Word;
  AutoTicks: Word;
  AutoDelay: Word;
  EventCount: Word;

var
  ShiftState: Byte absolute $40:$17;
  Ticks: Word absolute $40:$6C;

var
  OldCritInt,OldBreakInt:Pointer;
  Hourf,Minutef,Secondf,Sec100f:Word;

procedure ResetTime;
begin
  GetTime(Hourf,Minutef,Secondf,Sec100f);
end;

function Time:Longint;
var
  Hour,Minute,Second,Sec100:Word;
  Time_Now:Longint;
begin
  GetTime(Hour,Minute,Second,Sec100);
  Time_Now:=Longint(Sec100+Second*100+Minute*6000)
           -Longint(Sec100f+Secondf*100+Minutef*6000);
  while Time_Now<0 do Inc(Time_Now,6000);
  Time:=Time_Now;
end;

Procedure AssignRect(Var R:TRect; X1,Y1,X2,Y2:Integer);
Begin
  R.A.X:=X1;
  R.A.Y:=Y1;
  R.B.X:=X2;
  R.B.Y:=Y2;
end;

function IsPosIn(Pos,Pa,Pb:TPoint):Boolean;
begin
  IsPosIn:=PosIn(Pos.x,Pos.y,Pa.x,Pa.y,Pb.x,Pb.y);
end;

function IsIn(A:TPoint;P:TRect):Boolean;
begin
  IsIn:=PosIn(A.x,A.y,P.a.x,P.a.y,P.b.x,P.b.y);
end;

function MouIn(P:TRect):Boolean;
var
  T:TRect;
begin
  Dec(P.a.x,16);
  Dec(P.a.y,16);
  MouIn:=IsIn(LastWhere,P);
end;

const
  SCriticalError:  string[29] = 'Critical disk error on drive ';
  SWriteProtected: string[33] = 'Disk is write-protected in drive ';
  SDiskNotReady:   string[27] = 'Disk is not ready in drive ';
  SDataIntegrity:  string[30] = 'Data integrity error on drive ';
  SSeekError:      string[20] = 'Seek error on drive ';
  SUnknownMedia:   string[28] = 'Unknown media type in drive ';
  SSectorNotFound: string[26] = 'Sector not found on drive ';
  SOutOfPaper:     string[20] = 'Printer out of paper';
  SWriteFault:     string[21] = 'Write fault on drive ';
  SReadFault:      string[20] = 'Read fault on drive ';
  SGeneralFailure: string[26] = 'Hardware failure on drive ';
  SBadImageOfFAT:  string[32] = 'Bad memory image of FAT detected';
  SDeviceError:    string[19] = 'Device access error';
  SInsertDisk:     string[25] = 'Insert diskette in drive ';
  SRetryOrCancel:  string[27] = '~Enter~ Retry  ~Esc~ Cancel';

{$V-}
function SystemError(ErrorCode: Integer; Drive: Byte): Integer;
var
  Ch:Char;
  TempStr:string;
begin
  case ErrorCode of
  0 :TempStr:=SWriteProtected;
  1 :TempStr:=SCriticalError;
  2 :TempStr:=SDiskNotReady;
  3 :TempStr:=SCriticalError;
  4 :TempStr:=SDataIntegrity;
  5 :TempStr:=SCriticalError;
  6 :TempStr:=SSeekError;
  7 :TempStr:=SUnknownMedia;
  8 :TempStr:=SSectorNotFound;
  9 :TempStr:=SOutOfPaper;
  10:TempStr:=SWriteFault;
  11:TempStr:=SReadFault;
  12:TempStr:=SGeneralFailure;
  13:TempStr:=SBadImageOfFAT;
  14:TempStr:=SDeviceError;
  15:TempStr:=SInsertDisk;
  else TempStr:='Unknown Error in drive ';
  end;
  Insert(#1'Critical Error '+IntStr(ErrorCode)+':',TempStr,1);
  if ErrorCode in [9,13,14] then
  begin
    TempStr:=TempStr+#0;
    SystemError:=0;
    StatusLine^.SwapLine(TempStr);
    CritErrorFlag:=True;
    Exit;
  end;
  TempStr:=TempStr+Chr(Ord('A')+Drive)+#0+SRetryOrCancel+#0;
  StatusLine^.SwapLine(TempStr);
  repeat
    Ch:=Readkey;
    if Ch=#0 then Ch:=ReadKey;
  until (Ch=#13)or(Ch=#27);
  if Ch=#13 then
    SystemError:=1
  else
    SystemError:=0;
  StatusLine^.SwapLine(TempStr);
end;
{$V+}

procedure NewCritInt(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:Word);interrupt;
var
  ErrorCode:Byte;
begin
  ErrorCode:=Lo(DI);
  if (AX and $8000)<>0 then
  begin
    ErrorCode:=13;
    if (Mem[BP:SI+5] and $80)<>0 then Inc(ErrorCode);
  end;
  AX:=(AX and $FF00)+Lo(SystemError(ErrorCode,Lo(AX)));
  if Lo(AX)=0 then Flags:=Flags or 1;
end;

procedure NewBreakInt(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:Word);interrupt;
begin
  CtrlBreakHit:=True;
end;

procedure InstallNewInt;
begin
  GetIntVec($24,OldCritInt);
  SetIntVec($24,@NewCritInt);
  GetIntVec($1B,OldBreakInt);
  SetIntVec($1B,@NewBreakInt);
end;

procedure InitEvent;
begin
  LastButtons:=0;
  LastDouble:=False;
  ResetTime;
  ShiftState:=ShiftState or kbInsState;
  InstallNewInt;
  CtrlBreakHit:=False;
end;

procedure DoneEvent;
begin
  SetIntVec($24,OldCritInt);
  SetIntVec($1B,OldBreakInt);
end;

procedure GetMouseEvent(var Event: TEvent);
begin
  if not MouseGood then Exit;
  GetPosition(DownButtons,Mx,My);
  DownWhere.x:=Mx;
  DownWhere.y:=My;
  if (DownButtons<>0) and (LastButtons=0)
     and LastDouble and (Time<DoubleDelay) then
  begin
    Event.What:=evMouseDown;
    Event.Buttons:=DownButtons;
    Event.Double:=True;
    Event.Where:=DownWhere;
    LastDouble:=False;
    LastButtons:=DownButtons;
    LastWhere:=DownWhere;
  end else
  if (DownButtons=LastButtons) and (DownButtons<>0)
     and (LastWhere.x=Mx) and (LastWhere.y=My)
     and (Time>RepeatDelay) then
  begin
    Event.What:=evMouseAuto;
    Event.Buttons:=DownButtons;
    Event.Double:=False;
    Event.Where:=DownWhere;
    LastDouble:=False;
    LastButtons:=DownButtons;
    LastWhere:=DownWhere;
  end else
  if (LastButtons=0) and(DownButtons<>0) and
     (LastWhere.x=Mx) and (LastWhere.y=My) then
  begin
    Event.What:=evMouseDown;
    Event.Buttons:=DownButtons;
    Event.Double:=False;
    Event.Where:=DownWhere;
    LastButtons:=DownButtons;
    LastWhere:=DownWhere;
    ResetTime;
    LastDouble:=False;
  end else
  if (LastButtons<>0) and (DownButtons=0) then
  begin
    Event.What:=evMouseUp;
    Event.Buttons:=LastButtons;
    Event.Double:=False;
    Event.Where:=DownWhere;
    LastButtons:=DownButtons;
    LastWhere:=DownWhere;
    if Time<DoubleDelay then
      LastDouble:=True
    else
      LastDouble:=False;
  end else
  if (LastWhere.x<>Mx) or (LastWhere.y<>My) then
  begin
    Event.What:=evMouseMove;
    Event.Buttons:=DownButtons;
    Event.Double:=False;
    Event.Where:=DownWhere;
    LastButtons:=DownButtons;
    LastWhere:=DownWhere;
  end;
end;

procedure ConvertEvent(var Event: TEvent);
begin
  if (Event.KeyCode=$5200)or(Event.KeyCode=$5300)or
     (Event.KeyCode=$52E0)or(Event.KeyCode=$53E0) then
  begin
    if (ShiftState and $03 <> 0) then
    begin
      if (Event.KeyCode=$5200)or(Event.KeyCode=$52E0) then
        Event.KeyCode:=$0500
      else
        Event.KeyCode:=$0700;
    end;
  end else
  if (Event.KeyCode=$9200)or(Event.KeyCode=$9300)or
     (Event.KeyCode=$92E0)or(Event.KeyCode=$93E0) then
  begin
    if (ShiftState and $04 <> 0) then
    begin
      if (Event.KeyCode=$9200)or(Event.KeyCode=$92E0) then
        Event.KeyCode:=$0400
      else
        Event.KeyCode:=$0600;
    end;
  end;
end;

procedure GetKeyEvent(var Event: TEvent);
var
  Regs:Registers;
begin
  Regs.AH:=$00;
  Intr($16,Regs);
  Event.What:=evKeyDown;
  Event.CMark:=False;
  Event.KeyCode:=Regs.AX;
  ConvertEvent(Event);
end;

procedure GetEvent(var Event:TEvent);
begin
  if KeyPressed then
    GetKeyEvent(Event)
  else
    GetMouseEvent(Event);
end;

{
function GetKeyEvent:Word;assembler;
asm
      mov ah,01h
      int 16h
      jz @@1
      mov ah,00h
      int 16h
      jmp @@3
  @@1:mov ah,11h
      int 16h
      jz @@2
      mov ah,10h
      int 16h
      jmp @@3
  @@2:mov ax,00h
  @@3:
end;

procedure GetEvent(var Event:TEvent);
var
  Key:Word;
begin
  Key:=GetKeyEvent;
  if Key<>0 then
  begin
    Event.What:=evKeyDown;
    Event.KeyCode:=Key;
    Event.CMark:=False;
    ConvertEvent(Event);
  end
  else
    GetMouseEvent(Event);
end;
}
Function GetShiftState: Byte; assembler;
asm
    MOV    ES,Seg0040
    MOV    AL,ES:ShiftState
end;

Function ShiftPush: Boolean; assembler;
asm
    MOV    ES,Seg0040
    MOV    AL,ES:ShiftState
        AND     AL,03H
end;

{$V+}

{ ******** UTILITY ROUTINES ******** }

function GetcLen(S:string):Integer;
var
  i,j:Integer;
begin
  i:=0;
  for j:=1 to Length(S) do
  if S[j]<>'~' then Inc(i);
  GetcLen:=i;
end;

{ Keyboard support routines }

const

  AltCodes1: array[$10..$32] of Char =
    'QWERTYUIOP'#0#0#0#0'ASDFGHJKL'#0#0#0#0#0'ZXCVBNM';

  AltCodes2: array[$78..$83] of Char =
    '1234567890-=';

function GetAltChar(KeyCode: Word): Char;
begin
  GetAltChar := #0;
  if Lo(KeyCode) = 0 then
    case Hi(KeyCode) of
      $02: GetAltChar := #240;
      $10..$32: GetAltChar := AltCodes1[Hi(KeyCode)];
      $78..$83: GetAltChar := AltCodes2[Hi(KeyCode)];
    end;
end;

function GetAltCode(Ch: Char): Word;
var
  I: Word;
begin
  GetAltCode := 0;
  if Ch = #0 then Exit;
  Ch := UpCase(Ch);
  if Ch = #240 then
  begin
    GetAltCode := $0200;
    Exit;
  end;
  for I := $10 to $32 do
    if AltCodes1[I] = Ch then
    begin
      GetAltCode := I shl 8;
      Exit;
    end;
  for I := $78 to $83 do
    if AltCodes2[I] = Ch then
    begin
      GetAltCode := I shl 8;
      Exit;
    end;
end;

function GetCtrlChar(KeyCode: Word): Char;
begin
  GetCtrlChar := #0;
  if (Lo(KeyCode) <> 0) and (Lo(KeyCode) <= Byte('Z') - Byte('A') + 1) then
    GetCtrlChar := Char(Lo(KeyCode) + Byte('A') - 1);
end;

function GetCtrlCode(Ch: Char): Word;
begin
  GetCtrlCode := GetAltCode(Ch) or (Byte(UpCase(Ch)) - Byte('A') + 1);
end;

end.