Delphi - spacemouse code

This unit implements the lower level of the device. 
The communication requires an external package.

###################################################################
{ TSMouse - interfaces to the LOGICAD 3D Magellan/ Space mouse

  based on the manual V2.1 dated 1/99

  currently uses the Asynch Pro for the serial communication
   with the mouse : TAPdComPort component with its
   .putstring(..) method and .ComTriggerAvail(..) event
   they can easily be replaced.

   ** work in progress ** dated 6.nov.99 **

}
unit SMouse;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  AdPort;


type
  TMKeyEvent=procedure(Sender:TComponent;key:word) of object;
  TMMoveEvent=procedure(Sender:TComponent;dx,dy,dz,da,db,dc:smallint) of object;
  TMModeEvent=procedure(Sender:TComponent;mode:word) of object;

  {
   understanding of this component requires the mentioned manual as several parameters
   have a restricted range. There is no 3D yet, the returned values will have to be integrated
   to be useful.
  }
  TSMouse = class(TComponent)
  private
    { Private declarations }
   fversion:shortstring;
   fdx,fdy,fdz:smallint;
   fda,fdb,fdc:smallint;
   fcompress:integer;
   fmode:word;
   fbeep,fmindata,fmaxdata,fsenserot,fsensetrans:byte;
   fkey,flastkey:word;
   fradius:byte;
  protected
    { Protected declarations }
   com:TAPdComPort;
   rxbuffer,txbuffer:shortstring;
   received:boolean;
   fkeyup:TMKeyEvent;
   fkeydown:TMKeyEvent;
   fmousemove:TMMoveEvent;
   fmodechange:TMModeEvent;
   function getversion:shortstring;
   function decodenibble(u:char;var b:byte):boolean; // true=ok
   function codenibble(n:byte):char;
   procedure ComTriggerAvail(CP: TObject; Count: Word);
   procedure setmode(m:word);
   procedure setradius(r:byte);
   procedure settrans(t:boolean);
   procedure setrot(t:boolean);
   procedure setdom(t:boolean);
   procedure setbeep(t:boolean);
   procedure setbeeplen(b:byte);
   procedure setmindata(b:byte);
   procedure setmaxdata(b:byte);
   procedure setSenserot(b:byte);
   procedure setSensetrans(b:byte);
   function gettrans:boolean;
   function getrot:boolean;
   function getdom:boolean;
   function getbeep:boolean;
   function getbeeplen:byte;
  public
    { Public declarations }
    constructor create(AOwner:TComponent); override;
    destructor destroy; override;
    procedure init;
    procedure zero;  virtual;
  published
    { Published declarations }
   property OnKeyUp:TMKeyEvent read fkeyup write fkeyup;
   property OnKeyDown:TMKeyEvent read fKeyDown write fKeyDown;
   property OnMouseMove:TMMoveEvent read fmousemove write fmousemove;
   property OnModeChange:TMModeEvent read fmodechange write fmodechange;
   property version:shortstring read getversion;
   property mode:word read fmode write setmode;
   property radius:byte read fradius write setradius;
   property translations:boolean read gettrans write settrans;
   property rotations:boolean read getrot write setrot;
   property dominantmode:boolean read getdom write setdom;
   property beep:boolean read getbeep write setbeep;
   property beeplen:byte read getbeeplen write setbeeplen;
   property mindataperiod:byte read fmindata write setmindata;
   property maxdataperiod:byte read fmaxdata write setmaxdata;
   property sensitivityRot:byte read fsenserot write setSenserot;
   property sensitivityTrans:byte read fsensetrans write setSensetrans;
  end;


procedure Register;

implementation

function TSMouse.getversion:shortstring;
begin
 if fversion='' then begin
   txbuffer:='vQ'+chr(13);
   com.putstring(txbuffer);
   received:=false;
   sleep(100);
   if received then result:=fversion;
  end
 else result:=fversion;
end;


function TSMouse.decodenibble(u:char;var b:byte):boolean; // true=ok
begin
 case u of
  '0' :begin b:=0; result:=true; end;
  '3' :begin b:=3; result:=true; end;
  '5' :begin b:=5; result:=true; end;
  '6' :begin b:=6; result:=true; end;
  '9' :begin b:=9; result:=true; end;
  ':' :begin b:=10; result:=true; end;
  '<' :begin b:=12; result:=true; end;
  '?' :begin b:=15; result:=true; end;
  'A' :begin b:=1; result:=true; end;
  'B' :begin b:=2; result:=true; end;
  'D' :begin b:=4; result:=true; end;
  'G' :begin b:=7; result:=true; end;
  'H' :begin b:=8; result:=true; end;
  'K' :begin b:=11; result:=true; end;
  'M' :begin b:=13; result:=true; end;
  'N' :begin b:=14; result:=true; end;
  else result:=false;
 end;
end;

var code:array[0..15]of char
    =('0','A','B','3','D','5','6','G','H','9',':','K','<','M','N','?');

function TSMouse.codenibble(n:byte):char;
begin
 result:= code[(n and $0F)];
end;

// this event is provided by the Asynch Pro Comport component and 
// comes for every (or multiple) byte received.
procedure TSMouse.ComTriggerAvail(CP: TObject; Count: Word);
var i:integer;
    ch:char;
    u,v:byte;
    ok:boolean;
    tw:word;
begin
 for i:=1 to count do begin
   ch:=com.getchar;
   rxbuffer:=rxbuffer+ch;
   if ch=chr(13) then begin
     case rxbuffer[1] of
      'b':begin
           ok:=decodenibble(rxbuffer[2],u);
           if ok then fbeep:=u;
          end;
      'c':begin
           ok:=decodenibble(rxbuffer[2],u); tw:=u;
           ok:=ok and decodenibble(rxbuffer[3],u);tw:=tw or (u shl 4);
           if ok then fcompress:=tw;
          end; //c
      'd':begin
           ok:=decodenibble(rxbuffer[2],u);
           fdx:= u shl 12;
           ok:=ok and decodenibble(rxbuffer[3],u); fdx:=fdx or (u shl 8);
           ok:=ok and decodenibble(rxbuffer[4],u); fdx:=fdx or (u shl 4);
           ok:=ok and decodenibble(rxbuffer[5],u); fdx:=fdx or u;
           fdx:=fdx-32768;
           ok:=ok and decodenibble(rxbuffer[6],u); fdy:= u shl 12;
           ok:=ok and decodenibble(rxbuffer[7],u); fdy:=fdy or (u shl 8);
           ok:=ok and decodenibble(rxbuffer[8],u); fdy:=fdy or (u shl 4);
           ok:=ok and decodenibble(rxbuffer[9],u); fdy:=fdy or u;
           fdy:=fdy-32768;
           ok:=ok and decodenibble(rxbuffer[10],u); fdz:= u shl 12;
           ok:=ok and decodenibble(rxbuffer[11],u); fdz:=fdz or (u shl 8);
           ok:=ok and decodenibble(rxbuffer[12],u); fdz:=fdz or (u shl 4);
           ok:=ok and decodenibble(rxbuffer[13],u); fdz:=fdz or u;
           fdz:=fdz-32768;
           ok:=ok and decodenibble(rxbuffer[14],u); fda:= u shl 12;
           ok:=ok and decodenibble(rxbuffer[15],u); fda:=fda or (u shl 8);
           ok:=ok and decodenibble(rxbuffer[16],u); fda:=fda or (u shl 4);
           ok:=ok and decodenibble(rxbuffer[17],u); fda:=fda or u;
           fda:=fda-32768;
           ok:=ok and decodenibble(rxbuffer[18],u); fdb:= u shl 12;
           ok:=ok and decodenibble(rxbuffer[19],u); fdb:=fdb or (u shl 8);
           ok:=ok and decodenibble(rxbuffer[20],u); fdb:=fdb or (u shl 4);
           ok:=ok and decodenibble(rxbuffer[21],u); fdb:=fdb or u;
           fdb:=fdb-32768;
           ok:=ok and decodenibble(rxbuffer[22],u); fdc:= u shl 12;
           ok:=ok and decodenibble(rxbuffer[23],u); fdc:=fdc or (u shl 8);
           ok:=ok and decodenibble(rxbuffer[24],u); fdc:=fdc or (u shl 4);
           ok:=ok and decodenibble(rxbuffer[25],u); fdc:=fdc or u;
           fdc:=fdc-32768;
           if assigned(OnMouseMove) then OnMouseMove(self,fdx,fdy,fdz,fda,fdb,fdc);
          end; //d
      'e':begin
           // a coomunication error occured
           // do nothing now....
          end; //e
      'k':begin
           ok:=decodenibble(rxbuffer[2],u);        tw:=u;
           ok:=ok and decodenibble(rxbuffer[3],u); tw:=tw or (u shl 4);
           ok:=ok and decodenibble(rxbuffer[4],u); tw:=tw or (u shl 8);
           if ok then begin
             fkey:=tw;
             tw:=fkey xor flastkey;
             if (fkey=0) and assigned(OnKeyUp) then OnKeyUp(self,tw);
             if (flastkey=0) and assigned(OnKeyDown) then OnKeyDown(self,tw);
             flastkey:=fkey;
            end;
          end; //k
      'm':begin
           if decodenibble(rxbuffer[2],u) then begin
             fmode:=u;
             if assigned(fmodechange) then OnModeChange(self,fmode);
            end;
          end; //m
      'n':begin
           if decodenibble(rxbuffer[2],u) then begin
             fradius:=u;
            end;
          end;
      'p':begin
           ok:=decodenibble(rxbuffer[2],u);
           ok:=ok and decodenibble(rxbuffer[3],v);
           if ok then begin
            fmaxdata:=u;
            fmindata:=v;
            end;
          end;
      'q':begin
           ok:=decodenibble(rxbuffer[2],u);
           ok:=ok and decodenibble(rxbuffer[3],v);
           if ok then begin
            fsensetrans:=u;
            fsenserot:=v;
            end;
          end;
      'v':begin
           fversion:=rxbuffer;
           received:=true;
          end;
      'z':begin
           // zeroed .. do nothing now
          end;
     end; //case
     rxbuffer:='';
   end;
 end;
end;

constructor TSMouse.create(AOwner:TComponent);
begin
 inherited create(AOwner);
 Com:=TApdComPort.Create(self);
 Com.ComNumber:=1;                // preset to COM1 !!
 Com.Baud:=9600;
 Com.Stopbits:=2;
 Com.Open:=True;
 Com.OnTriggerAvail:=ComTriggerAvail;
 fversion:=''; received:=false;
 OnKeyUp:=nil;
 OnKeyDown:=nil;
 OnMouseMove:=nil;
 OnModeChange:=nil;
 //getversion;
 fmode:=0;
 fbeep:=$09;
 fmindata:=15;
 fmaxdata:=15;
 fsenserot:=0;
 fsensetrans:=0;
end;

destructor TSMouse.destroy;
begin
 If Com.open then Com.open:=false;
 Com.free;
 inherited destroy;
end;

procedure TSMouse.init;
begin
  txbuffer:='kQ'+chr(13);
 com.putstring(txbuffer);
end;

procedure TSMouse.setmode(m:word);
begin
 txbuffer:='m'+codenibble(lo(m) and $0F)+chr(13);
 com.putstring(txbuffer);
end;

procedure TSMouse.setradius(r:byte);
begin
 txbuffer:='n'+codenibble(r and $0F)+chr(13);
 com.putstring(txbuffer);
end;

procedure TSMouse.zero;
begin
 txbuffer:='z'+chr(13);
 com.putstring(txbuffer);
end;

procedure TSMouse.settrans(t:boolean);
begin
 if t then fmode:=fmode or $02 else fmode:=fmode and $FD;
 txbuffer:='m'+codenibble(fmode)+chr(13);
 com.putstring(txbuffer);
end;

procedure TSMouse.setrot(t:boolean);
begin
 if t then fmode:=fmode or $01 else fmode:=fmode and $FE;
 txbuffer:='m'+codenibble(fmode)+chr(13);
 com.putstring(txbuffer);
end;

procedure TSMouse.setdom(t:boolean);
begin
 if t then fmode:=fmode or $04 else fmode:=fmode and $FB;
 txbuffer:='m'+codenibble(fmode)+chr(13);
 com.putstring(txbuffer);
end;

function TSMouse.gettrans:boolean;
begin
 result:=(fmode and $02)<>0;
end;

function TSMouse.getrot:boolean;
begin
 result:=(fmode and $01)<>0;
end;

function TSMouse.getdom:boolean;
begin
 result:=(fmode and $04)<>0;
end;
procedure TSMouse.setbeep(t:boolean);
begin
 if t then fbeep:=fbeep or $08 else fbeep:=fbeep and $F7;
 txbuffer:='b'+codenibble(fbeep)+chr(13);
 com.putstring(txbuffer);
end;
procedure TSMouse.setbeeplen(b:byte);
begin
 fbeep:=fbeep or (b and $07);
 txbuffer:='b'+codenibble(fbeep)+chr(13);
 com.putstring(txbuffer);
end;

function TSMouse.getbeep:boolean;
begin
 result:=((fbeep and $08)<>0);
end;
function TSMouse.getbeeplen:byte;
begin
 result:=(fbeep and $07);
end;
procedure TSMouse.setmindata(b:byte);
begin
 //fmindata:=b;
 txbuffer:='p'+codenibble(fmaxdata)+codenibble(b)+chr(13);
 com.putstring(txbuffer);
end;
procedure TSMouse.setmaxdata(b:byte);
begin
 //fmaxdata:=b;
 txbuffer:='p'+codenibble(b)+codenibble(fmindata)+chr(13);
 com.putstring(txbuffer);
end;
procedure TSMouse.setSenserot(b:byte);
begin
 //fsenserot:=b;
 txbuffer:='q'+codenibble(fsensetrans)+codenibble(b)+chr(13);
 com.putstring(txbuffer);
end;
procedure TSMouse.setSensetrans(b:byte);
begin
 //fsensetrans:=b;
 txbuffer:='q'+codenibble(b)+codenibble(fsenserot)+chr(13);
 com.putstring(txbuffer);
end;

procedure Register;
begin
  RegisterComponents('Samples', [TSMouse]);
end;

end.
#######################################################################################