Unit Mouse;

{$R+}

Interface

Uses
  Crt,
  DOS,
  graph;

type cursor_shape = record
                      mask: array [1..32] of word;
                      hot_x,hot_y: word;
                    end;
     mouse_mode_type = (idle,pressed,held,start_drag,dragging,end_drag,clicked);

function reset_mouse(var num_buttons: word): boolean; {}
function mouse_exists: boolean; {}
procedure show_mouse; {}
procedure hide_mouse; {}
procedure show_mouse_moved;
procedure mouse_shape(var shape: cursor_shape); {}
procedure get_mouse_position(var x,y,button: word); {}
procedure set_mouse_position(x,y: word); {}
procedure last_mouse_press(var x,y,count: word; button: word); {}
procedure last_mouse_release(var x,y,count: word; button: word); {}
procedure mouse_limits(xmin,ymin,xmax,ymax: word); {}
function mouse_x_factor: word; {}
function screen_mouse(var num_buttons: word): boolean; {}
procedure test_mouse; {}
procedure test_text_mouse; {}
function mouse_mode(var x1,y1,x2,y2: word): mouse_mode_type; {}

Implementation

var x_factor: word;
    shown,textmouse: boolean;
    mode: mouse_mode_type;
    mouse_ok: boolean;




{--------------------------------------------------------------------------

PROCEDURE    call_mouse

PARAMETERS   service: word; service required
             var ax: word;  register input/output
             var bx: word;  register input/output
             var cx: word;  register input/output
             var dx: word;  register input/output
             var es: word;  register input/output

DESCRIPTION  calls the microsoft mouse interface via interrupt $33

             sets up the registers:
               AX := service
               BX := bx
               CX := cx
               DX := dx
               ES := es

             calls interrupt $33

             returns the register values
               ax := AX
               bx := BX
               cx := CX
               dx := DX
               es := ES

             the calling conventions and services are described in the microsoft
             mouse manual

--------------------------------------------------------------------------}
procedure call_mouse(service: word; var ax,bx,cx,dx,es: word);
  var r: registers;
begin
  r.ax:=service;
  r.bx:=bx;
  r.cx:=cx;
  r.dx:=dx;
  r.es:=es;
  intr($33,r);
  ax:=r.ax;
  bx:=r.bx;
  cx:=r.cx;
  dx:=r.dx;
  es:=r.es;
end;




{--------------------------------------------------------------------------

PROCEDURE    show_mouse;

DESCRIPTION  makes the mouse cursor visible

             calls mouse service 1

             the microsoft service decrements an internal flag and shows the
             mouse if the flag is 0 otherwise it's hidden

             this procedure protects the user from that piece of silly design:
             if you call show_mouse, the mouse is shown full stop!

GLOBALS      shown

--------------------------------------------------------------------------}
procedure show_mouse;
  var a: word;
begin
  if not shown then
    call_mouse(1,a,a,a,a,a);
  shown:=true;
end;




{--------------------------------------------------------------------------

PROCEDURE    show_mouse_moved;

DESCRIPTION  makes the mouse cursor visible if the mouse has moved since this
             was last called

--------------------------------------------------------------------------}
procedure show_mouse_moved;
  const px: word = 10000;
        py: word = 10000;
  var x,y,b: word;
begin
  get_mouse_position(x,y,b);
  if (x <> px) or (y <> py) then
  begin
    show_mouse;
    px:=x; py:=y;
  end;
end;




{--------------------------------------------------------------------------

PROCEDURE    hide_mouse;

DESCRIPTION  hides the mouse cursor

             calls mouse service 2

             the microsoft service decrements an internal flag and shows the
             mouse if the flag is 0 otherwise it's hidden

             this procedure protects the user from that piece of silly design:
             if you call hide_mouse, the mouse is hidden full stop!

GLOBALS      shown

--------------------------------------------------------------------------}
procedure hide_mouse;
  var a: word;
begin
  if shown then
    call_mouse(2,a,a,a,a,a);
  shown:=false;
end;




{--------------------------------------------------------------------------

FUNCTION     reset_mouse

PARAMETERS   var num_buttons: word; returns the number of buttons on the mouse

RESULT       boolean; if a mouse is intalled then true else false

DESCRIPTION  the mouse drivers are reset

             calls mouse service 0

             the x_factor is set to the number of mickeys per pixel

             the cursor is hidden

             textmouse := false; i.e. the cursor is a graphics cursor

             if the reset succeeded then

               return true

             else

               return false

GLOBALS      x_factor
             textmouse
             shown

--------------------------------------------------------------------------}
function reset_mouse(var num_buttons: word): boolean;
  var ax,a: word;
begin
  call_mouse(0,ax,num_buttons,a,a,a);
  mouse_ok:=ax=$FFFF;
  reset_mouse:=mouse_ok;
  if GetMaxX <> 0 then x_factor:=640 div GetMaxX;
  mode:=idle;
  textmouse:=false;
  shown:=false;
end;




{--------------------------------------------------------------------------

PROCEDURE    mouse_shape

PARAMETERS   var shape: cursor_shape;

DESCRIPTION  define the mouse cursor shape

             calls mouse service 9

             the cursor is described in the microsoft mouse manual

             the 'mask' defines the shape of the cursor
             hot_x and hot_y define the cursor hotspot

--------------------------------------------------------------------------}
procedure mouse_shape(var shape: cursor_shape);
  var dx,es: word;
begin
  with shape do
  begin
    es:=seg(mask);
    dx:=ofs(mask);
    call_mouse(9,dx,hot_x,hot_y,dx,es);
  end;
end;




{--------------------------------------------------------------------------

PROCEDURE    get_mouse_position

PARAMETERS   var x: word;      returns the mouse position in pixels or chars
             var y: word;      returns the mouse position in pixels or chars
             var button: word; returns the button states

DESCRIPTION  returns the current mouse position and button states

             is its a graphics cursor then
                returns the position in pixels
              else
                returns the position in screen characters

             calls mouse service 3

             each button is represented by one bit:

               button 1 down:    00000001
               button 2 down:    00000010
               button 3 down:    00000100

             button is the sum of these bits

--------------------------------------------------------------------------}
procedure get_mouse_position(var x,y,button: word);
  var a: word;
begin
  if not mouse_ok then
    begin x:=1; y:=1; button:=0; exit end;

  call_mouse(3,a,button,x,y,a);
  if textmouse then
  begin
    x:=1+x div 8;
    y:=1+y div 8;
  end else
    x:=x div x_factor;
end;




{--------------------------------------------------------------------------

PROCEDURE    set_mouse_position

PARAMETERS   x: word; the mouse position in pixels
             y: word; the mouse position in pixels

DESCRIPTION  sets the current mouse position

             calls mouse service 4

             is its a graphics cursor then
                the position is in pixels
              else
                the position is in screen characters

--------------------------------------------------------------------------}
procedure set_mouse_position(x,y: word);
  var a: word;
begin
  if textmouse then
  begin
    x:=x*8-1;
    y:=y*8-1;
  end else
    x:=x * x_factor;
  call_mouse(4,a,a,x,y,a);
end;




{--------------------------------------------------------------------------

PROCEDURE    last_mouse_press

PARAMETERS   var x: word;      returns the mouse position in pixels or chars
             var y: word;      returns the mouse position in pixels or chars
             var count: word;  returns the number of presses since last called
             button: word;     the button of interest

DESCRIPTION  returns the mouse position when the specified button was last
             pressed

             is its a graphics cursor then
                returns the position in pixels
              else
                returns the position in screen characters

             calls mouse service 5

             the button of interest is 1, 2, 3, etc.

--------------------------------------------------------------------------}
procedure last_mouse_press(var x,y,count: word; button: word);
  var a: word;
begin
  if not mouse_ok then
    begin x:=1; y:=1; count:=0; button:=0; exit end;

  call_mouse(5,button,count,x,y,a);
  if textmouse then
  begin
    x:=1+x div 8;
    y:=1+y div 8;
  end else
    x:=x div x_factor;
end;




{--------------------------------------------------------------------------

PROCEDURE    last_mouse_release

PARAMETERS   var x: word;      returns the mouse position in pixels or chars
             var y: word;      returns the mouse position in pixels or chars
             var count: word;  returns the number of releases since last called
             button: word;     the button of interest

DESCRIPTION  returns the mouse position when the specified button was last
             released

             is its a graphics cursor then
                returns the position in pixels
              else
                returns the position in screen characters

             calls mouse service 6

             the button of interest is 1, 2, 3, etc.

--------------------------------------------------------------------------}
procedure last_mouse_release(var x,y,count: word; button: word);
  var a: word;
begin
  if not mouse_ok then
    begin x:=1; y:=1; count:=0; button:=0; exit end;

  call_mouse(6,button,count,x,y,a);
  if textmouse then
  begin
    x:=1+x div 8;
    y:=1+y div 8;
  end else
    x:=x div x_factor;
end;




{--------------------------------------------------------------------------

PROCEDURE    mouse_limits

PARAMETERS   xmin: word; limit of mouse cursor in pixels or chars
             ymin: word; limit of mouse cursor in pixels or chars
             xmax: word; limit of mouse cursor in pixels or chars
             ymax: word; limit of mouse cursor in pixels or chars

DESCRIPTION  sets the mouse limits

             calls mouse service 7 and 8

             is its a graphics cursor then
                the position is in pixels
              else
                the position is in screen characters

--------------------------------------------------------------------------}
procedure mouse_limits(xmin,ymin,xmax,ymax: word);
  var a: word;
begin
  if textmouse then
  begin
    xmin:=xmin*8-1;
    xmax:=xmax*8-1;
    ymin:=ymin*8-1;
    ymax:=ymax*8-1;
  end else
  begin
    xmin:=xmin * x_factor;
    xmax:=xmax * x_factor;
  end;
  call_mouse(7,a,a,xmin,xmax,a);
  call_mouse(8,a,a,ymin,ymax,a);
end;




{--------------------------------------------------------------------------

FUNCTION     mouse_x_factor

RESULT       word; the x_factor

DESCRIPTION  returns the mouse xfactor in mickeys per pixel

--------------------------------------------------------------------------}
function mouse_x_factor: word;
begin
  mouse_x_factor:=x_factor;
end;




{--------------------------------------------------------------------------

FUNCTION     mouse_x_factor

RESULT       true if the mouse has been reset ok else false;

DESCRIPTION  returns whetheer the mouse drivers exist and have
             been reset

--------------------------------------------------------------------------}
function mouse_exists: boolean; {}
begin
  mouse_exists:=mouse_ok;
end;



{--------------------------------------------------------------------------

FUNCTION     screen_mouse

PARAMETERS   var num_buttons: word; returns the number of buttons on the mouse

RESULT       boolean; if a mouse is intalled then true else false

DESCRIPTION  the mouse drivers are reset

             calls mouse service 0 and 10

             the x_factor is set to 1

             the text cursor is set to invert the colour of the character

             the cursor is shown

             textmouse := true; i.e. the cursor is a text cursor

             if the reset succeeded then

               return true

             else

               return false

GLOBALS      x_factor
             textmouse
             shown

--------------------------------------------------------------------------}
function screen_mouse(var num_buttons: word): boolean;
  var ax,bx,and_mask,xor_mask,es: word;
begin
  call_mouse(0,ax,num_buttons,bx,bx,bx);
  mouse_ok:=ax=$FFFF;
  screen_mouse:=mouse_ok;
  bx:=0;
  and_mask:=$FFFF;
  xor_mask:=$7700;
  call_mouse(10,ax,bx,and_mask,xor_mask,es);

  mode:=idle;
  x_factor:=1;
  shown:=false;
  show_mouse;

  textmouse:=true;
end;




{--------------------------------------------------------------------------

FUNCTION     mouse_mode

PARAMETERS   var x1,y1: word; start drag position
             var x2,y2: word; end drag position

RESULT       mouse_mode_type;

DESCRIPTION  returns current mouse status, e.g.

                   mouse action      mouse_mode    x1,y1        x2,y2
                   ------------      ----------    -----        -----
                                     idle          current pos  current pos
                                     idle          current pos  current pos
                                     idle          current pos  current pos
                   move
                                     idle          current pos  current pos
                   move
                                     idle          current pos  current pos
                                     idle          current pos  current pos
                   press
                                     pressed       press pos    current pos
                                     held          press pos    current pos
                                     held          press pos    current pos
                                     held          press pos    current pos
                   release
                                     clicked       press pos    release pos
                                     idle          current pos  current pos
                                     idle          current pos  current pos
                                     idle          current pos  current pos
                   press
                                     pressed       press pos    current pos
                                     held          press pos    current pos
                                     held          press pos    current pos
                                     held          press pos    current pos
                   move
                                     start_drag    press pos    current pos
                                     dragging      press pos    current pos
                                     dragging      press pos    current pos
                   move
                                     dragging      press pos    current pos
                                     dragging      press pos    current pos
                   release
                                     end_drag      press pos    release pos
                                     idle          current pos  current pos
                                     idle          current pos  current pos

             x1,y1 return the current mouse position or the position it was
             in when the button was last pressed

             x2,y2 return the current mouse position or the position it was
             in when the button was last released

             the routine polls the mouse rather than using the
             last_mouse_press and last_mouse_release procedures

--------------------------------------------------------------------------}
function mouse_mode(var x1,y1,x2,y2: word): mouse_mode_type;
  var x,y,b,c: word;
  const moved: boolean = false;
        prev_b:    boolean = false;
        last_press_x:   word = 0;
        last_press_y:   word = 0;
        last_release_x: word = 0;
        last_release_y: word = 0;
begin
  Get_Mouse_position(x,y,B);

  if (b and 1) = 0 then
  begin
    if prev_b then
    begin
      last_release_x:=x;
      last_release_y:=y;
    end;
    prev_b:=false;

    case mode of
      pressed,
      held,
      start_drag,
      dragging: begin
              x1:=last_press_x;
              y1:=last_press_y;
              x2:=last_release_x;
              y2:=last_release_y;
              if (x1 <> x2) or (y1 <> y2) then moved:=true;
              if moved then
                mode:=end_drag else
                mode:=clicked;
            end;
      else  begin
              x1:=x;
              y1:=y;
              x2:=x;
              y2:=y;
              mode:=idle;
            end;
    end;
  end else
  begin
    if not prev_b then
    begin
      last_press_x:=x;
      last_press_y:=y;
    end;
    prev_b:=true;

    case mode of
      idle: begin
              x1:=last_press_x;
              y1:=last_press_y;
              x2:=x;
              y2:=y;
              mode:=pressed;
              moved:=false;
            end;
      else  begin
              x1:=last_press_x;
              y1:=last_press_y;
              x2:=x;
              y2:=y;
              if (x1 <> x2) or (y1 <> y2) then moved:=true;
              if not moved then
                mode:=held else
              if mode = held then
                mode:=start_drag else
                mode:=dragging;
            end;
    end;
  end;
  mouse_mode:=mode;
end;

{--------------------------------------------------------------------------

PROCEDURE    test_mouse;

DESCRIPTION  a short test program

             resets the mouse to a graphics cursor

--------------------------------------------------------------------------}
procedure test_mouse;
  var x,y,b,ax,num_buttons,a,x1,y1,x2,y2: word;
begin
  if not reset_mouse(num_buttons) then
    begin writeln('Error on Reset'); halt; end;
  x_factor:=1;
  clrscr;
  repeat
    Get_Mouse_position(x,y,B);
    gotoxy(1,1);
    writeln(x:10,y:10,b:10);
    case mouse_mode(x1,y1,x2,y2) of
      idle:     writeln('idle     ');
      pressed:  begin
                  writeln('pressed    ');
                  writeln(x1:10,y1:10);
                  writeln(x2:10,y2:10);
                  delay(500);
                end;
      held:     begin
                  writeln('held       ');
                  writeln(x1:10,y1:10);
                  writeln(x2:10,y2:10);
                end;
      start_drag: begin
                  writeln('start_drag ');
                  writeln(x1:10,y1:10);
                  writeln(x2:10,y2:10);
                  delay(500);
                end;
      dragging: begin
                  writeln('dragging   ');
                  writeln(x1:10,y1:10);
                  writeln(x2:10,y2:10);
                end;
      end_drag:  begin
                  writeln('end_drag    ');
                  writeln(x1:10,y1:10);
                  writeln(x2:10,y2:10);
                  delay(500);
                end;
      clicked:  begin
                  writeln('clicked    ');
                  writeln(x1:10,y1:10);
                  writeln(x2:10,y2:10);
                  delay(500);
                end;
    end;
  until keypressed;
end;





{--------------------------------------------------------------------------

PROCEDURE    test_text_mouse;

DESCRIPTION  a short test program

             resets the mouse to a text cursor

             shows the text cursor

             moves the current writing position whenever the left button is
             pressed

             repeats until Ctrl-C is pressed

             writes the mouse position and button state until a key is pressed

             drags a single line box

             on release: draws a double line box

--------------------------------------------------------------------------}
procedure test_text_mouse;
  procedure erase_box(x1,y1,x2,y2: integer);
    var x,y: integer;
  begin
    if (x1 = x2) or (y1 = y2) then exit;
    if x1 > x2 then begin x:=x1; x1:=x2; x2:=x; end;
    if y1 > y2 then begin y:=y1; y1:=y2; y2:=y; end;
    gotoxy(x1,y1);
    for x:=x1 to x2 do write(' ');
    for y:=y1+1 to y2-1 do
    begin
      gotoxy(x1,y); write(' ');
      gotoxy(x2,y); write(' ');
    end;
    gotoxy(x1,y2);
    for x:=x1 to x2 do write(' ');
  end;

  procedure draw_box_2(x1,y1,x2,y2: integer);
    var x,y: integer;
  begin
    if (x1 = x2) or (y1 = y2) then exit;
    if x1 > x2 then begin x:=x1; x1:=x2; x2:=x; end;
    if y1 > y2 then begin y:=y1; y1:=y2; y2:=y; end;
    gotoxy(x1,y1);
    write('É');
    for x:=x1+1 to x2-1 do write('Í');
    write('»');
    for y:=y1+1 to y2-1 do
    begin
      gotoxy(x1,y); write('º');
      gotoxy(x2,y); write('º');
    end;
    gotoxy(x1,y2);
    write('È');
    for x:=x1+1 to x2-1 do write('Í');
    write('¼');
  end;

  procedure draw_box_1(x1,y1,x2,y2: integer);
    var x,y: integer;
  begin
    if (x1 = x2) or (y1 = y2) then exit;
    if x1 > x2 then begin x:=x1; x1:=x2; x2:=x; end;
    if y1 > y2 then begin y:=y1; y1:=y2; y2:=y; end;
    gotoxy(x1,y1);
    write('Ú');
    for x:=x1+1 to x2-1 do write('Ä');
    write('¿');
    for y:=y1+1 to y2-1 do
    begin
      gotoxy(x1,y); write('³');
      gotoxy(x2,y); write('³');
    end;
    gotoxy(x1,y2);
    write('À');
    for x:=x1+1 to x2-1 do write('Ä');
    write('Ù');
  end;

  var
    px,py,x,y,b,x1,y1,x2,y2,px1,py1,px2,py2: word;
    c: char;
begin
  clrscr;
  if not screen_mouse(b) then write('mouse not found');
  get_mouse_position(px,py,b);

  repeat
    hide_mouse;
    repeat
      get_mouse_position(x,y,b);
      if (x <> px) or (y <> py) then show_mouse;
      case mouse_mode(x1,y1,x2,y2) of
        start_drag,
        dragging: begin
                    erase_box(px1,py1,px2,py2);
                    draw_box_1(x1,y1,x2,y2);
                    hide_mouse;
                    gotoxy(x,y);
                  end;
        end_drag:  begin
                    erase_box(px1,py1,px2,py2);
                    draw_box_2(x1,y1,x2,y2);
                    hide_mouse;
                    gotoxy(x,y);
                  end;
        clicked:  begin
                    hide_mouse;
                    x:=x1;
                    y:=y1;
                    gotoxy(x,y);
                  end;
      end;

{
gotoxy(1,1);
writeln(x1:10,y1:10);
writeln(x2:10,y2:10);
{}
      px:=x; py:=y;
      px1:=x1; py1:=y1;
      px2:=x2; py2:=y2;
    until keypressed;
    c:=readkey;
    write(c);
  until c = #3;
end;

begin
  mouse_ok:=false;
end.

/////////////////////////////////////////////////////


