Power-Programmierung/CD1.mdf/pascal/library/dos/sound/sampler/mousfunc.pas

Pascal/Delphi Source File | 1989-03-28 | 8.0 KB | 289 lines

{ Functions for MSmouse and Turbo Pascal 4             Rowan McKenzie 28/3/89}

Unit mousfunc;

Interface

Uses crt, dos, turbmous, graph;

Const
  arrowxsize     = 11;            {width of arrow pointer}
  arrowysize     = 17;            {height       "         }

Var
  mousex, mousey : Integer;
  mouseexists    : Boolean;
  arrowcolor     : Word;

Function mouseinit : Boolean;
  { Initialise mouse, return true if mouse available}

Procedure initpointer;
  { initialise mouse arrow pointer (must be graphics mode)}

Procedure mousearrowon;
  { Plots an arrow pointer at x,y}

Procedure mousearrowoff;
  { Removes last arrow pointer}

Function mousemoved : Boolean;
  { Checks for movement of mouse, if true, updates x,y}

Function mousekeys : Byte;
{ returns mouse key status in byte
    eg bit 0 for left key
       bit 1 for right key
       bit 2 for centre key         }


Procedure updatemousepos;

  { limit mouse movement and replot in new position}

Function trackmouse : Char;
  { plot mouse arrow until mouse key pressed, keypress interrupts}

Implementation

Const
  arrowpoints    = 10;            {no. points in arrow}

  uparrowshape : Array[1..arrowpoints] Of pointtype =
  ((x : 0; y : 0), (x : 0; y : 13), (x : 3; y : 10), (x : 6; y : 16),
   (x : 8; y : 16), (x : 8; y : 15), (x : 6; y : 9), (x : 10; y : 9),
   (x : 1; y : 0), (x : 0; y : 0));

Var
  arrowpointers  : Array[1..arrowxsize] Of Pointer;
  mousexold, mouseyold,
  mouselastx, mouselasty : Integer; {last x,y of mouse arrow for erase}



  Function mouseinit : Boolean;

    { Initialise mouse, return true if mouse available}

  Begin                           {mouseinit}
    mouseexists := False;
    If msmouse Then
    Begin
      mouseexists := True;
      reset_mouse;
      mouseinit := True;
    End
    Else
      mouseinit := False;
  End;                            {mouseinit}



  Procedure initpointer;

    { initialise mouse arrow pointer (must be graphics mode)}

  Var i          : Integer;

  Begin                           {initpointer}
    arrowcolor := getmaxcolor;
    mousex := getmaxx Div 2;      {start mouse in screen centre}
    mousey := getmaxy Div 2;
    mouselastx := mousex;
    mouselasty := mousey;
    mousexold := mousex;
    mouseyold := mousey;
    drawpoly(arrowpoints, uparrowshape); {draw arrow}
    fillpoly(arrowpoints, uparrowshape);
    For i := 1 To arrowxsize Do
    Begin
      GetMem(arrowpointers[i], imagesize(0, 0, arrowxsize-1, arrowysize));
      getimage(0, 0, i-1, arrowysize, arrowpointers[i]^); {save image}
    End;
    cleardevice;
  End;                            {initpointer}



  Procedure mousearrowon;

    { Plots an arrow pointer at mousex,mousey}

  Var viewport   : viewporttype;

  Begin                           {mousearrowon}
    getviewsettings(viewport);
    setviewport(0, 0, getmaxx, getmaxy, True);
    If mousey = getmaxy Then      {puimage doesn't work on last line!}
    Begin
      putpixel(mousex, mousey, getmaxcolor-getpixel(mousex, mousey));
      putpixel(Succ(mousex), mousey, getmaxcolor-getpixel(Succ(mousex), mousey));
    End
    Else
      If mousex <= getmaxx-Pred(arrowxsize) Then
        putimage(mousex, mousey, arrowpointers[arrowxsize]^, xorput)
      Else
        putimage(mousex, mousey, arrowpointers[getmaxx-Pred(mousex)]^, xorput);
    setviewport(viewport.x1, viewport.y1, viewport.x2, viewport.y2,
                viewport.clip);
    mouselastx := mousex;
    mouselasty := mousey;
  End;                            {mousearrowon}


  Procedure mousearrowoff;

    { Removes last arrow pointer}

  Var
    viewport       : viewporttype;

  Begin                           {mousearrowoff}
    getviewsettings(viewport);
    setviewport(0, 0, getmaxx, getmaxy, True);
    If mouselasty = getmaxy Then  {puimage doesn't work on last line!}
    Begin
      putpixel(mouselastx, mouselasty,
               getmaxcolor-getpixel(mouselastx, mouselasty));
      putpixel(Succ(mouselastx), mouselasty,
               getmaxcolor-getpixel(Succ(mouselastx), mouselasty));
    End
    Else
      If mouselastx <= getmaxx-Pred(arrowxsize) Then
        putimage(mouselastx, mouselasty, arrowpointers[arrowxsize]^, xorput)
      Else
        putimage(mouselastx, mouselasty,
                 arrowpointers[getmaxx-Pred(mouselastx)]^, xorput);
    setviewport(viewport.x1, viewport.y1, viewport.x2, viewport.y2,
                viewport.clip);
  End;                            {mousearrowoff}


  Function mousemoved : Boolean;

    { Checks for movement of mouse, if true, updates mousex,y}

  Var xinc, yinc : Integer;

  Begin                           {mousemoved}
    If mouseexists Then
    Begin
      mouse_motion(xinc, yinc);
      If (xinc <> 0) Or (yinc <> 0) Then
      Begin
        mousemoved := True;
        mousex := mousex+xinc;
        mousey := mousey+yinc;
      End
      Else
        mousemoved := False;
    End
    Else
      mousemoved := False;
  End;                            {mousemoved}


  Function mousekeys : Byte;

{ returns mouse key status in byte
    eg bit 0 for left key
       bit 1 for right key
       bit 2 for centre key

  keyboard equivalents are Alt  for left button
                           Ctrl for centre button
                           caps for right button  }

  Var dummy, keys : Integer;

  Begin                           {mousekeys}
    keys := 0;
    If (mem[$0:$417] And 12 > 0) Or (mem[$0:$418] And 64 > 0)
    Or Not mouseexists Then       {if one of three keys down}
    Begin
      If mem[$0:$418] And 64 > 0 Then {caps lock}
        keys := keys+2;
      If mem[$0:$417] And 8 > 0 Then {alt key}
        keys := keys+1;
      If mem[$0:$417] And 4 > 0 Then {ctrl}
        keys := keys+4;
    End
    Else
      get_mouse_status(keys, dummy, dummy);
    mousekeys := keys;
  End;                            {mousekeys}


  Procedure updatemousepos;

    { limit mouse movement and replot in new position}

  Begin                           {updatemousepos}
    If mousex > getmaxx Then
      mousex := getmaxx;
    If mousex < 0 Then
      mousex := 0;
    If mousey > getmaxy Then
      mousey := getmaxy;
    If mousey < 0 Then
      mousey := 0;
    mousearrowoff;
    mousexold := mousex;
    mouseyold := mousey;
    mousearrowon;                 {arrow on}
  End;                            {updatemousepos}


  Function trackmouse : Char;

    { plot mouse arrow until mouse key pressed, keypress interrupts}

  Var c          : Char;

  Begin                           {trackmouse}
    updatemousepos;           {incase movement since last time this was called}
    c := ' ';
    Repeat
      If keypressed Then
        c := readkey;
    Until (mousekeys = 0) Or (c = ^c); {make sure buttons released}
    While keypressed Do           {flush kbd}
      c := readkey;
    If c <> ^c Then
      While (mousekeys = 0) And (c = ' ') Do
      Begin
        If keypressed Then
        Begin
          c := readkey;
          Case c Of
            #0 : Begin
                   c := readkey;
                   Case c Of
                     #72 : Begin mousey := mousey-10; c := ' '; End;
                     #80 : Begin mousey := mousey+10; c := ' '; End;
                     #75 : Begin mousex := mousex-10; c := ' '; End;
                     #77 : Begin mousex := mousex+10; c := ' '; End;
                   End;           {case}
                 End;
            '8' : Begin Dec(mousey); c := ' '; End;
            '2' : Begin Inc(mousey); c := ' '; End;
            '4' : Begin Dec(mousex); c := ' '; End;
            '6' : Begin Inc(mousex); c := ' '; End;
          End;                    {case}
          updatemousepos;
        End;
        If mousemoved Then
          updatemousepos;
      End;
    If c <> ' ' Then
      trackmouse := c
    Else
      trackmouse := #0;
  End;                            {trackmouse}


Begin
  mouseexists := False;
End.