Solo Programadores 22/SOLO_22.iso/packages/win32ada/data.z/wxform_util.adb

Text File | 1995-12-06 | 39.1 KB | 1,060 lines

-- $Source: /home/harp/1/proto/monoBANK/winnt/wxform_util.adb,v $
-- $Revision: 1.1 $ $Date: 95/02/09 13:24:21 $ $Author: mg $

--  package Wxform_Util body
--
--  The functions here were translated from wxform.c.  Ada procedure
--  wxform_ada does the initial window creation and the message loop.  All
--  other utility functions are defined here.
--
--  One major change from the C version is the implementation of parts of
--  doTrackObject.  This function was initially written using the standard
--  calling parameters of a callback routine that handles messages.  The
--  C version used the lParam (a LONG type) to pass addresses of different
--  data structures.  Often, the address of an item which is part of a record
--  would be passed to dotrackobject where it would then be converted back
--  to the type of the record via C typecasts.  Ada strong typing is not
--  conducive to this kind of parameter passing.  Since the data object in
--  question is global to this whole routine, its data elements will be
--  referenced directly rather than type converting and passing addresses.
--  There have been other changes which mainly have to do with parameter
--  passing between routines, otherwise the overall design has remained the
--  same.
-- ------------------------------------------------------------------


with Win32;           use Win32;
with Win32.WinDef;    use Win32.WinDef;
with Win32.WinUser; use Win32.WinUser;
with Win32.WinGdi;  use Win32.WinGdi;

with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Unchecked_Conversion;

with Text_IO;
with Interfaces.C.Strings;

with Interfaces.C;
use type Interfaces.C.INT;  -- for operations on types
use type Interfaces.C.LONG;  -- for operations on types
use type Interfaces.C.C_FLOAT;  -- for operations on types
use type Interfaces.C.UNSIGNED;  -- for operations on types
use type Interfaces.C.UNSIGNED_SHORT;  -- for operations on types


package body Wxform_Util is

  -- aliases made global

    -- aliases for case WM_PAINT
    old_pt: aliased POINT;
    ps    : aliased PAINTSTRUCT;
    pt    : aliased POINT;
    rct   : aliased RECT;

    -- aliases for case WM_PUTUPFLOATS
    pScreen : aliased POINT;
    pWorld  : aliased array (0..5) of aliased POINT;

    -- aliases for procedure CenterOrigin
    rect_rec : aliased RECT;
    old_pt2  : aliased POINT;

    -- aliases for TROB_HITTEST
    mouWorld : array (0..5) of aliased POINT;

    -- aliased for WM_LBUTTONDOWN | WM_RBUTTONDOWN
    newmouScreen : array (0..5) of aliased POINT;
    mouWorld2    : array (0..5) of aliased POINT;

    -- aliased for WM_MOUSEMOVE
    rect : aliased WinDef.RECT;

    -- aliased for procedure MouseMove
    mouWorld3 : array (0..5) of aliased POINT;
    mouDevice : aliased POINT;
    orgDevice : aliased POINT;


  package Float_Functions is new
    Ada.Numerics.Generic_Elementary_Functions (FLOAT);

  -- define dummy variables to hold results of function calls
  iResult  : Win32.INT;
  bResult  : Win32.BOOL;
  lResult  : Win32.LONG;
  uResult  : Win32.UINT;
  lrResult : Win32.LRESULT;


function CP(S : Win32.CHAR_Array) return Win32.LPCSTR is
    function UC is new Ada.Unchecked_Conversion(System.Address,Win32.LPCSTR);
begin
    return UC(S(S'First)'Address);
end CP;

function To_CA(S: String) return Win32.CHAR_Array is
begin
   return Win32.To_Win(Interfaces.C.To_C(S));
end To_CA;

function New_LPCSTR (S: String) return Win32.LPCSTR is
begin
   return CP(To_CA(S));
end New_LPCSTR;


function HWND_to_WPARAM is new Ada.Unchecked_Conversion (HWND, WPARAM);
function To_DWORD is new Ada.Unchecked_Conversion (Win32.LPARAM, Win32.DWORD);
function To_DWORD is new Ada.Unchecked_Conversion (Win32.WPARAM, Win32.DWORD);


--debug
  procedure dobox (msg : LPCSTR) is
  begin
    iResult := MessageBox(System.Null_Address, msg, New_LPCSTR("Wxform_Util"), 0);
  end dobox;
--debug, end

  -- global boolean set by case TROB_HITTEST
  In_Bounds : Boolean := False;

--  function:  MainWndProc()
--
--  input parameters:  normal window procedure parameters.
--
--  global variables:
--   hwndTransform,
--   hwndMouse - information dialog box window handles.
--   showTransform,
--   showMouse - Booleans recording the retore/minimize state of the dialogs.
--   ptoRect   - The object in the middle of the screen
--   In_Bounds - Boolean indicating whether mouse is in the bounds of the
--   track object
function MainWndProc (hwnd    : HWND;
                      message : UINT;
                      wParam  : WPARAM;
                      lParam  : LPARAM) return Win32.LRESULT is
begin
  case message is

    -- *  WM_CREATE
    -- *
    -- * create a pen for later use.
    when WM_CREATE =>
      hPenGrid := CreatePen (PS_SOLID, 1, GRIDCOLOR);


    -- *  WM_DESTROY
    -- *
    -- * Complement of WM_CREATE.  send the track object the delete messages,
    -- *  then call PostQuitMessage.
    when WM_DESTROY =>
      bResult := DeleteObject(HGDIOBJ(hPenGrid));
      doTrackObject(TROB_DELETE, hwnd, lParam);
      PostQuitMessage(0);


    -- *  WM_SIZE
    -- *
    -- * Invalidate the whole window because we reset the origin on paint
    -- *  messages according to the size.  Also, send the track object a
    -- *  message so that it will also change its HDC's viewport origin.
    -- Note: in C, one can easily pass in a null pointer to a function.  If
    -- InvalidateRect gets a null second record, then the entire client area
    -- is added to the area to be invalidated.  For the Ada implementation,
    -- try declaring a pointer to a rect, but don't initialize it.
    when WM_SIZE =>
      declare
        null_rect : ac_RECT_t;
      begin
        bResult := InvalidateRect (hwnd, null_rect, Win32.False);
        doTrackObject (TROB_CENTER, hwnd, lParam);
      end;


    -- *  WM_PAINT
    -- *
    -- * First invalidate the whole window (forces the object to be painted
    -- *  fresh, and thus it won't XOR its old self out).  Then draw the
    -- *  grid and finally draw the object.
    when WM_PAINT =>
      declare
        the_Hdc   : HDC;
        i         : Win32.INT;
        hgdi      : HGDIOBJ;
        x, y      : Win32.INT;
        null_rect : ac_RECT_t;
      begin
        bResult := InvalidateRect (hwnd, null_rect, Win32.True);

        the_hdc := BeginPaint(hwnd, ps'Access);

        CenterOrigin (hwnd, the_hdc);
        bResult := GetClientRect (hwnd, rct'Access);
        bResult := GetViewportOrgEx(the_hdc, pt'Access);
        x := Win32.INT(pt.x * (-1));
        y := Win32.INT(pt.y * (-1));
        bResult := OffsetRect(rct'Access, x, y);

        -- /* Draw vertical lines.  Draw three at the origin. */
        hgdi := SelectObject(the_hdc, HGDIOBJ(hPenGrid));
        i := 0;
        while i <= Win32.INT (rct.right) loop
          bResult := MoveToEx
                     (the_hdc, i, Win32.INT(rct.top),old_pt'access );
          bResult := LineTo (the_hdc, i, Win32.INT (rct.bottom));
          bResult := MoveToEx (the_hdc, -i,
                            Win32.INT(rct.top),old_pt'access);
          bResult := LineTo (the_hdc, -i, Win32.INT (rct.bottom));
          i := i + TICKSPACE;
        end loop;

        bResult := MoveToEx (the_hdc, -1,
                   Win32.INT (rct.top), old_pt'access);
        bResult := LineTo (the_hdc, -1, Win32.INT (rct.bottom));
        bResult := MoveToEx (the_hdc, 1, Win32.INT (rct.top),
                                    old_pt'access);
        bResult := LineTo (the_hdc, 1, Win32.INT (rct.bottom));

        -- /* Draw horizontal lines.  Draw three at the origin. */
        i := 0;
        while i <= Win32.INT (rct.bottom) loop
          bResult := MoveToEx (the_hdc, Win32.INT (rct.left),
                                      i, old_pt'access);
          bResult := LineTo (the_hdc, Win32.INT (rct.right), i);
          bResult := MoveToEx (the_hdc, Win32.INT (rct.left),
                                      -i, old_pt'access);
          bResult := LineTo (the_hdc, Win32.INT (rct.right), -i);
          i := i + TICKSPACE;
        end loop;
        bResult := MoveToEx (the_hdc, Win32.INT (rct.left),
                                    -1, old_pt'access);
        bResult := LineTo (the_hdc, Win32.INT (rct.right), -1);
        bResult := MoveToEx (the_hdc, Win32.INT (rct.left),
                                    1, old_pt'access);
        bResult := LineTo (the_hdc, Win32.INT (rct.right), 1);

        doTrackObject(TROB_PAINT, hwnd, lParam);

        bResult := EndPaint (hwnd, ps'Access);

      end;


    -- *  WM_LBUTTONDOWN & WM_RBUTTONDOWN
    -- * On button down messages, hittest on the track object, and if
    -- * In_Bounds is True, then send these messages to the track object.
    when WM_RBUTTONDOWN | WM_LBUTTONDOWN =>
      In_Bounds := False;  -- preset to Win32.False
      doTrackObject (TROB_HITTEST, hwnd, lParam);
      if In_Bounds then
        doTrackObject (message, hwnd, lParam);
      end if;


    -- *  WM_LBUTTONUP & WM_RBUTTONDOWN & MW_MOUSEMOVE
    -- *  If the track object is in a "tracking mode" then send it
    -- *  these messages.
    -- *  If the transform dialog is not minimized, fill it with numbers.
    -- *  If the mouse dialog is not minimized, fill it with numbers.
    when WM_RBUTTONUP | WM_LBUTTONUP | WM_MOUSEMOVE =>
      if ptoRect.Mode /= TMNONE then
        doTrackObject(message, hwnd, lParam);
        if showTransform = Win32.True then
          lrResult := SendMessage (hwndTransform, WM_PUTUPFLOATS, 0, 0);
          -- Note, the C version follows.  I have opted not to use lParam
          -- of SendMessage to pass the information; it will be used
          -- directly in the dialog box procedure that handles this message.
          -- This avoids having to convert an address of a record to a long
          -- integer and then back to the record when it is handled by the
          -- callback routine.
          -- SendMessage (hwndTransform, WM_PUTUPFLOATS, 0,
          --              (LONG) &ptoRect->xfmChange);
        end if;
      end if;
      if showMouse = Win32.True then
        lrResult := SendMessage
                     (hwndMouse, WM_PUTUPFLOATS,
                      HWND_to_WPARAM(hwnd), lParam);
      end if;

    when others =>
      return DefWindowProc (hwnd, message, wParam, lParam);

  end case;
  return DefWindowProc(hwnd, message, wParam, lParam);

end MainWndProc;


-- *  function:  TransformDlgProc()
-- *
-- *  input parameters:  normal window procedure parameters.
-- *
-- *  global variables:
-- *   showTransform  - Win32.True if window is restored, Win32.False if minimized.
-- *       maintain the value in this routine for other windows' use.
-- *   ptoRect - the track object.
-- *   showMouse, hwndMain.
-- *
-- *  nonstandard messages:
-- *   WM_PUTUPFLOATS - fill the entry fields with the contents of an XFORM.
function TransformDlgProc(hwnd    : Windef.HWND;
                          message : Win32.UINT;
                          wParam  : WPARAM;
                          lParam  : LPARAM) return BOOL is

  zero_str: constant Win32.CHAR_Array := To_CA("0");
  one_str:  constant Win32.CHAR_Array := To_CA("1");

  Package Win32_Flt_IO is new Text_IO.Float_IO(Win32.Float);
  use Win32_Flt_IO;

begin
  case message is

    -- *  WM_INITDIALOG
    -- *
    -- * Fill the entry fields with sensible original values.
    when WM_INITDIALOG =>
      bResult := SetDlgItemText(hwnd, IDD_13, CP(zero_str));
      bResult := SetDlgItemText(hwnd, IDD_23, CP(zero_str));
      bResult := SetDlgItemText(hwnd, IDD_33, CP(one_str));
      return Win32.True;


    -- *  WM_PUTUPFLOATS
    -- *
    -- *  lParam - pointer to an XFORM structure (for the C version!).
    -- *   for the Ada implementation, read these values from the track object.
    -- *  fill the entry fields with the XFORM values.
    when WM_PUTUPFLOATS =>
    declare
      float_val : Win32.FLOAT;
      float_str : String(1..10);
    begin
      float_val := ptoRect.xfmChange.eM11;
      Put(float_str, float_val, Aft=>2);
      bResult := SetDlgItemText(hwnd, IDD_EM11, New_LPCSTR(float_str));
      float_val := ptoRect.xfmChange.eM12;
      Put(float_str, float_val, Aft=>2);
      bResult := SetDlgItemText(hwnd, IDD_EM12, New_LPCSTR(float_str));
      float_val := ptoRect.xfmChange.eDx;
      Put(float_str, float_val, Aft=>2);
      bResult := SetDlgItemText(hwnd, IDD_EDX, New_LPCSTR(float_str));

      float_val := ptoRect.xfmChange.eM21;
      Put(float_str, float_val, Aft=>2);
      bResult := SetDlgItemText(hwnd, IDD_EM21, New_LPCSTR(float_str));
      float_val := ptoRect.xfmChange.eM22;
      Put(float_str, float_val, Aft=>2);
      bResult := SetDlgItemText(hwnd, IDD_EM22, New_LPCSTR(float_str));
      float_val := ptoRect.xfmChange.eDy;
      Put(float_str, float_val, Aft=>2);
      bResult := SetDlgItemText(hwnd, IDD_EDY, New_LPCSTR(float_str));
    end;
    return Win32.False;


    -- *  WM_SIZE
    -- *
    -- *  toggle the global variable keeping track of the iconized state
    -- *   of this window.
    when WM_SIZE =>
      if wParam = SIZEICONIC then
        showTransform := Win32.False;
      else
        showTransform := Win32.True;
        lrResult := SendMessage (hwnd, WM_PUTUPFLOATS, 0, 0);
      end if;
      return Win32.False;


    when WM_COMMAND =>
    declare
      buf       : Win32.CHAR_Array(0 .. MAXCHARS-1) := (others => '0');
      buf_ptr   : LPSTR := Win32.LPSTR(CP(buf));
      float_val : Win32.FLOAT;
      junk: POSITIVE;
    begin
      -- *  WM_COMMAND,  IDD_SETXFORM
      -- *
      -- *  take the values from the entry field, fill them into an XFORM
      -- *   structure and then send the track object the message to use
      -- *   these values.  Finally, reformat and repaint the entry fields.
      if LOWORD (To_DWORD(wParam)) = IDD_SETXFORM then
        uResult := GetDlgItemText(hwnd, IDD_EM11, buf_ptr, MAXCHARS);
        Get(Interfaces.C.To_Ada(Win32.To_C(buf)),ptoRect.xfmChange.eM11,junk);

        uResult := GetDlgItemText(hwnd, IDD_EM12, buf_ptr, MAXCHARS);
        Get(Interfaces.C.To_Ada(Win32.To_C(buf)),ptoRect.xfmChange.eM12,junk);

        uResult := GetDlgItemText(hwnd, IDD_EDX, buf_ptr, MAXCHARS);
        Get(Interfaces.C.To_Ada(Win32.To_C(buf)),ptoRect.xfmChange.eDx,junk);

        uResult := GetDlgItemText(hwnd, IDD_EM21, buf_ptr, MAXCHARS);
        Get(Interfaces.C.To_Ada(Win32.To_C(buf)),ptoRect.xfmChange.eM21,junk);

        uResult := GetDlgItemText(hwnd, IDD_EM22, buf_ptr, MAXCHARS);
        Get(Interfaces.C.To_Ada(Win32.To_C(buf)),ptoRect.xfmChange.eM22,junk);

        uResult := GetDlgItemText(hwnd, IDD_EDY, buf_ptr, MAXCHARS);
         Get(Interfaces.C.To_Ada(Win32.To_C(buf)),ptoRect.xfmChange.eDy,junk);

        -- // HACK.  The WM_SIZE here is used to flush the GDI buffer in order
        -- //  to eliminate a very strange bug whereby DPtoLP() doesn't work.
        if showMouse = Win32.True then
          lrResult := SendMessage (hwndMain, WM_SIZE, 0,0);
        end if;

        doTrackObject (TROB_SETXFORM, hwnd, 0);
        lrResult := SendMessage (hwnd, WM_PUTUPFLOATS, 0, 0);

      -- *  WM_COMMAND,  IDD_IDENTITY
      -- *
      -- *  fill a local XFORM structure with the identity matrix.  Now
      -- *   send the track object the message to use these values.
      -- *   Finally, reformat and repaint the entry fields.
      elsif LOWORD (To_DWORD(wParam)) = IDD_IDENTITY then
        ptoRect.xfmChange.eM11 := 1.0;
        ptoRect.xfmChange.eM22 := 1.0;
        ptoRect.xfmChange.eDx  := 0.0;
        ptoRect.xfmChange.eDy  := 0.0;
        ptoRect.xfmChange.eM12 := 0.0;
        ptoRect.xfmChange.eM21 := 0.0;

        -- // HACK.  The WM_SIZE here is used to flush the GDI buffer in order
        -- //  to eliminate a very strange bug whereby DPtoLP() doesn't work.
        if showMouse = Win32.True then
          lrResult := SendMessage (hwndMain, WM_SIZE, 0,0);
        end if;

        doTrackObject (TROB_SETXFORM, hwnd, 0);
        lrResult := SendMessage (hwnd, WM_PUTUPFLOATS, 0, 0);
      end if;
      return Win32.False;
    end;

    when others =>
      return Win32.False;
  end case;
  return Win32.False;
end TransformDlgProc;


-- *  function:  MouseDlgProc()
-- *
-- *  input parameters:  normal window procedure parameters.
-- *
-- *  global variables:
-- *   showMouse  -- Win32.True if window is restored, Win32.False if minimized.
-- *       maintain the value in this routine for other windows' use.
-- *   ptoRect - pointer to the track object.  Needed for DPtoLP()
-- *
-- *  nonstandard messages:
-- *   WM_PUTUPFLOATS - fill the entry fields with the mouse position.
function MouseDlgProc(hwnd    : WinDef.HWND;
                      message : Win32.UINT;
                      wParam  : Win32.WPARAM;
                      lParam  : Win32.LPARAM) return BOOL is

function To_HWND
is new Ada.Unchecked_Conversion (Win32.WPARAM, WinDef.HWND);

begin

  case message is

    -- *  WM_PUTUPFLOATS
    -- *
    -- *  wParam - contains the hwnd for the main window.
    -- *  lParam - contains the mouse position in device coordinates.
    -- *           (c.f. WM_MOUSEMOVE)
    when WM_PUTUPFLOATS =>
      declare
        hwndMain: WinDef.HWND;
        buf     : Win32.CHAR_Array(0 .. MAXCHARS-1) := (others => '0');
          buf_ptr : LPSTR := Win32.LPSTR(CP(buf));
        num_char: Win32.INT;
      begin
        hwndMain    := To_HWND(wParam);
        pScreen.x   := Win32.LONG (LOWORD (To_DWORD(lParam)));
        pWorld(0).x := Win32.LONG (LOWORD (To_DWORD(lParam)));
        pScreen.y   := Win32.LONG (HIWORD (To_DWORD(lParam)));
        pWorld(0).y := Win32.LONG (HIWORD (To_DWORD(lParam)));

        bResult := SetDlgItemText(hwnd, IDD_DEVICEX,
                                  New_LPCSTR(Win32.LONG'Image(pScreen.x)));
        bResult := SetDlgItemText(hwnd, IDD_DEVICEY,
                                  New_LPCSTR(Win32.LONG'Image(pScreen.y)));

        bResult := ClientToScreen (hwndMain, pScreen'Access);
        bResult := SetDlgItemText(hwnd, IDD_SCREENX,
                                  New_LPCSTR(Win32.LONG'Image(pScreen.x)));
        bResult := SetDlgItemText(hwnd, IDD_SCREENY,
                                  New_LPCSTR(Win32.LONG'Image(pScreen.y)));

        bResult := DPtoLP (ptoRect.hdc_value, pWorld(0)'Access, 1);
        bResult := SetDlgItemText(hwnd, IDD_WORLDX,
                                  New_LPCSTR(Win32.LONG'Image(pWorld(0).x)));
        bResult := SetDlgItemText(hwnd, IDD_WORLDY,
                                  New_LPCSTR(Win32.LONG'Image(pWorld(0).y)));

        return Win32.False;
      end;


    -- *  WM_SIZE
    -- *
    -- *  toggle the global variable keeping track of the iconized state
    -- *   of this window.
    when WM_SIZE =>
      if wParam = SIZEICONIC then
        showMouse := Win32.False;
      else
        showMouse := Win32.True;
      end if;
      return Win32.False;

    when others =>
      return Win32.False;

  end case;
  return Win32.False;

end MouseDlgProc;


--  function:  CenterOrigin()
--
--  input parameters:
--   hwnd - window with client we want the center of.
--   hdc - device context which we set the Viewport origin of.
procedure CenterOrigin (hwnd : HWND;
                        the_hdc  : HDC) is
  x, y     : Win32.INT;
begin
  bResult := GetClientRect (hwnd, rect_rec'Access);
  x := Win32.INT (rect_rec.right) / 2;
  y := Win32.INT (rect_rec.bottom) / 2;

  bResult := SetViewportOrgEx (the_hdc, x, y, old_pt2'access);
end CenterOrigin;



--  function:  doTrackObject()
--
--  input parameters:
--   msg -  message selecting what action to take.  Values may include WM_*'s
--           (see case statements below for more information.)
--   hwnd - Window handle for the window the track object exists within.
--   lParam - Usually fourth param to window proc. varies based on msg.
--
--  global variables:  ptoRect (the object on which this procedure operates).
--
--  coordinate spaces:  There are three coordinate spaces of interest here,
--   and this routine is frequently switching between them...
--
--           WORLD                   DEVICE                  SCREEN
--
--      object coordinates       input mouse pos       used w/ SetCursorPos()
--         (pto->rect)          (lParam for WM_*)
--
--             ----->  LPtoDP() ---->    ----> ClientToScreen() -->
--             <-----  DPtoLP() <----    <---- ScreenToClient() <--
--
--   in addition, the HDC has an offset origin.  Device coordinates for the
--   mouse (lParam) never take this into account, but it is necessary to
--   translate them in order to get direct manipulation right.
--
procedure doTrackObject (msg    : Win32.UINT;
                         hwnd   : HWND;
                         lParam : Win32.LONG) is
begin
  case msg is

    --   TROB_NEW
    --
    --   Fill in default values for new PTrackObject structure.  (In the
    --   C version, space for this object is allocated; the object has
    --   already been created in the spec for the Ada version).
    --   for the fields of the structure.  Set up the HDC correctly.
    when TROB_NEW =>
      declare
        gdiobj : HGDIOBJ;
      begin
        -- /* initialize the HDC and other fields. */
        ptoRect.hdc_value := GetDC(hwnd);
        iResult := SetGraphicsMode (ptoRect.hdc_value, GM_ADVANCED);
        iResult := SetROP2(ptoRect.hdc_value, R2_NOT);
        gdiobj  := SelectObject (ptoRect.hdc_value,
                   GetStockObject (NULL_BRUSH));
        gdiobj  := SelectObject(ptoRect.hdc_value, HGDIOBJ (
                   CreatePen (PS_SOLID, 2,
                                     COLORREF (16#01000009#))));
        ptoRect.Mode := TMNONE;
        doTrackObject (TROB_CENTER, hwnd, lParam);
        bResult := GetWorldTransform (ptoRect.hdc_value,
                                      ptoRect.xfmChange'Access);
        -- /* initialize the size. */
        ptoRect.rect.top := 0;  ptoRect.rect.left := 0;
        ptoRect.rect.bottom := TICKSPACE * 5;
        ptoRect.rect.right  := TICKSPACE * 5;

      end;


    -- *  TROB_DELETE
    -- *
    -- * Delete the pen that we created, release the DC.
    -- *  free up the memory allocated for the object.
    when TROB_DELETE =>
      bResult := DeleteObject (
                               SelectObject (ptoRect.hdc_value,
                                  GetStockObject (BLACK_PEN)));
      doTrackObject (TROB_PAINT, hwnd, lParam);
      iResult := ReleaseDC (hwnd, ptoRect.hdc_value);


    -- *  TROB_CENTER
    -- *
    -- * Called in order to reset the view port origin in the track objects
    -- *  hdc whenever the client window changes size.  This hdc is thus kept
    -- *  synchronized with the hdc that the axes are painted into.
    when TROB_CENTER =>
      CenterOrigin (hwnd, ptoRect.hdc_value);


    -- *  TROB_PAINT
    -- *
    -- * Paint the object into its hdc.  Called half the time to erase
    -- *  the object, and half the time to redraw it.
    when TROB_PAINT =>
      bResult := Rectangle (ptoRect.hdc_value,
                            Win32.INT (ptoRect.rect.left)+1,
                            Win32.INT (ptoRect.rect.top) +1,
                            Win32.INT (ptoRect.rect.left)+INC,
                            Win32.INT (ptoRect.rect.top) +INC);

      bResult := Rectangle (ptoRect.hdc_value,
                            Win32.INT (ptoRect.rect.left),
                            Win32.INT (ptoRect.rect.top),
                            Win32.INT (ptoRect.rect.right),
                            Win32.INT (ptoRect.rect.bottom));


    -- *  TROB_SETXFORM
    -- *
    -- * lParam - pointer to the new transform.
    -- *  set the new transform into the HDC, then update xfmChange.
    -- This message is called when the transform has been changed via the
    -- dialog box.
    when TROB_SETXFORM =>
      doTrackObject (TROB_PAINT, hwnd, lParam);
      bResult := SetWorldTransform(ptoRect.hdc_value, ptoRect.xfmChange'Access);
      bResult := GetWorldTransform(ptoRect.hdc_value, ptoRect.xfmChange'Access);
      doTrackObject (TROB_PAINT, hwnd, lParam);


    -- *  TROB_HITTEST
    -- *
    -- * Check the point sent in in the lParam to see if it lays within
    -- *  the bounds of the object's defining rectangle.
    -- * iff the point is in rectangle, set In_Bounds = True, False otherwise.
    when TROB_HITTEST =>
      declare
      begin
        mouWorld(0).x := Win32.LONG (WinDef.LOWORD (DWORD(lParam)));
        mouWorld(0).y := Win32.LONG (WinDef.HIWORD (DWORD(lParam)));

        bResult := DPtoLP (ptoRect.hdc_value, mouWorld(0)'Access, 1);

        bResult := PtInRect (ptoRect.rect'Access, mouWorld(0));
        if bResult = Win32.True then
          In_Bounds := True;
        else
          In_Bounds := False;
        end if;
      end;


    -- *  WM_LBUTTONDOWN &  WM_RBUTTONDOWN
    -- *
    -- * Capture the mouse, set the tracking mode depending on the mouse
    -- *  location in world coordinates, reset the mouse position.
    when WM_LBUTTONDOWN | WM_RBUTTONDOWN =>
      declare
        hwnd_dummy   : WinDef.HWND;
        half_right   : Win32.LONG;
        half_bottom  : Win32.LONG;
      begin
        mouWorld2(0).x := Win32.LONG (WinDef.LOWORD (DWORD(lParam)));
        mouWorld2(0).y := Win32.LONG (WinDef.HIWORD (DWORD(lParam)));
        bResult := DPtoLP (ptoRect.hdc_value, mouWorld2(0)'Access, 1);
        half_right  := ptoRect.rect.right / 2;
        half_bottom := ptoRect.rect.bottom / 2;

        -- /* upper left hand corner. right button is no-op. */
        if ((mouWorld2(0).x <= half_right) and
            (mouWorld2(0).y <= half_bottom) ) then
          if msg = WM_LBUTTONDOWN then
            ptoRect.Mode := TMMOVE;
            newmouScreen(0).x := ptoRect.rect.left;
            newmouScreen(0).y := ptoRect.rect.top;
          else  -- WM_RBUTTONDOWN, do nothing
            null;
          end if;

        -- /* lower left hand corner */
        elsif ((mouWorld2(0).x <= half_right) and
               (mouWorld2(0).y >  half_bottom)) then
          if msg = WM_RBUTTONDOWN then
            ptoRect.Mode := TMSHEARY;
          else
            ptoRect.Mode := TMSIZEY;
          end if;
          newmouScreen(0).x := ptoRect.rect.left;
          newmouScreen(0).y := ptoRect.rect.bottom;

        -- /* upper right hand corner */
        elsif ((mouWorld2(0).x >  half_right) and
               (mouWorld2(0).y <= half_bottom)) then
          if msg = WM_RBUTTONDOWN then
            ptoRect.Mode := TMSHEARX;
          else
            ptoRect.Mode := TMSIZEX;
          end if;
          newmouScreen(0).x := ptoRect.rect.right;
          newmouScreen(0).y := ptoRect.rect.top;

        -- /* lower right hand corner */
        -- elsif ((mouWorld2(0).x > half_right) and
        --        (mouWorld2(0).y > half_bottom)) then
        else  -- take care of last case
          if msg = WM_RBUTTONDOWN then
            ptoRect.Mode := TMROTATE;
          else
            ptoRect.Mode := TMSIZEXY;
          end if;
          newmouScreen(0).x := ptoRect.rect.right;
          newmouScreen(0).y := ptoRect.rect.bottom;

        end if;

        hwnd_dummy := SetCapture(hwnd);
        bResult := LPtoDP (ptoRect.hdc_value, newmouScreen(0)'Access, 1);
        bResult := ClientToScreen (hwnd, newmouScreen(0)'Access);
        bResult := SetCursorPos (Win32.INT (newmouScreen(0).x),
                                 Win32.INT (newmouScreen(0).y));
        bResult := GetWorldTransform(ptoRect.hdc_value,ptoRect.xfmDown'Access);
      end;


    -- *  WM_MOUSEMOVE
    -- *
    -- * this is where almost all of the interesting calculation is done.
    -- *  First clip the mouse location to be in client rectangle, then
    -- *  call MouseMove() to handle the different tracking modes.
    when WM_MOUSEMOVE =>
      declare
        mouse_pos_out : POINT;
        mouse_pos_in  : POINT;
      begin
        mouse_pos_in.x := Win32.LONG (WinDef.LOWORD (DWORD(lParam)));
        mouse_pos_in.y := Win32.LONG (WinDef.HIWORD (DWORD(lParam)));
        bResult := GetClientRect (hwnd, rect'Access);
        -- set default values for the mouse out position.
        mouse_pos_out.x := mouse_pos_in.x;
        mouse_pos_out.y := mouse_pos_in.y;

        -- make corrections to the mouse out position.  If it is outside of
        -- any bounds of the client area, then use the client area.

        if mouse_pos_in.x < rect.left then
          mouse_pos_out.x := rect.left;
        end if;

        if mouse_pos_in.x > rect.right then
          mouse_pos_out.x := rect.right;
        end if;

        if mouse_pos_in.y < rect.top then
          mouse_pos_out.y := rect.top;
        end if;

        if mouse_pos_in.y > rect.bottom then
          mouse_pos_out.y := rect.bottom;
        end if;

        MouseMove (msg, hwnd, mouse_pos_out);

      end;


    -- *  WM_RBUTTONUP & WM_LBUTTONUP
    -- *
    -- * simply release the mouse capture, and set the mode to TMNONE.
    when WM_RBUTTONUP | WM_LBUTTONUP =>
      if (ptoRect.Mode /= TMNONE) then
        bResult := ReleaseCapture;
        ptoRect.Mode := TMNONE;
      end if;

    when others =>
      null;

  end case;

end doTrackObject;


-- *  function:  MouseMove()
-- *
-- *  input parameters:
-- *   msg -  not used.
-- *   hwnd - Window handle for the window the track object exists within.
-- *   location - location of the mouse
-- *
-- *  The tracking behavior which the user observers when moving the mouse
-- *   is based on the current tracking mode of the object.  This is usually
-- *   determined on the mouse down event (c.f. TM*).  First erase the old
-- *   object, then figure out the change to the transform matrix, finally
-- *   change the world transform matrix and redraw the object.
-- *
-- *  Tranform:
-- *    (    eM11        eM12        0   )
-- *    (    eM21        eM22        0   )
-- *    (    eDx         eDy         1   )
-- *
-- *   xDevice = (xWorld * eM11) + (yWorld * eM21) + eDx
-- *   yDevice = (xWorld * eM12) + (yWorld * eM22) + eDy
-- *
-- *   In this routine the Device (mouse location) and World (rectangle corner)
-- *   points are known.  Therefore, the two equations above are solved for
-- *   the desired matrix entry value (e.g. eM11, 1M12, ... eDy).  The tracking
-- *   mode determines which one of these entries may be changed.  E.g. scaling
-- *   in X modifies eM11 while shearing in X modifies eM12.  So rather than
-- *   using the world transform to map from world to device points, we are
-- *   back-computing the proper contents of the world transform.
-- *
-- Note;  The C version of this did not do any checking for possible divide
-- by zero errors.  This version will leave the procedure without doing
-- anything in the case in which the parameters are such that a divide by zero
-- or other floating point error occurs.  The C version also passed the x
-- and y values via a LONG type parameter.  Rather than doing this, I will
-- pass a point record in.  This will save on some converting back and forth.
procedure MouseMove (msg      : UINT;
                     hwnd     : HWND;
                     location : POINT) is
  temp      : FLOAT;
  invalid_computation : boolean := False;

begin
  doTrackObject(TROB_PAINT, hwnd, 0);
  mouDevice.x     := location.x;
  mouWorld3(0).x  := location.x;
  mouDevice.y     := location.y;
  mouWorld3(0).y  := location.y;

  bResult := SetWorldTransform (ptoRect.hdc_value, ptoRect.xfmDown'Access);
  bResult := DPtoLP (ptoRect.hdc_value, mouWorld3(0)'Access, 1);

  -- /* offset the mouse device point for the viewport's origin. */
  bResult := GetViewportOrgEx (ptoRect.hdc_value, orgDevice'Access);
  mouDevice.x := mouDevice.x - orgDevice.x;
  mouDevice.y := mouDevice.y - orgDevice.y;

  bResult := GetWorldTransform(ptoRect.hdc_value, ptoRect.xfmChange'Access);

  case ptoRect.Mode is
    -- *    (     1         xShear       0   )
    -- *    (     0           1          0   )
    -- *    (     0           0          1   )
    -- *
    -- * xWorld = rect.left == 0;
    when TMSHEARX =>
      if ptoRect.rect.right /= 0 then
        ptoRect.xfmChange.eM12 := (Win32.FLOAT (mouDevice.y) -
                                   ptoRect.xfmChange.eDy) /
                                   Win32.FLOAT (ptoRect.rect.right);
        bResult := SetWorldTransform (ptoRect.hdc_value, ptoRect.xfmChange'Access);
      else
        invalid_computation := True;
      end if;


    -- *    (     1           0          0   )
    -- *    (   yShear        1          0   )
    -- *    (     0           0          1   )
    -- *
    -- * yWorld = rect.top == 0;
    when TMSHEARY =>
      if ptoRect.rect.bottom /= 0 then
        ptoRect.xfmChange.eM21 := (Win32.FLOAT (mouDevice.x) -
                                   ptoRect.xfmChange.eDx) /
                                   Win32.FLOAT (ptoRect.rect.bottom);
        bResult := SetWorldTransform (ptoRect.hdc_value, ptoRect.xfmChange'Access);
      else
        invalid_computation := True;
      end if;


    -- *    (   cos(a)      -sin(a)      0   )
    -- *    (   sin(a)       cos(a)      0   )
    -- *    (     0           0          1   )
    -- *
    -- * a == rotation angle.  Since mouse in in lower right,
    -- *  we need to shift this back 45 degrees (assuming that
    -- *  straight down is 0 degrees).  Thus we actually compute
    -- *  cos(a) = cos(b - 45) = cos(b)sin(45) + cos(45)sin(45)
    -- *  where b is angle from the origin to the mouse (x,y)
    -- *  cos(45) = sin(45) ~= 0.707107
    -- *  cos(b) = y/r    sin(b) = x/r
    -- *
    when TMROTATE =>
    declare
      r : FLOAT;
    begin
      -- /* translate back to the origin. */
      ptoRect.xfmChange.eDx := 0.0;
      ptoRect.xfmChange.eDy := 0.0;
      bResult := SetWorldTransform (ptoRect.hdc_value, ptoRect.xfmChange'Access);

      -- /* rotate about the origin. */
      r := Float_Functions.sqrt (FLOAT (
             (mouWorld3(0).x * mouWorld3(0).x) +
             (mouWorld3(0).y * mouWorld3(0).y)) );

      ptoRect.xfmChange.eM11 :=
        Win32.FLOAT((FLOAT(mouWorld3(0).y + mouWorld3(0).x) * 0.707107) / r);
      ptoRect.xfmChange.eM22 := ptoRect.xfmChange.eM11;
      ptoRect.xfmChange.eM12 :=
        Win32.FLOAT((FLOAT (mouWorld3(0).y - mouWorld3(0).x) * 0.707107) / r);
      ptoRect.xfmChange.eM21 := -1.0 * ptoRect.xfmChange.eM12;
      ptoRect.xfmChange.eDx := 0.0;
      ptoRect.xfmChange.eDy := 0.0;

      bResult := ModifyWorldTransform (ptoRect.hdc_value,
                                       ptoRect.xfmChange'Access,
                                       MWT_RIGHTMULTIPLY);

      -- /* translate back to the original offset. */
      ptoRect.xfmChange.eM11 := 1.0;
      ptoRect.xfmChange.eM22 := 1.0;
      ptoRect.xfmChange.eM12 := 0.0;
      ptoRect.xfmChange.eM21 := 0.0;

      ptoRect.xfmChange.eDx := ptoRect.xfmDown.eDx;
      ptoRect.xfmChange.eDy := ptoRect.xfmDown.eDy;
      bResult := ModifyWorldTransform (ptoRect.hdc_value,
                                       ptoRect.xfmChange'Access,
                                       MWT_RIGHTMULTIPLY);
      bResult := GetWorldTransform (ptoRect.hdc_value, ptoRect.xfmChange'Access);
    end;


    -- *    (  Size X         0          0   )
    -- *    (     0        Size Y        0   )
    -- *    (     0           0          1   )
    -- *
    when TMSIZEXY =>
    if ptoRect.rect.right /= 0 and ptoRect.rect.bottom /= 0 then
      ptoRect.xfmChange.eM11 :=
         (Win32.FLOAT (mouDevice.x) - ptoRect.xfmChange.eDx -
          (Win32.FLOAT (ptoRect.rect.bottom) * ptoRect.xfmChange.eM21)) /
           Win32.FLOAT (ptoRect.rect.right);

      ptoRect.xfmChange.eM22 :=
          (Win32.FLOAT (mouDevice.y) - ptoRect.xfmChange.eDy -
           (Win32.FLOAT (ptoRect.rect.right) * ptoRect.xfmChange.eM12)) /
            Win32.FLOAT (ptoRect.rect.bottom);

      bResult := SetWorldTransform (ptoRect.hdc_value, ptoRect.xfmChange'Access);
    else
      invalid_computation := True;
    end if;


    -- *    (  Size X         0          0   )
    -- *    (     0           1          0   )
    -- *    (     0           0          1   )
    -- *
    -- * yWorld = rect.top == 0;
    when TMSIZEX =>
    if ptoRect.rect.right /= 0 then
      ptoRect.xfmChange.eM11 := (Win32.FLOAT (mouDevice.x) -
                                 ptoRect.xfmChange.eDx) /
                                 Win32.FLOAT (ptoRect.rect.right);
      bResult := SetWorldTransform (ptoRect.hdc_value, ptoRect.xfmChange'Access);
    else
      invalid_computation := True;
    end if;


    -- *    (     1           0          0   )
    -- *    (     0        Size Y        0   )
    -- *    (     0           0          1   )
    -- *
    -- * xWorld = rect.left == 0;
    when TMSIZEY =>
    if ptoRect.rect.bottom /= 0 then
      ptoRect.xfmChange.eM22 := (Win32.FLOAT (mouDevice.y) -
                                 ptoRect.xfmChange.eDy) /
                                 Win32.FLOAT (ptoRect.rect.bottom);
      bResult := SetWorldTransform (ptoRect.hdc_value, ptoRect.xfmChange'Access);
    else
      invalid_computation := True;
    end if;


    -- *    (     1           0          0   )
    -- *    (     0           1          0   )
    -- *    (   Move x      Move y       1   )
    -- *
    -- * xWorld = rect.left == 0;
    -- * yWorld = rect.top == 0;
    when TMMOVE =>
      ptoRect.xfmChange.eDx := Win32.FLOAT (mouDevice.x);
      ptoRect.xfmChange.eDy := Win32.FLOAT (mouDevice.y);
      bResult := SetWorldTransform (ptoRect.hdc_value, ptoRect.xfmChange'Access);

    when others =>
      invalid_computation := True;
  end case;

  doTrackObject(TROB_PAINT, hwnd, 0);

end MouseMove;

--  The following null dialog box procedure did not appear in the C version
--  of this sample.  It has been provided here for use in wxform_ada.
function Null_Dlgproc (hwnd    : HWND;
                       message : UINT;
                       wParam  : WPARAM;
                       lParam  : LPARAM) return BOOL is
begin
  return Win32.False;
end Null_Dlgproc;

-------------------------------------------------------------------------------
--
-- THIS FILE AND ANY ASSOCIATED DOCUMENTATION IS PROVIDED "AS IS" WITHOUT
-- WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT
-- LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR
-- A PARTICULAR PURPOSE.  The user assumes the entire risk as to the accuracy
-- and the use of this file.  This file may be used only by licensees of
-- Microsoft Corporation's WIN32 Software Development Kit in accordance with
-- the terms of the licensee's End-User License Agreement for Microsoft
-- Software for the WIN32 Development Kit.
--
-- Copyright (c) Intermetrics, Inc. 1995
-- Portions (c) 1985-1994 Microsoft Corporation with permission.
-- Microsoft is a registered trademark and Windows and Windows NT are
-- trademarks of Microsoft Corporation.
--
-------------------------------------------------------------------------------

end Wxform_Util;