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

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

Namespace ActiveBasic
Namespace Windows
Namespace UI

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

Class Control
	Inherits WindowHandle
Public
	/*!
	@brief Destroyイベントよりも後に呼ばれるDestroyイベントデリゲート
	@date	2008/07/16
	*/
	finalDestroy As ActiveBasic.Windows.UI.Handler

	Sub Control()
	End Sub

	Virtual Sub ~Control()
	End Sub

	Function Handle() As HWND
		Handle = hwnd
	End Function

	Static Function FromHWnd(hwnd As HWND) As Control
		FromHWnd = Nothing
		If _System_IsWindow(hwnd) Then
			FromHWnd = FromHWndCore(hwnd)
		End If
	End Function

Private
	Static Function FromHWndCore(hwnd As HWND) As Control
		Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
		If gchValue <> 0 Then
			Dim gch = System.Runtime.InteropServices.GCHandle.FromIntPtr(gchValue)
			FromHWndCore = gch.Target As Control
			Exit Function
		End If
	End Function

'--------------------------------
' ウィンドウ作成
'	Function Create(
'		parent As HWND,
'		rect As RECT,
'		name As String,
'		style As DWord,
'		exStyle = 0 As DWord,
'		menu = 0 As HMENU) As HWND

Public
	Sub Create(parent = Nothing As Control, style = 0 As DWord, exStyle = 0 As DWord, hmenu = 0 As HMENU)
		Dim cs As CREATESTRUCT
		With cs
			.dwExStyle = exStyle
			.lpszClass = (atom As ULONG_PTR) As LPCTSTR
			.lpszName = 0
			.style = style Or WS_CHILD Or WS_VISIBLE
			.x = CW_USEDEFAULT
			.y = CW_USEDEFAULT
			.cx = CW_USEDEFAULT
			.cy = CW_USEDEFAULT
			If IsNothing(parent) Then
				.hwndParent = 0
			Else
				.hwndParent = parent As HWND
				.style Or= WS_CHILD
			End If
			.hMenu = hmenu
			.hInstance = hInstance
		End With
		GetCreateStruct(cs)
		createImpl(cs, parent)
	End Sub

	Sub Create(parent As Control, style As DWord, exStyle As DWord, id As Long)
		Create(parent, style, exStyle, id As HMENU)
	End Sub
Protected
	Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)

	Sub createImpl(ByRef cs As CREATESTRUCT, parent As Control)
		Imports System.Runtime.InteropServices

		Dim gch = GCHandle.Alloc(This)
		TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)

		StartWndProc()

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

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

'--------------------------------
' ウィンドウプロシージャ
'Protected
Public
	Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		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)
				WndProc = a.LResult
				Exit Function
			End If
		End If
		WndProc = DefWndProc(msg, wp, lp)
	End Function

	Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
	End Function

Private
	Static Function makeKeysFormMsg(e As MessageArgs) As Keys
		Dim t As DWord
		t = e.WParam 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
		makeMouseEventFromMsg = New MouseArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
	End Function

	/*!
	@brief	最初にウィンドウプロシージャが呼ばれるときに実行される関数
	ここでは、主なメッセージハンドラの登録を行っている。
	@date	2008/07/11
	*/
	Sub StartWndProc()
		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, mu)
		AddMessageEvent(WM_RBUTTONDBLCLK, mu)
		AddMessageEvent(WM_MBUTTONDBLCLK, mu)
		AddMessageEvent(WM_XBUTTONDBLCLK, mu)

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

	Sub OnEraseBackground(sender As Object, e As MessageArgs)
		Dim rc = ClientRect
		FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
		e.LResult = TRUE
	End Sub

	Sub OnMouseDownBase(sender As Object, e As MessageArgs)
		OnMouseDown(makeMouseEventFromMsg(e))
	End Sub

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

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

	Sub OnMouseMoveBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		If mouseEntered Then
			OnMouseMove(me)
		Else
			mouseEntered = True
			OnMouseEnter(me)
		End If
	End Sub

	Sub OnMouseLeaveBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		OnMouseLeave(me)
		mouseEntered = False
	End Sub

	Sub OnPaintBase(sender As Object, e As MessageArgs)
		Dim ps As PAINTSTRUCT
		BeginPaint(ps)
		Try
			OnPaintDC(New PaintDCArgs(ps.hdc, ps.rcPaint))
		Finally
			EndPaint(ps)
		End Try
	End Sub

	Sub OnKeyDownBase(sender As Object, e As MessageArgs)
		OnKeyDown(New KeyArgs(makeKeysFormMsg(e)))
	End Sub

	Sub OnKeyUpBase(sender As Object, e As MessageArgs)
		OnKeyUp(New KeyArgs(makeKeysFormMsg(e)))
	End Sub

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

	Sub OnCreateBase(sender As Object, e As MessageArgs)
'		OnCreate(New CreateArgs(e.LParam As *CREATESTRUCT))
	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 マウスカーソルがクライアント領域に入っているかどうかのフラグ
	外から中に入ってきたときにMouseEnterイベントを発生させるために用意している。
	*/
	mouseEntered As Boolean
	/*!
	@brief ダブルクリックが起こったかどうかのフラグ
	Click/MouseClickイベントのために用意している。
	@date	2008/07/12
	*/
	doubleClickFired As Boolean

'--------------------------------
' 初期ウィンドウクラス
Private
	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
			Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
			TlsSetValue(tlsIndex, 0)
			If gchValue = 0 Then
				Goto *InstanceIsNotFound
			End If
			Dim gch = GCHandle.FromIntPtr(gchValue)
			rThis = gch.Target As Control
			' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき

			If AssociateHWnd(gch, hwnd) = False Then
				Goto *InstanceIsNotFound
			End If
		End If
		If msg = WM_NCDESTROY Then
			rThis.UnassociateHWnd()
		End If
		If msg = WM_DESTROY And IsNothing(rThis.finalDestroy) = False Then
			Dim f = rThis.finalDestroy
			f(rThis, Args.Empty)
'			finalDestroy(This, Args.Empty)
		End If
		WndProcFirst = rThis.WndProc(msg, wp, lp)
		Exit Function

	*InstanceIsNotFound
		OutputDebugString(Ex"ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.\r\n")
		WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
	End Function

	/*!
	@brief	Controlインスタンスとウィンドウハンドルを結び付ける。
	@param[in] 結び付けられるControlインスタンスを格納したGCHandle
	@param[in] hwnd	結び付けるウィンドウハンドル
	@date	2008/07/16
	これを実行することで、UnassociateHWndされるまでControlがGC対象にならなくなる。
	*/
	Static Function AssociateHWnd(gch As System.Runtime.InteropServices.GCHandle, hwnd As HWND) As Boolean
		Imports System.Runtime.InteropServices
		Dim rThis = gch.Target As Control
		If IsNothing(rThis) Then
			Exit Function
		End If
		rThis.hwnd = hwnd
		rThis.Prop[PropertyInstance] = GCHandle.ToIntPtr(gch) As HANDLE
	End Function

	/*!
	@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()
	End Sub

	Sub UnassociateHWnd()
		Imports System.Runtime.InteropServices
		Dim gchValue = Prop(PropertyInstance) As ULONG_PTR
		If gchValue <> 0 Then
			GCHandle.FromIntPtr(gchValue).Free()
		End If
	End Sub

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

'--------------------------------
'	その他の補助関数
Private
'	Sub tracMouseEvent()
/*		If pTrackMouseEvent <> 0 Then
			Dim tme As TRACKMOUSEEVENT
			With tme
				.cbSize = Len(tme)
				.dwFlags = TME_HOVER Or TME_LEAVE
				.hwndTrack = wnd
				.dwHoverTime = HOVER_DEFAULT
			End With
			pTrackMouseEvent(tme)
		End If
*/	'End Sub

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

	Static hInstance As HINSTANCE
	Static atom As ATOM
	Static hmodComctl As HMODULE
'	Static pTrackMouseEvent As PTrackMouseEvent

	Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
	Static Const PropertyInstance = 0 As ATOM
Public
	Static Sub Initialize(hinst As HINSTANCE)
		tlsIndex = TlsAlloc()
		hInstance = hinst
'		hmodComctl = LoadLibrary("comctl32.dll")
'		pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent"))

		Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
		PropertyInstance = GlobalAddAtom(ToTCStr(PropertyInstanceString))

		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 = 0
			.lpszMenuName = 0
			.lpszClassName = ToTCStr(WindowClassName)
			.hIconSm = 0
		End With
		atom = RegisterClassEx(wcx)
		If atom = 0 Then
			Dim buf[1023] As TCHAR
			wsprintf(buf, Ex"ActiveBasic.Windows.UI.Control.Control: RegisterClasseEx failed. Error code: &h%08X\r\n", GetLastError())
			OutputDebugString(buf)
			Debug
			ExitThread(0)
		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

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