home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / Pascal / Snippets / KbdLts 1.0 / KbdLts.p < prev    next >
Encoding:
Text File  |  1995-10-11  |  5.5 KB  |  185 lines  |  [TEXT/PJMM]
  1. {KbdLts}
  2. {A Keyboard light manipulating demo that WORKS - which Apple's demo dos NOT!}
  3. {This demo is directly based on Apple's demo (from Inside Mac), but corrected to}
  4. {work on non-US keyboards. Apple's code only checked for the US keyboard layout,}
  5. {and did nothing on international keyboards no matter whether they had lights or not.}
  6. {}
  7. {I don't claim that this is the optimal way to solve the problem, but I do claim that}
  8. {it works better than what we had before.}
  9. {}
  10. {By Ingemar Ragnemalm 1995. Think Pascal source-code.}
  11.  
  12. program KbdLts;
  13.     uses
  14.         DeskBus;
  15.  
  16.     function IsExtendedKeyboard (myAddress: ADBAddress): Boolean;
  17.         var
  18.             myInfo: ADBDataBlock;
  19.             myCommand: Integer;
  20.             myErr: OSErr;
  21.             response: Longint;
  22.             isExt: Boolean;
  23.         const
  24.             kExtKeyboardAddr = 2;
  25.             kExtKeyboardOrigHandlerID = 2;
  26.     begin
  27.         myErr := Gestalt('kbd ', response);
  28. {response one out of:}
  29. {4,9, 15? 16? 17? 20,21,24. PowerUser = 9 (ext ISO)}
  30.         case response of
  31.             4, 9, 15, 16, 17, 20, 21, 24: 
  32.                 isExt := true;
  33.             otherwise
  34.                 isExt := false;
  35.         end;
  36.  
  37.         myErr := GetADBInfo(myInfo, myAddress);
  38.         IsExtendedKeyboard := (myInfo.origADBAddr = kExtKeyboardAddr) and isExt;
  39.     end; {IsExtendedKeyboard}
  40.  
  41.  
  42.     procedure MySetFlag;
  43. {move a nonzero value into the word pointed to by register A2}
  44.     inline
  45.         $34BC, $FFFF;                                    {MOVE.W #$FFFF, (A2)}
  46.  
  47.     procedure MyCompletionRoutine;
  48.     begin
  49.         MySetFlag;                                {set a flag to indicate done}
  50.     end;
  51.  
  52.     function MySendADBCommand (myBufferPtr: Ptr; myCommand: Integer): OSErr;
  53. {send a command to an ADB device synchronously}
  54.         var
  55.             myDone: Integer;                {completion flag}
  56.             myErr: OSErr;
  57.     begin
  58.         myDone := 0;
  59.         myErr := ADBOp(@myDone, @MyCompletionRoutine, myBufferPtr, myCommand);
  60.         if myErr = noErr then
  61.             repeat
  62.             until myDone <> 0
  63.         else
  64.             ; {ADB buffer overflowed -- retry command here}
  65.         MySendADBCommand := myErr;
  66.     end;
  67.  
  68.     var
  69.         gRegisterData: packed array[0..8] of Byte;                                        {buffer for register data}
  70.     const
  71.         kListenMask = 8;            {masks for ADB commands}
  72.         kTalkMask = 12;
  73.         kLEDRegister = 2;            {register containing LED settings}
  74.         kLEDValueMask = 7;            {mask for bits containing current LED setting}
  75.  
  76.     function MyGetLEDValue (myAddress: ADBAddress; var myLEDValue: Integer): OSErr;
  77.         var
  78.             myCommand: Integer;
  79.             myErr: OSErr;
  80.     begin
  81.     {initialize length of buffer; on return, the ADB device sets }
  82.         gRegisterData[0] := Byte(0);                                        { this byte to the number of bytes returned}
  83.     {get existing register contents with a Talk command}
  84.         myCommand := (myAddress * 16) + kTalkMask + kLEDRegister;
  85.         myErr := MySendADBCommand(@gRegisterData, myCommand);
  86.         if myErr = noErr then                                            {make sure completed successfuly}
  87.         {gRegisterData now contains the existing data in device register 2; }
  88.         { the lower 3 bits of byte 2 contain the LED value}
  89.             myLEDValue := Integer(BAND(gRegisterData[2], kLEDValueMask))
  90.         else
  91.             myLEDValue := 0;
  92.         MyGetLEDValue := myErr;
  93.     end;
  94.  
  95. {Listing 5-4    Setting the current state of the LED lights}
  96.  
  97.     function MySetLEDValue (myAddress: ADBAddress; myValue: Integer): OSErr;
  98.         var
  99.             myCommand: Integer;
  100.             myByte: Byte;                            {existing byte 2 of device register 2}
  101.             myErr: OSErr;
  102.     begin
  103.         gRegisterData[0] := Byte(2);                                            {set length of buffer}
  104.     {get existing register contents with a Talk command}
  105.         myCommand := (myAddress * 16) + kTalkMask + kLEDRegister;
  106.         myErr := MySendADBCommand(@gRegisterData, myCommand);
  107.         MySetLEDValue := myErr;
  108.         if myErr <> noErr then                                            {make sure completed successfuly}
  109.             EXIT(MySetLEDValue);
  110.     {gRegisterData now contains the existing data in device register 2; }
  111.     { reset the lower 3 bits of byte 2 to the desired value}
  112.         myByte := gRegisterData[2];
  113.         myByte := BAND(myByte, 255 - 7);                                                        {mask off lower three bits}
  114.         myByte := BOR(myByte, Byte(myValue));                                                        {install desired value}
  115.         gRegisterData[2] := myByte;
  116.         myCommand := (myAddress * 16) + kListenMask + kLEDRegister;
  117.         MySetLEDValue := MySendADBCommand(@gRegisterData, myCommand);
  118.     end;
  119.  
  120. {Listing 5-5    Counting in binary using a keyboard’s LED lights}
  121.  
  122.     procedure MyCountWithLEDs;
  123.         var
  124.             myValue: Integer;
  125.             myIndex: Integer;
  126.             myAddress: ADBAddress;
  127.             myOrigLED: Integer;
  128.             myInfo: ADBDataBlock;                            {needed for GetIndADB; ignored here}
  129.             myDelay: LongInt;                            {needed for Delay; ignored here}
  130.             myErr: OSErr;
  131.     begin
  132.         for myIndex := 1 to CountADBs do
  133.             begin
  134.                 myAddress := GetIndADB(myInfo, myIndex);
  135.                 if IsExtendedKeyboard(myAddress) then
  136.                     begin
  137.             {save original state of LED lights}
  138.                         myErr := MyGetLEDValue(myAddress, myOrigLED);
  139.                         myValue := 7;                                                {turn all the lights OFF}
  140.                         while myValue >= 0 do
  141.                             begin
  142.                                 myErr := MySetLEDValue(myAddress, myValue);
  143.                                 myValue := myValue - 1;
  144.                                 Delay(30, myDelay);
  145.                             end;
  146.             {restore original state of LED lights}
  147.                         myErr := MySetLEDValue(myAddress, myOrigLED);
  148.                     end; {IF}
  149.             end; {FOR}
  150.     end;
  151.  
  152.     var
  153.         myDelay: LongInt;
  154.         myErr: OSErr;
  155.         myOrigLED: Integer;
  156.  
  157. begin
  158.  
  159.     myErr := MyGetLEDValue(2, myOrigLED);
  160.     myErr := MySetLEDValue(2, 7);
  161.     Delay(30, myDelay);
  162.     myErr := MySetLEDValue(2, 0);
  163.     Delay(30, myDelay);
  164.     myErr := MySetLEDValue(2, 7);
  165.     Delay(30, myDelay);
  166.     myErr := MySetLEDValue(2, 0);
  167.     Delay(30, myDelay);
  168.     myErr := MySetLEDValue(2, 7 - 1);
  169.     Delay(30, myDelay);
  170.     myErr := MySetLEDValue(2, 7 - 2);
  171.     Delay(30, myDelay);
  172.     myErr := MySetLEDValue(2, 7 - 4);
  173.     Delay(30, myDelay);
  174.     myErr := MySetLEDValue(2, 7 - 1);
  175.     Delay(30, myDelay);
  176.     myErr := MySetLEDValue(2, 7 - 2);
  177.     Delay(30, myDelay);
  178.     myErr := MySetLEDValue(2, 7 - 4);
  179.     Delay(30, myDelay);
  180.     myErr := MySetLEDValue(2, myOrigLED);
  181.  
  182.  
  183.     MyCountWithLEDs;
  184.  
  185. end.