'Classes/ActiveBasic/Windows/UI/Control.ab

#require <Classes/ActiveBasic/Windows/UI/WindowHandle.ab>
#require <Classes/ActiveBasic/Windows/UI/EventArgs.ab>
#require <Classes/ActiveBasic/COM/ComClassBase.ab>

Namespace ActiveBasic
Namespace Windows
Namespace UI

Namespace Detail
	TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL
End Namespace

/*
@brief Windowsのウィンドウを管理する基底クラス
@auther Egtra
*/
Class Control
	Inherits WindowHandle
	Implements ActiveBasic.COM.InterfaceQuerable
Public
	/*!
	@brief Destroyイベントよりも後に呼ばれるDestroyイベントデリゲート
	@date	2008/07/16
	*/
	finalDestroy As ActiveBasic.Windows.UI.Handler

	Sub Control()
		comImpl = New COM.ComClassDelegationImpl(This)
	End Sub

	Function Handle() As HWND
		Handle = hwnd
	End Function

	/*!
	@brief HWNDからControlインスタンスを取得する。
	@param[in] hwnd 対象のウィンドウハンドル
	@return 対応するControlインスタンス。存在しなければ作成される。ただし、hwndがNULLならNothing。
	*/
	Static Function FromHWnd(hwnd As HWND) As Control
		FromHWnd = Nothing
		If IsWindow(hwnd) Then
			FromHWnd = FromHWndCore(hwnd)
			If ActiveBasic.IsNothing(FromHWnd) Then
				Dim lock = New ActiveBasic.Windows.CriticalSectionLock(_System_CriticalSection)
				Try
					FromHWnd = New Control
					FromHWnd.registerStandardEvent()
					FromHWnd.AssociateHWnd(hwnd)
				Finally
					lock.Dispose()
				End Try
			End If
		End If
	End Function

	Function AddRef() As DWord
		AddRef = comImpl.AddRef()
	End Function

	Function Release() As DWord
		Release = comImpl.Release()
	End Function

	Function QueryInterface(ByRef riid As IID, ByRef pv As Any) As HRESULT
		QueryInterface = comImpl.QueryInterface(riid, pv)
	End Function

Private
	Static Function FromHWndCore(hwnd As HWND) As Control
		FromHWndCore = _System_PtrObj(GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As VoidPtr) As Control
	End Function

'--------------------------------
' ウィンドウ作成

Public
	/*!
	@brief ウィンドウを作成する（詳細版）。
	@date 2008/08/02
	通常はCreateやCreateFormその他を使ってください。
	ここで渡された引数は、GetCreateStructへ渡して修正の機会を与えた後に、
	CreateWindowExへ渡される。
	*/
	Sub CreateEx(parent As Control, style As DWord, exStyle As DWord, hmenu As HMENU)
		Dim cs As CREATESTRUCT
		With cs
			.dwExStyle = exStyle
			.lpszClass = (atom As ULONG_PTR) As LPCTSTR
			.lpszName = 0
			.style = style
			.x = 0
			.y = 0
			.cx = 0
			.cy = 0
			If IsNothing(parent) Then
				.hwndParent = 0
			Else
				.hwndParent = parent As HWND
			End If
			.hMenu = hmenu
			.hInstance = hInstance
		End With
		GetCreateStruct(cs)
		createImpl(cs, parent)
	End Sub

	/*!
	@brief ウィンドウを作成する（子ウィンドウ以外）。
	@date 2008/08/02
	*/
	Sub CreateForm(style As DWord, exStyle As DWord, owner = Nothing As Control, hmenu = 0 As HMENU)
		CreateEx(owner, style, exStyle, hmenu)
	End Sub

	Sub CreateForm()
		CreateEx(Nothing, 0, 0, 0)
	End Sub

	/*!
	@brief 子ウィンドウを作成する。
	@date 2008/08/02
	*/
	Sub Create(parent As Control, style = 0 As DWord, exStyle = 0 As DWord, id = 0 As Long)
		CreateEx(parent, style Or WS_CHILD Or WS_VISIBLE, exStyle, id As ULONG_PTR As HMENU)
	End Sub

Protected
	/*!
	@brief ウィンドウ作成前の初期設定確認
	派生クラスでオーバーライドして、csを書き換えてよい。
	書き換えられたcsを基にCreateWindowExが呼ばれる。
	*/
	Virtual Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
	End Sub

Private
	Sub createImpl(ByRef cs As CREATESTRUCT, parent As Control)
		throwIfAlreadyCreated()

		StartWndProc()

		With cs
			'よそのウィンドウクラスの場合、WndProcFirst内のhwndの代入が行われないため、ここでも行っておく。
			hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
				.x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
			If hwnd = 0 Then
				ThrowWithLastErrorNT("Control.CreateEx")
			End If
			
			If IsNothing(FromHWndCore(hwnd)) <> False Then
				AssociateHWnd(hwnd)
				TlsSetValue(tlsIndex, 0)
			End If
		End With

		If IsNothing(parent) = False Then
			RegisterUnassociateHWnd(parent)
		End If
	End Sub

Public
/*
	Sub Attach(hwndNew As HWND)
		throwIfAlreadyCreated()
		If hwndNew = 0 Then
			Throw New System.ArgumentNullException("Control.Attach")
		End If
		registerStandardEvent()
		AssociateHWnd(hwndNew)
	End Sub
*/

	Sub BeginSubclass()
		throwIfNotCreated()
		prevWndProc = SetWindowLongPtr(hwnd, GWLP_WNDPROC, AddressOf(WndProcFirst) As LONG_PTR) As WNDPROC
	End Sub

Private
	Sub throwIfAlreadyCreated()
		If hwnd <> 0 Then
			Throw New System.InvalidOperationException("Window is already created.")
		End If
	End Sub

	Sub throwIfNotCreated()
		If hwnd = 0 Then
			Throw New System.InvalidOperationException("Window is not already created.")
		End If
	End Sub

'--------------------------------
' ウィンドウプロシージャ

Protected
	Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		If Not ProcessMessage(msg, wp, lp, WndProc) Then
			WndProc = DefWndProc(msg, wp, lp)
		End If
	End Function

	Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		If prevWndProc Then
			DefWndProc = CallWindowProc(prevWndProc, hwnd, msg, wp, lp)
		Else
			DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
		End If
	End Function
Protected
	Function ProcessMessage(msg As DWord, wp As WPARAM, lp As LPARAM, ByRef lr As LRESULT) As Boolean
		Dim h = Nothing As MessageHandler
		Dim b = messageMap.TryGetValue(Hex$(msg), h)
		If b Then
			If Not IsNothing(h) Then
				Dim a = New MessageArgs(hwnd, msg, wp, lp)
				h(This, a)
				If a.Handled Then
					lr = a.LResult
					ProcessMessage = True
					Exit Function
				End If
			End If
		End If
		ProcessMessage = False
	End Function
Private
	Static Function makeKeysFormMsg(e As MessageArgs) As Keys
		Dim t = (e.WParam As DWord) And Keys.KeyCode
		t Or= (GetKeyState(VK_SHIFT) As Word And &h8000) << 1
		t Or= (GetKeyState(VK_CONTROL) As Word And &h8000) << 2
		t Or= (GetKeyState(VK_MENU) As Word And &h8000) << 3
		makeKeysFormMsg = t As Keys
	End Function

	Static Function makeMouseEventFromMsg(e As MessageArgs) As MouseArgs
		Dim wp = e.WParam
		Dim lp = e.LParam

		/*************************************************/
		Dim mb As MouseButtons
		If LOWORD(wp) = 0 Then mb = MouseButtons.None
		If LOWORD(wp) and MK_LBUTTON Then mb or = MouseButtons.Left
		If LOWORD(wp) and MK_RBUTTON Then mb or = MouseButtons.Right
		If LOWORD(wp) and MK_MBUTTON Then mb or = MouseButtons.Middle
		If LOWORD(wp) and MK_XBUTTON1 Then mb or = MouseButtons.XButton1
		If LOWORD(wp) and MK_XBUTTON2 Then mb or = MouseButtons.XButton2
		If LOWORD(wp) and MK_SHIFT Then mb or = MouseButtons.Shift
		If LOWORD(wp) and MK_CONTROL Then mb or = MouseButtons.Control
		makeMouseEventFromMsg = New MouseArgs(mb, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
		/*************************************************/

		'makeMouseEventFromMsg = New MouseArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
	End Function

Protected
	/*!
	@brief	最初にウィンドウプロシージャを使うための前処理を行う関数
	@date	2008/07/11
	WndProcFirstを使うときは、この関数を呼んでおく必要がある。
	*/
	Sub StartWndProc()
		TlsSetValue(tlsIndex, ObjPtr(This))
		registerStandardEvent()
	End Sub
Private
	/*!
	@brief	主なメッセージハンドラの登録を行う関数
	@date	2008/08/02
	*/
	Sub registerStandardEvent()
		AddMessageEvent(WM_ERASEBKGND, AddressOf(OnEraseBackground))
		Dim md = New MessageHandler(AddressOf(OnMouseDownBase))
		AddMessageEvent(WM_LBUTTONDOWN, md)
		AddMessageEvent(WM_RBUTTONDOWN, md)
		AddMessageEvent(WM_MBUTTONDOWN, md)
		AddMessageEvent(WM_XBUTTONDOWN, md)
		Dim mu = New MessageHandler(AddressOf(OnMouseUpBase))
		AddMessageEvent(WM_LBUTTONUP, mu)
		AddMessageEvent(WM_RBUTTONUP, mu)
		AddMessageEvent(WM_MBUTTONUP, mu)
		AddMessageEvent(WM_XBUTTONUP, mu)
		Dim mb = New MessageHandler(AddressOf(OnMouseDblClkBase))
		AddMessageEvent(WM_LBUTTONDBLCLK, mb)
		AddMessageEvent(WM_RBUTTONDBLCLK, mb)
		AddMessageEvent(WM_MBUTTONDBLCLK, mb)
		AddMessageEvent(WM_XBUTTONDBLCLK, mb)

		AddMessageEvent(WM_MOUSEMOVE, AddressOf(OnMouseMoveBase))
		AddMessageEvent(WM_MOUSELEAVE, AddressOf(OnMouseLeaveBase))
		AddMessageEvent(WM_MOUSEHOVER, AddressOf(OnMouseHoverBase))
		AddMessageEvent(WM_PAINT, AddressOf(OnPaintBase))
		AddMessageEvent(WM_KEYDOWN, AddressOf(OnKeyDownBase))
		AddMessageEvent(WM_CHAR, AddressOf(OnChar))	
		AddMessageEvent(WM_CREATE, AddressOf(OnCreateBase))
		AddMessageEvent(WM_SIZE, AddressOf(OnSize))
	End Sub

	Sub OnEraseBackground(sender As Object, e As MessageArgs)
		Dim a = New PaintBackgroundArgs(e.WParam, e.LParam)
		e.Handled = e.Handled And OnPaintBackground(a)
		e.LResult = a.Painted
	End Sub

	Sub OnMouseDownBase(sender As Object, e As MessageArgs)
		e.Handled = e.Handled And OnMouseDown(makeMouseEventFromMsg(e))
	End Sub

	Sub OnMouseUpBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		If doubleClickFired = False Then
			OnClick(Args.Empty)
			OnMouseClick(me)
		Else
			doubleClickFired = False
		End If
		e.Handled = e.Handled And OnMouseUp(me)
	End Sub

	Sub OnMouseDblClkBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		doubleClickFired = True
		OnMouseDown(me)
		OnDoubleClick(Args.Empty)
		e.Handled = e.Handled And OnMouseDoubleClick(me)
	End Sub

	Sub OnMouseMoveBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		If mouseEntered = False Then
			mouseEntered = True
			OnMouseEnter(me)
			trackMouseEvent(TME_LEAVE Or TME_HOVER)
		End If
		e.Handled = e.Handled And OnMouseMove(me)
	End Sub

	Sub OnMouseLeaveBase(sender As Object, e As MessageArgs)
		e.Handled = e.Handled And OnMouseLeave(Args.Empty)
		mouseEntered = False
	End Sub

	Sub OnMouseHoverBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		e.Handled = e.Handled And OnMouseHover(me)
	End Sub

	Sub OnPaintBase(sender As Object, e As MessageArgs)
		If ActiveBasic.IsNothing(paintDC) Then
			e.Handled = False
		Else
			Dim ps As PAINTSTRUCT
			BeginPaint(hwnd, ps)
			Try
				OnPaintDC(New PaintDCArgs(ps.hdc, ps.rcPaint))
			Finally
				EndPaint(hwnd, ps)
			End Try
		End If
	End Sub

	Sub OnKeyDownBase(sender As Object, e As MessageArgs)
		e.Handled = e.Handled And OnKeyDown(New KeyArgs(makeKeysFormMsg(e)))
	End Sub

	Sub OnKeyUpBase(sender As Object, e As MessageArgs)
		e.Handled = e.Handled And OnKeyUp(New KeyArgs(makeKeysFormMsg(e)))
	End Sub

	Sub OnChar(sender As Object, e As MessageArgs)
		e.Handled = e.Handled And OnKeyPress(New KeyPressArgs(e.WParam As Char))
	End Sub

	Sub OnCreateBase(sender As Object, e As MessageArgs)
		Dim c = New CreateArgs(e.LParam As *CREATESTRUCT)
		If e.LResult = -1 Then
			c.Cancel = True
		End If
		e.Handled = e.Handled And OnCreate(c)
		If c.Cancel Then
			e.LResult = -1
		Else
			e.LResult = 0
		End If
	End Sub

	Sub OnSize(sender As Object, e As MessageArgs)
		e.Handled = e.Handled And OnResize(New ResizeArgs(e.WParam, e.LParam))
	End Sub

	messageMap As System.Collections.Generic.Dictionary<Object /*DWord*/, MessageHandler>

Public
	/*!
	@biref	メッセージイベントハンドラを登録する。
	@date	2007/12/04
	*/
	Sub AddMessageEvent(message As DWord, h As MessageHandler)
		If Not IsNothing(h) Then
			If IsNothing(messageMap) Then
				messageMap = New System.Collections.Generic.Dictionary<Object, MessageHandler>
			End If
			Dim msg = Hex$(message)
			Dim m = Nothing As MessageHandler
			If messageMap.TryGetValue(msg, m) Then
				messageMap.Item[msg] = m + h
			Else
				messageMap.Item[msg] = h
			End If
		End If
	End Sub

	/*!
	@biref	メッセージイベントハンドラ登録を解除する。
	@date	2007/12/04
	*/
	Sub RemoveMessageEvent(message As DWord, a As MessageHandler)
		If Not IsNothing(a) Then
			If Not IsNothing(messageMap) Then
				Dim msg = Hex$(message)
				Dim m = messageMap.Item[msg]
				If Not IsNothing(m) Then
					messageMap.Item[msg] = m - a
				End If
			End If
		End If
	End Sub

'--------------------------------
' ウィンドウメッセージ処理


'--------
'イベント

#include "ControlEvent.sbp"

'--------------------------------
' インスタンスメンバ変数
Private
	/*!
	@brief	サブクラス化前のウィンドウプロシージャ
	@date	2008/08/23
	サブクラス化していなければNULL
	*/
	prevWndProc As WNDPROC
	/*!
	@brief マウスカーソルがクライアント領域に入っているかどうかのフラグ
	外から中に入ってきたときにMouseEnterイベントを発生させるために用意している。
	*/
	mouseEntered As Boolean
	/*!
	@brief ダブルクリックが起こったかどうかのフラグ
	Click/MouseClickイベントのために用意している。
	@date	2008/07/12
	*/
	doubleClickFired As Boolean

'--------------------------------
' 初期ウィンドウクラス
Protected
	Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		Imports System.Runtime.InteropServices

		Dim rThis = FromHWndCore(hwnd)
		If IsNothing(rThis) Then
			rThis = _System_PtrObj(TlsGetValue(tlsIndex)) As Control
			TlsSetValue(tlsIndex, 0)
			If IsNothing(rThis) Then
				Goto *InstanceIsNotFound
			End If
			' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
			rThis.AssociateHWnd(hwnd)
		End If
		If msg = WM_NCDESTROY Then
			rThis.UnassociateHWnd()
			rThis.hwnd = 0
		End If
		If msg = WM_DESTROY And IsNothing(rThis.finalDestroy) = False Then
			Dim f = rThis.finalDestroy
			f(rThis, Args.Empty)
		End If
		WndProcFirst = rThis.WndProc(msg, wp, lp)
		Exit Function

	*InstanceIsNotFound
		Dim err = String.Concat("Control.WndProcFirst: The attached instance is not found. msg = &h",
			Hex$(msg), Ex"\r\n")
		OutputDebugString(ToTCStr(err))
		WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
	End Function

	/*!
	@brief	Controlインスタンスとウィンドウハンドルを結び付ける。
	@param[in] hwndNew	結び付けるウィンドウハンドル
	@date	2008/07/16
	これを実行することで、UnassociateHWndされるまでControlがGC対象にならなくなると共に、
	FromHWndでウィンドウハンドルからControlインスタンスの取得が可能となる。
	*/
	Sub AssociateHWnd(hwndNew As HWND)
		SetHWnd(hwndNew)
		Prop[PropertyInstance] = ObjPtr(This) As HANDLE
		comImpl.AddRef()
	End Sub

	/*!
	@brief	オーナーの破棄時にこのControlインスタンスとウィンドウハンドルの結び付けを解除するよう登録する。
	@param[in] owner 結び付けの解除を連動させるControl
	@date	2008/07/16
	ownerのFinalDestoryでこのControlとHWNDとの結び付けを解除する。
	*/
	Sub RegisterUnassociateHWnd(owner As Control)
		If IsNothing(owner) = False Then
			Dim e = New Handler(AddressOf(UnassociateHWndOnEvent))
			If IsNothing(finalDestroy) Then
				owner.finalDestroy = e
			Else
				owner.finalDestroy += e
			End If
		End If
	End Sub

	Sub UnassociateHWndOnEvent(sender As Object, e As Args)
		UnassociateHWnd()
		hwnd = 0
	End Sub

	Sub UnassociateHWnd()
		comImpl.Release()
	End Sub

'	Static Const WM_CONTROL_INVOKE = WM_USER + 0 As DWord
'	Static Const WM_CONTROL_BEGININVOKE = WM_USER + 1 As DWord

'--------------------------------
'	インタフェース実装

Public
	Virtual Function QueryInterfaceImpl(ByRef iid As IID, ByRef pv As VoidPtr) As HRESULT
		QueryInterfaceImpl = E_NOTIMPL
	End Function

Private
	/*!
	@brief ウィンドウの寿命管理
	Controlには次のAddRef-Releaseの対がある。
	@li createImpl - WM_NCDESTROY（ウィンドウプロシージャがWndProcFirstの場合）
	@li createImpl - UnassociateHWnd←UnassociateHWndOnEvent←RegisterUnassociateHWnd（その他のウィンドウクラスの場合）
	@li Attach - WM_NCDESTROY（サブクラス化された場合）
	なお、Control派生クラスをサブクラス化すると、後ろ2つが両方適用される。
	*/
	comImpl As COM.ComClassDelegationImpl

'--------------------------------
'	その他の補助関数
Private
	Function trackMouseEvent(flags As DWord) As BOOL
		If pTrackMouseEvent <> 0 Then
			Dim tme As TRACKMOUSEEVENT
			With tme
				.cbSize = Len(tme)
				.dwFlags = flags
				.hwndTrack = hwnd
				.dwHoverTime = HOVER_DEFAULT
			End With
			trackMouseEvent = pTrackMouseEvent(tme)
		End If
	End Function

'--------------------------------
' 初期化終了関連（特にウィンドウクラス）
Private
	'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
	Static tlsIndex As DWord

	Static hInstance As HINSTANCE
	Static atom As ATOM
	Static hmodComctl As HMODULE
	Static pTrackMouseEvent As Detail.PTrackMouseEvent

	Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
	Static Const PropertyInstance = 0 As ATOM
Public
	Static Sub Initialize(hinst As HINSTANCE)
		tlsIndex = TlsAlloc()
		If tlsIndex = TLS_OUT_OF_INDEXES Then
			ThrowWithLastError("Control.Initialize: TlsAlloc failed.")
		End If
		hInstance = hinst
		hmodComctl = LoadLibrary("comctl32.dll")
		pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent")) As Detail.PTrackMouseEvent

		Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
		PropertyInstance = GlobalAddAtom(ToTCStr(PropertyInstanceString))
		If PropertyInstance = 0 Then
			ThrowWithLastError("Control.Initialize: GlobalAddAtom failed.")
		End If

		Dim wcx As WNDCLASSEX
		With wcx
			.cbSize = Len (wcx)
			.style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
			.lpfnWndProc = AddressOf (WndProcFirst)
			.cbClsExtra = 0
			.cbWndExtra = 0
			.hInstance = hinst
			.hIcon = 0
			.hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
			.hbrBackground = (COLOR_3DFACE + 1) As HBRUSH
			.lpszMenuName = 0
			.lpszClassName = ToTCStr(WindowClassName)
			.hIconSm = 0
		End With
		atom = RegisterClassEx(wcx)
		If atom = 0 Then
			ThrowWithLastErrorNT("Control.Initialize: RegisterClasseEx failed.")
		End If
	End Sub

	Static Sub Uninitialize()
		If atom <> 0 Then
			UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
		End If
		If tlsIndex <> 0 And tlsIndex <> &hffffffff Then
			TlsFree(tlsIndex)
		End If
		If hmodComctl <> 0 Then
			FreeLibrary(hmodComctl)
		End If
		If PropertyInstance <> 0 Then
			GlobalDeleteAtom(PropertyInstance)
		End If
	End Sub
End Class

/*!
@brief WM_COMMANDで通知を行うコントロールの基底クラス
@date 2008/08/28
@auther Egtra
親がWM_COMMANDを受け取ったら、RaiseCommandEventを呼ぶことを意図している。
（Formで実装済み）
*/
Class WmCommandControl
	Inherits Control
Public
	Abstract Function RaiseCommandEvent(notificationCode As Word) As Boolean
End Class

End Namespace 'UI
End Namespace 'Widnows
End Namespace 'ActiveBasic