Intuition.SetWindowPointerA()

Unfortunately no real explanation(s) yet, just some piece of code i wanted to 'rescue' out of the aros-exec.org 'haystack'.

The code is quite self-explanatory though.

The code was originally presented in this thread, this post to be exact (2-3-2013).

Another interesting (related) thread is this one, in which i stumbled upon some WritePixelArray() (/Alpha) curiosity (5-3-2013).

But the 'mother' of all threads is this one (21-1-2010)), in which the author of the new mouse pointer implementation explains how things are suppose to work in practice (don't worry, all the important information is already supplied in the comments of the presented source-code).

Unfortunately code is also still in my old stubborn 'use my unts and types'-format, so it won't compile out of the box (hence this example is not situated on the main page from ALB).

First a little picture of a slight variation on the presented code (using 64x64 pointer instead of 32x32)

And the code that made it happen:

program SinglePointerV2b; 

{$MODE OBJFPC}{$H+} 

uses 
  aros_types, 
  aros_exec, 
  aros_dos, 
  aros_graphics, 
  aros_intuition, 
  aros_cybergraphics, 
  mytagsarray; 


(* 
  author    : MaGoRiuM 
  date      : 03-march-2013 
  Name      : singlepointer revision V2b 
  Topic     : A quick'n'dirty mousepointer changing test 
  Target    : AROS 
  Usage     : Start from shell. No other windows must be open 
              to ensure the shell-window is the first window 
              on the screen. If not then the windows that has its 
              cursor changed needs to be activated before the changes 
              to the mousepointer are visible. 
              The name of the window for which the mousepointer 
              is changed is written in the shell along with  
              other debug information. 
              Tested in vesa mode only. Max dimensions tested 
              64*64*32 (w*h*d) 
  Disclaimer: Use and abuse at your own risk. 
              This file is not meant for distribution. Its 
              purpose is being an example. Bad coding style(tm) 
              applies. 
*) 


(* 
  Important notes: 
   
  From Sonic in "New Mouse Pointer" thread on aros-exec.org 

  FWIW Sonic is the AROS system developer that implemented the  
  mousepointerclass. 
   
  - The pointerclass attributes are not settable. You can pass them only  
    during object creation. 
  - If you want several different pointers then create several different  
    objects. Then just switch between them using SetWindowPointer(). 
  - Dont recreate the bitmap each time. After creating a pointerclass  
    object you may re-use it. The bitmap is NOT attached to the created  
    object in any way, data are copied and stored internally. 
    See rom/intuition/pointerclass.c for more details. 
  - Pixelformat specifies the order of bytes in RAM, not in a longword. So  
    they are endianess-dependant. Take this into account if you use longword  
    to specify your pointer image. 
*) 


(***************************************************************************) 
(**                                                                       **) 
(**       Routines that are missing from default units                    **) 
(**                                                                       **) 
(***************************************************************************) 

Const 
  BMF_SPECIALFMT = 1 shl 7;   // Missing tag in agraphics unit. 


function  NewObject(classPtr : pIClass; const classID: pChar; const tags : array of const) : Pointer; 
begin 
  // Cast to pointer to avois clas between aros_utility and utility unit. 
  NewObject := NewObjectA(classPtr, ClassID, Pointer(readinTags(tags))); 
end; 

procedure SetWindowPointer(win : pWindow; const tags : array of const); 
begin 
  // Cast to pointer to avoid clash between aros_utility and utility unit. 
  SetWindowPointerA(win, pointer(readintags(tags))); 
end; 



(***************************************************************************) 
(**                                                                       **) 
(**       Actual implementation                                           **) 
(**                                                                       **) 
(***************************************************************************) 

Const 
  TAG_DONE          =  0;   // for convenience, no need for utility unit. 

  RawDataWidth      = 16;  // The width in pixels of our rawdata 
  RawDataHeight     = 16;  // The height in pixels of our rawdata 


Var 
  RawData_16x16     : packed array[0..(RawDataWidth*RawDataHeight)-1] of longword = 
  ( 
    // format AABBGGRR; 
    $00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FF0000, 
    $00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FFFFFF,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00FF0000,$00FF0000, 
    $000000FF,$000000FF,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00, 
    $000000FF,$000000FF,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00,$0000FF00 
  ); 



(* 
          Routine that creates an actual AROS cursor from the raw cursor data. 
          Width, Height and Depth describes the raw data. 
*) 
Function AllocAROSPointer(Width, Height, Depth: Integer; RawData: pLongWord): pObject_; 
var 
  px, py, r     : Integer; 
  CursorBM      : pBitmap; 
  CursorRP      : pRastPort; 
  cc            : LongWord; 
  aa,rr,gg,bb   : Byte; 
  AROSCursor    : pObject_; 
  WordWidth     : LongInt; 
  //RawDataAccess : pRawCursorData; 
     
begin 
  AROSCursor := nil; 
  { 
    Now we need to actually make real AROS cursor 
    out of the raw data that is given. 
     
    It is a slow process but luckiliy this could     
    be execute tbefore a program actually runs so  
    that it will not take away runtime performance. 
  } 

  {  
    Step 1:  
    allocate an offscreen bitmap to copy the rgb32 pixeldata  
    into. This creates a bitmap, that is unfortunately needed 
    by AROS to create a new pointer. 
  }  
  CursorBM := AllocBitMap( 
    Width,          // sizeX, pixelwidth desired for bitmapdata 
    Height,         // sizey, pixelheight desired for bitmapdata 
    Depth,          // depth, number of bitplanes tha are at least allocated (32 bit for RGBA32) 
    BMF_MINPLANES or BMF_SPECIALFMT or (PIXFMT_RGBA32 shl 24), // flags, see documentation 
    nil // pRastPort(window^.RPort)^.BitMap 
  ); 

  if (CursorBM <> nil)  
  then writeln('allocated bitmap')  
  else writeln('ERROR: allocating bitmap failed'); 

  {  
    Step 2: 
    A rastport to the offscreen-bitmap is needed in order to be able to 
    actually write anything into the bitmap. 
    On classic we would use initrastport, but AROS specifically tells use to  
    use CreateRastPort(). Using inintrastport in this situation will freeze 
    AROS-OS. 
    NOTE: the rastport needs to be freed as well. 
  }  

  CursorRP := CreateRastPort; 
  if (CursorRP <> nil)  
  then writeln('created rastport for cursor')  
  else writeln('ERROR: creating rastport for cursor failed'); 

  {  
    Step 3: 
    Attach bitmap to rastport to make connection. 
  } 
  CursorRP^.Bitmap := CursorBM; 


  {  
    Step 4: 
    The RAW defined pixeldata needs to be: 
    - copied into the bitmap 
    - an cursor object needs to be created from this bitmap 
  } 

  begin 
    { 
      Step 4a: 
      Copy data into the bitmap       
    } 
    // initialize the counter used to count the nr of pixels that are 
    // drawn into the bitmap without any error. 
    r := 0;     
     
    for py := 0 to Height-1 do 
    begin 
      for px := 0 to Width-1 do 
      begin 
        // get color asociated with the current pixel 
        cc := rawdata[py*width+px]; 
        // break color component of pixel into seperate ARGB colorvalues 
        rr := cc shr  0 and $FF; 
        gg := cc shr  8 and $FF; 
        bb := cc shr 16 and $FF; 
        aa := cc shr 24 and $FF; 

        { 
        // Check if the pixel is transparant (RGB=000) 
        // If pixel is transparent we override alpha channel 
        // if pixel has alphavalue we need to fill in alphavalue 
        // for testing purpose only we fill in $FF which mean full color, no alpha 
        } 
        if (rr+gg+bb = 0) then aa := $00 else aa := $FF; 
        // Put back the colors + corrected alpha value into the correct format in order to be able to write a pixel 
        cc := (aa shl 24) + (rr shl 16) + (gg shl 8) + (bb); 
        // write the pixel into the bitmap 
        // cast to pointer because of type conflict between aros_graphics and agraphics unit. 
        If WriteRGBPixel(Pointer(CursorRp), px, py, cc) = 0 then 
        begin 
          // if the pixel is written ok, increase counter so pixelwritecount can be checked 
          inc(r); 
        end; 
      end; // for pixel-coordinates x 
    end; // for pixel-coordinates y 

    // write out the number of pixels that were written into the bitmap 
    // if it doesn't match px*py then an error occured. 
    writeln('wrote ', r, ' pixels into bitmap'); 


    { 
      Step 4b: 
      Now that the bitmap is setup correctly we attempt to create a cursor from it.         
    } 
    WordWidth := (Width + 15) shr 4; 

     
    AROSCursor := NewObject(nil,'pointerclass',  
    [ 
      POINTERA_BitMap    , CursorBM, 
      POINTERA_WordWidth , WordWidth,    // width of cursor in words. 
      //POINTERA_XResolution, POINTERXRESN_DEFAULT, 
      //POINTERA_YResolution, POINTERYRESN_DEFAULT, 
      POINTERA_XResolution, POINTERXRESN_SCREENRES, 
      POINTERA_YResolution, POINTERYRESN_SCREENRESASPECT, 
      //POINTERA_XOffset   , 0,    // Hotspot x 
      //POINTERA_YOffset   , 0,    // hotspot y         
      TAG_DONE 
    ]); 

    If (AROSCursor <> nil) 
    then writeln('allocated new pointer object') 
    else writeln ('ERROR: could not create new pointer object'); 
       
    // assume object is created 
    Result := AROSCursor; 
  end;  // done creating mousepointer object 
   
  { Step 5: 
    Give back the rastport 
  } 
  FreeRastPort(CursorRP); 

  { Step 6: 
    Give back the bitmap 
  } 
  FreeBitMap(CursorBM); 

  { 
  !!!!! DONE !!!!! 
  }        
   
end; 


(* 
          Routine that free the AROS cursor and so give back the created object 
*) 
Procedure FreeAROSPointer(Var AROSCursor: PObject_); 
begin 
  if AROSCursor <> nil then 
  begin 
    // we are done with our pointer so we can free the pointerclass 
    // Actually it is undetermined what happens if a cursor is 
    // still in use by the AROS system. 
    DisPoseObject(AROSCursor); 
    AROSCursor := nil; 
    writeln('Disposed AROS object'); 
  end 
  else writeln('ERROR: AROS pointerObject was not allocated and could therefore not be destroyed'); 
end; 


(* 
          Routine to test the mousepointer 
          Delaycount   = the nr of milliseconds to change the pointer 
          AROSPointer  = the feshly created mousepointer class that 
                         needs is being shown. 
*) 
Procedure TestPointer(delaycount: Integer; AROSPointer: pObject_); 
var 
  screen    : pScreen; 
  Window    : pWindow; 
begin 
  // A window is needed, so start-out with a screen. 
  Screen := LockPubScreen(nil); 
  if (screen <> nil) then 
  begin 
    writeln('found screen ', screen^.Title); 
     
    // get the window that is desperately needed 
    window := Screen^.firstwindow; 
    if (window <> nil) then 
    begin 
      writeln('found window ',window^.title); 

      writeln('Starting cursor demo'); 
      begin 
        writeln('Attempting to display cursor'); 
         
        // if the given pointer is valid then continue 
        If AROSPointer <> nil then 
        begin 
          // actually link the mousepointer to the window 
          // so that it becomes visible when the window is 
          // activated. 
          SetWindowPointer(Window, [WA_Pointer, AROSPointer, TAG_DONE]); 
                 
          writeln('Current cursor is being displayed'); 
          // Wait some time before returning back. 
          DOSDelay(DelayCount); 
        end  
        else writeln('ERROR: Cursor did not had a valid object'); 
       
      end; 
      writeln('ending cursor demo'); 

      // after fiddling and changing the cursor, the window 
      // needs back its original cursor. 
      // Unfortunatly there is no way of knowing if giving 
      // back the default cursor succeeded or not. 
      SetWindowPointer(Window, [WA_Pointer, 0, TAG_DONE]);       

    end else writeln('CERROR: ould not locate a window'); 

    // Albeit a bit late, the locked screen must really be unlocked. 
    unlockpubscreen(nil, screen); 
     
  end else WriteLn('ERROR: could not locate a screen'); 
end; 



(* 
       MAIN 
*) 
Var 
  AROSMousePointer : pObject_; 
   
begin 
  writeln('enter'); 

  // create real AROS mousepointer class from raw data 
  AROSMousePointer := AllocAROSPointer(16,16,32, @RawData_16x16[0] ); 
  //AROSMousePointer := AllocAROSPointer(32,32,32, @RawData_32x32[0] ); 
  //AROSMousePointer := AllocAROSPointer(64,64,32, @RawData_64x64[0] ); 
  If AROSMousePointer <> nil then 
  begin 
    writeln; 
    // Do some visual mousepointer changing 
    TestPointer(1000, AROSMousePointer); 
    writeln; 
    // Free the AROS mousepointer object. 
    FreeAROSPointer(AROSMousePointer);        
  end; 
  writeln('leave'); 
end.